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
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
| Dim ShtDep As Worksheet, ShtDes As Worksheet
Dim IncDes As Long, LigFinDep As Long
Sub pageblanche()
Sheets("Itineraire").Range("C4,C5,C9,C10,C12,C13,B16,B18,B19:B20,B22:B23,D2:K500").ClearContents
End Sub
Sub test()
Set ShtDes = ThisWorkbook.Sheets("Destinations")
LigFinDes = Application.Max(ShtDes.Range("E" & Rows.Count).End(xlUp).Row, ShtDes.Range("F" & Rows.Count).End(xlUp).Row, ShtDes.Range("H" & Rows.Count).End(xlUp).Row)
For IncDes = 2 To LigFinDes
pageblanche 'Procedure pour effacer les données
With Sheets("Itineraire")
.Range("FinAdr").Value = ShtDes.Cells(IncDes, 3)
.Range("FinVille").Value = Format(ShtDes.Cells(IncDes, 4), "00000") & " " & ShtDes.Cells(IncDes, 5)
dep = IIf(Range("DepAdr").Value = "", Range("DepVille"), Range("DepAdr").Value & " " & Range("DepVille").Value)
fin = IIf(Range("FinAdr").Value = "", Range("FinVille"), Range("FinAdr").Value & " " & Range("FinVille").Value)
If dep = "" Or fin = "" Then MsgBox "remplir correctement!!! le depart et la destination": pageblanche: Exit Sub
' Dim tablo(500, 10), tablobase, donnée1 As String
donnée1 = itineraire(dep, fin)
'***********************************************tableau de gauche*****************************
With Sheets("Itineraire")
.[B16] = Split(Split(donnée1, "text"" : """)(1), Chr(34))(0) 'met la distance totale en B16
.[B18] = Split(Split(donnée1, "value"" :")(2), " ")(0) 'met la duree en minutes en B18
.[B19] = Replace(Replace(Split(Split(donnée1, "text"" : """)(2), Chr(34))(0), "heures", ":"), "minutes", ":") & "00" 'Convertie la duree en minute en heure
.[B22] = dep 'met l'adresse de depart en B22
.[B23] = fin 'mette l'adresse de fin en B23
.[C9] = Split(Split(donnée1, "lat"" :")(2), ",")(0) 'Met la latitude de depart en C9
.[C10] = Split(Split(donnée1, "lng"" :")(2), " ")(0) 'Met la longitude de depart en C10
.[C12] = Split(Split(donnée1, "lat"" :")(1), ",")(0) 'Met la latitude de fin en C12
.[C13] = Val(Split(Split(donnée1, "lng"" :")(1), " ")(0)) 'Met la longitude de fin en C13
End With
'***********************************************tableau de droite*****************************
' donnée2 = Split(donnée1, "start_address")(1)
' Debug.Print texte
' tablobase = Split(donnée2, "points")
' For i = 0 To UBound(tablobase) - 2
' tablo(i, 0) = Split(Split(tablobase(i), "html_instructions"" : """)(1), Chr(34))(0)
' tablo(i, 1) = Split(Split(tablobase(i), "text"" : """)(1), Chr(34))(0)
' tablo(i, 2) = Split(Split(tablobase(i), "text"" : """)(2), Chr(34))(0)
' tablo(i, 3) = Split(Split(tablobase(i), "lat"" :")(1), ",")(0)
' tablo(i, 4) = Val(Split(Split(tablobase(i), "lng"" :")(1), " ")(0))
' tablo(i, 5) = Split(Split(tablobase(i), "lat"" :")(2), ",")(0)
' tablo(i, 6) = Val(Split(Split(tablobase(i), "lng"" :")(2), " ")(0))
' tablo(i, 7) = "https://maps.google.fr/maps?q=" & tablo(i, 3) & "," & Replace(tablo(i, 4), ",", ".")
' Next
' Sheets(2).Cells(2, 4).Resize(UBound(tablo), 10) = tablo
End With
Sauvegarde
Next IncDes
End Sub
Function itineraire(dep, fin)
Dim REQ As Object, url As String
Set REQ = CreateObject("microsoft.xmlhttp")
'ex:http://maps.google.fr/maps/api/directions/json?origin=toulon 83000,&destination=paris 75000
url = "http://maps.google.fr/maps/api/directions/json?origin=" & Replace(dep, " ", "") & ",&destination=" & Replace(fin, " ", "")
With REQ
.Open "POST", url, False
.SetRequestHeader "Accept", "text/html, application/xhtml+xml, */*"
.SetRequestHeader "Accept-Language", "fr-FR"
.SetRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 6.1; WOW64; Trident/7.0; rv:11.0) like Gecko"
.SetRequestHeader "Accept-Encoding", "gzip, deflate"
.SetRequestHeader "Host", "maps.google.fr"
.SetRequestHeader "Connection", "Keep - Alive"
.SetRequestHeader "Cache-Control", "no-cache"
.send
itineraire = Replace(.responsetext, vbCrLf, "")
itineraire = Replace(itineraire, "/", "")
itineraire = Replace(itineraire, "\", "")
itineraire = Replace(itineraire, "u003cbu003e", " ")
itineraire = Replace(itineraire, "points", vbCrLf & "points")
itineraire = Replace(itineraire, "u003cdiv style=", "")
End With
End Function
Sub Sauvegarde()
Dim Dlig As Long, ShtD As Worksheet
Set ShtD = Sheets("Sauvegarde")
Dlig = ShtD.Range("B" & Rows.Count).End(xlUp).Row + 1
With Sheets("Itineraire")
' Données départ
ShtD.Range("A" & Dlig).Value = .Range("DepAdr").Value
ShtD.Range("B" & Dlig).Value = .Range("DepVille").Value
ShtD.Range("C" & Dlig).Value = .Range("DepLat").Value
ShtD.Range("D" & Dlig).Value = .Range("DepLong").Value
.Range("DepLien").Copy Destination:=ShtD.Range("E" & Dlig)
ShtD.Range("E" & Dlig).Borders.LineStyle = xlNone
' Données Arrivée
ShtD.Range("F" & Dlig).Value = .Range("FinAdr").Value
ShtD.Range("G" & Dlig).Value = .Range("FinVille").Value
ShtD.Range("H" & Dlig).Value = .Range("FinLat").Value
ShtD.Range("I" & Dlig).Value = .Range("FinLong").Value
.Range("FinLien").Copy Destination:=ShtD.Range("J" & Dlig)
ShtD.Range("J" & Dlig).Borders.LineStyle = xlNone
' Données itinéraire
ShtD.Range("K" & Dlig).Value = .Range("TotalKm").Value
' Mettre le bon format dans la colonne L
ShtD.Range("L" & Dlig).Value = .Range("TotalDuree").Value / 60 / 24
ShtD.Range("L" & Dlig).NumberFormat = "hh:mm:ss"
ShtD.Range("L" & Dlig).HorizontalAlignment = xlCenter
' Inscrire le lien
.Range("LienMap").Copy Destination:=ShtD.Range("M" & Dlig)
End With
End Sub |
