Google Maps API - Distance Matrix on Microsoft Excel VB Module

[rasec_lc]

I've had this working on several spreadsheets for a long time, but yesterday the functions using Google's Distance Matrix API stop working.

I tested it on another network, different computers, created a new Key, a new project on Google Cloud and it still doesn't work.

Has anyone experienced this problem, could you give me an idea how to solve it?

Thank you very much..

*the key, I removed it from the code.

---------------------------

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 = "https://maps.googleapis.com/maps/api/distancematrix/json?origins="

secondVal = "&destinations="

lastVal = "&mode=car&language=pl&sensor=false&key=0000000000000000000000"

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

Public Function GetDuration(start As String, dest As String)

Dim firstVal As String, secondVal As String, lastVal As String

firstVal = "https://maps.googleapis.com/maps/api/distancematrix/json?origins="

secondVal = "&destinations="

lastVal = "&mode=car&language=en&sensor=false&key=0000000000000000000000"

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, """duration"" : {") = 0 Then GoTo ErrorHandl

Set regex = CreateObject("VBScript.RegExp"): regex.Pattern = "duration(?:.|\n)*?""value"".*?([0-9]+)": regex.Global = False

Set matches = regex.Execute(objHTTP.responseText)

tmpVal = Replace(matches(0).SubMatches(0), ".", Application.International(xlListSeparator))

GetDuration = CDbl(tmpVal)

Exit Function

ErrorHandl:

GetDuration = -1

End Function

Public Function MultiGetDistance(ParamArray args() As Variant) As Double

MultiGetDistance = 0

Dim startLoc As String, endLoc As String, i As Long

For i = LBound(args) To UBound(args) - 1

startLoc = args(i): endLoc = args(i + 1)

MultiGetDistance = MultiGetDistance + GetDistance(startLoc, endLoc)

Next i

End Function

Public Function MultiGetDuration(ParamArray args() As Variant) As Double

MultiGetDuration = 0

Dim startLoc As String, endLoc As String, i As Long

For i = LBound(args) To UBound(args) - 1

startLoc = args(i): endLoc = args(i + 1)

MultiGetDuration = MultiGetDuration + GetDuration(startLoc, endLoc)

Next i

End Function

[JR-DK]

Any solution? I have the same issue

[mvoelkerASC]

My users reported it broke on my spreadsheets as well... I did some testing as I thought it was the API key or my credit card expired.  I opened VBA editor and debugged against one line of code.  MsgBox = objHttp.responseText.

The response is valid as I tested it against  two good addresses.  The problem lies somewhere in vba.  I wonder if excel updates are at fault.  I had MS do this to me, not with an API, but pushing updates broke my code.  

I do not know the solution but figure I would post something to avoid you spinning your wheels.  Report back here if you figure something out.  I will do the same.

[mvoelkerASC]

I just verified that my Excel is on the latest version and this is the version.

Channel Version Build Latest release date Version availability date End of service

Current Channel

2307

16626.20170

August 8, 2023

July 23, 2023

Version 2308 is released

[rasec_lc]

I activated the debug module to check the error.
There is no error, the API brings the result between Point A and Point B with distance and duration. but something happens when it needs to be placed in the spreadsheet cell.

I'm looking for a solution, still can't do it.
now, it seems that this was due to a problem with VBA-JSON, the module that converts the result no longer works.

Does anyone have a solution for this?

[mvoelkerASC · Accepted solution]

I think I figured it out with one line of code.  It appears that the JSON response was slightly changed by the google API.  It was either  character spacing or carriage return I didn't investigate further.  See my below working code.

'Source code taken from https://analystcave.com/excel-calculate-distances-between-addresses/
' 8/19/23 Google JSON response format must have changed.  I had to modify my InStr() method to parse and find the result.
' https://www.googlecloudcommunity.com/gc/Developer-Tools/Google-Maps-API-Distance-Matrix-on-Microsoft-Excel-VB-Module/m-p/624366#M1309

'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 = "https://maps.googleapis.com/maps/api/distancematrix/json?origins="
    secondVal = "&destinations="
    lastVal = "&mode=car&language=en&sensor=false&key=xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx"
    
    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 ("")
    testvar = objHttp.responseText
            'If InStr(objHttp.responseText, """distance"" : {") = 0 Then GoTo ErrorHandl  ---- This is now broke
    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)
    GetDistance = Round(GetDistance / 1609.34, 1)
    Range("GoogleMileageOneWay").Value = GetDistance

    Exit Function
ErrorHandl:
    GetDistance = -1
End Function

Public Function GetDuration(start As String, dest As String)
    Dim firstVal As String, secondVal As String, lastVal As String
    firstVal = "https://maps.googleapis.com/maps/api/distancematrix/json?origins="
    secondVal = "&destinations="
    lastVal = "&mode=car&language=en&sensor=false&key=xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx"
    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, """duration"" : {") = 0 Then GoTo ErrorHandl   ---- This is now broke
    If InStr(objHttp.responseText, """duration""") = 0 Then GoTo ErrorHandl
    Set regex = CreateObject("VBScript.RegExp"): regex.Pattern = "duration(?:.|\n)*?""value"".*?([0-9]+)": regex.Global = False
    Set matches = regex.Execute(objHttp.responseText)
    tmpVal = Replace(matches(0).SubMatches(0), ".", Application.International(xlListSeparator))
    GetDuration = CDbl(tmpVal) / 3600
    Range("GoogleTravelTimeOneWay").Value = GetDuration
    Exit Function
ErrorHandl:
    GetDuration = -1
End Function

[lcichris]

This worked for my organization as well.  We just needed to swap out some code specific for our organization.  Thanks @mvoelkerASC!

[Varelse]

Thank you sooo much! I've run into this problem today and would be completely lost if I don't find your post. Absolute legend, thank you for posting the solution!!!!!!

[leuz66]

mvoelkerASC  Danke für deine Lösung, wir können nun wieder alle Berechnungen durchführen, top!

[FP20231]

I've got exactly the same problem. Does anyone have a solution for this?

[rasec_lc]

Hi, good morning @FP20231 
Yes, it was solved by @mvoelkerASC .
I shared the tweaks I made to work within what I needed.
It is already marked as solved. Enjoy!!!

[FP20231]

Hi @rasec_lc , yesss. It worked for me as well. 🙂

[rasec_lc]

I needed to make some adjustments because I don't have a query range, so with the code like this it worked!!!

Thank you @mvoelkerASC !!!

--------------------------------------------------------------------

' Calculate Google Maps distance between two addresses
Public Function GetDistance(origin As String, dest As String) As Double
On Error GoTo ErrorHandl
Dim firstVal As String, secondVal As String, lastVal As String
firstVal = "https://maps.googleapis.com/maps/api/distancematrix/json?origins="
secondVal = "&destinations="
lastVal = "&mode=car&language=en&sensor=false&key=xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx"

Set objHttp = CreateObject("MSXML2.ServerXMLHTTP")
url = firstVal & Replace(origin, " ", "+") & 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)
GetDistance = Round(GetDistance / 1609.34, 1)
Exit Function

ErrorHandl:
GetDistance = -1
Exit Function
End Function

Public Function GetDuration(origin As String, dest As String) As Double
On Error GoTo ErrorHandl
Dim firstVal As String, secondVal As String, lastVal As String
firstVal = "https://maps.googleapis.com/maps/api/distancematrix/json?origins="
secondVal = "&destinations="
lastVal = "&mode=car&language=en&sensor=false&key=xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx"
Set objHttp = CreateObject("MSXML2.ServerXMLHTTP")
url = firstVal & Replace(origin, " ", "+") & 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, """duration""") = 0 Then GoTo ErrorHandl
Set regex = CreateObject("VBScript.RegExp"): regex.Pattern = "duration(?:.|\n)*?""value"".*?([0-9]+)": regex.Global = False
Set matches = regex.Execute(objHttp.responseText)
tmpVal = Replace(matches(0).SubMatches(0), ".", Application.International(xlListSeparator))
GetDuration = CDbl(tmpVal) / 60
Exit Function

ErrorHandl:
GetDuration = -1
Exit Function
End Function

Public Function MultiGetDistance(ParamArray args() As Variant) As Double
MultiGetDistance = 0
Dim startLoc As String, endLoc As String, i As Long
For i = LBound(args) To UBound(args) - 1
startLoc = args(i): endLoc = args(i + 1)
MultiGetDistance = MultiGetDistance + GetDistance(startLoc, endLoc)
Next i
End Function

Public Function MultiGetDuration(ParamArray args() As Variant) As Double
MultiGetDuration = 0
Dim startLoc As String, endLoc As String, i As Long
For i = LBound(args) To UBound(args) - 1
startLoc = args(i): endLoc = args(i + 1)
MultiGetDuration = MultiGetDuration + GetDuration(startLoc, endLoc)
Next i
End Function

--------------------------------------------------------------------