我一直在修改以下 Access VBA 代码。它是问题中代码的扩展，但我使用它GetObject()以便可以附加到现有的 MapPoint 实例。这样我就可以在 MapPoint 中创建我的路线（并根据需要进行调整），然后 [Alt-Tab] 进入 Access 并运行代码。
代码绝不是完整的，但它似乎涵盖了基础知识。作为测试，我计划了一条从“纽约，纽约”到“洛杉矶，加利福尼亚”的路线，当我运行我的 VBA 代码时，VBA 编辑器的即时窗口中会出现以下内容：
"Origin_State: New York",0
"Entering New Jersey",1.57828283309937
"Entering Pennsylvania",76.8766632080078
"Entering Ohio",387.730041503906
"Entering Indiana",624.323974609375
"Entering Illinois",776.259155273438
"Entering Iowa",939.418151855469
"Entering Nebraska",1245.23413085938
"Entering Colorado",1599.96252441406
"Entering Utah",2054.32885742188
"Entering Arizona",2418.78686523438
"Entering Nevada",2448.091796875
"Entering California",2572.029296875
"End_of_route",2798.63793945313
代码如下：
Option Compare Database
Option Explicit
Dim objApp As MapPoint.Application
Dim objMap As MapPoint.Map
Const DebugMode = True '' controls how error messages are displayed
Public Sub RouteTest()
Dim objRoute As MapPoint.Route
Dim objDirection As MapPoint.Direction
Dim StateOfOrigin As String
On Error GoTo RouteTest_Error
'' attach to existing instance of MapPoint
Set objApp = GetObject(, "MapPoint.Application")
On Error GoTo 0 '' for debugging
Set objMap = objApp.ActiveMap
Set objRoute = objMap.ActiveRoute
If objRoute.Directions Is Nothing Then
DisplayErrorMessage "No route.", vbExclamation
Exit Sub
End If
StateOfOrigin = GetState(objRoute.Directions(1).Location)
Debug.Print """Origin_State: " & StateOfOrigin & """,0"
For Each objDirection In objRoute.Directions
If objDirection.Instruction Like "Entering *" Then
Debug.Print """" & Replace(objDirection.Instruction, """", """""", 1, -1, vbBinaryCompare) & """," & objDirection.ElapsedDistance
End If
Next
Set objDirection = objRoute.Directions(objRoute.Directions.Count)
Debug.Print """End_of_route""," & objDirection.ElapsedDistance
Set objDirection = Nothing
Set objRoute = Nothing
Set objMap = Nothing
Set objApp = Nothing
Exit Sub
RouteTest_Error:
If Err.Number = 429 Then
DisplayErrorMessage "Unable to attach to existing instance of MapPoint.", vbCritical
Else
Err.Raise Err.Number
End If
End Sub
Public Function GetState(loc As MapPoint.Location) As String
'' adapted from code at http://www.mp2kmag.com/articles.asp?ArticleID=47
Dim objResults As MapPoint.FindResults
Dim objTempLoc As MapPoint.Location
Dim rgn As String
rgn = ""
loc.Goto
objMap.Altitude = 1
Set objResults = objMap.ObjectsFromPoint(objMap.LocationToX(loc), objMap.LocationToY(loc))
If objResults.ResultsQuality = geoAllResultsValid Then
For Each objTempLoc In objResults
If objTempLoc.Type = geoShowByRegion1 Then
rgn = objTempLoc.Name
Exit For
End If
Next
Set objTempLoc = Nothing
End If
Set objResults = Nothing
GetState = rgn
End Function
Private Sub DisplayErrorMessage(ErrorMessage As String, MessageBoxStyle As Long)
If DebugMode Then
Debug.Print ErrorMessage
Else
MsgBox ErrorMessage, MessageBoxStyle
End If
End Sub