frmmain.frm
来自「都是基于VB所做的程序集合,值得大家作为实践的参考资料.」· FRM 代码 · 共 303 行
FRM
303 行
VERSION 5.00
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "mscomctl.ocx"
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "Comdlg32.ocx"
Object = "{03ED3B1E-ED1B-4A2E-8FE3-D8D1A673F5D4}#5.2#0"; "SuperMap.ocx"
Begin VB.Form frmMain
BorderStyle = 3 'Fixed Dialog
Caption = "复制、追加数据集"
ClientHeight = 5535
ClientLeft = 45
ClientTop = 330
ClientWidth = 10005
Icon = "frmMain.frx":0000
LinkTopic = "Form1"
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 5535
ScaleWidth = 10005
StartUpPosition = 2 'CenterScreen
Begin SuperMapLib.SuperWorkspace SuperWorkspace1
Left = 4755
Top = 2520
_Version = 327682
_ExtentX = 847
_ExtentY = 847
_StockProps = 0
End
Begin SuperMapLib.SuperMap SuperMap1
Height = 4995
Left = 2625
TabIndex = 12
Top = 480
Width = 7305
_Version = 327682
_ExtentX = 12885
_ExtentY = 8811
_StockProps = 160
BorderStyle = 1
End
Begin VB.CommandButton btnClose
Caption = "退出"
Height = 375
Left = 9090
TabIndex = 11
Top = 30
Width = 870
End
Begin VB.CommandButton btnViewEntire
Caption = "全幅显示"
Height = 375
Left = 8190
TabIndex = 10
Top = 30
Width = 915
End
Begin VB.CommandButton btnZoomFree
Caption = "自由缩放"
Height = 375
Left = 7290
TabIndex = 9
Top = 30
Width = 915
End
Begin VB.CommandButton btnZoomOut
Caption = "缩小"
Height = 375
Left = 6735
TabIndex = 8
Top = 30
Width = 570
End
Begin VB.CommandButton btnZoomIn
Caption = "放大"
Height = 375
Left = 6180
TabIndex = 7
Top = 30
Width = 570
End
Begin VB.CommandButton btnPan
Caption = "漫游"
Height = 375
Left = 5625
TabIndex = 6
Top = 30
Width = 570
End
Begin VB.CommandButton btnSelect
Caption = "选择"
Height = 375
Left = 5070
TabIndex = 5
Top = 30
Width = 570
End
Begin VB.CommandButton btnLayerAdmini
Caption = "图层管理"
Height = 375
Left = 4170
TabIndex = 4
Top = 30
Width = 915
End
Begin VB.CommandButton btnLayerClear
Caption = "清空图层"
Height = 375
Left = 3270
TabIndex = 1
Top = 30
Width = 915
End
Begin VB.CommandButton btnCopyDt
Caption = "数据集复制"
Height = 375
Left = 2190
TabIndex = 3
Top = 30
Width = 1095
End
Begin VB.CommandButton btnAddDt
Caption = "数据集追加"
Height = 375
Left = 1110
TabIndex = 2
Top = 30
Width = 1095
End
Begin VB.CommandButton btnOpenDs
Caption = "打开数据源"
Height = 375
Left = 30
TabIndex = 0
Top = 30
Width = 1095
End
Begin MSComDlg.CommonDialog CommonDialog1
Left = 5205
Top = 3540
_ExtentX = 847
_ExtentY = 847
_Version = 393216
End
Begin MSComctlLib.TreeView tvwSpace
Height = 5025
Left = 60
TabIndex = 13
Top = 480
Width = 2520
_ExtentX = 4445
_ExtentY = 8864
_Version = 393217
Style = 7
Appearance = 1
End
End
Attribute VB_Name = "frmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'=====================================SuperMap Objects示范工程说明=======================================
'
'功能简介：示范数据集的复制功能、矢量数据集的追加功能
'所用控件：SuperMap控件和SuperWrokspace控件
'所用数据：..\Data\World目录下的World.sdb和World.sdd两个文件
'操作说明：
' 1.单击"打开数据源"按钮，打开一个数据源；
' 2.单击"数据追加"按钮，是从一个数据集的数据中追加到指定的数据集中；
' 3.单击"数据集复制"按钮，可以对数据源中的数据集进行复制；
' "数据集复制"是用源数据源的数据集创建新的数据集或复制到另一个数据源中；
' 4.本示例还增加了"图层控制"、"放大"、"缩小"、"漫游"、"全幅显示"等功能。
'===================================SuperMap Objects示范工程说明结束=====================================
Option Explicit
Private Sub btnClose_Click()
End
End Sub
Private Sub btnOpenDs_Click()
'打开数据源
Dim objDataSource As soDataSource '数据源变量
Dim strAlias As String '数据源别名变量
Dim objDt As soDataset '数据集变量
Dim strDataSourceName As String '数据源名称变量
Dim i As Integer '循环不安量
'初始化打开数据源对话框
With CommonDialog1
.Filter = "SuperMap文件(*.sdb)|*.sdb"
.InitDir = App.Path
.FileName = ""
.FilterIndex = 2
.ShowOpen
If .FileName = "" Then Exit Sub
strAlias = PathToName(.FileTitle)
strDataSourceName = .FileName
End With
'打开数据源
Set objDataSource = SuperWorkspace1.OpenDataSource(strDataSourceName, strAlias, sceSDBPlus, False)
If objDataSource Is Nothing Then
MsgBox "数据源打开失败！"
Exit Sub
End If
'添加数据源到tvwSpace浏览器
tvwSpace.Nodes.Add "工作空间", tvwChild, objDataSource.Alias, objDataSource.Alias
For i = 1 To objDataSource.Datasets.Count
tvwSpace.Nodes.Add objDataSource.Alias, tvwChild, , objDataSource.Datasets(i).Name
Next i
tvwSpace.Nodes(1).Expanded = True
End Sub
Private Sub btnAddDt_Click() '数据集追加
If SuperWorkspace1.Datasources.Count = 0 Then
MsgBox "当前工作空间中没有数据源"
Exit Sub
End If
frmAppendFromOther.Show vbModal, Me
End Sub
Private Sub btnCopyDt_Click() '数据集复制
If SuperWorkspace1.Datasources.Count = 0 Then
MsgBox "当前工作空间中没有数据源"
Exit Sub
End If
frmCopyDataset.Show vbModal, Me
End Sub
Private Sub btnLayerAdmini_Click() '图层管理
If SuperMap1.Layers.Count = 0 Then
MsgBox "对不起，图层窗口中没有图层", vbInformation
Exit Sub
Else
'显示图层管理对话框
frmLayerSet.Show vbModal, Me
End If
End Sub
Private Sub btnSelect_Click()
SuperMap1.Action = scaSelect '选择
End Sub
Private Sub btnPan_Click()
SuperMap1.Action = scaPan '漫游
End Sub
Private Sub btnZoomIn_Click()
SuperMap1.Action = scaZoomIn '放大
End Sub
Private Sub btnZoomOut_Click()
SuperMap1.Action = scaZoomOut '缩小
End Sub
Private Sub btnZoomFree_Click()
SuperMap1.Action = scaZoomFree '自由缩放
End Sub
Private Sub btnViewEntire_Click()
SuperMap1.ViewEntire '全幅显示
End Sub
Private Sub btnLayerClear_Click()
'清空图层
SuperMap1.Layers.RemoveAll
SuperMap1.Refresh
End Sub
Private Sub Form_Load()
SuperMap1.Connect SuperWorkspace1.Handle
tvwSpace.Nodes.Add , , "工作空间", "工作空间"
End Sub
Private Sub Form_Unload(Cancel As Integer)
SuperMap1.Close
SuperMap1.Disconnect
SuperWorkspace1.Close
End Sub
Private Sub tvwSpace_DblClick()
'添加数据集到当前SuperMap1控件上
Dim objDs As soDataSource
Dim objDt As soDataset
If tvwSpace.SelectedItem.Index = 1 Then Exit Sub
If tvwSpace.SelectedItem.Parent.Index = 1 Then Exit Sub
Set objDs = SuperWorkspace1.Datasources(tvwSpace.SelectedItem.Parent.Text)
If objDs Is Nothing Then Exit Sub
Set objDt = objDs.Datasets(tvwSpace.SelectedItem.Text)
If objDt Is Nothing Then Exit Sub
SuperMap1.Layers.AddDataset objDt, False
SuperMap1.ViewEntire
End Sub
⌨️ 快捷键说明
复制代码Ctrl + C
搜索代码Ctrl + F
全屏模式F11
增大字号Ctrl + =
减小字号Ctrl + -
显示快捷键?