Apply Similar Symbology To Selected TINs

Created:12/6/2001
Description:

This function constructs a TIN renderer which is then applied to any selected TIN layers in the Scene or Map Table of Contents. The intent of this sample is to demonstrate the construction of renderers, as well as the programatic interaction with layers and table of contents.

How to use:
  1. Paste the following code into an ArcScene VBA session and call the macro 'ApplySimiliarSymbologyToSelectedTINs'.
'
'   call method for building a new color ramp renderer and applying
'   to selected TINs
'
Public Sub ApplySimiliarSymbologyToSelectedTINs()

  On Error GoTo ApplySimiliarSymbologyToSelectedTINs_ERR

  Dim pLayers As IArray
  Dim nRampType As Double
  Dim nFromColor As Double
  Dim nToColor As Double
  Dim nClassify_Breaks As Double
  
'   get all layers:
  Dim pTempLayers As IArray
  Set pTempLayers = GetDocLayers(True)
  
  If pTempLayers Is Nothing Then
      MsgBox "Please select TIN Layers for this command"
      Exit Sub
  End If
  
  If pTempLayers.Count <  1 Then
      MsgBox "Please select TIN Layers for this command"
      Exit Sub
  End If
  
'   build array of selected TIN layers:
  Dim i As Integer
  Set pLayers = New esriCore.Array
  For i = 0 To pTempLayers.Count - 1
      If TypeOf pTempLayers.Element(i) Is ITinLayer Then
          pLayers.Add pTempLayers.Element(i)
      End If
  Next
  
  If pLayers.Count <  1 Then
      MsgBox "Please select TIN layers before running this command."
      Exit Sub
  End If
  
  nClassify_Breaks = 2
  
'   call the routine to create the renderer and apply to either all the TINs, or the selected ones:
  ApplyElevationSymbologyToTINs pLayers, "RANDOM", nFromColor, nToColor, nClassify_Breaks
      
  Exit Sub
ApplySimiliarSymbologyToSelectedTINs_ERR:
  Debug.Print "ApplySimiliarSymbologyToSelectedTINs_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


'
'   create an equal classified TIN renderer with the optionally passed in colors,
'   apply it to TIN layers in array; refresh the Display:
'
Private Sub ApplyElevationSymbologyToTINs(pTinLayers As IArray, Optional sRampType_RANDOM_ALGORITMIC = "RANDOM", Optional nFromRGBColor As Double = 13166782, Optional nToRGBColor As Double = 2500231, Optional nClassify_NumBreaks = 2)

  On Error GoTo ApplyElevationSymbologyToTINs
  
  Dim pTRend As ITinRenderer
  Dim i As Double
  Dim pLayer As ILayer
  Dim pSxDoc As ISxDocument
  Dim nMaxElev As Double
  Dim nMinElev As Double
  Dim pA As IActiveView
  Dim pColorEnum As IEnumColors
  Dim pColorRampS As IColorRamp

'   Get Current Doc:
  Set pSxDoc = Application.Document
  Set pA = pSxDoc.Scene
  
'   get colors for renderer:
  If UCase(sRampType_RANDOM_ALGORITMIC) = "RANDOM" Then
'   random:
      Set pColorEnum = CreateRandomColorRamp(CDbl(nClassify_NumBreaks))
  ElseIf UCase(sRampType_RANDOM_ALGORITMIC) = "ALGORITHMIC" Then
'   algorithmic:
      Set pColorEnum = CreateAlgorithmicColorRamp(CDbl(nClassify_NumBreaks), nFromRGBColor, nToRGBColor)
  End If

'   retrieve ranges:
  GetElevStatsFromTINLayers pTinLayers, nMinElev, nMaxElev
  
'   create tin renderer
  Set pTRend = CreateTINEqualClassifyRenderer(nMaxElev, nMinElev, CDbl(nClassify_NumBreaks))
                  
'   apply the colorramp to renderer:
  ApplyColorRampToClassifyRenderer pTRend, pColorEnum
      
  If pTinLayers Is Nothing Or pTRend Is Nothing Then
      Debug.Assert 0
      Exit Sub
  End If
  
'   for each layer in the returned array, apply the new renderer:
  For i = 0 To pTinLayers.Count - 1
      
      Set pLayer = pTinLayers.Element(i)

'   set the TIN's renderer to this one:
      Dim pt As ITinLayer
      Set pt = pLayer
      Dim pTin As ITin
      Set pTin = pt.Dataset
      Set pTRend.Tin = pTin

'   delete the old elevation renderer(s)
      Dim ii As Integer
      For ii = 0 To pt.RendererCount - 1
          If UCase(pt.GetRenderer(ii).Name) = "ELEVATION" Then
              pt.DeleteRenderer pt.GetRenderer(ii)
          End If
      Next
      
'   add renderer, and make visible:
      pt.AddRenderer pTRend
      pt.GetRenderer(pt.RendererCount - 1).Visible = True
      pA.PartialRefresh 2, pLayer, Nothing
      
  Next
      
'   apply the changes and redraw:
  pSxDoc.UpdateContents
  pSxDoc.Scene.SceneGraph.RefreshViewers
  pSxDoc.Scene.SceneGraph.ActiveViewer.Redraw True

  Exit Sub

ApplyElevationSymbologyToTINs:
  Debug.Print "ApplyElevationSymbologyToTINs: " & Err.Description
  Debug.Assert 0
  
End Sub
'
'   take the number of breaks and create a random color ramp;
'   pass the ramp's colors back:
'
Private Function CreateRandomColorRamp(nNumBreaks As Double) As IEnumColors

  On Error GoTo CreateRandomColorRamp_ERR
  
  Dim pCRamp As IRandomColorRamp
  Set pCRamp = New RandomColorRamp
  
  pCRamp.Size = nNumBreaks
  pCRamp.CreateRamp True
  Set CreateRandomColorRamp = pCRamp.Colors
      
  Exit Function
  
CreateRandomColorRamp_ERR:
  Debug.Assert 0
  Debug.Print "CreateRandomColorRamp_ERR: " & Err.Description
  
End Function


'
'   take passed in size, and from and to color, and then create and pass back
'   an algorithmic color ramp:
'
Private Function CreateAlgorithmicColorRamp(nSize As Double, nFromRGBColor As Double, nToRGBColor As Double) As IEnumColors

  Dim pColors As IAlgorithmicColorRamp
  Dim pToColor As IRgbColor
  Dim pFromColor As IRgbColor

  On Error GoTo CreateAlgorithmicColorRamp_ERR

'   set the from and to colors:
  Set pToColor = New RgbColor
  Set pFromColor = New RgbColor
  
  pToColor.RGB = nToRGBColor
  pFromColor.RGB = nFromRGBColor

'   create the color ramp and set the colors:
  Set pColors = New AlgorithmicColorRamp
  pColors.Algorithm = esriCIELabAlgorithm
  pColors.Size = nSize
  pColors.FromColor = pFromColor
  pColors.ToColor = pToColor
  pColors.CreateRamp True
  
  Set CreateAlgorithmicColorRamp = pColors.Colors
  
  Exit Function
  
CreateAlgorithmicColorRamp_ERR:
  Debug.Assert 0
  Debug.Print "CreateAlgorithmicColorRamp_ERR: " & Err.Description
  Resume Next

End Function


'
'   look at each layer passed in, tracking the max and min z's
'
Private Sub GetElevStatsFromTINLayers(ByRef pLayers As IArray, ByRef nMinElev As Double, ByRef nMaxElev As Double)

  On Error GoTo GetElevStatsFromTINLayers_ERR
  
  Dim pLayer As ILayer
  Dim nZMin As Double
  Dim nZMax As Double
  Dim zmin As Double
  Dim zmax As Double
  Dim i As Double
  Dim pTLayer As ITinLayer
  Dim pEnv As IEnvelope
  

'   for each TIN layer in array, check min and max Z values, and return values:
  For i = 0 To pLayers.Count - 1
      If TypeOf pLayers.Element(i) Is ITinLayer Then
          Set pTLayer = pLayers.Element(i)
          Set pEnv = pTLayer.Dataset.Extent
          nZMax = pEnv.zmax
          nZMin = pEnv.zmin
  
  '   first time, set the max and min to this:
          If i = 0 Then
              zmin = nZMin
              zmax = nZMax
          End If
          
          If nZMin <  zmin Then zmin = nZMin
          If nZMax >  zmax Then zmax = nZMax
      End If
  Next

'   set return values:
  nMinElev = zmin
  nMaxElev = zmax
  
  Exit Sub
  
GetElevStatsFromTINLayers_ERR:
  Debug.Assert 0
  Debug.Print "GetElevStatsFromTINLayers_ERR: " & Err.Description
  Resume Next
  
  
End Sub


'
'   based on the parameters for high and low values,
'   return an ITinColorRampRenderer
'
Private Function CreateTINEqualClassifyRenderer(nHighValue As Double, nLowValue As Double, nNumBreaks As Double) As ITinColorRampRenderer

  On Error GoTo CreateTINEqualClassifyRenderer_ERR

  Dim i As Double
  Dim d As Double, dInt As Double
  
  Dim pTinRender As ITinColorRampRenderer
  Set pTinRender = New TinElevationRenderer

'   divide the range by number of breaks to get the interval:
  d = nHighValue - nLowValue
  dInt = d / nNumBreaks
  
  With pTinRender
      
      .BreakCount = nNumBreaks
      .MinimumBreak = nLowValue
      .Break(0) = nLowValue + dInt
      .MinimumBreak = nLowValue
      
'   create breaks for each range:
      For i = 1 To .BreakCount - 1
          .Break(i) = .Break(i - 1) + dInt
      Next
      
  End With

  pTinRender.SortClassesAscending = True

'   return the ITinColorRampRenderer:
  Set CreateTINEqualClassifyRenderer = pTinRender
  
  Exit Function
  
CreateTINEqualClassifyRenderer_ERR:
  Debug.Assert 0
  Debug.Print "CreateRasterEqualClassifyRenderer_ERR: " & Err.Description
  Resume Next
  
End Function


'
'   apply designated color enumerator to renderer
'
Private Sub ApplyColorRampToClassifyRenderer(ByRef pR, ByRef pColorEnum As IEnumColors)

  On Error GoTo ApplyColorRampToTINRenderer_ERR
  
  Dim pSym As ISimpleFillSymbol
  Dim i As Double
  Dim pColor As IColor
  Dim pTRender As ITinColorRampRenderer
  Dim pC As IClassBreaksUIProperties

  pColorEnum.Reset
  
  If Not pColorEnum Is Nothing Then
      Set pTRender = New TinElevationRenderer
      Set pTRender = pR
      Set pSym = New SimpleFillSymbol
      Set pColor = pColorEnum.Next
      
'   do first symbol:
'   just in case there is no color:
      If pColor Is Nothing Then
          pColor.RGB = 0
      End If
          
      pSym.Color = pColor
      pTRender.Symbol(i) = pSym
      pTRender.Label(i) = CStr(Format(pTRender.MinimumBreak, "#####.00")) &  " - " &  CStr(Format(pTRender.Break(0), "#####.00"))
              
      Set pC = pTRender
      pC.LowBreak(0) = pTRender.MinimumBreak

'   For each break, add the corresponding color to the renderer:
      For i = 1 To pTRender.BreakCount - 1
          Set pSym = New SimpleFillSymbol
          Set pColor = pColorEnum.Next
          
  '   just in case there is no color:
          If pColor Is Nothing Then
      
              Set pColor = New RgbColor
              pColor.RGB = 0
          
          End If
          
          pSym.Color = pColor
          pTRender.Symbol(i) = pSym
          pTRender.Label(i) = CStr(Format(pTRender.Break(i - 1), "#####.00")) &  " - " &  CStr(Format(pTRender.Break(i), "#####.00"))
          
          pC.LowBreak(i) = pTRender.Break(i - 1)

      Next
  
  End If
  
  
  Exit Sub
  
ApplyColorRampToTINRenderer_ERR:
  Debug.Assert 0
  Debug.Print "ApplyColorRampToTINRenderer_ERR: " & Err.Description
  Resume Next
  

End Sub