This routine accepts a layer name and the path to a text file, and exports a list of the vertices in each feature of the layer to the file. You can optionally supply the maximum number of features to report from. A summary of the maximum and minimum ranges of x, y, and z values for the list of vertices is also written to the end of the text file.
The example is provided in order to demonstrate how to iterate through features and point collections.
How to use
- Add a line or polygon feature layer into ArcScene.
- Paste the code into an ArcScene or ArcMap VBA session and call the function 'FeatureVertices2Text' in the macro
- When calling the function, you need to specify the Layer name you want to report on, the output textfile path, and optionally, the maximum number of features to base the report on.
Public Function FeatureVertices2Text(sLayerName As String, sTextFileName As String, Optional nMaxFeatures As Double)
' loop through layer features, up to nMaxFeatures
' write out x, y, z, and m values to sTextFileName, as well as summary info
Dim pFeat As IFeature
Dim pLayer As ILayer
Dim pSxDoc As ISxDocument
Dim pMxDoc As IMxDocument
Dim pEnumLayers As IEnumLayer
Dim i As Integer
Dim pFeatClass As IFeatureClass
Dim pFeatLayer As IFeatureLayer
Dim pFeatCursor As IFeatureCursor
Dim sZ As String, sY As String, sX As String, sM As String, sFeatN As String, sFeatVerts As String
Dim lFileID As Long
Dim pFeatPoints As IPointCollection
Dim pPoints As Point
Dim nFeat As Double
Dim pZAware As IZAware
Dim pMAware As IMAware
Dim nMaxX As Double, nMinX As Double
Dim nMinY As Double, nMaxY As Double
Dim nMinZ, nMaxZ
Dim nMinM, nMaxM
Dim nX, nY, nZ, nM
' get the document
If TypeOf Application.Document Is ISxDocument Then
Set pSxDoc = Application.Document
Set pEnumLayers = pSxDoc.Scene.Layers
ElseIf TypeOf Application.Document Is IMxDocument Then
Set pMxDoc = Application.Document
Set pEnumLayers = pMxDoc.FocusMap.Layers
End If
' find the requested layer:
Set pLayer = pEnumLayers.Next
Do While Not pLayer Is Nothing
If UCase(pLayer.Name) = UCase(sLayerName) Then Exit Do
Set pLayer = pEnumLayers.Next
Loop
If pLayer Is Nothing Then
Exit Function
End If
' get the feature cursor:
Set pFeatLayer = pLayer
Set pFeatClass = pFeatLayer.FeatureClass
Set pFeatCursor = pFeatClass.Search(Nothing, False)
' open file:
lFileID = FreeFile()
If Len(Dir(sTextFileName)) > 0 Then Kill sTextFileName
Open sTextFileName For Append As lFileID
' loop through the features:
Set pFeat = pFeatCursor.NextFeature
Do While Not pFeat Is Nothing
nFeat = nFeat + 1
If (nFeat > nMaxFeatures) And (nMaxFeatures > 0) Then
Exit Do
End If
If Not (pFeat.Shape.GeometryType = esriGeometryPoint) Then
' loop through the vertices of the features:
Set pFeatPoints = pFeat.Shape
Set pZAware = pFeat.Shape
Set pMAware = pFeat.Shape
For i = 0 To pFeatPoints.PointCount - 1
sFeatN = "FEATURE # " & nFeat
sFeatN = sFeatN & " ->> Vertice # " & i + 1
nX = pFeatPoints.Point(i).X
nY = pFeatPoints.Point(i).Y
sX = "X: " & nX & " "
sY = "Y: " & nY & " "
If pMAware.MAware Then
nM = pFeatPoints.Point(i).M
sM = "M: " & nM & " "
Else
nM = 0
sM = "M: NOT AWARE" & " "
End If
If pZAware.ZAware Then
nZ = pFeatPoints.Point(i).Z
sZ = "Z: " & nZ & " "
Else
sZ = "Z: NOT AWARE" & " "
End If
sFeatVerts = sFeatN & " -> " & sX & sY & sZ & sM
Print #lFileID, sFeatVerts
Next
Else
' loop through the vertices of the features:
' Set pFeatPoints = pFeat.Shape
Dim pInPoint As IPoint
Set pInPoint = pFeat.Shape
Set pZAware = pFeat.Shape
Set pMAware = pFeat.Shape
sFeatN = "FEATURE # " & nFeat
sFeatN = sFeatN & " ->> Vertice # " & i + 1
nX = pInPoint.X
nY = pInPoint.Y
sX = "X: " & nX & " "
sY = "Y: " & nY & " "
If pMAware.MAware Then
nM = pInPoint.M
sM = "M: " & nM & " "
Else
nM = 0
sM = "M: NOT AWARE" & " "
End If
If pZAware.ZAware Then
nZ = pInPoint.Z
sZ = "Z: " & nZ & " "
Else
sZ = "Z: NOT AWARE" & " "
End If
sFeatVerts = sFeatN & " -> " & sX & sY & sZ & sM
Print #lFileID, sFeatVerts
End If
If nFeat = 1 Then
nMinX = nX
nMaxX = nX
nMinY = nY
nMaxY = nY
nMinZ = nZ
nMinZ = nZ
nMinM = nM
nMaxM = nM
Else
If nX > nMaxX Then nMaxX = nX
If nX < nMinX Then nMinX = nX
If nY > nMaxY Then nMaxY = nY
If nY < nMinY Then nMinY = nY
If nZ > nMaxZ Then nMaxZ = nZ
If nZ < nMinZ Then nMinZ = nZ
If nM > nMaxM Then nMaxM = nM
If nM < nMinM Then nMinM = nM
End If
Set pFeat = pFeatCursor.NextFeature
Loop
If Not pZAware.ZAware Then
nMinZ = "NOT AWARE"
nMaxZ = "NOT AWARE"
End If
If Not pMAware.MAware Then
nMinM = "NOT AWARE"
nMaxM = "NOT AWARE"
End If
' write summary info:
Print #lFileID, ""
Print #lFileID, ""
Print #lFileID, "######## LAYER VERTICE SUMMARY ###################"
Print #lFileID, "##########################################################"
Print #lFileID, "########## LAYER NAME: " & sLayerName
Print #lFileID, "########## MIN X: " & nMinX
Print #lFileID, "########## MAX X: " & nMaxX
Print #lFileID, "########## MIN Y: " & nMinY
Print #lFileID, "########## MAX Y: " & nMaxY
Print #lFileID, "########## MIN Z: " & nMinZ
Print #lFileID, "########## MAX Z: " & nMaxZ
Print #lFileID, "########## MIN M: " & nMinM
Print #lFileID, "########## MAX M: " & nMaxM
Print #lFileID, "##########################################################"
Print #lFileID, "##########################################################"
Close lFileID
End Function