Recherche de distances kilométriques - Google Maps ou autre

Bonjour,

Savez-vous s’il existe la possibilité au travers d’Excel d’aller chercher la distance kilométrique entre deux localités ou adresses sur des sites comme Google Maps (de préférence) ou autre ?

Si oui, comment est-ce que ça fonctionne au niveau d’un fichier Excel ?

Cordialement.

bonjour,

un exemple :

attention google limite le nombre d'appels que tu peux faire par minute et par jour. si tu veux en faire un usage intensif il faudra payer google.

Sub test()
Dim d As Long
Dim t As Long
frain = InputBox("point de départ (gps (lat, long) ou adresse")
fra = Replace(frain, " ", "+")
toain = InputBox("point d'arrivée (gps (lat, long) ou adresse")
toa = Replace(toain, " ", "+")
Call GoogleGetRoute(fra, toa, d, t)
MsgBox "de " & frain & " à " & toain & vbCrLf & "distance : " & Format(d / 1000, "0.0") & " km, durée : " & Format(t / 86400, "hh:mm")
End Sub

Public Sub GoogleGetRoute(ByVal Fromaddr As String, ByVal Toaddr As String, ByRef rdistance As Long, ByRef rtime As Long, Optional ByVal traceon As Boolean = False)
    ' Eric De Schrevel 2013, merci de laisser cette référence si vous utilisez ce code
    ' eric.de.schrevel@gmail.com

    ' rajouter la référence à microsoft xml 3.0, via le menu developer Tools pour que ceci fonctionne
    Dim request As MSXML2.XMLHTTP
    Dim xmlresponse As MSXML2.DOMDocument
    Dim leg As IXMLDOMNode
    Dim googleurl As String
    Dim ctr As Integer
    rdistance = -1:  'pas parvenu à calculer la distance
    rtime = 0
    googleurl = "http://maps.google.com/maps/api/directions/xml?sensor=false&mode=DRIVING&origin=" & Fromaddr & "&destination=" & Toaddr

    Set request = New MSXML2.XMLHTTP
    responsestatus = ""
    While responsestatus <> "OK"

    request.Open "GET", googleurl, False
    request.send

    If traceon Then MsgBox request.responseText

    Set xmlresponse = request.responseXML
    responsestatus = xmlresponse.SelectSingleNode("DirectionsResponse/status").Text
     If responsestatus = "OK" Then
      ctr = 0
      Set leg = xmlresponse.SelectSingleNode("DirectionsResponse/route/leg")
      If Not (leg Is Nothing) Then
        rtime = CLng(leg.SelectSingleNode("duration/value").Text) ' en secondes
        rdistance = CLng(leg.SelectSingleNode("distance/value").Text) 'en mètres
      End If
     Else
      'limite à 2500 consultations de route par jour
      'cfr developers.google.com/maps/documentation/directions
      ctr = ctr + 1
      If responsestatus = "OVER_QUERY_LIMIT" Then
       Application.Wait Time + TimeSerial(0, 0, 1)
      Else
       ctr = 3
      End If
      If ctr = 3 Then MsgBox ("erreur " & responsestatus): responsestatus = "OK"
     End If
    Wend
Set leg = Nothing
Set xmlresponse = Nothing
Set request = Nothing
End Sub

Salut H2so4,

Ton code fonctionne à merveille, merci beaucoup pour ta réponse

J’ai transformé un tout petit peu ton code afin de l’adapter à mon fichier ; j’y ai notamment ajouté la référence ‘Suisse’ directement dans le code afin de ne pas devoir la saisir à chaque fois. Ca fonctionne bien.

Juste pour une référence, j’arrive à trouver une solution en passant directement par le site Google alors que ta macro ne trouve pas de solution. As-tu une idée pourquoi ? C’est la référence ‘Le Châble, Bagnes’ qui crée des problèmes dans Excel. Ce n’est pas trop gênant, je pourrais sans problème trouver une solution de rechange ; c’est plus par curiosité que je te pose cette question.

Encore merci pour ton aide.

Amicalement.

Bonjour,

il s'agit d'un problème avec les caractères spéciaux. ton "â" doit être remplacé par son code %E2.

j'ai trouvé une table des codes ici

http://www.degraeve.com/reference/urlencoding.php

ps si tu essaies sans l'accent il trouve bien un chemin de 500 m

Il trouve un chemin de 500 m OK, mais de combien de minutes

Merci infiniment pour ta réponse claire et complète.

Excellente fin de journée.

Bonjour,

malheureusement ce genre de requête est aujourd'hui systématiquement bloquée par google qui demande l'activation d'une clé d'accès à ses services

j'ai posté sur un autre sujet une solution de contournement, en attendant de l'améliorer encore si besoin

https://forum.excel-pratique.com/viewtopic.php?p=696880#p696880