Set Selected Rasters To Self Base Height

Created:12/6/2001
Description:

This function sets the 'base height' property for any selected Raster layer in the ArcScene table of contents to itself.

How to use:
  1. Paste the code into an ArcScene or ArcMap VBA session and call the macro 'SetSelectedRastersToSelfBaseHeight'.
'
' a macro for setting the baseheight of rasters in a scene to themselves
'
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 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 esriCore.Array
  
  If TypeOf Application.Document Is ISxDocument Then
      Set pSxDoc = Application.Document
      Set pScene = pSxDoc.Scene
      
      If Not bOnlySelected Then
          Set pLayers = New esriCore.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 esriCore.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 esriCore.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.de
  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


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
  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


'
' 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