Как автоматизировать нахождение значения М по маршруту

Question

Кирк Кайкендалл несколько лет назад привел пример сценария на форуме ESRI http://forums.esri.com/Thread.asp?c=93&f=996&t=88246&mc=4, как найти значение M (мера) точки в шейп-файле вдоль маршрута, когда вы щелкаете по точке , Это очень удобно, НО .. У меня есть 1500 баллов, для которых мне нужны значения М. Есть ли способ автоматизировать этот тип вещей? Мне нужны значения 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

Будет ли инструмент определения местоположения маршрута делать то, что вы хотите?

1. Нажмите Настроить> Настроить режим.
2. Откройте вкладку «Команды».
3. Нажмите Линейная ссылка в списке категорий.
4. Перетащите инструмент «Определить местоположение маршрута» «Определить местоположение маршрута» на выбранную вами панель инструментов, например на панель инструментов «Инструменты».
5. Нажмите Закрыть.

Добавление инструмента определения местоположения маршрута