VBA Tipp: Distanz Luftlinie berechnen

Aus DBWiki
Wechseln zu: Navigation, Suche

Aufgabenstellung

Berechnung der Entfernung zwischen zwei Orten anhand der Angabe der Längen- und Breitengrade

Code

Option Compare Database
Option Explicit
 
Public Type Koordinaten_ty
  Laenge As Double
  Breite As Double
End Type
 
 
Private Const dbla As Double = 6378137#
Private Const dble As Double = 6.69438000426084E-03
Private Const dblpi As Double = 1.74532925199444E-02
 
 
'
'
' Original kommt von: http://www.dbdev.org/members/schwanke/koordinaten.zip
' © Christa Schwanke, Juni 2000
' http://www.dbdev.org/downloads.html
'
' Das Ergebnis ist in KM
' Längen und Breitengrade können hier ermittelt werden (Stand Januar 2014):
' http://www.linkr.de/2009/03/24/mit-google-maps-laengen-breitengrade-ermitteln-freies-geocoding-skript/
'
'
 
Private Const EndOfDeclaration As String = "EndOfDeclaration"
'
'
'_______________________________________
 
Private Sub PseudoMain()
 
Dim Hamburg_lcl As Koordinaten_ty, Berlin_lcl As Koordinaten_ty
 
  Hamburg_lcl.Laenge = 9.9936817999: Hamburg_lcl.Breite = 53.5510846
  Berlin_lcl.Laenge = 13.404954: Berlin_lcl.Breite = 52.5200066
 
  Debug.Print fct_CalcLuftlinie(Hamburg_lcl, Berlin_lcl)
 
End Sub
'
'
'_______________________________________
 
Public Function fct_CalcLuftlinie(Ort1_prm As Koordinaten_ty, Ort2_prm As Koordinaten_ty) As Double
 
On Error GoTo error_lcl
'------
 
  fct_CalcLuftlinie = Format(Sqr(Abs((fct_dblz(Ort1_prm.Breite) - fct_dblz(Ort2_prm.Breite)) _
                                * (fct_dblz(Ort1_prm.Breite) - fct_dblz(Ort1_prm.Breite)) _
                                    + (fct_dblx(Ort1_prm) - fct_dblx(Ort2_prm)) * (fct_dblx(Ort1_prm) - fct_dblx(Ort2_prm)) _
                                    + (fct_dbly(Ort1_prm) - fct_dbly(Ort2_prm)) * (fct_dbly(Ort1_prm) - fct_dbly(Ort2_prm)))) / 1000, "Fixed")
 
'------
error_lcl:
 
  Select Case Err
    Case 0
    Case Else
      CalcLuftlinie_lcl = -1
  End Select
 
Err.Clear: On Error GoTo 0
 
End Function
' fct_CalcLuftlinie
'
'_______________________________________
 
Private Function fct_dblbeta(Breite_prm As Double) As Double
 
On Error GoTo error_lcl
'------
 
  fct_dblbeta = dbla / Sqr(Abs(1 - dble * Sin(Breite_prm * dblpi) * Sin(Breite_prm * dblpi)))
 
'------
error_lcl:
 
  Select Case Err
    Case 0
    Case Else
      fct_dblbeta = -1
  End Select
 
Err.Clear: On Error GoTo 0
 
End Function
'
'_______________________________________
 
Private Function fct_dblx(Ort_prm As Koordinaten_ty) As Double
 
On Error GoTo error_lcl
'------
 
    fct_dblx = fct_dblbeta(Ort_prm.Breite) * Cos(Ort_prm.Breite * dblpi) * Cos(Ort_prm.Laenge * dblpi)
 
'------
error_lcl:
 
  Select Case Err
    Case 0
    Case Else
      fct_dblx = -1
  End Select
 
Err.Clear: On Error GoTo 0
 
End Function
'
'_______________________________________
 
Private Function fct_dbly(Ort_prm As Koordinaten_ty) As Double
 
On Error GoTo error_lcl
'------
 
  fct_dbly = fct_dblbeta(Ort_prm.Breite) * Cos(Ort_prm.Breite * dblpi) * Sin(Ort_prm.Laenge * dblpi)
 
'------
error_lcl:
 
  Select Case Err
    Case 0
    Case Else
      fct_dbly = -1
  End Select
 
Err.Clear: On Error GoTo 0
 
End Function
'
'_______________________________________
 
Private Function fct_dblz(Breite_prm As Double) As Double
 
On Error GoTo error_lcl
'------
 
  fct_dblz = fct_dblbeta(Breite_prm) * (1 - dble) * Sin(Breite_prm * dblpi)
 
'------
error_lcl:
 
  Select Case Err
    Case 0
    Case Else
      fct_dblz = -1
  End Select
 
Err.Clear: On Error GoTo 0
 
End Function
'

Siehe auch