VBA Tipp: Distanz zwischen zwei Koordinaten berechnen

Aus DBWiki
Wechseln zu: Navigation, Suche

Aufgabenstellung

Ich möchte die Distanz zwischen 2 Koordinaten berechnen.

Lösung

Die folgende Funktion ermittelt die Distanz:

Public Function CalcDistance(dLonA As Single, dLatA As Single, _
                             dLonB As Single, dLatB As Single) _
                As Single
'Rückgabe: Distanz in Kilometern zwischen zwei Koordinaten-Paaren.
 
'Parameter: dLonA, dLatA - Longitude & Latitude of Location A in Grad _
            dLonB, dLatB - Longitude & Latitude of Location B in Grad
 
    Const PI = 3.14159265358979     'PI=4*Atn(1)    (wird nicht benutzt)
    Const PI2 = 1.5707963267949     'PI/2
    Const RAD = 0.01745329251994    'rad=pi/180 Bogenmaß
    Const DEG = 57.2957795130824    'deg=180/pi     (wird nicht benutzt)
 
 
    Dim dDist As Double
 
    Dim dLonARad As Single, dLatARad As Single, _
        dLonBRad As Single, dLatBRad As Single
 
 
    'Umrechnen der Gradzahlen ins Bogenmaß
    dLonARad = dLonA * RAD
    dLatARad = dLatA * RAD
    dLonBRad = dLonB * RAD
    dLatBRad = dLatB * RAD
 
    'Distanz auf Einheitskreis
    dDist = Sin(dLatARad) * Sin(dLatBRad) + _
            Cos(Abs(dLonARad - dLonBRad)) * Cos(dLatARad) * Cos(dLatBRad)
 
''originale Bedingung:
'        If (dDist = 1) Or ((-dDist * dDist) < -1) Then
'            dDist = 0
''abgewandelt wegen Rundungsproblematik zu
'    If (dDist * dDist) >= 1 Then
'        dDist = 0 _
'    ElseIf -(Log(Abs(dDist - 1)) / Log(10)) > 12 Then
'        dDist = 0
''d.h. wir betrachten nur bis zur 12 Dezimalstelle
 
    If (dDist * dDist) >= 1 Then
        dDist = 0
    ElseIf -(Log(Abs(dDist - 1)) / Log(10)) > 12 Then
        dDist = 0
    Else
        'Streckung auf Erdkugel mit 6378.388: Erdradius
        dDist = (Atn(-dDist / Sqr(-dDist * dDist + 1)) + PI2) * 6378.388
    End If
 
    CalcDistance = dDist
 
End Function

Aufruf

Debug.Print CalcDistance(8.68194, 50.11222, 13.2975, 52.2222)

Siehe auch