Generate edge (continued)

Private Sub commandbutton#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

'Create a surface File
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
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
PFieldsEdit. AddField pField

Set pField = New Field
Set pFieldEdit = pField
With pFieldEdit
. Name = "Integer"
. Type = esriFieldTypeInteger
End
PFieldsEdit. AddField pField

Set pField = New Field
Set pFieldEdit = pField
With pFieldEdit
. Name = "Single"
. Type = esriFieldTypeSingle
End
PFieldsEdit. AddField pField

Set pField = New Field
Set pFieldEdit = pField
With pFieldEdit
. Precision = 5
. Scale = 5
. Name = "Double"
. Type = esriFieldTypeDouble
End
PFieldsEdit. AddField pField

Set pField = New Field
Set pFieldEdit = pField
With pFieldEdit
. Length = 30
. Name = "String"
. Type = esriFieldTypeString
End
PFieldsEdit. AddField pField

Set pField = New Field

Set pFieldEdit = pField
With pFieldEdit
. Name = "Date"
. Type = esriFieldTypeDate
End
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

'Create a line file
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
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
PFieldsEdit. AddField pField

Set pField = New Field
Set pFieldEdit = pField
With pFieldEdit
. Name = "Integer"
. Type = esriFieldTypeInteger
End
PFieldsEdit. AddField pField

Set pField = New Field
Set pFieldEdit = pField
With pFieldEdit
. Name = "Single"
. Type = esriFieldTypeSingle
End
PFieldsEdit. AddField pField

Set pField = New Field
Set pFieldEdit = pField
With pFieldEdit
. Precision = 5
. Scale = 5
. Name = "Double"
. Type = esriFieldTypeDouble
End
PFieldsEdit. AddField pField

Set pField = New Field
Set pFieldEdit = pField
With pFieldEdit
. Length = 30
. Name = "String"
. Type = esriFieldTypeString
End
PFieldsEdit. AddField pField

Set pField = New Field

Set pFieldEdit = pField
With pFieldEdit
. Name = "Date"
. Type = esriFieldTypeDate
End
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 ipolympus gon
Dim pOnePoints As IPointCollection

Dim I As Integer

Dim pPoint As IPoint
Dim pPolygon As ipolympus gon
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 ipolympus gon
Dim pPolygonTwo As ipolympus gon
Dim pOnePoints As IPointCollection
Dim pTwoPoints As IPointCollection
Dim I As Integer

Dim pFromPoint As IPoint
Dim pToPoint As IPoint
Dim pPolyline As ipolympus line
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 for improved insertion Efficiency

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 for improved insertion Efficiency

Next I

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

 

End Function