Google Maps API VBA宏无法返回行驶时间与距离问题求助

数据老陈

2026-7-12

修复Excel VBA调用Google Maps Distance Matrix API获取距离/时长的宏

我之前用以下VBA宏在Excel中通过两个地址获取行驶距离或时间，公式示例：

转换为英里：=GetDistance(A1,B1)*0.000621371（原返回单位为米）
转换为小时：=GetDuration(A1,B1)/3600（原返回单位为秒）

现在这两个宏无法正常运行，推测是Google调整了API相关规则，但我对VBA和Google Maps API了解有限，求修复：

获取Google Maps距离（单位：米）旧代码

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=*MyKey*"
    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

获取Google Maps行驶时长（单位：秒）旧代码

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= *MyKey*"
    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(?:.|
)*?""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

我查过Google Maps Platform文档但没找到相关路径说明，恳请协助修复。

修复方案

问题根源

语法错误：原代码中InStr判断语句的字符串格式错误，引号转义和空格处理不符合VBA规则。
正则表达式缺陷：匹配逻辑不精准，容易误抓JSON中其他value字段，稳定性差。
API参数过时：sensor参数已被Google废弃，无需再传入。
HTTP请求兼容性：旧版MSXML2.ServerXMLHTTP在现代环境下兼容性不足，建议升级版本。
JSON解析方式低效：用正则提取JSON值容错率低，改用专业JSON解析模块更可靠。

修复后的代码

首先，在Excel VBA编辑器中勾选工具→引用→Microsoft Scripting Runtime，再导入JsonConverter.bas模块（用于稳定解析JSON，可直接复制该模块代码到VBA工程中），然后使用以下代码：

GetDistance（获取距离，单位米）

Public Function GetDistance(startAddr As String, destAddr As String) As Double
    Dim apiKey As String
    apiKey = "YOUR_GOOGLE_API_KEY" '替换为你的API密钥
    
    Dim apiUrl As String
    apiUrl = "https://maps.googleapis.com/maps/api/distancematrix/json?" & _
             "origins=" & URLEncode(startAddr) & _
             "&destinations=" & URLEncode(destAddr) & _
             "&mode=driving&language=pl&key=" & apiKey
    
    Dim http As Object
    Set http = CreateObject("MSXML2.XMLHTTP.6.0")
    http.Open "GET", apiUrl, False
    http.setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 10.0; Win64; x64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/114.0.0.0 Safari/537.36"
    http.send
    
    If http.Status <> 200 Then
        GetDistance = -1
        Exit Function
    End If
    
    Dim jsonText As String
    jsonText = http.responseText
    
    '解析JSON
    Dim json As Object
    Set json = JsonConverter.ParseJson(jsonText)
    
    '检查API返回状态
    If json("status") <> "OK" Then
        GetDistance = -1
        Exit Function
    End If
    
    '提取距离值
    Dim rows As Object
    Set rows = json("rows")
    If rows.Count = 0 Then
        GetDistance = -1
        Exit Function
    End If
    
    Dim elements As Object
    Set elements = rows(1)("elements")
    If elements.Count = 0 Then
        GetDistance = -1
        Exit Function
    End If
    
    Dim element As Object
    Set element = elements(1)
    If element("status") <> "OK" Then
        GetDistance = -1
        Exit Function
    End If
    
    GetDistance = element("distance")("value")
End Function

GetDuration（获取时长，单位秒）

Public Function GetDuration(startAddr As String, destAddr As String) As Double
    Dim apiKey As String
    apiKey = "YOUR_GOOGLE_API_KEY" '替换为你的API密钥
    
    Dim apiUrl As String
    apiUrl = "https://maps.googleapis.com/maps/api/distancematrix/json?" & _
             "origins=" & URLEncode(startAddr) & _
             "&destinations=" & URLEncode(destAddr) & _
             "&mode=driving&language=en&key=" & apiKey
    
    Dim http As Object
    Set http = CreateObject("MSXML2.XMLHTTP.6.0")
    http.Open "GET", apiUrl, False
    http.setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 10.0; Win64; x64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/114.0.0.0 Safari/537.36"
    http.send
    
    If http.Status <> 200 Then
        GetDuration = -1
        Exit Function
    End If
    
    Dim jsonText As String
    jsonText = http.responseText
    
    '解析JSON
    Dim json As Object
    Set json = JsonConverter.ParseJson(jsonText)
    
    '检查API返回状态
    If json("status") <> "OK" Then
        GetDuration = -1
        Exit Function
    End If
    
    '提取时长值
    Dim rows As Object
    Set rows = json("rows")
    If rows.Count = 0 Then
        GetDuration = -1
        Exit Function
    End If
    
    Dim elements As Object
    Set elements = rows(1)("elements")
    If elements.Count = 0 Then
        GetDuration = -1
        Exit Function
    End If
    
    Dim element As Object
    Set element = elements(1)
    If element("status") <> "OK" Then
        GetDuration = -1
        Exit Function
    End If
    
    GetDuration = element("duration")("value")
End Function

辅助URL编码函数

Private Function URLEncode(str As String) As String
    Dim script As Object
    Set script = CreateObject("ScriptControl")
    script.Language = "JScript"
    URLEncode = script.CodeObject.encodeURIComponent(str)
End Function

额外说明

确保你的Google API密钥已启用Distance Matrix API，并配置了正确的计费和访问权限（否则会返回权限错误）。
替换代码中的YOUR_GOOGLE_API_KEY为你自己的有效密钥。

内容的提问来源于stack exchange，提问作者MrPink