Skript zur Berechnung von EntfernungskilometernIII

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