Google API 距离矩阵宏工具，适用于 excel

Question

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

我已经创建了一个谷歌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"