This VBA code demonstrates how to find a point location along a given route feature. In this example a point 565.5 units along route 1 is found and the located point is drawn on the screen.
How to use
- Add a route (PolyLineM) layer to ArcMap called 'roads_route_hwy' (or change the code accordingly).
- Paste the code into VBA.
- Run the code.
Public Sub FindPointRouteLocation()
'+++ VBA code that shows how to find a point location along a route
On Error GoTo eh
Dim pMxDoc As IMxDocument
Dim pMap As IMap
Set pMxDoc = ThisDocument
Set pMap = pMxDoc.FocusMap
'+++ Get the route feature class. It is called 'roads_route_hwy'.
Dim pLayer As ILayer
Dim pFLayer As IFeatureLayer
Dim pRouteFc As IFeatureClass
Dim i As Long
For i = 0 To pMap.LayerCount - 1
Set pLayer = pMap.Layer(i)
If LCase(pLayer.Name) = "roads_route_hwy" Then
If TypeOf pLayer Is IFeatureLayer Then
Set pFLayer = pLayer
Set pRouteFc = pFLayer.FeatureClass
Exit For
End If
End If
Next i
If pRouteFc Is Nothing Then
MsgBox "Could not find the route feature class", vbExclamation, "FindPointRouteLocation"
Exit Sub
End If
'+++ Create a route locator. This is the object that knows how to find
'+++ locations along a route.
Dim pName As IName
Dim pDS As IDataset
Dim pRtLocName As IRouteLocatorName
Dim pRtLoc As IRouteLocator
Set pDS = pRouteFc '+++ A PolyLineM feature class
Set pName = pDS.FullName
Set pRtLocName = New RouteMeasureLocatorName
With pRtLocName
Set .RouteFeatureClassName = pName
.RouteIDFieldName = "rkey"
.RouteIDIsUnique = True
.RouteMeasureUnit = esriMeters
.RouteWhereClause = ""
End With
Set pName = pRtLocName
Set pRtLoc = pName.Open
'+++ Create a route location
Dim pRouteLoc As IRouteLocation
Dim pRMPointLoc As IRouteMeasurePointLocation
Set pRouteLoc = New RouteMeasurePointLocation
With pRouteLoc
.MeasureUnit = esriMeters
.RouteID = 1 '+++ the route key
.LateralOffset = 0
End With
Set pRMPointLoc = pRouteLoc
pRMPointLoc.Measure = 565.5
'+++ Locate the point (it's actually a MultiPoint)
Dim pGeom As IGeometry
Dim LocError As esriLocatingError
pRtLoc.Locate pRMPointLoc, pGeom, LocError
'+++ Draw the Multipoint as a graphic on the screen
If Not pGeom Is Nothing And Not pGeom.IsEmpty Then
Dim pGCont As IGraphicsContainer
Dim pGraphicsLayer As IGraphicsLayer
Dim pMElement As IMarkerElement
Dim pElement As IElement
Dim pPC As IPointCollection
Dim pPt As IPoint
Dim pActive As IActiveView
Set pGraphicsLayer = pMap.BasicGraphicsLayer
Set pGCont = pGraphicsLayer
Set pActive = pMxDoc.ActiveView
Set pPC = pGeom
For i = 0 To pPC.PointCount - 1
Set pPt = pPC.Point(i)
Set pMElement = New MarkerElement
Set pElement = pMElement
pMElement.Symbol = New SimpleMarkerSymbol
pElement.Geometry = pPt
pGCont.AddElement pElement, 0
Next i
pActive.Refresh
Else
MsgBox "Point not found", vbExclamation, "FindPointRouteLocation"
Exit Sub
End If
Exit Sub
eh:
Dim lNum As Long, sDesc As String, sSrc As String
lNum = Err.Number
sDesc = Err.Description
sSrc = Err.Source
Err.Raise lNum, sSrc, sDesc
End Sub