Макроинструмент Google API Distance Matrix для Excel - PullRequest
Новая
       25

Макроинструмент Google API Distance Matrix для Excel

0 голосов
/ 06 сентября 2018

Я располагаю макро инструмент, который я использовал для расчета расстояния между различными точками в Excel. Однако, поскольку Google API начал выставлять счета за услугу, она не используется.

Я создал ключ API 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

1 Ответ

0 голосов
/ 06 сентября 2018

В этой строке: 

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"
...