如何将选中的点集转换成Polygon
本例要实现的功能是根据选中的Points创建一个Polygon，并且保存到Polygon类型的FeatureLayer中，要求被选择的Points最少为3个。
● 要点
根据选择的点创建一个Polygon，首先要判断生成的Polygon是否是Simple,这里用到接口ITopologicalOperator2的属性IsSimple。如果不是,则要对做Polygon排序等处理。此外还用到了接口IPointCollection的方法ReplacePoints，进行点的交换。将排好序的点，按顺序创建Segment，运用实例化为Ring的ISegmentCollection接口方法AddSegment增加Segment。实例化为Polygon的IGeometryCollection接口方法AddGeometry增加Ring。这样，通过上面的方法便可以创建Polygon。
●程序说明
根据接口ITopologicalOperator2.IsSimple属性判断Polygon是否Simple。如果返回为False，就对Polygon上的点进行排序等处理，排好序后，找出X方向上值最大和最小的点，由这两点创建一条直线，将所有点分成在直线左边和右边两部分。
●代码
Public Sub ConvertPointToPolygon()
Dim pMxDoc As IMxDocument
Dim pMap As IMap
Dim pEnumFeature As IEnumFeature
Dim pMultiPoint As IPointCollection
Dim pMultiPointSorted As IPointCollection
Dim pFeature As IFeature
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 pMultiRight As IPointCollection
Dim pMultiLeft As IPointCollection
Dim pGonColl2 As IGeometryCollection
Dim pPolygon As IPolygon
Dim pRing As IRing
Dim pFeatureClass As IFeatureClass
Dim pFeatureLayer As IfeatureLayer
Dim pFeature1 As IFeature
Dim pFeatureClass1 As IFeatureClass
Dim pFeatureLayer1 As IFeatureLayer
Dim pDataSet As IDataset
Dim pWorkspaceFactory As IWorkspaceFactory
Dim pWorkspaceEdit As IWorkspaceEdit
Dim pRingColl As ISegmentCollection
Dim dDistAlong As Double
Dim dDistFrom As Double
Dim bIsRight As Boolean
Dim i As Long
Dim j As Long
Dim lFlag As Long
On Error GoTo errorHander
Set pMxDoc = ThisDocument
Set pMap = pMxDoc.FocusMap
Set pActiveView = pMap
Set pFeatureLayer = pMap.Layer(0)
Set pFeatureClass = pFeatureLayer.FeatureClass
'创建一个工作区，开始编辑
Set pDataSet = pFeatureClass
Set pWorkspaceFactory = New ShapefileWorkspaceFactory
Set pWorkspaceEdit = pWorkspaceFactory.OpenFromFile(pDataSet.Workspace.PathName, 0)
pWorkspaceEdit.StartEditOperation
pWorkspaceEdit.StartEditing True
Set pMultiLeft = New Multipoint
Set pMultiRight = New Multipoint
Set pGonColl = New Polygon
Set pMultiPoint = New Multipoint
Set pMultiPointSorted = New Multipoint
'得到所选择的图形集
Set pEnumFeature = pMxDoc.FocusMap.FeatureSelection
Set pFeature = pEnumFeature.Next
'增加点到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
'创建第一个Polygon
pGonColl.AddPointCollection pMultiPoint
Set pTopoOp = pGonColl
'将Polygon是否是Simple设置成未知
pTopoOp.IsKnownSimple = False
'经判断，如果不是Simple，则经过以下处理，将其转换为Simple
If pTopoOp.IsSimple = False and pMultiPoint.PointCount>3 Then
lFlag = 1
Set pTopoOp = pMultiPoint
pTopoOp.IsKnownSimple = False
pTopoOp.Simplify
'将Multipoint进行排序
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
Set pClonei = pMultiPoint.Point(i)
Set pPointi = pClonei.Clone
'交换两点
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
'找出MultiPoint中的最大和最小点
pMultiPoint.QueryPoint 0, ptMin
pMultiPoint.QueryPoint pMultiPoint.PointCount - 1, ptMax
'创建一条线段
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
Set pRingColl = New Ring
'将左边的线添加到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
'第一条线
Set pLine = New Line
pLine.PutCoords pMultiLeft.Point(pMultiLeft.PointCount - 1), pMultiRight.Point(0)
pRingColl.AddSegment pLine
'将右边的先添加到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
'最后一条线
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
Else
Set pPolygon = pGonColl2 'QI
End If
'画出Polygon
Set pFeatureLayer1 = pMap.Layer(1)
Set pFeatureClass1 = pFeatureLayer1.FeatureClass
Set pFeature1 = pFeatureClass1.CreateFeature
'把画的Polygon加到新建的Feature上
Set pFeature1.Shape = pPolygon
'保存Feature
pFeature1.Store
pMxDoc.ActiveView.Refresh
'停止编辑
pWorkspaceEdit.StopEditOperation
pWorkspaceEdit.StopEditing True
Exit Sub
ErrorHander:
pWorkspaceEdit.AbortEditOperation
MsgBox Err.Description
End Sub
