📄 frmmain.frm
字号:
Begin MSComctlLib.Toolbar Toolbar1
Align = 1 'Align Top
Height = 420
Left = 0
TabIndex = 1
Top = 0
Width = 9090
_ExtentX = 16034
_ExtentY = 741
ButtonWidth = 609
ButtonHeight = 582
Appearance = 1
ImageList = "ImageList"
_Version = 393216
BeginProperty Buttons {66833FE8-8583-11D1-B16A-00C0F0283628}
NumButtons = 8
BeginProperty Button1 {66833FEA-8583-11D1-B16A-00C0F0283628}
Object.ToolTipText = "选择"
ImageIndex = 8
EndProperty
BeginProperty Button2 {66833FEA-8583-11D1-B16A-00C0F0283628}
Object.ToolTipText = "放大"
ImageIndex = 11
EndProperty
BeginProperty Button3 {66833FEA-8583-11D1-B16A-00C0F0283628}
Object.ToolTipText = "缩小"
ImageIndex = 12
EndProperty
BeginProperty Button4 {66833FEA-8583-11D1-B16A-00C0F0283628}
Object.ToolTipText = "自由缩放"
ImageIndex = 13
EndProperty
BeginProperty Button5 {66833FEA-8583-11D1-B16A-00C0F0283628}
Object.ToolTipText = "平移"
ImageIndex = 14
EndProperty
BeginProperty Button6 {66833FEA-8583-11D1-B16A-00C0F0283628}
Object.ToolTipText = "全幅显示"
ImageIndex = 68
EndProperty
BeginProperty Button7 {66833FEA-8583-11D1-B16A-00C0F0283628}
Style = 3
EndProperty
BeginProperty Button8 {66833FEA-8583-11D1-B16A-00C0F0283628}
Object.ToolTipText = "投影坐标系"
ImageIndex = 42
EndProperty
EndProperty
End
Begin MSComctlLib.StatusBar StatusBar1
Align = 2 'Align Bottom
Height = 255
Left = 0
TabIndex = 0
Top = 6090
Width = 9090
_ExtentX = 16034
_ExtentY = 450
_Version = 393216
BeginProperty Panels {8E3867A5-8586-11D1-B16A-00C0F0283628}
NumPanels = 2
BeginProperty Panel1 {8E3867AB-8586-11D1-B16A-00C0F0283628}
AutoSize = 2
Object.Width = 4604
MinWidth = 4410
Text = "北京超图地理信息技术有限公司"
TextSave = "北京超图地理信息技术有限公司"
EndProperty
BeginProperty Panel2 {8E3867AB-8586-11D1-B16A-00C0F0283628}
Object.Width = 10583
MinWidth = 10583
EndProperty
EndProperty
End
End
Attribute VB_Name = "FrmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'=====================================SuperMap Objects示范工程说明=======================================
'
'功能简介：示范SuperMap Objects 如何实现投影坐标系转换
'所用控件：SuperMap控件和SuperWorkspace控件
'所用数据：上一级目录\..\Data\World\PrjSample中wgs84.sdb和wgs84.sdd两个文件
'操作说明：1、单击选择、放大、缩小等按钮可以进行简单的地图操作；
' 2、单击"投影坐标系"按钮，可以显示当前数据源所使用的投影方式和坐标系，单击“转换”按钮
' 可以设置目标投影坐标系并实现不同坐标系之间的转换；单击“地理坐标系”按钮可以查看当
' 前投影坐标系所使用的地理坐标系的详细信息。注意，本程序不支持地理坐标系的转换。
'
'
'===================================SuperMap Objects 示范工程说明结束=====================================
Private Sub cmdPrjInfo_Click()
frmPCSProp.Show
End Sub
Private Sub Cmdprjtogeo_Click()
Dim objPCS As soPJCoordSys '投影坐标系对象
Dim objGCS As New soPJGeoCoordSys '地理坐标系对象
Dim objParams As New soPJParams '投影参数
Dim objSpheroid As New soPJSpheroid '椭球参数
Dim objDatum As New soPJDatum '大地参照系
Dim objPrimeMeridian As New soPJPrimeMeridian '中央经线
Dim objDatasource As soDataSource
Dim bResult As Boolean
Dim objDataset As soDatasetVector
Dim objRecordset As soRecordset
Dim objGeometry As soGeometry
Dim i As Integer
Set objDatasource = SuperWorkspace1.Datasources(1)
Set objPCS = objDatasource.PJCoordSys
If objPCS.Projection > -1 Then
Set objDataset = objDatasource.Datasets(1)
Set objRecordset = objDataset.Query("", True)
objRecordset.MoveFirst
For i = 1 To objRecordset.RecordCount
Set objGeometry = objRecordset.GetGeometry
bResult = objPCS.Inverse(objGeometry)
objRecordset.Edit
objRecordset.SetGeometry objGeometry
objRecordset.Update
objRecordset.MoveNext
Next
objDataset.ComputeBounds
objSpheroid.Type = -1 '椭球参数类型：-1为自定义
objSpheroid.Axis = 6378156 '地球赤道半径（椭球体半长轴）
objSpheroid.Flatten = 1 / 298.3 '地球椭球体的扁率
objDatum.Type = -1 '大地参照系类型
Set objDatum.PJSpheroid = objSpheroid '大地参照系所依托的地球椭球参数
objPrimeMeridian.Type = scPrimeMeridian_GREENWICH '中央经线类型
objGCS.Type = -1 '地理坐标系的类型：-1为自定义
objGCS.CoordUnits = scuDegree '地理坐标系的单位，固定为角度
Set objGCS.PJDatum = objDatum '地理坐标系所依托的大地参照系
Set objGCS.PJPrimeMeridian = objPrimeMeridian '地理坐标系的中央经线
'设置投影系的属性
objPCS.Type = 1 '投影系的类型
objPCS.CoordUnits = scuDegree '投影系的坐标单位
Set objPCS.GeoCoordSys = objGCS '投影系所依赖的地理坐标系
objDatasource.PJCoordSys = objPCS
SuperMap1.Layers.RemoveAll
SuperMap1.Layers.AddDataset objDataset, True
SuperMap1.ViewEntire
SuperMap1.Refresh
End If
Set objPCS = Nothing
Set objGCS = Nothing
Set objParams = Nothing
Set objDatum = Nothing
Set objSpheroid = Nothing
Set objPrimeMeridian = Nothing
Set objDatasource = Nothing
Set objDataset = Nothing
Set objRecordset = Nothing
Set objGeometry = Nothing
End Sub
Private Sub CmdGeoToPrj_Click()
Dim objPCS As New soPJCoordSys '投影坐标系对象
Dim objGCS As New soPJGeoCoordSys '地理坐标系对象
Dim objParams As New soPJParams '投影参数
Dim objSpheroid As New soPJSpheroid '椭球参数
Dim objDatum As New soPJDatum '大地参照系
Dim objPrimeMeridian As New soPJPrimeMeridian '中央经线
Dim objDatasource As soDataSource
Dim bResult As Boolean
Dim objDataset As soDatasetVector
Dim objRecordset As soRecordset
Dim objGeometry As soGeometry
Dim i As Integer
Set objDatasource = SuperWorkspace1.Datasources(1)
Set objPCS = objDatasource.PJCoordSys
If objPCS.Projection = -1 Then
objSpheroid.Type = -1 '椭球参数类型：-1为自定义
objSpheroid.Axis = 6378156 '地球赤道半径（椭球体半长轴）
objSpheroid.Flatten = 1 / 298.3 '地球椭球体的扁率
objDatum.Type = -1 '大地参照系类型
Set objDatum.PJSpheroid = objSpheroid '大地参照系所依托的地球椭球参数
objPrimeMeridian.Type = scPrimeMeridian_GREENWICH '中央经线类型
objGCS.Type = -1 '地理坐标系的类型：-1为自定义
objGCS.CoordUnits = scuDegree '地理坐标系的单位，固定为角度
Set objGCS.PJDatum = objDatum '地理坐标系所依托的大地参照系
Set objGCS.PJPrimeMeridian = objPrimeMeridian '地理坐标系的中央经线
'投影参数
objParams.CentralMeridian = 110 '中央经线 = '坐标原点之经度值
objParams.CentralParallel = 0 '坐标原点之纬度值
objParams.StandardParallel1 = 25 '双标准纬度之一
objParams.StandardParallel2 = 47 '双标准纬度之二
'设置投影系的属性
objPCS.Type = scPCS_USER_DEFINED '投影系的类型
objPCS.CoordUnits = scuMeter '投影系的坐标单位
objPCS.Projection = scPRJ_ALBERS '投影方式
Set objPCS.PJParams = objParams '投影参数
Set objPCS.GeoCoordSys = objGCS '投影系所依赖的地理坐标系
objPCS.Forward objDatasource
Set objDataset = objDatasource.Datasets(1)
Set objRecordset = objDataset.Query("", True)
objRecordset.MoveFirst
For i = 1 To objRecordset.RecordCount
Set objGeometry = objRecordset.GetGeometry
bResult = objPCS.Forward(objGeometry)
objRecordset.Edit
objRecordset.SetGeometry objGeometry
objRecordset.Update
objRecordset.MoveNext
Next
objDatasource.PJCoordSys = objPCS
SuperMap1.Layers.RemoveAll
SuperMap1.Layers.AddDataset objDataset, True
SuperMap1.ViewEntire
SuperMap1.Refresh
End If
Set objPCS = Nothing
Set objGCS = Nothing
Set objParams = Nothing
Set objDatum = Nothing
Set objSpheroid = Nothing
Set objPrimeMeridian = Nothing
Set objDatasource = Nothing
Set objDataset = Nothing
Set objRecordset = Nothing
Set objGeometry = Nothing
End Sub
Private Sub Form_Load()
Dim objDatasource As soDataSource
SuperMap1.Connect SuperWorkspace1.Handle
Set objDatasource = SuperWorkspace1.OpenDataSource(App.Path & "\..\Data\PrjSample\wgs84.sdb", "world", sceSDBPlus, False)
If objDatasource Is Nothing Then Exit Sub
Dim i As Integer
For i = 1 To objDatasource.Datasets.Count
SuperMap1.Layers.AddDataset objDatasource.Datasets(i), True
Next
SuperMap1.ViewEntire
SuperMap1.Refresh
Set objDatasource = Nothing
End Sub
Private Sub SuperMap1_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
Dim strBL As String
Dim strXY As String
Dim pointXY As New soPoint
Dim mx As Single
Dim my As Single
mx = ScaleX(x, vbTwips, vbPixels)
my = ScaleY(y, vbTwips, vbPixels)
pointXY.x = Round(SuperMap1.PixelToMapX(mx), 3)
pointXY.y = Round(SuperMap1.PixelToMapY(my), 3)
strXY = "X:" & pointXY.x & " Y:" & pointXY.y
Dim objDatasource As soDataSource
Set objDatasource = SuperWorkspace1.Datasources(1)
If objDatasource Is Nothing Then Exit Sub
If (objDatasource.PJCoordSys.Inverse(pointXY)) Then
pointXY.x = Round(pointXY.x, 3)
pointXY.y = Round(pointXY.y, 3)
strBL = "经度：" & pointXY.x & " 纬度:" & pointXY.y
Else
strBL = ""
End If
StatusBar1.Panels(2).Text = strXY & " " & strBL
Set pointXY = Nothing
End Sub
Private Sub Toolbar1_ButtonClick(ByVal Button As MSComctlLib.Button)
Select Case Button.Index
Case 1
SuperMap1.Action = scaSelect
Case 2
SuperMap1.Action = scaZoomIn
Case 3
SuperMap1.Action = scaZoomOut
Case 4
SuperMap1.Action = scaZoomFree
Case 5
SuperMap1.Action = scaPan
Case 6
SuperMap1.ViewEntire
Case 8
frmPCSProp.Show
SuperMap1.ViewEntire
SuperMap1.Refresh
End Select
End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -