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 Function

On 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 myEnd

Private 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