arcmap vba 生成3维侧棱 以及 createfeature与createfeaturebuffer的区别

Sub huaxian()
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
Dim pFLayerNew As IFeatureLayer

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

Set pFeatureClassOne = pFLayerOne.FeatureClass
Set pFeatureClassTwo = pFLayerTwo.FeatureClass
Set pFeatureClassNew = pFLayerNew.FeatureClass

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

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

MsgBox "done!"
End Sub

——————————————————————————————————————————————————————————————————————

Sub huaxian()

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
Dim pFLayerNew As IFeatureLayer

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

Set pFeatureClassOne = pFLayerOne.FeatureClass
Set pFeatureClassTwo = pFLayerTwo.FeatureClass
Set pFeatureClassNew = pFLayerNew.FeatureClass

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

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 = pFeatureClassNew.CreateFeature
Set pFeatureNew.Shape = pPolyline
pFeatureNew.Store

Next i

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

MsgBox "done!"

End Sub