Type PositionGps
latitude As String
longitude As String
Ville As String
End Type
Sub test()
Dim Pos As PositionGps
Pos = GPS
OpenInIE Pos.latitude, Pos.longitude
End Sub
Private Function GPS() As PositionGps
Dim Position As Object
' Obtenir la position de l'utilisateur
Set Position = GetCurrentPosition()
' Extraire les informations de position
GPS.latitude = Position("lat")
GPS.longitude = Position("lon")
GPS.Ville = Position("city")
End Function
Sub OpenInIE(latitude As String, longitude As String)
Dim iePath As String
Dim googleMapsURL As String
' Construire l'URL Google Maps
url = "https://www.openstreetmap.org/?mlat=" & latitude & "&mlon=" & longitude
googleMapsURL = "https://www.google.com/maps?q=" & latitude & "," & longitude
' Chemin vers Internet Explorer
iePath = "C:\Program Files\Internet Explorer\iexplore.exe"
' Vérifiez si Internet Explorer existe à cet emplacement
If Dir(iePath) = "" Then
MsgBox "Internet Explorer n'est pas installé ou n'est pas trouvé à l'emplacement attendu."
Exit Sub
End If
' Ouvrir Internet Explorer avec l'URL
Shell iePath & " " & googleMapsURL, vbNormalFocus
End Sub
Private Sub Workbook_Open()
Dim latitude As String
Dim longitude As String
Dim city As String
' Obtenir la position de l'utilisateur
Dim Position As Object
Set Position = GetCurrentPosition()
' Extraire les informations de position
latitude = Position("lat")
longitude = Position("lon")
city = Position("city")
' Afficher les informations récupérées
Debug.Print "Latitude: " & latitude
Debug.Print "Longitude: " & longitude
Debug.Print "Ville: " & city
' Ouvrir l'URL dans Internet Explorer
OpenInIE latitude, longitude
End Sub
Function GetCurrentPosition() As Object
Dim http As Object
Dim jsonResponse As Object
Dim url As String
url = "http://ip-api.com/json/"
' Créer une instance de l'objet XMLHttpRequest
Set http = CreateObject("MSXML2.XMLHTTP")
' Effectuer la requête GET
On Error GoTo ErrorHandler
http.Open "GET", url, False
http.Send
' Analyser la réponse JSON
Set jsonResponse = JsonConverter.ParseJson(http.responseText)
' Nettoyer
Set http = Nothing
' Retourner la réponse JSON
Set GetCurrentPosition = jsonResponse
Exit Function
ErrorHandler:
' Gestion des erreurs
MsgBox "Erreur lors de la récupération des données : " & Err.Description
Set GetCurrentPosition = Nothing
Set http = Nothing
End Function