Find a point location along a route


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:
  1. Add a route (PolyLineM) layer to ArcMap called 'roads_route_hwy' (or change the code accordingly).
  2. Paste the code into VBA.
  3. 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
    MsgBox "Point not found", vbExclamation, "FindPointRouteLocation"
    Exit Sub
  End If
  Exit Sub
  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