Question

我放置了一个宏工具，该工具用于Excel中不同点之间的距离计算。但是，由于Google API开始对服务收费，因此该服务已停用。

我已经创建了一个google API密钥，但目前停留在这一步，它说对象'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"

适用于Excel的Google API Distance Matrix宏工具

1 个答案: