When I first started with the Google Maps API (more than 1.5 years ago) I wrote a VBA function to access both the Geocoding and Directions API. Now these have been superseded (and improved upon) by the JavaScript and Python versions (actually I just use python now). However, I felt the VBA was interesting (despite being useless to me now) and wanted to share (especially the cryptography to sign the key).

Interesting thing about this (looking back) is that it used XML rather than JSON for the output as VBA did not support JSON. The idea is basically summarised in these lines:

urlString = "https://maps.googleapis.com/maps/api/geocode/xml?address=" & Addr & "&client=" & clientid & "&channel=" & channelid 
signedKey = Base64_HMACSHA1(urlString, keyString)
finalURL = urlString & "&signature=" & signedKey

Where the constructed URL requests an XML data-feed and the “Addr” variable is URL-safe encoded. Then we take the constructed URL, along with our private key (which is decoded from Base64 to binary) and encrypt the URL (stripping of the http://www.google base) using the private key in SHA1, then we encode this in Base64, make it URL-safe and add it on as a signature parameter to our final URL. We generate a “GET” request and parse the result using the Microsoft V6.0 XML Library.

“Address” Procedure calls the Geocoding API:

googmaps_vba

“Distances” Procedure calls the Directions API:

As usual we had three options (driving, cycling, walking)

googmaps_vba2

The result:

googmaps_summ

VBA Script:

'v1.0 - Google Maps V3 API: GeoCoding & Distance Matrix
'References: XML v6.0
''''''''''''''''''''''
'DELAY
''''''''''''''''''''''
'https://developers.google.com/maps/documentation/geocoding
'Google Maps API for Work: 10 requests per second
'However, with overhead may not be necessary

Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Public delay As Long
Public finish_state As Long

''''''''''''''''''''''
'Run
''''''''''''''''''''''

Sub Address()
Dim cell As Range
Dim counter As Long
Dim refile(1 To 3) As Variant
Dim i As Long
Dim rsp As Variant
Application.DisplayStatusBar = True
Application.ScreenUpdating = True
'1000 milliseconds = 1 second
'If get error OVER_QUERY_LIMIT, then this will increase to 1000
delay = 100
finish_state = Selection.Rows.count

'Connect to Repository
i = 1
On Error Resume Next
Open "...\GeocodeKeyV1.txt" For Input As #1
Do While EOF(1) = False
    If i > 3 Then Exit Do
    Line Input #1, strLine
    refile(i) = strLine
    i = i + 1
Loop
Close #1
On Error GoTo 0

If refile(2) <> 3 Then
    MsgBox ("Key File Not Found. Make Sure You are Connected to Network and Using latest Version of Code")
    Exit Sub
Else
    rsp = MsgBox(refile(1) & vbNewLine & vbNewLine & "This macro will overwrite the 4 cells to the right with:" & _
        vbNewLine & "Address" & vbNewLine & "Latitude, Longitude" & vbNewLine & "Match Type" & _
            vbNewLine & "Location Type" & vbNewLine & vbNewLine & "Pause/Cancel with Ctrl+Break" & _
                vbNewLine & vbNewLine & "Continue?", vbYesNoCancel)
    If rsp <> vbYes Then
        Exit Sub
    End If
End If

counter = 1
If Selection.Columns.count = 1 Then
    For Each cell In Selection
        If cell <> vbNullString Then
            Range(cell.Offset(, 1), cell.Offset(, 4)) = GeoCodeAddress(cell, refile(3), counter)
        End If
        counter = counter + 1
        'Introduce a delay (unsure if this is needed)
        Sleep delay
    Next cell
Else
    MsgBox ("Please select data in only one column")
    Exit Sub
End If

End Sub

Sub Distance()
Dim cell As Range
Dim counter As Long
Dim refile(1 To 3) As Variant
Dim i As Long
Dim rsp As Variant
Application.DisplayStatusBar = True
Application.ScreenUpdating = True
'1000 milliseconds = 1 second
'If get error OVER_QUERY_LIMIT, then this will increase to 1000
delay = 100
finish_state = Selection.Rows.count

'Connect to Repository
i = 1
On Error Resume Next
Open ...\TravelTimeKeyV1.txt" For Input As #1
Do While EOF(1) = False
    If i > 3 Then Exit Do
    Line Input #1, strLine
    refile(i) = strLine
    i = i + 1
Loop
Close #1
On Error GoTo 0

If refile(2) <> 3 Then
    MsgBox ("Key File Not Found. Make Sure You are Connected to Network and Using latest Version of Code")
    Exit Sub
Else
    rsp = MsgBox(refile(1) & vbNewLine & vbNewLine & "First column = Start" & vbNewLine & "Second column = Finish" & vbNewLine _
                & "(Optional) Third column = Mode [1=car, 2=bike, 3=walk]" & vbNewLine & vbNewLine & _
                    "This macro will overwrite the 2 cells to the right with:" & vbNewLine & _
                        "Distance (Miles)" & vbNewLine & vbNewLine & "Pause/Cancel with Ctrl+Break" & _
                            vbNewLine & vbNewLine & "Continue?", vbYesNoCancel)
    If rsp <> vbYes Then
        Exit Sub
    End If
End If

counter = 1
If Selection.Columns.count = 2 Then
'If no travel method specified then CAR
    For Each cell In Selection
        If (counter + 2) Mod 2 <> 0 And cell.Value <> vbNullString & cell.Offset(, 1) <> vbNullString Then
            Range(cell.Offset(, 2), cell.Offset(, 3)) = GeoCodeDist(cell, cell.Offset(, 1), refile(3), counter)
            cell.Offset(, 2).NumberFormat = "#.00 ""Miles"""
            cell.Offset(, 3).NumberFormat = "# ""Minutes"""
        End If
        counter = counter + 1
        'Introduce a delay (unsure if this is needed)
        Sleep delay
    Next cell
    
ElseIf Selection.Columns.count = 3 Then
'Travel method specified
    For Each cell In Selection
        If (counter + 2) Mod 3 = 0 And cell <> vbNullString & cell.Offset(, 1) <> vbNullString & cell.Offset(, 2) <> vbNullString Then
            Range(cell.Offset(, 3), cell.Offset(, 4)) = GeoCodeDist(cell, cell.Offset(, 1), refile(3), counter, cell.Offset(, 2))
            cell.Offset(, 3).NumberFormat = "#.00 ""Miles"""
            cell.Offset(, 4).NumberFormat = "# ""Minutes"""
        End If
        counter = counter + 1
        'Introduce a delay (unsure if this is needed)
        Sleep delay
    Next cell
    
Else
    MsgBox ("Incorrect Selection:" & vbNewLine & "First column = Start" _
    & vbNewLine & "Second column = Finish" & vbNewLine _
    & "(Optional) Third column = Mode [1=car, 2=bike, 3=walk]")
End If
End Sub

''''''''''''''''''''''
'Main Functions
''''''''''''''''''''''

Function GeoCodeAddress(ByVal Addr As String, ByVal keyString As String, _
    Optional ByVal counter As Integer)
Dim Request As XMLHTTP60
Dim DOMdoc As DOMDocument60
Dim try As Long
Dim StatErr As Long

Dim gAddr As IXMLDOMNode
Dim latNode As IXMLDOMNode
Dim lngNode As IXMLDOMNode
Dim typeNode As IXMLDOMNode
Dim type2Node As IXMLDOMNode
Dim zeroNode As IXMLDOMNode

Dim urlString As String
Dim signedKey As String
Dim finalURL As String

Const clientid As String = "..."
Const channelid As String = "Excel-Test"

'Make URL Safe
Addr = URLEncode(Addr)

RepeatCode:
'SENDING THE REQUEST
'https://developers.google.com/maps/documentation/geocoding/#RegionCodes
'Possible extension: & "&components=|country:" & Country & "|postal_code:" & Postal
'Using the components filter it is possible to make a query without the address parameter

urlString = "https://maps.googleapis.com/maps/api/geocode/xml?address=" & Addr & "&client=" & clientid & "&channel=" & channelid

'Sign Key
signedKey = Base64_HMACSHA1(urlString, keyString)
finalURL = urlString & "&signature=" & signedKey
Debug.Print "Sending request #" & counter & "/ " & finish_state & " : " & finalURL
Application.StatusBar = "Sending request #" & counter & "/ " & finish_state & " : " & finalURL

'Retry 3 times
On Error Resume Next
    try = 1
    Do While try <= 3
        Set Request = New XMLHTTP60
        With Request
            .Open "GET", finalURL, False
            .send
        End With
        If Err.Number <> 0 Then
            Debug.Print Err.Number
            try = try + 1
            'Wait 5 seconds
            Sleep (5000)
        Else
            Exit Do
        End If
    Loop
On Error GoTo 0

If try > 3 Then
    MsgBox ("Failed to send request #" & counter & ": " & finalURL & "." & _
        vbNewLine & "Check internet connection / URL")
        End
End If

Set DOMdoc = New DOMDocument60
DOMdoc.LoadXML Request.responseText

'CHECK STATUS
Set zeroNode = DOMdoc.SelectSingleNode("GeocodeResponse//status")

'From documentation only "UNKNOWN_ERROR" and "OVER_QUERY_LIMIT" are worth retrying
Select Case zeroNode.Text
    Case "OK"
        'Continue
    Case "ZERO_RESULTS"
        'Continue
        'Possible extension: recurse with a more limited search-string?
        GeoCodeAddress = "ZERO_RESULTS"
        Exit Function
    Case "NOT_FOUND"
        'Continue
        'Origin and/or destination of this pairing could not be geocoded
        GeoCodeAddress = "NOT_FOUND"
        Exit Function
    Case "INVALID_REQUEST"
        'Skip to next
        GeoCodeAddress = "INVALID_REQUEST"
        Exit Function
    Case Else
        'End
        StatErr = StatErr + 1
        If StatErr <= 3 Then
            'Pause for 2 seconds and resend the same request (twice)
            'If still OVER_QUERY_LIMIT then too many requests per day
            'Otherwise too many requests per second: increase (global) delay
            Sleep (2000)
            delay = 1000
            'Retry
            GoTo RepeatCode
        Else
            'Failed on two retries
            MsgBox ("Daily limit has been reached/Unknown Errors Have Occured")
            End
        End If
End Select

'Get formatted_address, latitude & longitude
Set gAddr = DOMdoc.SelectSingleNode("GeocodeResponse//result//formatted_address")
Set latNode = DOMdoc.SelectSingleNode("GeocodeResponse//result//geometry//location//lat")
Set lngNode = DOMdoc.SelectSingleNode("GeocodeResponse//result//geometry//location//lng")
'Get mode matches
Set typeNode = DOMdoc.SelectSingleNode("GeocodeResponse//result//address_component//type")
Set type2Node = DOMdoc.SelectSingleNode("GeocodeResponse//result//geometry//location_type")

'Return results
Dim results(1 To 4) As Variant
results(1) = gAddr.Text
results(2) = latNode.Text & "," & lngNode.Text
results(3) = type2Node.Text
results(4) = typeNode.Text

GeoCodeAddress = results
End Function

Function GeoCodeDist(ByVal Startstr As String, ByVal Finishstr As String, ByVal keyString As String, _
    Optional ByVal counter As Integer, Optional ByVal Moden As Integer = 1)
Dim Request As XMLHTTP60
Dim DOMdoc As DOMDocument60
Dim try As Long
Dim StatErr As Long

Dim distNode As IXMLDOMNode
Dim timeNode As IXMLDOMNode
Dim zeroNode As IXMLDOMNode

Dim urlString As String
Dim signedKey As String
Dim finalURL As String
Dim Modestr As String

Select Case Moden
Case 1: Modestr = "driving"
Case 2: Modestr = "bicycling"
Case 3: Modestr = "walking"
Case Else: Modestr = "driving"
End Select

Const clientid As String = "..."
Const channelid As String = "Excel-Test"

'Make URL Safe
Startstr = URLEncode(Startstr)
Finishstr = URLEncode(Finishstr)

RepeatCode:
'SENDING THE REQUEST
urlString = "https://maps.googleapis.com/maps/api/directions/xml?origin=" & _
    Startstr & "&destination=" & Finishstr & "&mode=" & Modestr & "&client=" & clientid & "&channel" & channelid

'Sign Key
signedKey = Base64_HMACSHA1(urlString, keyString)
finalURL = urlString & "&signature=" & signedKey
Debug.Print "Sending request #" & counter & "/ " & finish_state & " : " & finalURL
Application.StatusBar = "Sending request #" & counter & "/ " & finish_state & " : " & finalURL

'Retry 3 times
On Error Resume Next
    try = 1
    Do While try <= 3
        Set Request = New XMLHTTP60
        With Request
            .Open "GET", finalURL, False
            .send
        End With
        If Err.Number <> 0 Then
            Debug.Print Err.Number
            try = try + 1
            'Wait 5 seconds
            Sleep (5000)
        Else
            Exit Do
        End If
    Loop
On Error GoTo 0

If try > 3 Then
    MsgBox ("Failed to send request #" & counter & ": " & finalURL & "." & _
        vbNewLine & "Check internet connection / URL")
        End
End If

Set DOMdoc = New DOMDocument60
DOMdoc.LoadXML Request.responseText

'CHECK STATUS
Set zeroNode = DOMdoc.SelectSingleNode("DirectionsResponse//status")

'From documentation only "UNKNOWN_ERROR" and "OVER_QUERY_LIMIT" are worth retrying
Select Case zeroNode.Text
    Case "OK"
        'Continue
    Case "ZERO_RESULTS"
        'Continue
        'Possible extension: recurse with a more limited search-string?
        GeoCodeDist = "ZERO_RESULTS"
        Exit Function
    Case "NOT_FOUND"
        'Continue
        'Origin and/or destination of this pairing could not be geocoded
        GeoCodeDist = "NOT_FOUND"
        Exit Function
    Case "INVALID_REQUEST"
        'Skip to next
        GeoCodeDist = "INVALID_REQUEST"
        Exit Function
    Case Else
        'End
        StatErr = StatErr + 1
        If StatErr <= 3 Then
            'Pause for 2 seconds and resend the same request (twice)
            'If still OVER_QUERY_LIMIT then too many requests per day
            'Otherwise too many requests per second: increase (global) delay
            Sleep (2000)
            delay = 1000
            'Retry
            GoTo RepeatCode
        Else
            'Failed on two retries
            MsgBox ("Daily limit has been reached/Unknown Errors Have Occured")
            End
        End If
End Select

'Distance in metres
Set distNode = DOMdoc.SelectSingleNode("DirectionsResponse//leg/distance/value")
'Time in seconds
Set timeNode = DOMdoc.SelectSingleNode("DirectionsResponse//leg/duration/value")

Dim results(1 To 2) As Variant
'Distance in miles
results(1) = distNode.Text / 1000 / 1.609344
results(2) = timeNode.Text / 60

GeoCodeDist = results
End Function

''''''''''''''''''''''
'AUTHENTICATION
''''''''''''''''''''''

'Sign Signature
Function Base64_HMACSHA1(ByVal sTextToHash As String, ByVal sSharedSecretKey As String)
Dim asc As Object, 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")

'Only need to hash path
sTextToHash = Replace(sTextToHash, "https://maps.googleapis.com", "")
TextToHash = asc.Getbytes_4(sTextToHash)
'Decode sSharedSecretKey
SharedSecretKey = DecodeBase64(sSharedSecretKey)
'SharedSecretKey = asc.Getbytes_4(sSharedSecretKey)
enc.key = SharedSecretKey

bytes = enc.ComputeHash_2((TextToHash))
Base64_HMACSHA1 = EncodeBase64(bytes)
'Make URL Safe
Base64_HMACSHA1 = Replace(Base64_HMACSHA1, "/", "_")
Base64_HMACSHA1 = Replace(Base64_HMACSHA1, "+", "-")
Set asc = Nothing
Set enc = Nothing
End Function

'Encode Signature
Function EncodeBase64(ByRef arrData() As Byte) As String
Dim objXML As MSXML2.DOMDocument60
Dim objNode As MSXML2.IXMLDOMElement
Set objXML = New MSXML2.DOMDocument60
Set objNode = objXML.createElement("b64")

objNode.DataType = "bin.base64"
objNode.nodeTypedValue = arrData
EncodeBase64 = objNode.Text

Set objNode = Nothing
Set objXML = Nothing
End Function

'Decode Key
Function DecodeBase64(ByVal strData As String) As Byte()
Dim objXML As MSXML2.DOMDocument60
Dim objNode As MSXML2.IXMLDOMElement
Set objXML = New MSXML2.DOMDocument60
Set objNode = objXML.createElement("b64")

objNode.DataType = "bin.base64"
objNode.Text = strData
DecodeBase64 = objNode.nodeTypedValue

Set objNode = Nothing
Set objXML = Nothing
End Function

'Clean the URL query
Function URLEncode(StringVal As String, Optional SpaceAsPlus As Boolean = False) As String
Dim StringLen As Long: StringLen = Len(StringVal)
Dim i As Long, CharCode As Integer
Dim Char As String, Space As String
    If StringLen > 0 Then
        ReDim result(StringLen) As String
    If SpaceAsPlus Then Space = "+" Else Space = "%20"
        For i = 1 To StringLen
            Char = Mid$(StringVal, i, 1)
            CharCode = asc(Char)
            Select Case CharCode
                Case 97 To 122, 65 To 90, 48 To 57, _
                    45, 46, 61, 95, 123, 125, 126
                    result(i) = Char
                Case 32
                    result(i) = Space
                Case 0 To 15
                    result(i) = "%0" & Hex(CharCode)
                Case Else
                    result(i) = "%" & Hex(CharCode)
            End Select
        Next i
        URLEncode = Join(result, "")
    End If
End Function