Home arrow GIS Data & Resources arrow Scripts and Code arrow Visual Basic / VBA arrow VBA: Transfer Milepost M Coordinates From Route To Features
VBA: Transfer Milepost M Coordinates From Route To Features PDF Print E-mail

Written by Bert Granberg,

One of the Interfaces in ArcObjects, IHitTest , is extremely useful for exploring proximity ('nearest') relationships between two features. It's very fast and doesn't much care what types of geometry you throw at it.

The code below shows an example of how IHitTest can be used to transfer milepost measure or m coordinates from a route feature (think all of I-15NB as one route feature) to range attributes of all the street features that make up the route. Route features are great for doing linear referencing but a lot of applications can do 'geocoding' style route-milepost location better if the milepost values at each end of the street feature are stored the same way address ranges are stored.

Basically, the code looks at each street feature that should get a milepost range (based on whether it has a DOT_RTNAME value or not) and then queries the route feature class to find the corresponding 'parent' route. Then it takes each end point for the street feature and queries the parent route for the nearest vertex to the specified point. Lastly, the code gets the m coordinate stored at that vertex to throw into a range field in the street feature class.

Street centerline features in the new SGID 9.3 SDE database will carry From and To milepost approximations on UDOT state and federal routes.  

'UPDATED 5/14/09 TO QUERY ALONG ROUTE FOR INTERPOLATED M COORDINATE WHEN
'A ROUTE VERTEX IS NOT HIT DIRECTLY

Public Sub milepostRangeLookup()
       
    Dim pMxDoc As IMxDocument
    Dim pMap As IMap
    Set pMxDoc = ThisDocument
    Set pMap = pMxDoc.FocusMap
    
    Dim pSrcLayer As IFeatureLayer
    Dim pSrcFeatureClass As IFeatureClass
    Dim pSrcFeatureCursor As IFeatureCursor
    Dim pSrcFeature As IFeature
    Dim pTarPolyline As IPolyline
    Dim pTarEndPt As IPoint
    Dim pTarTopOp As ITopologicalOperator
    Dim pTarPolygon As IPolygon
    Dim tarRtNameID As String
    Dim pTarLayer As IFeatureLayer
    Dim pTarFeatureClass As IFeatureClass
    Dim pTarFeatureCursor As IFeatureCursor
    Dim pTarFeature As IFeature
    Dim pTarDataset As IDataset
    Dim pTarWS As IWorkspace

    Dim pHitTest As IHitTest
    Dim hitStart As Boolean
    Dim hitend As Boolean
    Dim pHit As IPoint
    Dim dDist As Double
    Dim lPartIndex As Long
    Dim lSegIndex As Long
    Dim bRight As Boolean
    
    Dim pQF As IQueryFilter
    Dim pQF2 As IQueryFilter
    Dim pSrcRt As IPolyline
    Dim pSRcRTPC As IPointCollection
    Dim pTO As ITopologicalOperator
    
    Dim tarDOTMPFromFI As Integer
    Dim tarDOTMPToFI As Integer
    Dim tarDOTRTNameFI As Integer
    Dim Count As Long
    
    Dim pSegColl As ISegmentCollection
    Dim pSeg As ISegment
    Dim pOutPoint As IPoint
    Dim outDist As Double
    Dim mcoord As Double
    Dim awayDist As Double
    Set pQF = New QueryFilter
    pQF.WhereClause = "(not DOT_RTNAME is null) and DOT_RTNAME <> ''"
    
    Set pSrcLayer = pMap.Layer(1)
    Set pSrcFeatureClass = pSrcLayer.FeatureClass
    
    Set pTarLayer = pMap.Layer(0)
    Set pTarFeatureClass = pTarLayer.FeatureClass
    Set pTarDataset = pTarFeatureClass
    Set pTarWS = pTarDataset.Workspace
    tarDOTMPFromFI = pTarFeatureClass.FindField("DOT_F_MP")
    tarDOTMPToFI = pTarFeatureClass.FindField("DOT_T_MP")
    tarDOTRTNameFI = pTarFeatureClass.FindField("DOT_RTNAME")
      
    Dim pEditor As IEditor
    Dim pUID As New UID
    pUID = "esriEditor.Editor"
    Set pEditor = Application.FindExtensionByCLSID(pUID)
    
    If pEditor.EditState = esriStateEditing Then
        MsgBox "You must not currently be in an edit session to run this script.", vbOKOnly, "Exiting"
        Exit Sub
    End If
    
    pEditor.StartEditing pTarWS
    pEditor.StartOperation
    On Error GoTo errorhandler
    
    Set pTarFeatureCursor = pTarFeatureClass.Update(pQF, True)
    Set pTarFeature = pTarFeatureCursor.NextFeature
    
    Do Until pTarFeature Is Nothing
        
        Count = Count + 1

        Set pQF2 = New QueryFilter
        pQF2.WhereClause = "LABEL = '" & pTarFeature.Value(tarDOTRTNameFI) & "'"
        
        Set pSrcFeatureCursor = pSrcLayer.Search(pQF2, True)
        Set pSrcFeature = pSrcFeatureCursor.NextFeature
        
        If Not pSrcFeature Is Nothing Then
        
        
            'do for startpoint
            Set pTarPolyline = pTarFeature.Shape
            Set pSrcRt = pSrcFeature.Shape
            Set pTarEndPt = pTarPolyline.FromPoint
            
            dDist = 0
            lPartIndex = 0
            lSegIndex = 0
            bRight = False
            hitStart = False
            Set pHit = New Point
            Set pHitTest = pSrcRt
            hitStart = pHitTest.HitTest(pTarEndPt, 2, esriGeometryPartVertex, pHit, dDist, lPartIndex, lSegIndex, bRight)
            'Debug.Print "Hit point X, Y : " & pHit.X & " , " & pHit.Y
            'Debug.Print "Hit Distance : " & dDist
            'Debug.Print "Hit M Coordinate : " & CStr(CLng(pHit.M * 1000) / 1000)
            
            If hitStart Then
                pTarFeature.Value(tarDOTMPFromFI) = CStr(CLng(pHit.M * 1000) / 1000)
                'if no vertex to vertex hit, then interpolate along route segment
            Else
                hitStart = pHitTest.HitTest(pTarEndPt, 2, esriGeometryPartBoundary, pHit, dDist, lPartIndex, lSegIndex, bRight)
                If hitStart Then
                    Set pSegColl = pSrcRt
                    Set pSeg = pSegColl.Segment(lSegIndex)
                    'interpolate
                    pSeg.QueryPointAndDistance esriNoExtension, pTarEndPt, True, pOutPoint, outDist, awayDist, True
                    mcoord = pSeg.FromPoint.M + ((pSeg.ToPoint.M - pSeg.FromPoint.M) * outDist)
                    pTarFeature.Value(tarDOTMPFromFI) = CStr(CLng(mcoord * 1000) / 1000) + 0.001
                Else
                    Debug.Print "   end not found: " & pTarFeature.OID & " " & pTarFeature.Value(tarDOTRTNameFI)
                End If
            End If
            
            
            'do for endpoint
            Set pTarEndPt = pTarPolyline.ToPoint
            dDist = 0
            lPartIndex = 0
            lSegIndex = 0
            bRight = False
            hitend = False
            Set pHit = New Point
            Set pHitTest = pSrcRt
            hitend = pHitTest.HitTest(pTarEndPt, 2, esriGeometryPartVertex, pHit, dDist, lPartIndex, lSegIndex, bRight)
            If hitend Then
                pTarFeature.Value(tarDOTMPToFI) = CStr(CLng(pHit.M * 1000) / 1000)
            Else
                'if no vertex to vertex hit, then interpolate along route segment
                hitend = pHitTest.HitTest(pTarEndPt, 2, esriGeometryPartBoundary, pHit, dDist, lPartIndex, lSegIndex, bRight)
                If hitend Then
                    Set pSegColl = pSrcRt
                    Set pSeg = pSegColl.Segment(lSegIndex)
                    'interpolate
                    pSeg.QueryPointAndDistance esriNoExtension, pTarEndPt, True, pOutPoint, outDist, awayDist, True
                    mcoord = pSeg.FromPoint.M + ((pSeg.ToPoint.M - pSeg.FromPoint.M) * outDist)
                    pTarFeature.Value(tarDOTMPToFI) = CStr(CLng(mcoord * 1000) / 1000)
                Else
                    Debug.Print "   end not found: " & pTarFeature.OID & " " & pTarFeature.Value(tarDOTRTNameFI)
                End If
            End If
                
            
            If hitStart Or hitend Then
                pTarFeatureCursor.UpdateFeature pTarFeature
            End If
            
        Else
            Debug.Print "*** no rt found for " & pTarFeature.OID & " " & pTarFeature.Value(tarDOTRTNameFI)
        End If
        
        Debug.Print Count
        
        Set pTarFeature = pTarFeatureCursor.NextFeature
    
    Loop

    pEditor.StopOperation "Transfer Milepost Ranges"
    pEditor.StopEditing (True)
    Exit Sub
errorhandler:
    Debug.Print "Error on: " & pTarFeature.OID
    pEditor.StopOperation "Transfer Milepost Ranges"
    pEditor.StopEditing (False)
    
End Sub


Users' Comments  
 

No comment posted

Add your comment

06, May. 2009
Last Updated ( 14, May. 2009 )
 
< Prev   Next >

AGRC Contacts | UGIC Contacts

feed image feed image

Utah GIS Portal © 2009 AGRC

Optimized for