📄 frmmain.frm
字号:
VERSION 5.00
Object = "{03ED3B1E-ED1B-4A2E-8FE3-D8D1A673F5D4}#5.2#0"; "SuperMap.ocx"
Begin VB.Form frmMain
BorderStyle = 1 'Fixed Single
Caption = "导航图与点视图"
ClientHeight = 6375
ClientLeft = 705
ClientTop = 1155
ClientWidth = 10170
Icon = "frmMain.frx":0000
LinkTopic = "Form1"
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 6375
ScaleWidth = 10170
StartUpPosition = 2 'CenterScreen
Begin SuperMapLib.SuperMap SuperMap1
Height = 5775
Left = 30
TabIndex = 14
Top = 510
Width = 6855
_Version = 327682
_ExtentX = 12091
_ExtentY = 10186
_StockProps = 160
Appearance = 1
End
Begin SuperMapLib.SuperWorkspace SuperWorkspace1
Left = 1920
Top = 2280
_Version = 327682
_ExtentX = 847
_ExtentY = 847
_StockProps = 0
End
Begin VB.CheckBox chkPoint_ZoomIn
Caption = "点放大"
CausesValidation= 0 'False
Height = 255
Left = 7110
TabIndex = 13
Top = 2700
Width = 975
End
Begin VB.Frame Frame2
Height = 3645
Left = 6975
TabIndex = 8
Top = 2700
Width = 3180
Begin VB.TextBox txtZoom_Multiplier
Height = 315
HideSelection = 0 'False
Left = 1110
TabIndex = 11
Text = "2.0"
Top = 3225
Width = 1935
End
Begin VB.PictureBox pic1
BackColor = &H000000FF&
Height = 2730
Left = 1620
ScaleHeight = 2730
ScaleWidth = 15
TabIndex = 10
Top = 345
Width = 15
End
Begin VB.PictureBox pic2
BackColor = &H000000FF&
Height = 15
Left = 135
ScaleHeight = 15
ScaleWidth = 2895
TabIndex = 9
Top = 1710
Width = 2895
End
Begin SuperMapLib.SuperMap SuperMap3
Height = 2775
Left = 90
TabIndex = 16
Top = 270
Width = 2955
_Version = 327682
_ExtentX = 5212
_ExtentY = 4895
_StockProps = 160
Appearance = 1
End
Begin VB.Label label4
Caption = "放缩倍数："
Height = 255
Left = 120
TabIndex = 12
Top = 3285
Width = 990
End
End
Begin VB.Frame Frame1
Caption = "导航图"
Height = 2145
Left = 6945
TabIndex = 7
Top = 480
Width = 3180
Begin SuperMapLib.SuperMap SuperMap2
Height = 1890
Left = 30
TabIndex = 15
Top = 195
Width = 3060
_Version = 327682
_ExtentX = 5397
_ExtentY = 3334
_StockProps = 160
Appearance = 1
End
End
Begin VB.CommandButton btnClose
Caption = "关闭"
Height = 450
Left = 8595
TabIndex = 6
Top = 15
Width = 1545
End
Begin VB.CommandButton btnViewEntire
Caption = "全幅显示"
Height = 450
Left = 7050
TabIndex = 5
Top = 15
Width = 1545
End
Begin VB.CommandButton btnZoomFree
Caption = "自由缩放"
Height = 450
Left = 5640
TabIndex = 4
Top = 15
Width = 1410
End
Begin VB.CommandButton btnZoomOut
Caption = "缩小"
Height = 450
Left = 4200
TabIndex = 3
Top = 15
Width = 1440
End
Begin VB.CommandButton btnZoomIn
Caption = "放大"
Height = 450
Left = 2820
TabIndex = 2
Top = 15
Width = 1380
End
Begin VB.CommandButton btnPan
Caption = "漫游"
Height = 450
Left = 1410
TabIndex = 1
Top = 15
Width = 1410
End
Begin VB.CommandButton btnSelect
Caption = "选择"
Height = 450
Left = 45
TabIndex = 0
Top = 15
Width = 1365
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下的World.sdb和World.sdd两个文件
'操作说明：
' 1、鹰眼图功能：放大地图窗口的地图，看导航图窗口的的变化。在导航图窗口中点击左键，看地图窗口的变化。
' 2、点视图功能：选中点视图检查框，在地图窗口中移动鼠标，看点视图窗口的变化。
'===================================SuperMap Objects示范工程说明结束=====================================
Option Explicit
'定义全局变量，确定鼠标指针的形状
Dim iStartPointx As Integer
Dim iStartPointy As Integer
Private Sub btnSelect_Click()
SuperMap1.Action = scaSelect '选择
End Sub
Private Sub btnPan_Click()
SuperMap1.Action = scaPan '漫游
End Sub
Private Sub btnZoomIn_Click()
SuperMap1.Action = scaZoomIn '放大
End Sub
Private Sub btnZoomOut_Click()
SuperMap1.Action = scaZoomOut '缩小
End Sub
Private Sub btnZoomFree_Click()
SuperMap1.Action = scaZoomFree '自由缩放
End Sub
Private Sub btnViewEntire_Click()
SuperMap1.ViewEntire '全幅显示
End Sub
Private Sub btnClose_Click() '关闭
Unload Me
End Sub
Private Sub Form_Load()
SuperMap1.Connect SuperWorkspace1.object '地图窗口与工作空间建立连接
SuperMap2.Connect SuperWorkspace1.object '预览框与工作空间建立连接
SuperMap3.Connect SuperWorkspace1.object '点放大视图与工作空间建立连接
Dim strAlias As String '定义supermap数据源名
Dim nEngingType As seEngineType '定义引擎类型
Dim strDatasourceName As String '定义数据源名
Dim strMapName As String
Dim objDatasource As soDataSource '定义将要打开的数据源
Dim objDataset As soDataset
Dim breadOnly As Boolean '定义文件是否只读
Dim objLayer As soLayer '定义打开的图层
Dim bAddToHead As Boolean '定义是否加到最上面
Dim i As Integer '定义循环变量
'定义预览框
Dim objLine As New soGeoLine
Dim objPoints As New soPoints
Dim dWidth As Double
Dim dHeight As Double
Dim dx As Double
Dim dy As Double
strMapName = "world"
nEngingType = sceSDBPlus '定义打开的源数据类型
strDatasourceName = App.Path & "\..\Data\World\World.sdb" '打开的路径初值
breadOnly = True
'打开数据源
Set objDatasource = SuperWorkspace1.OpenDataSource(strDatasourceName, strAlias, nEngingType, breadOnly)
If objDatasource Is Nothing Then
MsgBox "打开数据源失败", vbInformation
Else
'将数据源的说有图层加到supermap
bAddToHead = True
Set objDataset = objDatasource.Datasets("grid")
If Not objDataset Is Nothing Then
SuperMap1.Layers.AddDataset objDataset, bAddToHead
SuperMap2.Layers.AddDataset objDataset, bAddToHead
SuperMap3.Layers.AddDataset objDataset, bAddToHead
End If
Set objDataset = objDatasource.Datasets.Item("world")
If Not objDataset Is Nothing Then
SuperMap1.Layers.AddDataset objDataset, bAddToHead
SuperMap2.Layers.AddDataset objDataset, bAddToHead
SuperMap3.Layers.AddDataset objDataset, bAddToHead
End If
Set objDataset = objDatasource.Datasets.Item("Country_Lable")
If Not objDataset Is Nothing Then
SuperMap1.Layers.AddDataset objDataset, bAddToHead
SuperMap2.Layers.AddDataset objDataset, bAddToHead
SuperMap3.Layers.AddDataset objDataset, bAddToHead
End If
SuperMap2.Action = scaNull
SuperMap3.Action = scaNull
End If
'刷新地图窗口
SuperMap1.Refresh
SuperMap2.Refresh
SuperMap3.Refresh
SuperMap2.MarginPanEnable = False
SuperMap3.MarginPanEnable = False
pic1.Left = SuperMap3.Width / 2 + SuperMap3.Left
pic2.Top = SuperMap3.Height / 2 + SuperMap3.Top
pic1.ZOrder 0
pic2.ZOrder 0
iStartPointx = 0
iStartPointy = 0
'释放内存
Set objDatasource = Nothing
Set objLayer = Nothing
Set objLine = Nothing
Set objPoints = Nothing
End Sub
Private Sub Form_Resize()
pic1.Left = SuperMap3.Width / 2 + SuperMap3.Left
pic1.Top = SuperMap3.Top
pic2.Top = SuperMap3.Height / 2 + SuperMap3.Top
pic2.Left = SuperMap3.Left
pic1.ZOrder 0
pic2.ZOrder 0
End Sub
Private Sub Form_Unload(Cancle As Integer)
SuperMap1.Close
SuperMap2.Close
SuperMap3.Close
SuperMap1.Disconnect
SuperMap2.Disconnect
SuperMap3.Disconnect
SuperWorkspace1.Close
End Sub
'选择放大
Private Sub chkPoint_zoomin_Click()
If chkPoint_ZoomIn.Value = 1 Then
txtZoom_Multiplier.Enabled = True
Else
txtZoom_Multiplier.Enabled = False
SuperMap3.ViewEntire
End If
End Sub
'画矩形
Private Sub SuperMap1_AfterMapDraw(ByVal hdc As stdole.OLE_HANDLE)
Dim objRect As soRect
Dim objStyle As New soStyle
Dim objLine As New soGeoLine
Dim objPoints As New soPoints
Dim dWidth As Double
Dim dHeight As Double
Dim dx As Double
Dim dy As Double
Set objRect = SuperMap1.ViewBounds
If objRect Is Nothing Then Exit Sub
'get the supermap1.viewbound ,and convert to rect
dWidth = objRect.Width()
dHeight = objRect.Height()
dx = objRect.TopLeft.X
dy = objRect.TopLeft.Y
'create a new rect ,and add points of the supermap1.viewbound
objPoints.Add2 dx, dy
objPoints.Add2 dx, dy - dHeight
objPoints.Add2 dx + dWidth, dy - dHeight
objPoints.Add2 dx + dWidth, dy
objPoints.Add2 dx, dy
objLine.AddPart objPoints
objStyle.PenColor = vbRed
objStyle.PenWidth = 8
SuperMap2.TrackingLayer.ClearEvents
SuperMap2.TrackingLayer.AddEvent objLine, objStyle, ""
SuperMap2.TrackingLayer.Refresh
Set objRect = Nothing
Set objStyle = Nothing
Set objLine = Nothing
Set objPoints = Nothing
End Sub
Private Sub SuperMap1_Mousemove(Button As Integer, Shift As Integer, X As Single, Y As Single)
'定义当前在注视图中在图上的点位
Dim dXRecent As Double
Dim dYRecent As Double
'定义放缩比例
Dim Zoom_rule As Double
Dim Zoom_size As Double
'取得显示区周围的坐标
'判断是否选择点放大
If chkPoint_ZoomIn.Value = vbChecked Then
If chkPoint_ZoomIn.Enabled = True Then
'中点坐标转换
dXRecent = SuperMap1.PixelToMapX(ScaleX(X, vbTwips, vbPixels))
dYRecent = SuperMap1.PixelToMapY(ScaleY(Y, vbTwips, vbPixels))
If txtZoom_Multiplier.Text = "" Then '判断是否为空格
Zoom_size = 1
Else
Zoom_size = txtZoom_Multiplier.Text
End If
If Zoom_size > 0 And Zoom_size <= 100000 Then '判断是否在 0.000001 与 100000 之间
Zoom_rule = Zoom_size
Else
If Zoom_size > 100000 Then
txtZoom_Multiplier.Text = 100000
Zoom_rule = 100000
End If
End If
'画点视图放大图
SuperMap3.CenterX = dXRecent
SuperMap3.CenterY = dYRecent
SuperMap3.ViewScale = SuperMap1.ViewScale * Zoom_size
SuperMap3.Refresh
SuperMap1.Refresh
End If
End If
End Sub
'点击一览图上的点确定主视图位置
Private Sub SuperMap2_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim xPosition As Double
Dim yPosition As Double
xPosition = SuperMap2.PixelToMapX(ScaleX(X, vbTwips, vbPixels))
yPosition = SuperMap2.PixelToMapY(ScaleY(Y, vbTwips, vbPixels))
SuperMap1.CenterX = xPosition
SuperMap1.CenterY = yPosition
SuperMap1.Refresh
End Sub
Private Sub txtZoom_Multiplier_KeyPress(KeyAscii As Integer)
If KeyAscii > Asc("9") Or KeyAscii < Asc("0") Then
If (KeyAscii <> vbKeyBack) And (KeyAscii <> Asc(".")) Then
KeyAscii = 0
Beep
End If
End If
End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -