Transform a shape into a string

Created:8/29/2000
Description:

The code below demonstrates how you could transform the information from a Point, MultiPoint, PolyLine or Polygon shape into a string. Calling the ShapeAsString macro returns a string of information listing the shape type, the number of parts (if the shape has multiple parts), followed by the number of vertices (if multiple vertices) in each part, and their coordinates.

If required, you can use the CallShapeAsString macro to call the ShapeAsString macro - this will generate information for the first selected Feature geometry in the ActiveView's FocusMap.


How to use:
  1. Open ArcMap, open the VBA Editor and paste the code into the code window. Close the VBA Editor.
  2. Add a feature layer the the Map, and select a feature.
  3. Now run the CallShapeAsString macro (press ALT+F8).
Option Explicit
		
Public Sub CallShapeAsString()
  '
  ' Get the currently selected features from the FocusMap.
  '
  Dim pMxDoc As IMxDocument, pEnumFeat As IEnumFeature, pGeom As IGeometry
  Set pMxDoc = ThisDocument
  If pMxDoc.FocusMap.SelectionCount = 1 Then
    Set pEnumFeat = pMxDoc.FocusMap.FeatureSelection
    pEnumFeat.Reset
    Set pGeom = pEnumFeat.Next.ShapeCopy
    '
    ' Report information on the first selected feature.
    '
    If Not pGeom Is Nothing Then
      MsgBox ShapeAsString(pGeom, 2)
    End If
  End If
End Sub

Public Function ShapeAsString(pGeom As IGeometry, lFormatNum As Long) As String
  '
  ' This function summarizes much of the information held in a Shape. ]
  ' The pGeom parameter should hold the required Geometry object, and the lFormatNum
  ' parameter indicates the required number of decimal places for the coordinates.
  '
  Dim pPC As IPointCollection, pGC As IGeometryCollection
  Dim pPt As IPoint, pMA As IMAware, pZA As IZAware, pIDA As IPointIDAware
  Dim strShape As String, strSub As String
  Dim lCount As Long, i As Long
  '
  ' Report to user if Shape is nothing or has no geometry set (is empty).
  '
  If pGeom Is Nothing Then
    ShapeAsString = "Shape is Nothing"
    Exit Function
  End If
  If pGeom.IsEmpty Then
    ShapeAsString = "Shape is Empty"
    Exit Function
  End If
  '
  ' Get the attribute awareness interfaces of the geometry.
  '
  Set pMA = pGeom
  Set pZA = pGeom
  Set pIDA = pGeom
  '
  ' Identify the type of geometry.
  '
  Select Case pGeom.GeometryType
  Case 1
    '
    ' For a Point, simply report the attribute awareness and coordinates.
    '
    strShape = "Point"
    If pZA.ZAware Then strShape = strShape & "Z"
    If pMA.MAware Then strShape = strShape & "M"
    If pIDA.PointIDAware Then strShape = strShape & " +IDs"
    strShape = strShape & vbCrLf & PointAsString(pGeom, lFormatNum)
  Case 2
    '
    ' For a Multipoint, report attribute awareness and coordinates of each point.
    '
    Set pPC = pGeom
    strShape = "MultiPoint"
    If pZA.ZAware Then strShape = strShape & "Z"
    If pMA.MAware Then strShape = strShape & "M"
    If pIDA.PointIDAware Then strShape = strShape & " +IDs"
    strShape = strShape & vbCrLf & PointCollAsString(pGeom, lFormatNum)
  Case 3, 4
    '
    ' For a Polyline or Polygon, report attribute awareness, the number of parts,
    ' and the number of vertices and coordinates of each vertex in each part.
    '
    If pGeom.GeometryType = esriGeometryPolyline Then strShape = "PolyLine"
    If pGeom.GeometryType = esriGeometryPolygon Then strShape = "Polygon"
    If pZA.ZAware Then strShape = strShape & "Z"
    If pMA.MAware Then strShape = strShape & "M"
    If pIDA.PointIDAware Then strShape = strShape & " +IDs"
    Set pGC = pGeom
    lCount = pGC.GeometryCount - 1
    strShape = strShape & vbCrLf & (lCount + 1) & vbCrLf
    For i = 0 To lCount
      Set pPC = pGC.Geometry(i)
      If Not i = lCount Then
        strShape = strShape & PointCollAsString(pPC, lFormatNum) & vbCrLf
      Else
        strShape = strShape & PointCollAsString(pPC, lFormatNum)
      End If
    Next i
  Case Else
    strShape = "Shape type not supported"
  End Select
  ShapeAsString = strShape
End Function

Private Function PointAsString(pPt As IPoint, lFormatNum As Long) As String
  '
  ' This function creates a string of infomation for a single Point.
  '
  Dim strFormat As String
  Dim strXCoord As String, strYCoord As String
  Dim strMValue As String, strZValue As String, strIDValue As String
  Dim pMA As IMAware, pZA As IZAware, pIDA As IPointIDAware
  '
  ' Work out format string for required number of decimal places.
  '
  If lFormatNum = 0 Then
    strFormat = "#0"
  Else
    strFormat = "#0."
    Dim i As Long
    For i = 0 To lFormatNum - 1
     strFormat = strFormat & "0"
    Next i
  End If
  '
  ' Get the attribute awareness interfaces.
  '
  Set pMA = pPt
  Set pZA = pPt
  Set pIDA = pPt
  '
  ' Work out the coordinates and attribute values, and create a string.
  '
  strXCoord = Format(CStr(Round(pPt.x, lFormatNum)), strFormat)
  strYCoord = Format(CStr(Round(pPt.y, lFormatNum)), strFormat)
  PointAsString = "(" & strXCoord & ", " & strYCoord & ")"
  If pZA.ZAware Then
    strZValue = Format(CStr(Round(pPt.z, lFormatNum)), strFormat)
    If Not IsNaN(strZValue) Then
      PointAsString = PointAsString & ", " & strZValue
    Else
      PointAsString = PointAsString & ", " & "NaN"
    End If
  End If
  If pMA.MAware Then
    strMValue = Format(CStr(Round(pPt.m, lFormatNum)), strFormat)
    If Not IsNaN(strMValue) Then
      PointAsString = PointAsString & ", " & strMValue
    Else
      PointAsString = PointAsString & ", " & "NaN"
    End If
  End If
  If pIDA.PointIDAware Then
    strIDValue = CStr(pPt.id)
    PointAsString = PointAsString & ", " & strIDValue
  End If
End Function

Private Function PointCollAsString(pPC As IPointCollection, lFormatNum As Long) As String
  '
  ' This function creates a string of infomation for a PointCollection.
  '
  Dim lCount As Long, i As Long
  Dim pPt As IPoint, pMA As IMAware, pZA As IZAware, pIDA As IPointIDAware
  Dim strCollection As String, strPoint As String
  '
  ' Get the attribute awareness interfaces.
  '
  Set pMA = pPC
  Set pZA = pPC
  Set pIDA = pPC
  '
  ' Iterate the point collection.
  '
  lCount = pPC.PointCount - 1
  strCollection = CStr(pPC.PointCount) & vbCrLf
  For i = 0 To lCount
    Set pPt = pPC.Point(i)
    '
    ' Create a string of information for each Point in the collection.
    '
    strPoint = PointAsString(pPt, lFormatNum)
    strCollection = strCollection & strPoint
    If Not i = lCount Then
      strCollection = strCollection & vbCrLf
    End If
    Set pPt = Nothing
  Next i
  PointCollAsString = strCollection
End Function

Private Function IsNaN(expression As Variant) As Boolean
 '
 ' VB does not provide a good way to evaluate NaN, so this is
 ' one workaround. (NaN = Not a number).
 '
 If Not IsNumeric(expression) Then
   IsNaN = True
   Exit Function
 End If
 If InStr(CStr(expression), ".#") Then  '1.#QNAN or 1.#Q0
   IsNaN = True
 Else
   IsNaN = False
 End If
End Function