📄 frm3dbase.frm
字号:
VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "comdlg32.ocx"
Object = "{99AA4EEF-16DB-41B9-8A9E-CACCD93FBD5D}#5.2#0"; "Super3D.ocx"
Object = "{03ED3B1E-ED1B-4A2E-8FE3-D8D1A673F5D4}#5.2#0"; "SuperMap.ocx"
Begin VB.Form frm3Dbase
Caption = "三维窗口"
ClientHeight = 7575
ClientLeft = 1185
ClientTop = 675
ClientWidth = 10335
Icon = "frm3Dbase.frx":0000
LinkTopic = "Form1"
LockControls = -1 'True
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 505
ScaleMode = 3 'Pixel
ScaleWidth = 689
Begin Super3DLib.Super3D Super3D1
Height = 6855
Left = 1080
TabIndex = 16
Top = 240
Width = 6975
_Version = 327682
_ExtentX = 12303
_ExtentY = 12091
_StockProps = 128
AltitudeField = ""
Texture = ""
ScaleZ = 1
End
Begin SuperMapLib.SuperWorkspace SuperWorkspace1
Left = 9000
Top = 3240
_Version = 327682
_ExtentX = 847
_ExtentY = 847
_StockProps = 0
End
Begin VB.Timer Timer1
Left = 8535
Top = 5460
End
Begin VB.CommandButton cmdRotate
Caption = "旋转"
Height = 612
Left = 240
Style = 1 'Graphical
TabIndex = 15
Top = 2400
Width = 612
End
Begin VB.CommandButton CmdZoomIn
Caption = "放大"
Height = 612
Left = 240
TabIndex = 14
Top = 960
Width = 612
End
Begin VB.CommandButton CmdZoomout
Caption = "缩小"
Height = 612
Left = 240
TabIndex = 13
Top = 1680
Width = 612
End
Begin VB.Timer Timer2
Left = 8640
Top = 6240
End
Begin VB.CommandButton CmdFlood
Caption = "水淹"
Height = 612
Left = 240
Style = 1 'Graphical
TabIndex = 12
Top = 5280
Width = 612
End
Begin VB.CommandButton CmdUnload
Caption = "退出"
Height = 612
Left = 240
TabIndex = 11
Top = 6600
Width = 612
End
Begin VB.CommandButton CmdPicture
Caption = "背景贴图"
Height = 612
Left = 240
TabIndex = 10
Top = 3840
Width = 612
End
Begin MSComDlg.CommonDialog Dlg
Left = 9000
Top = 6240
_ExtentX = 688
_ExtentY = 688
_Version = 393216
End
Begin VB.CommandButton Down
Caption = "下"
Height = 372
Left = 9720
TabIndex = 9
Top = 1200
Width = 372
End
Begin VB.CommandButton Up
Caption = "上"
Height = 372
Left = 9720
TabIndex = 8
Top = 120
Width = 372
End
Begin VB.CommandButton Path
Caption = "录制"
Height = 492
Left = 8880
Style = 1 'Graphical
TabIndex = 7
Top = 600
Width = 612
End
Begin VB.CommandButton Left
Appearance = 0 'Flat
Caption = "左"
Height = 492
Left = 8400
TabIndex = 6
Top = 600
Width = 492
End
Begin VB.CommandButton Right
Appearance = 0 'Flat
Caption = "右"
Height = 492
Left = 9480
TabIndex = 5
Top = 600
Width = 492
End
Begin VB.CommandButton Backward
Appearance = 0 'Flat
Caption = "后"
Height = 492
Left = 8880
TabIndex = 4
Top = 1080
Width = 612
End
Begin VB.CommandButton Forward
Appearance = 0 'Flat
Caption = "前"
Height = 492
Left = 8880
TabIndex = 3
Top = 120
Width = 612
End
Begin VB.CommandButton CmdOutput
Caption = "输出"
Height = 612
Left = 240
TabIndex = 2
Top = 4560
Width = 612
End
Begin VB.CommandButton CmdBackcolor
Caption = "背景色"
Height = 612
Left = 240
TabIndex = 1
Top = 3120
Width = 612
End
Begin VB.CommandButton CmdRestore
Caption = "连接"
Height = 612
Left = 240
TabIndex = 0
Top = 240
Width = 612
End
Begin VB.Shape Shape2
Height = 1452
Left = 8400
Top = 120
Width = 1692
End
Begin VB.Shape Shape1
Height = 7092
Left = 960
Top = 120
Width = 7212
End
End
Attribute VB_Name = "frm3Dbase"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'=====================================SuperMap Objects 示范工程说明=======================================
'
'功能简介：示范SuperMap Objects中三维的基本操作：三维的放大、缩小、平移、旋转、淹没、查询、有方向的运动等
'所用控件：Supermap控件，SuperWorkspace控件和Super3D控件
'所用数据：..\Data\3Dbase\dem.sdb和dem.sdd两个文件
'操作说明：
' 1、点击"连接"，打开三维图像
' 2、点击"放大"、"缩小"和"平移"按钮后，可以在窗口中操作三维图像
' 3、点击"旋转"，图像会自动旋转，此时按下"结束"，可以随时中止旋转
' 4、点击"水淹"，可以进行三维图像被水淹没的模拟
' 5、点击"复位"，可以把三维图像恢复为初始时的状态
' 6、点击右上侧的"前"、"后"等按钮，三维图像则做相应的移动
'
'===================================SuperMap Objects 示范工程说明结束=====================================
Dim iFlag As Integer
Dim objFlyPathViewPoint(1 To 100) As New soPoint3D
Dim iTag As Integer
Dim fWaterHeight As Single
Dim fDatasetHeight As Double
Private Sub Backward_Click() '后
Dim objPoint3D As soPoint3D
Super3D1.Camera.MoveRelative 0, 0, 200
Set objPoint3D = Super3D1.Camera.Position
'
' objPoint3D.Z = objPoint3D.Z - 200
' Set objCamera.Position = objPoint3D
Super3D1.Refresh
AddFlyPoint objPoint3D
End Sub
Private Sub CmdBackcolor_Click() '改变背景颜色
Dlg.ShowColor
Super3D1.BackColor = Dlg.Color
Super3D1.Refresh
End Sub
Private Sub CmdFlood_Click() '水淹模拟
If CmdFlood.Caption = "水淹" Then
Super3D1.FloodEnable = True
Timer2.Interval = 200
Timer2.Enabled = True
CmdFlood.Caption = "停止"
CmdFlood.BackColor = RGB(255, 0, 0)
Else
Super3D1.FloodEnable = False
Timer2.Interval = 0
Timer2.Enabled = False
CmdFlood.Caption = "水淹"
CmdFlood.BackColor = RGB(191, 191, 191)
Super3D1.Refresh
fWaterHeight = 0
End If
End Sub
Private Sub CmdOutput_Click() '输出3维图片
Dim filename As String
Dlg.InitDir = App.Path
Dlg.Filter = "(*.jpg)|*.jpg"
Dlg.filename = ""
Dlg.ShowSave
filename = Dlg.filename
Super3D1.OutputToFile filename
End Sub
Private Sub CmdPicture_Click() '改变背景贴图
Dim filename As String
Dlg.InitDir = App.Path
Dlg.Filter = "(*.bmp)|*.bmp"
Dlg.filename = ""
Dlg.ShowOpen
filename = Dlg.filename
Super3D1.BackGroundTexture = filename
Super3D1.Refresh
End Sub
Private Sub cmdRotate_Click() '旋转
Super3D1.Action = sca3DPanRotate
End Sub
Private Sub CmdRestore_Click() '复位
If CmdRestore.Caption = "连接" Then
Dim objDs As soDataSource
Dim objDt As soDataset
Set objDs = SuperWorkspace1.OpenDataSource(App.Path & "\..\Data\3Dbase\dem.sdb", "dem", sceSDBPlus, False)
If objDs Is Nothing Then
MsgBox "打开数据失败"
End
End If
Super3D1.Connect SuperWorkspace1.Handle
Set objDt = objDs.Datasets.Item("dem")
If (objDt Is Nothing) Or (objDt.Type <> scdDEM) Then
MsgBox "没有找到数据集，或者当前数据集不能做三维显示"
End
End If
Super3D1.Layer3Ds.AddDataset objDt, True
Super3D1.Refresh
CmdRestore.Caption = "复位"
fDatasetHeight = objDt.MaxZ
Else
CmdRestore.Caption = "复位"
Super3D1.RestoreScene
Super3D1.Refresh
End If
End Sub
Private Sub CmdUnload_Click() '退出
Unload Me
End Sub
Private Sub CmdZoomIn_Click() '放大
Super3D1.Action = sca3DZoomIn
End Sub
Private Sub CmdZoomout_Click() '缩小
Super3D1.Action = sca3DZoomOut
End Sub
Private Sub Down_Click() '下
Dim objPoint3D As soPoint3D
Super3D1.Camera.MoveRelative 0, -200, 0
Set objPoint3D = Super3D1.Camera.Position
'
' objPoint3D.Y = objPoint3D.Y - 200
' Set objCamera.Position = objPoint3D
'
Super3D1.Refresh
AddFlyPoint objPoint3D
End Sub
Private Sub Form_Load()
Path.Caption = "移动"
Path.BackColor = RGB(100, 100, 0)
fWaterHeight = 0
iFlag = 0
End Sub
Private Sub Form_Unload(Cancel As Integer)
If Timer1.Enabled = True Then Timer1.Enabled = False
If Timer2.Enabled = True Then Timer2.Enabled = False
Dim i As Integer
For i = 1 To 100
Set objFlyPathViewPoint(i) = Nothing
Next i
Super3D1.Close
Super3D1.Disconnect
SuperWorkspace1.Close
End Sub
Private Sub Path_Click() '录制及回放功能
iFlag = iFlag + 1
If iFlag > 3 Then
iFlag = 1
End If
If iFlag = 1 Then
Path.Caption = "移动"
Path.BackColor = RGB(100, 100, 0)
Super3D1.Action = sca3DPan
ElseIf iFlag = 2 Then '当iFlag=2时，设置为录制状态，程序中将记载飞行的各参数值
Path.Caption = "录制"
Path.BackColor = RGB(255, 0, 0)
iTag = 0
ElseIf iFlag = 3 Then
Path.Caption = "回放"
Path.BackColor = RGB(0, 255, 0)
Timer1.Interval = 500
Timer1.Enabled = True
End If
End Sub
Private Sub Forward_Click() '前
Dim objPoint3D As soPoint3D
Super3D1.Camera.MoveRelative 0, 0, -200
Set objPoint3D = Super3D1.Camera.Position
Super3D1.Refresh
AddFlyPoint objPoint3D
End Sub
Private Sub Left_Click() '左
Dim objPoint3D As soPoint3D
Super3D1.Camera.MoveRelative -200, 0, 0
Set objPoint3D = Super3D1.Camera.Position
'
' objPoint3D.X = objPoint3D.X - 200
' Set objCamera.Position = objPoint3D
'
Super3D1.Refresh
AddFlyPoint objPoint3D
End Sub
Private Sub Right_Click() '右
Dim objPoint3D As soPoint3D
Super3D1.Camera.MoveRelative 200, 0, 0
Set objPoint3D = Super3D1.Camera.Position
'
' objPoint3D.X = objPoint3D.X + 200
' Set objCamera.Position = objPoint3D
Super3D1.Refresh
AddFlyPoint objPoint3D
End Sub
Private Sub Timer1_Timer()
If iTag = 0 Then
Path.Caption = "移动"
Timer1.Enabled = False
iFlag = 0
Exit Sub
End If
Dim objCamera As soCamera
Dim objPoint3D As soPoint3D
Set objCamera = Super3D1.Camera
Set objPoint3D = objCamera.Position
Set objPoint3D = objFlyPathViewPoint(iTag)
Set objCamera.Position = objPoint3D
Super3D1.Refresh
iTag = iTag - 1
End Sub
Private Sub Timer2_Timer()
If fWaterHeight < fDatasetHeight Then
fWaterHeight = fWaterHeight + 50
Else
fWaterHeight = fWaterHeight
End If
Super3D1.Flood fWaterHeight
Super3D1.Refresh
End Sub
Private Sub Up_Click() '上
Dim objPoint3D As soPoint3D
Super3D1.Camera.MoveRelative 0, 200, 0
Set objPoint3D = Super3D1.Camera.Position
'
' objPoint3D.Y = objPoint3D.Y + 200
' Set objCamera.Position = objPoint3D
Super3D1.Refresh
AddFlyPoint objPoint3D
End Sub
Private Sub AddFlyPoint(objPoint3D As soPoint3D)
iTag = iTag + 1
objFlyPathViewPoint(iTag).X = objPoint3D.X
objFlyPathViewPoint(iTag).Y = objPoint3D.Y
objFlyPathViewPoint(iTag).Z = objPoint3D.Z
End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -