Koordinatlara Göre Haritada Yer Gösterme - Baskı Önizleme +- AccessTr.neT (https://accesstr.net) +-- Forum: Microsoft Access (https://accesstr.net/forum-microsoft-access.html) +--- Forum: Access Örnekleri ve Uygulamaları (https://accesstr.net/forum-access-ornekleri-ve-uygulamalari.html) +--- Konu Başlığı: Koordinatlara Göre Haritada Yer Gösterme (/konu-koordinatlara-gore-haritada-yer-gosterme.html) |
Cvp: Koordinatlara Göre Haritada Yer Gösterme - esrefigit - 17/12/2008 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)), " ", " ") 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 Cvp: Koordinatlara Göre Haritada Yer Gösterme - ayhan2122 - 17/12/2008 Cvp: Koordinatlara Göre Haritada Yer Gösterme - birgizlidost - 12/03/2009 Yaptığınız bu program size çok teşekür ederim. Çalışmalarınızda başarılar dilerim. Cvp: Koordinatlara Göre Haritada Yer Gösterme - zhtug - 12/03/2009 sizi bu örnekten dolayı tebrik ederim. daha başka örnekleri bizimle paylaşırsanız sevinirim. iyi günler. Cvp: Koordinatlara Göre Haritada Yer Gösterme - linux2ex - 13/03/2009 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 Cvp: Koordinatlara Göre Haritada Yer Gösterme - esrefigit - 25/03/2009 evet doğruymuş kodun listeye başvurusunu yanlış yapımışım kusura bakmayın |