form1.frm

继续更新

VERSION 5.00
Object = "{9BD6A640-CE75-11D1-AF04-204C4F4F5020}#2.0#0"; "Mo20.ocx"
Object = "{C7FC2F7C-0688-11D5-B2F8-000102D87123}#1.0#0"; "MO21Legend.ocx"
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCTL.OCX"
Begin VB.Form Form1 
   Caption         =   "Form1"
   ClientHeight    =   3090
   ClientLeft      =   60
   ClientTop       =   450
   ClientWidth     =   4680
   LinkTopic       =   "Form1"
   ScaleHeight     =   3090
   ScaleWidth      =   4680
   StartUpPosition =   3  '窗口缺省
   Begin MSComctlLib.StatusBar StatusBar1 
      Align           =   2  'Align Bottom
      Height          =   255
      Left            =   0
      TabIndex        =   4
      Top             =   2835
      Width           =   4680
      _ExtentX        =   8255
      _ExtentY        =   450
      _Version        =   393216
      BeginProperty Panels {8E3867A5-8586-11D1-B16A-00C0F0283628} 
         NumPanels       =   5
         BeginProperty Panel1 {8E3867AB-8586-11D1-B16A-00C0F0283628} 
            AutoSize        =   2
            Object.Width           =   7938
            Text            =   "黄土高原生态经济数据库系统                      "
            TextSave        =   "黄土高原生态经济数据库系统                      "
         EndProperty
         BeginProperty Panel2 {8E3867AB-8586-11D1-B16A-00C0F0283628} 
            Text            =   "                                "
            TextSave        =   "                                "
         EndProperty
         BeginProperty Panel3 {8E3867AB-8586-11D1-B16A-00C0F0283628} 
         EndProperty
         BeginProperty Panel4 {8E3867AB-8586-11D1-B16A-00C0F0283628} 
            Style           =   6
            Alignment       =   2
            AutoSize        =   2
            TextSave        =   "2008-5-22"
         EndProperty
         BeginProperty Panel5 {8E3867AB-8586-11D1-B16A-00C0F0283628} 
            Style           =   5
            TextSave        =   "13:57"
         EndProperty
      EndProperty
   End
   Begin VB.CommandButton Command1 
      Caption         =   "坐标信息"
      Height          =   495
      Left            =   1080
      TabIndex        =   3
      Top             =   480
      Width           =   975
   End
   Begin MO21legend.legend legend1 
      Height          =   6855
      Left            =   120
      TabIndex        =   2
      Top             =   1200
      Width           =   2775
      _ExtentX        =   4895
      _ExtentY        =   12091
      BackColor       =   -2147483644
      ForeColor       =   -2147483630
      BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} 
         Name            =   "MS Sans Serif"
         Size            =   8.25
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
   End
   Begin MapObjects2.Map Map2 
      Height          =   2415
      Left            =   0
      TabIndex        =   1
      Top             =   8280
      Width           =   2895
      _Version        =   131072
      _ExtentX        =   5106
      _ExtentY        =   4260
      _StockProps     =   225
      BackColor       =   16777215
      BorderStyle     =   1
      Contents        =   "Form1.frx":0000
   End
   Begin MapObjects2.Map Map1 
      Height          =   10335
      Left            =   3000
      TabIndex        =   0
      Top             =   360
      Width           =   10935
      _Version        =   131072
      _ExtentX        =   19288
      _ExtentY        =   18230
      _StockProps     =   225
      BackColor       =   16777215
      BorderStyle     =   1
      Contents        =   "Form1.frx":001A
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False

Dim dc As New DataConnection
Dim layer As MapLayer
Dim r As MapObjects2.Rectangle
Dim cl(2) As ColorConstants
Dim drag As DragFeedback

Dim X1 As Integer, X2 As Integer, Y1 As Integer, Y2 As Integer
Dim xmid As Long, ymid As Long

'cl(0) = RGB(205, 191, 242) '淡紫 淡蓝RGB(190, 232, 255)  灰RGB(233, 233, 233)


Private Sub layerset()
   
   Set layer = New MapLayer
   Set layer.GeoDataset = dc.FindGeoDataset("xj")
   layer.Name = "县界"
   layer.Symbol.Color = RGB(205, 191, 242)
   Map1.Layers.Add layer
   '显示县名
   Set layer = New MapLayer
   Set layer.GeoDataset = dc.FindGeoDataset("jmd")
   layer.Name = "县市名"
   layer.Symbol.Color = moBlack
   layer.Symbol.Size = 0
   Set layer.Renderer = New LabelRenderer
   layer.Renderer.Field = "城镇点名"
   layer.Renderer.Symbol(0).Font.Size = 7
   layer.Renderer.AllowDuplicates = True
   Map1.Layers.Add layer
   
   Set layer = New MapLayer
   Set layer.GeoDataset = dc.FindGeoDataset("jmd")
   layer.Name = "居民点"
   layer.Symbol.Color = vbCyan
   Map1.Layers.Add layer
      
   Set layer = New MapLayer
   Set layer.GeoDataset = dc.FindGeoDataset("shj")
   layer.Name = "省界"
   layer.Symbol.Color = RGB(190, 232, 255)
   Map1.Layers.Add layer
   
    Set layer = New MapLayer
   Set layer.GeoDataset = dc.FindGeoDataset("jmd")
   layer.Name = "居民点"
   layer.Symbol.Color = vbCyan
   Map1.Layers.Add layer
    
   Set layer = New MapLayer
   Set layer.GeoDataset = dc.FindGeoDataset("bj")
   layer.Name = "边界"
   layer.Symbol.Color = QBColor(13)
   Map1.Layers.Add layer
   
   Set layer = New MapLayer
   Set layer.GeoDataset = dc.FindGeoDataset("continent")
   layer.Name = "州"
   layer.Symbol.Color = vbCyan
   Map1.Layers.Add layer
   
End Sub

Private Sub Command1_Click()
Dim zb As Object
Dim mylayer As MapObjects2.MapLayer
Set mylayer = Map1.Layers(0)
Set zb = mylayer.CoordinateSystem
If zb.IsProjected Then
  MsgBox "投影坐标系"
ElseIf Not zb.IsProjected Then
  MsgBox "地理坐标系"
End If
End Sub

Private Sub Form_Load()
   dc.Database = App.Path + "\..\" + "shp"    'app指proj,shp与 proj在同一层，是平行的
   If Not dc.Connect Then
      MsgBox "没找到！"
      End
   End If
   layerset
   legend1.setMapSource Map1
   legend1.LoadLegend True
   Map1.Refresh
   '给2加载图像，并与1联动
   Set layer = New MapLayer
   Set layer.GeoDataset = dc.FindGeoDataset("xj")
   layer.Symbol.Color = moPaleYellow
   Map2.Layers.Add layer
   Map2.Refresh
   
                '确定查询form坐标的参数
   X1 = 200
   X2 = Map1.Width
   Y1 = 200
   Y2 = Int(Map1.Height / 2) + 1000
   xmid = Map1.Extent.Left + Int(Map1.Extent.Width / 2)
   ymid = Map1.Extent.Top - Int(Map1.Extent.Height / 2)
End Sub

Private Sub Form_Unload(Cancel As Integer)
    Unload identify
End Sub

Private Sub legend1_AfterSetLayerVisible(index As Integer, isVisible As Boolean)
  Map1.Refresh
End Sub
Private Sub Map1_AfterLayerDraw(ByVal index As Integer, ByVal canceled As Boolean, ByVal hdc As stdole.OLE_HANDLE)
   If index = 0 Then
       Map2.TrackingLayer.Refresh True
   End If
End Sub
Private Sub Map1_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
    If Button = vbLeftButton Then                     '左键放大，右键缩小
      Set Map1.Extent = Map1.TrackRectangle
    ElseIf Button = vbRightButton Then
      Set r = Map1.Extent
      r.ScaleRectangle 1.5
      Map1.Extent = r
    End If
    
    
    Dim p As MapObjects2.Point                 '判断查询form的位置，放在四角上
    Set p = Map1.ToMapPoint(x, y)
    
    If p.x < xmid Then
       identify.Left = X2
    Else
       identify.Left = X1
    End If
    If p.y < ymid Then
       identify.Top = Y2
    Else
       identify.Top = Y1
    End If
    
    
    Call identify.idty(x, y)
    identify.ZOrder 0
    
End Sub
Private Sub Map2_AfterTrackingLayerDraw(ByVal hdc As stdole.OLE_HANDLE) '在2上画红色指示框
   Dim sym As New Symbol
   sym.OutlineColor = moRed
   sym.Size = 2
   sym.Style = moTransparentFill
   Map2.DrawShape Map1.Extent, sym
End Sub
Private Sub Map2_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
   '指示窗中改变主窗口的大小
   Dim cur As MapObjects2.Rectangle
   Dim pt As New MapObjects2.Point
   Set cur = Map2.TrackRectangle
   Set Map1.Extent = cur
   Set pt = Map2.ToMapPoint(x, y)
   Map1.CenterAt pt.x, pt.y
   '在指示窗中拖动方框
   Dim p As Point
   Set p = Map2.ToMapPoint(x, y)
   If Map1.Extent.IsPointIn(p) Then '如果点击发生在方框内，开始拖动
      Set drag = New DragFeedback
      drag.DragStart Map1.Extent, Map2, x, y
   End If
End Sub
Private Sub Map2_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
   If Not drag Is Nothing Then
      drag.DragMove x, y
   End If
End Sub
Private Sub Map2_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
   If Not drag Is Nothing Then
      Map1.Extent = drag.DragFinish(x, y)
      Set drag = Nothing
   End If
End Sub