Zoom To Selected Layers

Created:12/6/2001
Description:

This macro will set the extent of the current map or scene to the envelope represented by the collection of layers selected in the application's table of contents. The intent of this sample is to demonstrate programmatic interaction with the extents of layers, and the map or scene extent.

How to use:
  1. Copy and paste the following code into an ArcMap or ArcScene VBA session and call the macro 'ZoomToExtentOfSelectedLayers'.
'
' build a new extent from all selected layers and zoom into this
'
Public Sub ZoomToSelectedLayers()
  
  On Error GoTo ZoomToSelectedLayers_ERR
  
  Dim pLayerArray As IArray
  
' get the selected layers; exit if there are none:
  Set pLayerArray = GetDocLayers(True)
  If pLayerArray Is Nothing Then Exit Sub
  If pLayerArray.Count <  1 Then Exit Sub
  
  Dim pSxDoc As ISxDocument
  Dim pMxDoc As IMxDocument
  Dim i As Integer
  Dim pExtent As IEnvelope
  Dim pLayer As ILayer
  Dim pLayersExtent As IEnvelope

' instantiate extent variables:
  Set pExtent = New Envelope
  Set pLayersExtent = New Envelope
  
  Dim xMax As Double, xMin As Double, yMin As Double, yMax As Double
  Dim zmax As Double, zmin As Double
  Dim bInScene As Boolean
  Dim bInMap As Boolean
  Dim pScene As IScene
  
' check once to see if we are in ArcMap or ArcScene:
  bInScene = InScene
  bInMap = InMap
  
  
' set the new extent boundary to the first one:
  Set pLayer = pLayerArray.Element(0)
  With pLayer.AreaOfInterest
      xMin = .xMin
      xMax = .xMax
      yMin = .yMin
      yMax = .yMax
      
' need to ask the scenegraph for the z information:
      If bInScene Then
          Set pScene = GetScene()
          Set pExtent = pScene.SceneGraph.OwnerExtent(pLayer, False)
          zmax = pExtent.zmax
          zmin = pExtent.zmin
      End If
      
  End With
      
' iterate through each other selected layer and set new boundary coordinates
' if necessary:
  For i = 1 To pLayerArray.Count - 1
      Set pLayer = pLayerArray.Element(i)
      With pLayer.AreaOfInterest
          If .xMax >  xMax Then xMax = .xMax
          If .xMin <  xMin Then xMin = .xMin
          If .yMax >  yMax Then yMax = .yMax
          If .yMin >  yMin Then yMin = .yMin
      
          If bInScene Then
              Set pExtent = pScene.SceneGraph.OwnerExtent(pLayer, False)
              If pExtent.zmax >  zmax Then zmax = pExtent.zmax
              If pExtent.zmin <  zmin Then zmin = pExtent.zmin
          End If
          
      End With
  Next
     
  Dim pZAware As IZAware
  Set pZAware = pLayersExtent
  pZAware.ZAware = True
         
' set boundary of new extent from our variables:
  With pLayersExtent
      .xMin = xMin
      .xMax = xMax
      .yMin = yMin
      .yMax = yMax
      .zmin = zmin
      .zmax = zmax
  End With
  
' call the appropriate method for ArcScene or ArcMap:
  If bInScene Then
      Set pSxDoc = Application.Document
      
' set default minimum bounding box:
      pSxDoc.Scene.SceneGraph.ActiveViewer.Camera.SetDefaultsMBB pLayersExtent
      
  ElseIf bInMap Then
      Set pMxDoc = Application.Document

      Dim pDisplayTransform As IDisplayTransformation
  
' set the bisible bounds:
      Set pDisplayTransform = pMxDoc.ActiveView.ScreenDisplay.DisplayTransformation
      pDisplayTransform.VisibleBounds = pLayersExtent
      
  Else
      Exit Sub
  End If
  
' call a refresh:
  RefreshDocument
  
  Exit Sub
  
ZoomToSelectedLayers_ERR:
  Debug.Print "ZoomToSelectedLayers_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 IScene of the current app if it is found
'
Private Function GetScene() As IScene
On Error GoTo eh

  Dim pSxDoc As ISxDocument

  If Not TypeOf Application Is ISxApplication Then Exit Function
  
  Set pSxDoc = Application.Document
  Set GetScene = pSxDoc.Scene
  
  Exit Function
  
eh:

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 ArcMap
'
Private Function InMap() As Boolean
  
  On Error Resume Next
  If TypeOf Application Is IMxApplication Then
      InMap = True
  Else
      InMap = False
  End If
  

End Function


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