Google Maps Abfrage mit Geodaten
21.02.2016 17:31:16
Thomas
ich versuche verzweifelt eine Maps Abfrage hinzubekommen. Ich nehme aus einem Dialog Adressdaten und baue sie zu einer Abfrage zusammen. Zurück kommt die Entfernung zwischen den beiden Adressen in Kilometer.
So weit so gut ... Das funktioniert einwandfrei. Wenn ich aber jetzt eine Adresse durch Geodaten ersetze kommt die Meldung Blockvariable nicht gesetzt.
Die Geodaten lauten 47°46'06.0"N 12°56'35.9"E . Ich habe sie schon in das Google Format umgewandelt 47%C2%B046'06.0%22N+12%C2%B056'35.9%22E aber immer die gleiche Meldung. Wenn ich den String so eingebe zeigt Google sofort die Roote an, aber mit dem Code geht es nicht.
Hier der Code
Public Function Entfernung_ermitteln1(SAdr, SPlz, SStadt, ZAdr, ZPlz, ZStadt, EntfKM, FDauer1, _
ID0)
On Error GoTo errorhandler
Set a = dlgFahrteingabe1
Application.ScreenUpdating = False 'Flackern aus
'XML-Objecte festlegen
Set objXML = CreateObject("Msxml2.XMLHTTP")
Set xmlDoc = CreateObject("MSXML2.DOMDocument")
'Wenn Instanzierung nicht nichts gebracht hat, dann
If Not objXML Is Nothing Then
If ID0 = 1 Or ID0 = 3 Then
'String für den Start generieren. Hinweise: Straße, Postleitzahl, Stadt
strStartAddr = ReplaceGermans1(SAdr) & ",+" & Format(SPlz, "0####") & ",+" & _
ReplaceGermans1(SStadt)
'String für das Ziel generieren. Hinweise: Straße, Postleitzahl, Stadt
If IsNumeric(Mid(ZAdr, 1, 1)) = False Then
strZielAddr = ReplaceGermans1(ZAdr) & ",+" & Format(ZPlz, "0####") & ",+" & _
ReplaceGermans1(ZStadt)
'Abfrage oeffnen
objXML.Open "POST", "http://maps.googleapis.com/maps/api/distancematrix/xml?origins=" & _
strStartAddr & "&destinations=" & strZielAddr & "&language=de-DE&sensor=false", False
Else
'Abfrage oeffnen
strZielAddr = ReplaceGeoDat(ZAdr) & ",+"",+"
objXML.Open "POST", "https://www.google.de/maps/dir/" & strStartAddr & "& _
destinations=" & strZielAddr & ", False"
End If
'Abfrageheader
objXML.setRequestHeader "Content-Type", "content=text/html; charset=UTF-8"
'Abfrage senden
objXML.send
'Abfrageergebnis (Text) aufnehmen
xmlDoc.LoadXML objXML.responseText
'Entfernung auslesen /Value=Meter /Text = Kilometer mit Angabe "km"
Set xmlNod = xmlDoc.SelectSingleNode("//row/element/distance/value")
'Entfernung in km zelle eintragen, Rueckgabewert / 1000
EntfKM = xmlNod.Text / 1000
'Berechnung auf die neue Startzeit übertragen => zB 11:00 + die berechnete Zeit
FDauer1 = EntfKM / 80 / 24
If ID0 = 1 Then
t = "" & dlgFahrteingabe1.tboAnfDat & " " & dlgFahrteingabe1.tboAnfZeit & ""
t = t + CDbl(CDate(dlgFahrteingabe1.tboAnfAbstand)) + FDauer1
t2 = CDate(FormatDateTime(t, vbShortDate))
t3 = CDate(FormatDateTime(t, vbShortTime))
dlgFahrteingabe1.tboStartDat = t2
dlgFahrteingabe1.tboStartZeit = t3
dlgFahrteingabe1.tboStartZeit = Format(t3, "short time")
FDauer1 = CDate(FormatDateTime(FDauer1, vbShortTime))
'Dauer in DATA_Zeit (unsichtbares Textfeld im Dialog) eintragen
dlgFahrteingabe1.DATA_Zeit = Format(FDauer1, "short time")
'errechnete Zeit mit Dimension versehen
FDauer1 = "" & Mid(FDauer1, 1, Len(FDauer1) - 3) & " hh:mm"
'Entfernung in DATA_km (unsichtbares Textfeld im Dialog) eintragen
dlgFahrteingabe1.DATA_km = EntfKM
'Entfernungswert mit Dimension versehen
EntfKM = "" & EntfKM & " km"
ElseIf ID0 = 3 Then
t = "" & dlgFahrteingabe1.tboStartDat & " " & dlgFahrteingabe1.tboStartZeit & ""
t = t + FDauer1
t2 = CDate(FormatDateTime(t, vbShortDate))
t3 = CDate(FormatDateTime(t, vbShortTime))
dlgFahrteingabe1.tboZielDat = t2
dlgFahrteingabe1.tboZielZeit = Format(t3, "short time")
' FDauer1 = CDate(FormatDateTime(FDauer1, vbShortTime))
'Dauer in DATA_Zeit (unsichtbares Textfeld im Dialog) eintragen
dlgFahrteingabe1.DATA_Zeit = Format(FDauer1, "short time")
'errechnete Zeit mit Dimension versehen
FDauer1 = "" & Mid(FDauer1, 1, Len(FDauer1) - 3) & " hh:mm"
'Entfernung in DATA_km (unsichtbares Textfeld im Dialog) eintragen
dlgFahrteingabe1.DATA_km2 = EntfKM
'Entfernungswert mit Dimension versehen
EntfKM = "" & EntfKM & " km"
End If
ElseIf ID0 = 2 Or ID0 = 4 Then
'http://maps.google.com/maps?saddr=Königsstraße,Stuttgart&daddr=Hochenstraße,Frankfurt&hl=de
'String für den Start generieren. Hinweise: Straße, Postleitzahl, Stadt
strStartAddr = ReplaceGermans1(SAdr) & "," & Format(SPlz, "0####") & "," & _
ReplaceGermans1(SStadt)
'String für das Ziel generieren. Hinweise: Straße, Postleitzahl, Stadt
strZielAddr = ReplaceGermans1(ZAdr) & "," & Format(ZPlz, "0####") & "," & _
ReplaceGermans1(ZStadt)
item = "" & strStartAddr & "/" & strZielAddr & ""
'https://www.google.de/maps/dir/Pettenkoferstra%C3%9Fe+21,+83052+Bruckm%C3%BChl/ _
Vagenerau+Weg+72,+83052+Bruckm%C3%BChl
Set IEApp = CreateObject("InternetExplorer.Application")
IEApp.Visible = True
IEApp.Navigate "https://www.google.de/maps/dir/" & item & ""
End If
'Ende Wenn Instanzierung nicht nichts gebracht hat, dann
End If
'Fehlerbehandlung / Programmende
errorhandler:
'Flackern ein
Application.ScreenUpdating = True
'Wenn Fehlernummer 0, dann Ausgabe Fehlermeldung
If Err.Number 0 Then MsgBox "Fehler: " & Err.Number & vbLf & Err.Description
'XML-Objecte zuruecksetzen
Set xmlNod = Nothing
Set xmlDoc = Nothing
Set objXML = Nothing
End Function
'Funktion ersetzt deutsche Umlaute
'Variablendeklaration
'Integer
Dim iCnt%
'Array
Dim arrRep
'Array mit Umlauten und Replacements definieren
arrRep = Array("Ö", "Oe", "ö", "oe", "Ä", "Ae", "ä", "ae", "Ü", "Ue", "ü", "ue", "ß", "ss")
'Schleife von 0 bis Ende vom Array, Schrittweite 2
For iCnt = 0 To UBound(arrRep) Step 2
'Umlaut mit Replacement ersetzen
strText = Replace(strText, arrRep(iCnt), arrRep(iCnt + 1))
'Ende Schleife von 0 bis Ende vom Array, Schrittweite 2
Next
ReplaceGermans1 = strText
End Function
Function ReplaceGeoDat(ByVal strText As String) As String
strText = Replace(strText, "°", "%C2B0")
strText = Replace(strText, " ", "+")
strText = Replace(strText, """", "%22")
ReplaceGeoDat = strText
End Function
Sub Entfernung()
Set IEApp = CreateObject("InternetExplorer.Application")
IEApp.Visible = True
IEApp.Navigate "http://maps.google.com/maps?saddr=" & Von
Do: Loop Until IEApp.Busy = False
End Sub Vielleicht hat ja jemand einen Tip für mich?
Vielen Dank im Voraus ...