起源 目的地 Excel VBA API（谷歌地图）

Question

我正在尝试查找多个起点和终点之间的距离和旅行时间。出于某种原因，我的代码根本不起作用。没有错误，我只是没有任何输出。请参阅随附的 Excel 工作表图像。

Sub Origins_Destinations()
    Dim a, b, i, Str As String
    Dim lineS As Variant

    On Error Resume Next
    'Application.ScreenUpdating = False

    With CreateObject("WinHttp.WinHttpRequest")
        Dim iRow As Long: iRow = ThisWorkbook.Worksheets(1).Range("g65000").End(xlUp).Row
        For j = 4 To iRow
            b = ThisWorkbook.Worksheets(1).Range("b4" & j)
            a = ThisWorkbook.Worksheets(1).Range("a4" & j)
            .Open "GET", "https://maps.googleapis.com/maps/api/distancematrix/json?units=imperial&origins=" & a & " &destinations= " & b & " &key=MY_KEY", False
            .Send
            lineS = Split(.ResponseText, vbLf)
            For k = 25 To UBound(lineS)
                If Trim(lineS(k)) = """distance"" : {" Then
                    Exit For
                End If
            Next k
             ThisWorkbook.Worksheets(1).Range("c" & j) = lineS(k + 1)
             ThisWorkbook.Worksheets(1).Range("d" & j) = lineS(k + 5)
             Application.Wait (Now + TimeValue("0:00:01"))
        Next j
    End With
    Application.ScreenUpdating = True    
End Sub

enter image description here

有什么建议吗？？？？？？

Answer 1

据我了解，下面的代码是您开始寻找的代码。在顶部的常量中输入您的 Google Maps API 密钥，然后运行 ​​sub TestRun。

它将替换您提供的地址中不允许使用的字符，然后将来自 Google Matrix 的 JSON 结果加载到一个字符串中，然后，由于我们只查找 1 或 2 个值，因此它将使用一种凌乱的作弊方法来定位值，我不能保证总是有效：

它找到单词“distance”的第一次出现，然后是单词“value”的第一次出现，向右移动3个字符，然后将那里和下一个“”之间的任何内容都取为空白空间，并将其转换为一个值，希望是以米为单位的距离。

然后重复（从文件开头）以秒为单位查找“持续时间”，方法相同。请注意，距离和持续时间将返回到变量“byref”。

正如我所说，这非常令人费解，但你得到了你所付出的。 （通常我不会分享这种“恶心”的代码，但你就在我附近，所以，去加拿大吧！）

Option Explicit
'3333 University Way,Kelowna,BC,V1V 1V7
'1555 Banks Rd, Kelowna, BC, V1X 7Y8
'1938 Pandosy Street, Kelowna, BC, V1Y 1R7
'2280 Baron Rd, Kelowna, BC, V1X 7W3
Const key = "YOUR-API-KEY-HERE"


Sub testRun()

    Dim orig As String, dest As String, distance_Meters As Long, duration_Sec As Long
    orig = EncodeEscapeString("3333 University Way,Kelowna,BC,V1V 1V7")
    dest = EncodeEscapeString("1555 Banks Rd, Kelowna, BC, V1X 7Y8")

    Call getGoogleDistanceMatrix(orig, dest, distance_Meters, duration_Sec)

    Debug.Print distance_Meters & "m"
    Debug.Print duration_Sec & "sec"

End Sub


Sub getGoogleDistanceMatrix(ByVal orig As String, ByVal dest As String, ByRef distance_Meters As Long, ByRef duration_Sec As Long)

    Const distanceTag1 = """distance"""
    Const distanceTag2 = """value"""
    Const durationTag1 = """duration"""
    Const durationTag2 = """value"""

    Dim jSON As String, pStart As Long, pEnd As Long
    jSON = Get_URL_text("https://maps.googleapis.com/maps/api/distancematrix/json?units=metric&origins=" & orig & "&destinations=" & dest & "&key=" & key)

    pStart = InStr(jSON, distanceTag1) + Len(distanceTag1)
    pStart = InStr(pStart, jSON, distanceTag2) + Len(distanceTag2) + 3
    pEnd = InStr(pStart, jSON, " ")
    distance_Meters = Val(Trim(Mid(jSON, pStart, pEnd - pStart)))

    pStart = InStr(jSON, durationTag1) + Len(durationTag1)
    pStart = InStr(pStart, jSON, durationTag2) + Len(durationTag2) + 3
    pEnd = InStr(pStart, jSON, " ")
    duration_Sec = Val(Trim(Mid(jSON, pStart, pEnd - pStart)))

End Sub

Function Get_URL_text(url As String) As String

    Dim XMLHTTP As Object
    Set XMLHTTP = CreateObject("MSXML2.serverXMLHTTP")
    XMLHTTP.Open "GET", url, False
    XMLHTTP.send
    Get_URL_text = XMLHTTP.responseText
    Set XMLHTTP = Nothing

End Function

Function EncodeEscapeString(str_In As String) As String

    Dim s As String

    s = str_In
    s = Replace(s, "%", "%25")
    s = Replace(s, " ", "%20")
    s = Replace(s, Chr(34), "%22")
    s = Replace(s, "<", "%3C")
    s = Replace(s, ">", "%3E")
    s = Replace(s, "#", "%23")
    s = Replace(s, "|", "%7C")

    EncodeEscapeString = s

End Function

同样的“欺骗方法”可用于从任何具有一致文本输出的 URL（JSON、HTML、XML、CSV 等）中抓取数据。

您可能需要添加工具 -> 参考以支持 XMLHTTP。

祝你好运！（如果它有用的话，别忘了“接受”这个答案，我已经投入了比预期更多的时间！）