Feature Vertices To Textfile

Created:12/13/2000
Description:

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:
  1. Paste the code into VBA.
  2. Add a line or polygon feature layer into ArcScene.
  3. Run the macro, passing in 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
      
  ' 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
      
      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