Bing Entfernungsrechner / Fahrzeit

[el_gor]

Hallo,

ich habe zzt. einen Entfernungsrechner mit Darstellung der Fahrzeit durch Google Maps Einbindung mit folgendem Script in Verwendung:

Public Function GetDistance(start As String, dest As String)
    Dim firstVal As String, secondVal As String, lastVal As String
    firstVal = "https://maps.googleapis.com/maps/api/distancematrix/json?origins="
    secondVal = "+&destinations="
    lastVal = "mein API-Key"
    Set objHTTP = CreateObject("MSXML2.ServerXMLHTTP")
    URL = firstVal & Replace(start, " ", "+") & secondVal & Replace(dest, " ", "+") & lastVal
    objHTTP.Open "GET", URL, False
    objHTTP.setRequestHeader "User-Agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.0)"
    objHTTP.send ("")
    If InStr(objHTTP.responseText, """distance"" : {") = 0 Then GoTo ErrorHandl
    Set regex = CreateObject("VBScript.RegExp"): regex.Pattern = """value"".*?([0-9]+)": regex.Global = False
    Set matches = regex.Execute(objHTTP.responseText)
    tmpVal = Replace(matches(0).SubMatches(0), ".", Application.International(xlListSeparator))
    GetDistance = CDbl(tmpVal)
    Exit Function
ErrorHandl:
    GetDistance = -1
End Function
Public Function GetDuration(start As String, dest As String)
    Dim firstVal As String, secondVal As String, lastVal As String
    firstVal = "https://maps.googleapis.com/maps/api/distancematrix/json?origins="
    secondVal = "&destinations="
    lastVal = "mein API-Key"
    Set objHTTP = CreateObject("MSXML2.ServerXMLHTTP")
    URL = firstVal & Replace(start, " ", "+") & secondVal & Replace(dest, " ", "+") & lastVal
    objHTTP.Open "GET", URL, False
    objHTTP.setRequestHeader "User-Agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.0)"
    objHTTP.send ("")
    If InStr(objHTTP.responseText, """duration"" : {") = 0 Then GoTo ErrorHandl
    Set regex = CreateObject("VBScript.RegExp"): regex.Pattern = "duration(?:.|\n)*?""value"".*?([0-9]+)": regex.Global = False
    Set matches = regex.Execute(objHTTP.responseText)
    tmpVal = Replace(matches(0).SubMatches(0), ".", Application.International(xlListSeparator))
    GetDuration = CDbl(tmpVal)
    Exit Function
ErrorHandl:
    GetDuration = -1
End Function


Funktioniert an sich super ... allerdings sind mir die angefallenen Kosten bei Google zu hoch geworden, sodass ich nun gerne auf Bing-Maps (oder gibt es noch andere gute Alternativen?) umsteigen möchte.
Hat jemand ein Script der diesem ähnelt, ohne dass ich mein komplettes Excel umbauen muss?

Besten Dank und schönen Gruss, Elmar

[wisch]

Ist es nicht so, dass du einige Tausen Abfragen im Monat machen kannst, bis dein monatliches Freikontingent aufgebraucht ist?

Dann müsstes du ja jeden Monat etliche Tausend Abfragen gemacht haben, wenn du in den kostenpflichten Bereich geraten bist.

[LCohen]

Keine Antwort auf Deine Frage: https://forum.openstreetmap.org/viewtopic.php?id=66575

[volti]

Hallo Elmar,

ich habe mir Deinen code jetzt nicht angeschaut und mit Bing habe ich (noch) nicht gearbeitet, aber für Entfernungsanfragen habe ich mal einen Entfernungsrecher über luftlinie.org erstellt.
Der liegt hier so in meinen Bastelkiste rum.

Vielleicht entspricht er ja Deiner Vorstellung und kann von Dir entsprechend Deiner Wünsche angepasst werden oder zur Wissenserweiterung dienen.
Leider zur Zeit auch noch ohne Kommentierung...

[+][-]
 
Option Explicit

Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Type DIST_STRUCT
 Start As String 'Mehrere durch "/" getrennt eingeben
 Ziel  As String
 LDist As String
 FDist As String
End Type

Sub EntfernungErmitteln()
 Dim tDist As DIST_STRUCT
 With tDist
  .Start = "Frankfurt": .Ziel = "München"
  GetDistance tDist
  MsgBox "Die Entfernung zwischen" & vbCrLf _
      & .Start & vbCrLf & "und" & vbCrLf _
      & .Ziel & vbCrLf & "beträgt " & .LDist & " km." & vbCrLf _
      & "Die Fahrstrecke beträgt " & .FDist & "!", vbInformation, "Entfernung ermitteln"
 End With
End Sub


Sub GetDistance(tDist As DIST_STRUCT)
 Dim oNode As Object
 With CreateObject("InternetExplorer.Application")
  .navigate "http://www.luftlinie.org"       'Zur Url surfen
  While Not .readyState = 4: DoEvents: Wend  'Warten bis Seite geladen ist

  With .document
   Set oN‌ode = .getElementById("start")
   If Not oNode Is Nothing Then
    oNode.value = tDist.Start
    Set oN‌ode = .getElementById("end")
    On Error Resume Next
    If Not oNode Is Nothing Then
      oNode.value = tDist.Ziel
      Set oN‌ode = .getElementById("calcDistance")
      If Not oNode Is Nothing Then oNode.Click
      Do
        Sleep 100
        Set oN‌ode = Nothing
        Set oN‌ode = .getElementById("strck")
        If Not oNode Is Nothing Then
          If Not oNode.outerText Like "*--*" Then Exit Do
        End If
        DoEvents
      Loop
      tDist.LDist = .getElementsByClassName("value km")(0).outerText
      tDist.FDist = .getElementById("strck").outerText
      tDist.Start = tDist.Start & " " & .getElementsByClassName("regions")(0).outerText
      tDist.Ziel = tDist.Ziel & " " & .getElementsByClassName("regions")(2).outerText
    End If       'End
   End If       'Start
  End With
  .Quit         'IE schließen
 End With
End Sub

viele Grüße aus Freigericht
Karl-Heinz

[LCohen]

volti's Formel tut es! Ich habe die aufrufende Sub kurz und hässlich als Function umgeschrieben:

Function EntfernungErmitteln(a, b)
Dim tDist As DIST_STRUCT
With tDist
  .Start = a: .Ziel = b
  GetDistance tDist
  EntfernungErmitteln = Replace(.Start, " ", "_") & " " & Replace(.Ziel, " ", "_") & " " & .LDist & " " & .FDist
End With
End Function

und rufe sie wie folgt auf (mit Ergebnis in C1:F1, mit Start in A1 und Ende in B1; der restliche VBA-Code wird natürlich weiterhin benötigt):

C1: =MTRANS(XMLFILTERN(WECHSELN("<a><b>"&WECHSELN(EntfernungErmitteln(A1;B1);" km";)&"</b></a>";" ";"</b><b>");"//b"))

Bremen Hannover 100,13 124,02 
Göttingen Hannover 94,14 120,11
Hamburg Hannover 132,52 151,13
München Hannover 488,72 631,30
Stuttgart Hannover 401,78 522,95
Imperia Hannover 948,22 1.235,64 

C1:=INDEX(MTRANS(XMLFILTERN(WECHSELN("<a><b>"&WECHSELN(EntfernungErmitteln(A1;B1);" km";)&"</b></a>";" ";"</b><b>");"//b"));{3.4})
zeigt nur die Zahlen an.

[volti]

Super LCohen ?
VG KH

[schauan]

@wisch,

sind wohl nur noch 250 ...

[el_gor]

Hallo und herzlichen Dank für eure Rückmeldungen,

den Anzahl der Aufrufe zu diesem Thema lässt darauf schließen, dass es doch für viele ein brennendes Anliegen zu sein scheint.

Um das Problem etwas authentischer darzustellen: Ich sollte hier für eine größere Anzahl von Dienstnehmern, die gefahrenen Kilometer ermitteln, welche sie im Laufe eines Tages für Kundenbesuche aufgewendet haben um in weiterer Folge eine Abrechnung darüber erstellen zu können.

also Dienstnehmer 1 fährt heute

von A nach B      .... Anzahl km
von B nach C      .... Anzahl km
von C nach D     .... Anzahl km 
usw.

das ergibt dann eine Tagessumme, welche dann mit dem km-Satz multipliziert wird. 

Sehr gefallen würde mir die angesprochene Einbindung in OpenStreetMap, da wäre ich meine Kosten erst mal los.

Time-Distance Matrix
Matrices allow you to compute many-to-many distances and the times of routes much faster than consuming the directions api over and over again. This application is frequently used by logistics companies trying to figure out the most optimal route for deliveries

Doch wie ich zu einem diesbezüglichen VBA-Code (vergl. Google Maps) komme, weiß ich nicht. Habe zumindest nichts gefunden.

Eine weitere Option ist nach wie vor die Einbindung in Bing Maps. Allerdings würde ich nicht die Luftlinie sondern die tatsächlich gefahrene Wegstrecke benötigen.

Diese Einbindung von Bing Maps in Excel wird in den verschiedenen Foren immer wieder angesprochen, aber einen gut funktionierenden VBA-Code (vergl. Google-Maps) konnte ich bislang noch nicht ausfindig machen.

Danke für euere Mühen und die zahlreichen Antworten.

Lg. Elmar

[LCohen]

Ich habe noch mal geschaut: Ja, der Beitrag von volti und von mir ist tatsächlich noch da. Auch wenn er überhaupt nicht beachtet wird. - Deswegen hänge ich die Datei an, damit man bloß nichts selbst machen muss. Man könnte sich ja überanstrengen.

Möglicherweise ist das vorherige Öffnen von luftlinie.org im Browser sinnvoll. Es geht nicht um die Luftlinie. Das Ding heißt nur so. Ich bin auch kein Songwriter, oder glaubt man das etwa auch? Das Schreiben von Adressen sollte besser gleich richtig sein, sonst muss man den Code händisch beenden. Richtige VBA-Schreiber können das sicher absturzsicher machen.

  20200727 LuftlinieOrg Entfernungsmessung.xlsm (Größe: 19,04 KB / Downloads: 102)

[el_gor]

Hallo Volti / Cohen ...

herzlichen Dank für den Hinweis und deinen Excel-Script mit "Luftlinie.org".

Ist ja genau das, wonach ich gesucht habe. Muss mir nun überlegen, wie ich mein bestehendes Excel umbaue.

Sorry noch, dass nicht nicht gleich darauf reagiert haben, denn der Name lässt schon auf eine Luftlinienberechnung schließen und dass hätte ich nicht gebrauchen können.

Werde nun mal Luftlinie ausprobieren und schauen, ob ich das hinkriege.

Jedenfalls total super und besten Dank für euere Mitteilung.

Liebe Grüße, Elmar