Microsoft 365 Trouver coordonnées a partir d'un nom de ville OpenStreetMap

burger0715

burger0715

XLDnaute Nouveau
Bonjour !

Je voudrais solliciter votre aide, je souhaite trouver automatiquement les coordonnées d'une ville juste en ayant son nom grâce à OpenStreetMap (je peux pas utiliser d'API). J'ai trouvé un tuto pour le faire mais le problème c'est qu'il utilise InternetExplorer, or je ne sais pas si c'est parce qu'IE à fermé le 15 juin dernier, mais OPS(OpenStreetMap) ne marche plus dessus. J'aimerais donc utiliser GoogleChrome à la place mais c'est vraiment plus compliqué à priori et je n'arrive pas à adapter le code.

Si quelqu'un à une idée de comment faire ça m'aiderait beaucoup, merci d'avance !😁

NB : Voici le vba

VB: 
Function coordonneesGPS(URL As String)
Dim web As Object
Set web = CreateObject("InternetExplorer.Application")
web.navigate URL
Do While web.busy And web.readyState <> 4
    DoEvents
Loop
pause (1)
coordonnesGPS = web.locationUrl
web.Quit

End Function
    Sub pause(duree As Double)
    Dim finPause As Double
    finPause = Timer + duree
    Do While Timer < finPause
        DoEvents
    Loop
End Sub
 

Pièces jointes

  • CoordonnéesAuto.xlsm
    14.5 KB · Affichages: 19
Trier par date Trier par votes
V

vincent-laurent

XLDnaute Nouveau
fanch55 à dit:
Re,
Classeur modifié pour utiliser Ops.
Obligé d'utiliser WinHttpRequest,
le premier appel au Get est lent : entre 10 et 26 secondes .. 😡
les appels suivant durent moins de la seconde ...🤗
Cliquez pour agrandir...
bonjour, je voudrais utiliser votre module mais j'utilise libre office sous mac lorsque je rentre dans le tableau une nouvelle adresse on me dit erreur #valeur! et quand je regarde dans le script il me dit erreur de syntax basic symbole inattendu : object et il me surligne Name à la ligne 13
Je n'y connais pas grand chose et je me pose la question comment fait il appel à OPS je ne vois aucun lien vers ce site
Merci de votre réponse
 
Vote positif 0 Vote négatif
fanch55

fanch55

XLDnaute Barbatruc
vincent-laurent à dit:
je me pose la question comment fait il appel à OPS je ne vois aucun lien vers ce site
Merci de votre réponse
Cliquez pour agrandir...
Bonjour,
Ops a été employé à tort, c'est plutôt OSM = OpenStreetMap :rolleyes:
1673879392693.png

Enrichi (BBcode): 
Option Explicit
'
' Fanch55 Juin 2022
'
Sub Start_Gps()
Dim Stamp   As Variant
Dim UrlReq  As Variant
Dim Line    As Range
Dim R       As Long
  
    [TabGps[[Longitude]:[Name]]].ClearContents
    Stamp = Timer
    Application.ScreenUpdating = False
        For Each Line In [TabGps].Rows
            R = Line.Row - [TabGps[#Headers]].Row
          ' On décompose les assignations pour plus de clarté
          ' car le Vbe est mauvais avec les continuations avec des crochets
          ' Cela permet également de mettre une des assignations en commentaire sans la supprimer ..
            UrlReq = vbNullString
            UrlReq = UrlReq & [TabGps[Id]].Rows(R) & " "
            UrlReq = UrlReq & [TabGps[Adresse]].Rows(R) & " "
            UrlReq = UrlReq & [TabGps[Cp]].Rows(R) & " "
            UrlReq = UrlReq & [TabGps[Ville]].Rows(R) & " "
            UrlReq = UrlReq & [TabGps[Pays]].Rows(R)
          
            [TabGps[[Longitude]:[Name]]].Rows(R) = GetGps([Site], UrlReq)
            [TabGps[Requête]].Rows(R) = UrlReq
          
        Next
        [TabGps].Calculate
    Application.ScreenUpdating = True
    MsgBox "Temps d'exécution : " & Timer - Stamp & " secondes."

End Sub
Function GetGps(Url, Adr) ' renvoie un tableau de 3 éléments:  latitude,longitude et Nom de l'endroit
Dim XmlHttpRequest  As Object
Dim Reponse         As Object
    GetGps = Array("", "", "Stop: Pas d'adresse indiquée")

    Adr = WorksheetFunction.EncodeURL(Trim(Adr))
    If Adr <> vbNullString Then
      
'        Set XmlHttpRequest = CreateObject("MSXML2.serverXMLHTTP")
        Set XmlHttpRequest = CreateObject("MSXML2.XMLHTTP")
        With XmlHttpRequest
            .Open "GET", Url & "/search?limit=1&format=xml&q=" & Adr, False
            .Send
            If .Status <> 200 Then
                GetGps = Array("", "", "Stop: " & .ResponseXML.Text)
                Err.Clear
             Else
                Set Reponse = .ResponseXML.SelectSingleNode("//place")
                If Not Reponse Is Nothing Then
                    With Reponse.Attributes
                     GetGps = Array(Format(.getnameditem("lat").Value, "0.00000"), _
                                    Format(.getnameditem("lon").Value, "0.00000"), _
                                           .getnameditem("display_name").Value)
                    End With
                    Set Reponse = Nothing
                Else
                    GetGps = Array("", "", "Stop: Pas de coordonnées pour l'adresse indiquée")
                End If
             End If
        End With
        Set XmlHttpRequest = Nothing
    End If

End Function
 
Vote positif 0 Vote négatif
V

vincent-laurent

XLDnaute Nouveau
fanch55 à dit:
Bonjour,
Ops a été employé à tort, c'est plutôt OSM = OpenStreetMap :rolleyes:
Regarde la pièce jointe 1160496
Enrichi (BBcode): 
Option Explicit
'
' Fanch55 Juin 2022
'
Sub Start_Gps()
Dim Stamp   As Variant
Dim UrlReq  As Variant
Dim Line    As Range
Dim R       As Long
 
    [TabGps[[Longitude]:[Name]]].ClearContents
    Stamp = Timer
    Application.ScreenUpdating = False
        For Each Line In [TabGps].Rows
            R = Line.Row - [TabGps[#Headers]].Row
          ' On décompose les assignations pour plus de clarté
          ' car le Vbe est mauvais avec les continuations avec des crochets
          ' Cela permet également de mettre une des assignations en commentaire sans la supprimer ..
            UrlReq = vbNullString
            UrlReq = UrlReq & [TabGps[Id]].Rows(R) & " "
            UrlReq = UrlReq & [TabGps[Adresse]].Rows(R) & " "
            UrlReq = UrlReq & [TabGps[Cp]].Rows(R) & " "
            UrlReq = UrlReq & [TabGps[Ville]].Rows(R) & " "
            UrlReq = UrlReq & [TabGps[Pays]].Rows(R)
         
            [TabGps[[Longitude]:[Name]]].Rows(R) = GetGps([Site], UrlReq)
            [TabGps[Requête]].Rows(R) = UrlReq
         
        Next
        [TabGps].Calculate
    Application.ScreenUpdating = True
    MsgBox "Temps d'exécution : " & Timer - Stamp & " secondes."

End Sub
Function GetGps(Url, Adr) ' renvoie un tableau de 3 éléments:  latitude,longitude et Nom de l'endroit
Dim XmlHttpRequest  As Object
Dim Reponse         As Object
    GetGps = Array("", "", "Stop: Pas d'adresse indiquée")

    Adr = WorksheetFunction.EncodeURL(Trim(Adr))
    If Adr <> vbNullString Then
     
'        Set XmlHttpRequest = CreateObject("MSXML2.serverXMLHTTP")
        Set XmlHttpRequest = CreateObject("MSXML2.XMLHTTP")
        With XmlHttpRequest
            .Open "GET", Url & "/search?limit=1&format=xml&q=" & Adr, False
            .Send
            If .Status <> 200 Then
                GetGps = Array("", "", "Stop: " & .ResponseXML.Text)
                Err.Clear
             Else
                Set Reponse = .ResponseXML.SelectSingleNode("//place")
                If Not Reponse Is Nothing Then
                    With Reponse.Attributes
                     GetGps = Array(Format(.getnameditem("lat").Value, "0.00000"), _
                                    Format(.getnameditem("lon").Value, "0.00000"), _
                                           .getnameditem("display_name").Value)
                    End With
                    Set Reponse = Nothing
                Else
                    GetGps = Array("", "", "Stop: Pas de coordonnées pour l'adresse indiquée")
                End If
             End If
        End With
        Set XmlHttpRequest = Nothing
    End If

End Function
Cliquez pour agrandir...
ok merci mais cela ne me dit pas comment le faire marcher , j'ai ouvert libre office et j'ai bien la macro et les 2 feuilles j'ai saisi manuellement 2 nouvelles adresses et j'ai fait un copier coller des formules long et lat dans mes nouvelles lignes les cases restent vides comment lancer l'appli , je suis désolé mais je suis super novice sur ce genre de chose je ne suis qu'un utilisateur et je veux simplement récuperer les points GPS de mes clients pour afficher sur une carte merci bien
 
Vote positif 0 Vote négatif
V

vincent-laurent

XLDnaute Nouveau
fanch55 à dit:
Le lien en cliquant sur "exemple emploi" n'est pas un classeur
mais un fichier .Gif plus volumineux qua la taille autorisée par le forum .
Il est sur Google Drive, et je n'avais pas donné les bonnes autorisations de lecture, ce qui a été corrigé ce lundi.
Cliquez pour agrandir...
Ok merci beaucoup ca j'avais bien compris mais j'avais des pb de java non installé sur mon mac mais j'ai toujours maintenant des soucis d'assignation du bouton récupérer les infos mais pas grave je viens de trouver une routine sous libre office et OSM plus simple et qui marche bien que je vais adapter mais ca me suffit amplement pour récupérer les infos en csv en tout cas merci beaucoup pour votre temps
 

Pièces jointes

  • importgps.pdf
    21 KB · Affichages: 9
Vote positif 0 Vote négatif

Discussions similaires

K
  • Question
XL 2016 Comment replacer Internet explorer par EDGE?
Réponses
10
Affichages
1 K
patty58
patty58
R1-
  • Question
XL 2016 Obtenir des données client à partir de google Maps, VBA
Réponses
3
Affichages
822
R1-
R1-
shhsh
  • Question
Comment récuperer liste Liens du type <a href= "/.../..=xx.html" situé dans 1 Iframe?
2
Réponses
18
Affichages
8 K
shhsh
shhsh
C
  • Question
comment agir sur internet via un code VBA ?
Réponses
3
Affichages
9 K
cecile_64
C
M
[REF] Wiki Page 7 de MichelXld
Réponses
0
Affichages
51 K
MichelXld
M

Membres actuellement en ligne

6 membres et 66 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
314 628
Messages
2 111 337
Membres
111 104
dernier inscrit
JEMADA