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: 92)

[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