This function calculates the volume and surface area for a TIN layer selected in the Map or Scene Table Of Contents. The results are opened into a message box. The intent of this sample is to demonstrate programmatic interaction with a TIN surface.
How to use
- Copy and paste the following code into an ArcMap or ArcScene VBA session and call the macro 'DisplaySelectedTINStatisticsAboveZMin'.
'
' calculate the volume of the selected TIN, and display in a message box
'
Public Sub DisplaySelectedTINStatisticsFromZMin()
On Error GoTo DisplaySelectedTINStatisticsFromZMin_ERR
Dim pTinLayer As ITinLayer
Dim pLayerArray As IArray
Set pLayerArray = GetDocLayers(True)
' find the first TIN layer:
Dim i As Integer
For i = 0 To pLayerArray.Count - 1
If TypeOf pLayerArray.Element(i) Is ITinLayer Then
Set pTinLayer = pLayerArray.Element(i)
Exit For
End If
Next
' exit if no TIN layer is selected:
If pTinLayer Is Nothing Then
MsgBox "Please select a TIN layer for this command."
Exit Sub
End If
' get TIN surface:
Dim pSurf As ISurface
Set pSurf = GetSurfaceFromLayer(, pTinLayer)
Dim pTinSurf As ITinSurface
Set pTinSurf = pSurf
' calculate statistics:
Dim nVolume As Double
Dim nArea As Double
nVolume = pTinSurf.GetVolume(pTinLayer.AreaOfInterest.zmin, 0)
nArea = pTinSurf.GetSurfaceArea(pTinLayer.AreaOfInterest.zmin, 0)
' display results:
Dim sMsg As String
sMsg = "Statistics for " & pTinLayer.Name & " above height " & pTinLayer.AreaOfInterest.ZMin & ":" & vbCrLf & vbCrLf
sMsg = sMsg & "===============================" & vbCrLf
sMsg = sMsg & "Volume: " & nVolume & vbCrLf
sMsg = sMsg & "Surface Area: " & nArea & vbCrLf
sMsg = sMsg & "==============================="
MsgBox sMsg
Exit Sub
DisplaySelectedTINStatisticsFromZMin_ERR:
Debug.Print "DisplaySelectedTINStatisticsFromZMin_ERR: " & Err.Description
Debug.Assert 0
End Sub
'
' 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
'
' given a layername or index return the ISurface from it;
'
Private Function GetSurfaceFromLayer(Optional sLayer, Optional OrActualLayer 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 OrActualLayer Is Nothing Then
Set pLayer = GetLayer(sLayer)
Else
Set pLayer = OrActualLayer
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 For
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