VBA Function to get text driving directions from XML web page

Reference Needed: Microsoft XML, V6.0

Function TextDirectionsXML(StartAddress As String, EndAddress As String) As String
On Error GoTo ErrMsg
dteStartTime = Now()
'populate addresses
strStartAddress = StartAddress
strEndAddress = EndAddress

' check google.com using xml
Dim xSite As XMLHTTP60
Set xSite = New XMLHTTP60
xSite.Open "GET", "http://maps.google.com/maps?q=from+" & strStartAddress & "+to+" & strEndAddress & "&output=kml", False
xSite.Send
Do Until xSite.readyState = 4
Loop

'MsgBox xSite.getAllResponseHeaders
'MsgBox xSite.getResponseHeader("Last-Modified")
'MsgBox "Status Text: " & xSite.statusText & vbCr & vbCr & "Status: " & xSite.Status
'MsgBox xSite.responseText


Dim xml_doc As New DOMDocument
Dim nde_Placemark As IXMLDOMNode
'Dim nde_Dividend As IXMLDOMNode
xml_doc.loadXML (xSite.responseText) ' response text is the xml file being returned

i = 1
DriveDirection = ""

'Looop through node
For Each nde_Placemark In xml_doc.selectNodes("//Placemark")

str_Phrase = nde_Placemark.childNodes(0).Text
str_DistanceTime = nde_Placemark.childNodes(1).Text
If str_Phrase = "Route" Then
str_Phrase = ""
If InStr(str_DistanceTime, "&") <> 0 Then
If InStr(str_DistanceTime, "hour") > 1 Then
'time is at least 1 hour
pos1 = InStr(str_DistanceTime, "about")
pos2 = InStr(str_DistanceTime, "hours")
intHours = Mid(str_DistanceTime, pos1 + 6, pos2 - pos1 - 7)
pos1 = InStr(str_DistanceTime, "hours")
pos2 = InStr(str_DistanceTime, "mins")
intMinutes = Mid(str_DistanceTime, pos1 + 6, pos2 - pos1 - 7)
IntTotalMinutes = intHours * 60 + intMinutes
Else
'time is less than 1 hour
intHours = 0
pos1 = InStr(str_DistanceTime, "about")
pos2 = InStr(str_DistanceTime, "mins")
intMinutes = Mid(str_DistanceTime, pos1 + 6, pos2 - pos1 - 7)
IntTotalMinutes = intHours * 60 + intMinutes
End If

intDistanceValue = Mid(str_DistanceTime, 11, InStr(str_DistanceTime, "&") - 11)
intDistanceUnit = Mid(str_DistanceTime, InStr(str_DistanceTime, ";") + 1, 2)
strTotalMiles = intDistanceValue & intDistanceUnit
intSpeed = (intDistanceValue / IntTotalMinutes) * 60
Else
MilesUnits = ""
End If

Else
If InStr(str_DistanceTime, "&") <> 0 Then
intDistanceValue = Mid(str_DistanceTime, 4, InStr(str_DistanceTime, "&") - 4)
intDistanceUnit = Mid(str_DistanceTime, InStr(str_DistanceTime, ";") + 1, Len(str_DistanceTime))
strTotalMiles = " (Go " & intDistanceValue & intDistanceUnit & ")"
Else
MilesUnits = ""
End If

End If

If i = 1 Then Str_AddressBeg = nde_Placemark.childNodes(2).Text

If str_Phrase <> "" Then
If Left(str_Phrase, 6) = "Arrive" Then
Str_AddressEnd = nde_Placemark.childNodes(1).Text
DriveDirection = DriveDirection & i & "." & str_Phrase & vbCrLf
Else
DriveDirection = DriveDirection & i & "." & str_Phrase & strTotalMiles & vbCrLf
End If

Else
DriveDirection = DriveDirection
End If

i = i + 1
Next

dteEndTime = Now()
dteRunTime = "(" & Format(dteEndTime - dteStartTime, "s") & " Second(s))"
Header = "Retreived: " & Format(Now(), "m/d/yy, h:mma/p")
TextDirectionsXML = DriveDirection & vbCrLf & _
"Distance: " & strTotalMiles & vbCrLf & _
"Travel Time: " & intHours & ":" & intMinutes & vbCrLf & _
"Speed: " & Format(intSpeed, "#,##0.0 mph") & vbCrLf & _
"Est Time To Deliver: " & Format(TimeValue(TimeSerial(0, i * 1 + (IntTotalMinutes * 2) + 15, 0)), "h:mm") & vbCrLf & _
Str_AddressBeg & vbCrLf & _
Str_AddressEnd & vbCrLf


' Header & " " & dteRunTime & vbCrLf & _
' "ettd: " & i * 1 + (IntTotalMinutes * 2) + 15


Exit Function
ErrMsg:

TextDirectionsXML = ""
Exit Function

End Function

http://www.tek-tips.com/viewthread.cfm?qid=1444524&page=8
http://groups.google.com/group/Google-Maps-API/msg/4dc2fad4f74e3314