Excel vba - Query to Google maps over limit

Question

I'm trying to get distances from google maps through VBA. This portion of code is in a loop so it computes quite a few distances in a short period of time, which is why I tried to add a way to deal with the query over time. I'm using parts of code by Desmond Oshiwambo.

Option Explicit

Const strUnits = "metric" ' imperial/metric (miles/km)
Const strTransportMode = "driving" ' alternative = 'walking'
Const strDelimeter = "|"    'for lists of via points
Const MAX_GOOGLE_RETRIES = 10

The first function is a helper function that gets the data from Google Maps.

Function gglDirectionsResponse(ByVal strStartLocation, ByVal strEndLocation, ByRef strTravelTime, ByRef strDistance, ByRef strInstructions, Optional ByRef strError = "") As Boolean
On Error GoTo ErrorHandler
Dim strURL As String
Dim objXMLHttp As Object
Dim objDOMDocument As Object
Dim nodeRoute As Object
Dim lngDistance As Long
Dim strThisLegDuration As String
Dim legRoute
Dim lngSeconds As Long

Set objXMLHttp = CreateObject("MSXML2.XMLHTTP")
Set objDOMDocument = CreateObject("MSXML2.DOMDocument.6.0")

strStartLocation = Replace(strStartLocation, " ", "+")
strEndLocation = Replace(strEndLocation, " ", "+")
strTravelTime = "00:00"
strURL = "http://maps.googleapis.com/maps/api/directions/xml" & _
        "?origin=" & strStartLocation & _
        "&destination=" & strEndLocation & _
        "&sensor=false" & _
        "&units=" & strUnits  
With objXMLHttp
    .Open "GET", strURL, False
    .setRequestHeader "Content-Type", "application/x-www-form-URLEncoded"
    .send
    objDOMDocument.LoadXML .responseText
End With

With objDOMDocument
    If .SelectSingleNode("//status").Text = "OK" Then

    'Iterate through each leg

        For Each legRoute In .SelectSingleNode("//route").ChildNodes
            If legRoute.BaseName = "leg" Then         'SelectSingleNode("/distance/value").Text
                  For Each nodeRoute In legRoute.ChildNodes
                    If nodeRoute.BaseName = "step" Then
                       lngDistance = lngDistance +     nodeRoute.SelectSingleNode("distance/value").Text    ' Retrieves distance in meters
                       lngSeconds = lngSeconds +     Val(nodeRoute.SelectSingleNode("duration/value").Text)
                    End If
                  Next
            End If
        Next

        strTravelTime = formatGoogleTime(lngSeconds)    ' Retrieves distance in meters


        Select Case strUnits
            Case "imperial": strDistance = Round(lngDistance * 0.00062137, 1)  'Convert meters to miles
            Case "metric": strDistance = Round(lngDistance / 1000, 1) 'Convert meters to miles
        End Select

    Else
        strError = .SelectSingleNode("//status").Text
        GoTo ErrorHandler
    End If
End With

gglDirectionsResponse = True
GoTo CleanExit

ErrorHandler:
    If strError = "" Then strError = Err.Description
    strDistance = -1
    strTravelTime = "00:00"
    strInstructions = ""
    gglDirectionsResponse = False

CleanExit:
    Set objDOMDocument = Nothing
    Set objXMLHttp = Nothing

End Function

The second function is where I tried to implement "wait until query limit is over". This doesn't work because 70% of the values that the function returns to me are -1 (error value).

Function getGoogleDistance(ByVal strFrom, ByVal strTo) As String
Dim strDistance As String
Dim strTravelTime As String
Dim blnOverLimit As Boolean
Dim lngStartTimer As Long
Dim lngQueryCount As Long
Dim lngQueryPauses As Long
Dim strInstructions As String
Dim strError As String
Dim lngRetries As Long


lngStartTimer = Timer
lngQueryCount = 0
lngRetries = 0
Application.DisplayStatusBar = True
 If gglDirectionsResponse(strFrom, strTo, strTravelTime, strDistance, strInstructions, strError) Then
 Do             
                blnOverLimit = False
                If (strDistance = "OVER_QUERY_LIMIT") Then
                ' Google has maxed out, wait a couple of seconds and try again.
                    Application.StatusBar = "Waiting 3 second for Google overload"
                    Application.Wait Now + TimeValue("00:00:03")  ' pause 2 seconds
                    Application.StatusBar = "Try again"

                    lngQueryPauses = lngQueryPauses + 1
                    blnOverLimit = True
                    lngRetries = lngRetries + 1
                Else
                    If (strError = "") And (Val(strDistance) > 0) Then
                        Application.StatusBar = "Processed "
                        lngQueryCount = lngQueryCount + 1
                    End If
                End If

                If lngRetries > MAX_GOOGLE_RETRIES Then
                    ' the Google per day allowance hase been reached
                GoTo GoogleTooManyQueries
                End If

            Loop Until Not blnOverLimit  ' Over Limit either means too many queries too fast, or that the per day allowance has been reached

            If (strDistance <> "INVALID_REQUEST") Then
                getGoogleDistance = strDistance

            End If

Else
    getGoogleDistance = -1
End If
CleanExit:
    Application.StatusBar = "Finished"
    Exit Function

GoogleTooManyQueries:
    MsgBox "Sorry, Google limit of 2000 queries per day has been reached. This may take upto 24 hours to reset", vbCritical
    Exit Function

ErrorHandler:
    MsgBox "Error :" & Err.Description, vbCritical
    Exit Function

End Function

If any one can figure out why the code isn't being "slowed down" I'd greatly appreciate it.

Answer 1

I entered a list of addresses from this link.

https://gist.github.com/HeroicEric/1102788

The time to finish calculating was around 60 seconds, on a T430 Thinkpad (it's pretty old).

'Calculate Google Maps distance between two addresses
Public Function GetDistance(start As String, dest As String)
    Dim firstVal As String, secondVal As String, lastVal As String
    firstVal = "http://maps.googleapis.com/maps/api/distancematrix/json?origins="
    secondVal = "&destinations="
    lastVal = "&mode=car&language=pl&sensor=false"
    Set objHTTP = CreateObject("MSXML2.ServerXMLHTTP")
    URL = firstVal & Replace(start, " ", "+") & secondVal & Replace(dest, " ", "+") & lastVal
    objHTTP.Open "GET", URL, False
    objHTTP.setRequestHeader "User-Agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.0)"
    objHTTP.send ("")
    If InStr(objHTTP.responseText, """distance"" : {") = 0 Then GoTo ErrorHandl
    Set regex = CreateObject("VBScript.RegExp"): regex.Pattern = """value"".*?([0-9]+)": regex.Global = False
    Set matches = regex.Execute(objHTTP.responseText)
    tmpVal = Replace(matches(0).SubMatches(0), ".", Application.International(xlListSeparator))
    GetDistance = CDbl(tmpVal)
    Exit Function
ErrorHandl:
    GetDistance = -1
End Function