📄 form1.frm
字号:
VERSION 5.00
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCTL.OCX"
Object = "{9BD6A640-CE75-11D1-AF04-204C4F4F5020}#2.0#0"; "Mo20.ocx"
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "COMDLG32.OCX"
Begin VB.Form Form1
Caption = "Form1"
ClientHeight = 7305
ClientLeft = 60
ClientTop = 450
ClientWidth = 10065
LinkTopic = "Form1"
ScaleHeight = 7305
ScaleWidth = 10065
StartUpPosition = 3 '窗口缺省
Begin MSComctlLib.StatusBar StatusBar1
Align = 2 'Align Bottom
Height = 495
Left = 0
TabIndex = 2
Top = 6810
Width = 10065
_ExtentX = 17754
_ExtentY = 873
_Version = 393216
BeginProperty Panels {8E3867A5-8586-11D1-B16A-00C0F0283628}
NumPanels = 2
BeginProperty Panel1 {8E3867AB-8586-11D1-B16A-00C0F0283628}
Object.Width = 8820
MinWidth = 8820
EndProperty
BeginProperty Panel2 {8E3867AB-8586-11D1-B16A-00C0F0283628}
Object.Width = 8820
MinWidth = 8820
EndProperty
EndProperty
End
Begin MSComctlLib.ImageList ImageList1
Left = 6000
Top = 0
_ExtentX = 1005
_ExtentY = 1005
BackColor = -2147483643
ImageWidth = 24
ImageHeight = 24
MaskColor = 12632256
_Version = 393216
BeginProperty Images {2C247F25-8591-11D1-B16A-00C0F0283628}
NumListImages = 6
BeginProperty ListImage1 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "Form1.frx":0000
Key = ""
EndProperty
BeginProperty ListImage2 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "Form1.frx":0112
Key = ""
EndProperty
BeginProperty ListImage3 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "Form1.frx":0224
Key = ""
EndProperty
BeginProperty ListImage4 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "Form1.frx":0336
Key = ""
EndProperty
BeginProperty ListImage5 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "Form1.frx":0448
Key = ""
EndProperty
BeginProperty ListImage6 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "Form1.frx":055A
Key = ""
EndProperty
EndProperty
End
Begin MSComctlLib.Toolbar Toolbar1
Align = 1 'Align Top
Height = 540
Left = 0
TabIndex = 1
Top = 0
Width = 10065
_ExtentX = 17754
_ExtentY = 953
ButtonWidth = 820
ButtonHeight = 794
Appearance = 1
ImageList = "ImageList1"
_Version = 393216
BeginProperty Buttons {66833FE8-8583-11D1-B16A-00C0F0283628}
NumButtons = 6
BeginProperty Button1 {66833FEA-8583-11D1-B16A-00C0F0283628}
ImageIndex = 1
Style = 2
EndProperty
BeginProperty Button2 {66833FEA-8583-11D1-B16A-00C0F0283628}
ImageIndex = 2
Style = 2
EndProperty
BeginProperty Button3 {66833FEA-8583-11D1-B16A-00C0F0283628}
ImageIndex = 3
Style = 2
EndProperty
BeginProperty Button4 {66833FEA-8583-11D1-B16A-00C0F0283628}
ImageIndex = 4
Style = 2
EndProperty
BeginProperty Button5 {66833FEA-8583-11D1-B16A-00C0F0283628}
ImageIndex = 5
Style = 2
EndProperty
BeginProperty Button6 {66833FEA-8583-11D1-B16A-00C0F0283628}
ImageIndex = 6
Style = 2
EndProperty
EndProperty
Begin MSComDlg.CommonDialog CommonDialog1
Left = 4320
Top = 120
_ExtentX = 847
_ExtentY = 847
_Version = 393216
End
End
Begin MapObjects2.Map Map1
Height = 5775
Left = 120
TabIndex = 0
Top = 960
Width = 9855
_Version = 131072
_ExtentX = 17383
_ExtentY = 10186
_StockProps = 225
BackColor = 16777215
BorderStyle = 1
Contents = "Form1.frx":08B8
End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Dim line1 As MapObjects2.Line
Dim mappcs As New MapObjects2.ProjCoordSys
Dim mapgcs As New MapObjects2.GeoCoordSys
Private Sub Layer_Load()
Dim dc As New DataConnection '建立新的数据库连接，定义变量dc
Dim gset As GeoDataset
Dim name As String '定义一个调用数据文件的名称的字符串变量
Dim curlayerName As String '定义一个图层名字的字符串变量
Dim layer As New MapObjects2.MapLayer '定义一个新的图层变量
On Error GoTo err '出错时结束
CommonDialog1.Filter = "图层文件(*.shp)| *.shp|"
CommonDialog1.ShowOpen '弹出“打开式”对话框
CommonDialog1.CancelError = True '单击Cancel按钮关闭对话框时，将显示出错信息
If Len(CommonDialog1.FileName) = 0 Then Exit Sub '如果没有选择任何一个文件，将退出对话框
dc.Database = CurDir '返回用户选中文件的路径
If Not dc.Connect Then '验证数据连接是否成功
MsgBox "加载示例数据失败"
Exit Sub '连接失败则退出程序
End If
name = CommonDialog1.FileTitle '把指定文件对话框中选择的文件名赋给变量name
If Trim(name) <> "" Then '在去掉name两边空的字符串后，验证name是否为空
curlayerName = Left(name, Len(name) - 4) '去掉name字符串的后缀名,返回前Len(name) - 4字符串
Set gset = dc.FindGeoDataset(curlayerName)
If gset Is Nothing Then Exit Sub '如果没有图层退出
Set layer.GeoDataset = dc.FindGeoDataset(curlayerName) '增加新图层与数据的连接
Dim i As Integer '定义整形变量i
Dim lyrs As MapObjects2.Layers '定义lyrs为图层集对象
Set lyrs = Map1.Layers
If lyrs.Count = 0 Then Map1.Layers.Add layer
If lyrs.Count > 0 Then
For i = 0 To lyrs.Count - 1
If lyrs.Item(i).name <> curlayerName Then
lyrs.Add layer
End If
Next i
End If
Map1.Refresh
'打开按钮恢复原状
Toolbar1.Buttons(1).Value = 0
Else: Exit Sub
End If
err:
End Sub
Private Sub Map1_AfterTrackingLayerDraw(ByVal hDC As stdole.OLE_HANDLE)
Dim sym As New MapObjects2.Symbol
'线特征
If Not line1 Is Nothing Then
sym.Style = moDashLine
sym.Color = moRed
Map1.DrawShape line1, sym
End If
End Sub
Private Sub Map1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim r As New MapObjects2.Rectangle '定义r为一个新的矩形框变量
Dim p As MapObjects2.Point '定义p为点对象
Set p = Map1.ToMapPoint(X, Y) '控制坐标转换为地图坐标p
Select Case Map1.MousePointer
Case moPan '地图漫游
Map1.Pan
Case moZoomIn '地图放大
Set r = Map1.Extent
r.ScaleRectangle (0.5)
Map1.Extent = r
Case moZoomOut '地图缩小
Set r = Map1.Extent
r.ScaleRectangle (2)
Map1.Extent = r
End Select
Dim coordsys As Object
Dim uni As MapObjects2.Unit
Dim lyr As MapObjects2.MapLayer
Dim he As String
Set lyr = Map1.Layers(0)
Set coordsys = lyr.CoordinateSystem
Set uni = coordsys.Unit
he = uni.name
If Toolbar1.Buttons(6).Value = tbrPressed Then
Set line1 = Map1.TrackLine
Map1.TrackingLayer.Refresh True
StatusBar1.Panels(1).Text = "地图距离=" & Format(line1.Length, "#.00") & he
StatusBar1.Panels(2).Text = "控件距离=" & Format(Map1.FromMapDistance(line1.Length), "#.00")
Map1.TrackingLayer.Refresh True
End If
End Sub
Private Sub Toolbar1_ButtonClick(ByVal Button As MSComctlLib.Button)
Select Case Button.Index
Case 1 '载入图层数据
Call Layer_Load
Case 2 '呈现放大形状
Map1.MousePointer = moZoomIn
Case 3 '呈现缩小形状
Map1.MousePointer = moZoomOut
Case 5 '地图全屏
Map1.Extent = Map1.FullExtent
Map1.MousePointer = moDefault
Case 4 '呈现漫游形状
Map1.MousePointer = moPan
Case 6 '恢复原始状态
Map1.MousePointer = moDefault
End Select
If Map1.Layers.Count > 0 Then
'给map1设置坐标系
If Map1.CoordinateSystem Is Nothing Then
If Map1.Layers(0).CoordinateSystem.IsProjected Then
Dim mappcs As New MapObjects2.ProjCoordSys
mappcs.Type = Map1.Layers(0).CoordinateSystem.Type
Map1.CoordinateSystem = mappcs
ElseIf Not Map1.Layers(0).CoordinateSystem.IsProjected Then
Dim mapgcs As New MapObjects2.GeoCoordSys
mapgcs.Type = "4326"
Map1.CoordinateSystem = mapgcs
End If
End If
End If
End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -