Thread: Google Maps Driving Times Part 2

Previous thread: http://www.excelforum.com/excel-gene...ing-times.html

I am using the VBA in the above thread as an add-in. It worked great up until around the end of 2011 and it no longer works. It now gives 0 for distance and time. I have tried to do some digging in the VBA/HTML from google but I could not come up with anything. Is anyone else experiencing this problem or knows how to fix it?

Welcome to the forum! I got the XML text and parsed that rather than HTML text . This is similar to your referenced link but gets both distance and time. You may want to visit the link to get the workbook that you can test this code with. The link where I posted that below is at: http://www.vbaexpress.com/forum/showthread.php?t=33373

 ' Google API code directions:
 ' http://code.google.com/apis/maps/documentation/directions/
 
 '=GoogleDistanceTime(A4,B4,C4,D4,E4,F4,G4,H4)
Public Function GoogleDistanceTime(startAddr As String, StartCity As String, _ 
    startState As String, StartZip As String, endAddr As String, _ 
    EndCity As String, endState As String, EndZip As String) As String 
     
    Dim xml As String, sDistance As String, sDuration As String 
    Dim sURL As String 
    Dim s As String, _ 
    d As String, _ 
    t As String 
     
     'http://maps.googleapis.com/maps/api/directions/xml?origin=Chicago,IL&destination=Los+Angeles,CA&waypoints=Joplin,MO|Oklahoma+City,OK&sensor=false
    sURL = "http://maps.googleapis.com/maps/api/directions/xml?origin=" 
    sURL = sURL & Replace(startAddr, " ", "+") & ",+" & Replace(StartCity, " ", "+") & ",+" & startState 
    sURL = sURL & "&destination=" & Replace(endAddr, " ", "+") & ",+" & Replace(EndCity, " ", "+") & ",+" & endState 
    sURL = sURL & "&sensor=false" 
     
    Application.Volatile False 
     
    xml = getXML(sURL) 
    sDistance = pGoog("distance", xml) 
    sDuration = pGoog("duration", xml) 
    GoogleDistanceTime = sDistance & " / " & sDuration 
End Function 
 
Private Function getXML(strURL As String) As String 
    Dim HTTPreq As Object 
    Dim BodyTxt As String 
     
     'Set HTTPreq = CreateObject("msxml2.xmlhttp")
    Set HTTPreq = CreateObject("WinHttp.WinHttpRequest.5.1") 
    With HTTPreq 
        .Open "GET", strURL, False 
        .send 
        .WaitForResponse 
        BodyTxt = .responseText 
    End With 
    Set HTTPreq = Nothing 
    getXML = BodyTxt 
End Function 
 
Private Function pGoog(strSearch As String, strHTML As String) As String 
    Dim s As String 
    s = pRevTags(strSearch, strHTML) 
    pGoog = pRevTags("text", s) 
End Function 
 
Private Function pRevTags(strSearch As String, strHTML As String) As String 
    Dim s As String, p1 As Long, p2 As Long, lss As Integer 
    p1 = InStrRev(strHTML, "<" & strSearch & ">") 
    If p1 = 0 Then 
        pRevTags = "Not Found" 
        Exit Function 
    End If 
    p2 = InStrRev(strHTML, "</" & strSearch & ">") 
    lss = Len(strSearch) 
    s = Mid(strHTML, p1 + lss + 2, p2 - p1 - 2 - lss) 
    pRevTags = s 
End Function

First off, thanks for a tremendous macro!

I've hit two sticking points in using the macro and I'm hoping someone can provide insight...
I’m trying to calculate the driving miles and time between two addresses using the macro posted in this thread. (This macro is wrapped in a sub that will feed it about 20,000 address pairs.) I’m having two issues described below:

Issue #1 – when I run the macro from home:
The macro was running beautifully last night from home until after about 2,000 successes. After that time, the macro started returning ‘Not Found’ for both the driving miles and time for all submissions. I am able to capture the miles & time manually be going to the website and entering the origin / destination addresses so the addresses are valid. (In addition, the macro did return valid miles/times for other address pairs that used the same origin & destination.)

Issue #2 – when I run the macro from work:
I get the following error: ‘A connection with the server could not be established’. This error occurs at the following line of code:
HTTPreq.send
If I paste the sURL variable from the code into the address line of an Explorer session, I do get a valid return so I’m not sure what’s happening.

Any help is appreciated.

Thanks,
Stu

Welcome to the forum!

With that many, you might try just running a macro that does it for the range of cells rather than as a UDF. You may need some Application.Wait times or DoEvents. The intent of the UDF is that it would only update if the data changes. Processing many at once to catch up could be staged if needed.

For the work issue, you might want to check that you have winhttp v5.1. In VBE, you can look for Tools > References... > Microsoft WinHTTP Request Services, version 5.1. You may only have 5.0 which is easily changed in the code.

Kenneth,

Thank you for the welcome and it's nice to be able to thank you directly for this macro you've posted. It's very helpful.
Regarding my work situation, I do have version 5.1 so I don't think that's driving the issue at work.

Regarding running the large number, is there somewhere in my code (see posted below) that I would add a wait times or do events, or would I add that to your macro.

Below is the code I've used to wrap your macro.
Any insight you can offer is appreciated.
Thanks again!!!
Stu

PHP Code: 

Sub GetDriveMiles()
Dim ws As Worksheet
Dim rg As Range, rgDC As Range, rgStore As Range
Dim sStartAddr As String
Dim sStartCity As String
Dim sStartState As String
Dim sStartZip As String
Dim sEndAddr As String
Dim sEndCity As String
Dim sEndState As String
Dim sEndZip As String
Dim sDistance As String

With cStoreAddr
    Set rg = .Range("A1")
    Set rgDC = .Range("rgDC")
    Set rgStore = .Range("rgStore")
End With

Do Until IsEmpty(rgDC)
    sStartAddr = rgDC
    sStartCity = rgDC.Offset(1, 0)
    sStartState = rgDC.Offset(2, 0)
    sStartZip = rgDC.Offset(3, 0)
    
    Do Until IsEmpty(rgStore)
        sEndAddr = rgStore.Offset(0, 1)
        sEndCity = rgStore.Offset(0, 2)
        sEndState = rgStore.Offset(0, 3)
        sEndZip = rgStore.Offset(0, 4)
        sDistance = GoogleDistanceTime(sStartAddr, sStartCity, sStartState, sStartZip, sEndAddr, sEndCity, sEndState, sEndZip)
        cStoreAddr.Cells(rgStore.Row, rgDC.Column).Value = sDistance
        Set rgStore = rgStore.Offset(1, 0)
    Loop
    
    Set rgDC = rgDC.Offset(0, 1)
    If Not IsEmpty(rgDC) Then
        Set rgStore = cStoreAddr.Range("rgStore")
    End If
Loop
    
End Sub 


I was able to resolve issue #2 above. (I now realize I should have posted two separate issues)

To solve #2 I changed the getXML function to use "Microsoft.XMLHTTP" instead of "WinHttp.WinHttpRequest.5.1". I also had to take out the .WaitForResponse statement (I'm guessing it's not part of that object model). See the function below.

As with my original attempt, this one worked for about 1,500 submissions or so, then it just started returning 'Not Found' for Mileage and Distance. I appreciate any insight on resolving this issue.

Thanks,
Stu

PHP Code: 

Private Function getXML(strURL As String) As String
    Dim HTTPreq As Object
    Dim BodyTxt As String
    Set HTTPreq = CreateObject("Microsoft.XMLHTTP")
    With HTTPreq
        .Open "GET", strURL, False
        .send
        BodyTxt = .responseText
    End With
    Set HTTPreq = Nothing
    getXML = BodyTxt
End Function