Requete en fonction de choix d'une liste a choix multiple

**phoenix974** · 25/06/2016, 12h18

Bonjour à tous,

J'aimerais pouvoir effectuer X requêtes googleMaps en fonction des choix fait sur une liste de choix multiple d'un formulaire et sauvegarder les différentes réponses puis retourner les réponses (nombre de km et durée de chaque destination sélectionnée en fonction de l'adresse de départ) dans un autres formulaire.

je dispose d'un fichier si vous avez besoin

J'ai préparé les formulaires mais je ne sais pas comment continuer. Voici le code utilisé:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Sub test()
    dep = IIf([C2].Value = "", [C3].Value, [C2].Value)
    fin = IIf([C4].Value = "", [C5].Value, [C4].Value)
    If dep = "" Or fin = "" Then MsgBox "remplir correctement!!! le depart et la destination": pageblanche: Exit Sub
    pageblanche
    Dim tablo(500, 10), tablobase, donnée1 As String
    donnée1 = itineraire(dep, fin)
    '***********************************************tableau de gauche*****************************
    With Sheets(2)
        .[B16] = Split(Split(donnée1, "text"" : """)(1), Chr(34))(0)
        .[B18] = Split(Split(donnée1, "value"" :")(2), "  ")(0)
        .[B19] = Replace(Replace(Split(Split(donnée1, "text"" : """)(2), Chr(34))(0), "heures", ":"), "minutes", ":") & "00"
        .[B22] = dep
        .[B23] = fin
        .[C9] = Split(Split(donnée1, "lat"" :")(2), ",")(0)
        .[C10] = Split(Split(donnée1, "lng"" :")(2), "  ")(0)
        .[C12] = Split(Split(donnée1, "lat"" :")(1), ",")(0)
        .[C13] = Val(Split(Split(donnée1, "lng"" :")(1), "  ")(0))
 
 
    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 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

**patricktoulon** · 25/06/2016, 17h46

bonjour je t'ai laissé un peu dans le jus pour te faire digérer le passage de l'api a la requête et constate que tu a adopter mon code
maintenant
Q1: a tu besoins de toute les données pour la sheets sauvegarde( je pense que non)
si oui
Q2: veut tu sauvegarder le sheets itinéraire tel quel pour toutes les adresse??
réponds a ces deux questions et on verra

**phoenix974** · 25/06/2016, 18h07

Bonjour Patrick,

J'utilise ton code étant donné qu'il est mieux apriori meme si tu ne m'as pas encore expliqué comment il fonctionne exactement.

pour tes question:

Q1: Je veux sauvegarder que la distance et la durée des itineraires selectionnés.
Q2: je ne suis pas sur d'avoir compris ta question. Par rapport au fichier, les details de l'itineraire ne m'interesse pas. Le but est de faire un truc simple, ou on rentre une adresse et on selectionne les destionations dans la liste a choix multiple et cela nous indique pour chacun des choix la distance et la durée puis selectionne le plus court dans un autre champs par exemple.

Voici un fichier, j'ai commencé a concevoir un formulaire avec liste de choix multiple

ITINERAIRE GOOGLE MAP VER Pat 1.02.xlsm

Update :
quelqu'un pour m'aider à avancer?

**patricktoulon** · 26/06/2016, 23h37

re
La bonne blague !!
je t' ai donné une macro toute prête qui te donne ces donnée et plus toute prête avec un départ et une destination
dans une boucle lancer cette même fonction tu sais pas faire ??????

dans ces cas la il faut réviser tes bases VBA c'est le B.A.B.A

tu comprends bien que l'on peut pas tout faire a ta place

je t'ai fait la fonction parce que c'est quand même un peu complexe

maintenant le reste c'est de la nioniote pour celui qui s y met un peu

**phoenix974** · 27/06/2016, 07h23

Bonjour patrick,

Oui et je te remercie encore pour ton aide, cependant je ne sais pas exactement comment fonctionne la requete, le format attendu pour le depart et la destination

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
 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

Notamment sur

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

origin=" & Replace(dep, " ", "") & ",&destination=" & Replace(fin, " ", "")

quel est le format, a quoi correspondent les , " " , "" ?
A quoi correspondent tous les parametres du with?

**patricktoulon** · 27/06/2016, 22h22

re

quel est le format, a quoi correspondent les , " " , "" ?
A quoi correspondent tous les parametres du with?

avec " ","" je remplace les espace dans les adresses
pour le with tu n'a rien a toucher pour n'importe quelle adresse c'est toujours pareil
je m'en occupe la semaine prochaine je suis sur un projet qui me turlupine depuis des mois

**phoenix974** · 09/07/2016, 20h29

Bonjour

j'ai avancésur mon projet, mais lorsque je lance ma macro pour des destinations multiple, une erreur 9 apparait aléatoirement au bout d'un certain nombre de destinations testées, je ne comprends pas pourquoi

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

        .[B16] = Split(Split(Donnee1, "text"" : """)(1), Chr(34))(0)

erreur d execution 9 l'indicie n'appartient pas à la selection.

Donnee1 remonte le message suivant:

{
"geocoder_status" : "OK

"{
"geocoded_way
points" : [
{
"geocoder_status" : "OK",
"partial_match" : true,
"place_id" : "ChIJH6prgH7k5UcRuZgb4q1S5Tk",
"types" : [ "street_address" ]
},
{
"geocoder_status" : "ZE

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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

Pouvez vous m'aider à avancer un peu, merci d'avance

**phoenix974** · 11/07/2016, 18h00

Cette erreur viens t elle du code en lui meme ou de l'API googlemap?

Requete en fonction de choix d'une liste a choix multiple

Macros et VBA Excel

Discussions similaires

Partager

Partager