Hallo, da ich heute eine E-Mail bekommen habe stelle ich mal hier meine uralt Funktion für die Berechnung ein. Man kann dort noch einige Dinge optimieren:

Function DAT855_CalcPos(Telegramm As String, GPSLat As Single, GPSLng As Single) As Boolean
Dim Zeichen As String
Dim i As Integer
Dim Dezimal As Long

1 If bolFehlerbehandlung Then
2 On Error GoTo DAT855_CalcPos_Error
3 End If

'Überprüfen ob das Telegramm 8 Zeichen lang ist
4 If Len(Trim(Telegramm)) <> 8 Then Exit Function

'Auf Hex-String überprüfen
5 For i = 1 To Len(Telegramm)
6 Zeichen = UCase(Mid(Telegramm, i, 1))

7 If Zeichen <> "0" And Zeichen <> "1" And Zeichen <> "2" And Zeichen <> "3" And Zeichen <> "4" And Zeichen <> "5" And Zeichen <> "6" And Zeichen <> "7" And Zeichen <> "8" And Zeichen <> "9" And Zeichen <> "A" And Zeichen <> "B" And Zeichen <> "C" And Zeichen <> "D" And Zeichen <> "E" And Zeichen <> "F" Then
8 Exit Function
9 End If
10 Next i

Dim BinTmp, BinGes, BinLänge, BinBreite, BinID
Dim DecLänge As Double, DecBreite As Double
Dim OffsetLänge As Double, OffsetBreite As Double
Dim OffsetLänge1 As Double, OffsetBreite1 As Double, OffsetLänge2 As Double, OffsetBreite2 As Double

11 OffsetLänge1 = MySQL_Setting("dat855_offset_lng1", "0")
12 OffsetLänge2 = MySQL_Setting("dat855_offset_lng2", "0")
13 OffsetBreite1 = MySQL_Setting("dat855_offset_lat1", "0")
14 OffsetBreite2 = MySQL_Setting("dat855_offset_lat2", "0")


15 For i = 1 To Len(Telegramm)
16 Zeichen = Mid(Telegramm, i, 1)
17 Dezimal = CLng("&H" & Zeichen)
18 BinTmp = "0000" & Dec2Bin(Dezimal)
19 BinTmp = Right(BinTmp, 4)
20 BinGes = BinGes & BinTmp
21 Next i

22 BinLänge = Left(BinGes, 15)
23 BinBreite = Mid(BinGes, 16, 15)
24 BinID = Right(BinGes, 2)

25 If BinID = "11" Then
'Längengrad berechnen
26 DecLänge = Bin2Dec(BinLänge) * 128

27 If DecLänge < 16384 Then
28 OffsetLänge = OffsetLänge1 * 4194304
29 Else
30 OffsetLänge = OffsetLänge2 * 4194304
31 End If

32 GPSLng = (OffsetLänge + DecLänge) / 1000000

'Breitengrad berechnen
33 DecBreite = Bin2Dec(BinBreite) * 64

34 If DecBreite < 16384 Then
35 OffsetBreite = OffsetBreite1 * 2097152
36 Else
37 OffsetBreite = OffsetBreite2 * 2097152
38 End If
39 GPSLat = (OffsetBreite + DecBreite) / 1000000

40 DAT855_CalcPos = True
41 Else
42 DAT855_CalcPos = False
43 End If

44 On Error GoTo 0
45 Exit Function
DAT855_CalcPos_Error:
46 AddDebug "Fehler beim Berechnen der DAT855 GPS Position!" & Err.Description
End Function