Automation error when running Excel VBA

Question

Hi,

I have this VBA code which does the distance calculation between points. The code has been running properly for the past few years, until today where this error message keeps popping up when I run the code.

It is quite disappointing to see that this error message is not very helpful.

Please give me some guidance on how to resolve this.

Thank you very much.

HP

Answer 1

Show us your code.

Andreas.

Answer 2

Hi Andreas,

Thank you for helping out. This is the code:

+Credit to Desmond Oshiwambo for sharing this code around.

Public gDistance As String
Public gTravelTime As String
Const strUnits = "metric" ' imperial/metric (miles/km)

' Usage :
' GetGoogleTravelTime (strFrom, strTo) returns a string containing journey duration : hh:mm
' GetGoogleDistance (strFrom, strTo) returns a string containing journey distance in either miles or km (as defined by strUnits)
' GetGoogleDirections (strFrom, strTo) returns a string containing the directions
'
' where strFrom/To are address search terms recognisable by Google
' i.e. Postcode, address etc.
'
' by Desmond Oshiwambo

Public Sub GetTimeDistance()
    Dim row As Long
    Dim col As Integer
    Dim fromID As String
    Dim toID As String
    Dim count As Integer
    Dim ws As Worksheet
    
    Set ws = Sheets("OD Matrix")
    count = 1
    row = 2
    col = 8
    fromID = ws.Cells(row, col).Value
    toID = ws.Cells(row, col + 1).Value
    ws.Activate
     While (fromID <> "")
            While (ws.Cells(row, 4).Value <> "")
                If (ws.Cells(row, col - 1).Value = "") Then
                    Call getGoogleDistance(fromID, toID)
                    If (IsNumeric(gDistance)) Then
                        'Do Nothing
                    Else
                        MsgBox ("Error: " & gDistance & " Please check and try again")
                        Exit Sub
                    End If
                    ws.Cells(row, col - 1).Activate
                    ws.Cells(row, col - 1).Value = gDistance
                    ws.Cells(row, col - 2).Activate
                    ws.Cells(row, col - 2).Value = gTravelTime
                    ws.Cells(row, col + 2).Value = count
                    row = row + 1
                    count = count + 1
                   'Application.Wait (Now + TimeValue("00:00:01"))
                Else
                    row = row + 1
                End If
                fromID = ws.Cells(row, col).Value
                toID = ws.Cells(row, col + 1).Value
            Wend
            fromID = ""
    Wend
End Sub
Function CleanHTML(ByVal strHTML)
'Helper function to clean HTML instructions
Dim strInstrArr1() As String
Dim strInstrArr2() As String
Dim s As Integer

strInstrArr1 = Split(strHTML, "<")
For s = LBound(strInstrArr1) To UBound(strInstrArr1)
   strInstrArr2 = Split(strInstrArr1(s), ">")
   If UBound(strInstrArr2) > 0 Then
        strInstrArr1(s) = strInstrArr2(1)
   Else
        strInstrArr1(s) = strInstrArr2(0)
   End If
Next
 
CleanHTML = Join(strInstrArr1)
End Function

Public Function formatGoogleTime(ByVal lngSeconds As Double)
'Helper function. Google returns the time in seconds, so this converts it into time format hh:mm
 
Dim lngMinutes As Long
Dim lngHours As Long
 
lngMinutes = Fix(lngSeconds / 60)
lngHours = Fix(lngMinutes / 60)
lngMinutes = lngMinutes - (lngHours * 60)
 
formatGoogleTime = Format(lngHours, "00") & ":" & Format(lngMinutes, "00")
End Function

Function gglDirectionsResponse(ByVal strStartLocation, ByVal strEndLocation, ByRef strTravelTime, ByRef strDistance, ByRef strInstructions, Optional ByRef strError = "") As Boolean
On Error GoTo errorHandler
' Helper function to request and process XML generated by Google Maps.

Dim strURL As String
Dim objXMLHttp As Object
Dim objDOMDocument As Object
Dim nodeRoute As Object
Dim lngDistance As Long
Dim sig As String
Dim encText As String
Dim secret As String
Dim Pr As String

mykey= "XXXXXXXX"

Set objXMLHttp = CreateObject("MSXML2.XMLHTTP")
Set objDOMDocument = CreateObject("MSXML2.DOMDocument.6.0")
 
strStartLocation = Replace(strStartLocation, " ", "+")
strEndLocation = Replace(strEndLocation, " ", "+")
 
encText = "/maps/api/directions/xml" & _
            "?origin=" & strStartLocation & _
            "&destination=" & strEndLocation & _
            "&sensor=false" & _
            "&units=" & strUnits & _
            "&client=YYYYYYYYYY" & _
            "&avoid=ferries"
            'Sensor field is required by google and indicates whether a Geo-sensor is being used by the device making the request

sig = Base64_HMACSHA1(encText, mykey)

strURL = "https://maps.googleapis.com" & encText & "&signature=" & sig

'Send XML request
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
        'Get Distance
        lngDistance = .SelectSingleNode("/DirectionsResponse/route/leg/distance/value").Text ' 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
        
        'Get Travel Time
        strTravelTime = .SelectSingleNode("/DirectionsResponse/route/leg/duration/value").Text  'returns in seconds from google
        strTravelTime = formatGoogleTime(strTravelTime) 'converts seconds to hh:mm
        
        'Get Directions
        'For Each nodeRoute In .SelectSingleNode("//route/leg").ChildNodes
        '    If nodeRoute.BaseName = "step" Then
        '        strInstructions = strInstructions & nodeRoute.SelectSingleNode("html_instructions").Text & " - " & nodeRoute.SelectSingleNode("distance/text").Text & vbCrLf
        '    End If
        'Next
        
        'strInstructions = CleanHTML(strInstructions) 'Removes MetaTag information from HTML result to convert to plain text.
        
    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

Function getGoogleTravelTime(ByVal strFrom, ByVal strTo) As String
'Returns the journey time between strFrom and strTo
 
Dim strTravelTime As String
Dim strDistance As String
Dim strInstructions As String
Dim strError As String

If gglDirectionsResponse(strFrom, strTo, strTravelTime, strDistance, strInstructions, strError) Then
    getGoogleTravelTime = strTravelTime
Else
    getGoogleTravelTime = strError
End If
 
End Function
 
Public Sub getGoogleDistance(ByVal strFrom, ByVal strTo)
'Returns the distance between strFrom and strTo
'where strFrom/To are address search terms recognisable by Google
'i.e. Postcode, address etc.
 
Dim strTravelTime As String
Dim strDistance As String
Dim strError As String
Dim strInstructions As String

If gglDirectionsResponse(strFrom, strTo, strTravelTime, strDistance, strInstructions, strError) Then
    gDistance = strDistance
    gTravelTime = strTravelTime
Else
    gDistance = strError
    gTravelTime = strError
End If
 
End Sub

Function getGoogleDirections(ByVal strFrom, ByVal strTo) As String
'Returns the directions between strFrom and strTo
'where strFrom/To are address search terms recognisable by Google
'i.e. Postcode, address etc.
 
Dim strTravelTime As String
Dim strDistance As String
Dim strError As String
Dim strInstructions As String

If gglDirectionsResponse(strFrom, strTo, strTravelTime, strDistance, strInstructions, strError) Then
    getGoogleDirections = strInstructions
Else
    getGoogleDirections = strError
End If
 
End Function

Function IsTime(rng As Range) As Boolean
    Dim sValue As String
    sValue = rng.Cells(1).Text
    On Error Resume Next
    IsTime = IsDate(TimeValue(sValue))
    On Error GoTo 0
End Function

Public Function Base64_HMACSHA1(ByVal sTextToHash As String, ByVal sSharedSecretKey As String)

    Dim asc As Object
    Dim enc As Object
    Dim TextToHash() As Byte
    Dim SharedSecretKey() As Byte
    Dim bytes() As Byte
    
    Set asc = CreateObject("System.Text.UTF8Encoding")
    Set enc = CreateObject("System.Security.Cryptography.HMACSHA1")
    
    ''Replace illegal Characters and decode base64 string
    sSharedSecretKey = Replace(Replace(sSharedSecretKey, "-", "+"), "_", "/")
    SharedSecretKey = DecodeBase64(sSharedSecretKey)
    enc.Key = SharedSecretKey
    
    TextToHash = asc.Getbytes_4(sTextToHash)
    
    bytes = enc.ComputeHash_2(TextToHash)
    Base64_HMACSHA1 = Replace(Replace(EncodeBase64(bytes), "+", "-"), "/", "_")

End Function

Answer 3

The error is not due to Excel, your code creates objects from external DLLs and furthermore calls a web service from Google.

Anywhere there is the issue. You have to debug the code to find out where exactly the error is generated. Here's a good tutorial how to do that and much more:

Excel Visual Basic Tutorial - VBA Macros Online Training

After you find the source of the error you can investigate further if a solution exists. From my experience, it's the web services, these are usually changed by the provider after some time or are completely discontinued.

I'm sorry, I don't have time to help you with this.

Andreas.