AW: Problem mit Reiseplanung.de
12.10.2010 09:21:55
Christian
Dim Von_PLZ As String
Dim Nach_PLZ As String
Dim Von_Ort As String
Dim Nach_Ort As String
Dim Von_Strasse As String
Dim Nach_Strasse As String
Dim wks As Worksheet
Function Entfernung_map2(Von_PLZ, Von_Ort, Von_Strasse)
Dim IEApp As Object
Dim IEDoc As Object
Dim teile, teilen, i, k, l, minuten As Integer
Dim intLastRow As Integer
Application.Calculation = xlCalculationManual
'Internet Explorer starten
Set IEApp = CreateObject("InternetExplorer.Application")
'Internet Explorer ausblenden
IEApp.Visible = False
Set wks = ThisWorkbook.Worksheets("Lieferant")
intLastRow = wks.Range("A5000").End(xlUp).Row
' Spalten Entfernung und Fahrtzeit löschen
wks.Range(Cells(3, 8), Cells(5000, 9)).ClearContents
For k = 3 To intLastRow
' Fortschritt der ProgressBar
'If k Mod 1 = 0 Then
ProgressBar.ProgressBar k / intLastRow
'Lieferantenadresse übergeben
Nach_PLZ = wks.Cells(k, 5).Value
Nach_Ort = wks.Cells(k, 6).Value
Nach_Strasse = wks.Cells(k, 4).Value
'Route aufrufen
sUrl = "http://rs.ptv.de/emr/routing.asp?LNG=D&UC=&ID=BINFO&IDS=&DEBUGI=False&SP=" & _
Von_PLZ & "&SO=" & Von_Ort & "&SS=" & Von_Strasse & _
"&ZP=" & Nach_PLZ & "&ZO=" & Nach_Ort & "&ZS=" & _
Nach_Strasse & "&SPD=PKWL&ROUTE=Route+berechnen"
IEApp.Navigate sUrl
Do: Loop Until IEApp.Busy = False
Do: Loop Until IEApp.Busy = False
Set IEDoc = IEApp.Document
Do: Loop Until IEDoc.ReadyState = "complete"
teile = Split(IEDoc.body.innertext, vbCrLf)
l = 0
minuten = 0
If teile(8) "" Then
teilen = Split(teile(8), " ")
For i = LBound(teilen) To UBound(teilen)
If IsNumeric(teilen(i)) And teilen(i + 1) "nach" And teilen(i + 1) "ist" Then
If l = 0 Then
wks.Cells(k, 8).Value = teilen(i)
l = 1
Else
If l = 1 Then
minuten = teilen(i) * 60
l = 2
Else
minuten = minuten + teilen(i)
wks.Cells(k, 9).Value = minuten
Exit For
End If
End If
End If
Next
' Else
' IEApp.Visible = True
End If
Set IEDoc = Nothing
Next k
Application.Calculation = xlCalculationAutomatic
IEApp.Quit
Set IEApp = Nothing
Unload ProgressDlg
End Function