ich habe diese vorgefertigte Datei zur Berechnung von Entfernungskilometern (von User Tino vor geraumer Zeit programmiert) gefunden und leider funktioniert diese nicht mehr, weil folgende weiter unten fett markierte Anweisung keine Gültigkeit mehr hat. (URL-Daten wurden von Google-Maps wohl überarbeitet)
Hat jemand eine Lösung, wie man dieses sehr nützliche Programm auf den aktuellen Stand der Dinge bringen kann und es wieder zum Laufen bringt?
Bin euch wahnsinnig dankbar für jede Hilfe.
Unten der Programmiercode mit der Problemstelle (aus meiner Sicht!)
Datei anbei: https://www.herber.de/bbs/user/90486.xls
Option Explicit
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Sub LeseEntfernung()
Dim appIE As Object
Dim strStart As String, strHTML As String, tempHTML
Dim ZielAdress As Range, strErr As String
Dim A As Long, lngAnzahl As Long
If Range("A2") = "" Then Exit Sub
strStart = Range("A2")
Range("B2:C3", "B5:C" & Rows.Count).ClearContents
Set appIE = CreateObject("InternetExplorer.application")
appIE.Visible = False 'False ist unsichtbar True ist Sichtbar
On Error GoTo Fehler:
For A = ActiveSheet.Shapes.Count To 1 Step -1
If InStr(ActiveSheet.Shapes(A).Name, "Karte") > 0 Then ActiveSheet.Shapes(A).Delete
Next A
For Each ZielAdress In Range("A5", Cells(Rows.Count, 1).End(xlUp))
A = 0
If ZielAdress > "" Then
appIE.Navigate "http://maps.google.de/maps?saddr=" & strStart & "&daddr=" & ZielAdress & "& _
output=html"
While Not appIE.ReadyState = 4 'Warte auf Webseite
Sleep (20)
A = A + 1
If A > 500 Then '10 Sekunden warten auf webseite
strErr = "Webseite konnte nicht geöffnet werden!"
GoTo Fehler
End If
DoEvents
Wend
Sleep (50)
tempHTML = appIE.Document.body.InnerHtml
If InStr(tempHTML, "ist unbekannt") > 0 Or InStr(tempHTML, "Meinten Sie") > 0 Then
ZielAdress.Offset(0, 2) = "unbekannt"
GoTo NächstePLZ
End If
If Range("B1") = "" Then
strHTML = tempHTML
' Debug.Print tempHTML
If IsNumeric(strStart) Then
strHTML = Right$(strHTML, Len(strHTML) - InStr(strHTML, "sa dir=ltr>" & strStart) - 16) _
Else
strHTML = Right$(strHTML, Len(strHTML) - InStr(strHTML, "sa dir=ltr>" & strStart & "") - 1)
If InStr(strHTML, ">") > 0 Or InStr(strHTML, " 0 Then strHTML = ""
Range("C2") = Trim$(strHTML)
End If
strHTML = tempHTML
strHTML = Right$(strHTML, Len(strHTML) - InStr(strHTML, "Fahrt:") - 4)
strHTML = Left$(strHTML, InStr(strHTML, " "))
strHTML = Trim$(Replace(strHTML, " ", " "))
ZielAdress.Offset(0, 1) = strHTML
strHTML = tempHTML
If IsNumeric(ZielAdress) Then
strHTML = Right$(strHTML, Len(strHTML) - InStr(strHTML, "sa dir=ltr>" & ZielAdress) - 16)
Else
strHTML = Right$(strHTML, Len(strHTML) - InStr(strHTML, "sa dir=ltr>" & ZielAdress & "") - 1)
If InStr(strHTML, ">") > 0 Or InStr(strHTML, " 0 Then strHTML = "kein Ort"
ZielAdress.Offset(0, 2) = Trim$(strHTML)
ErstelleButton (ZielAdress.Offset(0, 3).Address)
End If
NächstePLZ:
lngAnzahl = lngAnzahl + 1
Call MeinBalken(Cells(Rows.Count, 1).End(xlUp).Row - 4, lngAnzahl)
Next ZielAdress
Application.Calculate
If appIE > "" Then appIE.Quit
Set appIE = Nothing
UserForm2.Hide
MsgBox "Alle Entfernungen ermittelt", vbInformation, "Webdaten gelesen"
Exit Sub
Fehler:
UserForm2.Hide
If Err.Number 0 Then MsgBox Err.Description, vbCritical, "Fehler!!"
If strErr > "" Then MsgBox strErr, vbCritical, "Fehler!!"
If appIE > "" Then appIE.Quit
Set appIE = Nothing
End Sub
Sub MeinBalken(GesA As Long, Anzahl As Long)
Dim Breite As Single
Breite = (378 / GesA) * Anzahl
With UserForm2
.Label1.Width = Breite
.Repaint
End With
End Sub
LG Hans