AE计算Tin的体积

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