This function sets the 'base height' property of any applicable layer selected in the ArcScene Table of Contents to the surface which is selected in the 3D Analyst toolbar. The intent of this sample is to demonstrate programmatic interaction with 3D layer properties.
How to use
- Copy and paste the following code into an ArcScene VBA session and call the macro 'DrapeSelectedLayersOnActiveSurface'.
' set the base surface for all selected layers to the surface selected
' in the 3D Analyst toolbar
'
Public Sub DrapeSelectedLayersOnActiveSurface()
On Error GoTo DrapeSelectedLayersOnActiveSurface_ERR
' only relavent in ArcScene:
If Not InScene Then Exit Sub
Dim pSurface As ISurface
' get the surface from the 3D Analyst toolbar:
Set pSurface = GetCurrentSurface()
If pSurface Is Nothing Then
MsgBox "Please add a surface layer and select it in the 3D Analyst Toolbar to use this macro.", vbInformation
Exit Sub
End If
Dim pLayerArray As IArray
' get the selected layers:
Set pLayerArray = GetDocLayers(True)
If pLayerArray Is Nothing Then Exit Sub
If pLayerArray.Count < 1 Then Exit Sub
Dim i As Integer
Dim pLayer As ILayer
Dim p3DProps As I3DProperties
' iterate through array; modifying the 3D layer properties; invalidate layer;
' then redraw the document
For i = 0 To pLayerArray.Count - 1
Set pLayer = pLayerArray.Element(i)
Set p3DProps = Get3DPropsFromLayer(pLayer)
With p3DProps
Set .BaseSurface = pSurface
.BaseOption = esriBaseSurface
End With
InvalidateSceneLayer pLayer
Next
RefreshDocument
Exit Sub
DrapeSelectedLayersOnActiveSurface_ERR:
Debug.Print "DrapeSelectedLayersOnActiveSurface_ERR: " & Err.Description
Debug.Assert 0
Resume Next ' to go to the next layer
End Sub
'
' return the surface from the layer listed in the 3DAnalyst Toolbar dropdown
'
Private Function GetCurrentSurface() As ISurface
On Error GoTo GetCurSurLayer_ERR
Dim p As IDDDToolbarEnvironment
Dim pLayer As ILayer
Set p = New DDDToolbarEnvironment
Set pLayer = p.CurrentSelectedLayer
Set GetCurrentSurface = GetSurfaceFromLayer(, pLayer)
Exit Function
GetCurSurLayer_ERR:
Debug.Print "GetCurSurLayer_ERR: " & Err.Description
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 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)
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
End If
Exit Function
GetLayer_Err:
Debug.Print "GetLayer_ERR: " & Err.Description
Debug.Assert 0
End Function
'
' return an IEnumLayer of layers in current document
'
Private Function GetDocLayers(Optional bOnlySelected As Boolean) As IArray
Dim pSxDoc As ISxDocument
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
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
Private Sub InvalidateSceneLayer(pLayer As ILayer, Optional bGeography As Boolean = True, Optional bSelection As Boolean = False)
On Error GoTo InvalidateSceneLayer_ERR
If Not InScene Then Exit Sub
Dim pSxDoc As ISxDocument
Set pSxDoc = Application.Document
pSxDoc.Scene.SceneGraph.Invalidate pLayer, bGeography, bSelection
Exit Sub
InvalidateSceneLayer_ERR:
Debug.Print "InvalidateSceneLayer_ERR: " & Err.Description
Debug.Assert 0
End Sub
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.RefreshViewers
End If
Exit Sub
RefreshDocument_ERR:
Debug.Print "RefreshDocument_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