Koordinatlara Göre Haritada Yer Gösterme

1 2 3
17/12/2008, 10:15

esrefigit

daha ayrıntılı bir şekilde kullanmak isteyenler için googlemap classmodülü

Option Compare Text
Option Explicit

'Windows API function to close Map_Viewer window
Private Declare Function CloseWindow Lib "user32" _
Alias "DestroyWindow" _
(ByVal hwnd As Long) _
As Boolean

'Public events
Public Event StartMap()

Public Event MapClick(Lat As Double, Lng As Double)
Public Event MapDblClick(Lat As Double, Lng As Double)

Public Event MarkerClick(markernum As Integer, Lat As Double, Lng As Double)
Public Event MarkerDblClick(markernum As Integer, Lat As Double, Lng As Double)
Public Event MarkerDragStart(markernum As Integer, Lat As Double, Lng As Double)
Public Event MarkerDragEnd(markernum As Integer, Lat As Double, Lng As Double)

Public Event DirectionsLoaded(Status As Integer, RoutesRS As ADODB.Recordset, StepsRS As ADODB.Recordset)
Public Event GeocodeLoaded(Status As Integer, GeoRecordset As ADODB.Recordset)

'global variables
Private objMap As Object
Private objWebBrowser As Object
Private blnWaitForCallback As Boolean
Private varReturnValue As Variant
Private blnMapStarted As Boolean
Private varGeoResponse() As Variant
Private adoGeocode As ADODB.Recordset
Private adoDirRoutes As ADODB.Recordset
Private adoDirSteps As ADODB.Recordset
Private strError As String

'enumerations for map
Public Enum gmTypesOfControls
Small_Control = 1
Large_Control = 2
Small_Zoom_Control = 3
Scale_Control = 4
Map_Type_Control = 5
Overview_Control = 6
End Enum

Public Enum gmMarkerIconTypes
Basic = 0
Custom = 1
lettered = 2
End Enum

Public Enum gmMapTypes
Normal = 1
Sattelite = 2
Hybrid = 3
Physical = 4
Google_Earth = 5
End Enum

Public Enum gmWhichPoints
None = 0
First = 1
All = 2
End Enum

Public Enum gmUnits
Meters = 1
Miles = 2
End Enum

Public Enum GeocodeResponse
GeoName = 0
GeoNumOfLocations = 1
GeoStatus = 2
GeoAddress = 3
GeoCity = 4
GeoState = 5
GeoZip = 6
GeoCounty = 7
GeoCountry = 8
GeoAccuracy = 9
GeoLatitude = 10
GeoLongitude = 11
End Enum

Public Sub DefaultCallback()
'invisible attribute set to make this the default method of the class

Dim strCallbackEvent As String
Dim varCallbackData As Variant
Dim blnResultOk As Boolean
Dim varCallbackResult As Variant

varCallbackResult = Split(objWebBrowser.Document.GetElementById("callbackDiv").innerText, "-=-")

strCallbackEvent = varCallbackResult(0)
varCallbackData = Replace(varCallbackResult(1), "(", "")
varCallbackData = Replace(varCallbackData, ")", "")
varCallbackData = Split(varCallbackData, ",")
blnResultOk = varCallbackData(0)

Select Case strCallbackEvent
'These CallbackEvent's will simple send back a true of false to the function "waiting for callback"
Case "Draggable", _
"Add Control", _
"Remove Control", _
"Clear Overlay", _
"Map Type Change", _
"Create Marker", _
"Create InfoWindow", _
"Create Polyline", _
"Center Map", _
"Zoom Map", _
"Create Icon"

If blnResultOk Then
varReturnValue = (CInt(varCallbackData(1)))
Else
varReturnValue = -1
'if result is not ok then raise the error event
SetError (strCallbackEvent & ". " & CStr(varCallbackData(1)))
End If
Case "Map CenterPoint"
varReturnValue = (CStr(varCallbackData(1)) & "," & CStr(varCallbackData(2)))

'Raise Events
Case "Polyline Length"
If blnResultOk Then
varReturnValue = CDbl(varCallbackData(1))
Else
varReturnValue = -1
SetError (CStr(varCallbackData(2))), 202
End If
Case "Load Map"
varReturnValue = True
RaiseEvent StartMap
Case "Clicked Map"
If CStr(varCallbackData(1)) <> "undefined" Then
RaiseEvent MapClick(CDbl(varCallbackData(1)), CDbl(varCallbackData(2)))
End If
Case "dblClicked Map"
RaiseEvent MapDblClick(CDbl(varCallbackData(1)), CDbl(varCallbackData(2)))
Case "Clicked Marker"
RaiseEvent MarkerClick(CInt(varCallbackData(1)), CDbl(varCallbackData(2)), CDbl(varCallbackData(3)))
Case "dblClicked Marker"
RaiseEvent MarkerDblClick(CInt(varCallbackData(1)), CDbl(varCallbackData(2)), CDbl(varCallbackData(3)))
Case "Drag Start"
RaiseEvent MarkerDragStart(CInt(varCallbackData(1)), CDbl(varCallbackData(2)), CDbl(varCallbackData(3)))
Case "Drag End"
RaiseEvent MarkerDragEnd(CInt(varCallbackData(1)), CDbl(varCallbackData(2)), CDbl(varCallbackData(3)))
Case "Directions"
varReturnValue = blnResultOk
If blnResultOk Then
varCallbackData = Split(varCallbackResult(1), ",", 3, vbTextCompare)
varCallbackData(2) = Replace(CStr(varCallbackData(2)), "&nbsp;", " ")
CreateDirectionsRecordsets CStr(varCallbackData(2))
RaiseEvent DirectionsLoaded(CInt(varCallbackData(1)), adoDirRoutes, adoDirSteps)
Else
SetError "Directions Error", CInt(varCallbackData(1))
End If
Case "Geocode"
If blnResultOk Then
varCallbackData = Split(varCallbackResult(1), ",", 3, vbTextCompare)
ParseGeocodeString CStr(varCallbackData(2))
CreateGeoCodeRecordset
varReturnValue = varGeoResponse(0, 1)

RaiseEvent GeocodeLoaded(CInt(varCallbackData(1)), adoGeocode)
Else
varReturnValue = -1
SetError "Geocode Error", CInt(varCallbackData(1))
End If
End Select
blnWaitForCallback = False
End Sub

Private Sub SetError(Optional strDescription As String = "Unknown Error", _
Optional intErrorNum As Integer = 201)

On Error Resume Next

Select Case intErrorNum

Case 201
'this is a general map error - just return the strdescription that is already assigned
Case 300
strDescription = "Subscript out of range"
Case 400
strDescription = "Bad Request"
Case 500
strDescription = "Server Error"
Case 601
strDescription = "Missing Query/Address. No Address Given"
Case 602
strDescription = "Unknown Address. No corresponding geographic location could be found for the specified address"
Case 603
strDescription = "Unavailible Address. Geocode/Directions cannot be given for legal or cantractual reasons"
Case 604
strDescription = "Unknown Directions. No Route Availible"
Case 610
'if the Html file is located on the local machine - this error should never be thrown
'google maps ignores the key (or at least the domain that is assigned to the key)
'when the file is on the local machine
strDescription = "Bad Key. The given google maps key is either invalid or does not match the domain for which it was given"
Case 620
strDescription = "Too Many Queries. The given key has gone over the requests limit in the 24 hour period"
End Select

strError = vbObjectError + 513 + intErrorNum & ",Google Maps," & strDescription
End Sub
Private Function GetCallback(ByVal Script As String) As Variant
blnWaitForCallback = True
objWebBrowser.Document.parentwindow.execscript Script, "JavaScript"
Do Until (Not blnWaitForCallback)
DoEvents
Loop
GetCallback = varReturnValue
End Function
Private Sub Class_Initialize()
blnMapStarted = False
blnWaitForCallback = False
End Sub

Public Property Set SetWebBrowser(WebBrowser As Object)
If Not (objMap Is Nothing) Then
Me.MapViewerClose
objMap = Nothing
End If

Set objWebBrowser = WebBrowser

LoadMap

End Property

Public Sub LoadMap(Optional ByVal blnShowMap As Boolean = False)
If objWebBrowser Is Nothing Then
Set objMap = New Form_Map_Viewer
Set objWebBrowser = objMap.MapContainer
objMap.Caption = "Maps by Google!"
objMap.Visible = blnShowMap
End If

objWebBrowser.Navigate Application.CurrentProject.Path & "/googlemaps.html"

Do Until objWebBrowser.ReadyState = 4
DoEvents
Loop

'initialize the map and set the callback procedure
objWebBrowser.Document.GetElementById("callbackDiv").onpropertychange = Me

blnMapStarted = False
End Sub

Public Function StartMap(Optional ByVal Lat As Double = -1, _
Optional ByVal Lng As Double = -1, _
Optional ByVal Zoom As Integer = -1)

If objWebBrowser Is Nothing Then LoadMap

blnMapStarted = GetCallback("startMap(" & IIf(Lat <> -1, Lat, "null") & "," & _
IIf(Lng <> -1, Lng, "null") & "," & _
IIf(Zoom <> -1, Zoom, "null") & ");")

StartMap = blnMapStarted
End Function

Public Sub MapViewerVisibility(ByVal blnVisible As Boolean)

If Not (objMap Is Nothing) Then
objMap.Visible = blnVisible
End If

End Sub

Public Sub MapViewerMove(Optional ByVal LeftTwips As Integer, _
Optional ByVal TopTwips As Integer = -1, _
Optional ByVal WidthTwips As Integer = -1, _
Optional ByVal HeightTwips As Integer = -1)

If Not (objMap Is Nothing) Then
objMap.Move IIf(LeftTwips >= 0, LeftTwips, objMap.WindowLeft), _
IIf(TopTwips >= 0, TopTwips, objMap.WindowTop), _
IIf(WidthTwips >= 0, WidthTwips, objMap.WindowWidth), _
IIf(HeightTwips >= 0, HeightTwips, objMap.WindowHeight)
End If

End Sub

Public Sub MapViewerClose()
On Error Resume Next
If Not (objMap Is Nothing) Then
CloseWindow objMap.hwnd
End If
End Sub

Public Sub MapViewerCaption(ByVal NewCaption As String)
If Not (objMap Is Nothing) Then
objMap.Caption = NewCaption
End If
End Sub

Public Property Get MapViewerTop()
If Not (objMap Is Nothing) Then
MapViewerTop = objMap.WindowTop
End If
End Property
Public Property Get MapViewerLeft()
If Not (objMap Is Nothing) Then
MapViewerLeft = objMap.WindowLeft
End If
End Property
Public Property Get MapViewerWidth()
If Not (objMap Is Nothing) Then
MapViewerWidth = objMap.WindowWidth
End If
End Property
Public Property Get MapViewerHeight()
If Not (objMap Is Nothing) Then
MapViewerHeight = objMap.WindowHeight
End If
End Property

'map controling functions
Public Function CenterMapAt(Optional ByVal Lat As Double = -1, _
Optional ByVal Lng As Double = -1)

If objWebBrowser Is Nothing Then LoadMap
If Not blnMapStarted Then StartMap

Dim ParamString As String
ParamString = IIf(Lat = -1, "null", Lat) & "," & IIf(Lng = -1, "null", Lng)
CenterMapAt = GetCallback("centerMap(" & ParamString & ");")

End Function
Public Function ZoomTo(ByVal ZoomLevel As Integer)

If objWebBrowser Is Nothing Then LoadMap
If Not blnMapStarted Then StartMap

ZoomTo = GetCallback("zoomTo(" & ZoomLevel & ");")

End Function
Public Function AddControl(ByVal ControlType As gmTypesOfControls)
If objWebBrowser Is Nothing Then LoadMap
If Not blnMapStarted Then StartMap

AddControl = GetCallback("addControl(" & ControlType & ");")
If AddControl = -1 Then
Dim varError As Variant
varError = Split(strError, ",")
Err.Raise varError(0), varError(1), varError(2)
End If
End Function
Public Function RemoveControl(ByVal ControlType As gmTypesOfControls)
If objWebBrowser Is Nothing Then LoadMap
If Not blnMapStarted Then StartMap

RemoveControl = GetCallback("removeControl(" & ControlType & ",true);")
If RemoveControl = -1 Then
Dim varError As Variant
varError = Split(strError, ",")
Err.Raise varError(0), varError(1), varError(2)
End If
End Function
Public Function RemoveOverlay(ByVal OverlayIndex As Integer)
If objWebBrowser Is Nothing Then LoadMap
If Not blnMapStarted Then StartMap

RemoveOverlay = GetCallback("removeOverlays(" & OverlayIndex & ");")
If RemoveOverlay = -1 Then
Dim varError As Variant
varError = Split(strError, ",")
Err.Raise varError(0), varError(1), varError(2)
End If
End Function
Public Function RemoveAllOverlays()
If objWebBrowser Is Nothing Then LoadMap
If Not blnMapStarted Then StartMap

RemoveAllOverlays = GetCallback("removeOverlays(-1);")
If RemoveAllOverlays = -1 Then
Dim varError As Variant
varError = Split(strError, ",")
Err.Raise varError(0), varError(1), varError(2)
End If
End Function
Public Function CreateCustomIcon(ByVal IconURL As String, _
ByVal ShadowURL As String, _
ByVal IconX As Integer, _
ByVal IconY As Integer, _
ByVal ShadowX As Integer, _
ByVal ShadowY As Integer, _
ByVal IconAnchorX As Integer, _
ByVal IconAnchorY As Integer, _
ByVal InfoWindowAnchorX As Integer, _
ByVal InfoWindowAnchorY As Integer, _
ByVal InfoWindowShadowAnchorX As Integer, _
ByVal InfoWindowShadowAnchorY As Integer)

If objWebBrowser Is Nothing Then LoadMap
If Not blnMapStarted Then StartMap

Dim ParamString As String
ParamString = """" & IconURL & """," & _
"""" & ShadowURL & """," & _
IconX & "," & _
IconY & "," & _
ShadowX & "," & _
ShadowY & "," & _
IconAnchorX & "," & _
IconAnchorY & "," & _
InfoWindowAnchorX & "," & _
InfoWindowAnchorY & "," & _
InfoWindowShadowAnchorX & "," & _
InfoWindowShadowAnchorY

CreateCustomIcon = GetCallback("createIcon(" & ParamString & ");")
End Function
Public Function PlaceMarker(ByVal Lat As Double, _
ByVal Lng As Double, _
Optional ByVal UseIcon As gmMarkerIconTypes = 0, _
Optional ByVal MarkerLetter As String = "A")
If objWebBrowser Is Nothing Then LoadMap
If Not blnMapStarted Then StartMap

Dim MarkerIndex As Integer
MarkerIndex = Asc(Left(UCase(MarkerLetter), 1)) - 65
If MarkerIndex < 0 Then MarkerIndex = 0
If MarkerIndex > 25 Then MarkerIndex = 25

Dim ParamString As String
ParamString = Lat & "," & _
Lng & "," & _
UseIcon & "," & _
MarkerIndex

PlaceMarker = GetCallback("createMarker(" & ParamString & ",true);")
If PlaceMarker = -1 Then
Dim varError As Variant
varError = Split(strError, ",")
Err.Raise varError(0), varError(1), varError(2)
End If
End Function
Public Function AddInfoWindow(ByVal MarkerNumber As Integer, _
ByVal InfoMarkup As String)
If objWebBrowser Is Nothing Then LoadMap
If Not blnMapStarted Then StartMap

AddInfoWindow = GetCallback("createInfoWindow(" & MarkerNumber & ",""" & InfoMarkup & """);")
If AddInfoWindow = -1 Then
Dim varError As Variant
varError = Split(strError, ",")
Err.Raise varError(0), varError(1), varError(2)
End If
End Function
Public Function Draggable(ByVal MarkerNumber As Integer, _
Optional CanDrag As Boolean = True)
If objWebBrowser Is Nothing Then LoadMap
If Not blnMapStarted Then StartMap

Draggable = GetCallback("makeDraggable(" & MarkerNumber & "," & LCase(CanDrag) & ");")
If Draggable = -1 Then
Dim varError As Variant
varError = Split(strError, ",")
Err.Raise varError(0), varError(1), varError(2)
End If
End Function
Public Function ChangeMapType(ByVal MapType As gmMapTypes)
If objWebBrowser Is Nothing Then LoadMap
If Not blnMapStarted Then StartMap

ChangeMapType = GetCallback("changeMapType(" & MapType & ");")
If ChangeMapType = -1 Then
Dim varError As Variant
varError = Split(strError, ",")
Err.Raise varError(0), varError(1), varError(2)
End If
End Function
Public Function PolylineBetweenMarkers(ByVal FromMarker As Integer, _
ByVal ToMarker As Integer, _
Optional ByVal Color As Long = 0, _
Optional ByVal LineWeight As Integer = 1, _
Optional ByVal LineOpacity As Integer = 1, _
Optional ByVal Geodesic As Boolean = False)

If objWebBrowser Is Nothing Then LoadMap
If Not blnMapStarted Then StartMap

Dim HexColor As String
HexColor = Left("#" & Hex(Color) & "00000", 7)

Dim ParamString As String
ParamString = FromMarker & "," & _
ToMarker & ",""" & _
HexColor & """," & _
LineWeight & "," & _
LineOpacity & "," & _
LCase(Geodesic)
PolylineBetweenMarkers = GetCallback("addLineBetweenMarkers(" & ParamString & ");")
If PolylineBetweenMarkers = -1 Then
Dim varError As Variant
varError = Split(strError, ",")
Err.Raise varError(0), varError(1), varError(2)
End If
End Function
Public Function PolylineBetweenLatLng(ByVal FromLat As Double, ByVal FromLng As Double, _
ByVal ToLat As Double, ByVal ToLng As Double, _
Optional ByVal Color As Long = 0, _
Optional ByVal LineWeight As Integer = 1, _
Optional ByVal LineOpacity As Single = 1, _
Optional ByVal Geodesic As Boolean = False)
If objWebBrowser Is Nothing Then LoadMap
If Not blnMapStarted Then StartMap

Dim HexColor As String
HexColor = Left("#" & Hex(Color) & "00000", 7)

Dim ParamString As String
ParamString = FromLat & "," & FromLng & "," & _
ToLat & "," & ToLng & ",""" & _
HexColor & """," & _
LineWeight & "," & _
LineOpacity & "," & _
LCase(Geodesic)

PolylineBetweenLatLng = GetCallback("addLineBetweenLatLngs(" & ParamString & ");")
If PolylineBetweenLatLng = -1 Then
Dim varError As Variant
varError = Split(strError, ",")
Err.Raise varError(0), varError(1), varError(2)
End If
End Function
Public Property Get PolylineLength(ByVal PolylineIndex As Integer, _
ByVal ReturnUnits As gmUnits)
Dim returned
returned = GetCallback("getPolylineLength(" & PolylineIndex & ");")
PolylineLength = returned * (IIf(ReturnUnits = Miles, 0.000621371192, ReturnUnits))
If PolylineLength = -1 Then
Dim varError As Variant
varError = Split(strError, ",")
Err.Raise varError(0), varError(1), varError(2)
End If

End Property
Public Property Get CenterOfMap()

If objWebBrowser Is Nothing Then LoadMap
If Not blnMapStarted Then StartMap

CenterOfMap = GetCallback("getMapCenter();")
End Property
Public Sub SimpleDirections(ByVal FromAddress As String, _
ParamArray ToAddress() As Variant)
If objWebBrowser Is Nothing Then LoadMap
If Not blnMapStarted Then StartMap

Dim ParamString As String
ParamString = """" & FromAddress & """"
Dim intI As Integer
For intI = 0 To UBound(ToAddress())
ParamString = ParamString & ",""" & ToAddress(intI) & """"
Next intI

Dim varResult As Variant
varResult = GetCallback("getDirections(" & ParamString & ");")
If varResult = False Then
Dim varError As Variant
varError = Split(strError, ",")
Err.Raise varError(0), varError(1), varError(2)
End If
End Sub
Public Sub DirectionsUsingMarkers(ByVal FromMarkerNum As Integer, _
ParamArray ToMarkerNum() As Variant)
If objWebBrowser Is Nothing Then LoadMap
If Not blnMapStarted Then StartMap

Dim ParamString As String
ParamString = FromMarkerNum
Dim intI As Integer
For intI = 0 To UBound(ToMarkerNum())
ParamString = ParamString & "," & ToMarkerNum(intI)
Next intI

Dim varResult As Variant
varResult = GetCallback("getDirectionsUsingMarkers(" & ParamString & ");")
If varResult = False Then
Dim varError As Variant
varError = Split(strError, ",")
Err.Raise varError(0), varError(1), varError(2)
End If
End Sub
Private Sub CreateDirectionsRecordsets(DirectionsString As String)
Set adoDirRoutes = New ADODB.Recordset
Set adoDirSteps = New ADODB.Recordset


adoDirRoutes.Fields.Append "RouteID", adInteger
adoDirRoutes.Fields.Append "StartPoint", adVarChar, 150
adoDirRoutes.Fields.Append "EndPoint", adVarChar, 150
adoDirRoutes.Fields.Append "Duration", adVarChar, 50
adoDirRoutes.Fields.Append "Distance", adVarChar, 50


adoDirSteps.Fields.Append "RouteID", adInteger
adoDirSteps.Fields.Append "StepID", adInteger
adoDirSteps.Fields.Append "Description", adVarChar, 500
adoDirSteps.Fields.Append "Duration", adVarChar, 50
adoDirSteps.Fields.Append "Distance", adVarChar, 50


adoDirRoutes.CursorLocation = adUseClient
adoDirRoutes.LockType = adLockOptimistic
adoDirSteps.CursorLocation = adUseClient
adoDirSteps.LockType = adLockOptimistic

adoDirRoutes.Open
adoDirSteps.Open

adoDirRoutes.AddNew
adoDirRoutes.Fields("RouteID") = 0
adoDirRoutes.Fields("Duration") = grabElement(DirectionsString, "T")
adoDirRoutes.Fields("Distance") = grabElement(DirectionsString, "D")
adoDirRoutes.Fields("StartPoint") = grabElement(DirectionsString, "add")
adoDirRoutes.Fields("EndPoint") = grabElement(DirectionsString, "end")
adoDirRoutes.Update

Dim RouteLoop As Integer
Dim StepLoop As Integer
Dim RouteString As String
Dim StepString As String

RouteLoop = 1
StepLoop = 1

Do Until InStr(1, DirectionsString, "r" & RouteLoop, vbTextCompare) = 0
RouteString = grabElement(DirectionsString, "r" & RouteLoop)
adoDirRoutes.AddNew
adoDirRoutes.Fields("RouteID") = RouteLoop
adoDirRoutes.Fields("Duration") = grabElement(RouteString, "T")
adoDirRoutes.Fields("Distance") = grabElement(RouteString, "D")
adoDirRoutes.Fields("StartPoint") = grabElement(RouteString, "add")
If InStr(1, DirectionsString, "r" & (RouteLoop + 1), vbTextCompare) = 0 Then
adoDirRoutes.Fields("Endpoint") = grabElement(DirectionsString, "end")
Else
adoDirRoutes.Fields("EndPoint") = grabElement(grabElement(DirectionsString, "r" & (RouteLoop + 1)), "add")
End If
adoDirRoutes.Update
Do Until InStr(1, RouteString, "s" & StepLoop, vbTextCompare) = 0
StepString = grabElement(RouteString, "s" & StepLoop)
adoDirSteps.AddNew
adoDirSteps.Fields("RouteID") = RouteLoop
adoDirSteps.Fields("StepID") = StepLoop
adoDirSteps.Fields("Duration") = grabElement(StepString, "t")
adoDirSteps.Fields("Distance") = grabElement(StepString, "d")
adoDirSteps.Fields("Description") = grabElement(StepString, "desc")
adoDirSteps.Update

StepLoop = StepLoop + 1
Loop
RouteLoop = RouteLoop + 1
StepLoop = 1
Loop
adoDirRoutes.MoveFirst
adoDirSteps.MoveFirst
End Sub
Public Function GeocodeAddress(ByVal address As String, _
Optional ByVal ShowPoints As gmWhichPoints = 2)
If objWebBrowser Is Nothing Then LoadMap
If Not blnMapStarted Then StartMap


GeocodeAddress = CInt(GetCallback("geocodeAddress(""" & address & """," & ShowPoints & ");"))
If GeocodeAddress = -1 Then
Dim varError As Variant
varError = Split(strError, ",")
Err.Raise varError(0), varError(1), varError(2)
End If
End Function
Private Function ParseGeocodeString(GeoCodedString As String)
Dim NumOfLocations As Integer
NumOfLocations = CInt(grabElement(GeoCodedString, "#ofP"))
ReDim varGeoResponse((NumOfLocations - 1), 12)
Dim strTempLocal As String
Dim LocationLoop As Integer
For LocationLoop = 0 To (NumOfLocations - 1)
varGeoResponse(LocationLoop, 0) = grabElement(GeoCodedString, "n")
varGeoResponse(LocationLoop, 1) = NumOfLocations
varGeoResponse(LocationLoop, 2) = grabElement(GeoCodedString, "sC")
strTempLocal = grabElement(GeoCodedString, "Pm" & LocationLoop)
varGeoResponse(LocationLoop, 3) = grabElement(strTempLocal, "add")
varGeoResponse(LocationLoop, 4) = grabElement(strTempLocal, "city")
varGeoResponse(LocationLoop, 5) = grabElement(strTempLocal, "st")
varGeoResponse(LocationLoop, 6) = grabElement(strTempLocal, "zip")
varGeoResponse(LocationLoop, 7) = grabElement(strTempLocal, "cty")
varGeoResponse(LocationLoop, 8) = grabElement(strTempLocal, "ctry")
varGeoResponse(LocationLoop, 9) = grabElement(strTempLocal, "acc")
varGeoResponse(LocationLoop, 10) = grabElement(strTempLocal, "lat")
varGeoResponse(LocationLoop, 11) = grabElement(strTempLocal, "lng")
Next LocationLoop
ParseGeocodeString = NumOfLocations
End Function
Private Function grabElement(GeocodedStr As String, GeoSection As String) As Variant
Dim StartOfElement As Integer
Dim LengthOfElement As Integer
StartOfElement = InStr(1, GeocodedStr, "[" & GeoSection & "]", vbTextCompare) + Len("[" & GeoSection & "]")
LengthOfElement = InStr(1, GeocodedStr, "[/" & GeoSection & "]", vbTextCompare) - StartOfElement
grabElement = Mid(GeocodedStr, IIf(StartOfElement, StartOfElement, 1), LengthOfElement)
End Function
Public Property Get GeocodeDetail(AddressIndex As Integer, GeoDetail As GeocodeResponse) As Variant
If AddressIndex > UBound(varGeoResponse, 1) Then
AddressIndex = UBound(varGeoResponse, 1)
End If
GeocodeDetail = varGeoResponse(AddressIndex, GeoDetail)
End Property
Private Function CreateGeoCodeRecordset()
Set adoGeocode = New ADODB.Recordset

adoGeocode.Fields.Append "LocationNumber", adInteger
adoGeocode.Fields.Append "Address", adChar, 100
adoGeocode.Fields.Append "City", adVarChar, 100
adoGeocode.Fields.Append "State", adVarChar, 50
adoGeocode.Fields.Append "Zip", adVarChar, 10
adoGeocode.Fields.Append "County", adVarChar, 50
adoGeocode.Fields.Append "Country", adVarChar, 50
adoGeocode.Fields.Append "Accuracy", adInteger
adoGeocode.Fields.Append "Latitude", adDouble
adoGeocode.Fields.Append "Longitude", adDouble

adoGeocode.CursorLocation = adUseClient
adoGeocode.LockType = adLockOptimistic
adoGeocode.Open

Dim rsLoop As Integer

For rsLoop = 0 To UBound(varGeoResponse, 1)
adoGeocode.AddNew
adoGeocode("LocationNumber") = CInt(rsLoop)
adoGeocode("Address") = varGeoResponse(rsLoop, 3)
adoGeocode("City") = varGeoResponse(rsLoop, 4)
adoGeocode("State") = varGeoResponse(rsLoop, 5)
adoGeocode("Zip") = varGeoResponse(rsLoop, 6)
adoGeocode("County") = varGeoResponse(rsLoop, 7)
adoGeocode("Country") = varGeoResponse(rsLoop, 8)
adoGeocode("Accuracy") = varGeoResponse(rsLoop, 9)
adoGeocode("Latitude") = varGeoResponse(rsLoop, 10)
adoGeocode("Longitude") = varGeoResponse(rsLoop, 11)
adoGeocode.Update
Next rsLoop
adoGeocode.MoveFirst
End Function

Private Sub Class_Terminate()
Me.MapViewerClose
Set objMap = Nothing
Set objWebBrowser = Nothing
End Sub
17/12/2008, 12:46

ayhan2122

12/03/2009, 08:42

birgizlidost

Yaptığınız bu program size çok teşekür ederim. Çalışmalarınızda başarılar dilerim.
12/03/2009, 18:39

zhtug

sizi bu örnekten dolayı tebrik ederim. daha başka örnekleri bizimle paylaşırsanız sevinirim. iyi günler.
13/03/2009, 13:11

linux2ex

hocam yaptığınız uygulamayı kendi ilim için kullanmak istiyorum ama yardımcı olurmusunuz.
api key aldım google dan . ilime ait koordinatlarıda http://www.getlatlon.com/ bu siteden buldum. ama aynı bölgede kısa aralıklarla olan örneğin sokakları buldurmak istiyorum ama başaramadım. tablodaki koordinatları azönce yazdığım siteden buldum ve güncelledim. form u çalıştırınca yine sizin belirlediğiniz alana gidiyor. nereyi atlamış olabilirim. şimdiden teşekkürler. emeğinize sağlık

üstad formun vb kodlarındaki

WebBrowser1.Document.getElementByID("address").Value = Liste5.Column(2) & "," & Liste5.Column(2) bu satırı


WebBrowser1.Document.getElementByID("address").Value = Liste5.Column(2) & "," & Liste5.Column(3) bu şekle getirdim oldu sanırım sorun burdanmış benim anladığım kadarı ile bu şekilde çözdüm
25/03/2009, 12:14

esrefigit

evet doğruymuş kodun listeye başvurusunu yanlış yapımışım kusura bakmayın
1 2 3