1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
|
Public Function GetDistDurat(ByVal start As String, ByVal Dest As String, _
ByRef Distance As Long, ByRef Duree As Long) As Boolean
Const cSrc As String = "GM"
Const cDebDistance As String = """distance"" : {"
Const cDebDuree As String = """duration"" : {"
Const cValue As String = """value"" :"
Const cFin As String = "},"
Dim firstVal As String, secondVal As String, lastVal As String
Dim sRep As String, Url As String
firstVal = "https://maps.googleapis.com/maps/api/distancematrix/json?origins=" & start
secondVal = "&destinations=" & Dest
lastVal = "&mode=car&units=metric&language=fr&key=" & "Mon API KEY Google"
Url = firstVal & secondVal & lastVal
sRep = getHTTPreponse(Replace(Url, " ", ""))
If InStr(sRep, AddQuotes("status") & " : " & AddQuotes("OK")) <> 0 Then
Distance = Val(getTextBetween(getTextBetween(sRep, cDebDistance, cFin), cValue, cFin))
Duree = Val(getTextBetween(getTextBetween(sRep, cDebDuree, cFin), cValue, cFin))
GetDistDurat = True
End If
End Function
Private Function getHTTPreponse(ByVal sURL As String) As String
On Error GoTo catch
Dim objHTTP As Object
Set objHTTP = CreateObject("MSXML2.ServerXMLHTTP")
objHTTP.Open "GET", sURL, False
objHTTP.setRequestHeader "User-Agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.0)"
objHTTP.Send ""
getHTTPreponse = objHTTP.responseText
fin:
Set objHTTP = Nothing
Exit Function
catch:
MsgBox "err n°" & Err.Number & vbCrLf & Err.Source, vbExclamation, "getHTTPreponse"
Resume fin
End Function
'avec séparateur : ,"
Private Function LLtoStr(ByVal l1 As Double, ByVal l2 As Double) As String
LLtoStr = DbletoStr(l1) & "%2C" & DbletoStr(l2)
End Function
Private Function DbletoStr(ByVal v As Double, Optional ByVal lNbDec As Long = 4) As String
DbletoStr = LTrim$(Str(Round(v, lNbDec)))
End Function
Private Function AddQuotes(ByVal txt As String) As String
AddQuotes = Chr(34) & txt & Chr(34)
End Function
'retourne un texte entre deux limites
Private Function getTextBetween(ByVal text As String, ByVal Before As String, Optional ByVal After As String) As String
On Error Resume Next
getTextBetween = Split(Split(text, Before)(1), After)(0)
End Function |
