生成侧棱解决了 多边形有洞的问题

Private Sub CommandButton1_Click()

'这样什么时候看起来都思路很清晰

Dim pFeatureClassTwo As IFeatureClass
Set pFeatureClassTwo = CreatePolygonShapeFile(GetLayerDataPath, TextBox2.Text)

Dim pFeatureClassNew As IFeatureClass
Set pFeatureClassNew = CreatePolylineShapeFile(GetLayerDataPath, TextBox3.Text)

Call CopyFeatureClass(GetLayerDataPath, TextBox2.Text, CDbl(TextBox1.Text))

Call AddLayer(GetLayerDataPath, TextBox2.Text)

Call huaxian(GetLayerDataPath, TextBox3.Text)

Call AddLayer(GetLayerDataPath, TextBox3.Text)

 

 

 

MsgBox "done!"
End Sub
Public Function GetInitFeatureClass() As IFeatureClass
Dim pMxDoc As IMxDocument
Set pMxDoc = Application.Document

Dim pMap As IMap
Set pMap = pMxDoc.FocusMap

Dim pActiveView As IActiveView
Set pActiveView = pMxDoc.FocusMap

Dim pFeatureClassOne As IFeatureClass
Dim pFLayerOne As IFeatureLayer

Set pFLayerOne = pMap.Layer(0)
Set pFeatureClassOne = pFLayerOne.FeatureClass

Set GetInitFeatureClass = pFeatureClassOne

End Function

Public Function GetLayerDataPath() As String
Dim pMxDoc As IMxDocument
Set pMxDoc = Application.Document

Dim pMap As IMap
Set pMap = pMxDoc.FocusMap

Dim pActiveView As IActiveView
Set pActiveView = pMxDoc.FocusMap

Dim pFeatureClassOne As IFeatureClass
Dim pFLayerOne As IFeatureLayer

Set pFLayerOne = pMap.Layer(0)
Set pFeatureClassOne = pFLayerOne.FeatureClass

Dim pDataSet As IDataset
Set pDataSet = pFeatureClassOne

Dim pWorkspace As IWorkspace
Set pWorkspace = pDataSet.Workspace

Dim dataPath As String
dataPath = pWorkspace.PathName

GetLayerDataPath = dataPath
 

End Function

Public Function CreatePolygonShapeFile(ByVal sFilePath As String, ByVal sFileName As String) As IFeatureClass
  
   '新建面文件
    Dim pFeatureWorkspace           As IFeatureWorkspace
    Dim pWorkSpaceFactory           As IWorkspaceFactory
    Dim pFields                     As IFields
    Dim pFieldsEdit                 As IFieldsEdit
    Dim pField                      As IField
    Dim pFieldEdit                  As IFieldEdit
    Dim pGeometryDef                As IGeometryDef
    Dim pGeometryDefEdit            As IGeometryDefEdit
    Dim pFeatClass                  As IFeatureClass
    Dim sShapeFieldName             As String
    Dim sNewShapeFileName           As String
   
On Error GoTo ErrorHandler:
   
    sNewShapeFileName = Dir(sFilePath & "/" & sFileName & ".shp")
   

   
    sShapeFieldName = "Shape"

    'Open the folder to contain the shapefile as a workspace
    Set pWorkSpaceFactory = New ShapefileWorkspaceFactory
    Set pFeatureWorkspace = pWorkSpaceFactory.OpenFromFile(sFilePath, 0)
   
    'Set up a simple fields collection
    Set pFields = New Fields
    Set pFieldsEdit = pFields
   
    'Make the shape field
    'it will need a geometry definition, with a spatial reference
    Set pField = New Field
    Set pFieldEdit = pField
    pFieldEdit.Name = sShapeFieldName
    pFieldEdit.Type = esriFieldTypeGeometry
    Set pGeometryDef = New GeometryDef
    Set pGeometryDefEdit = pGeometryDef
    With pGeometryDefEdit
        .GeometryType = esriGeometryPolygon
        Set .SpatialReference = New UnknownCoordinateSystem
    End With
    Set pFieldEdit.GeometryDef = pGeometryDef
    pFieldsEdit.AddField pField
   
        'Add others miscellaneous text field
    Set pField = New Field
    Set pFieldEdit = pField
    With pFieldEdit
        .Name = "SmallInteger"
        .Type = esriFieldTypeSmallInteger
    End With
    pFieldsEdit.AddField pField
   
    Set pField = New Field
    Set pFieldEdit = pField
    With pFieldEdit
        .Name = "Integer"
        .Type = esriFieldTypeInteger
    End With
    pFieldsEdit.AddField pField
   
    Set pField = New Field
    Set pFieldEdit = pField
    With pFieldEdit
        .Name = "Single"
        .Type = esriFieldTypeSingle
    End With
    pFieldsEdit.AddField pField
   
    Set pField = New Field
    Set pFieldEdit = pField
    With pFieldEdit
        .Precision = 5
        .Scale = 5
        .Name = "Double"
        .Type = esriFieldTypeDouble
    End With
    pFieldsEdit.AddField pField
   
    Set pField = New Field
    Set pFieldEdit = pField
    With pFieldEdit
        .Length = 30
        .Name = "String"
        .Type = esriFieldTypeString
    End With
    pFieldsEdit.AddField pField
   
    Set pField = New Field

    Set pFieldEdit = pField
    With pFieldEdit
        .Name = "Date"
        .Type = esriFieldTypeDate
    End With
    pFieldsEdit.AddField pField
   
    'Create the shapefile
    '(some parameters apply to geodatabase options and can be defaulted as Nothing)
    Set pFeatClass = pFeatureWorkspace.CreateFeatureClass(sFileName, pFields, Nothing, Nothing, esriFTSimple, sShapeFieldName, "")
    CreatPShapeFile = pFeatClass
    
    sNewShapeFileName = Dir(sFilePath & "/" & sFileName & ".shp")
   
   
    Exit Function
ErrorHandler:
   MsgBox Err.Descrition
  
  
End Function

Public Function CreatePolylineShapeFile(ByVal sFilePath As String, ByVal sFileName As String) As IFeatureClass
  
   '新建线文件
    Dim pFeatureWorkspace           As IFeatureWorkspace
    Dim pWorkSpaceFactory           As IWorkspaceFactory
    Dim pFields                     As IFields
    Dim pFieldsEdit                 As IFieldsEdit
    Dim pField                      As IField
    Dim pFieldEdit                  As IFieldEdit
    Dim pGeometryDef                As IGeometryDef
    Dim pGeometryDefEdit            As IGeometryDefEdit
    Dim pFeatClass                  As IFeatureClass
    Dim sShapeFieldName             As String
    Dim sNewShapeFileName           As String
   
On Error GoTo ErrorHandler:
    sNewShapeFileName = Dir(sFilePath & "/" & sFileName & ".shp")
   

   
    sShapeFieldName = "Shape"

    'Open the folder to contain the shapefile as a workspace
    Set pWorkSpaceFactory = New ShapefileWorkspaceFactory
    Set pFeatureWorkspace = pWorkSpaceFactory.OpenFromFile(sFilePath, 0)
   
    'Set up a simple fields collection
    Set pFields = New Fields
    Set pFieldsEdit = pFields
   
    'Make the shape field
    'it will need a geometry definition, with a spatial reference
    Set pField = New Field
    Set pFieldEdit = pField
    pFieldEdit.Name = sShapeFieldName
    pFieldEdit.Type = esriFieldTypeGeometry
    Set pGeometryDef = New GeometryDef
    Set pGeometryDefEdit = pGeometryDef
    With pGeometryDefEdit
        .GeometryType = esriGeometryPolyline
        Set .SpatialReference = New UnknownCoordinateSystem
    End With
    Set pFieldEdit.GeometryDef = pGeometryDef
    pFieldsEdit.AddField pField
   
        'Add others miscellaneous text field
    Set pField = New Field
    Set pFieldEdit = pField
    With pFieldEdit
        .Name = "SmallInteger"
        .Type = esriFieldTypeSmallInteger
    End With
    pFieldsEdit.AddField pField
   
    Set pField = New Field
    Set pFieldEdit = pField
    With pFieldEdit
        .Name = "Integer"
        .Type = esriFieldTypeInteger
    End With
    pFieldsEdit.AddField pField
   
    Set pField = New Field
    Set pFieldEdit = pField
    With pFieldEdit
        .Name = "Single"
        .Type = esriFieldTypeSingle
    End With
    pFieldsEdit.AddField pField
   
    Set pField = New Field
    Set pFieldEdit = pField
    With pFieldEdit
        .Precision = 5
        .Scale = 5
        .Name = "Double"
        .Type = esriFieldTypeDouble
    End With
    pFieldsEdit.AddField pField
   
    Set pField = New Field
    Set pFieldEdit = pField
    With pFieldEdit
        .Length = 30
        .Name = "String"
        .Type = esriFieldTypeString
    End With
    pFieldsEdit.AddField pField
   
    Set pField = New Field

    Set pFieldEdit = pField
    With pFieldEdit
        .Name = "Date"
        .Type = esriFieldTypeDate
    End With
    pFieldsEdit.AddField pField
   
    'Create the shapefile
    '(some parameters apply to geodatabase options and can be defaulted as Nothing)
    Set pFeatClass = pFeatureWorkspace.CreateFeatureClass(sFileName, pFields, Nothing, Nothing, esriFTSimple, sShapeFieldName, "")
    CreatPShapeFile = pFeatClass
    
    sNewShapeFileName = Dir(sFilePath & "/" & sFileName & ".shp")
   
   
    Exit Function
ErrorHandler:
   MsgBox Err.Descrition
  
  
End Function
Public Function CopyFeatureClass(sFilePath As String, sFileName As String, diff As Double)

Dim pFeatureClassOne As IFeatureClass
Set pFeatureClassOne = GetInitFeatureClass

Dim pFeatureClassTwo As IFeatureClass
Set pFeatureClassTwo = openFeatureClass(sFilePath, sFileName)

Dim pFeatureCursorOne As IFeatureCursor
Set pFeatureCursorOne = pFeatureClassOne.Search(Nothing, True)

Dim pFeatureOne As IFeature
Set pFeatureOne = pFeatureCursorOne.NextFeature

Dim pPolygonOne As IPolygon
Dim pOnePoints As IPointCollection

Dim i As Long
Dim j As Long

Dim pPoint As IPoint
Dim pPolygon As IPolygon
Dim pPointCollection As IPointCollection
Dim pFeature As IFeature

 'create a feature cursor and feature buffer interface
 Dim pFeatCur As IFeatureCursor
 Dim pFeatBuf As IFeatureBuffer
 
 'open the feature cursor and feature buffer
 Set pFeatCur = pFeatureClassTwo.Insert(True)
 Set pFeatBuf = pFeatureClassTwo.CreateFeatureBuffer

 Dim q As Long

'Dim pZAware As IZAware
Dim pGeometryCollectionOne As IGeometryCollection
Dim pRingOne As IRing
Dim pGeometryCollection As IGeometryCollection

Dim pRing As IRing

 
'直接copy shape而不用分解shape。这样就避免了生成环的问题。copy feature的好方法，但是不能平移feature
While Not pFeatureOne Is Nothing
  
 
  Set pPolygonOne = pFeatureOne.ShapeCopy
  Set pGeometryCollectionOne = pPolygonOne
 
  'Set pZAware = pPolygonOne
  'pZAware.ZAware = False
  'pPoint1.Z = 11.1
 
    
If hasHole(pPolygonOne) = True Then  '非简单多边形
  
  
   'Set pOnePoints = pPolygonOne
   Set pPolygon = New Polygon
   Set pGeometryCollection = pPolygon
  
  
  
  For j = 0 To pGeometryCollectionOne.GeometryCount - 1
  
   Set pRingOne = pGeometryCollectionOne.Geometry(j)
   Set pOnePoints = pRingOne
  
   Set pRing = New Ring
   Set pPointCollection = pRing
  
   For i = 0 To pOnePoints.PointCount - 1
  
   Set pPoint = New Point
  
   pPoint.X = pOnePoints.Point(i).X
   pPoint.Y = pOnePoints.Point(i).Y + diff
   pPointCollection.AddPoint pPoint
  
   Next i
  
   pRing.Close
   pGeometryCollection.AddGeometry pRing
  
  
 Next j
  
   'pPolygon.Close
   'pPolygon.SimplifyPreserveFromTo  '这句话不能要！
  
   Set pFeature = pFeatBuf
   Set pFeature.Shape = pPolygon
  
   q = pFeatCur.InsertFeature(pFeatBuf)
  
 End If
 
 If hasHole(pPolygonOne) = False Then  '简单多边形
  
   Set pOnePoints = pPolygonOne
  
   Set pPolygon = New Polygon
   Set pPointCollection = pPolygon
  
   For i = 0 To pOnePoints.PointCount - 1
  
   Set pPoint = New Point
   pPoint.X = pOnePoints.Point(i).X
   pPoint.Y = pOnePoints.Point(i).Y + diff
   pPointCollection.AddPoint pPoint
   Next i
  
   pPolygon.Close
   'pPolygon.SimplifyPreserveFromTo'这句话不能要！
  
   Set pFeature = pFeatBuf
   Set pFeature.Shape = pPolygon
   q = pFeatCur.InsertFeature(pFeatBuf)
 
 End If
 
 
   Set pFeatureOne = pFeatureCursorOne.NextFeature
Wend

End Function

Public Function openFeatureClass(sFilePath As String, sFileName As String) As IFeatureClass
   
    Dim pFeatureWorkspace  As IFeatureWorkspace
    Dim pWorkSpaceFactory  As IWorkspaceFactory
   
    Set pWorkSpaceFactory = New ShapefileWorkspaceFactory
    Set pFeatureWorkspace = pWorkSpaceFactory.OpenFromFile(sFilePath, 0)
   
    Set openFeatureClass = pFeatureWorkspace.openFeatureClass(sFileName)
   

End Function

Public Function AddLayer(sFilePath As String, sFileName As String)

    Dim pFeatureWorkspace  As IFeatureWorkspace
    Dim pWorkSpaceFactory  As IWorkspaceFactory
   
    Set pWorkSpaceFactory = New ShapefileWorkspaceFactory
    Set pFeatureWorkspace = pWorkSpaceFactory.OpenFromFile(sFilePath, 0)
   
    Dim openFeatureClass As IFeatureClass
    Set openFeatureClass = pFeatureWorkspace.openFeatureClass(sFileName)

   Dim pMxDoc As IMxDocument
   Set pMxDoc = Application.Document

   Dim pMap As IMap
   Set pMap = pMxDoc.FocusMap

   Dim pActiveView As IActiveView
   Set pActiveView = pMxDoc.FocusMap
  
   Dim pFeatureLayer As IFeatureLayer
   Set pFeatureLayer = New FeatureLayer
  
   Set pFeatureLayer.FeatureClass = openFeatureClass
   pFeatureLayer.Name = sFileName
  
   pMap.AddLayer pFeatureLayer
  
   pActiveView.Refresh

End Function

Function huaxian(sFilePath As String, sFileName As String)

Dim pMxDoc As IMxDocument
Set pMxDoc = Application.Document

Dim pMap As IMap
Set pMap = pMxDoc.FocusMap

Dim pActiveView As IActiveView
Set pActiveView = pMxDoc.FocusMap

Dim pFeatureClassOne As IFeatureClass
Dim pFLayerOne As IFeatureLayer

Dim pFeatureClassTwo As IFeatureClass
Dim pFLayerTwo As IFeatureLayer

Dim pFeatureClassNew As IFeatureClass

Set pFLayerOne = pMap.Layer(0)
Set pFLayerTwo = pMap.Layer(1)

Set pFeatureClassOne = pFLayerOne.FeatureClass
Set pFeatureClassTwo = pFLayerTwo.FeatureClass
Set pFeatureClassNew = openFeatureClass(sFilePath, sFileName)

Dim pFeatureCursorOne As IFeatureCursor
Dim pFeatureCursorTwo As IFeatureCursor

Set pFeatureCursorOne = pFeatureClassOne.Search(Nothing, True)
Set pFeatureCursorTwo = pFeatureClassTwo.Search(Nothing, True)

Dim pFeatureOne As IFeature
Dim pFeatureTwo As IFeature

Set pFeatureOne = pFeatureCursorOne.NextFeature
Set pFeatureTwo = pFeatureCursorTwo.NextFeature

Dim pPolygonOne As IPolygon
Dim pPolygonTwo As IPolygon
Dim pOnePoints As IPointCollection
Dim pTwoPoints As IPointCollection
Dim i As Long

Dim pFromPoint As IPoint
Dim pToPoint As IPoint
Dim pPolyline As IPolyline
Dim polylinePoints As IPointCollection
Dim pFeatureNew As IFeature

 'create a feature cursor and feature buffer interface
 Dim pFeatCur As IFeatureCursor
 Dim pFeatBuf As IFeatureBuffer
 
 'open the feature cursor and feature buffer
 Set pFeatCur = pFeatureClassNew.Insert(True)
 Set pFeatBuf = pFeatureClassNew.CreateFeatureBuffer

 Dim q As Long

 
While Not pFeatureOne Is Nothing And Not pFeatureTwo Is Nothing
   Set pPolygonOne = pFeatureOne.Shape
   Set pPolygonTwo = pFeatureTwo.Shape
   Set pOnePoints = pPolygonOne
   Set pTwoPoints = pPolygonTwo
 
 For i = 0 To pOnePoints.PointCount - 1
  
   Set pFromPoint = pOnePoints.Point(i)
   Set pToPoint = pTwoPoints.Point(i)
   Set pPolyline = New Polyline
   Set polylinePoints = pPolyline
  
   polylinePoints.AddPoint pFromPoint
   polylinePoints.AddPoint pToPoint
  
   Set pFeatureNew = pFeatBuf
   Set pFeatureNew.Shape = pPolyline
 
   q = pFeatCur.InsertFeature(pFeatBuf)
  
   Next i
  
   Set pFeatureOne = pFeatureCursorOne.NextFeature
   Set pFeatureTwo = pFeatureCursorTwo.NextFeature
Wend

 

End Function
Public Function hasHole(pPolygon As IPolygon) As Boolean

Dim geocollection As IGeometryCollection
Set geocollection = pPolygon
Dim area As IArea

Dim i As Integer

 For i = 0 To geocollection.GeometryCount - 1
  Set area = geocollection.Geometry(i)
  If area.area < 0 Then
    hasHole = True
    Exit Function
  End If
 Next i
 hasHole = False
End Function