2008年5月30日

Extract points from polyline in ArcGIS

Here is a visual basic macro for ArcGIS to generate points on the polylines. How to use these codes. Few steps are discussed below:
  1. Add the polyline shapefile in your ArcMap project.
  2. Create a point shapefile in ArcCatalog by right-click a specific folder and select New to create a new point shapefile in which the to-be-generated points will be saved.
  3. In ArcMap, Go to Tool > Macro > Visual Basic Editor > Project > ArcMap Objects > ThisDocument
  4. Copy the VB script attached below and paste into ThisDocument
  5. Highlight the polyline shapefile to be extracted
  6. Click the "Run Sub" button to execute the script
  7. Done !!
----------------------------------------------------
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

沒有留言: