Convert selected points to polygon

Created:01/25/2002
Description:

The ConvertPointToPolygon function construct a polygon from the selected points in the view. At least three points need to be selected.



How to use:
  1. Open ArcMap, open the VBA editor and paste the code below into the code window.
  2. Add one point feature class or more to ArcMap. Select three point features or more, run the script. It will create a new polygon from the selected points.You have to add supplementary code to Draw/Store it.
Option Explicit

'******************************************************************************************
'This function will construct a polygon from the selected points in the view.
'You have to select at least 3 points. This sub will first try to create a simple
'polygon out of the points. If the polygon is not simple it will manipulate the points
'to create a simple polygon.
'******************************************************************************************
Private Sub ConvertPointToPolygon()
Dim pMxDoc As IMxDocument
Dim pEnumFeature As IEnumFeature
Dim pMultiPoint As IPointCollection
Dim pMultiPointSorted As IPointCollection
Dim pFeature As IFeature
Dim i As Long
Dim j As Long
Dim pPointi As IPoint
Dim pTopoOp As ITopologicalOperator2
Dim pLine As ILine
Dim pGonColl As IPointCollection
Dim pClonei As IClone
Dim ptMin As IPoint
Dim ptMax As IPoint
Dim pBaseLine As ILine
Dim pBaseCurve As ICurve
Dim pOutpoint As IPoint
Dim dDistAlong As Double
Dim dDistFrom As Double
Dim bIsRight As Boolean
Dim pMultiRight As IPointCollection
Dim pMultiLeft As IPointCollection
Dim lFlag As Long
Dim pGonColl2 As IGeometryCollection
Dim pPolygon As IPolygon
Dim pRing As IRing
Set pMultiLeft = New Multipoint
Set pMultiRight = New Multipoint
Set pGonColl = New Polygon
Set pMxDoc = ThisDocument
Set pMultiPoint = New Multipoint
Set pMultiPointSorted = New Multipoint
Set pEnumFeature = pMxDoc.FocusMap.FeatureSelection
Set pFeature = pEnumFeature.Next
'Add the points to the multipoint
While Not pFeature Is Nothing
   If pFeature.ShapeCopy.GeometryType = esriGeometryPoint Then
      pMultiPoint.AddPoint pFeature.ShapeCopy
   ElseIf pFeature.ShapeCopy.GeometryType = esriGeometryMultipoint Then
      pMultiPoint.AddPointCollection pFeature.ShapeCopy
   End If
   Set pFeature = pEnumFeature.Next
Wend
If pMultiPoint.PointCount < 3 Then
   MsgBox "Select a least 3 points !"
Exit Sub
End If
'Create a first polygon
pGonColl.AddPointCollection pMultiPoint
Set pTopoOp = pGonColl
'Force the geometry to be known as not simple by the system. I fthis property is not set
'the isSimple method will not do anything and will return true
pTopoOp.IsKnownSimple = False
'If the first polygon is simple it keep this one if not it create one not self intesecting
'IsSimple method is very usefull because it has less overhead (less demanding) than a pure simplify and
'will verify if the geometry is simple without altering it.
If pTopoOp.IsSimple = False Then
   lFlag = 1
   'Heart of the code
   'Simplify the Multipoint to eliminate the duplicate
   Set pTopoOp = pMultiPoint
   pTopoOp.IsKnownSimple = False
   pTopoOp.Simplify
   'Sort the multipoint in ascending X order
   For i = 0 To pMultiPoint.PointCount - 1
      For j = i + 1 To pMultiPoint.PointCount - 1
         If pMultiPoint.Point(j).X < pMultiPoint.Point(i).X Or pMultiPoint.Point(j).X = pMultiPoint.Point(i).X And pMultiPoint.Point(j).Y < pMultiPoint.Point(i).Y Then
            'Take a copy of the point
            Set pClonei = pMultiPoint.Point(i)
            Set pPointi = pClonei.Clone
            'Replace the points
            pMultiPoint.ReplacePoints i, 1, 1, pMultiPoint.Point(j)
            pMultiPoint.ReplacePoints j, 1, 1, pPointi
         End If
      Next
   Next
   Set ptMin = New Point
   Set ptMax = New Point
   'Take the min and max point
   pMultiPoint.QueryPoint 0, ptMin
   pMultiPoint.QueryPoint pMultiPoint.PointCount - 1, ptMax
   'Create the base line
   Set pBaseLine = New Line
   pBaseLine.PutCoords ptMin, ptMax
   Set pBaseCurve = pBaseLine
   For i = 0 To pMultiPoint.PointCount - 1
      Set pOutpoint = New Point
      pBaseCurve.QueryPointAndDistance esriNoExtension, pMultiPoint.Point(i), False, pOutpoint, dDistAlong, dDistFrom, bIsRight
      If bIsRight Then
         pMultiRight.AddPoint pMultiPoint.Point(i)
      Else
         pMultiLeft.AddPoint pMultiPoint.Point(i)
      End If
   Next
   Dim pRingColl As ISegmentCollection
   Set pRingColl = New Ring
   'Add the left lines to the ring
   For i = 0 To pMultiLeft.PointCount - 2
      Set pLine = New Line
      pLine.PutCoords pMultiLeft.Point(i), pMultiLeft.Point(i + 1)
      pRingColl.AddSegment pLine
   Next
   'First line right
   Set pLine = New Line
   pLine.PutCoords pMultiLeft.Point(pMultiLeft.PointCount - 1), pMultiRight.Point(0)
   pRingColl.AddSegment pLine
   'Add the right line to the ring
   For i = (pMultiRight.PointCount - 1) To 1 Step -1
      Set pLine = New Line
      pLine.PutCoords pMultiRight.Point(i), pMultiRight.Point(i - 1)
      pRingColl.AddSegment pLine
   Next
   'Last line right
   Set pLine = New Line
   pLine.PutCoords pMultiRight.Point(0), pMultiLeft.Point(0)
   pRingColl.AddSegment pLine
   Set pRing = pRingColl
   pRing.Close
   Set pGonColl2 = New Polygon
   pGonColl2.AddGeometry pRing
End If
If lFlag = 0 Then
   Set pPolygon = pGonColl 'QI
Else
'Take the IPolygon interface on the polygon
   Set pPolygon = pGonColl2 'QI
End If
   'You can now Draw/Store the polygon
End Sub