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