AccessTr.neT

Tam Versiyon: Microsoft Access Kullanarak Boylam Coğrafi Kodlama
Şu anda arşiv modunu görüntülemektesiniz. Tam versiyonu görüntülemek için buraya tıklayınız.
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

[Resim: do.php?img=10273]