- Add the polyline shapefile in your ArcMap project.
- 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.
- In ArcMap, Go to Tool > Macro > Visual Basic Editor > Project > ArcMap Objects > ThisDocument
- Copy the VB script attached below and paste into ThisDocument
- Highlight the polyline shapefile to be extracted
- Click the "Run Sub" button to execute the script
- 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
