📄 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
BorderStyle = 3 'Fixed Dialog
Caption = "地图量算"
ClientHeight = 5490
ClientLeft = 45
ClientTop = 330
ClientWidth = 8700
LinkTopic = "Form1"
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 5490
ScaleWidth = 8700
StartUpPosition = 2 'CenterScreen
Begin VB.CommandButton CmdClear
Caption = "清 除"
Height = 375
Left = 6840
TabIndex = 17
Top = 1680
Width = 1335
End
Begin VB.CommandButton CmdRegion
Caption = "画 面"
Height = 375
Left = 6840
TabIndex = 16
Top = 1200
Width = 1335
End
Begin VB.CommandButton CmdLine
Caption = "画 线"
Height = 375
Left = 6840
TabIndex = 15
Top = 720
Width = 1335
End
Begin VB.CommandButton btnSelect
Caption = "选择"
Height = 375
Left = 165
TabIndex = 8
Top = 60
Width = 1200
End
Begin VB.CommandButton btnViewEntire
Caption = "全幅"
Height = 375
Left = 6165
TabIndex = 7
Top = 60
Width = 1200
End
Begin VB.CommandButton btnZoomFree
Caption = "自由缩放"
Height = 375
Left = 4965
TabIndex = 6
Top = 60
Width = 1200
End
Begin VB.CommandButton btnZoomOut
Caption = "缩小"
Height = 375
Left = 3765
TabIndex = 5
Top = 60
Width = 1200
End
Begin VB.CommandButton btnZoomIn
Caption = "放大"
Height = 375
Left = 2565
TabIndex = 4
Top = 60
Width = 1200
End
Begin VB.CommandButton btnPan
Caption = "漫游"
Height = 375
Left = 1365
TabIndex = 3
Top = 60
Width = 1200
End
Begin VB.CommandButton btnClose
Caption = "关闭"
BeginProperty Font
Name = "宋体"
Size = 9
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 375
Left = 7365
TabIndex = 0
Top = 60
Width = 1200
End
Begin MSComDlg.CommonDialog CommonDialog1
Left = 8280
Top = 2280
_ExtentX = 847
_ExtentY = 847
_Version = 393216
End
Begin SuperMapLib.SuperWorkspace SuperWorkspace1
Left = 7800
Top = 2280
_Version = 196610
_ExtentX = 847
_ExtentY = 847
_StockProps = 0
End
Begin SuperMapLib.SuperMap SuperMap1
Height = 4980
Left = 30
TabIndex = 2
Top = 480
Width = 6435
_Version = 196610
_ExtentX = 11351
_ExtentY = 8784
_StockProps = 160
Appearance = 1
End
Begin VB.Frame Frame1
Caption = "测量结果"
Height = 3150
Left = 6480
TabIndex = 1
Top = 2280
Width = 2175
Begin VB.TextBox TxtArea
BackColor = &H00C0FFFF&
ForeColor = &H00FF0000&
Height = 375
Left = 120
TabIndex = 13
Text = "0.000000000"
Top = 2520
Width = 1935
End
Begin VB.TextBox TxtTolLength
BackColor = &H00C0FFFF&
ForeColor = &H00FF0000&
Height = 375
Left = 120
TabIndex = 10
Text = "0.0000000000"
Top = 1560
Width = 1920
End
Begin VB.TextBox TxtCurLength
BackColor = &H00C0FFFF&
ForeColor = &H00FF0000&
Height = 375
Left = 120
TabIndex = 9
Text = "0.0000000000"
Top = 600
Width = 1920
End
Begin VB.Label Label2
Caption = "面积："
BeginProperty Font
Name = "宋体"
Size = 9.75
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 255
Left = 120
TabIndex = 14
Top = 2280
Width = 855
End
Begin VB.Label Label1
Caption = "总距离 ："
BeginProperty Font
Name = "宋体"
Size = 9.75
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 240
Index = 0
Left = 120
TabIndex = 12
Top = 1320
Width = 1320
End
Begin VB.Label Label1
Caption = "两点间距离："
BeginProperty Font
Name = "宋体"
Size = 9.75
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 225
Index = 1
Left = 120
TabIndex = 11
Top = 360
Width = 1170
End
End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'================================SuperMap Objects示范工程说明=================================
'
'功能简介：示范SuperMap Objects中折线的分段长度和总长度、多边形面积的量算。
'所用控件：Supermap控件和SuperWorkspace控件
'所用数据：..\Data\目录下的World.sdb和World.sdd两个文件
'操作说明：
' 1、测量折线长度：选中"画线"。在SuperMap控件中单击左键画出线，并计算出距离；单击右键：结束画线。
' 2、测量多边形面积：选中"画面"。在SuperMap控件中单击左键画多边形，单击右键结束，并计算出多边形面积。
'===============================SuperMap Objects 示范工程说明结束===============================
Private Sub btnClose_Click()
Unload Me
End Sub
Private Sub btnPan_Click()
SuperMap1.Action = scaPan
End Sub
Private Sub btnSelect_Click()
SuperMap1.Action = scaSelect
End Sub
Private Sub btnViewEntire_Click()
SuperMap1.ViewEntire
End Sub
Private Sub btnZoomFree_Click()
SuperMap1.Action = scaZoomFree
End Sub
Private Sub btnZoomIn_Click()
SuperMap1.Action = scaZoomIn
End Sub
Private Sub btnZoomOut_Click()
SuperMap1.Action = scaZoomOut
End Sub
Private Sub CmdClear_Click()
SuperMap1.TrackingLayer.ClearEvents
SuperMap1.TrackingLayer.Refresh
End Sub
Private Sub CmdLine_Click()
SuperMap1.TrackingLayer.ClearEvents
SuperMap1.TrackingLayer.Refresh
SuperMap1.Action = scaTrackPolyline
End Sub
Private Sub CmdRegion_Click()
SuperMap1.TrackingLayer.ClearEvents
SuperMap1.TrackingLayer.Refresh
SuperMap1.Action = scaTrackPolygon
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 bAddToHead As Boolean '是否加到最上面
Dim i As Integer '循环变量
SuperMap1.Connect SuperWorkspace1.Object
SuperMap1.Appearance = 1
strAlias = "World" '原则上别名可以任意给,建议取成和数据源文件主名
nEngineType = sceSDB 'SuperMap支持多种类型，此处为SDB类型
strDataSourceName = App.Path & "\..\data\world.sdb" 'CommonDialog1.FileName
'打开数据源
Set objDataSource = SuperWorkspace1.OpenDataSource(strDataSourceName, strAlias, nEngineType, True)
If objDataSource Is Nothing Then
MsgBox "打开数据源失败！", vbInformation
Else
'把数据源中的所有图层加入到SuperMap中
bAddToHead = True
Set objlayer = SuperMap1.Layers.AddDataset(objDataSource.Datasets.Item("grid"), bAddToHead)
Set objlayer = SuperMap1.Layers.AddDataset(objDataSource.Datasets.Item("world"), bAddToHead)
End If
'释放内存
Set objDataSource = Nothing
Set objlayer = Nothing
End Sub
Private Sub Form_Unload(Cancel As Integer)
SuperMap1.Close
SuperMap1.Disconnect
SuperWorkspace1.Close
End Sub
Private Sub SuperMap1_Tracked()
Dim objStyle As New soStyle
Dim objGeometry As soGeometry
objStyle.PenWidth = 2
objStyle.PenColor = vbBlue
objStyle.PenStyle = 0
objStyle.BrushStyle = 1
Set objGeometry = SuperMap1.TrackedGeometry
If Not (objGeometry Is Nothing) Then
SuperMap1.TrackingLayer.AddEvent objGeometry, objStyle, ""
SuperMap1.TrackingLayer.Refresh
SuperMap1.Action = scaSelect
End If
Set objStyle = Nothing
Set objGeometry = Nothing
End Sub
Private Sub SuperMap1_Tracking(ByVal x As Double, ByVal y As Double, ByVal dCurrentLength As Double, ByVal dCurrentAngle As Double, ByVal dTotalLength As Double, ByVal dTotalArea As Double, ByVal nButtonClicked As Long)
'关键代码，在画线/面的同时跟踪显示当前线段长度、总长度和面积
TxtCurLength.Text = dCurrentLength
TxtTolLength.Text = dTotalLength
TxtArea.Text = dTotalArea
End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -