|
Private Function PolygonsFromPolygonRings(pGeomColl As IGeometryCollection, bClone As Boolean) As _ IGeometryCollection
Dim i As Long
Dim pGeometryCollection As IGeometryCollection
Dim pTopologicalOperator As ITopologicalOperator
If Not pGeomColl Is Nothing Then
If pGeomColl.GeometryCount > 0 Then
Set PolygonsFromPolygonRings = New GeometryBag
If bClone Then
If TypeOf pGeomColl Is IClone Then
Dim pClone As IClone
Set pClone = pGeomColl
Set pGeomColl = pClone.Clone
End If
End If
'为每个Ring创建一个新Polygon,将Polygon进行simplify后,放在GeometryBag中
For i = 0 To pGeomColl.GeometryCount - 1
If pGeomColl.Geometry(i).GeometryType = esriGeometryRing Then
Set pGeometryCollection = New Polygon
Set pTopologicalOperator = pGeometryCollection
pGeometryCollection.AddGeometry pGeomColl.Geometry(i)
pTopologicalOperator.Simplify
PolygonsFromPolygonRings.AddGeometry pGeometryCollection
End If
Next i
End If
End If
End Function
Public Sub PolygonRingsToPolygons()
Dim pMxDocument As IMxDocument
Dim pMap As IMap
Dim pActiveView As IActiveView
Dim pEnumFeature As IEnumFeature
Dim pFeature0 As IFeature
Dim pFeatureLayer0 As IFeatureLayer
Dim pFeatureClass0 As IFeatureClass
Dim pFeature1 As IFeature
Dim pFeatureLayer1 As IFeatureLayer
Dim pFeatureClass1 As IFeatureClass
Dim pPointCollection As IPointCollection
Dim pGeometryCollection As IGeometryCollection
Dim pDataSet As IDataset
Dim pWorkspaceFactory As IWorkspaceFactory
Dim pWorkspaceEdit As IWorkspaceEdit
Dim pPolygon As IPolygon
Dim pGeometryColPolygon As IGeometryCollection
Dim pGeometryColPolygonNew As IGeometryCollection
Dim pGeometryCollectionPolygon As IgeometryCollection
Dim lGeometryIndex As Long
Dim lPointFieldIndex As Long
On Error GoTo ErrorHanlder
'得到当前层
Set pMxDocument = ThisDocument
Set pMap = pMxDocument.FocusMap
Set pActiveView = pMap
Set pPolygon1 = New Polygon
Set pGeometryColPolygon = New Polygon
Set pGeometryColPolygonNew = New Polygon
Set pGeometryColPolygonNew1 = New Polygon
Set pGeometryCollectionPolygon = New GeometryBag
'得到0层和1层的FeatureClass
Set pFeatureLayer0 = pMxDocument.FocusMap.Layer(0)
Set pFeatureClass0 = pFeatureLayer0.FeatureClass
Set pFeatureLayer1 = pMxDocument.FocusMap.Layer(1)
Set pFeatureClass1 = pFeatureLayer1.FeatureClass
'建立编辑工作区
Set pDataSet = pFeatureClass1
Set pWorkspaceFactory = New ShapefileWorkspaceFactory
Set pWorkspaceEdit = pWorkspaceFactory.OpenFromFile(pDataSet.Workspace.PathName, 0)
pWorkspaceEdit.StartEditOperation
pWorkspaceEdit.StartEditing True
'得到Feature
Set pEnumFeature = pMxDocument.FocusMap.FeatureSelection
Set pFeature0 = pEnumFeature.Next
If pFeature0 Is Nothing Then
MsgBox "Must have Select in Position 0"
Exit Sub
End If
'将一个Polygon上的多个Ring转换成多个Polygon
Set pGeometryCollectionPolygon = PolygonsFromPolygonRings(pGeometryColPolygonNew, True)
'将转换成的多个Polygon添加到第二层上
For lGeometryIndex = 0 To pGeometryCollectionPolygon.GeometryCount - 1
Set pFeature1 = pFeatureClass1.CreateFeature
'把画的Polygon加到新建的Feature上
Set pPolygon1 = pGeometryCollectionPolygon.Geometry(lGeometryIndex)
Set pFeature1.Shape = pPolygon1
'保存Feature
pFeature1.Store
Next
pMxDocument.ActiveView.Refresh
'停止编辑
pWorkspaceEdit.StopEditOperation
pWorkspaceEdit.StopEditing True
Exit Sub
ErrorHanlder:
pWorkspaceEdit.AbortEditOperation
MsgBox Err.Description
End Sub | 
