📄 frmmain.frm
字号:
VERSION 5.00
Object = "{03ED3B1E-ED1B-4A2E-8FE3-D8D1A673F5D4}#5.0#0"; "SuperMap.ocx"
Begin VB.Form frmMain
BorderStyle = 1 'Fixed Single
Caption = "经纬度坐标系下的面积距离量算"
ClientHeight = 6480
ClientLeft = 45
ClientTop = 435
ClientWidth = 8805
Icon = "frmMain.frx":0000
LinkTopic = "Form1"
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 6480
ScaleWidth = 8805
StartUpPosition = 3 'Windows Default
Begin VB.CommandButton Command8
Caption = "量算面积"
Height = 540
Left = 7695
TabIndex = 7
Top = 30
Width = 1095
End
Begin VB.CommandButton Command7
Caption = "量算距离"
Height = 540
Left = 6600
TabIndex = 6
Top = 30
Width = 1095
End
Begin VB.CommandButton Command6
Caption = "全幅"
Height = 540
Left = 5505
TabIndex = 5
Top = 30
Width = 1095
End
Begin VB.CommandButton Command5
Caption = "漫游"
Height = 540
Left = 4410
TabIndex = 4
Top = 30
Width = 1095
End
Begin VB.CommandButton Command4
Caption = "自由缩放"
Height = 540
Left = 3315
TabIndex = 3
Top = 30
Width = 1095
End
Begin VB.CommandButton Command3
Caption = "缩小"
Height = 540
Left = 2220
TabIndex = 2
Top = 30
Width = 1095
End
Begin VB.CommandButton Command2
Caption = "放大"
Height = 540
Left = 1125
TabIndex = 1
Top = 30
Width = 1095
End
Begin VB.CommandButton Command1
Caption = "选择"
Height = 540
Left = 30
TabIndex = 0
Top = 30
Width = 1095
End
Begin VB.Frame Frame1
Height = 5970
Left = 45
TabIndex = 8
Top = 495
Width = 8760
Begin SuperMapLib.SuperMap SuperMap1
Height = 4980
Left = 30
TabIndex = 9
Top = 120
Width = 8670
_Version = 327680
_ExtentX = 15293
_ExtentY = 8784
_StockProps = 160
Appearance = 1
End
Begin VB.Label lblRsult
Appearance = 0 'Flat
ForeColor = &H80000008&
Height = 750
Left = 5865
TabIndex = 12
Top = 5145
Width = 2850
End
Begin VB.Label lblTY
BorderStyle = 1 'Fixed Single
Height = 765
Left = 2820
TabIndex = 11
Top = 5145
Width = 3000
End
Begin VB.Label lblJWD
BorderStyle = 1 'Fixed Single
Height = 765
Left = 45
TabIndex = 10
Top = 5145
Width = 2760
End
End
Begin SuperMapLib.SuperWorkspace SuperWorkspace1
Left = 5430
Top = 1845
_Version = 327680
_ExtentX = 847
_ExtentY = 847
_StockProps = 0
End
End
Attribute VB_Name = "frmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Dim objpoint As New soPoint
Dim objPCS As New soPJCoordSys
Dim objGCS As New soPJGeoCoordSys
Dim objParams As New soPJParams
Private Sub Command7_Click()
SuperMap1.Action = scaTrackPolyline
End Sub
Private Sub Command8_Click()
SuperMap1.Action = scaTrackPolygon
End Sub
Private Sub Form_Load()
Dim objDs As soDataSource
Dim objDt As soDataset
SuperMap1.Connect SuperWorkspace1.Handle
Set objDs = SuperWorkspace1.OpenDataSource(App.Path & "\test.sdb", "test", sceSDBPlus, False)
Set objDt = objDs.Datasets(1)
SuperMap1.Layers.AddDataset objDt, True
SuperMap1.ViewEntire
SetPjCoord
Set objDt = Nothing
Set objDs = Nothing
End Sub
Private Sub Form_Unload(Cancel As Integer)
Set objParams = Nothing
Set objGCS = Nothing
Set objPCS = Nothing
Set objpoint = Nothing
SuperMap1.Close
SuperMap1.Disconnect
SuperWorkspace1.Close
End Sub
Private Sub SuperMap1_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
Dim dx As Double
Dim dy As Double
If SuperMap1.Layers.Count = 0 Then Exit Sub
dx = SuperMap1.PixelToMapX(ScaleX(x, vbTwips, vbPixels))
dy = SuperMap1.PixelToMapY(ScaleY(y, vbTwips, vbPixels))
lblJWD.Caption = "当前经纬坐标为:" & vbCrLf & "x=" & dx & "度" & vbCrLf & "y=" & dy & "度"
ChangeJWD2TY dx, dy
End Sub
Private Sub SetPjCoord()
Dim objDs As soDataSource
Dim objDt As soDataset
Dim objRect As soRect
Set objDs = SuperWorkspace1.Datasources(1)
Set objDt = objDs.Datasets(1)
Set objRect = objDt.Bounds
objGCS.Type = scGCS_BEIJING_1954 '地理坐标系的类型
'投影参数
objParams.CentralMeridian = objRect.CenterPoint.x '中央经线
objParams.FalseEasting = 500000
'设置投影系的属性
objPCS.Type = scPCS_USER_DEFINED '投影系的类型
objPCS.CoordUnits = scuMeter '投影系的坐标单位
objPCS.Projection = scPRJ_GAUSS_KRUGER '投影方式
Set objPCS.PJParams = objParams '投影参数
Set objPCS.GeoCoordSys = objGCS '投影系所依赖的地理坐标系
Set objpoint = Nothing
Set objDs = Nothing
Set objDt = Nothing
Set objRect = Nothing
End Sub
Private Sub ChangeJWD2TY(dx As Double, dy As Double)
objpoint.x = dx
objpoint.y = dy
objPCS.Forward objpoint
dx = objpoint.x
dy = objpoint.y
lblTY.Caption = "当前投影坐标为:" & vbCrLf & "x=" & dx & "米" & vbCrLf & "y=" & dy & "米"
End Sub
Private Sub ChangeGeometry(objGm As soGeometry)
Dim objDs As soDataSource
Dim objPCSS As soPJCoordSys
Dim objPjTranse As New soPJTranslator
Dim objGr As soGeoRegion
Dim objGl As soGeoLine
Dim dZYJX As Double
Dim dTmp As Double
Set objDs = SuperWorkspace1.Datasources(1)
Set objPCSS = objDs.PJCoordSys
objPjTranse.Create
Set objPjTranse.PJCoordSysSrc = objPCSS
Set objPjTranse.PJCoordSysDes = objPCS
If objGm.Type = scgRegion Then
Set objGr = objGm
dTmp = Format(objGr.Area, "#.####")
objPjTranse.Convert objGr
lblRsult.Caption = "面积为：" & vbCrLf & "转换前>" & dTmp & "平方米" & vbCrLf & "转换后>" & Format(objGr.Area, "#.####") & "平方米"
ElseIf objGm.Type = scgLine Then
Set objGl = objGm
dTmp = Format(objGl.Length, "#.####")
objPjTranse.Convert objGl
lblRsult.Caption = "长度为：" & vbCrLf & "转换前>" & dTmp & "米" & vbCrLf & "转换后>" & Format(objGl.Length, "#.####") & "米"
End If
lblRsult.Refresh
Set objGl = Nothing
Set objGr = Nothing
Set objDs = Nothing
Set objPCSS = Nothing
Set objPjTranse = Nothing
End Sub
Private Sub SuperMap1_Tracked()
Dim objGm As soGeometry
Set objGm = SuperMap1.TrackedGeometry
ChangeGeometry objGm
Set objGm = Nothing
End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -