高程處理（Tin）

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.Search(Nothing, False)

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
pFeature.Store

Set pFeature = pFeatureCursor.NextFeature
Wend

MsgBox "轉化完成"
End Sub