高程处理（改进）

Sub 高程处理()

Dim app As IApplication
Set app = Application

Dim pMxDocument As IMxDocument
Set pMxDocument = Application.Document

Dim pMap As IMap
Set pMap = pMxDocument.FocusMap

Dim pFeatureLayer As IFeatureLayer
Set pFeatureLayer = pMap.Layer(0)

Dim pTinLayer As ITinLayer
Set pTinLayer = pMap.Layer(1)

Dim pFuncSurf As IFunctionalSurface
Set pFuncSurf = pTinLayer.Dataset

Dim pFeatureCursor As IFeatureCursor
Set pFeatureCursor = pFeatureLayer.FeatureClass.Update(Nothing, False)   ‘用于修改的cursor

Dim pFeature As IFeature
Set pFeature = pFeatureCursor.NextFeature

Dim pPoint As IPoint
Dim x As Double
Dim y As Double
Dim z As Double

Dim index As Integer
Dim pFields As IFields

While Not pFeature Is Nothing

Set pPoint = pFeature.ShapeCopy
x = pPoint.x
y = pPoint.y
z = pFuncSurf.z(x, y)

Set pFields = pFeature.Fields
index = pFields.FindField("Elevation")

pFeature.Value(index) = z
pFeatureCursor.UpdateFeature pFeature     ‘用于修改的cursor，效率提高不少

Set pFeature = pFeatureCursor.NextFeature
Wend

MsgBox "转化完成"
End Sub