📄 form05.frm
字号:
VERSION 5.00
Object = "{9BD6A640-CE75-11D1-AF04-204C4F4F5020}#2.0#0"; "mo20.ocx"
Begin VB.Form Form05
Caption = "世界地图"
ClientHeight = 7545
ClientLeft = 60
ClientTop = 345
ClientWidth = 10125
LinkTopic = "Form1"
ScaleHeight = 7545
ScaleWidth = 10125
StartUpPosition = 2 '屏幕中心
Begin VB.CommandButton Command1
Caption = "c1"
Height = 495
Left = 4680
TabIndex = 1
Top = 6960
Width = 1215
End
Begin MapObjects2.Map Map1
Height = 5895
Left = 0
TabIndex = 0
Top = 0
Width = 10095
_Version = 131072
_ExtentX = 17806
_ExtentY = 10398
_StockProps = 225
BackColor = 16777215
BorderStyle = 1
Contents = "Form05.frx":0000
End
Begin VB.Label Label1
Caption = "Label1"
Height = 855
Left = 720
TabIndex = 2
Top = 6000
Width = 8775
End
End
Attribute VB_Name = "Form05"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'Xuewei,2003/6/12
'Transform方法示例;
Option Explicit
Dim theShape As Object
Dim transShape As Object
Dim recs As New MapObjects2.Recordset
Dim extentStr As String
Dim sym As New MapObjects2.Symbol
Dim newsym As New MapObjects2.Symbol
Private Sub Command1_Click()
If Not theShape Is Nothing Then
Dim toCS As New MapObjects2.ProjCoordSys
toCS.Type = 54021
Set transShape = toCS.Transform(Map1.Layers(0).CoordinateSystem, theShape)
Map1.Refresh
End If
End Sub
Private Sub Form_Load()
DrawLayer '加载世界地图的Country图层;
Dim CSMap As New MapObjects2.ProjCoordSys
CSMap.Type = 54019 'World_Winkel-Ⅱ
Map1.Layers(0).CoordinateSystem = CSMap
Map1.CoordinateSystem = Map1.Layers(0).CoordinateSystem
With sym
.SymbolType = moFillSymbol
.Color = moDarkGreen
.Outline = True
End With
With newsym
.Outline = True
.OutlineColor = moRed
.Size = 1.5
.Style = moTransparentFill
End With
Command1.Caption = "Transform"
extentStr = "Map Extent: " & Map1.Extent.Left & ", " & Map1.Extent.Right & ", " & Map1.Extent.Top & ", " & Map1.Extent.Bottom
Label1.Caption = extentStr
End Sub
Private Sub Map1_AfterLayerDraw(ByVal index As Integer, ByVal canceled As Boolean, ByVal hDC As Stdole.OLE_HANDLE)
If Not theShape Is Nothing Then
Map1.DrawShape theShape, sym
Label1.Caption = extentStr & vbNewLine & "Shape1 Extent: " & theShape.Extent.Left & ", " & theShape.Extent.Right & ", " & theShape.Extent.Top & ", " & theShape.Extent.Bottom
If Not transShape Is Nothing Then
Map1.DrawShape transShape, newsym
Label1.Caption = Label1.Caption & vbNewLine & "Shape2 Extent: " & transShape.Extent.Left & ", " & transShape.Extent.Right & ", " & transShape.Extent.Top & ", " & transShape.Extent.Bottom
End If
End If
End Sub
Private Sub Map1_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
If Button = 1 Then
Dim usrPt As New MapObjects2.Point
Set usrPt = Map1.ToMapPoint(x, y)
Set recs = Map1.Layers(0).SearchShape(usrPt, moPointInPolygon, "")
If recs.Count = 1 Then
Set theShape = recs.Fields("Shape").Value
Set transShape = Nothing
Map1.Refresh
End If
'右键放大;
ElseIf Button = 2 Then
Dim r As New MapObjects2.Rectangle
Set r = Map1.TrackRectangle
Map1.Extent = r
End If
End Sub
Sub DrawLayer()
Dim dc As New DataConnection
Dim layer As MapObjects2.MapLayer
dc.Database = App.Path + "\..\" + "World"
If Not dc.Connect Then
MsgBox "在指定的文件夹下没找到图层数据文件!"
End
End If
Set layer = New MapLayer
Set layer.GeoDataset = dc.FindGeoDataset("country")
layer.Symbol.Color = moLimeGreen
Map1.Layers.Add layer
End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -