產生側棱（續）

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 Integer

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

 
While Not pFeatureOne Is Nothing
  
   Set pPolygonOne = pFeatureOne.Shape
   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
  
   Set pFeature = pFeatBuf
   Set pFeature.Shape = pPolygon
   q = pFeatCur.InsertFeature(pFeatBuf)
  
   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
  

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 Integer

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    ’提高插入效率的buffer

 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)     ’提高插入效率的buffer
   
   Next i
  
   Set pFeatureOne = pFeatureCursorOne.NextFeature
   Set pFeatureTwo = pFeatureCursorTwo.NextFeature
Wend

 

End Function