Entfernung zwischen zwei PLZ mit GoogleMaps berechnen!

[cysu11]

Hallo liebe Excelgemeinde,


stehe mal wieder vor einer Aufgabe und ich benötige wieder eure Hilfe! :)

Folgenden Code habe ich im Internet gefunden, bei Ausführen passiert jedoch nichts!

Code:

Option Explicit

Private IEApp As Object
Private objRe As Object

Sub Orte()
    Dim i As Long, strVonPLZ As String, strBisPLZ As String

    With Tabelle1
       If Not isPLZ(.Range("A1").Text, strVonPLZ) Then Exit Sub
      
       Set IEApp = CreateObject("InternetExplorer.Application")
       IEApp.Visible = False
      
       Set objRe = CreateObject("vbscript.regexp")
       objRe.Pattern = "^(\d+(?:[\D]\d+)? km . .*Minuten)$"
       objRe.MultiLine = True
      
       For i = 2 To IIf(Len(.Cells(.Rows.Count, 1)), .Rows.Count, .Cells(.Rows.Count, 1).End(xlUp).Row)
          If isPLZ(.Cells(i, 1).Text, strBisPLZ) Then .Cells(i, 2).Value = Entfernung(strVonPLZ, strBisPLZ)
       Next i
      
       Set objRe = Nothing
       IEApp.Quit
       Set IEApp = Nothing
    End With
End Sub

Private Function isPLZ(ByVal strVal As String, ByRef strPLZ As String) As Boolean
    strPLZ = Trim(strVal)
    isPLZ = strPLZ Like "#####"
End Function

Function Entfernung(ByVal strVonPLZ As String, ByVal strBisPLZ As String) As String
    Dim IEDocument As Object
    Dim objMc As Object
  
   'IEApp.Navigate "http://maps.google.com/maps?saddr=" & strVonPLZ & "&daddr=" & strBisPLZ & "&hl=de"
   IEApp.Navigate "http://maps.google.de/maps?f=d&hl=de&geocode=&saddr=" & strVonPLZ & "&daddr=" & strBisPLZ & "&output=html"
   Do: Loop Until IEApp.Busy = False
   Do: Loop Until IEApp.Busy = False
  
   Set IEDocument = IEApp.Document
   Set objMc = objRe.Execute(IEDocument.Body.innerText)
   If objMc.Count Then Entfernung = objMc(0)
   Set objMc = Nothing
   Set IEDocument = Nothing
End Function

Was ich vorhabe ist, die Entfernung zwischen der PLZ die in A1 steht und er PLZ die in A2 steht. Die PLZ gebe ich immer per Hand ein und beim Auslösen des Codes soll in B1 die Entfernung in KM ausgegeben werden, und in C1 die Fahrzeit!

Kann mir jemand helfen und den Code meinen Vorhaben anpassen?


Für eure Hilfe danke ich im Voraus
LG aus Nürnberg
Alexandra

[schauan]

Hallo Alexandra,
Hast Du denn auch den IE als Browser?

[cysu11]

Hallo Andre,


ja habe ich! :)


LG
Alexandra

[Max]

Hallo Alexandra,
hallo André,

so wie ich das verstehe, wird in dem Makro vorausgesetzt, dass auf Google-Maps vbscript zum Einsatz kommt.

Code:

...
Set objRe = CreateObject("vbscript.regexp")
...

Schau ich mir den Quellcode auf Google-Maps in Firefox an, finde ich da Javascript, wenn ich das richtig sehe/verstehe.

Code:

...
<script type="text/javascript">
...

Kann das das Problem sein ?
Das ganze überschreitet aber ein wenig meinen Backround und vielleicht ist das auch alles nur rubbish.

Gruß
Max

[Max]

Hallo,

ich habe hier etwas gefunden.
Das scheint zu funtionieren, wenn man die Adressdaten wie folgt erfasst:

Arbeitsblatt mit dem Namen 'Tabelle1'
	A	B	C	D
1	Straße	PLZ	Ort	Entfernung
2	Mittelstr.	58285	Gevelsberg
3	Königsallee	40212	Düsseldorf

Hier der dazu gehörige Code:

Code:

Option Explicit
Sub Orte()
Dim i As Integer
Dim zeile As Long

With Sheets(1)
zeile = .Range("A65536").End(xlUp).Row - 1
For i = 2 To zeile
.Cells(i + 1, 4).Value = Entfernung(.Cells(i, 1), .Cells(i, 2), .Cells(i, 3), .Cells(i + 1, 1), .Cells(i + 1, 2), .Cells(i + 1, 3))
Next i
End With

End Sub

Function Entfernung(Von_Straße As String, Von_PLZ As String, Von_Ort As String, Nach_Straße As String, Nach_PLZ As String, Nach_Ort As String)
  Dim IEApp As Object
  Dim IEDocument As Object
  Dim blnGefunden As Boolean
  Dim RouteStr As String
  Dim Von As String
  Dim Nach As String
  Dim IEDoc As Object
  Dim strTeile As Variant
  Dim i As Long
  Dim msg As String

  blnGefunden = False
  
  Von = Adresse(Von_Straße, Von_Ort, Von_PLZ)
  Nach = Adresse(Nach_Straße, Nach_Ort, Nach_PLZ)
  Set IEApp = CreateObject("InternetExplorer.Application")
  IEApp.Visible = False
  IEApp.Navigate "http://maps.google.com/maps?saddr=" & Von & "&daddr=" & Nach & "&hl=de"
  Do: Loop Until IEApp.Busy = False
  Set IEDocument = IEApp.Document
  Set IEDoc = IEApp.Document
  strTeile = Split(IEDoc.Body.innerText, vbCrLf)
  For i = LBound(strTeile) To UBound(strTeile)
    If InStr(1, strTeile(i), "Minuten", vbTextCompare) > 0 Then
      blnGefunden = True
      Entfernung = "Von: " & Von & vbLf & "Nach: " & Nach & vbLf & strTeile(i)
    End If
  Next
  If blnGefunden = False Then
    MsgBox "Die Adresse konnte nicht decodiert werden." & vbCr & "Falsche PLZ?"
  Else
  End If
  IEApp.Quit
  Set IEDocument = Nothing
  Set IEApp = Nothing
End Function

Function Adresse(Street As String, City As String, ZIP As String) As String
Dim HStr As String

    If Street <> "" Then HStr = Street & ","
    If ZIP <> "" Then HStr = HStr & ZIP & " "
    If City <> "" Then HStr = HStr & City
    Adresse = Trim(HStr)
End Function

Wie gesagt, nicht ganz mein Backround. Vielleicht kann jemand der anderen VBA-ler den Code anpassen.

Gruß
Max

[schauan]

Hallo Alexandra,

ich habe vor über 2 Jahren mal was zusammengestellt, siehe Anhang. Du kannst hier oben 2 Ausgangspunkte eintragen und darunter in der Tabelle verschiedene Ziele.

[cysu11]

Hallo Andre,


wow, das funktioniert ja super! :28:

Kannst du mir den Code noch so anpassen, dass wirklich nur die PLZ in A1 und A2 eingegeben werden müssen und dann nur die KM in B1 und die Zeit in C1 angezeigt werden?

Das wäre echt super, und würde mir unheimlich weiterhelfen!!!!!

Für deine Hilfe bedanke ich mich im Voraus
LG aus Nürnberg
Alexandra

[schauan]

Hallo ALexandra,

dann ersetze die codes durch diesen:

Option Explicit

Public Sub GoogleTest()
'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
On Error GoTo errorhandler
'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
  'OriginAddress ermitteln 
  'Hinweise: 
  'PLZ auch 4stellig moeglich 
  strOAddr = "Deutschland, " & Format(Cells(1, 1), "0####")
  'DestinationAddress ermitteln 
  'Hinweise: 
  'PLZ nicht 4stellig moeglich! 
  strDAddr = "Deutschland, " & Format(Cells(2, 1), "0####")
  '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")
  '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(1, 2) = xmlNod.Text / 1000
  'Zeit in Stundenzelle eintragen, Rueckgabewert / 86400 
  Cells(1, 3) = CDate(xmlNod.Text / 86400)
'Ende Wenn Instanzierung nicht nichts gebracht hat, dann 
End If
'Fehlerbehandlung / Programmende 
errorhandler:
'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

[Winny]

Hi

da hat sich noch ein kleiner Fehler eingeschlichen, so funktionierts auch mit der Dauer

      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(1, 3) = 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(1, 2) = xmlNod.Text / 1000

[cysu11]

Hallo Andre, Hallo Winny,


super, es funktioniert perfekt! Das einzige das noch nicht ganz passt, ist die Zeit!
Wenn ich bei googlemaps die Entfernung zwischen 90427 und 80331 eingebe dann kommen 3 Vorschläge und da wird komischerweise die Entfernung von dem ersten Vorschlag was ja passt nur die Zeit von dem 2 oder 3. Vorschlag! Was muss ich ändern, damit auch die Zeit vom ersten Vorschlag genommen wird?


Vielen DAnk
VG
Alexandra