ich habe eine kleine Funktion geschrieben, die die Entfernung zwischen zwei Orten in Metern berechnet. Es wird die Google Maps API (über die URL) verwendet.
Es fehlt noch die Fehlerbehandlung, aber an sonsten sollte es funktionieren.
Declare Function InternetOpen Lib "wininet.dll" Alias "InternetOpenA" (Byval sAgent As String, Byval lAccessType As Long, Byval sProxyName As String, Byval sProxyBypass As String, Byval lFlags As Long) As Long
Declare Function InternetOpenUrl Lib "wininet.dll" Alias "InternetOpenUrlA" (Byval hOpen As Long, Byval sUrl As String, Byval sHeaders As String, Byval lLength As Long, Byval lFlags As Long, Byval lContext As Long) As Long
Declare Function InternetReadFile Lib "wininet.dll" (Byval hFile As Long, Byval sBuffer As String, Byval lNumBytesToRead As Long, lNumberOfBytesRead As Long) As Integer
Declare Function InternetCloseHandle Lib "wininet.dll" (Byval hInet As Long) As Integer
Function GoogleMapsDistance(inVonLand As String, inVonOrt As String, inVonStrasse As String, inNachLand As String, inNachOrt As String, inNachStrasse As String, inAutobahn As Boolean) As Long
'*** Die Entfernung wird in Metern zurückgegeben ***
Dim hOpen As Long
Dim hOpenUrl As Long
Dim sUrl As String
Dim bDoLoop As Boolean
Dim bRet As Boolean
Dim sReadBuffer As String * 2048
Dim lNumberOfBytesRead As Long
Dim vonLandTemp As String
Dim vonOrtTemp As String
Dim vonStrasseTemp As String
Dim vonLand As Variant
Dim vonOrt As Variant
Dim vonStrasse As Variant
Dim nachLandTemp As String
Dim nachOrtTemp As String
Dim nachStrasseTemp As String
Dim nachLand As Variant
Dim nachOrt As Variant
Dim nachStrasse As Variant
Dim vonString As String
Dim nachString As String
Dim autobahn As String
Dim replFormel As String
Dim vonListe As String
Dim nachListe As String
Dim stringRetValTemp As String
Dim stringRetVal As String
Dim arrayRetVal As Variant
Dim statusAbfrage As String
Dim statusAbfrageError As String
Dim statusEntfBerechnung As String
Dim statusEntfBerechnungError As String
Dim entfernungString As String
'---> Ersetzen von nicht unterstützten Zeichen
vonLandTemp = RepSubstr(Fulltrim(inVonLand), " ", "+")
vonOrtTemp = RepSubstr(Fulltrim(inVonOrt), " ", "+")
vonStrasseTemp = RepSubstr(Fulltrim(inVonStrasse), " ", "+")
nachLandTemp = RepSubstr(Fulltrim(inNachLand), " ", "+")
nachOrtTemp = RepSubstr(Fulltrim(inNachOrt), " ", "+")
nachStrasseTemp = RepSubstr(Fulltrim(inNachStrasse), " ", "+")
vonListe = |"Ä":"Ö":"Ü":"ä":"ö":"ü":"ß"|
nachListe = |"Ae":"Oe":"Ue":"ae":"oe":"ue":"ss"|
replFormel = |@ReplaceSubstring("| + vonLandTemp + |" ; | + vonListe + | ; | + nachListe + |)|
vonLand = Evaluate(replFormel)
replFormel = |@ReplaceSubstring("| + vonOrtTemp + |" ; | + vonListe + | ; | + nachListe + |)|
vonOrt = Evaluate(replFormel)
replFormel = |@ReplaceSubstring("| + vonStrasseTemp + |" ; | + vonListe + | ; | + nachListe + |)|
vonStrasse = Evaluate(replFormel)
replFormel = |@ReplaceSubstring("| + nachLandTemp + |" ; | + vonListe + | ; | + nachListe + |)|
nachLand = Evaluate(replFormel)
replFormel = |@ReplaceSubstring("| + nachOrtTemp + |" ; | + vonListe + | ; | + nachListe + |)|
nachOrt = Evaluate(replFormel)
replFormel = |@ReplaceSubstring("| + nachStrasseTemp + |" ; | + vonListe + | ; | + nachListe + |)|
nachStrasse = Evaluate(replFormel)
'<---
'---> Autobahnen erlaubt (True) oder nicht (False)
Select Case inAutobahn
Case False : autobahn = "&avoid=highways"
Case True : autobahn = ""
End Select
'<---
If vonLandTemp <> "" And vonOrtTemp <> "" And nachStrasseTemp <> "" Then
vonString = Cstr(vonStrasse(0)) + "+" + Cstr(vonOrt(0)) + "+" + Cstr(vonLand(0))
Elseif vonLandTemp = "" And vonOrtTemp <> "" And nachStrasseTemp <> "" Then
vonString = Cstr(vonStrasse(0)) + "+" + Cstr(vonOrt(0))
Elseif vonLandTemp <> "" And vonOrtTemp = "" And nachStrasseTemp <> "" Then
vonString = Cstr(vonStrasse(0)) + "+" + Cstr(vonLand(0))
Elseif vonLandTemp <> "" And vonOrtTemp <> "" And nachStrasseTemp = "" Then
vonString = Cstr(vonOrt(0)) + "+" + Cstr(vonLand(0))
Elseif vonLandTemp <> "" And vonOrtTemp = "" And nachStrasseTemp = "" Then
vonString = Cstr(vonLand(0))
Elseif vonLandTemp = "" And vonOrtTemp <> "" And nachStrasseTemp = "" Then
vonString = Cstr(vonOrt(0))
Elseif vonLandTemp = "" And vonOrtTemp = "" And nachStrasseTemp <> "" Then
vonString = Cstr(vonStrasse(0))
Else
GoogleMapsDistance = 0
Exit Function
End If
If nachLandTemp <> "" And nachOrtTemp <> "" And nachStrasseTemp <> "" Then
nachString = Cstr(nachStrasse(0)) + "+" + Cstr(nachOrt(0)) + "+" + Cstr(nachLand(0))
Elseif nachLandTemp = "" And nachOrtTemp <> "" And nachStrasseTemp <> "" Then
nachString = Cstr(nachStrasse(0)) + "+" + Cstr(nachOrt(0))
Elseif nachLandTemp <> "" And nachOrtTemp = "" And nachStrasseTemp <> "" Then
nachString = Cstr(nachStrasse(0)) + "+" + Cstr(nachLand(0))
Elseif nachLandTemp <> "" And nachOrtTemp <> "" And nachStrasseTemp = "" Then
nachString = Cstr(nachOrt(0)) + "+" + Cstr(nachLand(0))
Elseif nachLandTemp <> "" And nachOrtTemp = "" And nachStrasseTemp = "" Then
nachString = Cstr(nachLand(0))
Elseif nachLandTemp = "" And nachOrtTemp <> "" And nachStrasseTemp = "" Then
nachString = Cstr(nachOrt(0))
Elseif nachLandTemp = "" And nachOrtTemp = "" And nachStrasseTemp <> "" Then
nachString = Cstr(nachStrasse(0))
Else
GoogleMapsDistance = 0
Exit Function
End If
'---> Anfrage an Google Maps API
sUrl = "http://maps.googleapis.com/maps/api/distancematrix/xml?origins=" + vonString + "&destinations=" + nachString + "&mode=driving&language=de-DE&sensor=false" + autobahn
hOpen = InternetOpen(scUserAgent, INTERNET_OPEN_TYPE_PRECONFIG, "", "", 0)
hOpenUrl = InternetOpenUrl(hOpen, sUrl, "", 0, INTERNET_FLAG_RELOAD, 0)
bDoLoop = True
While bDoLoop
sReadBuffer = ""
bRet = InternetReadFile(hOpenUrl, sReadBuffer, Len(sReadBuffer), lNumberOfBytesRead)
sBuffer = sBuffer & Left$(sReadBuffer, lNumberOfBytesRead)
If Not Cbool(lNumberOfBytesRead) Then bDoLoop = False
Wend
If hOpenUrl <> 0 Then InternetCloseHandle (hOpenUrl)
If hOpen <> 0 Then InternetCloseHandle (hOpen)
'<---
'---> Rückgabewert prüfen und aufbereiten
stringRetValTemp = Fulltrim(RepSubstr(Cstr(sBuffer), Chr(10), "~"))
stringRetVal = RepSubstr(Cstr(stringRetValTemp), "~ ", "~")
arrayRetVal = Split(stringRetVal, "~")
'<---
'---> Das zurückgegebene Array nach der entfernung prüfen
statusAbfrage = Strright(Strleftback(arrayRetVal(2), "</status>", 0, 1), "<status>", 0, 1)
If Ucase(statusAbfrage) = "OK" Then
statusEntfBerechnung = Strright(Strleftback(arrayRetVal(7), "</status>", 0, 1), "<status>", 0, 1)
If Ucase(statusEntfBerechnung) = "OK" Then
entfernungString = Strright(Strleftback(arrayRetVal(13), "</value>", 0, 1), "<value>", 0, 1)
GoogleMapsDistance = Clng(entfernungString)
Else
GoogleMapsDistance = 0
End If
Else
statusAbfrageError = Strright(Strleftback(arrayRetVal(3), "</error_message>", 0, 1), "<error_message>", 0, 1)
GoogleMapsDistance = 0
End If
'<---
End Function