basdddmodelpreviewer.bas

ArcEngine二次开发例子！三维场景显示！

Attribute VB_Name = "basDDDModelPreviewer"

' Copyright 1995-2005 ESRI

' All rights reserved under the copyright laws of the United States.

' You may freely redistribute and use this sample code, with or without modification.

' Disclaimer: THE SAMPLE CODE IS PROVIDED "AS IS" AND ANY EXPRESS OR IMPLIED 
' WARRANTIES, INCLUDING THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS 
' FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL ESRI OR 
' CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, 
' OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF 
' SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 
' INTERRUPTION) SUSTAINED BY YOU OR A THIRD PARTY, HOWEVER CAUSED AND ON ANY 
' THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT ARISING IN ANY 
' WAY OUT OF THE USE OF THIS SAMPLE CODE, EVEN IF ADVISED OF THE POSSIBILITY OF 
' SUCH DAMAGE.

' For additional information contact: Environmental Systems Research Institute, Inc.

' Attn: Contracts Dept.

' 380 New York Street

' Redlands, California, U.S.A. 92373 

' Email: [e-mail]


Option Explicit

Public pSymbols As Collection
Public pFileNames As Collection
Public bLargeViewerSize As Boolean
Public m_bNonEvent As Boolean

Public Sub Main()

  On Error GoTo eh
  Dim sFile As String
  sFile = Command
  If Right(sFile, 1) = Chr(34) And Left(sFile, 1) = Chr(34) Then
    sFile = Mid(sFile, 2, Len(sFile) - 2)
  End If
  
  Load frmPreviewModels
  frmPreviewModels.MousePointer = vbHourglass
  frmPreviewModels.Show
  
  If UCase(Right(sFile, 4)) = ".3DS" Or _
      UCase(Right(sFile, 4)) = ".FLT" Or _
      UCase(Right(sFile, 4)) = ".WRL" Then
    LoadModel sFile
  Else

    sFile = App.Path
    If Right(sFile, 1) <> "\" Then sFile = sFile & "\"
    sFile = sFile & "3D Model Viewer.mru"
    
    If Len(Dir(sFile)) > 0 Then
      If MsgBox("Load Most Recently Used list?", vbYesNoCancel, "3D Model Preview") = vbYes Then
        Dim i As Integer
        Dim lFileID As Long
        lFileID = FreeFile
        Open sFile For Input As lFileID
        m_bNonEvent = True
        Do While Not EOF(lFileID)
          Input #lFileID, sFile
          LoadModel sFile
        Loop
        Close lFileID
        frmPreviewModels.lstModels.ListIndex = frmPreviewModels.lstModels.ListCount - 1
        m_bNonEvent = False
        DisplaySymbol frmPreviewModels.lstModels.ListCount - 1
      End If
    End If
  End If
  frmPreviewModels.MousePointer = vbDefault
  
  Exit Sub
eh:
  frmPreviewModels.MousePointer = vbDefault
  frmPreviewModels.Show
End Sub

'
' from a file name, create and store an IMarker3DSymbol
'
Public Sub LoadModel(sFile As String)

  On Error GoTo LoadModel_ERR

  If Len(Dir(sFile)) < 1 Then Exit Sub
  
  frmPreviewModels.MousePointer = vbHourglass
  
  ' create new translator object:
  'Dim p3DFile As IMarker3DFile: Set p3DFile = New Marker3DFile
  Dim p3DFile As IImport3DFile: Set p3DFile = New Import3DFile
  p3DFile.CreateFromFile sFile  ' open the file
  
  ' create a new 3D marker symbol and set the geometry
  ' from what we found in the file:
  Dim pGeometry As IGeometry: Set pGeometry = p3DFile.Geometry
  Dim pMarker3DSymbol As IMarker3DSymbol: Set pMarker3DSymbol = New Marker3DSymbol
  Set pMarker3DSymbol.Shape = pGeometry
  
  ' create a new point at 0,0,0:
  Dim pLocation As IPoint: Set pLocation = New Point
  Dim pZAware As IZAware: Set pZAware = pLocation: pZAware.ZAware = True
  pLocation.X = 0: pLocation.Y = 0: pLocation.Z = 0
  
  ' create a new marker element:
  Dim pElement As IElement: Set pElement = New MarkerElement
  Dim pME As IMarkerElement: Set pME = pElement
  
  ' set the marker element symbol to the currently selected one:
  pME.Symbol = pMarker3DSymbol
  
  ' set the location (geometry) of the symbol:
  pElement.Geometry = pLocation
  
  ' add the symbol to the scene viewer:
  Dim pGLayer As IGraphicsLayer
  Dim pG As IGraphicsContainer3D
  
  ' when opening from MRU, set the boolean value so we don't
  ' have to waste time drawing each symbol until the last one:
  If Not m_bNonEvent = True Then
    Set pGLayer = frmPreviewModels.SV1.SceneGraph.Scene.BasicGraphicsLayer
    frmPreviewModels.SV1.SceneGraph.SetOwnerFaceCulling pGLayer, esriFaceCullingNone
    
    Set pG = pGLayer
    pG.DeleteAllElements
    
    pG.AddElement pElement
    frmPreviewModels.SV1.SceneGraph.RefreshViewers
  End If
  
  ' store both the symbol and the original file name (for dialog caption)
  ' in collections:
  If pSymbols Is Nothing Then Set pSymbols = New Collection
  
  If pFileNames Is Nothing Then Set pFileNames = New Collection
  
  pSymbols.Add pMarker3DSymbol
  pFileNames.Add sFile
  
  Dim sName As String: sName = GetFileName(sFile)
  
  Static bEventsWereOff As Boolean: bEventsWereOff = m_bNonEvent
  
  ' add the symbol name to the listbox, turning off events
  ' so as not to trigger a redraw of the symbol:
  m_bNonEvent = True
  frmPreviewModels.lstModels.AddItem sName
  frmPreviewModels.lstModels.ListIndex = frmPreviewModels.lstModels.ListCount - 1
  m_bNonEvent = bEventsWereOff
  frmPreviewModels.Caption = "3D Model Preview - " & sFile
  DoEvents
  frmPreviewModels.MousePointer = vbDefault
  
  Exit Sub
  
LoadModel_ERR:
  If Not m_bNonEvent Then MsgBox "Error loading model: " & sFile & vbCrLf & Err.Description
  frmPreviewModels.MousePointer = vbDefault
End Sub

Public Function GetFileName(ByVal sFilePath As String, Optional bNoExtension As Boolean) As String

  Dim i As Integer, iBeg As Integer
  Dim s As String, sName As String
  
  On Error GoTo GetFileName_ERR

  For i = Len(sFilePath) To 1 Step -1
    s = Mid(sFilePath, i, 1)
    ' stop when when you get first backslash (s="\"):
    If s = "\" Then Exit For
  Next i
  
  iBeg = i + 1
  
  sName = IIf((iBeg - 1 = Len(sFilePath)), Left(sFilePath, 1), Mid(sFilePath, iBeg))
  
  If bNoExtension Then
    If Len(sName) > 3 Then
      ' If there is an extension:
      If Mid(sName, Len(sName) - 3, 1) = "." Then
        If Len(sName) > 4 Then
          GetFileName = Mid(sName, 1, Len(sName) - 4)
        Else
          GetFileName = ""
        End If
      Else
          GetFileName = sName
      End If
    Else
    ' no extension- filename is only 3 characters:
      GetFileName = sName
    End If
  Else
    GetFileName = sName
  End If
  
Exit Function
    
GetFileName_ERR:
  Debug.Assert 0
  Debug.Print "GetFileName_ERR: " & Err.Description

End Function

'
' draw the symbol at the designated index from the collection
'
Public Sub DisplaySymbol(iIndex As Long)
  On Error GoTo DisplaySymbol_ERR

  If pSymbols Is Nothing Then Exit Sub
  
  ' if the index is invalid, clear the viewers and exit:
  If iIndex < 1 Or iIndex > pSymbols.Count Then
    frmPreviewModels.Caption = "3D Model Preview"
    frmPreviewModels.SV1.SceneGraph.RefreshViewers
    Exit Sub
  End If
  frmPreviewModels.MousePointer = vbHourglass
  
  Dim pMarker3DSymbol As IMarker3DSymbol
  Set pMarker3DSymbol = pSymbols.Item(iIndex)
  
  Dim pLocation As IPoint: Set pLocation = New Point
  Dim pZAware As IZAware: Set pZAware = pLocation: pZAware.ZAware = True
  pLocation.X = 0: pLocation.Y = 0: pLocation.Z = 0
  
  ' create a new marker element:
  Dim pElement As IElement: Set pElement = New MarkerElement
  Dim pME As IMarkerElement: Set pME = pElement
  
  ' set the marker element symbol to the currently selected one:
  pME.Symbol = pMarker3DSymbol
  
  ' set the location (geometry) of the symbol:
  pElement.Geometry = pLocation
  
  Dim pGLayer As IGraphicsLayer
  Set pGLayer = frmPreviewModels.SV1.SceneGraph.Scene.BasicGraphicsLayer
  frmPreviewModels.SV1.SceneGraph.SetOwnerFaceCulling pGLayer, esriFaceCullingNone
  
  Dim pG As IGraphicsContainer3D: Set pG = pGLayer
  pG.DeleteAllElements
  
  pG.AddElement pElement
  
  frmPreviewModels.SV1.SceneGraph.RefreshViewers
  frmPreviewModels.Caption = "3D Model Preview - " & pFileNames.Item(iIndex)
  frmPreviewModels.MousePointer = vbDefault
  
Exit Sub
  
DisplaySymbol_ERR:
  MsgBox "Error displaying symbol " & iIndex & vbCrLf & Err.Description
  frmPreviewModels.MousePointer = vbDefault
End Sub

'
' present a dialog to open supported model types, and load from that filename
'
Public Sub BrowseForSymbol()
  On Error GoTo BrowseForSymbol_ERR
  
  Dim sFile As String
  With frmPreviewModels.CD1
    .MaxFileSize = 32000
    .CancelError = True
    .Flags = cdlOFNAllowMultiselect
    .Filter = "3DS Files (*.3DS)|*.3ds|Open Flight Files (*.flt)|*.flt|VRML Files (*.wrl)|*.wrl"
    .ShowOpen
    sFile = .FileName

    Dim sDir As String
    Dim iBlank As Integer
    iBlank = InStr(1, sFile, " ", vbTextCompare)
    If iBlank < 1 Then
      LoadModel sFile
    Else
      m_bNonEvent = True
      sDir = Trim(Mid(sFile, 1, iBlank))
      If Right(sDir, 1) <> "\" Then sDir = sDir & "\"
      sFile = sFile & " "
      Dim iNextBlank As Integer
      Dim sName As String
      Dim bContinue As Boolean
      bContinue = True
      
      Do While bContinue
        iNextBlank = InStr(iBlank + 1, sFile, " ", vbTextCompare)
        If iNextBlank < 1 Then iNextBlank = Len(sFile)
        sName = Trim(Mid(sFile, iBlank + 1, iNextBlank - iBlank))
        LoadModel sDir & sName
        iBlank = iNextBlank
        iNextBlank = InStr(iBlank + 1, sFile, " ", vbTextCompare)
        If iNextBlank < 1 Then bContinue = False
      Loop
      m_bNonEvent = False
      DisplaySymbol frmPreviewModels.lstModels.ListCount - 1
    End If
  End With
  
  Exit Sub
  
BrowseForSymbol_ERR:
  If Err.Number = 32755 Then Exit Sub ' cancelled dialog
  MsgBox "Error browsing for symbol: " & vbCrLf & Err.Description
  
End Sub

Public Sub PopulateViewers(iModelIndex As Integer, pSVC As SceneViewerCtrl)
  If pSymbols Is Nothing Then Exit Sub
  
  Dim pMarker3DSymbol As IMarker3DSymbol
  Set pMarker3DSymbol = pSymbols.Item(iModelIndex)
  
  Dim pLocation As IPoint: Set pLocation = New Point
  Dim pZAware As IZAware: Set pZAware = pLocation: pZAware.ZAware = True
  pLocation.X = 0: pLocation.Y = 0: pLocation.Z = 0
  
  ' create a new marker element:
  Dim pElement As IElement: Set pElement = New MarkerElement
  Dim pME As IMarkerElement: Set pME = pElement
  
  ' set the marker element symbol to the currently selected one:
  pME.Symbol = pMarker3DSymbol
  
  ' set the location (geometry) of the symbol:
  pElement.Geometry = pLocation
  
  Dim pGLayer As IGraphicsLayer
  Set pGLayer = pSVC.SceneGraph.Scene.BasicGraphicsLayer
  pSVC.SceneGraph.SetOwnerFaceCulling pGLayer, esriFaceCullingNone
  
  Dim pG As IGraphicsContainer3D: Set pG = pGLayer
  pG.DeleteAllElements
  
  pG.AddElement pElement
  pSVC.SceneGraph.RefreshViewers
End Sub