frmmain.frm
来自「都是基于VB所做的程序集合,值得大家作为实践的参考资料.」· FRM 代码 · 共 419 行
FRM
419 行
VERSION 5.00
Object = "{03ED3B1E-ED1B-4A2E-8FE3-D8D1A673F5D4}#5.2#0"; "SuperMap.ocx"
Object = "{4FC91D58-577E-4757-BB48-21E286FB41BF}#5.2#0"; "SUPERL~1.OCX"
Begin VB.Form FrmMain
BorderStyle = 3 'Fixed Dialog
Caption = "SuperLayout-Sample"
ClientHeight = 6945
ClientLeft = 45
ClientTop = 330
ClientWidth = 9375
Icon = "frmmain.frx":0000
LinkTopic = "Form1"
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 6945
ScaleWidth = 9375
ShowInTaskbar = 0 'False
StartUpPosition = 2 'CenterScreen
Begin SuperMapLib.SuperMap SuperMap1
Height = 1875
Left = 45
TabIndex = 19
Top = 5025
Width = 2625
_Version = 327682
_ExtentX = 4630
_ExtentY = 3307
_StockProps = 160
Appearance = 1
End
Begin SuperLayoutLib.SuperLayout SuperLayout1
Height = 6855
Left = 2760
TabIndex = 20
Top = 45
Width = 6585
_Version = 327682
_ExtentX = 11615
_ExtentY = 12091
_StockProps = 0
End
Begin SuperMapLib.SuperWorkspace SuperWorkspace1
Left = 4140
Top = 4680
_Version = 327682
_ExtentX = 847
_ExtentY = 847
_StockProps = 0
End
Begin VB.Frame Frame2
Height = 1665
Left = 30
TabIndex = 12
Top = -45
Width = 2640
Begin VB.CommandButton CmdExit
Caption = "退 出"
Height = 390
Left = 1350
TabIndex = 18
Top = 1125
Width = 1215
End
Begin VB.CommandButton CmdClear
Caption = "清除布局"
Height = 390
Left = 75
TabIndex = 17
Top = 1125
Width = 1215
End
Begin VB.CommandButton CmdSelect
Caption = "选 择"
Height = 390
Left = 75
TabIndex = 16
Top = 225
Width = 1215
End
Begin VB.CommandButton CmdPan
Caption = "漫 游"
Height = 390
Left = 1350
TabIndex = 15
Top = 675
Width = 1215
End
Begin VB.CommandButton CmdZoomOut
Caption = "缩 小"
Height = 390
Left = 75
TabIndex = 14
Top = 675
Width = 1215
End
Begin VB.CommandButton CmdZoomIn
Caption = "放 大"
Height = 390
Left = 1350
TabIndex = 13
Top = 225
Width = 1215
End
End
Begin VB.Frame Frame1
Height = 3000
Left = 30
TabIndex = 0
Top = 1620
Width = 2655
Begin VB.ComboBox cbCountries
ForeColor = &H000000FF&
Height = 315
Left = 90
TabIndex = 21
Top = 570
Width = 2430
End
Begin VB.TextBox txtMapHeight
Height = 315
Left = 1050
TabIndex = 3
Text = "15"
Top = 1950
Width = 855
End
Begin VB.TextBox txtMapWidth
Height = 315
Left = 1050
TabIndex = 2
Text = "15"
Top = 1500
Width = 855
End
Begin VB.TextBox txtLabel
Height = 315
Left = 945
TabIndex = 1
Text = "地图标题"
Top = 1050
Width = 1500
End
Begin VB.CommandButton cmdOk
Caption = "生成该国家的布局"
Height = 375
Left = 150
TabIndex = 4
Top = 2475
Width = 2265
End
Begin VB.Label Label5
AutoSize = -1 'True
Caption = "请选择要显示的国家或地区："
Height = 195
Left = 150
TabIndex = 10
Top = 300
Width = 2340
End
Begin VB.Label Label1
Caption = "地图标题:"
Height = 255
Left = 75
TabIndex = 9
Top = 1050
Width = 735
End
Begin VB.Label Label2
Caption = "图宽"
Height = 255
Left = 525
TabIndex = 8
Top = 1500
Width = 495
End
Begin VB.Label Label3
Caption = "图高"
Height = 255
Left = 525
TabIndex = 7
Top = 1950
Width = 495
End
Begin VB.Label Label4
Caption = "厘米"
Height = 255
Index = 0
Left = 2025
TabIndex = 6
Top = 1500
Width = 375
End
Begin VB.Label Label4
Caption = "厘米"
Height = 255
Index = 1
Left = 2025
TabIndex = 5
Top = 1950
Width = 375
End
End
Begin VB.Label Label6
Caption = "地图浏览"
Height = 240
Left = 45
TabIndex = 11
Top = 4740
Width = 1140
End
End
Attribute VB_Name = "FrmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'=====================================SuperMap Objects示范工程说明=======================================
'
'功能简介：本示范工程演示了在Layout中动态生成地图，并自动调节地图比例尺和位置，使地图充满图框。
'所用控件：SuperWorkspace、SuperLayout和SuperMap
'所用数据：\..\Data\World\下World.sdb、World.sdd和WorldMap.smw
'操作说明：
' 1、单击"选择"按钮，当布局中有对象时就可以使该对象处于被选中状态，双击该对象，就弹出该对象的属性对
' 话框，你可以通过修改对话框中的属性来改变该对象的状态；
' 2、单击"放大"按钮，当在布局中按下鼠标时放大布局视窗；
' 3、单击"缩小"按钮，当在布局中按下鼠标时缩小布局视窗；
' 4、单击"漫游"按钮，当在布局中按下鼠标并移动鼠标时可以随意浏览布局；
' 5、单击"清除布局"按钮，布局视窗上的所有对象全部清除掉；
' 6、单击"退出"按钮，结束程序
' 7、在"Combo1"中选择希望显示的国家的全图，在"地图标题"中输入布局的标题（也可以不修改，使用默认的标
' 题），再然后点"生成该国家的布局"按钮，就会在Layout窗口中出现该国家的全图，并自动生成标题；还可
' 以通过改变"图宽"、"图高"的值来控制布局中地图的大小。本示例稍做改动，就可以成为一个比较完善的自
' 动出图程序。
'
'===================================SuperMap Objects示范工程说明结束=====================================
Private Sub cbCountries_Click() '选择国家
txtLabel.Text = cbCountries.Text
End Sub
Private Sub CmdClear_Click() '清除布局
SuperLayout1.Elements.RemoveAll
SuperLayout1.Refresh
End Sub
Private Sub CmdExit_Click()
'断开所有连接，关闭工作空间，结束程序
SuperMap1.Close
SuperMap1.Disconnect
SuperWorkspace1.Close
End
End Sub
Private Sub CmdPan_Click()
SuperLayout1.LytAction = sclytActPalm '漫游布局视窗
End Sub
Private Sub CmdSelect_Click()
SuperLayout1.LytAction = sclytActSel '选择对象
End Sub
Private Sub CmdZoomIn_Click()
SuperLayout1.LytAction = sclytActZoomIn '放大布局视窗
End Sub
Private Sub CmdZoomOut_Click()
SuperLayout1.LytAction = sclytActZoomOut '缩小布局视窗
End Sub
Private Sub Form_Load()
'打开数据源，添加图层
Dim i As Integer
Dim bResult As Boolean
SuperMap1.Connect SuperWorkspace1.Handle
SuperLayout1.Connect SuperWorkspace1.Handle
bResult = SuperWorkspace1.Open(App.Path & "\..\Data\World\WorldMap.smw")
If bResult = False Then
MsgBox "打开数据失败 ! ", vbInformation, "消息："
Exit Sub
End If
SuperMap1.OpenMap "World"
SuperMap1.ViewEntire
'向cbCountries中添加数据
Dim objDatasetVector As soDatasetVector
Dim objRecordSet As soRecordset
Dim strCountry As String
Set objDatasetVector = FrmMain.SuperWorkspace1.Datasources(1).Datasets("World")
If objDatasetVector Is Nothing Then Exit Sub
Set objRecordSet = objDatasetVector.Query("", False)
If objRecordSet Is Nothing Then Exit Sub
objRecordSet.MoveFirst
For i = 1 To objRecordSet.RecordCount
If Not IsNull(objRecordSet.GetFieldValue("Country")) Then
strCountry = objRecordSet.GetFieldValue("Country")
cbCountries.AddItem strCountry, i - 1
End If
objRecordSet.MoveNext
Next i
cbCountries.ListIndex = 0
'改变页面显示比例
' SuperLayout1.ViewScale = 0.1
' SuperLayout1.Refresh
Set objDatasetVector = Nothing
Set objRecordSet = Nothing
End Sub
Private Sub Form_Resize()
On Error Resume Next
SuperLayout1.Width = Me.Width - SuperLayout1.Left
SuperLayout1.Height = Me.Height
End Sub
Private Sub Form_Unload(Cancel As Integer)
SuperMap1.Close
SuperMap1.Disconnect
SuperLayout1.Disconnect
SuperWorkspace1.Close
End Sub
Private Sub cmdOk_Click() '生成该国家的布局
Dim objLytMap As soLytMap
Dim objRect As New soRect
Dim objCountryRecord As soRecordset
Dim objGeoRegion As soGeoRegion
Dim objGeoRect As soRect
Dim objlytText As soLytText
Dim objTextStyle As New soTextStyle
Dim objDataset As soDatasetVector
Dim dMax As Double
Dim dScale As Double
'清空页面
SuperLayout1.Elements.RemoveAll
'检索所要显示的国家
Set objDataset = FrmMain.SuperWorkspace1.Datasources(1).Datasets("World")
If objDataset Is Nothing Then Exit Sub
Set objCountryRecord = objDataset.Query("Country = " & "'" & cbCountries.Text & "'", True)
If objCountryRecord Is Nothing Then
MsgBox "找不到国家" & cbCountries.Text & "!"
Exit Sub
End If
Set objGeoRegion = objCountryRecord.GetGeometry()
If objGeoRegion Is Nothing Then Exit Sub
Set objGeoRect = objGeoRegion.Bounds
If objGeoRect Is Nothing Then Exit Sub
'得到距离单位
Select Case SuperWorkspace1.Datasources.Item(1).DistanceUnits
Case scuMeter
nUnit = 10000
Case scuKilometer
nUnit = 10000000
End Select
'设置要显示国家的比例尺
Dim dScale1 As Double
Dim dScale2 As Double
dScale1 = objGeoRect.Width
dScale2 = objGeoRect.Height
If dScale1 > dScale2 Then
dMax = objDataset.Bounds.Width / dScale1
Else
dMax = objDataset.Bounds.Height / dScale2
End If
'设置地图图幅大小
objRect.Top = 500
objRect.Bottom = objRect.Top + CLng(txtMapHeight.Text) * 100
objRect.Left = 150
objRect.Right = objRect.Left + CLng(txtMapWidth.Text) * 100
'生成地图和标题
Set objLytMap = FrmMain.SuperLayout1.Elements.CreateElement(sclytMap)
If objLytMap Is Nothing Then Exit Sub
objLytMap.SetPosition objRect
objLytMap.MapName = "World"
objLytMap.ViewEntire
dScale = objLytMap.MapScale
dScale = dScale * dMax
objLytMap.MapScale = dScale
objLytMap.CenterAt objGeoRect.CenterPoint.x, objGeoRect.CenterPoint.y
'设置标题的位置
objRect.Top = 300
objRect.Left = 300
Set objlytText = FrmMain.SuperLayout1.Elements.CreateElement(sclytText)
objlytText.Text = txtLabel.Text
objlytText.SetPosition objRect
objTextStyle.Bold = True
objTextStyle.FontHeight = 80
objTextStyle.Color = vbBlue
Set objlytText.Font = objTextStyle
SuperLayout1.Refresh
'释放内存
Set objLytMap = Nothing
Set objlytText = Nothing
Set objDataset = Nothing
Set objTextStyle = Nothing
Set objRect = Nothing
End Sub
⌨️ 快捷键说明
复制代码Ctrl + C
搜索代码Ctrl + F
全屏模式F11
增大字号Ctrl + =
减小字号Ctrl + -
显示快捷键?