Herbers Excel-Forum - das Archiv
Googel Maps API in Excel VBA einfügen
- Googel Maps API in Excel VBA einfügen von Dirk1966 vom 12.09.2019 19:56:23
- Du hast am 3.10.2018 eine Antwort auf bekommen - von EtoPHG am 13.09.2019 15:25:44
Betrifft: Googel Maps API in Excel VBA einfügen
von: Dirk1966
Guten Abend zusammen,
vor 2 Jahren habe ich zusammen mit einigen Mitgliedern aus diesem Forum bereits ein Problem mit der VBA zur Ermittlung der Entfernung via Google Maps auf der Excel Datei lösen können. Mit der Änderung 08.2018 bei Google habe ich die Excel Datei nicht mehr genutzt. Ich wollte nun die Datei wieder aktivieren und habe auch im Internet gesucht ob ich eine Information finde so ich in dem bestehenden VBA Code ide Google Maps API einfügen muss. Leider ohne Erfolg.
Ich hoffe ihr könnt mir weiterhelfen.
Nachstehende die VBA
Public Sub GoogleTest1000()
'Variablendeklarastionen
'Objekt - Late Binding
Dim objXML As Object 'fuer XML-"String"
Dim xmlDoc As Object
Dim xmlNod As Object
'Objekt - Early Binding
'Dim xmlDoc As New MSXML2.DOMDocument
'Dim xmlNod As MSXML2.IXMLDOMNode
'String
Dim strOAddr$, strDAddr
'Integer
Dim iCnt1%, iCnt2%
'Long
Dim lCnt&
On Error GoTo errorhandler
'Flackern aus
Application.ScreenUpdating = False
'XML-Objecte instanzieren
Set objXML = CreateObject("Msxml2.XMLHTTP")
Set xmlDoc = CreateObject("MSXML2.DOMDocument")
'Wenn Instanzierung nicht nichts gebracht hat, dann
If Not objXML Is Nothing Then
'Zeile und Spalte fuer OriginAddress
iCnt1 = 4: iCnt2 = 3
'Schleife ueber alle OriginAddress anhand Eintraegen in Zeile 4
'Tue solange Zellinhalt nicht leer
Do While Cells(5, iCnt2) <> ""
'Wenn Eintrag Berechnen in Zeile 7 = "JA", dann
If UCase(Cells(7, iCnt2)) = "JA" Then
'OriginAddress ermitteln
'Hinweise:
'Keine deutschen "Sonderbuchstaben" verwendbar
'PLZ auch 4stellig moeglich
'Zeile 4 = Straße, Zeile 5 = PLZ, Zeile 6 = Ort
strOAddr = ReplaceGermans(Cells(iCnt1, iCnt2)) & "," & Format(Cells(iCnt1 + 1, iCnt2), "0# _
###") & "," & ReplaceGermans(Cells(iCnt1 + 2, iCnt2))
'Schleife ueber alle DestinationAddress anhand Eintraegen in Spalte A
For lCnt = 11 To Cells(Rows.Count, 1).End(xlUp).Row
'DestinationAddress ermitteln
'Hinweise:
'Keine deutschen "Sonderbuchstaben" verwendbar
'PLZ nicht 4stellig moeglich!
'Spalte A = PLZ, Spalte B = Ort
strDAddr = Format(Cells(lCnt, 1), "0####") & "," & ReplaceGermans(Cells(lCnt, 2))
'Abfrage oeffnen
objXML.Open "POST", "http://maps.googleapis.com/maps/api/distancematrix/xml?origins=" & _
strOAddr & "&destinations=" & strDAddr & "&language=de-DE&sensor=false", False
'Abfrageheader
objXML.setRequestHeader "Content-Type", "content=text/html; charset=iso8859-1"
'Abfrage senden
objXML.send
'Abfrageergebnis (Text) aufnehmen
xmlDoc.LoadXML objXML.responseText
'Zeit auslesen /Value=Sekunden /Text = Minuten mit Angabe "Minuten"
Set xmlNod = xmlDoc.SelectSingleNode("//row/element/duration/value")
'Zeit in Stundenzelle eintragen, Rueckgabewert / 86400
Cells(lCnt, iCnt2 + 1) = CDate(xmlNod.Text / 86400)
'Entfernung auslesen /Value=Meter /Text = Kilometer mit Angabe "km"
Set xmlNod = xmlDoc.SelectSingleNode("//row/element/distance/value")
'Entfernung in km zelle eintragen, Rueckgabewert / 1000
Cells(lCnt, iCnt2) = xmlNod.Text / 1000
'Ende Schleife ueber alle DestinationAddress anhand Eintraegen in Spalte A
Next
'Ende Wenn Eintrag Berechnen in Zeile 7 = "JA", dann
End If
'Spaltenzaehler hochsetzen
iCnt2 = iCnt2 + 2
'Ende Tue solange Zellinhalt nicht leer
DoEvents
Loop
'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 Sub
https://www.herber.de/bbs/user/132013.xlsm
Ich hoffe ihr könnt mir helfen-
Vielen Dank.
Mit freundlichem Grüss vom Niederrhein.
Dirk Beranek
Betrifft: Du hast am 3.10.2018 eine Antwort auf bekommen
von: 1712949.html
Geschrieben am: 3.10.2018 eine Antwort auf bekommen
Dirk,
In diesem Thread wurde das Problem ausführlich besprochen. Orientiere Dich am Geschriebenen dort.
Warum also nochmals aufwärmen? Was genau ist dein Problem? Nicht funktionieren oder die erwähnte Fehlermeldung (im obigem Thread) ist keine Problembeschreibung.
Gruess Hansueli