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