form05.frm

来自「一个关于基于MO编程的参考资料希望对大家的交流和学习有帮助」· FRM 代码 · 共 145 行

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