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)), " ", " ")
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
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