Skip to main content

AccessTr.neT


Microsoft Access Kullanarak Boylam Coğrafi Kodlama

Microsoft Access Kullanarak Boylam Coğrafi Kodlama

#1
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]
@benbendedeilem
Son Düzenleme: 01/06/2020, 23:12, Düzenleyen: accessman.
Cevapla

Bir hesap oluşturun veya yorum yapmak için giriş yapın

Yorum yapmak için üye olmanız gerekiyor

ya da
Task