📄 frmdatasetstru.frm
字号:
VERSION 5.00
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "mscomctl.ocx"
Begin VB.Form frmDataSetStru
BorderStyle = 3 'Fixed Dialog
Caption = "查询结果"
ClientHeight = 3810
ClientLeft = 45
ClientTop = 330
ClientWidth = 7410
LinkTopic = "Form2"
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 3810
ScaleWidth = 7410
ShowInTaskbar = 0 'False
StartUpPosition = 1 'CenterOwner
Begin MSComctlLib.ProgressBar ProgressBar
Height = 255
Left = 30
TabIndex = 8
Top = 3480
Width = 7365
_ExtentX = 12991
_ExtentY = 450
_Version = 393216
Appearance = 0
Scrolling = 1
End
Begin VB.CommandButton btnClose
Caption = "关闭"
Default = -1 'True
Height = 330
Left = 6285
TabIndex = 0
Tag = "3064"
Top = 0
Width = 1080
End
Begin MSComctlLib.ListView lsvDtStru
Height = 3390
Left = 15
TabIndex = 1
Top = 375
Width = 7380
_ExtentX = 13018
_ExtentY = 5980
View = 3
LabelEdit = 1
LabelWrap = -1 'True
HideSelection = 0 'False
AllowReorder = -1 'True
FullRowSelect = -1 'True
GridLines = -1 'True
_Version = 393217
ForeColor = -2147483640
BackColor = -2147483643
BorderStyle = 1
Appearance = 1
NumItems = 0
End
Begin VB.Label lblDtName
BackColor = &H80000018&
BorderStyle = 1 'Fixed Single
Height = 285
Left = 1065
TabIndex = 7
Top = 30
Width = 1455
End
Begin VB.Label lblDtType
BackColor = &H80000018&
BorderStyle = 1 'Fixed Single
Height = 285
Left = 3600
TabIndex = 6
Top = 0
Width = 720
End
Begin VB.Label lblObjCount
BackColor = &H80000018&
BorderStyle = 1 'Fixed Single
Height = 285
Left = 5325
TabIndex = 5
Top = 30
Width = 825
End
Begin VB.Label Label5
Caption = "对象总数"
Height = 225
Left = 4500
TabIndex = 4
Tag = "3114"
Top = 60
Width = 885
End
Begin VB.Label Label3
Caption = "数据集类型"
Height = 225
Left = 2625
TabIndex = 3
Tag = "3113"
Top = 60
Width = 990
End
Begin VB.Label Label1
Caption = "数据集名称"
Height = 225
Left = 75
TabIndex = 2
Tag = "3112"
Top = 75
Width = 1005
End
End
Attribute VB_Name = "frmDataSetStru"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Public objRecordset As soRecordset '定义接受查询记录的记录对象
Public objDt As soDataset '定义用来查询的数据集
Private Sub btnClose_Click()
Set objRecordset = Nothing
FrmMain.SuperMap1.selection.RemoveAll
FrmMain.SuperMap1.TrackingLayer.ClearEvents
FrmMain.SuperMap1.Refresh
Unload Me
End Sub
Private Sub Form_Activate()
'装载查询到的数据记录
Dim i As Long, j As Long, vFieldVal As Variant
Dim objFieldInfos As soFieldInfos
Dim objFieldInfo As soFieldInfo
Dim strDsName As String
Dim dgnlinks As soDgnLinks
If objDt Is Nothing Then Exit Sub
If objRecordset Is Nothing Then Exit Sub
Me.lblDtName = objDt.Name
Select Case objDt.Type
Case scdPoint
lblDtType.Caption = "点"
Case scdPointZ
lblDtType.Caption = "维点"
Case scdLine
lblDtType.Caption = "线"
Case scdLineZ
lblDtType.Caption = "三维线"
Case scdNetwork
lblDtType.Caption = "网络"
Case scdRegion
lblDtType.Caption = "面"
Case scdRegionZ
lblDtType.Caption = "三维面"
Case scdText
lblDtType.Caption = "文本"
Case scdTIN
lblDtType.Caption = "TIN" ' TIN
Case scdTabular
lblDtType.Caption = "属性表"
Case scdTraverse
lblDtType.Caption = "Traverse"
Case scdCAD
lblDtType.Caption = "CAD"
Case Else
lblDtType.Caption = "其他"
End Select
lblObjCount.Caption = objRecordset.RecordCount
Set objFieldInfos = objRecordset.GetFieldInfos
If objFieldInfos Is Nothing Then
MsgBox "错误！ ", vbInformation
Exit Sub
End If
DoEvents
'添加表头
frmDataSetStru.lsvDtStru.ColumnHeaders.Clear
For Each objFieldInfo In objFieldInfos
lsvDtStru.ColumnHeaders.Add , , objFieldInfo.Name
Next
If objRecordset.RecordCount > 1 Then
ProgressBar.Min = 1
ProgressBar.Max = objRecordset.RecordCount
Else
ProgressBar.Min = 1
ProgressBar.Max = 2
End If
frmDataSetStru.lsvDtStru.ListItems.Clear
objRecordset.MoveFirst
'添加记录
For i = 1 To objRecordset.RecordCount
ProgressBar.Value = i
vFieldVal = objRecordset.GetFieldValue(1)
If (VarType(vFieldVal) = vbNull) Or (VarType(vFieldVal) = vbEmpty) Then
lsvDtStru.ListItems.Add , , " "
Else
lsvDtStru.ListItems.Add , , vFieldVal
End If
For j = 2 To lsvDtStru.ColumnHeaders.Count
If (objRecordset.GetFieldInfo(j).Type = scfDgnLink) Then
Set dgnlinks = objRecordset.GetFieldValue(j)
If Not (dgnlinks Is Nothing) Then
vFieldVal = dgnlinks.ConvertToString()
Else
vFieldVal = ""
End If
Else
vFieldVal = objRecordset.GetFieldValue(j)
End If
If (VarType(vFieldVal) = vbNull) Or (VarType(vFieldVal) = vbEmpty) Then
lsvDtStru.ListItems(i).SubItems(j - 1) = " "
Else
lsvDtStru.ListItems(i).SubItems(j - 1) = vFieldVal
End If
Next
objRecordset.MoveNext
Next
ProgressBar.Visible = False
'添加完毕
Set objDt = Nothing
Set objFieldInfos = Nothing
Set objFieldInfo = Nothing
Set dgnlinks = Nothing
End Sub
Private Sub Form_Resize()
lsvDtStru.Left = 0
lsvDtStru.Top = 360
lsvDtStru.Width = frmDataSetStru.ScaleWidth - 2 * lsvDtStru.Left
lsvDtStru.Height = frmDataSetStru.ScaleHeight - lsvDtStru.Top - 20
End Sub
Private Sub lsvDtStru_ColumnClick(ByVal ColumnHeader As MSComctlLib.ColumnHeader)
lsvDtStru.Sorted = True
lsvDtStru.SortKey = ColumnHeader.Index - 1
lsvDtStru.SortOrder = IIf(lsvDtStru.SortOrder = lvwAscending, lvwDescending, lvwAscending)
End Sub
Private Sub lsvDtStru_ItemClick(ByVal Item As MSComctlLib.ListItem)
'通过属性记录的选择，在SuperMap1上显示对应的几何对象
Dim objGeometry As soGeometry
Dim objStyle As New soStyle
objStyle.PenColor = vbBlue
objStyle.BrushColor = vbBlue
If CLng(Item.Text) = 0 Then
objRecordset.MoveFirst
Else
objRecordset.MoveTo CLng(Item.Text) + 1
End If
Set objGeometry = objRecordset.GetGeometry()
'Debug.Print objGeometry.ID
If Not objGeometry Is Nothing Then
FrmMain.SuperMap1.TrackingLayer.ClearEvents
FrmMain.SuperMap1.TrackingLayer.AddEvent objGeometry, objStyle, ""
End If
FrmMain.SuperMap1.Refresh
Set objGeometry = Nothing
Set objStyle = Nothing
End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -