Microsoft Excel

Herbers Excel/VBA-Archiv

Informationen und Beispiele zum Thema MsgBox
BildScreenshot zu MsgBox MsgBox-Seite mit Beispielarbeitsmappe aufrufen

Googel Maps API in Excel VBA einfügen


Betrifft: Googel Maps API in Excel VBA einfügen von: Dirk1966
Geschrieben am: 12.09.2019 19:56:23

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=UTF-8"
         '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
Die Datei füge ich bei.
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

Beiträge aus dem Excel-Forum zum Thema "Googel Maps API in Excel VBA einfügen"