VBA : Coordonnées GPS à partir d'une adresse

Bonsoir à toutes et à tous,

Je cherche désespérément une solution pour récupérer les coordonnées GPS à partir d'une adresse
Et il me faut des coordonnées les plus précises possible.

J'utilise ce code, mais les coordonnées semblent ne pas être assez précises pour Maps

Function GetCoordinate(ByVal pURL As String) As String
    Dim oRequest As Object
    Dim sLat As String, sLong As String, Result As String
    Dim Decomp() As String, Pos1 As Integer, Pos2 As Integer
    Set oRequest = CreateObject("WinHttp.WinHttpRequest.5.1")
    oRequest.Open "GET", pURL
    oRequest.Send
    repapi = oRequest.responseText
    Decomp = Split(repapi, ",""")                 'decompose la reponse API selon les blancs
    For i = LBound(Decomp) To UBound(Decomp)
      If InStr(1, Decomp(i), "coordinates") > 0 Then
        Pos1 = InStr(1, Decomp(i), ":[") + 2
        Pos2 = InStr(1, Decomp(i), "]") - 1
        sTmp = Mid(Decomp(i), Pos1, Pos2 - Pos1+1)
        ' Inverser Longitude et Latitude
        sLat = Mid(sTmp, InStr(1, sTmp, ",") + 1)
        sLong = Left(sTmp, InStr(1, sTmp, ",") - 1)
        Result = sLat & "," & sLong
        Exit For
      End If
    Next i
  GetCoordinate = Result
End Function

Savez-vous s'il en existent d'autres ?

A+

Bonsoir,

Vous pouvez par exemple utiliser cette API :

Function Adresse_GPS(adresse As String) As String
    '// ajouter la référence  Microsoft XML v6.0

    Dim url As String
    Dim temps_début As Long
    Dim doc_xml As DOMDocument60
    Const doc_loading As Integer = 1, doc_loaded As Integer = 2, doc_interactive As Integer = 3, doc_completed As Integer = 4
    Dim coordonnées As IXMLDOMNode

    '//URL API
    adresse = Replace(Trim(adresse), " ", "+")
    url = "https://nominatim.openstreetmap.org/search?format=xml" & "&q=" & adresse & "&polygon_kml=1&addressdetails=1"

    '// chargement du document xml à partir de l'url
    Set doc_xml = New DOMDocument60: doc_xml.Load url
    temps_début = Timer
    While doc_xml.readyState <> doc_completed
        DoEvents
        If Timer > temps_début + 30 Then MsgBox "temps de chargement de la page > 30 secondes -- Abandon": Exit Function
    Wend

    '// Récupération coordonnées GPS
    Set coordonnées = doc_xml.SelectSingleNode("/searchresults/place/geokml/Point/coordinates")
    If coordonnées Is Nothing Then MsgBox "coordonnées " & adresse & " non trouvées": Exit Function
    Adresse_GPS = Split(coordonnées.Text, ",")(1) & "," & Split(coordonnées.Text, ",")(0)

End Function

Bonjour thev et merci

Malheureusement ton code ne fonctionne pas, alors que l'adresse existe bien

A+

Effectuer cette modif :

    '//URL API
    adresse = Replace(Trim(adresse), ",", "+")

ou mettre des espaces au lieu des virgules dans l'adresse cherchée.