Inserting LR Event Features with VBA

RichardFairhurst · ‎10-01-2010

I have searched the old and new forums and not seen any code that inserts new records into a Linear Reference Event Feature Layer using VBA. After some experimenting I found it was not possible to insert the features directly into the LR Event Layer, but it was possible to insert them into the underlying event table.

The code below is what I came up with. It duplicates selected LR Event Features by inserting copies into the underlying Event table (I use it to split LR line features when changes in my sidewalk network occur). The code also reselects the original and new duplicated features so that they will display in the LR Event Feature Layer's Tableview. I hope this helps.

Sub AddLRRecord()
  ' Get a reference to the Event Layer through the map.
  Dim pMxDoc As IMxDocument
  Set pMxDoc = ThisDocument
  Dim pMap As IMap
  Set pMap = pMxDoc.FocusMap
  Dim pLayer As ILayer
  Dim i As Long
  For i = 0 To pMap.LayerCount - 1
    Set pLayer = pMap.Layer(i)
    If pLayer.Name = "SIDEWALKS Events" Then
      Exit For
    End If
  Next i
  If pLayer Is Nothing Then
    MsgBox "Layer Not Found"
    Exit Sub
  End If
  Dim pFLayer As IFeatureLayer
  Set pFLayer = pLayer

  ' Get the LR Event layer's Selection Set.
  Dim pFSel As IFeatureSelection
  Set pFSel = pFLayer
  Dim pSelSet As ISelectionSet
  Set pSelSet = pFSel.SelectionSet

  ' Create a where clause to select records from underlying event table using OID values.
  Dim pEnumIDs As IEnumIDs
  Set pEnumIDs = pSelSet.IDs
  Dim strWhere As String
  strWhere = """OBJECTID"" IN ("
  Dim lID As Long
  pEnumIDs.Reset
  lID = pEnumIDs.Next
  Do While lID <> -1
    strWhere = strWhere & lID & ","
    lID = pEnumIDs.Next
  Loop
  strWhere = Left(strWhere, Len(strWhere) - 1) & ")"
  If strWhere = """OBJECTID"" IN )" Then ' Make sure something was selected
    MsgBox "No Sidewalks selected"
    Exit Sub
  End If

  ' Select the records in the underlying event table.
  Dim pQF As IQueryFilter
  Set pQF = New QueryFilter
  pQF.WhereClause = strWhere
  Dim pRouteEventSource As IRouteEventSource ' This is the interface for getting the Event Table
  Set pRouteEventSource = pFLayer.FeatureClass
  Dim pTable As ITable
  Set pTable = pRouteEventSource.EventTable
  Dim pCursor As ICursor
  Set pCursor = pTable.Search(pQF, False)

  ' Copy the records and prepare a new where clause to select original and new features in the LR Event layer.
  Dim pICursor As ICursor ' Set up insert cursor for underlying event table.
  Set pICursor = pTable.Insert(True)
  Dim pRowB As IRowBuffer
  Set pRowB = pCursor.NextRow
  Dim lFIDC As Long
  lFIDC = pRowB.Fields.FindField("FID_CENTERLINE")
  Dim lRoadSide As Long
  lRoadSide = pRowB.Fields.FindField("ROAD_SIDE")
  strWhere = """FID_CENTERLINE"" IN (" ' Create a new query for selecting in LR Event layer.
  Dim strWhere2 As String
  strWhere2 = " AND ""ROAD_SIDE"" IN ("
  Do While Not pRowB Is Nothing
    pICursor.InsertRow pRowB ' This duplicates the record in the event table.
    strWhere = strWhere & pRowB.Value(lFIDC) & "," ' Adding records to where clause.
    strWhere2 = strWhere2 & "'" & pRowB.Value(lRoadSide) & "',"
    Set pRowB = pCursor.NextRow
  Loop
  strWhere = Left(strWhere, Len(strWhere) - 1) & ")"
  strWhere2 = Left(strWhere2, Len(strWhere2) - 1) & ")"
  strWhere = strWhere & strWhere2

  ' Reselect original records and duplicated records in the event layer.
  pQF.WhereClause = strWhere
  pFSel.SelectFeatures pQF, esriSelectionResultNew, False
  Set pSelSet = pFSel.SelectionSet ' A SelectionSet will show selection in user tableview.
End Sub

RichardFairhurst · ‎10-15-2010

I have created a new version of the split code designed to work as a UIToolControl that can split a selected LR Line Event where a mouse was clicked.

Private Sub UIToolControl1_MouseDown(ByVal button As Long, ByVal shift As Long, ByVal x As Long, ByVal y As Long)
  Dim pEditor As IEditor
  Dim pID As New UID
  pID = "esriEditor.Editor"
  Set pEditor = Application.FindExtensionByCLSID(pID)

  If Not pEditor.EditState = esriStateEditing Then
    MsgBox "Not in an Edit Session!.  Please start Editor."
    Exit Sub
  End If
  
  Dim pMxDoc As IMxDocument
  Set pMxDoc = Application.Document
  Dim pMap As IMap
  Set pMap = pMxDoc.FocusMap
  Dim i As Long
  Dim pLayer As ILayer
  For i = 0 To pMap.LayerCount - 1
    Set pLayer = pMap.Layer(i)
    If pLayer.Name = "SIDEWALKS Events" Then
      Exit For
    End If
  Next i
  If pLayer Is Nothing Then
    MsgBox "Layer Not Found"
    Exit Sub
  End If
  Dim pFLayer As IFeatureLayer
  Set pFLayer = pLayer
  If pFLayer Is Nothing Then
    MsgBox "Layer is not a Feature Layer!"
    Exit Sub
  End If
  
 
  If Not TypeOf pFLayer.FeatureClass Is IRouteEventSource Then
    MsgBox "Layer is not a Route Event Source!"
    Exit Sub
  End If
  Dim pRouteEventSource As IRouteEventSource
  Set pRouteEventSource = pFLayer.FeatureClass
  If Not TypeOf pRouteEventSource.EventProperties Is IRouteMeasureLineProperties Then
    MsgBox "Layer is not a Line Event Layer!"
    Exit Sub
  End If
  
  Dim pDataset As IDataset
  Set pDataset = pRouteEventSource.EventTable
  Dim pProps As IPropertySet
  Set pProps = pEditor.EditWorkspace.ConnectionProperties
  If Not pDataset.Workspace.ConnectionProperties.IsEqual(pProps) Then
    MsgBox "Workspace of Sidewalk Events Layer is not being edited!"
    Exit Sub
  End If

  'Get the point where the user clicked
  If pMxDoc.CurrentLocation.IsEmpty Then Exit Sub
  'Clone the point because we don't want to alter
  'the actual document's current location point
  Dim pClone As IClone
  Set pClone = pMxDoc.CurrentLocation
  Dim pPoint As IPoint
  Set pPoint = pClone.Clone
  
  Dim pFSel As IFeatureSelection
  Set pFSel = pFLayer
  Dim pSelSet As ISelectionSet
  Set pSelSet = pFSel.SelectionSet
  If pSelSet.Count < 1 Then
    MsgBox "No Sidewalks selected"
    Exit Sub
  End If
  
  ' Read selected records to create an update where clause using OID values
  Dim pCursor As ICursor
  Dim pRow As IRow
  pSelSet.Search Nothing, False, pCursor
  Set pRow = pCursor.NextRow
  Dim strWhere As String
  strWhere = """OBJECTID"" IN ("
  
  ' This where clause is specific to my sidewalk data.
  Dim lFIDC As Long
  lFIDC = pRow.Fields.FindField("FID_CENTERLINE")
  Dim lRoadSide As Long
  lRoadSide = pRow.Fields.FindField("ROAD_SIDE")
  Dim strWhere2 As String
  Dim strwhere3 As String
  strWhere2 = """FID_CENTERLINE"" IN ("
  strwhere3 = " AND ""ROAD_SIDE"" IN ("
  
  ' Loop through selected records to create two where clauses.
  Do While Not pRow Is Nothing
    ' This clause is common to all GDBs
    strWhere = strWhere & pRow.OID & ","
  
    strWhere2 = strWhere2 & pRow.Value(lFIDC) & ","
    strwhere3 = strwhere3 & "'" & pRow.Value(lRoadSide) & "',"
    Set pRow = pCursor.NextRow
  Loop
  ' Complete where clause common to all GDBs.
  strWhere = Left(strWhere, Len(strWhere) - 1) & ")"

  strWhere2 = Left(strWhere2, Len(strWhere2) - 1) & ")"
  strwhere3 = Left(strwhere3, Len(strwhere3) - 1) & ")"
  strWhere2 = strWhere2 & strwhere3
      
  Dim pQF As IQueryFilter
  Set pQF = New QueryFilter
  
  ' Do the Split in an edit operations so that it can be undone
  pEditor.StartOperation
    SplitLRRecord pPoint, pRouteEventSource, strWhere

    ' Reselect original records and added records for split in the event layer.
    pQF.WhereClause = strWhere2
    pFSel.SelectFeatures pQF, esriSelectionResultNew, False
    Set pSelSet = pFSel.SelectionSet
  pEditor.StopOperation "Split Event Record"
  
  ' Switch tool to Select Feature tools to avoid accidental split and allow new selection
  Dim pItem As ICommandItem
  Set pItem = CommandBars.Find(arcid.Query_SelectFeatures)
  Set Application.CurrentTool = pItem
End Sub

Sub SplitLRRecord(ByVal pPoint As IPoint, ByVal pRouteEventSource As IRouteEventSource, ByVal strWhere As String)
  ' Select the records in the underlying event table.
  Dim pQF As IQueryFilter
  Set pQF = New QueryFilter
  pQF.WhereClause = strWhere
  Dim pTable As ITable
  Set pTable = pRouteEventSource.EventTable
  Dim pICursor As ICursor
  Set pICursor = pTable.Insert(True)
  Dim pRowB As IRowBuffer
  Set pRowB = pTable.CreateRowBuffer
  Dim pCursor As ICursor
  Set pCursor = pTable.Update(pQF, False)
  
  ' Get the event fields for selecting Routes
  Dim pEventRouteField As String
  pEventRouteField = pRouteEventSource.EventProperties.EventRouteIDFieldName
  Dim pEventRouteIndex As Long
  pEventRouteIndex = pTable.FindField(pEventRouteField)
  ' Get Route Feature Class and fields
  Dim pRouteFC As IFeatureClass
  Set pRouteFC = pRouteEventSource.RouteLocator.RouteFeatureClass
  Dim pRouteField As String
  pRouteField = pRouteEventSource.RouteLocator.RouteIDFieldName
  'Create QueryFilter and Feature Cursor for querying routes
  Dim pQFRoute As IQueryFilter
  Set pQFRoute = New QueryFilter
  Dim pFCursor As IFeatureCursor
  Dim pFeature As IFeature
  ' Variables for NearestMToPoint Sub
  Dim pCurve As ICurve
  Dim dMeas As Double
  Dim pNearPoint As IPoint
  Dim dNearDist As Double
  Dim bRight As Boolean
  Dim dFromMeas As Double
  Dim dToMeas As Double
  
  ' Find records that the point splits and modify measures of existing and inserted event.
  Dim pRow As IRow ' Normal row for modifying original row measure
  Set pRow = pCursor.NextRow
  Dim lFromMeas As Long
  Dim lToMeas As Long
  Dim pRMLP As IRouteMeasureLineProperties
  Set pRMLP = pRouteEventSource.EventProperties
  lFromMeas = pRow.Fields.FindField(pRMLP.FromMeasureFieldName)
  lToMeas = pRow.Fields.FindField(pRMLP.ToMeasureFieldName)
  Do While Not pRow Is Nothing
    pQFRoute.WhereClause = """" & pRouteField & """ = '" & pRow.Value(pEventRouteIndex) & "'"
    Set pFCursor = pRouteFC.Search(pQFRoute, False)
    Set pFeature = pFCursor.NextFeature
    If Not pFeature Is Nothing Then
      Set pCurve = pFeature.ShapeCopy
      NearestMToPoint pCurve, pPoint, dMeas, pNearPoint, dNearDist, bRight
      dMeas = Round(dMeas, 0) ' Apply Rounding if desired or comment out
      dFromMeas = pRow.Value(lFromMeas)
      dToMeas = pRow.Value(lToMeas)
      If dFromMeas < dToMeas And dMeas > dFromMeas And dMeas < dToMeas And dMeas <> -1 Then
        Set pRowB = pRow
        pRowB.Value(lFromMeas) = dMeas
        pICursor.InsertRow pRowB ' This duplicates the record in the event table.
        pRow.Value(lFromMeas) = dFromMeas
        pRow.Value(lToMeas) = dMeas
        pCursor.UpdateRow pRow
      ElseIf dFromMeas > dToMeas And dMeas > dToMeas And dMeas < dFromMeas And dMeas <> -1 Then
        Set pRowB = pRow
        pRowB.Value(lToMeas) = dMeas
        pICursor.InsertRow pRowB ' This duplicates the record in the event table.
        pRow.Value(lToMeas) = dToMeas
        pRow.Value(lFromMeas) = dMeas
        pCursor.UpdateRow pRow
      End If
    End If
    Set pRow = pCursor.NextRow
  Loop
End Sub


' Sub to Get Nearest M value, Point on Curve, Distance, and Side of Curve from original Point
Private Sub NearestMToPoint(ByRef pCurve As ICurve, ByRef pPoint As IPoint, _
  ByRef dMeas As Double, ByRef pNearPoint As IPoint, ByRef dNearDist As Double, ByRef bRight As Boolean)
   ' Set dMeas to a value that is invalid so that result can be tested by calling code
   dMeas = -1
   ' Validate Minimum input variables
   If pCurve Is Nothing Then
     Err.Raise vbObjectError + 11282003, "NearestMToPoint", "No Input Curve Provided"
     Exit Sub
   End If
   If pPoint Is Nothing Then
     Err.Raise vbObjectError + 11282002, "NearestMToPoint", "No Input Point Provided"
     Exit Sub
   End If
  ' Initialize resulting pNearPoint if it is not already initialized to avoid causing an error
   If pNearPoint Is Nothing Then
     Set pNearPoint = New Point
   End If

   ' Make sure input curve is MAware
   Dim pMA As IMAware
   Set pMA = pCurve
   If pMA.MAware Then
     ' initialize variables used to QueryPointAndDistance
     Dim bAsRatio As Boolean
     bAsRatio = True
     Dim dAlong As Double
     pCurve.QueryPointAndDistance esriNoExtension, pPoint, bAsRatio, pNearPoint, dAlong, dNearDist, bRight

     ' Initialize variables to find the best M value of point
     Dim pMSeg As IMSegmentation
     Set pMSeg = pCurve
     Dim Ms As Variant
     Ms = pMSeg.GetMsAtDistance(dAlong, bAsRatio)
     If UBound(Ms) > 0 Then
       Dim iCount As Long
       Dim lCount As Long
       Dim pGeomColl As IGeometryCollection
       Dim pGeom As IGeometry
       Dim pTestPoint As IPoint
       Set pTestPoint = New Point
       For iCount = LBound(Ms) To UBound(Ms)
         Set pGeomColl = pMSeg.GetPointsAtM(Ms(iCount), 0)
         For lCount = 0 To pGeomColl.GeometryCount - 1
           Set pGeom = pGeomColl.Geometry(lCount)
           Set pTestPoint = pGeom
           ' Make sure the M value returns a Point that matches the point returned by QueryPointAndDistance.
           If Round(pTestPoint.x, 8) = Round(pNearPoint.x, 8) And Round(pTestPoint.y, 8) = Round(pNearPoint.y, 8) Then
             dMeas = Ms(iCount)
           End If
         Next lCount
       Next iCount
       If dMeas = -1 Then
         Err.Raise vbObjectError + 11282001, "NearestMToPoint", "No M Values Located"
       End If
     Else
       dMeas = Ms(0)
     End If
   Else
     Err.Raise vbObjectError + 11282000, "NearestMToPoint", "Not M Aware"
   End If
End Sub