0

Kirk Kuykendall は、数年前に ESRI フォーラムhttp://forums.esri.com/Thread.asp?c=93&f=996&t=88246&mc=4で、ポイントをクリックしたときのルートに沿ったシェープファイル内のポイント。これは非常に便利ですが、M 値が必要な 1500 ポイントがあります。この種のことを自動化する方法はありますか？ルート上に線形イベントを作成するには、ポイントの M 値が必要です。

注: 私はプログラマーではありませんが、助けてくれる人がいます。

4

2 に答える 2

3

ここにいくつかの古いコードがありますが、あまりテストしていません。

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
于 2010-05-07T20:45:08.460 に答える