Routenplaner mit VBA Excel programmieren

Routenplaner mit VBA Excel programmieren

Author D.Selzer-McKenzie

Video: https://youtu.be/lbIPE6WY9Y8

Hier zeige ich Ihnen, wie Sie einen Routenplaner mit exakten Kilometerständen usw. für ganz Europa programmieren können.

Den SourceCode VBA können Sie im Forum

http://Outbackbrumby.Blogspot.com

herunterladen.

 

Hier der SourceCode VBA:

Private Sub cmdRoute_Click()

   Dim strTemp    As String

   Dim objIE      As Object

   Dim strStart   As String

   Dim strDest    As String

  

   ' Ausgabebereich löschen

   Me.Range("G8:G1000").Clear

  

  

   ' Start aus Tabellenblatt auslesen zu einer

   ' Zeichenkette zusammensetzen

   strStart = Me.Range("H2")

   strStart = strStart & ", " & Me.Range("H3") & " " & Me.Range("H4")

   strStart = strStart & ", " & Me.Range("H5")

 

   ' Ziel aus Tabellenblatt auslesen und zu einer

   ' Zeichenkette zusammensetzen

   strDest = Me.Range("I2")

   strDest = strDest & ", " & Me.Range("I3") & " " & Me.Range("I4")

   strDest = strDest & ", " & Me.Range("I5")

 

   ' Browser Objektvariable erzeugen

   Set objIE = Me.objBrowser

  

   ' Pfad zum Zwischenspeichern der HTML-Seite erzeugen

   strTemp = Environ("Temp") & "\MyRoute66.html"

  

   ' Vorhandene HTML-Seite im Temp-Ordner löschen

   If Dir(strTemp) <> "" Then Kill strTemp

  

   ' HTML-Seite im Temp-Ordner anlegen

   Open strTemp For Binary As #1

      Put #1, , GetRouteHTML(strStart, strDest)

   Close #1

  

   ' HTML-Seite anzeigen

   objIE.Navigate strTemp

 

End Sub

 

Private Function GetRouteHTML( _

   Optional Home As String, _

   Optional Dest As String _

   ) As String

   Dim i         As Long

   Dim strOutPut As String

   Dim x()       As String

   ' HTML-Seite mit Scriptcode erzeugen

  

   ReDim x(1 To 86)

   If Home = "" Then

      ' Defaultwert zum Testen

      Home = "Kaiserstrasse 1,61169 Friedberg, Germany"

   End If

  

   If Dest = "" Then

      ' Defaultwert

      Dest = "Am Wehrturm 3 ,34134 Kassel , Germany"

   End If

  

   x(1) = ""

   x(2) = "

      " content=""text/html;charset=utf-8"">"

   x(3) = ""

   x(4) = ""

   x(5) = ""

   x(7) = ""

   x(80) = ""

   x(81) = ""

   x(82) = "

"

   x(83) = "

      "width:100%;"">

"

   x(84) = "

"

   x(85) = ""

   x(86) = ""

   For i = 1 To 86

      strOutPut = strOutPut & x(i) & vbCrLf

   Next

   GetRouteHTML = strOutPut

End Function

 

Private Sub cmdPrint_Click()

   Dim objMyBrowser  As Object

   Dim strBody       As String

   Dim varBody       As Variant

   Dim i             As Long

  

   On Error GoTo ErrorHandler

  

   ' Ausgabebereich löschen

   Me.Range("G8:G1000").Clear

 

   ' Browser Objektvariable erzeugen

   Set objMyBrowser = Me.objBrowser

  

   ' HTML-Code auslesen

   strBody = objMyBrowser.document.body.innerHTML

  

   ' Bereich mit der Route

   strBody = Left(strBody, InStr(1, strBody, _

      "

") - 1)

     

   ' Route übersetzen und in ein Array umwandeln

   strBody = Replace(strBody, "

", "")

   strBody = TranslateRoute(strBody)

   varBody = Split(strBody, "  

  

   ' Ausgeben

   For i = 1 To UBound(varBody)

      Me.Cells(i + 7, 7) = Split(varBody(i), ">")(1)

   Next

  

   Exit Sub

ErrorHandler:

 

  

End Sub

 

Private Sub cmdTranslate_Click()

   Dim objMyBrowser  As Object

   Dim strBody       As String

 

   On Error Resume Next

  

   ' Browser Objektvariable erzeugen

   Set objMyBrowser = Me.objBrowser

  

   ' HTML-Text auslesen

   strBody = objMyBrowser.document.body.innerHTML

  

   ' Übersetzen

   strBody = TranslateRoute(strBody)

   

   ' Zurückschreiben. VORSICHT, eine weitere Navigation

   ' in der aktuellen Session ist nicht möglich

   objMyBrowser.document.body.innerHTML = strBody

  

End Sub

 

Private Function TranslateRoute( _

   ByVal strBody As String _

   ) As String

   strBody = Replace(strBody, "Start at", "Beginn")

   strBody = Replace(strBody, "Depart", "Losfahren")

   strBody = Replace(strBody, "Turn", "Abbiegen nach")

   strBody = Replace(strBody, " LEFT ", " LINKS ")

   strBody = Replace(strBody, " RIGHT ", " RECHTS ")

   strBody = Replace(strBody, "Take exit", "Abfahren")

   strBody = Replace(strBody, "At exit", "An der Abfahrt")

   strBody = Replace(strBody, "Take ramp", "Ausfahrt nehmen")

   strBody = Replace(strBody, "take ramp", "Ausfahrt nehmen")

   strBody = Replace(strBody, "Merge onto", "Wechseln in Richtung")

   strBody = Replace(strBody, "Arrive at", "Ankunft")

   strBody = Replace(strBody, " onto ", " Richtung ")

   strBody = Replace(strBody, " toward ", " nach ")

   strBody = Replace(strBody, "(northeast)", "(Nordost)")

   strBody = Replace(strBody, "(northwest)", "(Nordwest)")

   strBody = Replace(strBody, "(southeast)", "(Südost)")

   strBody = Replace(strBody, "(southwest)", "(Südwest)")

   strBody = Replace(strBody, "(north)", "(Norden)")

   strBody = Replace(strBody, "(east)", "(Osten)")

   strBody = Replace(strBody, "(south)", "(Süden)")

   strBody = Replace(strBody, "(west)", "(Westen)")

   strBody = Replace(strBody, " STRAIGHT ", " GERADEAUS ")

   strBody = Replace(strBody, " to stay on ", " auf die ")

   strBody = Replace(strBody, " to ", " auf die ")

   TranslateRoute = strBody

End Function