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
