📄 form1.frm
字号:
VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "comdlg32.ocx"
Object = "{257830F1-B11E-4360-A3B9-E2E9D72A50E3}#3.2#0"; "SuperMap.ocx"
Begin VB.Form Form1
Caption = "动态跟踪使用范例"
ClientHeight = 7275
ClientLeft = 60
ClientTop = 345
ClientWidth = 10620
LinkTopic = "Form1"
LockControls = -1 'True
MaxButton = 0 'False
ScaleHeight = 7275
ScaleWidth = 10620
StartUpPosition = 2 'CenterScreen
Begin VB.Frame Frame1
Height = 510
Left = 5385
TabIndex = 9
Top = -90
Width = 5175
Begin VB.ComboBox cmbField
Height = 315
Left = 3525
Style = 2 'Dropdown List
TabIndex = 14
Top = 150
Width = 1560
End
Begin VB.ComboBox cmbLayer
Height = 315
Left = 1305
Style = 2 'Dropdown List
TabIndex = 13
Top = 150
Width = 1650
End
Begin VB.CheckBox Check1
Caption = "跟踪"
Height = 270
Left = 135
TabIndex = 12
Top = 180
Width = 720
End
Begin VB.Label Label3
Caption = "属性"
Height = 210
Left = 3090
TabIndex = 11
Top = 210
Width = 480
End
Begin VB.Label Label1
Caption = "图层"
Height = 210
Left = 855
TabIndex = 10
Top = 210
Width = 495
End
End
Begin MSComDlg.CommonDialog CommonDialog1
Left = 240
Top = 6420
_ExtentX = 847
_ExtentY = 847
_Version = 393216
End
Begin SuperMapLib.SuperWorkspace SuperWorkspace1
Left = 1425
Top = 6180
_Version = 196610
_ExtentX = 847
_ExtentY = 847
_StockProps = 0
End
Begin VB.CommandButton btnSelect
Caption = "选择"
Height = 375
Left = 45
TabIndex = 7
Top = 30
Width = 885
End
Begin VB.CommandButton btnPan
Caption = "漫游"
Height = 375
Left = 930
TabIndex = 6
Top = 30
Width = 885
End
Begin VB.CommandButton btnZoomIn
Caption = "放大"
Height = 375
Left = 1815
TabIndex = 5
Top = 30
Width = 885
End
Begin VB.CommandButton btnZoomOut
Caption = "缩小"
Height = 375
Left = 2700
TabIndex = 4
Top = 30
Width = 885
End
Begin VB.CommandButton btnZoomFree
Caption = "自由缩放"
Height = 375
Left = 3600
TabIndex = 3
Top = 30
Width = 885
End
Begin VB.CommandButton btnViewEntire
Caption = "全幅显示"
Height = 375
Left = 4470
TabIndex = 2
Top = 30
Width = 885
End
Begin VB.Timer Timer1
Left = 945
Top = 6195
End
Begin VB.PictureBox Picture2
Appearance = 0 'Flat
AutoSize = -1 'True
BackColor = &H00FFFFFF&
ForeColor = &H80000008&
Height = 220
Left = 120
ScaleHeight = 195
ScaleWidth = 705
TabIndex = 0
Top = 6240
Width = 735
Begin VB.Label Label2
AutoSize = -1 'True
BackColor = &H80000018&
Caption = "Label2"
Height = 180
Left = 90
TabIndex = 1
Top = 0
Width = 540
End
End
Begin SuperMapLib.SuperMap SuperMap1
Height = 3855
Left = 30
TabIndex = 8
Top = 450
Width = 3285
_Version = 196610
_ExtentX = 5794
_ExtentY = 6800
_StockProps = 160
Appearance = 1
End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'=====================================SuperMap Objects示范工程说明=======================================
'
'功能简介：示范是用来跟踪显示目标的一个属性，并可以随时改变跟踪的对象
'所用控件：SueprMap控件、SuperWorkspace控件和SuperLegend控件
'所用数据：..\Data\World.sdb和World.sdd两个文件
'操作说明：
' 1、使用"选择"、"漫游"、"放大"、"缩小"、"自由缩放"和"全幅显示"等按钮可以对地图进行操作。
' 2、当选择"自动跟踪"复选框，在"图层"列表中选择要跟踪的图层，在"属性"列表中选择要跟踪的属性，
' 就可以在地图窗口中进行跟踪显示相应的属性。
'
'===================================SuperMap Objects示范工程说明结束=====================================
Option Explicit
Dim objMapTip As New clsMapTip '自动跟踪类模块定义
Private Sub Check1_Click()
Dim objLayer As soLayer
Dim objDtV As soDatasetVector
Dim Fldn As Integer
If SuperMap1.Layers.Count < 1 Then Exit Sub
If Check1.Value = 1 Then '开始Tip
'把地图中的图层加载到列表中
For Each objLayer In SuperMap1.Layers
cmbLayer.AddItem objLayer.Name
Next objLayer
cmbLayer.ListIndex = cmbLayer.ListCount - 1
Else '停止Tip
cmbLayer.Clear
cmbField.Clear
Picture2.Visible = False
End If
objMapTip.Tracking = Check1.Value
Set objLayer = Nothing
Set objDtV = Nothing
End Sub
'改变显示Tip的图层
Private Sub cmbLayer_Click()
Dim objLayer As soLayer
Dim objDtV As soDatasetVector
Dim Fldn As Integer
If Check1.Value = False Then Exit Sub
'把选中的图层的属性表中的字段加载到列表中
cmbField.Clear
Set objLayer = SuperMap1.Layers(cmbLayer.List(cmbLayer.ListIndex))
Set objDtV = objLayer.Dataset
For Fldn = 1 To objDtV.FieldCount
cmbField.AddItem objDtV.GetFieldInfo(Fldn).Name
Next Fldn
cmbField.ListIndex = 0 '默认为第一个字段
objMapTip.SetLayer SuperMap1.Layers(cmbLayer.text), cmbField.text '更改字段设置
Set objLayer = Nothing
Set objDtV = Nothing
End Sub
'改变显示Tip的字段
Private Sub cmbField_Click()
If cmbField.text <> "" Then
objMapTip.SetLayer SuperMap1.Layers(cmbLayer.text), cmbField.text '更改图层设置
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 Form_Load()
Dim strAlias As String '数据源别名
Dim nEngineType As seEngineType '数据引擎类型
Dim strDataSourceName As String '数据源绝对路径名
Dim objDataSource As soDataSource '数据源对象,指向打开的数据源
Dim objLayer As soLayer '图层对象变量,指向将要打开的图层
Dim i As Integer '循环变量
strAlias = "World" '原则上别名可以任意给,建议取成和数据源文件主名
nEngineType = sceSDB 'SuperMap支持多种类型，此处为SDB类型
strDataSourceName = App.Path & "\..\Data\world.sdb"
SuperMap1.Connect SuperWorkspace1.Object
'打开数据源
Set objDataSource = SuperWorkspace1.OpenDataSource(strDataSourceName, strAlias, nEngineType, True)
If objDataSource Is Nothing Then
MsgBox "打开数据源失败！", vbInformation
Else
'把数据源中的所有图层加入到SuperMap中
Set objLayer = SuperMap1.Layers.AddDataset(objDataSource.Datasets("Grid"), True)
Set objLayer = SuperMap1.Layers.AddDataset(objDataSource.Datasets("world"), True)
End If
SuperMap1.Refresh
objMapTip.Initialize Form1, SuperMap1, Timer1, Picture2, Label2
If SuperMap1.Layers.Count <= 0 Then Exit Sub
'释放内存
Set objDataSource = Nothing
Set objLayer = Nothing
End Sub
'改变窗口尺寸
Private Sub Form_Resize()
On Error Resume Next
SuperMap1.Height = Form1.ScaleHeight - SuperMap1.Top - 20
SuperMap1.Width = Form1.ScaleWidth - SuperMap1.Left * 2
End Sub
'退出程序
Private Sub Form_Unload(Cancel As Integer)
SuperMap1.Close
SuperMap1.Disconnect
SuperWorkspace1.Close
End Sub
Private Sub SuperMap1_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
objMapTip.MouseMove x, y '跟踪并显示Tip
End Sub
Private Sub Timer1_Timer()
objMapTip.Timer
End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -