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