arcmap vba 实现“卫星立体测图”高度字段值的计算，今天的一点小成就

Private Sub UIButtonControl1_Click()


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 pRasterLayer As IRasterLayer
Set pRasterLayer = pMap.Layer(1)

Dim pRaster2 As IRaster2
Set pRaster2 = pRasterLayer.Raster

Dim pFeatureCursor As IFeatureCursor
Set pFeatureCursor = pFeatureLayer.FeatureClass.Search(Nothing, False)

Dim pFeature As IFeature
Set pFeature = pFeatureCursor.NextFeature

Dim pPolygon As IPolygon
Dim pArea As IArea
Dim pFields As IFields
Dim height As Long
Dim elevation As Long
Dim pPoint As IPoint
Dim x As Double
Dim y As Double
Dim pixelvalue As Variant
Dim column As Long
Dim row As Long



While Not pFeature Is Nothing

Set pPolygon = pFeature.ShapeCopy
Set pArea = pPolygon
Set pPoint = pArea.Centroid
Set pFields = pFeature.Fields

x = pPoint.x
y = pPoint.y

height = pFields.FindField("HEIGHT")
elevation = pFields.FindField("ELEVATION")

column = pRaster2.ToPixelColumn(x)
row = pRaster2.ToPixelRow(y)

pixelvalue = pRaster2.GetPixelValue(0, column, row)

If pFeature.Value(elevation) <> -9999 Then

pFeature.Value(height) = Abs(CDbl(pixelvalue) - pFeature.Value(elevation))
Else

pFeature.Value(height) = 0
End If



pFeature.Store
Set pFeature = pFeatureCursor.NextFeature
Wend


MsgBox "转化完成"

End Sub