📄 spatialquery.frm
字号:
VERSION 5.00
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 FrmSpatialQuery
Caption = "Form2"
ClientHeight = 5880
ClientLeft = 60
ClientTop = 345
ClientWidth = 9120
Icon = "SpatialQuery.frx":0000
LinkTopic = "Form2"
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 5880
ScaleWidth = 9120
StartUpPosition = 2 'CenterScreen
Begin SuperMapLib.SuperWorkspace SuperWorkspace1
Left = 5340
Top = 2520
_Version = 327682
_ExtentX = 847
_ExtentY = 847
_StockProps = 0
End
Begin SuperMapLib.SuperMap SuperMap1
Height = 4815
Left = 2160
TabIndex = 18
Top = 480
Width = 6915
_Version = 327682
_ExtentX = 12197
_ExtentY = 8493
_StockProps = 160
End
Begin VB.TextBox Text1
Height = 1590
Left = 0
MultiLine = -1 'True
ScrollBars = 2 'Vertical
TabIndex = 17
Top = 3750
Width = 2040
End
Begin VB.ComboBox CmbLayer
Height = 315
Left = 0
TabIndex = 14
Text = "Combo1"
Top = 3150
Width = 2040
End
Begin VB.ListBox LstQueryMode
Height = 1230
Left = 0
TabIndex = 9
Top = 1350
Width = 2040
End
Begin VB.Frame Frame1
Caption = "查询对象"
Height = 615
Left = 0
TabIndex = 8
Top = 450
Width = 2040
Begin VB.OptionButton OptRegion
Caption = "面"
Height = 315
Left = 1275
TabIndex = 13
Top = 225
Width = 540
End
Begin VB.OptionButton OptLine
Caption = "线"
Height = 315
Left = 675
TabIndex = 12
Top = 225
Width = 690
End
Begin VB.OptionButton OptPoint
Caption = "点"
Height = 315
Left = 150
TabIndex = 11
Top = 225
Width = 465
End
End
Begin VB.CommandButton Command1
Caption = "刷新"
Height = 375
Index = 7
Left = 5775
TabIndex = 7
Top = 30
Width = 960
End
Begin VB.CommandButton Command1
Caption = "选择"
Height = 375
Index = 0
Left = 15
TabIndex = 6
Top = 30
Width = 960
End
Begin VB.CommandButton Command1
Caption = "漫游"
Height = 375
Index = 1
Left = 975
TabIndex = 5
Top = 30
Width = 960
End
Begin VB.CommandButton Command1
Caption = "放大"
Height = 375
Index = 2
Left = 1935
TabIndex = 4
Top = 30
Width = 960
End
Begin VB.CommandButton Command1
Caption = "缩小"
Height = 375
Index = 3
Left = 2895
TabIndex = 3
Top = 30
Width = 960
End
Begin VB.CommandButton Command1
Caption = "自由缩放"
Height = 375
Index = 4
Left = 3855
TabIndex = 2
Top = 30
Width = 960
End
Begin VB.CommandButton Command1
Caption = "全幅显示"
Height = 375
Index = 5
Left = 4815
TabIndex = 1
Top = 30
Width = 960
End
Begin VB.CommandButton Command1
Caption = "退出"
Height = 390
Index = 6
Left = 8100
TabIndex = 0
Top = 0
Width = 990
End
Begin MSComDlg.CommonDialog CommonDialog1
Left = 5970
Top = 4785
_ExtentX = 847
_ExtentY = 847
_Version = 393216
End
Begin VB.Label Label1
AutoSize = -1 'True
Height = 195
Left = 105
TabIndex = 19
Top = 5520
Width = 45
End
Begin VB.Label Label4
Caption = "空间查询模式说明："
ForeColor = &H00FF0000&
Height = 315
Left = 0
TabIndex = 16
Top = 3525
Width = 1815
End
Begin VB.Label Label3
Caption = "用来查询的图层"
Height = 315
Left = 0
TabIndex = 15
Top = 2850
Width = 1515
End
Begin VB.Label Label2
Caption = "空间查询模式"
Height = 315
Left = 0
TabIndex = 10
Top = 1125
Width = 1965
End
End
Attribute VB_Name = "FrmSpatialQuery"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'=====================================SuperMap Objects 示范工程说明=======================================
'
'功能简介：示范矢量数据集soDatasetVector的空间查询功能
'所用控件：SuperMap控件、SuperWorkspace控件
'所用数据：..\Data\world目录下的World.sdb和World.sdd两个文件
'操作说明：
' 1、选择“查询对象”设置SuperMap1的操作状态，画点、画线、画面三种方式求得用来空间查询的集合对象；
' 2、选择"空间查询模式"用来设置点查询、线查询、面查询时的查询模式；
' 3、单击"用来查询的图层"设置被查询的数据集
' 4、然后在SuperMap上进行相应的操作，操作结束后或出现相应的查询结果
'===================================SuperMap Objects 示范工程说明结束=====================================
Option Explicit
Dim objGeometry As New soGeometry
Dim iQueryMode As Integer
Dim objDt As soDatasetVector
Private Sub CmbLayer_Click()
SuperMap1.Layers(CmbLayer.ListIndex + 1).Snapable = True
If CmbLayer.ListCount < 1 Then
Set objDt = Nothing
Exit Sub
End If
Set objDt = SuperMap1.Layers(CmbLayer.ListIndex + 1).Dataset
End Sub
Private Sub Command1_Click(Index As Integer)
Select Case Index
Case 0
SuperMap1.Action = scaSelect
Case 1
SuperMap1.Action = scaPan
Case 2
SuperMap1.Action = scaZoomIn
Case 3
SuperMap1.Action = scaZoomOut
Case 4
SuperMap1.Action = scaZoomFree
Case 5
SuperMap1.ViewEntire
Case 6
Unload Me
Case 7
SuperMap1.Refresh
End Select
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 '循环变量
SuperMap1.Connect SuperWorkspace1.Handle
nEngineType = sceSDBPlus 'SuperMap支持多种类型，此处为SDB类型
strDataSourceName = App.Path & "\..\Data\world\world.sdb" 'CommonDialog1.FileName
strAlias = "world"
'打开数据源
Set objDataSource = SuperWorkspace1.OpenDataSource(strDataSourceName, strAlias, nEngineType, True)
If objDataSource Is Nothing Then
MsgBox "打开数据源失败！", vbInformation
Exit Sub
Else
'把数据源中的所有图层加入到SuperMap中
Set objLayer = SuperMap1.Layers.AddDataset(objDataSource.Datasets("world"), True)
objLayer.Snapable = True
Set objLayer = SuperMap1.Layers.AddDataset(objDataSource.Datasets("grid"), True)
objLayer.Snapable = True
SuperMap1.Refresh
CmbLayer.AddItem "world_grid"
CmbLayer.AddItem "world_world"
CmbLayer.ListIndex = 0
End If
LstQueryMode.AddItem "scsCommonPoint"
LstQueryMode.AddItem "scsLineCross"
LstQueryMode.AddItem "scsCommonLine"
LstQueryMode.AddItem "scsCommonPointOrLineCross"
LstQueryMode.AddItem "scsEdgeTouchOrAreaIntersect"
LstQueryMode.AddItem "scsAreaIntersect "
LstQueryMode.AddItem "scsAreaIntersectNoEdgeTouch "
LstQueryMode.AddItem "scsContainedBy "
LstQueryMode.AddItem "scsContaining "
LstQueryMode.AddItem "scsContainedByNoEdgeTouch "
LstQueryMode.AddItem "scsContainingNoEdgeTouch "
LstQueryMode.AddItem "scsPointInPolygon "
LstQueryMode.AddItem "scsCentroidInPolygon"
LstQueryMode.AddItem "scsIdentical"
LstQueryMode.ListIndex = 0
SuperMap1.Action = scaSelect
'释放内存
Set objDataSource = Nothing
Set objLayer = Nothing
End Sub
Private Sub Form_Unload(Cancel As Integer)
Set objGeometry = Nothing
Set objDt = Nothing
SuperMap1.Disconnect
SuperMap1.Close
SuperWorkspace1.Close
End Sub
Private Sub LstQueryMode_Click()
SuperMap1.Layers(CmbLayer.ListIndex + 1).Snapable = True
If LstQueryMode.ListIndex < 0 Or LstQueryMode.ListIndex >= LstQueryMode.ListCount Then Exit Sub
iQueryMode = LstQueryMode.ListIndex + 1
Select Case LstQueryMode.ListIndex
Case 0: Text1.Text = "返回与搜索对象有公共点的所有对象 "
Case 1: Text1.Text = "返回与搜索对象中的的边线有相交的所有对象 "
Case 2: Text1.Text = "返回与搜索对象有公共边的所有对象 "
Case 3: Text1.Text = "返回与搜索对象有公共点或者与搜索对象中的的边线有相交的所有对象 "
Case 4: Text1.Text = "返回全部或部分包含搜索对象、或者全部或者部分被搜索对象包含的所有对象，边线有接触的对象也符合条件"
Case 5: Text1.Text = "如果搜索对象是多边形，返回全部或部分被搜索对象包含的对象；如果，搜索对象不是多边形，就返回全部或部分包含搜索对象的对象"
Case 6: Text1.Text = "与scsAreaIntersect相同，但是相邻/有边线相接触的对象不符合条件"
Case 7: Text1.Text = "返回完全包含搜索对象的对象。如果是多边形，返回的对象必须全部包含搜索对象；如果是线，返回的对象必须重叠于搜索对象，并且搜索对象不得有任何一段超出返回的对象；如果是点，搜索对象必须重叠于返回的点对象中的一个顶点"
Case 8: Text1.Text = "返回完全被搜索对象包含的对象 "
Case 9: Text1.Text = "返回完全包含搜索对象的对象，并且没有边线或者点接触，因此，被查询的对象必须是多边形对象"
Case 10: Text1.Text = "返回完全被搜索对象包含的对象，并且没有边线或者点接触"
Case 11: Text1.Text = "返回包含搜索对象中的第一个点的多边形对象 "
Case 12: Text1.Text = "返回质心在其内部的多边形对象 "
Case 13: Text1.Text = "返回与搜索对象完全相同的对象，包括对象类型和坐标数据都相同"
End Select
End Sub
Private Sub OptLine_Click()
SuperMap1.Action = scaTrackPolyline
SuperMap1.TrackingLayer.ClearEvents
SuperMap1.TrackingLayer.Refresh
End Sub
Private Sub OptPoint_Click()
SuperMap1.Action = scaTrackPoint
SuperMap1.TrackingLayer.ClearEvents
SuperMap1.TrackingLayer.Refresh
End Sub
Private Sub OptRegion_Click()
SuperMap1.Action = scaTrackPolygon
SuperMap1.TrackingLayer.ClearEvents
SuperMap1.TrackingLayer.Refresh
End Sub
Private Sub SuperMap1_Tracked()
Dim objRcd As soRecordset
Dim objStyle As New soStyle
Dim objGeoRegion As soGeoRegion
Dim objGeoLine As soGeoLine
If objDt Is Nothing Then GoTo q
Set objGeometry = SuperMap1.TrackedGeometry
SuperMap1.TrackingLayer.ClearEvents
With objStyle
.PenColor = vbBlue
.SymbolSize = 80
.BrushStyle = 1
End With
SuperMap1.TrackingLayer.AddEvent objGeometry, objStyle, ""
Set objRcd = objDt.QueryEx(objGeometry, iQueryMode, "")
SuperMap1.TrackingLayer.Refresh
If (objRcd Is Nothing) Or objRcd.RecordCount < 1 Then
Label1.Caption = "查询出对象个数：0"
If SuperMap1.selection.Count > 0 Then
SuperMap1.selection.RemoveAll
SuperMap1.Refresh
End If
GoTo q
Else
Label1.Caption = "查询出对象个数：" & objRcd.RecordCount
SuperMap1.selection.FromRecordset objRcd
SuperMap1.Refresh
End If
q:
Set objRcd = Nothing
Set objStyle = Nothing
Set objGeoRegion = Nothing
Set objGeoLine = Nothing
End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -