如何將選中的點集轉換成Polygon

本例要實現的功能是根據選中的Points創建一個Polygon，並且保存到Polygon類型的FeatureLayer中，要求被選擇的Points最少爲3個。

l 要點

根據選擇的點創建一個Polygon，首先要判斷生成的Polygon是否是Simple,這裏用到接口ITopologicalOperator2的屬性IsSimple。如果不是,則要對做Polygon排序等處理。此外還用到了接口IPointCollection的方法ReplacePoints，進行點的交換。將排好序的點，按順序創建Segment，運用實例化爲Ring的ISegmentCollection接口方法AddSegment增加Segment。實例化爲Polygon的IGeometryCollection接口方法AddGeometry增加Ring。這樣，通過上面的方法便可以創建Polygon。

l 程序說明

根據接口ITopologicalOperator2.IsSimple屬性判斷Polygon是否Simple。如果返回爲False，就對Polygon上的點進行排序等處理，排好序後，找出X方向上值最大和最小的點，由這兩點創建一條直線，將所有點分成在直線左邊和右邊兩部分。

l 代碼

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