📄 frmpreviewmodels.frm
字号:
VERSION 5.00
Object = "{03485A85-59D0-11D3-8172-0080C7597E71}#1.0#0"; "SceneViewer.ocx"
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "comdlg32.ocx"
Begin VB.Form frmPreviewModels
Caption = "3D Model Preview"
ClientHeight = 6180
ClientLeft = 45
ClientTop = 330
ClientWidth = 10800
LinkTopic = "Form1"
ScaleHeight = 6516.327
ScaleMode = 0 'User
ScaleWidth = 10909.09
StartUpPosition = 3 'Windows Default
Begin esriSceneViewerCtrlCtl.SceneViewerCtrl SVC
Height = 948
Index = 4
Left = 2376
TabIndex = 10
Top = 4608
Width = 990
_Version = 1
_ExtentX = 1746
_ExtentY = 1672
_StockProps = 197
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "MS Sans Serif"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
TheCaption = "Scene view"
DocName = ""
FastPrinting = -1 'True
OverrideBackColor= 0 'False
GestureEnabled = 0 'False
GestureSensitivity= 6
MousePointer = 0
End
Begin esriSceneViewerCtrlCtl.SceneViewerCtrl SVC
Height = 948
Index = 3
Left = 2376
TabIndex = 9
Top = 3564
Width = 990
_Version = 1
_ExtentX = 1757
_ExtentY = 1672
_StockProps = 197
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "MS Sans Serif"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
TheCaption = "Scene view"
DocName = ""
FastPrinting = -1 'True
OverrideBackColor= 0 'False
GestureEnabled = 0 'False
GestureSensitivity= 6
MousePointer = 0
End
Begin esriSceneViewerCtrlCtl.SceneViewerCtrl SVC
Height = 948
Index = 2
Left = 2376
TabIndex = 8
Top = 2520
Width = 990
_Version = 1
_ExtentX = 1757
_ExtentY = 1672
_StockProps = 197
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "MS Sans Serif"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
TheCaption = "Scene view"
DocName = ""
FastPrinting = -1 'True
OverrideBackColor= 0 'False
GestureEnabled = 0 'False
GestureSensitivity= 6
MousePointer = 0
End
Begin esriSceneViewerCtrlCtl.SceneViewerCtrl SVC
Height = 948
Index = 1
Left = 2376
TabIndex = 7
Top = 1476
Width = 990
_Version = 1
_ExtentX = 1757
_ExtentY = 1672
_StockProps = 197
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "MS Sans Serif"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
TheCaption = "Scene view"
DocName = ""
FastPrinting = -1 'True
OverrideBackColor= 0 'False
GestureEnabled = 0 'False
GestureSensitivity= 6
MousePointer = 0
End
Begin esriSceneViewerCtrlCtl.SceneViewerCtrl SVC
Height = 948
Index = 0
Left = 2376
TabIndex = 6
Top = 432
Width = 990
_Version = 1
_ExtentX = 1757
_ExtentY = 1672
_StockProps = 197
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "MS Sans Serif"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
TheCaption = "Scene view"
DocName = ""
FastPrinting = -1 'True
OverrideBackColor= 0 'False
GestureEnabled = 0 'False
GestureSensitivity= 6
MousePointer = 0
End
Begin VB.CommandButton cmdRemoveAll
Caption = "Clear"
Height = 288
Left = 72
TabIndex = 5
Top = 5760
Width = 2184
End
Begin MSComDlg.CommonDialog CD1
Left = 9756
Top = 36
_ExtentX = 688
_ExtentY = 688
_Version = 393216
End
Begin VB.Frame Frame1
Height = 5304
Left = 3492
TabIndex = 3
Top = 324
Width = 7224
Begin esriSceneViewerCtrlCtl.SceneViewerCtrl SV1
Height = 5000
Left = 108
TabIndex = 4
Top = 180
Width = 7000
_Version = 1
_ExtentX = 12347
_ExtentY = 8826
_StockProps = 197
BackColor = -2147483643
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "MS Sans Serif"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
TheCaption = "Scene view"
DocName = ""
FastPrinting = -1 'True
OverrideBackColor= 0 'False
GestureEnabled = 0 'False
GestureSensitivity= 6
MousePointer = 0
End
End
Begin VB.CommandButton cmdCancel
Cancel = -1 'True
Caption = "&OK"
Default = -1 'True
Height = 324
Left = 9936
TabIndex = 2
Top = 5760
Width = 780
End
Begin VB.ListBox lstModels
Height = 5130
ItemData = "frmPreviewModels.frx":0000
Left = 72
List = "frmPreviewModels.frx":0007
OLEDropMode = 1 'Manual
TabIndex = 0
Top = 360
Width = 2196
End
Begin VB.Label Label1
Caption = "Drag && Drop or browse to add 3D models to the list. Double-click entry or small viewer to see model in larger viewer."
Height = 252
Left = 48
TabIndex = 1
Top = 72
Width = 8424
End
End
Attribute VB_Name = "frmPreviewModels"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
' 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: contracts@esri.com
Option Explicit
Private Sub cmdCancel_Click()
Unload Me
End Sub
'
' remove all models from the list
'
Private Sub cmdRemoveAll_Click()
On Error Resume Next
Dim i As Integer
For i = 1 To lstModels.ListCount
pSymbols.Remove i
Me.lstModels.RemoveItem i
pFileNames.Remove i
Dim pGLayer As IGraphicsContainer3D: Set pGLayer = Me.SV1.SceneGraph.Scene.BasicGraphicsLayer
pGLayer.DeleteAllElements
DisplaySymbol -1
Next i
'clean up smaller viewers:
Dim j As Integer
For j = 0 To 4
SVC(j).SceneGraph.Scene.ClearLayers
SVC(j).SceneGraph.ActiveViewer.Redraw True
Next j
End Sub
Private Sub Form_Load()
bLargeViewerSize = False
'display in 5 smaller viewers:
Dim i As Integer
For i = 0 To 4
PopulateViewers lstModels.ListIndex + i, SVC(i)
Next i
End Sub
Private Sub Form_Resize()
On Error Resume Next
If Me.Width < 4000 Then
Me.Width = 4000
Exit Sub
ElseIf Me.Height < 4000 Then
Me.Height = 4000
Exit Sub
End If
With Me
.lstModels.Height = .Frame1.Height
.cmdCancel.Top = .Frame1.Top + .Frame1.Height + 150
.cmdCancel.Left = .Width - .cmdCancel.Width - 200
.cmdRemoveAll.Top = .cmdCancel.Top
.SV1.SceneGraph.RefreshViewers
End With
End Sub
'
' write a most recently used text file in the app directory
' to read on startup
'
Private Sub Form_Unload(Cancel As Integer)
On Error Resume Next
If Not pFileNames Is Nothing Then
If MsgBox("Write Most Recently Used List?", vbYesNoCancel, "3D Model Preview") = vbYes Then
Dim sFile As String
sFile = App.Path
If Right(sFile, 1) <> "\" Then sFile = sFile & "\"
sFile = sFile & "3D Model Viewer.mru"
Dim i As Integer
Dim lFileID As Long
lFileID = FreeFile
Open sFile For Output As lFileID
For i = 1 To pFileNames.Count
Print #lFileID, pFileNames.Item(i)
Next
Close lFileID
End If
End If
Set pSymbols = Nothing
Set pFileNames = Nothing
End Sub
'
' display the symbol at the designated index
'
Private Sub lstModels_Click()
On Error Resume Next
If m_bNonEvent Then Exit Sub
If lstModels.ListIndex > 0 Then
DisplaySymbol lstModels.ListIndex
'display in 5 smaller viewers:
Dim i As Integer
For i = 0 To 4
PopulateViewers lstModels.ListIndex + i, SVC(i)
SVC(i).Tag = CStr(lstModels.ListIndex + i)
Next i
End If
End Sub
'
' open dialog to browse for symbols
'
Private Sub lstModels_DblClick()
On Error Resume Next
If Me.lstModels.ListIndex = 0 Then
BrowseForSymbol
End If
End Sub
'
' process delete key to remove a single model
'
Private Sub lstModels_KeyDown(KeyCode As Integer, Shift As Integer)
On Error Resume Next
If lstModels.ListIndex < 1 Then Exit Sub
If KeyCode = vbKeyDelete Then
Dim i As Integer
i = lstModels.ListIndex
pSymbols.Remove i
Me.lstModels.RemoveItem i
pFileNames.Remove i
Dim pGLayer As IGraphicsContainer3D
Set pGLayer = Me.SV1.SceneGraph.Scene.BasicGraphicsLayer
pGLayer.DeleteAllElements
DisplaySymbol CLng(i - 1)
End If
End Sub
'
' allow for drag and drop of file names as input
'
Private Sub lstModels_OLEDragDrop(Data As DataObject, _
Effect As Long, _
Button As Integer, _
Shift As Integer, _
X As Single, _
Y As Single)
On Error Resume Next
Dim sFile As String
Dim i As Integer
Me.MousePointer = vbHourglass
m_bNonEvent = True
For i = 1 To Data.Files.Count
sFile = Data.Files(i)
If UCase(Right(sFile, 4)) = ".3DS" Or _
UCase(Right(sFile, 4)) = ".FLT" Or _
UCase(Right(sFile, 4)) = ".WRL" Then LoadModel sFile
Next i
m_bNonEvent = False
DisplaySymbol Me.lstModels.ListIndex
Me.MousePointer = vbDefault
End Sub
Private Sub SV1_OnLButtonDblClk(ByVal xPos As Integer, ByVal yPos As Integer, ByVal keyFlags As Integer)
If bLargeViewerSize Then
SV1.Width = 7500
SV1.Height = 5000
Else
SV1.Width = 2000
SV1.Height = 2000
End If
bLargeViewerSize = Not bLargeViewerSize
End Sub
Private Sub SVC_OnLButtonDblClk(Index As Integer, ByVal xPos As Integer, ByVal yPos As Integer, ByVal keyFlags As Integer)
DisplaySymbol CLng(SVC(Index).Tag)
End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -