Calcul de distance

Le 25/09/2015 à 16:04

Bonjour,

J'essaye de créer une macro pour calculer la distance automatiquement entre deux villes en passant par google map. Je n'arrive pas à la faire marcher. Pouvez vous m'aider svp ?

Le code est le suivant :

Sub test()
Dim Départ As String, Arrivée As String
Dim X As Variant

Départ = "Lille France"
Arrivée = "Paris France"

X = DISTANCE(Départ, Arrivée)
Cells(6, 2).Value = X

End Sub
'---------------------------------------------------------------------

Function DISTANCE(ByVal Origin As String, ByVal Destination As String) As Double

Dim myRequest As XMLHTTP60
Dim myDomDoc As DOMDocument60
Dim distanceNode As IXMLDOMNode
DISTANCE = 0
On Error GoTo exitRoute
Origin = Replace(Origin, " ", "%20")
Destination = Replace(Destination, " ", "%20")
Set myRequest = New XMLHTTP60
myRequest.Open "GET", "http://maps.googleapis.com/maps/api...gin=" & Origin & "&destination=" & Destination & "&sensorúlse", False
myRequest.send
Set myDomDoc = New DOMDocument60
myDomDoc.LoadXML myRequest.responseText
Set distanceNode = myDomDoc.SelectSingleNode("//leg/distance/value")
If Not distanceNode Is Nothing Then DISTANCE = distanceNode.Text / 1000
exitRoute:
Set distanceNode = Nothing
Set myDomDoc = Nothing
Set myRequest = Nothing
End Function
Le 25/09/2015 à 16:15

bonjour,

voici de quoi t'inspirer

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
Le 25/09/2015 à 16:20

Merci pour votre réponse,

J'ai déja consulté ce poste, avant d'écrire le mien. Je n'ai pas réussi. J'ai mis le fichier en pièce jointe.

126test.xlsm (15.45 Ko)
Le 25/09/2015 à 16:35

bonjour,

remplace ce code

Sub newdistance()
    Dim d As Long
    Dim t As Long
    Dim i
    i = 2
    While Cells(i, 1) <> ""

    frain = Cells(i, "K")
    If frain <> "" Then
    '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")
    toain = Cells(i, "L")
    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")
    Cells(i, "E") = d / 1000
    Cells(i, "E").NumberFormat = "0.0"
    Cells(i, "f") = t / 86400
    Cells(i, "F").NumberFormat = "hh:mm"
    i = i + 1
    End If
    Wend
    End Sub

par

Sub newdistance()
    Dim d As Long
    Dim t As Long
    Dim i
    i = 2
    While Cells(i, 1) <> ""

    frain = Cells(i, "A")
    If frain <> "" Then
    '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")
    toain = Cells(i, "B")
    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")
    Cells(i, "E") = d / 1000
    Cells(i, "E").NumberFormat = "0.0"
    Cells(i, "f") = t / 86400
    Cells(i, "F").NumberFormat = "hh:mm"
    i = i + 1
    End If
    Wend
    End Sub
Rechercher des sujets similaires à "calcul distance"