Positions Berechnung mit VB6

Hi,

also es ist mal wieder zum Haare raufen :-)

Ich muss den AscCos ausrechen und ich komm nicht auf das Ergebniss
wie mit den Taschenrechner das allerdings richtig ist!

Arkuskosinus(x) = Atn(-x / Sqr(-x * x + 1)) + 2 * Atn(1)

wäre die Funktion für den AscCos (Invert Cosinus oder Cos-1)

füge ich nun an der Stelle X meine Bsp.-Wert ein 0.4614 kommt immer
1,091223762 raus und nicht die 65.34 ° was rauskommen sollen.

Was mach ich den Bitte falsch :-)

Danke für eure Hilfe.

By Ulli

Hi Ulli,

ich zitiere mal aus dem BasCom - Handbuch :

ACos
Action

Returns the arccosine of a single in radians.

Zitat Ende

Die Winkelfunktionen werden im BasCom in Radiant berechnet.

Gruß Klaus

Vllt noch zur Orientierung: "radiant" heißt im Deutschen "Bogenmaß".
Umrechnen kann man das ganze wie folgt:
Von Bogenmaß nach Grad: Wert mit 57.296 multiplizieren (Genau: 180/Pi)
Von Grad nach Bogenmaß: Wert mit 0.01745 multiplizieren (Genau: Pi/180)

Gruß, Trabukh

Hi,

ja habe es nun so gemacht.

Point1_Lati = (Text1.Text + (Text2.Text / 60) + (Text3.Text / 3600))
Point1_Longi = -(Text4.Text + (Text5.Text / 60) + (Text6.Text / 3600))

Point2_Lati = (Text7.Text + (Text8.Text / 60) + (Text9.Text / 3600))
Point2_Longi = -(Text10.Text + (Text11.Text / 60) + (Text12.Text / 3600))

L1 = Point1_Lati
L2 = Point1_Longi
G1 = Point2_Lati
G2 = Point2_Longi

Text15.Text = L1
Text16.Text = L2
Text17.Text = G1
Text18.Text = G2


D1 = Sin(L1) * Sin(G1) + Cos(L1) * Cos(G1) * Cos(L2 - G1)
Text19.Text = D1
Text20.Text = Cos(L2 - G1)
D2 = Format(Cos(D1) * 180 / Pi, "0.000")
Text13.Text = D2 * 60 'Entfernung
Text14.Text = D2 'Winkel zum Ziel

Warumn bekomme ich andere Ergebisse als wie mit meinen Taschenrechner?

---> φ1 = 41° 09' 28,0" N = 41,1578°, λ1 = 008° 38' W = -8,6333°
---> φ2 = 0° 40' 19,9" N = 0,6722°, λ2 = 061° 32' W = -61,5333°

->cos c = sin φ1 · sin φ2 + cos φ1 · cos φ2 · cos (λ1 - λ2)

---> 0,4618 = c = 62,5° = 3749' = 3749 sm

So ich komm mit den obigen Programm nicht drauf???

Was mach ich den falsch??

Danke Leute

Zitat:

---

D2 = Format(Cos(D1) * 180 / Pi, "0.000")

---

Hier wurden die Klammern vergessen!
D2 = Format(Cos(D1) * (180 / Pi), "0.000")

Gruß, Trabukh

Hi,

kommt auch mit der Klammer das falsche raus *grrrr*

I komm net weiter :-(

Will Geographische Daten Grad'Minuten'Secunden Start -->Ziehl ausrechnen Winkel und Entfernung mit VB aber irgendwie wills net :-)

Evtl. noch jemand ne Lösung?

by Ulli

Hi,

so ich habs :-) :-) :-)

VB kann des nicht auf den direkten weg und somit hab ich mich mal auf die Suche nach Funktionen gemacht!

Bin auch fündig geworden und man mus es zuvor auf Deg2 umrechen!

Sieht nun wie folgt aus.

Code:

---

Option Explicit

Dim Lat1
Dim Lon1
Dim Lat2
Dim Lon2
Dim L1
Dim L2
Dim G1
Dim G2


Const pi = 3.14159265358979


Function acos(rad)
  If Abs(rad) <> 1 Then
    acos = pi / 2 - Atn(rad / Sqr(1 - rad * rad))
  ElseIf rad = -1 Then
    acos = pi
  End If
End Function



Function deg2rad(Deg)
    deg2rad = CDbl(Deg * pi / 180)
End Function


Function rad2deg(rad)
    rad2deg = CDbl(rad * 180 / pi)
End Function

Private Sub Command1_Click()

Lat1 = (Text1.Text + (Text2.Text / 60) + (Text3.Text / 3600))
Lon1 = -(Text4.Text + (Text5.Text / 60) + (Text6.Text / 3600))

Lat2 = (Text7.Text + (Text8.Text / 60) + (Text9.Text / 3600))
Lon2 = -(Text10.Text + (Text11.Text / 60) + (Text12.Text / 3600))

L1 = Lat1
L2 = Lon1
G1 = Lat2
G2 = Lon2

Text15.Text = L1
Text16.Text = L2
Text17.Text = G1
Text18.Text = G2

Dim theta, dist, distance, Deg

  theta = Lon1 - Lon2
  dist = Sin(deg2rad(Lat1)) * Sin(deg2rad(Lat2)) + Cos(deg2rad(Lat1)) * Cos(deg2rad(Lat2)) * Cos(deg2rad(theta))
  dist = acos(dist)
  dist = rad2deg(dist)
  distance = Format(dist * 60, "0.000")
  Deg = Format(dist, "0.000")
   
Text14.Text = Deg
Text13.Text = distance



End Sub

---

So gehts nun, also damit kann man leben :-)

Und ab jetzt wird es erst Interessant!

Es kommen GPS Daten hinzu und Log Daten

Und zur Fehlerkorrektur kommt noch ein Privates DGPS dazu :-)

Wird also noch a bissl Arbeit

by Ulli

Tipps immer gerne willkommen!

Hmm, komisch. Ich habe neulich eine Billiardsimulation mit VB gemacht, da ging das mit den Winkeln prima... komisch... ???
Aber schön, dass es jetzt doch endlich geklappt hat! :-)

Gruß, Trabukh

EDIT: Ich weiß jetzt, warum es bei dir nicht ging, die Grad-Variable MUSS als Double deklariert werden!!!

Hi,

hatte ich zuvor auch als Double :-)

By Ulli

Naja, ansonsten fehlt bei deinem ersten Code nur noch die Konstante PI! :-) Und die Werte L1, L2, G1 und G2 müssen auch vor den trigonometrischen Funktion umgerechnet werden. Aber das ist ja jetzt auch egal, Hauptsache, es funktioniert... :-)

Gruß, Trabukh

sorry, wenn ich den alten beitrag nochmal hochhole...

ich benutze folgendes modul um die gps-daten (512X.2722=51° 2X.2722min x 121X.0787=12° 1X.0787min) in grad umzuwandeln (51,33787° x 12,234645°)

Code:

---

' quelle: http://www.planet-source-code.com/vb...63143&lngWId=1

Option Explicit
Option Base 1

'The RMC-Datasentence (RMC=recommended minimum sentence C)
'is a recommendation for the minimum, that a GPS-Receiver should give back.
'It looks like this: "$GPRMC,191410,A,4735.5634,N,00739.3538,E,0.0,0.0,181102,0.4,E,A*19"
Public Sub decodeRMC(ByVal inp As String, _
            Optional ByRef UtcTime As String, _
            Optional ByRef ReceiverWarning As Boolean, _
            Optional ByRef Latitude As Double, _
            Optional ByRef LatitudeDir As String, _
            Optional ByRef Longitude As Double, _
            Optional ByRef LongitudeDir As String, _
            Optional ByRef SpeedKMH As Double, _
            Optional ByRef Course As Double, _
            Optional ByRef DateStamp As String, _
            Optional ByRef MagneticDeclination As Double, _
            Optional ByRef Checksum As Boolean)
    On Error Resume Next
    inp = UCase(Trim(inp))
    'Checking initstring. Must be the same for all RMC sentences.
    If Left(inp, 1) <> "$" Or Mid(inp, 4, 3) <> "RMC" Then Checksum = False: Exit Sub
    'Extracting that part of the sentence that is needed to calculate the checksum
    Dim ChkDat As String
    ChkDat = Mid(inp, 2, InStr(2, inp, "*") - 2)
    'For compatibility with split function
    inp = Replace(inp, ",,", ", ,")
    'Splitting sentence
    Dim Dat As Variant
    Dat = Split(inp, ",")
    'Calculating checksum and comparing it
    Dim ChkSum As String
    ChkSum = Dat(UBound(Dat))
    ChkSum = Right(ChkSum, Len(ChkSum) - InStr(1, ChkSum, "*"))
    If calcChecksum(ChkDat) = Hex2Dec(ChkSum) Then Checksum = True Else Checksum = False: Exit Sub
    'UtcTime
    UtcTime = Left(Dat(2), 6)
    If UtcTime <> " " Then UtcTime = Left(UtcTime, 2) & ":" & Mid(UtcTime, 3, 2) & ":" & Right(UtcTime, 2) Else UtcTime = ""
    'ReceiverWarning
    If Dat(3) = "A" Or Dat(3) = "" Then ReceiverWarning = False Else ReceiverWarning = True
    'Length
    Dim sp As Integer
    sp = InStr(1, Dat(4), ".")
    Latitude = CDbl(Left(Dat(4), sp - 3)) + CDbl(CDbl(Replace(Mid(Dat(4), sp - 2), ".", ",")) / 60)
    Latitude = Round(Latitude, 8)
    'LengthDir
    LatitudeDir = Dat(5)
    'Width
    sp = InStr(1, Dat(6), ".")
    Longitude = CDbl(Left(Dat(6), sp - 3)) + CDbl(CDbl(Replace(Mid(Dat(6), sp - 2), ".", ",")) / 60)
    Longitude = Round(Longitude, 8)
    'WidthDir
    LongitudeDir = Dat(7)
    'SpeedKMH (needs to be converted from knots)
    SpeedKMH = Replace(CStr((Dat(8) * 0.54)), ".", ",")
    'Course without movement
    Course = Replace(CStr(Dat(9)), ".", ",")
    'DateStamp
    DateStamp = Left(Dat(10), 6)
    If DateStamp <> " " Then DateStamp = Left(DateStamp, 2) & "." & Mid(DateStamp, 3, 2) & "." & Mid(DateStamp, 5) Else DateStamp = ""
    'MagneticDeclination
    MagneticDeclination = Replace(CStr(Dat(11)), ".", ",")
End Sub

'The GGA-Datasentence contains the most important information about GPS-position and accuracy.
'it looks like: "$GPGGA,191410,4735.5634,N,00739.3538,E,1,04,4.4,351.5,M,48.0,M,,*45"
Public Sub decodeGGA(ByVal inp As String, _
            Optional ByRef UtcTime As String, _
            Optional ByRef Latitude As Double, _
            Optional ByRef LatitudeDir As String, _
            Optional ByRef Longitude As Double, _
            Optional ByRef LongitudeDir As String, _
            Optional ByRef Quality As String, _
            Optional ByRef SatellitesIV As Integer, _
            Optional ByRef HDOP As Double, _
            Optional ByRef AltitudeSea As Double, _
            Optional ByRef AltitudeSeaUnit As String, _
            Optional ByRef AltitudeEllipsoid As Double, _
            Optional ByRef AltitudeEllipsoidUnit As String, _
            Optional ByRef Checksum As Boolean)
    On Error Resume Next
    inp = UCase(Trim(inp))
    'Checking initstring. Must be the same for all GGA sentences.
    If Left(inp, 1) <> "$" Or Mid(inp, 4, 3) <> "GGA" Then Checksum = False: Exit Sub
    'Extracting that part of the sentence that is needed to calculate the checksum
    Dim ChkDat As String
    ChkDat = Mid(inp, 2, InStr(2, inp, "*") - 2)
    'For compatibility with split function
    inp = Replace(inp, ",,", ", ,")
    'Splitting sentence
    Dim Dat As Variant
    Dat = Split(inp, ",")
    'Calculating checksum and comparing it
    Dim ChkSum As String
    ChkSum = Dat(UBound(Dat))
    ChkSum = Right(ChkSum, Len(ChkSum) - InStr(1, ChkSum, "*"))
    If calcChecksum(ChkDat) = Hex2Dec(ChkSum) Then Checksum = True Else Checksum = False: Exit Sub
    'UtcTime
    UtcTime = Left(Dat(2), 6)
    If UtcTime <> " " Then UtcTime = Left(UtcTime, 2) & ":" & Mid(UtcTime, 3, 2) & ":" & Right(UtcTime, 2) Else UtcTime = ""
    'Length
    Dim sp As Integer
    sp = InStr(1, Dat(3), ".")
    Latitude = CDbl(Left(Dat(3), sp - 3)) + CDbl(CDbl(Replace(Mid(Dat(3), sp - 2), ".", ",")) / 60)
    Latitude = Round(Latitude, 8)
    'LengthDir
    LatitudeDir = Dat(4)
    'Width
    sp = InStr(1, Dat(5), ".")
    Longitude = CDbl(Left(Dat(5), sp - 3)) + CDbl(CDbl(Replace(Mid(Dat(5), sp - 2), ".", ",")) / 60)
    Longitude = Round(Longitude, 8)
    'WidthDir
    LongitudeDir = Dat(6)
    'Quality: 0-invalid, 1-gps, 2-dgps, 6-guessed
    Quality = "unknown"
    If Dat(7) = 0 Then Quality = "no fix"
    If Dat(7) = 1 Then Quality = "GPS fix"
    If Dat(7) = 2 Then Quality = "DGPS fix"
    If Dat(7) = 6 Then Quality = "guessed"
    'Satellites in view
    SatellitesIV = Dat(8)
    'HDOP: horizontal dilution of precision (accuracy)
    HDOP = Replace(CStr(Dat(9)), ".", ",")
    'Altitude over sea
    AltitudeSea = Replace(CStr(Dat(10)), ".", ",")
    'Altitude over sea unit
    AltitudeSeaUnit = Dat(11)
    'Altitude over ellipsoid
    AltitudeEllipsoid = Replace(CStr(Dat(12)), ".", ",")
    'Altitude over ellipsoid unit
    AltitudeEllipsoidUnit = Dat(13)
End Sub

'The GSA-Datasentence contains information about the PRN-Numbers of the satellites that are used
'for calculating the actual position and some more detailed info about the accuracy.
'it looks like: "$GPGSA,A,3,,,,15,17,18,23,,,,,,4.7,4.4,1.5*3F"
Public Sub decodeGSA(ByVal inp As String, _
            Optional ByRef AutoSel As Boolean, _
            Optional ByRef mode As String, _
            Optional ByRef prn As Variant, _
            Optional ByRef PDOP As Double, _
            Optional ByRef HDOP As Double, _
            Optional ByRef VDOP As Double, _
            Optional ByRef Checksum As Boolean)
    On Error Resume Next
    inp = UCase(Trim(inp))
    'Checking initstring. Must be the same for all GSA sentences.
    If Left(inp, 1) <> "$" Or Mid(inp, 4, 3) <> "GSA" Then Checksum = False: Exit Sub
    'Extracting that part of the sentence that is needed to calculate the checksum
    Dim ChkDat As String
    ChkDat = Mid(inp, 2, InStr(2, inp, "*") - 2)
    'For compatibility with split function
    inp = Replace(inp, ",,", ", ,")
    'Splitting sentence
    Dim Dat As Variant
    Dat = Split(inp, ",")
    'Calculating checksum and comparing it
    Dim ChkSum As String
    ChkSum = Dat(UBound(Dat))
    ChkSum = Right(ChkSum, Len(ChkSum) - InStr(1, ChkSum, "*"))
    If calcChecksum(ChkDat) = Hex2Dec(ChkSum) Then Checksum = True Else Checksum = False: Exit Sub
    'Auto Selection Mode
    If Dat(2) = "A" Then AutoSel = True Else AutoSel = False
    'Mode
    mode = "unknown"
    If Dat(3) = "3" Then mode = "3D-Fix"
    If Dat(3) = "2" Then mode = "2D-Fix"
    If Dat(3) = "1" Then mode = "No-Fix"
    'PRN-Numbers
    ReDim prn(12)
    Dim i As Integer
    For i = 4 To 15
        If IsNumeric(Dat(i)) Then prn(i - 3) = CInt(Dat(i)) Else prn(i - 3) = ""
    Next
    'PDOP in meters
    PDOP = Replace(CStr(Dat(16)), ".", ",")
    'HDOP horizontal dilution of precision in meters
    HDOP = Replace(CStr(Dat(17)), ".", ",")
    'VDOP vertical dilution of precision in meters
    VDOP = Replace(Left(CStr(Dat(18)), InStr(1, Dat(18), "*") - 1), ".", ",")
End Sub

'              sn ed azi dB ------------ ------------ ------------
'$GPGSV,3,1,12,22,89,000,00,14,59,000,00,15,53,000,00,18,51,000,00*7F
'              ------------ ------------ ---------- ----------
'$GPGSV,3,2,12,09,47,000,00,19,15,000,00,21,13,000,,31,13,000,*7C
'              ------------ ---------- ------------ ------------
'$GPGSV,3,3,12,03,06,000,00,11,04,000,,28,02,000,00,05,01,000,00*77

'$GPGSV,3,1,12,22,89,000,00,14,59,000,00,15,53,000,00,18,51,000,00*7F
'$GPGSV,3,2,12,09,47,000,00,19,15,000,00,21,13,000,,31,13,000,*7C
'$GPGSV,3,3,12,03,06,000,00,11,04,000,,28,02,000,00,05,01,000,00*77
'GSV - Satellites in view
'        1 2 3 4 5 6 7    n
'        | | | | | | |    |
' $--GSV,x,x,x,x,x,x,x,...*hh<CR><LF>
'  1) total number of messages
'  2) message number
'  3) satellites in view
'  4) satellite number
'  5) elevation in degrees
'  6) azimuth in degrees to true
'  7) SNR in dB
'  more satellite infos like 4)-7)
'  n) checksum
 
Public Sub decodeGSV(ByVal inp As String, _
            Optional ByRef tnm As Integer, _
            Optional ByRef mn As Integer, _
            Optional ByRef SatsInView As Integer, _
            Optional ByRef SatNr As Variant, _
            Optional ByRef Elevation As Variant, _
            Optional ByRef Azimuth As Variant, _
            Optional ByRef SNRdB As Variant, _
            Optional ByRef Checksum As Boolean)
    On Error Resume Next
    inp = UCase(Trim(inp))
    'Checking initstring. Must be the same for all GSV sentences.
    If Left(inp, 1) <> "$" Or Mid(inp, 4, 3) <> "GSV" Then Checksum = False: Exit Sub
    'Extracting that part of the sentence that is needed to calculate the checksum
    Dim ChkDat As String
    ChkDat = Mid(inp, 2, InStr(2, inp, "*") - 2)
    ChkDat = ChkDat
    'For compatibility with split function
    inp = Replace(inp, ",,", ", ,")
    'Splitting sentence
    Dim Dat As Variant
    Dat = Split(inp, ",")
    'Cutting what we won't need
    inp = Right(inp, Len(inp) - 7)
    inp = Left(inp, InStr(1, inp, "*") - 1)
    'Calculating checksum and comparing it
    Dim ChkSum As String
    ChkSum = Dat(UBound(Dat))
    ChkSum = Right(ChkSum, Len(ChkSum) - InStr(1, ChkSum, "*"))
    Dim ccs As Integer, dcs As Long
    ccs = calcChecksum(ChkDat)
    dcs = Hex2Dec(ChkSum)
    If ccs = dcs Then Checksum = True Else Checksum = False: Exit Sub
    'total number of messages
    tnm = CInt(Dat(1))
    'message number
    mn = CInt(Dat(2))
    'Satellites in View
    SatsInView = Dat(3)
    Dim i As Integer
    Dim sp As Integer
    'Satellite-Numbers
    ReDim SatNr(4)
    For i = 1 To 4
        sp = InStr(1, Dat(3 + i), "*")
        If sp > 0 Then Dat(3 + i) = Left(Dat(3 + i), sp - 1)
        SatNr(i) = Dat(3 + i)
    Next
    'Elevations
    ReDim Elevation(4)
    For i = 1 To 4
        sp = InStr(1, Dat(7 + i), "*")
        If sp > 0 Then Dat(7 + i) = Left(Dat(7 + i), sp - 1)
        Elevation(i) = Dat(7 + i)
    Next
    'Azimuth's
    ReDim Azimuth(4)
    For i = 1 To 4
        sp = InStr(1, Dat(11 + i), "*")
        If sp > 0 Then Dat(11 + i) = Left(Dat(11 + i), sp - 1)
        Azimuth(i) = Dat(11 + i)
    Next
    'SNRdB's
    ReDim SNRdB(4)
    For i = 1 To 4
        sp = InStr(1, Dat(15 + i), "*")
        If sp > 0 Then Dat(15 + i) = Left(Dat(15 + i), sp - 1)
        SNRdB(i) = Dat(15 + i)
    Next
End Sub
 
 
 
'Helper functions:
'=================

Function calcChecksum(inp As String) As Integer
    Dim i As Integer, s As Integer
    s = 0
    For i = 1 To Len(inp)
        s = s Xor Asc(Mid(inp, i, 1))
    Next
    calcChecksum = s
End Function

Function Hex2Dec(HexNum As Variant) As Long
    Hex2Dec = "&h" & HexNum
End Function


'Compatibility functions:
'========================

Function Split(sIn As String, sDel As String) As Variant
    Dim i As Integer, x As Integer, s As Integer, t As Integer
    i = 1: s = 1: t = 1: x = 1
    ReDim tArr(1 To x) As Variant
    If InStr(1, sIn, sDel) <> 0 Then
        Do
            ReDim Preserve tArr(1 To x) As Variant
            tArr(i) = Mid(sIn, t, InStr(s, sIn, sDel) - t)
            t = InStr(s, sIn, sDel) + Len(sDel)
            s = t
            If tArr(i) <> "" Then i = i + 1
            x = x + 1
        Loop Until InStr(s, sIn, sDel) = 0
        ReDim Preserve tArr(1 To x) As Variant
        tArr(i) = Mid(sIn, t, Len(sIn) - t + 1)
    Else
        tArr(1) = sIn
    End If
    Split = tArr
End Function

Function Round(ByVal Value As Variant, Optional ByVal digits As Integer = 0) As Variant
  Dim i As Long
  Dim Pot10(-28 To 28) As Variant
  If i = 0 Then
    For i = LBound(Pot10) To UBound(Pot10)
      Pot10(i) = CDec(10 ^ i)
    Next i
  End If
  On Error Resume Next
    If Value > 0 Then
      Round = Int(Value * Pot10(digits) + 0.5) * Pot10(-digits)
    Else
      Round = -Int(-Value * Pot10(digits) + 0.5) * Pot10(-digits)
    End If
    If Err.Number Then Round = Value
  On Error GoTo 0
End Function

Function Replace(strString As String, Find As String, strReplace As String) As String
    Dim ss As Long
    ss = InStr(1, strString, Find)
    If ss > 0 Then
        strString = Left(strString, ss - 1) & strReplace & Right(strString, Len(strString) - (ss + (Len(Find) - 1)))
        Replace = Replace(strString, Find, strReplace)
    Else
        Replace = strString
    End If
End Function

---

wenn ich nun L1, L2, G1, G2 durch die errechneten koordinaten ersetze, dann müßte ich doch ebenfalls die entfernung ermittelt bekommen, kann das einer bestätigen? oder gibt es vielleicht andere gps-projekte die sich näher mit der entfernungsberechnung beschäftigen? hat vielleicht schon einer ein fertiges beispielprojekt, da ich mir nicht sicher bin ob ich mit der oben genannten methode ein korrektes ergebniss erhalte oder ob da irgendwo doch ein fehler drin ist.

vielleicht kann einer weiterhelfen.
mfg.

ok, ich komme immer auf falsche ergebnisse, im deut. raum muß man wohl folgende konstante benutzen: distance = dist * 111.12 '<- den wert hab ich aus einer exel-koordinaten-umrechnungstabelle

weiß vielleicht einer warum gerade "111.12"? woraus/wie errechnet sich dieser wert bzw. woher kommen die "60" aus dem obigen code?

mfg.

Hallo

> weiß vielleicht einer warum gerade "111.12"? woraus/wie errechnet sich dieser wert bzw. woher kommen die "60" aus dem obigen code?


Der Wert kommt mir irgendwie bekannt vor. Der Abstand zwischen zwei Breitengraden beträgt 111Km ( oder vielleicht auch: 111.12 Km ?).
Das kann doch kein Zufall sein?

Klaus

Hallo,
ich habe den Code von SOMMER am PDA unter Verwendung von "eVB" ausprobiert. Zum Testen wurden allerdings nur fixe Eingangsdaten verwendet.
Wenn man den Entfernungsparameter "dist" mit 1.852 multipliziert, erhält man Entfernungsangaben in Km. Von einem Breitengrad zum nächsten ergibt das exakt 111.12KM. Der Abstand zwischen zwei Längengraden variiert dagegen in Abhängigkeit vom Breitengrad. Im mittleren Teil von Deutschland sind es etwa 70Km. Soweit scheint der Code also zu funktionieren. Nicht klargekommen bin ich dagegen mit der verwendeten Richtungsberechnung. Deshalb habe ich hierfür stattdessen eine vorhandene Routine eingebaut. Sie ist auch im beigefügten Code zu finden.

Klaus

Code:

---

Option Explicit

Dim Lat1
Dim Lon1
Dim Lat2
Dim Lon2
Dim L1
Dim L2
Dim G1
Dim G2

Const pi = 3.14159265358979
Const radian = 0.017453292  'pi/180

Private Sub Command2_Click()

'Lat1 = (Text1.Text + (Text2.Text / 60) + (Text3.Text / 3600))
'Lon1 = -(Text4.Text + (Text5.Text / 60) + (Text6.Text / 3600))

'Lat2 = (Text7.Text + (Text8.Text / 60) + (Text9.Text / 3600))
'Lon2 = -(Text10.Text + (Text11.Text / 60) + (Text12.Text / 3600))

Lat1 = 50.96
Lon1 = 8.2
Lat2 = 49.96
Lon2 = 8.2

L1 = Lat1
L2 = Lon1
G1 = Lat2
G2 = Lon2

Text1.Text = L1
Text2.Text = L2
Text3.Text = G1
Text4.Text = G2

'Distanzberechnung
Dim theta, dist, Deg

theta = Lon1 - Lon2
dist = Sin(deg2rad(Lat1)) * Sin(deg2rad(Lat2)) + Cos(deg2rad(Lat1)) * Cos(deg2rad(Lat2)) * Cos(deg2rad(theta))
dist = acos(dist)
dist = rad2deg(dist)
Text5.Text = (Int(dist * 6000 + 0.5) / 100) * 1.852
 
'Richtungsbrechnung
Dim ga, zw, bear

If dist > 0 Then

Lon1 = Lon1 * radian
Lat1 = Lat1 * radian
Lon2 = Lon2 * radian
Lat2 = Lat2 * radian

ga = Lon1 - Lon2
zw = Cos(Lat1) * Cos(Lon1 - Lon2) * Cos(Lat2) + Sin(Lat1) * Sin(Lat2)
zw = Atn(zw / Sqr(1 - zw * zw))
zw = pi / 2 - zw

bear = ((Sin(Lat2) - Sin(Lat1) * Cos(zw)) / (Cos(Lat1) * Sin(zw)))
bear = Atn(bear / Sqr(1 - bear * bear))
bear = (pi / 2 - bear) / radian

    If Sin(ga) >= 0 Then
        bear = 360 - bear
    End If
End If

bear = Int(bear * 10 + 0.5) / 10
If bear = 0 Then bear = 360
Text6.Text = bear

End Sub

Function acos(rad)
  If Abs(rad) <> 1 Then
    acos = pi / 2 - Atn(rad / Sqr(1 - rad * rad))
  ElseIf rad = -1 Then
    acos = pi
  End If
End Function

Function deg2rad(Deg)
    deg2rad = CDbl(Deg * pi / 180)
End Function

Function rad2deg(rad)
    rad2deg = CDbl(rad * 180 / pi)
End Function

Private Sub Form_OKClick()
    App.End
End Sub

---

Zitat:

---

Zitat von gpsklaus

...Wenn man den Entfernungsparameter "dist" mit 1.852 multipliziert, erhält man Entfernungsangaben in Km...

---

:-k Wer wissen möchte warum das so ist: http://de.wikipedia.org/wiki/Nautische_Meile