如何将选中的点集转换成Polygon

最新推荐文章于 2024-08-01 11:37:39 发布

swfsunboy

最新推荐文章于 2024-08-01 11:37:39 发布

阅读量3.2k

点赞数

分类专栏： ARCGIS 文章标签：图形工作

ARCGIS 专栏收录该内容

30 篇文章 1 订阅

订阅专栏

本例要实现的功能是根据选中的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