Option Explicit
Public ScriptControl As Object
Public Type deAaB
ptA As String
ptB As String
dist As Single
duree As Single
End Type
Sub Serie()
Dim Tdata As Variant, lg As Long, i As Long
Dim Trajet As deAaB
With Sheets("Gmaps")
lg = .Cells(Rows.Count, "A").End(xlUp).Row
Tdata = .Range(.Cells(2, "A"), .Cells(lg, "D")).value
For i = 1 To lg - 1
Trajet = AversB(Ote_accents(Tdata(i, 1)), Ote_accents(Tdata(i, 2)))
Tdata(i, 1) = Trajet.ptA
Tdata(i, 2) = Trajet.ptB
Tdata(i, 3) = 1 * Format(Trajet.dist, "# ###.00")
Tdata(i, 4) = Trajet.duree
Next i
.Range("A2").Resize(UBound(Tdata, 1), UBound(Tdata, 2)) = Tdata
End With
End Sub
' ***** FONCTIONS *********************************************************************************
Function Ote_accents(Sv As Variant) As String
Dim S As String
S = CStr(Sv)
S = Replace(S, "â", "a")
S = Replace(S, "à", "a")
S = Replace(S, "ä", "a")
S = Replace(S, "ê", "e")
S = Replace(S, "é", "e")
S = Replace(S, "è", "e")
S = Replace(S, "ë", "e")
S = Replace(S, "ï", "i")
S = Replace(S, "ô", "o")
S = Replace(S, "ö", "o")
S = Replace(S, "û", "u")
S = Replace(S, "ù", "u")
S = Replace(S, "ü", "u")
S = Replace(S, "'", " ")
Ote_accents = S
End Function
Function AversB(A As String, B As String) As deAaB
Dim Depart As String, Arrivee As String, Site As String
Dim Json As Object, Elem As Object, Elem1 As Object
Dim ok As Boolean
With Sheets("Gmaps")
Depart = Ote_accents(A)
Arrivee = Ote_accents(B)
On Error Resume Next
Site = "https://maps.googleapis.com/maps/api/distancematrix/json?origins=" & _
Depart & "&destinations=" & Arrivee & "&mode=driving&language=fr-FR"
Set Json = oRecordSet(Site)
For Each Elem In Json.Rows
For Each Elem1 In Elem.elements
ok = Not (Elem1.status = "ZERO_RESULTS")
AversB.dist = Elem1.distance.value / 1000
AversB.duree = Elem1.duration.value / 24 / 60 / 60
Next Elem1
Next Elem
ScriptControl.AddCode "Object.prototype.item=function( i ) { return this[i] } ; "
AversB.ptA = Json.origin_addresses.item(0)
AversB.ptB = Json.destination_addresses.item(0)
If Not ok Then
AversB.dist = 0
AversB.duree = 0
End If
Set Json = Nothing
End With
End Function
Function oRecordSet(txt As String, Optional www As Boolean = True) As Object
Dim Html As Object, Obj As Object, S As String
Set ScriptControl = CreateObject("MSScriptControl.ScriptControl")
ScriptControl.Language = "JScript"
If www Then
Set Html = CreateObject("MSXML2.XMLHTTP")
With Html
.Open "GET", txt, False
.send
S = .responsetext
End With
Else
S = txt
End If
Set Obj = ScriptControl.Eval("(" & S & ")")
Set oRecordSet = Obj
Set Obj = Nothing
End Function
