Menü :

• Access
• Grundlagen
• SQL-Server
• TabToWeb

Access

• » Entfernungen
• Feiertage
• Kombifeld
• Reguläre Ausdrücke
• Seek
• Hitliste
• Links

Access - 'Entfernungen'

Mit den unten aufgeführten Funktionen kann man anhand von Längen- und Breitengraden den Abstand zwischen 2 Orten berechnen (Annahme: Die Erde sei eine Kugel). Bisher getestet wurde das ganze nur mit Orten in Deutschland. Außerdem gibt es hier noch andere Funktionen wie Arcus-Sinus, Peilwinkel zwischen den Orten etc.

Wem das Kopieren zu mühselig ist, der kann durch Klick auf den folgenden Link eine Demo-Datenbank downloaden: (960 kByte) . Darin enthalten sind die hier erläuterten Funktionen, sowie eine Tabelle mit über 14000 Orten in Deutschland. Den Orten sind ihre Postleitzahl, die Ortsgröße, die Längen- und Breitengrade sowie das Bundesland zugeordnet.

Am besten folgende Codeabschnitte markieren und in ein globales Modul kopieren:

Option Compare Database
Option Explicit
'Zunächst benötigt man einige globale Konstanten bzw. Variablen:
Public Const conErdradius = 6378.388
Public Const conMile = 1.609341
Public ErrArccos As Boolean
 
 
 
Public Function KoordToDouble(Koord) As Double
 
Dim IntGrad As Integer, IntMinuten As Integer
Dim IntSekunden As Integer, GradWo As Integer
 
GradWo = InStr(1, Koord, "°")
IntGrad = Left(Koord, GradWo - 1)
IntMinuten = Mid(Koord, GradWo + 1, 2)
IntSekunden = Mid(Koord, GradWo + 4, 2)
 
KoordToDouble = IntGrad + (IntMinuten / 60) + (IntSekunden / 3600)
 
End Function
 
 
 
Public Function PI()
 
PI = Atn(1) * 4
 
End Function
 
 
 
Public Function DoubleToRad(x) As Double
'Umrechnung der dezimalen Koordinaten in Bogenmaß:
DoubleToRad = x / 180 * PI()
 
End Function
 
 
 
Public Function arccos(x)
'Definition der Arcus-Cosinus-Funktion:
On Error GoTo ErrArccos:
 
ErrArccos = False
 
arccos = Atn(-x / Sqr(-x * x + 1)) + PI() / 2
 
ExitArccos:
  Exit Function
 
ErrArccos:
  ErrArccos = True
  Resume ExitArccos:
 
End Function
 
 
 
Public Function arcsin(x)
'Wenn wir schon mal dabei sind: so sieht Arcus-Sinus aus:
arcsin = PI() / 2 - arccos(x)
 
End Function
 
 
 
Public Function Give_KM(Breite1, Breite2, Laenge1, Laenge2) As Double
 
'Berechnung der Entfernung von 2 Orten Teil I
'(wichtig! Bitte die Reihenfolge der Parameter beachten):
 
Dim e As Double
 
e = arccos(Sin(Breite1) * Sin(Breite2) + Cos(Breite1) _
    * Cos(Breite2) * Cos(Laenge2 - Laenge1))
 
If ErrArccos = False Then
  Give_KM = Round((e * conErdradius), 2)
 Else
  Give_KM = 0
End If
 
End Function
 
 
 
Public Function Entfernung(Breite1, Breite2, Laenge1, Laenge2)
'Berechnung der Entfernung von 2 Orten Teil II
'(wichtig! Bitte die Reihenfolge der Parameter beachten):
 
If Not IsNumeric(Breite1) Then Breite1 = KoordToDouble(Breite1)
If Not IsNumeric(Breite2) Then Breite2 = KoordToDouble(Breite2)
If Not IsNumeric(Laenge1) Then Laenge1 = KoordToDouble(Laenge1)
If Not IsNumeric(Laenge2) Then Laenge2 = KoordToDouble(Laenge2)
 
Entfernung = Give_KM(DoubleToRad(Breite1), DoubleToRad(Breite2), _
             DoubleToRad(Laenge1), DoubleToRad(Laenge2))
 
End Function
 
 
 
Function Peilwinkel(Breite1, Breite2, Laenge1, Laenge2, Von)
 
Dim B1 As Double, B2 As Double
Dim L1 As Double, L2 As Double
Dim x As Double, y As Double
Dim z As Double, PW_Temp As Double
 
On Error GoTo Pw_Err:
 
If Von = "Start" Then
  B1 = DoubleToRad(KoordToDouble(Breite1))
  B2 = DoubleToRad(KoordToDouble(Breite2))
  L1 = DoubleToRad(KoordToDouble(Laenge1))
  L2 = DoubleToRad(KoordToDouble(Laenge2))
 Else
  B1 = DoubleToRad(KoordToDouble(Breite2))
  B2 = DoubleToRad(KoordToDouble(Breite1))
  L1 = DoubleToRad(KoordToDouble(Laenge2))
  L2 = DoubleToRad(KoordToDouble(Laenge1))
End If
 
x = (Cos(B1) * Sin(B2)) - (Sin(B1) * Cos(B2) * Cos(L2 - L1))
y = Cos(B2) * Sin(L2 - L1)
 
z = Atn(y / x)
 
PW_Temp = z * 180 / PI()
 
If Von = "Start" Then
  Select Case PW_Temp
   Case Is < 0
    If B1 > B2 Then
      PW_Temp = 180 + PW_Temp
     Else
      PW_Temp = 360 + PW_Temp
    End If
   Case Else
    If B1 > B2 Then
      PW_Temp = 180 + PW_Temp
    End If
  End Select
 Else
  Select Case PW_Temp
   Case Is < 0
    If B1 > B2 Then
      PW_Temp = 180 + PW_Temp
     Else
      PW_Temp = 360 + PW_Temp
    End If
   Case Else
    If B1 > B2 Then
      PW_Temp = 180 + PW_Temp
    End If
  End Select
End If
 
Peilwinkel = Round(PW_Temp)
 
PW_Exit:
    Exit Function
 
Pw_Err:
    Peilwinkel = Null
    Resume PW_Exit:
 
End Function
 
 
 
Public Function Himmelsrichtung(GradZahl) As String
 
Dim H_Temp As String
 
Select Case GradZahl
 Case 0 To 22.5
  H_Temp = "N"
 Case 22.6 To 67.5
  H_Temp = "NO"
 Case 67.6 To 112.5
  H_Temp = "O"
 Case 112.6 To 157.5
  H_Temp = "SO"
 Case 157.6 To 202.5
  H_Temp = "S"
 Case 202.6 To 247.5
  H_Temp = "SW"
 Case 248.6 To 292.5
  H_Temp = "W"
 Case 292.6 To 337.5
  H_Temp = "NW"
 Case 337.5 To 360
  H_Temp = "N"
 Case Else
  'H_Temp = "N"
End Select
 
Himmelsrichtung = H_Temp
 
End Function
 
 
 
Public Function Mittelpunkt(Breite1, Breite2, Laenge1, Laenge2)
 
Dim B1, B2, L1, L2, x1, x2, x3, x4, z1, z2, z3, z4
Dim y1, y2, y3, y4, r, l3, b3, breite, laenge
 
B1 = DoubleToRad(KoordToDouble(Breite1))
B2 = DoubleToRad(KoordToDouble(Breite2))
L1 = DoubleToRad(KoordToDouble(Laenge1))
L2 = DoubleToRad(KoordToDouble(Laenge2))
 
x1 = Cos(B1) * Cos(L1)
y1 = Cos(B1) * Sin(L1)
z1 = Sin(B1)
 
x2 = Cos(B2) * Cos(L2)
y2 = Cos(B2) * Sin(L2)
z2 = Sin(B2)
 
x3 = x1 + x2
y3 = y1 + y2
z3 = z1 + z2
 
r = Sqr(x3 * x3 + y3 * y3 + z3 * z3)
 
x4 = 1 / r * x3
y4 = 1 / r * y3
z4 = 1 / r * z3
 
l3 = arcsin(z4)
b3 = arccos(x4 / Cos(l3))
 
breite = DoubleToKoord(l3 * 180 / PI(), "N")
If y4 < 0 Then breite = breite * -1
laenge = DoubleToKoord(b3 * 180 / PI(), "O")
 
Mittelpunkt = breite & "     " & laenge
 
End Function
 
 
 
Public Function KoordToQTH(breite, laenge)
 
Dim LaengeNK As Double, BreiteNK As Double
Dim A1 As String, A2 As String
Dim z1 As String, z2 As String
Dim A3 As String, A4 As String
 
laenge = KoordToDouble(laenge)
breite = KoordToDouble(breite)
 
laenge = laenge + 180
breite = breite + 90
 
LaengeNK = laenge - Val(laenge)
BreiteNK = breite - Val(breite)
 
A1 = Chr(Val(laenge / 20) + 65)
A2 = Chr(Val(breite / 10) + 65)
z1 = Chr(Val((laenge Mod 20) / 2) + 48)
z2 = Chr(Val(breite) Mod 10 + 48)
 
A3 = Chr(Val(LaengeNK * 60 / 5) + 65)
A4 = Chr(Val(BreiteNK * 60 / 2.5 + 65))
 
If Val(laenge) Mod 2 = 1 Then
  A3 = Chr(Asc(A3) + 12)
End If
 
KoordToQTH = A1 & A2 & z1 & z2 & A3 & A4
 
End Function
 
 
 
Public Function QthToDouble(QthWert As String, Gradtyp As String) As Double
 
Dim l, b
 
If Gradtyp = "L" Then
  l = ((Asc(Left(QthWert, 1)) - 65) * 20) - 180
  l = l + Val(Mid(QthWert, 3, 1) * 2)
  l = l + (Asc(Mid(QthWert, 5, 1)) - 65) / 12
  l = l + 1 / 24
  QthToDouble = Round(l, 5)
 Else
  b = (Val(Asc(Mid(QthWert, 2, 1)) - 65) * 10) - 90
  b = b + Val(Mid(QthWert, 4, 1))
  b = b + (Val(Asc(Right(QthWert, 1)) - 64) / 24)
  b = b - 1 / 48
  QthToDouble = Round(b, 5)
End If
 
End Function
 
 
 
Public Function DoubleToKoord(GradWert As Double, NoderO As String) As String
 
Dim IntGrad As Integer, IntMinuten As Integer, IntSekunden As Integer
Dim IntMinutenTemp As Double
 
IntGrad = Val(GradWert)
 
IntMinutenTemp = (GradWert - IntGrad) * 60
IntMinuten = Val(IntMinutenTemp)
 
IntSekunden = Val((IntMinutenTemp - IntMinuten) * 60)
 
DoubleToKoord = FuehrendeNull(CStr(IntGrad)) & "°" _
                & FuehrendeNull(CStr(IntMinuten)) & "'" _
                & FuehrendeNull(CStr(IntSekunden)) & "''" & NoderO
 
End Function
 
 
 
Public Function FuehrendeNull(KonvStr As String) As String
 
If Val(KonvStr) < 10 Then
  FuehrendeNull = "0" & Trim(KonvStr)
 Else
  FuehrendeNull = Trim(KonvStr)
End If
 
End Function
 
 
 
Public Function MileToKmVV(EntfInMilOKM As Double, Richtung As String) _
                As Double
 
If Richtung = "M" Then      'Umrechnung in Meilen
  MileToKmVV = Round(EntfInMilOKM / conMile, 2)
 Else
  MileToKmVV = Round(EntfInMilOKM * conMile, 2) 'Umrechnung in Km
End If
 
End Function