📄 frmmain.frm
字号:
VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "Comdlg32.ocx"
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCTL.OCX"
Object = "{03ED3B1E-ED1B-4A2E-8FE3-D8D1A673F5D4}#5.2#0"; "SuperMap.ocx"
Begin VB.Form frmMain
BorderStyle = 3 'Fixed Dialog
Caption = "属性查询"
ClientHeight = 6225
ClientLeft = 45
ClientTop = 330
ClientWidth = 9135
Icon = "frmMain.frx":0000
LinkTopic = "Form1"
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 6225
ScaleWidth = 9135
StartUpPosition = 2 'CenterScreen
Begin SuperMapLib.SuperMap SuperMap1
Height = 5625
Left = 60
TabIndex = 11
Top = 555
Width = 6315
_Version = 327682
_ExtentX = 11139
_ExtentY = 9922
_StockProps = 160
Appearance = 1
End
Begin SuperMapLib.SuperWorkspace SuperWorkspace1
Left = 4740
Top = 1500
_Version = 327682
_ExtentX = 847
_ExtentY = 847
_StockProps = 0
End
Begin MSComDlg.CommonDialog CommonDialog1
Left = 6135
Top = 5640
_ExtentX = 847
_ExtentY = 847
_Version = 393216
End
Begin VB.ComboBox cmbLayer
Height = 315
Left = 7320
Style = 2 'Dropdown List
TabIndex = 9
Top = 555
Width = 1755
End
Begin VB.CommandButton btnViwEntire
Caption = "全幅显示"
Height = 465
Left = 6795
TabIndex = 8
Top = 30
Width = 1125
End
Begin VB.CommandButton btnZoomFree
Caption = "自由缩放"
Height = 465
Left = 5670
TabIndex = 7
Top = 30
Width = 1125
End
Begin VB.CommandButton btnSelect
Caption = "选择"
Height = 465
Left = 45
TabIndex = 6
Top = 30
Width = 1125
End
Begin MSComctlLib.ListView lvwPro
Height = 5205
Left = 6405
TabIndex = 5
Top = 975
Width = 2685
_ExtentX = 4736
_ExtentY = 9181
View = 3
LabelEdit = 1
LabelWrap = -1 'True
HideSelection = 0 'False
GridLines = -1 'True
_Version = 393217
ForeColor = -2147483640
BackColor = -2147483643
BorderStyle = 1
Appearance = 1
NumItems = 2
BeginProperty ColumnHeader(1) {BDD1F052-858B-11D1-B16A-00C0F0283628}
Text = "字段名"
Object.Width = 2117
EndProperty
BeginProperty ColumnHeader(2) {BDD1F052-858B-11D1-B16A-00C0F0283628}
SubItemIndex = 1
Text = "字段值"
Object.Width = 2540
EndProperty
End
Begin VB.CommandButton cmdOption
Caption = "最后一个"
Height = 465
Index = 4
Left = 4545
TabIndex = 4
Top = 30
Width = 1125
End
Begin VB.CommandButton cmdOption
Caption = "下一个"
Height = 465
Index = 3
Left = 3420
TabIndex = 3
Top = 30
Width = 1125
End
Begin VB.CommandButton cmdOption
Caption = "上一个"
Height = 465
Index = 2
Left = 2310
TabIndex = 2
Top = 30
Width = 1125
End
Begin VB.CommandButton cmdOption
Caption = "第一个"
Height = 465
Index = 1
Left = 1170
TabIndex = 1
Top = 30
Width = 1125
End
Begin VB.CommandButton cmdOption
Caption = "关闭"
Height = 465
Index = 0
Left = 7920
TabIndex = 0
Top = 30
Width = 1125
End
Begin VB.Label Label1
Caption = "当前图层"
Height = 240
Left = 6435
TabIndex = 10
Top = 615
Width = 870
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控件和SuperWorkspace控件
'所用数据：..\Data\World\下的World.sdb和World.sdd
'操作说明：
' 1、单击"选择"按钮，在地图窗口中选择一个对象，可以查询它的所有属性。
' 2、单击"第一个"、"上一个"、"下一个"、"最后一个"等按钮，可以依次浏览"当前图层"中的每一个对象的属性。
'
'===================================SuperMap Objects 示范工程说明结束=====================================
Dim objLayerMove As soLayer
Dim objDataMove As soDatasetVector
Dim objRecMove As soRecordset
Dim iRec As Integer
Private Sub RecChange(objdata As soDatasetVector, objRechage As soRecordset)
If objRechage Is Nothing Or objRechage.RecordCount < 1 Then
Exit Sub
End If
lvwPro.ListItems.Clear
Dim fldNumber As Integer
For fldNumber = 1 To objRechage.FieldCount
lvwPro.ListItems.Add , , objRechage.GetFieldInfo(fldNumber).Name
If IsNull(objRechage.GetFieldValue(fldNumber)) = False Then
lvwPro.ListItems(lvwPro.ListItems.Count).SubItems(1) = objRechage.GetFieldValue(fldNumber)
End If
Next fldNumber
End Sub
Private Sub btnSelect_Click()
SuperMap1.Action = scaSelect
End Sub
Private Sub btnViwEntire_Click()
SuperMap1.ViewEntire
End Sub
Private Sub btnZoomFree_Click()
SuperMap1.Action = scaZoomFree
End Sub
Private Sub cmbLayer_Click()
Dim objdata As soDatasetVector
Set objLayerMove = SuperMap1.Layers(cmbLayer.Text)
If objLayerMove Is Nothing Then Exit Sub
Set objdata = objLayerMove.Dataset
Set objRecMove = objdata.Query("", True)
objRecMove.MoveFirst
cmdOption(2).Enabled = False
If objRecMove.RecordCount <= 1 Then
cmdOption(3).Enabled = False
Else
cmdOption(3).Enabled = True
End If
iRec = 1
End Sub
'切换当前所选择图层数据集的记录
Private Sub cmdOption_Click(Index As Integer)
Dim objlayer As soLayer
Dim objDataset As soDatasetVector
If Index = 0 Then
Unload Me
End If
If objRecMove Is Nothing Then Exit Sub
If iRec <= 1 Then
cmdOption(2).Enabled = False '不可以movepreview操作
Else
cmdOption(2).Enabled = True '可以Movepreview操作
End If
If iRec >= objRecMove.RecordCount Then
cmdOption(3).Enabled = False '不可以Movenext操作
Else
cmdOption(3).Enabled = True '可以MoveNext操作
End If
'移动记录
Select Case Index
Case 1
objRecMove.MoveFirst '第一条记录
iRec = 1
Case 2
objRecMove.MovePrev '上一条记录
iRec = iRec - 1
Case 3
objRecMove.MoveNext '下一条记录
iRec = iRec + 1
Case 4
objRecMove.MoveLast '最后一条记录
iRec = objRecMove.RecordCount
End Select
'让当前记录高亮显示在SuperMap窗口
Set objlayer = SuperMap1.Layers(cmbLayer.List(cmbLayer.ListIndex))
If objlayer Is Nothing Then Exit Sub
Set objDataset = objlayer.Dataset
Set SuperMap1.selection.Dataset = objDataset
SuperMap1.selection.RemoveAll
SuperMap1.selection.Add objRecMove.GetID
'居中显示当前记录的对象
Dim Obj As soGeometry
Set Obj = objRecMove.GetGeometry()
If Not Obj Is Nothing Then
SuperMap1.EnsureVisibleGeometry Obj, 1
End If
SuperMap1.Refresh
If iRec <= 1 Then
cmdOption(2).Enabled = False
Else
cmdOption(2).Enabled = True
End If
If iRec >= objRecMove.RecordCount Then
cmdOption(3).Enabled = False
Else
cmdOption(3).Enabled = True
End If
RecChange objDataMove, objRecMove
End Sub
Private Sub Form_Load()
Dim strAlias As String '数据源别名
Dim nEngineType As seEngineType '数据引擎类型
Dim strDataSourceName As String '数据源绝对路径名
Dim objDataSource As soDataSource '数据源对象,指向打开的数据源
Dim objDataset As soDataset
Dim bReadOnly As Boolean '数据源里的数据是否只读
Dim objlayer As soLayer '图层对象变量,指向将要打开的图层
Dim bAddToHead As Boolean '是否加到最上面
Dim i As Integer '循环变量
SuperMap1.Connect SuperWorkspace1.Object
SuperMap1.MarginPanEnable = False
strAlias = "World" '原则上别名可以任意给,建议取成和数据源文件主名
nEngineType = sceSDBPlus 'SuperMap支持多种类型，此处为SDBPlus类型
strDataSourceName = App.Path & "\..\Data\World\World.sdb"
strAlias = "world"
bReadOnly = True
'打开数据源
Set objDataSource = SuperWorkspace1.OpenDataSource(strDataSourceName, strAlias, nEngineType, bReadOnly)
If objDataSource Is Nothing Then
MsgBox "打开数据源失败！", vbInformation
Else
'把数据源中的所有图层加入到SuperMap中
bAddToHead = True
Set objDataset = objDataSource.Datasets.Item("ocean")
If Not objDataset Is Nothing Then
Set objlayer = SuperMap1.Layers.AddDataset(objDataset, bAddToHead)
cmbLayer.AddItem objlayer.Name
End If
Set objDataset = objDataSource.Datasets.Item("grid")
If Not objDataset Is Nothing Then
Set objlayer = SuperMap1.Layers.AddDataset(objDataset, bAddToHead)
cmbLayer.AddItem objlayer.Name
End If
Set objDataset = objDataSource.Datasets.Item("world")
If Not objDataset Is Nothing Then
Set objlayer = SuperMap1.Layers.AddDataset(objDataset, bAddToHead)
cmbLayer.AddItem objlayer.Name
End If
End If
If SuperMap1.Layers.Count <= 0 Then Exit Sub
cmbLayer.ListIndex = 0
'刷新地图窗口
SuperMap1.Refresh
'释放内存
Set objDataSource = Nothing
Set objlayer = Nothing
End Sub
Private Sub Form_Unload(Cancel As Integer)
Set objRecMove = Nothing
Set objLayerMove = Nothing
Set objDataMove = Nothing
SuperMap1.Close
SuperMap1.Disconnect
SuperWorkspace1.Close
End Sub
Private Sub SuperMap1_GeometrySelected(ByVal nSelectedGeometryCount As Long)
Dim objRec As soRecordset
Set objRec = SuperMap1.selection.ToRecordset(False) '将选择集转换为记录集
If objRec Is Nothing Then
lvwPro.ListItems.Clear
cmbLayer.ListIndex = -1
Exit Sub
End If
objRec.MoveFirst
lvwPro.ListItems.Clear
cmbLayer.ListIndex = -1
cmbLayer.Text = SuperMap1.selection.Dataset.Name + "@" + SuperMap1.selection.Dataset.DataSourceAlias
Dim recFieldN As Integer
For recFieldN = 1 To objRec.FieldCount
lvwPro.ListItems.Add , , objRec.GetFieldInfo(recFieldN).Name
If Not IsNull(objRec.GetFieldValue(recFieldN)) Then
lvwPro.ListItems(lvwPro.ListItems.Count).SubItems(1) = objRec.GetFieldValue(recFieldN)
End If
Next recFieldN
End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -