如何自动沿路线查找 M 值

Question

Kirk Kuykendall 几年前在 ESRI 论坛http://forums.esri.com/Thread.asp?c=93&f=996&t=88246&mc=4 上给出了一个脚本示例，说明当您单击某个点时，如何在 shapefile 中沿路线查找该点的 M（度量）值。这非常方便，但是..我有 1500 个点需要 M 值。有没有办法自动化这种类型的事情？我需要点的 M 值来在路线上创建线性事件。

注意：我不是程序员，但有可以帮助我的人。

Answer 1

这里有一些旧代码，没怎么测试过。

Option Explicit
Sub Test()
    Dim pMxDoc As IMxDocument
    Set pMxDoc = ThisDocument

    Dim pEditor As IEditor
    Set pEditor = Application.FindExtensionByName("ESRI Object Editor")

    Dim pEL As IEditLayers
    Set pEL = pEditor


    ' assume the points are the current edit target
    ' and the polylines are the top layer in the TOC
    Dim pPointLayer As IFeatureLayer
    Set pPointLayer = pEL.CurrentLayer

    Dim pLineLayer As IFeatureLayer
    Set pLineLayer = pMxDoc.FocusMap.Layer(0)

    pEditor.StartOperation
    On Error Resume Next
    CalcMeasures pPointLayer, pLineLayer, "M", pMxDoc.SearchTolerance
    If Err.Number = 0 Then
        pEditor.StopOperation "calc Ms"
    Else
        MsgBox Err.Description
        pEditor.AbortOperation
    End If

End Sub

Sub CalcMeasures(pPointLayer As IFeatureLayer, pLineLayer As IFeatureLayer, fldName As String, searchTol As Double)
    On Error GoTo EH

    Dim idx As Long
    idx = pPointLayer.FeatureClass.Fields.FindField(fldName)
    If idx = -1 Then
        Err.Raise 1, , "field not found: " & fldName
    End If

    Application.StatusBar.ShowProgressBar "calculating measures", 0, pPointLayer.FeatureClass.FeatureCount(Nothing), 1, False
    Dim pFCur As IFeatureCursor
    Set pFCur = pPointLayer.FeatureClass.Update(Nothing, False)
    Dim pFeat As IFeature
    Set pFeat = pFCur.NextFeature
    Do Until pFeat Is Nothing
        Dim pLinefeat As IFeature
        Set pLinefeat = GetClosestFeat(pFeat.Shape, pLineLayer.FeatureClass, searchTol)
        If Not pLinefeat Is Nothing Then
            Dim m As Double
            m = GetMeasure(pFeat.Shape, pLinefeat.Shape)
            pFeat.Value(idx) = m
        Else
            ' what to do if nothing is nearby?
            pFeat.Value(idx) = -1#
        End If
        pFCur.UpdateFeature pFeat
        Set pFeat = pFCur.NextFeature
        Application.StatusBar.StepProgressBar
    Loop
    Exit Sub
EH:
    MsgBox Err.Description
    Err.Raise Err.Number, , Err.Description
End Sub

Function GetClosestFeat(pPoint As IPoint, pLineFC As IFeatureClass, searchTol As Double) As IFeature
    Dim pEnv As IEnvelope
    Set pEnv = pPoint.Envelope
    pEnv.Expand searchTol * 2#, searchTol * 2#, False

    Dim pSF As ISpatialFilter
    Set pSF = New SpatialFilter
    Set pSF.Geometry = pEnv
    pSF.SpatialRel = esriSpatialRelEnvelopeIntersects
    Set pSF.Geometry = pEnv

    Dim pFCur As IFeatureCursor
    Set pFCur = pLineFC.Search(pSF, False)

    Dim pProxOp As IProximityOperator
    Set pProxOp = pPoint

    Dim pFeat As IFeature, pClosestFeat As IFeature
    Dim dDist As Double, dClosestDist As Double
    Set pClosestFeat = Nothing

    Set pFeat = pFCur.NextFeature
    Do Until pFeat Is Nothing
        dDist = pProxOp.ReturnDistance(pFeat.Shape)
        If pClosestFeat Is Nothing Then
            Set pClosestFeat = pFeat
            dClosestDist = dDist
        Else
            If dDist < dClosestDist Then
                Set pClosestFeat = pFeat
                dClosestDist = dDist
            End If
        End If
        Set pFeat = pFCur.NextFeature
    Loop
    Set GetClosestFeat = pClosestFeat
End Function

Function GetMeasure(pPoint As IPoint, pPolyline As IPolyline) As Double

    Dim pOutPoint As IPoint
    Set pOutPoint = New Point
    Dim dAlong As Double, dFrom As Double, bRight As Boolean
    pPolyline.QueryPointAndDistance esriNoExtension, _
                                    pPoint, False, _
                                    pOutPoint, dAlong, _
                                    dFrom, bRight
    Dim pMSeg As IMSegmentation2, vMeasures As Variant
    Set pMSeg = pPolyline
    vMeasures = pMSeg.GetMsAtDistance(dAlong, False)
    GetMeasure = vMeasures(0)
End Function

Answer 2

Identify Route Locations 工具能满足您的需求吗？

1. 单击自定义 > 自定义模式。
2. 单击“命令”选项卡。
3. 单击类别列表中的线性参考。
4. 将“识别路径位置”工具“识别路径位置”拖到您选择的工具栏上，例如“工具”工具栏。
5. 单击关闭。

Adding the Identify Route Locations tool