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
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
|
Option Compare Database
Option Explicit
'Type des éléments de l'adresse postale
Public Type tGTPComposant
sType As String
sValeur As String
End Type
'Type public contenant l'adresse postale à partir de la latitude et longitude
Public Type tGeoToPostal
sAdresse As String
atComposants() As tGTPComposant
dRetLatitude As Double
dRetLongitude As Double
sType As String
sExactitude As String
sStatut As String
End Type
Public Function TestGeocodageInverse()
Const csTitre As String = "Géocodage inversé..."
Dim tGp As tGeoToPostal
Dim dLatitude As Double, dLongitude As Double, dEcart As Double
Dim i As Long
Dim sMsg As String
'Rensigner ici la latitude [-90,90], longitude [-180,180]
dLatitude = 45.55875
dLongitude = 4.954854
tGp = GeoToPostalViaGM(dLatitude, dLongitude)
sMsg = "Résultat du géocodage inversé pour " & dLatitude & "/" & dLongitude & " :" & vbCrLf & vbCrLf
If tGp.sStatut = "OK" Then
dEcart = DistanceKm(dLatitude, dLongitude, tGp.dRetLatitude, tGp.dRetLongitude)
sMsg = sMsg & "Adresse postale : " & tGp.sAdresse & vbCrLf & _
"Exactitude : " & tGp.sExactitude & vbCrLf & _
"Type résultat : " & tGp.sType & vbCrLf & _
"Ecart (km) : " & format(dEcart, "0.000") & vbCrLf & vbCrLf & _
"Composants de l'adresse :"
For i = LBound(tGp.atComposants) To UBound(tGp.atComposants)
sMsg = sMsg & vbCrLf & tGp.atComposants(i).sType & " : " & tGp.atComposants(i).sValeur
Next i
MsgBox sMsg, vbInformation, csTitre
Else
MsgBox sMsg & "Statut retourné non conforme : " & tGp.sStatut, vbExclamation, csTitre
End If
End Function
'---------------------------------------------------------------------------------------
' Procedure : GeoToPostalViaGM -> Google Geocoding API v3
' Version : 1.0
' DateTime : 22/12/2010 08:10
' Author : Philippe
' Purpose : Rechercher une adresse postale à partir d'une latitude et longitude
' Paramètre : Latitude et longitude en degrés décimaux
' Retour : Une structure tGeoToPostal contenant l'adresse postale et ses composants,
' la latitude et longitude correspondante, l'exactitude du géocodage
' le type et le statut du géocodage.
' Infos : Statut retourné par Google :
' - "OK" : Pas d'erreur
' - "ZERO_RESULTS" : Géocodage ok mais pas de résultat
' - "OVER_QUERY_LIMIT" : Quota dépassé des demandes de géocodage
' - "REQUEST_DENIED" : Demande refusée
' - "INVALID_REQUEST" : Requête non valide
' : Exactitude du géocodage :
' - "ROOFTOP" : Excellente, précision au n° de rue ?
' - "RANGE_INTERPOLATED": Bonne précision, supérieure à la rue ?
' - "GEOMETRIC_CENTER" : Correcte, précision à la rue
' - "APPROXIMATE" : Approximation du résultat...
' Référence : http://code.google.com/intl/fr-FR/apis/maps/documentation/geocoding/index.html#ReverseGeocoding
'---------------------------------------------------------------------------------------
Public Function GeoToPostalViaGM(ByVal dLatitude As Double, ByVal dLongitude As Double) As tGeoToPostal
On Error GoTo catch
Dim oXmlDoc As Object, oXmlNode As Object
Dim i As Long
Dim sUrl As String, sLatLng As String
sLatLng = toStr(dLatitude) & "," & toStr(dLongitude)
'Création de l'URL d'appel, renvoi d'un xml contenant les informations
sUrl = "http://maps.googleapis.com/maps/api/geocode/xml?latlng=" & sLatLng & "&sensor=false"
'Créér l'objet xml
Set oXmlDoc = CreateObject("Microsoft.XMLDOM")
With oXmlDoc
.Async = False
If .Load(sUrl) And Not .selectSingleNode("GeocodeResponse/status") Is Nothing Then
'Code retour de l'appel
GeoToPostalViaGM.sStatut = .selectSingleNode("GeocodeResponse/status").Text
'S'il existe un résultat du géocodage
If Not .selectSingleNode("GeocodeResponse/result") Is Nothing Then
'on récupère le premier résultat qui est le meilleur
With .selectSingleNode("GeocodeResponse/result")
GeoToPostalViaGM.sType = .selectSingleNode("type").Text
GeoToPostalViaGM.sAdresse = .selectSingleNode("formatted_address").Text
GeoToPostalViaGM.dRetLatitude = Val(.selectSingleNode("//location/lat").Text)
GeoToPostalViaGM.dRetLongitude = Val(.selectSingleNode("//location/lng").Text)
GeoToPostalViaGM.sExactitude = .selectSingleNode("//location_type").Text
'et les composants de l'adresse
ReDim GeoToPostalViaGM.atComposants(1 To .selectNodes("address_component").length)
For Each oXmlNode In .selectNodes("address_component")
i = i + 1
GeoToPostalViaGM.atComposants(i).sValeur = oXmlNode.selectSingleNode("long_name").Text
GeoToPostalViaGM.atComposants(i).sType = oXmlNode.selectSingleNode("type").Text
Next oXmlNode
End With
End If
End If
End With
finally:
Set oXmlNode = Nothing
Set oXmlDoc = Nothing
Exit Function
catch:
MsgBox "Erreur n°:" & Err & vbCrLf & "Description:" & Err.Description, vbExclamation, "GeoToPostalViaGM"
Resume finally
End Function
'Conversion d'un nombre en texte
Public Function toStr(ByVal dValeur As Double) As String
toStr = Replace(format(dValeur, "0.0#####"), ",", ".")
End Function
'pour calculer l'écart de distance (coordonnées en degrés décimaux)
Public Function DistanceKm(ByVal dLat1 As Double, ByVal dLon1 As Double, _
ByVal dLat2 As Double, ByVal dLon2 As Double) As Double
dLat1 = DegreDecToRadian(dLat1)
dLat2 = DegreDecToRadian(dLat2)
dLon1 = DegreDecToRadian(dLon1)
dLon2 = DegreDecToRadian(dLon2)
DistanceKm = 6371 * ArcCosRad(Cos(dLat1) * Cos(dLat2) * Cos(dLon2 - dLon1) + (Sin(dLat1) * Sin(dLat2)))
End Function
Private Function ArcCosRad(dRadian As Double) As Double
Const pi As Double = 3.14159265358979
If dRadian > -1 And dRadian < 1 Then
ArcCosRad = Atn(-dRadian / Sqr(-dRadian * dRadian + 1)) + pi / 2
ElseIf dRadian = -1 Then
ArcCosRad = pi
End If
End Function
Public Function DegreDecToRadian(ByVal dAngle As Double)
DegreDecToRadian = 3.14159265358979 * dAngle / 180
End Function |
Géocodage inversé pour retrouver une adresse postale
Répondre avec citation
Partager