Question

我试图找到多个来源和目的地之间的距离和旅行时间。出于某种原因，我的代码根本不起作用。没有错误，我只是没有输出。请参阅随附的Excel for 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密钥，然后运行子TestRun。

它将替换您提供的地址中的不允许字符，然后将Google Matrix中的JSON结果加载到字符串中，然后，由于我们只查找1或2个值，它将使用凌乱的骗子 - 定位值的方法，我无法保证始终有效：

它首先出现单词＆＃34; distance＆＃34;，然后第一次出现单词＆＃34; value＆＃34;之后，向右移动3个字符，然后在那里和下一个之间移动任何字符＆＃34; ＆＃34;空格，并将其转换为值，希望以米为单位的距离。

然后重复（从文件开头）找到＆＃34; duration＆＃34;在几秒钟，相同的方法。请注意，距离和持续时间将返回变量＆＃34; byref＆＃34;。

正如我所说的那样，它非常复杂，但你得到了你付出的代价。（通常情况下，我不会分享此代码＆＃34;令人讨厌的＃34;，但是你在我家附近，所以，去加拿大吧！）

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

这同样的骗子方法＆＃34;可以用来从具有一致文本输出的任何URL（JSON，HTML，XML，CSV等）中抓取数据。

您可能需要添加工具 - ＆gt;参考支持XMLHTTP。

祝你好运！（不要忘记＆＃34;接受＆＃34;这个答案如果有用的话，我已经花了更多时间这比我想要的那样！）

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

1 个答案: