01/06/2020, 23:06
Public Type tGeocodeResult
dblLatitude As Double
dblLongitude As Double
strRetAddress As String
strAccuracy As String
strStatus As String
End Type'---------------------------------------------------------------------------------------
' Procedure : Geocode with Google Geocoding API v3
' Version : 1.01
' DateTime : 03/03/2011
' Author : Philben
' Purpose : converting addresses into geographic coordinates
' Parameter : No mandatory. string format or NULL
' Reference : http://code.google.com/intl/fr-FR/apis/m...index.html
' Remark : Query limit of 2,500 geolocation requests per day
' : A good accuracy is different of a good geocoding !!!
' : Minimum delay between two queries : >= 200 ms
'---------------------------------------------------------------------------------------
Public Function Geocode(Optional ByVal vAddress As Variant = Null, _
Optional ByVal vTown As Variant = Null, _
Optional ByVal vPostCode As Variant = Null, _
Optional ByVal vRegion As Variant = Null, _
Optional ByVal sCountry As String = "ITALY") As tGeocodeResult
On Error GoTo myErr
Dim oXmlDoc As Object
Dim sUrl As String, sFormatAddress As String
If Not IsNull(vAddress) Then vAddress = Replace(vAddress, ",", " ")
sFormatAddress = (vAddress + ",") & _
(vTown + ",") & _
(vRegion + ",") & _
(vPostCode + ",") & _
sCountry
'To create the URL
sUrl = "http://maps.googleapis.com/maps/api/geocode/xml?address=" & sFormatAddress & "&sensor=false"
''XMLDOM to get the XML response
Set oXmlDoc = CreateObject("Microsoft.XMLDOM")
With oXmlDoc
.Async = False
If .Load(sUrl) And Not .selectSingleNode("GeocodeResponse/status") Is Nothing Then
'Status code
Geocode.strStatus = .selectSingleNode("GeocodeResponse/status").Text
'If a result is returned
If Not .selectSingleNode("GeocodeResponse/result") Is Nothing Then
'formatted_address
Geocode.strRetAddress = .selectSingleNode("//formatted_address").Text
'Accuracy
Geocode.strAccuracy = .selectSingleNode("//location_type").Text
'Latitude and longitude
Geocode.dblLatitude = Val(.selectSingleNode("//location/lat").Text)
Geocode.dblLongitude = Val(.selectSingleNode("//location/lng").Text)
End If
End If
End With
Set oXmlDoc = Nothing
Exit Function
myErr:
Set oXmlDoc = Nothing
Err.Raise Err.Number, , Err.Description
End FunctionOn Error GoTo myErr
Dim tGeo As tGeocodeResult
'Start geocoding
tGeo = Geocode(PrepareAddress(Me.txtAddress), PrepareAddress(Me.txtCity), _
PrepareAddress(Me.txtZipCode), PrepareAddress(Me.txtRegion), _
PrepareAddress(Me.txtCountry))
'Display results
With tGeo
Me.txtRetAddress = .strRetAddress
Me.txtLatitude = .dblLatitude
Me.txtLongitude = .dblLongitude
Me.txtAccuracy = .strAccuracy
Me.txtStatus = .strStatus
End With
myEnd:
Exit Sub
myErr:
MsgBox Err.Number & vbCrLf & Err.Description, vbExclamation
Resume myEndPrivate Function PrepareAddress(ByVal vText As Variant) As Variant ' R. Dezan
Const csIn As String = "ÀÁÂÃÄÅÈÉÊËÌÍÎÏÑÐÒÓÔÕÖÙÚÛÜÝŸÇ"
Const csOut As String = "AAAAAAEEEEIIIINOOOOOOUUUUYYC"
Dim i As Long, j As Long
Dim sText As String
If Not IsNull(vText) Then
sText = UCase(vText)
For i = 1 To Len(sText)
j = InStr(1, csIn, Mid$(sText, i, 1), vbBinaryCompare)
If j Then Mid$(sText, i, 1) = Mid$(csOut, j, 1)
Next i
PrepareAddress = CVar(Replace(Replace(sText, "Œ", "OE"), "Æ", "AE"))
End If
End Function