This function reads the extent information from any selected layers in the Table Of Contents in ArcScene, and adds a graphic representing the full 3D extent of these layers to the application.
The intent of this sample is to demonstrate how to query the extent information in a layer, how to construct a multipatch geometry from the extent coordinates, and how to add graphic elements to the application.
How to use
- Paste the code into an ArcScene VBA session and call the macro 'Add3DBoundingBoxForSelectedLayers'.
Option Explicit
'' Declare module level variables
Private m_SxDoc As ISxDocument
Private m_Scene As IScene
'' get the cumulative envelope\extent of each layer, and add as a graphic:
Public Sub Add3DBoundingBoxForSelectedLayers()
On Error GoTo AddExtentGraphicForSelectedLayers_ERR
' Set the variables
SetVariables
Dim pLayerArray As IArray
' return all selected layers:
Set pLayerArray = GetDocLayers(True)
If pLayerArray Is Nothing Then
MsgBox "Please select at least one layer in the Table of Contents", , "Add 3D Bounding Box"
Exit Sub
End If
Dim pLayer As ILayer
Dim pExtent As IEnvelope
Dim i As Integer
Dim pPoly As IPointCollection
Dim pPt As IPoint
Dim xMin As Double, xMax As Double
Dim yMin As Double, yMax As Double
Dim zMin As Double, zMax As Double
' set flag that the first extent needs to be noted:
Dim bStart As Boolean
bStart = True
' for each layer, ask the scenegraph for it's 3D extent:
For i = 0 To pLayerArray.Count - 1
Set pLayer = pLayerArray.Element(i)
Set pExtent = m_Scene.SceneGraph.OwnerExtent(pLayer, False)
' track the cumulative extent:
If pExtent.xMax > xMax Or bStart Then xMax = pExtent.xMax
If pExtent.xMin < xMin Or bStart Then xMin = pExtent.xMin
If pExtent.yMax > yMax Or bStart Then yMax = pExtent.yMax
If pExtent.yMin < yMin Or bStart Then yMin = pExtent.yMin
If pExtent.zMax > zMax Or bStart Then zMax = pExtent.zMax
If pExtent.zMin < zMin Or bStart Then zMin = pExtent.zMin
' only track if outside the currently stored envelope:
bStart = False
Next
' build a 3D flat polygon:
Set pPoly = New Polygon
Set pPt = New Point
' set the ZAware flag so the polygon can store Z's
Dim pZAware As IZAware
Set pZAware = pPoly
pZAware.ZAware = True
' add the points of the 'footprint':
Set pPt = New Point
pPt.X = xMin
pPt.Y = yMin
pPt.Z = zMin
pPoly.AddPoint pPt
Set pPt = New Point
pPt.X = xMin
pPt.Y = yMax
pPt.Z = zMin
pPoly.AddPoint pPt
Set pPt = New Point
pPt.X = xMax
pPt.Y = yMax
pPt.Z = zMin
pPoly.AddPoint pPt
Set pPt = New Point
pPt.X = xMax
pPt.Y = yMin
pPt.Z = zMin
pPoly.AddPoint pPt
'close the polygon geometry:
Dim pPolygon As IPolygon
Set pPolygon = pPoly
pPolygon.Close
' construct a multipatch from the footprint to the zMax height:
Dim pMultipatch As IMultiPatch
Set pMultipatch = New MultiPatch
Dim pMC As IConstructMultiPatch
Set pMC = pMultipatch
pMC.ConstructExtrudeAbsolute zMax, pPoly
' create a new 3D graphics layer, add our multipatch element to it,
' and set the transparancy so the bounding box does not hide the
' features inside of it:
Dim pGLayer As IGraphicsLayer
Set pGLayer = AddNew3DGraphicsLayer("layer bounding box")
Dim pLayerEffects As ILayerEffects
Set pLayerEffects = pGLayer
pLayerEffects.Transparency = 27
' finally, add the graphic element to the graphics layer:
AddGraphic pMultipatch, , , , , pGLayer
Exit Sub
AddExtentGraphicForSelectedLayers_ERR:
MsgBox "AddExtentGraphicForSelectedLayers_ERR: " & Err.Description
Debug.Assert 0
End Sub
' Set the variables
Private Sub SetVariables()
Set m_SxDoc = ThisDocument
Set m_Scene = m_SxDoc.Scene
End Sub
' Add graphic to passed application. App needs to be ArcMap or ArcScene. If ArcMap, the graphic
' is added to the BasicGraphicsLayer of the ActiveView FocusMap. If ArcScene, the graphic is
' added to the BasicGraphicsLayer of the scene, unless the graphics container is passed in.
Private Sub AddGraphic(pGeom As IGeometry, Optional pSym As ISymbol, Optional bAddToSelection As Boolean = False, _
Optional bRefresh As Boolean, Optional sElementName As String, _
Optional pGC3D As IGraphicsContainer3D)
On Error GoTo EH
If (pGeom.IsEmpty) Then
Exit Sub
End If
Dim pElemProps As IElementProperties
Dim pElement As IElement
Dim pFillElement As IFillShapeElement
Select Case pGeom.GeometryType
Case esriGeometryPoint
Set pElement = New MarkerElement
Dim pPointElement As IMarkerElement
Set pPointElement = pElement
If (Not pSym Is Nothing) Then
pPointElement.Symbol = pSym
Else
pPointElement.Symbol = GetDefaultSymbol(esriGeometryPoint)
End If
Case esriGeometryPolyline
Set pElement = New LineElement
Dim pLineElement As ILineElement
Set pLineElement = pElement
If (Not pSym Is Nothing) Then
pLineElement.Symbol = pSym
Else
pLineElement.Symbol = GetDefaultSymbol(esriGeometryPolyline)
End If
Case esriGeometryPolygon
Set pElement = New PolygonElement
Set pFillElement = pElement
If (Not pSym Is Nothing) Then
pFillElement.Symbol = pSym
Else
pFillElement.Symbol = GetDefaultSymbol(esriGeometryPolygon)
End If
Case esriGeometryMultiPatch
Set pElement = New MultiPatchElement
Set pFillElement = pElement
If (Not pSym Is Nothing) Then
pFillElement.Symbol = pSym
Else
pFillElement.Symbol = GetDefaultSymbol(esriGeometryMultiPatch)
End If
End Select
pElement.Geometry = pGeom
Dim pGLayer As IGraphicsLayer
Dim pGCon3D As IGraphicsContainer3D
If pGC3D Is Nothing Then
Set pGLayer = m_SxDoc.Scene.BasicGraphicsLayer
Set pGCon3D = pGLayer
Else
Set pGCon3D = pGC3D
End If
If Len(sElementName) > 0 Then
Set pElemProps = pElement
pElemProps.Name = sElementName
End If
pGCon3D.AddElement pElement
If bRefresh Then
m_Scene.SceneGraph.RefreshViewers
End If
Exit Sub
EH:
Debug.Print "AddGraphic_ERR: " & Err.Description
Debug.Assert 0
Resume Next
End Sub
'' given type of passed in IApplication and geometry type, return the default symbol
Private Function GetDefaultSymbol(eType As esriGeometryType) As ISymbol
On Error GoTo EH
Dim pDefaults As IBasicDocumentDefaultSymbols
Dim pSym As ISymbol
Set pDefaults = m_SxDoc
Select Case eType
Case esriGeometryPoint
Set pSym = pDefaults.MarkerSymbol
Case esriGeometryPolyline
Set pSym = pDefaults.LineSymbol
Case esriGeometryPolygon, esriGeometryMultiPatch
Set pSym = pDefaults.FillSymbol
End Select
Set GetDefaultSymbol = pSym
Exit Function
EH:
Debug.Print "GetDefaultSymbol_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 pTOC As IContentsView
Dim i As Integer
Dim m_Scene As IScene
Dim ppSet As ISet
Dim p
Dim pLayers As IArray
Dim pLayer As ILayer
On Error GoTo GetDocLayers_ERR
If Not bOnlySelected Then
Set pLayers = New esriSystem.Array
For i = 0 To m_Scene.LayerCount - 1
pLayers.Add m_Scene.Layer(i)
Next
Set GetDocLayers = pLayers
Exit Function
Else
Dim pSxTOC As ISxContentsView
Set pSxTOC = m_SxDoc.ContentsView(0)
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
If pLayers.Count > 0 Then
Set GetDocLayers = pLayers
End If
Exit Function
GetDocLayers_ERR:
Debug.Print "GetDocLayers_ERR: " & Err.Description
Debug.Assert 0
End Function
'' create a new named graphics layer and add to the document'
Private Function AddNew3DGraphicsLayer(Optional sName As String) As IGraphicsLayer
On Error Resume Next
Dim pGLayer As IGraphicsLayer
Set pGLayer = New GraphicsLayer3D
Dim pLayer As ILayer
Set pLayer = pGLayer
If Len(sName) < 1 Then
pLayer.Name = InputBox("Name of New Graphics Layer?", "Graphics Layer", "Graphics")
Else
pLayer.Name = sName
End If
m_SxDoc.AddLayer pGLayer
Set AddNew3DGraphicsLayer = pGLayer
End Function