AE calculates the volume of Tin

Public Sub SetSelectedRastersToSelfBaseHeight ()
On Error GoTo eh

Dim pRLayer As IRasterLayer
Dim pLayer As ILayer
Dim I As Integer
Dim pLayersArray As IArray
Dim pDDD As I3DProperties
Dim pSurf As ISurface
If Not InScene () Then Exit Sub


'Get the layers:
Set pLayersArray = GetDocLayers (True)

'No layers found:
If pLayersArray Is Nothing Then Exit Sub


For I = 0 To pLayersArray. Count-1
Set pLayer = pLayersArray. Element (I)

If TypeOf pLayer Is IRasterLayer Then
Set pRLayer = pLayer
Set pDDD = Get3DPropsFromLayer (pLayer)
PDDD. BaseOption = esriBaseSurface
Set pSurf = GetSurfaceFromLayer (pLayer. name)
Set pDDD. BaseSurface = pSurf
PDDD. Apply3DProperties pLayer
End If
Next

RefreshDocument

Exit Sub

Eh:
Debug. Print "SetSelectedRastersToSelfBaseHeight_ERR:" & err. Description
Debug. Assert 0
End Sub
'
'Return true if application is ArcScene
'
Private Function InScene () As Boolean
On Error Resume Next
If TypeOf Application Is ISxApplication Then
InScene = True
Else
InScene = False
End If
End Function
'
'Return an IEnumLayer of layers in current document
'
Private Function GetDocLayers (Optional bOnlySelected As Boolean) As IArray
Dim pSxDoc As ISxDocument
Dim pMxDoc As IMxDocument
Dim pTOC As IContentsView
Dim I As Integer
Dim pScene As IScene
Dim ppSet As ISet
Dim p
Dim pLayers As IArray
Dim pLayer As ILayer

On Error GoTo GetDocLayers_ERR
Set GetDocLayers = New esriSystem. Array

If TypeOf Application. Document Is ISxDocument Then
Set pSxDoc = Application. Document
Set pScene = pSxDoc. Scene

If Not bOnlySelected Then
Set pLayers = New esriSystem. Array
For I = 0 To pScene. LayerCount-1
PLayers. Add pScene. Layer (I)
Next
Set GetDocLayers = pLayers
Exit Function
Else
Dim pSxTOC As ISxContentsView
Set pSxTOC = pSxDoc. ContentsView (0)
End If

ElseIf TypeOf Application. Document Is IMxDocument Then
Set pMxDoc = Application. Document

If Not bOnlySelected Then
Set pLayers = New esriSystem. Array
For I = 0 To pMxDoc. FocusMap. LayerCount-1
PLayers. Add pMxDoc. FocusMap. Layer (I)
Next
Set GetDocLayers = pLayers
Exit Function
Else
Set pTOC = pMxDoc. ContentsView (0)
End If

End If

If Not pTOC Is Nothing Then
If IsNull (pTOC. SelectedItem) Then Exit Function
Set p = pTOC. SelectedItem
ElseIf Not pSxTOC Is Nothing Then
If IsNull (pSxTOC. SelectedItem) Then Exit Function
Set p = pSxTOC. SelectedItem
End If

Set pLayers = New esriSystem. Array

If TypeOf p Is ISet Then
Set ppSet = p
PpSet. Reset
For I = 0 To ppSet. Count
Set pLayer = ppSet. Next
If Not pLayer Is Nothing Then
PLayers. Add pLayer
End If
Next
ElseIf TypeOf p Is ILayer Then
Set pLayer = p
PLayers. Add pLayer
End If

Set GetDocLayers = pLayers

Exit Function

GetDocLayers_ERR:
Debug. Print "GetDocLayers_ERR:" & err. Description
Debug. Assert 0
End Function
'
'Return the I3DProperties from the given ILayer
'
Private Function Get3DPropsFromLayer (pLayer As ILayer) As I3DProperties
On Error GoTo eh

Dim I As Integer
Dim pLayerExts As ILayerExtensions

Set pLayerExts = pLayer
'Get 3d properties from extension;
'Layer must have it if it is in scene:

For I = 0 To pLayerExts. ExtensionCount-1
Dim p3DProps As I3DProperties
Set p3DProps = pLayerExts. Extension (I)
If (Not p3DProps Is Nothing) Then
Set Get3DPropsFromLayer = p3DProps
Exit Function
End If
Next

Exit Function

Eh:
Debug. Print "Get3DPropsFromLayer_ERR:" & err. Description
Debug. Assert 0

End Function
'
'Giveen a layername or index return the ISurface from it;
'
Private Function GetSurfaceFromLayer (Optional sLayer, Optional ubuntuallayer As ILayer) As ISurface
Dim pLayer As ILayer
Dim pTin As ITin
Dim pRLayer As IRasterLayer
Dim pTLayer As ITinLayer
Dim pSurf As IRasterSurface
Dim pBands As IRasterBandCollection
Dim sName As String
On Error GoTo GetSurfaceFromLayer_ERR
'Get the layer:
If ubuntuallayer Is Nothing Then
Set pLayer = GetLayer (sLayer)
Else
Set pLayer = ubuntuallayer
End If
If pLayer Is Nothing Then Exit Function
If TypeOf pLayer Is IRasterLayer Then
Set pRLayer = pLayer
Dim p3DProp As I3DProperties
Dim pLE As ILayerExtensions
Set pLE = pLayer

Dim I As Integer

'Look for 3D properties of layer:
For I = 0 To pLE. ExtensionCount-1
If TypeOf pLE. Extension (I) Is I3DProperties Then
Set p3DProp = pLE. Extension (I)
Exit
End If
Next

'Look first for base surface of layer:
Set pSurf = p3DProp. BaseSurface

'If not found, try first band of raster:
If pSurf Is Nothing Then
If Not pRLayer. raster Is Nothing Then
Set pSurf = New RasterSurface
Set pBands = pRLayer. raster
PSurf. RasterBand = pBands. Item (0)
SName = pLayer. name
End If
Else
End If

Set GetSurfaceFromLayer = pSurf

ElseIf TypeOf pLayer Is ITinLayer Then
'Get the surface off the tin layer:
Set pTLayer = pLayer
Set GetSurfaceFromLayer = pTLayer. Dataset
Else

End If

Exit Function

GetSurfaceFromLayer_ERR:
Debug. Print "GetSurfaceFromLayer_ERR:" & vbCrLf & err. Description
Debug. Assert 0
End Function
'
'Accept a layername or index and return the corresponding ILayer
'
Private Function GetLayer (sLayer) As ILayer
Dim pSxDoc As ISxDocument
Dim pMxDoc As IMxDocument
Dim pTOCs As ISxContentsView
Dim pTOC As IContentsView
Dim I As Integer
Dim pLayers As IEnumLayer
Dim pLayer As ILayer

On Error GoTo GetLayer_Err
If IsNumeric (sLayer) Then
'If numeric index, this is easy:
If TypeOf Application. Document Is ISxDocument Then
Set pSxDoc = Application. Document
Set GetLayer = pSxDoc. Scene. Layer (sLayer)
ElseIf TypeOf Application. Document Is IMxDocument Then
Set pMxDoc = Application. Document
Set GetLayer = pMxDoc. FocusMap. Layer (sLayer)
Exit Function
End If

Else
'Iterate through document layers looking for a name match:
If TypeOf Application. Document Is ISxDocument Then
Set pSxDoc = Application. Document
Set pLayers = pSxDoc. Scene. Layers
Set pLayer = pLayers. Next
Do While Not pLayer Is Nothing
If UCase (sLayer) = UCase (pLayer. name) Then
Set GetLayer = pLayer
Exit Function
End If
Set pLayer = pLayers. Next
Loop

ElseIf TypeOf Application. Document Is IMxDocument Then
Set pMxDoc = Application. Document
Set pLayers = pMxDoc. FocusMap. Layers
Set pLayer = pLayers. Next
Do While Not pLayer Is Nothing
If UCase (sLayer) = UCase (pLayer. name) Then
Set GetLayer = pLayer
Exit Function
End If
Set pLayer = pLayers. Next
Loop
End If
End If
Exit Function

GetLayer_Err:
Debug. Print "GetLayer_ERR:" & err. Description
Debug. Assert 0
End Function

Public Sub RefreshDocument (Optional bInvalidateSelection As Boolean)
On Error GoTo RefreshDocument_ERR

If TypeOf Application. Document Is ISxDocument Then
Dim pSxDoc As ISxDocument
Set pSxDoc = Application. Document
PSxDoc. Scene. SceneGraph. Invalidate pSxDoc. Scene. SceneGraph. ActiveViewer, True, bInvalidateSelection
PSxDoc. Scene. SceneGraph. RefreshViewers
Else
Dim pMxDoc As IMxDocument
Set pMxDoc = Application. Document
PMxDoc. ActiveView. Refresh
End If

Exit Sub

RefreshDocument_ERR:
Debug. Print "RefreshDocument_ERR:" & err. Description
Debug. Assert 0
End Sub