用于excel的Google距离矩阵宏工具

Question

我配置了一个宏工具，用于在Excel中计算不同点之间的距离。但是，自从Google开始计费服务以来，它就不再使用了。

我已经创建了google密钥，但目前我仍然停留在这一步，它说打开对象'IXMLHTTPRequest‘的方法失败了。

https://i.stack.imgur.com/ODXT4.png

https://i.stack.imgur.com/6ZDcG.png

你能帮我一下吗？

下面是我的宏的整个脚本：

Sub Calculer(Départ As String, Arrivée As String, Distance As String, Temps As Double)

Dim surl As String
Dim oXH As Object
Dim bodytxt As String

'Utilisation de l'API Google

Distance = ""
Temps = 0
Départ = Replace(Départ, " ", "+")
Départ = SupprimerAccents(Départ)
Arrivée = Replace(Arrivée, " ", "+")
Arrivée = SupprimerAccents(Arrivée)

surl = "http://maps.googleapis.com/maps/api/distancematrix/xml?origins=" & _
Départ & "&destinations=" & Arrivée & _
"&mode=driving&sensor=false&units=metric"

Set oXH = CreateObject("msxml2.xmlhttp")

With oXH
.Open "get", surl, False
.send
bodytxt = .responseText
End With

bodytxt = Right(bodytxt, Len(bodytxt) - InStr(1, bodytxt, "<text>") - 5)
If InStr(1, bodytxt, "</text>") <> 0 Then Temps_Texte = Left(bodytxt, InStr(1, bodytxt, "</text>") - 1)
If Temps_Texte <> "" Then
    Temps_Texte = Replace(Temps_Texte, " weeks", "w")
    Temps_Texte = Replace(Temps_Texte, " week", "w")
    Temps_Texte = Replace(Temps_Texte, " day", "j")
    Temps_Texte = Replace(Temps_Texte, " hours", "h")
    Temps_Texte = Replace(Temps_Texte, " hour", "h")
    Temps_Texte = Replace(Temps_Texte, " mins", "m")
    Temps_Texte = Replace(Temps_Texte, " min", "m")
    Temps_Texte = Replace(Temps_Texte, " seconds", "s")
    Temps_Texte = Replace(Temps_Texte, " second", "s")
    Heure = Split(Temps_Texte, " ")
    j = 0
    On Error GoTo fin
    If Right(Heure(j), 1) = "w" Then Temps = Temps + Val(Heure(j)) * 7: j = j + 1
    If Right(Heure(j), 1) = "d" Then Temps = Temps + Val(Heure(j)): j = j + 1
    If Right(Heure(j), 1) = "h" Then Temps = Temps + Val(Heure(j)) / 24: j = j + 1
    If Right(Heure(j), 1) = "m" Then Temps = Temps + Val(Heure(j)) / 24 / 60: j = j + 1
    If Right(Heure(j), 1) = "s" Then Temps = Temps + Val(Heure(j)) / 24 / 60 / 60: j = j + 1
fin:
    On Error GoTo 0
End If


bodytxt = Right(bodytxt, Len(bodytxt) - InStr(1, bodytxt, "<text>") - 5)
If InStr(1, bodytxt, "</text>") <> 0 Then Distance = Left(bodytxt, InStr(1, bodytxt, "</text>") - 1)
If Distance = "" Then Distance = "Aucun résultat"

Distance = Replace(Distance, " km", "")
Distance = Replace(Distance, ",", "")

Set oXH = Nothing

End Sub

Function SupprimerAccents(ByVal sChaine As String) As String
'Fonction récupérée ici : http://www.developpez.net/forums/d1089902/logiciels/microsoft-office/excel/macros-vba-excel/suppression-accents-chaines-caracteres/
Dim sTmp As String, i As Long, p As Long
Const sCarAccent As String = "ÁÂÃÄÅÇÈÉÊËÌÍÎÏÑÒÓÔÕÖÙÚÛÜÝàáâãäåçèéêëìíîïñòóôõöùúûüýÿ"
Const sCarSansAccent As String = "AAAAACEEEEIIIINOOOOOUUUUYaaaaaaceeeeiiiinooooouuuuyy"
    sTmp = sChaine
    For i = 1 To Len(sTmp)
        p = InStr(sCarAccent, Mid(sTmp, i, 1))
        If p > 0 Then Mid$(sTmp, i, 1) = Mid$(sCarSansAccent, p, 1)
    Next i
    SupprimerAccents = sTmp
End Function

Answer 1

在这一行：

surl = "http://maps.googleapis.com/maps/api/distancematrix/xml?origins=" & _
Départ & "&destinations=" & Arrivée & _
"&mode=driving&sensor=false&units=metric"

添加您的密钥(并删除&sensor=false)：

surl = "http://maps.googleapis.com/maps/api/distancematrix/xml?origins=" & _
Départ & "&destinations=" & Arrivée & _
"&mode=driving&units=metric&key=MY_API_KEY"