Экстраполяция и добавление точек

Question

Есть линия, задача в том, чтобы от одного (определенного) конца этой линии проэкстраполировать точки с заданным интервалом (в метрах).
Пытался использовать скрипт для ArcView 3.x но он почему-то не с начала линии начинает расставлять точки, т.е. задаю скажем интервал 25 м - ни с одного края линии первая точка не отстоит на 25 метров. Вроде все перепробовал и 0 ставить и 25 (для начальной точки) разницы никакой.

Answer 1

Если "по-взрослому", то это делается путем работы с маршрутными темами (routes, polylineM). Для их создания, правда, нужна аркинфа: Toolbox/calibrate route как раз занимается интерполяцией вдоль по трассе.

Если аркинфы нет, то еще совет: в арквью маршрутные темы мы делали c помощью EditTools.

Answer 2

Попробуй этот скрипт.

Attribute VB_Name = "CreatePointsAlongCurve"

Public Sub CreatePointsAlongCurve()
  'Creates points at a set distance along any feature implementing ICurve
  '
  'Justin Johnson
  'January 23, 2004
  'justin.johnson@geog.utah.edu
  '
  'Obtains selected features from currently-selected Layer
  'Stores new points in point theme at top of TOC

  Dim pMxDoc As IMxDocument
  Dim pMap As IMap
  Dim pInGeometry As IGeometry
  Dim pInLayer As ILayer
  Dim pInFLayer As IFeatureLayer
  Dim pOutFLayer As IFeatureLayer
  Dim pInFCursor As IFeatureCursor
  Dim pOutFCursor As IFeatureCursor
  Dim pOutFBuffer As IFeatureBuffer
  Dim pInFClass As IFeatureClass
  Dim pOutFClass As IFeatureClass
  Dim pSelSet As ISelectionSet
  Dim pFSelection As IFeatureSelection
  Dim pInFeature As IFeature
  Dim pCurve As ICurve
  Dim pPointCollection As IPointCollection
  Dim pConstructMultipoint As IConstructMultipoint
 
  Set pMxDoc = ThisDocument
  Set pMap = pMxDoc.FocusMap
  Set pInLayer = pMxDoc.SelectedLayer
 
  If pInLayer Is Nothing Then  'Check if no input layer is selected
    MsgBox "Select a feature layer in the TOC", vbCritical, "Incompatible input layer"
    Exit Sub
  End If
 
  If TypeOf pInLayer Is IFeatureLayer Then  'check if selected layer is a feature layer
    Set pInFLayer = pMxDoc.SelectedLayer  'set selected layer as input feature layer
  Else
    MsgBox "Select a feature layer in the TOC", vbCritical, "Incompatible input layer"
    Exit Sub
  End If
   
  Set pOutFLayer = pMap.Layer(0) ' set top layer in TOC as output feature layer
  Set pInFClass = pInFLayer.FeatureClass
  Set pOutFClass = pOutFLayer.FeatureClass
 
  If Not pOutFClass.ShapeType = esriGeometryPoint Then  'check if output layer is Point type
    MsgBox "Geometry type of output layer is not Point", vbCritical, "Incompatible Output Layer"
    Exit Sub
  End If

  'Get selected features, if any
  Set pFSelection = pInFLayer
  Set pSelSet = pFSelection.SelectionSet
 
  'Prompt user for distance between points
  Dim pPointDist As Double
  pPointDist = InputBox("Distance between points: ", "Point Spacing in Map Units")
   
  'Create an Insert cursor on output feature class
  Set pOutFBuffer = pOutFClass.CreateFeatureBuffer
  Set pOutFCursor = pOutFClass.Insert(True)
 
  If pSelSet.Count <> 0 Then
    'use selected features from input feature class
    pFSelection.SelectionSet.Search Nothing, True, pInFCursor
  Else
    'use all features if none are selected
    Set pInFCursor = pInFClass.Search(Nothing, True)
  End If
 
  Dim k As Long 'count the number of points created
  k = 0
 
  Set pInFeature = pInFCursor.NextFeature
     
  Do While Not pInFeature Is Nothing
 
    Set pInGeometry = pInFeature.Shape
    Set pCurve = pInGeometry
    Set pConstructMultipoint = New Multipoint
 
    pConstructMultipoint.ConstructDivideLength pCurve, pPointDist
   
    Set pPointCollection = pConstructMultipoint
   
    Dim i As Long
    For i = 0 To pPointCollection.PointCount - 1
     
      Set pOutFBuffer.Shape = pPointCollection.Point(i)  'store the new geometry
      pOutFCursor.InsertFeature pOutFBuffer
      k = k + 1
   
    Next i
   
  Set pInFeature = pInFCursor.NextFeature
 
  Loop
 
  pMxDoc.ActiveView.Refresh
  MsgBox k & " points created in " & pOutFLayer.Name, vbInformation, "Complete"
 
End Sub

Answer 3

И попробуй этот

Sub AddRandomPointElements()
    Dim pMxDoc As IMxDocument
    Set pMxDoc = ThisDocument
   
    Dim pGC As IGraphicsContainer
    Set pGC = pMxDoc.ActiveView
   
    Dim pGCS As IGraphicsContainerSelect
    Set pGCS = pGC
   
    Dim pEnumFeat As IEnumFeature
    Set pEnumFeat = pMxDoc.FocusMap.FeatureSelection
       
    Randomize
    Dim pFeat As IFeature
    Set pFeat = pEnumFeat.Next
    Do Until pFeat Is Nothing
        If TypeOf pFeat.Shape Is IPolyline Then
             Dim lPoints As Long
            
             lPoints = 10 'This is the number of random points to generate

             Dim pGrpElement As IGroupElement
             Set pGrpElement = New GroupElement
             Dim l As Long
             For l = 0 To lPoints - 1
                 Dim pElement As IElement
                 Set pElement = New MarkerElement
                 pElement.Geometry = GetRandomPoint(pFeat.Shape)
                 pGrpElement.AddElement pElement
             Next l
             pGC.AddElement pGrpElement, 0
             pGCS.SelectElement pGrpElement
        End If
        Set pFeat = pEnumFeat.Next
    Loop
    pMxDoc.ActiveView.PartialRefresh esriViewGraphics, Nothing, Nothing
    UngroupGraphics
    CmdCreateShapefile
    'ConvertGraphics2Shape
End Sub

Function GetRandomPoint(pPolyline As IPolyline) As IPoint
    ' get a random point along a line
    Set GetRandomPoint = New Point
    pPolyline.QueryPoint esriNoExtension, Rnd, True, GetRandomPoint
End Function

Sub UngroupGraphics()
  Dim pUID As New UID
  Dim pCmdItem As ICommandItem
  ' Use the GUID of the Ungroup command
  pUID.Value = "{4B96A444-FA41-11D0-83AF-080009B996CC}"
  ' or you can use the ProgID
  ' pUID.Value = "esriCore.UngroupCommand"
  pUID.SubType = 3
  Set pCmdItem = Application.Document.CommandBars.Find(pUID)
  pCmdItem.Execute
End Sub

Private Sub CmdCreateShapefile()
   
Dim theIMXDoc As IMxDocument
Set theIMXDoc = ThisDocument
Dim theimap As IMap
Set theimap = theIMXDoc.FocusMap
Dim theilayer As ILayer
Set theilayer = theIMXDoc.SelectedLayer

' Get the spatial reference
    Dim pSR As ISpatialReference
    Set pSR = theimap.SpatialReference

' Check to see if a map is selected or not.

    If theIMXDoc.SelectedItem Is Nothing Then
      MsgBox "Select a feature layer in the table of contents as the input feature class."
      Exit Sub
    End If
   
    If Not TypeOf theIMXDoc.SelectedItem Is IFeatureLayer Then
      MsgBox "No feature layer selected. Select a feature layer."
      Exit Sub
    End If

    Dim theifeaturelayer As IFeatureLayer
    Set theifeaturelayer = theilayer
   
    'get the layer name
    Dim theilayername As String
    theilayername = theilayer.name
   
    Dim theigeometry As IGeometry
   
    Call makeshapefile(Nothing, theilayername, pSR)

End Sub

Public Sub makeshapefile(thePolyGeometry As IGeometry, theilayername, theSpatialRef As ISpatialReference)
On Error GoTo EH

        Dim tFileName As String, tFilePath As String, tPath As String
        Dim pGxObject As IGxObject
        Dim pGxDialog As IGxDialog
        Dim pGxFilter As IGxObjectFilter
             Set pGxDialog = New GxDialog
             Set pGxFilter = New GxFilterShapefiles
             Set pGxDialog.ObjectFilter = pGxFilter
                 pGxDialog.AllowMultiSelect = False
                 pGxDialog.ButtonCaption = "Click to Save Point Shapefile"
                 pGxDialog.Title = "Enter name for random points"
                 pGxDialog.name = "rand_" & theilayername
             If pGxDialog.DoModalSave(0) Then
                 Set pGxObject = pGxDialog.FinalLocation
             Else
                 Exit Sub      'user cancelled operation
             End If
             If pGxDialog.ReplacingObject Then
                 MsgBox "Create a new filename", , "Random Points"
             Exit Sub
             End If
                
    '
    ''------- GET FILE NAME AND OUTPUT FILE --------
    tFileName = pGxDialog.name
    tFilePath = pGxObject.FullName

  Dim strfolder As String
  Dim strname As String ' Dont include .shp extension
  Const strShapeFieldName As String = "Shape"
    strfolder = tFilePath