📄 frmmain.frm
字号:
VERSION 5.00
Object = "{03ED3B1E-ED1B-4A2E-8FE3-D8D1A673F5D4}#5.2#0"; "SuperMap.ocx"
Begin VB.Form Frm3PArc
BorderStyle = 1 'Fixed Single
Caption = "三点画弧"
ClientHeight = 6555
ClientLeft = 45
ClientTop = 330
ClientWidth = 9330
FillColor = &H00C0C0C0&
ForeColor = &H8000000F&
Icon = "frmMain.frx":0000
LinkTopic = "Form1"
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 6555
ScaleWidth = 9330
StartUpPosition = 3 'Windows Default
Begin SuperMapLib.SuperMap sm
Height = 6090
Left = 30
TabIndex = 4
Top = 450
Width = 9255
_Version = 327682
_ExtentX = 16325
_ExtentY = 10742
_StockProps = 160
Appearance = 1
End
Begin SuperMapLib.SuperWorkspace sw
Left = 6780
Top = 180
_Version = 327682
_ExtentX = 847
_ExtentY = 847
_StockProps = 0
End
Begin VB.OptionButton OptNothing
Caption = "什么也不做"
Height = 195
Left = 90
TabIndex = 3
Top = 150
Value = -1 'True
Width = 1245
End
Begin VB.OptionButton OptTrackArc3P
Caption = "scaTrackArc3P"
ForeColor = &H00FF0000&
Height = 195
Left = 4470
TabIndex = 2
Top = 150
Width = 1995
End
Begin VB.OptionButton OptCircle3P
Caption = "scaEditCreateCircle3P"
ForeColor = &H00008000&
Height = 195
Left = 2410
TabIndex = 1
Top = 150
Width = 1995
End
Begin VB.OptionButton OptCustom
Caption = "自定义"
ForeColor = &H000000FF&
Height = 195
Left = 1400
TabIndex = 0
Top = 150
Width = 900
End
End
Attribute VB_Name = "Frm3PArc"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'=====================================SuperMap Objects示范工程说明=================================
'
'功能简介：示范利用SuperMap Objects画三点弧的功能。SuperMap Objects画三点弧的方法比较灵活，可以提供三种
' 方式，一种是用户自定义方式，另两种直接借助SuperMap定义的Action。此示例对于跟踪层和几何对象的操作
' 是很好的示范。
'所用控件：SuperMap 控件、SuperWorkspace 控件
'所用数据：临时创建的Track.sdb数据源
'操作说明：
' 选中某种画圆弧方式后在地图窗口中进行操作即可
' 本例中sm为Supermap的name; sw为SuperWorkspace的name
'
'===================================SuperMap Objects示范工程说明结束================================
Option Explicit
Dim iMyAction As Integer '用来表示是否开始画三点圆弧，如果为1则开始画
Dim objMyPoints As New soPoints '依次记录三点弧的三个点
Private Sub Form_Load() '创建Track数据源，elements的CAD数据集
Dim objDatasource As soDataSource
Dim objDataset As soDataset
iMyAction = 0
sm.Connect sw.Object
Set objDatasource = sw.CreateDataSource(App.Path & "\..\Data\MakeWith3p\Track.sdb", "Track", sceSDBPlus, False, True, False, "")
If Not (objDatasource Is Nothing) Then
Set objDataset = objDatasource.CreateDataset("Elements", scdCAD, scoDefault)
If Not (objDataset Is Nothing) Then
sm.Layers.AddDataset objDataset, True
Else
MsgBox "创建数据集失败"
End If
Else
MsgBox "创建默认数据源track.sdb失败"
End If
Set objDatasource = Nothing
Set objDataset = Nothing
End Sub
Private Sub Form_Unload(Cancel As Integer)
Set objMyPoints = Nothing
sm.Close
sm.Disconnect
sw.Close
End Sub
Private Sub OptCircle3P_Click() '编辑三点弧
If OptCircle3P.Value Then
iMyAction = 2
sm.Action = scaNull
sm.Layers.SetEditableLayer 1
sm.CurStyle.PenColor = RGB(0, 255, 0)
sm.Action = scaEditCreateArc3P
End If
End Sub
Private Sub OptCustom_Click() '自定义
If OptCustom.Value Then
sm.selection.RemoveAll
sm.Refresh
sm.Layers.SetEditableLayer 0
sm.Action = scaTrackPoint
iMyAction = 1
objMyPoints.RemoveAll
End If
End Sub
Private Sub OptNothing_Click() '什么也不做
If OptNothing.Value Then
sm.selection.RemoveAll
sm.Refresh
sm.Action = scaNull
iMyAction = 0
objMyPoints.RemoveAll
sm.Layers.SetEditableLayer 0
End If
End Sub
Private Sub OptTrackArc3P_Click() '跟踪层上绘制3点圆弧
If OptTrackArc3P.Value Then
sm.selection.RemoveAll
sm.Layers.SetEditableLayer 0
iMyAction = 3
sm.Action = scaTrackArc3P
sm.Refresh
End If
End Sub
Private Sub sm_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
If Button = 2 Then
If objMyPoints.Count > 0 Then
objMyPoints.RemoveAll
End If
sm.TrackingLayer.ClearEvents
End If
End Sub
Private Sub sm_Tracked()
Dim objStyle As New soStyle
Dim objGeoPoint As soGeoPoint
Dim objPoints As New soPoints
Dim objGeoLine As New soGeoLine
Dim objGeoArc As New soGeoArc
Dim objRecordset As soRecordset
Select Case iMyAction
Case 1
objStyle.PenColor = RGB(255, 0, 0)
objStyle.SymbolSize = 20
Select Case objMyPoints.Count '根据画过的点数处理跟踪层
Case 0 '第一个点
sm.TrackingLayer.ClearEvents
sm.TrackingLayer.AddEvent sm.TrackedGeometry, objStyle, "Point1"
Set objGeoPoint = sm.TrackedGeometry
objMyPoints.Add2 objGeoPoint.x, objGeoPoint.y
sm.TrackingLayer.Refresh
Case 1 '第二个点
Set objGeoPoint = sm.TrackedGeometry
objMyPoints.Add2 objGeoPoint.x, objGeoPoint.y
'在Trackinglayer上面显示第一点和第二点之间的连线
sm.TrackingLayer.RemoveEvent "Line"
objPoints.Add objMyPoints.Item(1)
objPoints.Add objMyPoints.Item(2)
objGeoLine.AddPart objPoints
objStyle.PenStyle = 2
objStyle.PenColor = RGB(196, 196, 196)
sm.TrackingLayer.AddEvent objGeoLine, objStyle, "Line1"
objStyle.PenColor = RGB(255, 0, 0)
sm.TrackingLayer.AddEvent sm.TrackedGeometry, objStyle, "Point2"
sm.TrackingLayer.Refresh
Case 2 '第三个点
Set objGeoPoint = sm.TrackedGeometry
objMyPoints.Add2 objGeoPoint.x, objGeoPoint.y
objGeoArc.MakeWith3P objMyPoints.Item(1), objMyPoints.Item(2), objMyPoints.Item(3)
Set objGeoArc.Style = objStyle
Set objRecordset = sm.Layers(1).Dataset.Query("1<0", True)
objRecordset.AddNew objGeoArc
objRecordset.Update
sm.TrackingLayer.ClearEvents
objMyPoints.RemoveAll '清空，以便进行下一次绘图
sm.Refresh
End Select
Case 2
Case 3 '通过在跟踪层上画三点弧的方式进行画三点弧，此处截获三点弧并保存下来
Set objGeoArc = sm.TrackedGeometry
objStyle.PenColor = RGB(0, 0, 255)
Set objGeoArc.Style = objStyle
If Not (objGeoArc Is Nothing) Then
Set objRecordset = sm.Layers(1).Dataset.Query("1<0", True)
objRecordset.AddNew objGeoArc
objRecordset.Update
sm.Refresh
End If
End Select
Set objStyle = Nothing
Set objGeoLine = Nothing
Set objGeoPoint = Nothing
Set objPoints = Nothing
Set objRecordset = Nothing
End Sub
Private Sub sm_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)
Dim objStyle As New soStyle
Dim objPoints As New soPoints
Dim objGeoLine As New soGeoLine
Dim objGeoArc As New soGeoArc
Dim objPoint As New soPoint
Select Case iMyAction
Case 1
objStyle.PenColor = RGB(196, 196, 196)
Select Case objMyPoints.Count
Case 0
Case 1 '根据当前点和前一个点连线
sm.TrackingLayer.RemoveEvent "Line" '清楚跟踪层
objPoints.Add objMyPoints.Item(1)
objPoints.Add2 x, y
objGeoLine.AddPart objPoints
objStyle.PenStyle = 2
sm.TrackingLayer.AddEvent objGeoLine, objStyle, "Line"
sm.TrackingLayer.Refresh
Case 2 '根据当前点和前两个点连线
sm.TrackingLayer.RemoveEvent "Line2"
sm.TrackingLayer.RemoveEvent "Arc"
objPoints.Add objMyPoints.Item(2)
objPoints.Add2 x, y
objGeoLine.AddPart objPoints
objStyle.PenStyle = 2
sm.TrackingLayer.AddEvent objGeoLine, objStyle, "Line2"
objPoint.x = x
objPoint.y = y
objGeoArc.MakeWith3P objMyPoints.Item(1), objMyPoints.Item(2), objPoint
objStyle.PenColor = RGB(255, 0, 0)
objStyle.PenStyle = 0
Set objGeoArc.Style = objStyle
sm.TrackingLayer.AddEvent objGeoArc, objStyle, "Arc"
sm.TrackingLayer.Refresh
End Select
End Select
Set objStyle = Nothing
Set objPoints = Nothing
Set objPoint = Nothing
Set objGeoLine = Nothing
Set objGeoArc = Nothing
End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -