frmoverview.frm

这个是利用地理信息系统组件MO做的武汉道路污染源强的分析系统。

VERSION 5.00
Object = "{9BD6A640-CE75-11D1-AF04-204C4F4F5020}#2.0#0"; "Mo20.ocx"
Begin VB.Form frmOverview 
   Caption         =   "Overview"
   ClientHeight    =   2295
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   2865
   LinkTopic       =   "Form2"
   ScaleHeight     =   2295
   ScaleWidth      =   2865
   StartUpPosition =   3  '窗口缺省
   Begin MapObjects2.Map mapOverview 
      Height          =   2175
      Left            =   0
      TabIndex        =   0
      Top             =   0
      Width           =   2775
      _Version        =   131072
      _ExtentX        =   4895
      _ExtentY        =   3836
      _StockProps     =   225
      BackColor       =   16777215
      BorderStyle     =   1
      Appearance      =   1
      Contents        =   "frmOverview.frx":0000
   End
End
Attribute VB_Name = "frmOverview"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'=============================================================================

Option Explicit

' -- window position and state

Private Declare Function SetWindowPos Lib "user32" (ByVal hWnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long

Private Const HWND_TOPMOST = -1
Private Const HWND_NOTOPMOST = -2

Dim mMaps As New Collection
Dim mExtent As MapObjects2.Rectangle

Private Sub Form_Load()
 
StayOnTop True

End Sub

Private Sub mapOverview_BeforeTrackingLayerDraw(ByVal hDC As stdole.OLE_HANDLE)

Dim lSym As MapObjects2.Symbol, l As MapObjects2.line
Dim pts As MapObjects2.Points, p As MapObjects2.point

' -- draw the extent as a thick red line

If Not mExtent Is Nothing Then
  Set lSym = New MapObjects2.Symbol
  lSym.SymbolType = moLineSymbol
  lSym.Color = moRed
  lSym.Size = 3

  Set l = New MapObjects2.line
  Set pts = New MapObjects2.Points
  Set p = New MapObjects2.point
  p.X = mExtent.Left
  p.Y = mExtent.Bottom
  pts.Add p
  Set p = New MapObjects2.point
  p.X = mExtent.Left
  p.Y = mExtent.Top
  pts.Add p
  Set p = New MapObjects2.point
  p.X = mExtent.Right
  p.Y = mExtent.Top
  pts.Add p
  Set p = New MapObjects2.point
  p.X = mExtent.Right
  p.Y = mExtent.Bottom
  pts.Add p
  Set p = New MapObjects2.point
  p.X = mExtent.Left
  p.Y = mExtent.Bottom
  pts.Add p
  l.Parts.Add pts
  
  mapOverview.DrawShape l, lSym
End If

End Sub

Private Sub mapOverview_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)

Dim e As MapObjects2.Rectangle

' -- let the user create a new extent with the left mouse button or begin
' -- dragging the current extent with the right

If Button = 1 Then
  Set mExtent = mapOverview.TrackRectangle
  UpdateMaps
Else
  MoveExtent mapOverview.ToMapPoint(X, Y)
End If

End Sub

Private Sub mapOverview_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)

' -- continue dragging the extent

If Button = 2 Then
  MoveExtent mapOverview.ToMapPoint(X, Y)
End If

End Sub

Private Sub mapOverview_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)

' -- finish dragging the extent

If Button = 2 Then
  UpdateMaps
End If

End Sub

Private Sub MoveExtent(p As MapObjects2.point)

Dim c As MapObjects2.point

' -- shift the extent to a new center point and draw it

Set c = mExtent.Center
mExtent.Offset p.X - c.X, p.Y - c.Y
mapOverview.TrackingLayer.Refresh True

End Sub

Private Sub UpdateMaps()

Dim m As MapObjects2.Map

' -- set the new extent on each of the maps

For Each m In mMaps
  m.extent = mExtent
Next m

End Sub

Public Sub AddLayer(ml As MapObjects2.MapLayer)

' -- add a layer to show on the overview map

'mapOverview.Layers.Add ml
End Sub

Public Sub AddMap(m As MapObjects2.Map)

' -- add a map to update when the extent is changed

mMaps.Add m

End Sub

Public Sub SetExtent(e As MapObjects2.Rectangle)

' -- receive a new extent from an external source

Set mExtent = e
If Me.Visible Then
  mapOverview.TrackingLayer.Refresh True
End If

End Sub

Public Sub SetFullExtent(e As MapObjects2.Rectangle)

' -- set the full extent for the overview map

mapOverview.fullextent = e
mapOverview.extent = mapOverview.fullextent

End Sub
 
Public Sub StayOnTop(onTop As Boolean)

Dim fLeft As Long, fTop As Long, fWidth As Long, fHeight As Long
Dim fState As Long

' -- set the "always on top" mode for this form

fLeft = Me.Left / Screen.TwipsPerPixelX
fTop = Me.Top / Screen.TwipsPerPixelY
fWidth = Me.Width / Screen.TwipsPerPixelX
fHeight = Me.Height / Screen.TwipsPerPixelY

If onTop Then
  fState = HWND_TOPMOST
Else
  fState = HWND_NOTOPMOST
End If

SetWindowPos Me.hWnd, fState, fLeft, fTop, fWidth, fHeight, 0

End Sub