경로를 따라 M 값을 찾는 방법을 자동화하는 방법

Kirk Kuykendall은 ESRI 포럼 http://forums.esri.com/Thread.asp?c=93&f=996&t=88246&mc=4에서 몇 년 전에 스크립트를 통해 셰이프 파일의 한 점에 대한 M 값을 찾는 방법에 대한 스크립트 예제를 제공했습니다. 포인트를 클릭하면 경로가 표시됩니다. 이것은 매우 편리하지만, 나는 M 값을 필요로하는 1500 점을 가지고 있습니다. 이 유형의 것을 자동화하는 방법이 있습니까? 경로 상에 선형 이벤트를 생성하기 위해 포인트의 M 값이 필요합니다.경로를 따라 M 값을 찾는 방법을 자동화하는 방법

참고 : 저는 프로그래머가 아니지만 나를 도울 수있는 사람들이 있습니다.

출처

2010-05-06 Heather Taylor

여기에 몇 가지 오래된 코드가 있습니다. 테스트하지 않은 것이 많습니다.

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-07 20:45:08