frmmagnifier.frm

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

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

Option Explicit

' == Windows API calls and constants

' -- 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

' -- device contexts

Private Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hDC As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long

' -- bit map manipulation

Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hDC As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long

' -- drawing

Private Declare Function CreatePen Lib "gdi32" (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As Long
Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
Private Declare Function MoveToEx Lib "gdi32" (ByVal hDC As Long, ByVal X As Long, ByVal Y As Long, lpPoint As POINTAPI) As Long
Private Declare Function LineTo Lib "gdi32" (ByVal hDC As Long, ByVal X As Long, ByVal Y As Long) As Long
Private Declare Function Rectangle Lib "gdi32" (ByVal hDC As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long

Private Declare Function GetROP2 Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function SetROP2 Lib "gdi32" (ByVal hDC As Long, ByVal nDrawMode As Long) As Long

Private Type POINTAPI
  X As Long
  Y As Long
End Type

' == module variables

Dim mForm As Form
Dim mMap As MapObjects2.Map
Dim mWidth As Long, mHeight As Long

Dim mMagnification As Double

Dim mDC As Long           ' device context for the snapshot
Dim mBitmap As Long       ' bitmap snapshot of the underlying map
Dim mOldBitmap As Long

Private Sub Form_Load()

StayOnTop True
mMagnification = 4

End Sub

Private Sub Form_Unload(Cancel As Integer)

' -- free the memory used by the snapshot and its device context

If mOldBitmap > 0 Then
  SelectObject mDC, mOldBitmap
  DeleteObject mBitmap
  DeleteDC mDC
End If

End Sub

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

If Button = 1 Then
  MoveMagnifier X, Y
End If

End Sub

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

If Button = 1 Then
  MoveMagnifier X, Y
End If

End Sub

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

DrawMap

End Sub

Private Sub DrawMap()

Dim sx As Single, sy As Single
Dim p As MapObjects2.point, e As MapObjects2.Rectangle

' -- draw the magnified map; determine the screen location of mapMagnify
' -- relative to the underlying map

Set e = New MapObjects2.Rectangle
sx = (frmMagnifier.Left + mapMagnify.Left) - (mForm.Left + mMap.Left) - (3 * Screen.TwipsPerPixelX)
sy = (frmMagnifier.Top + mapMagnify.Top) - (mForm.Top + mMap.Top) - (6 * Screen.TwipsPerPixelY)

' -- get the map extent from the underlying map based on the pixel extent
' -- of mapMagnify

Set p = mMap.ToMapPoint(sx, sy)
e.Left = p.X
e.Top = p.Y
Set p = mMap.ToMapPoint(sx + mapMagnify.Width, sy + mapMagnify.Height)
e.Right = p.X
e.Bottom = p.Y

' -- scale mapMagnify to the set magnification and display

e.ScaleRectangle 1 / mMagnification
mapMagnify.extent = e

End Sub

Private Sub MoveMagnifier(X As Single, Y As Single)

Dim mapDC As Long, tempDC As Long, bitmap As Long, oldBitmap As Long
Dim dx As Single, dy As Single
Dim sx As Long, sy As Long, w As Long, h As Long
Dim tx As Long, ty As Long

Dim mag As Single
Dim oldBrush As Long, hndBrush As Long
Dim oldPen As Long, hndPen As Long, lastPoint As POINTAPI
Dim oldDrawMode As Long

' -- if the specified coordinates do not represent the center of mapMagnify, move
' -- the form to recenter

dx = X - (mapMagnify.Width / 2)
dy = Y - (mapMagnify.Height / 2)
If dx <> 0 Or dy <> 0 Then
  Me.Move Me.Left + dx, Me.Top + dy
End If

' -- determine the screen location of mapMagnify relative to the underlying map

tx = Screen.TwipsPerPixelX
ty = Screen.TwipsPerPixelY

sx = (((frmMagnifier.Left + mapMagnify.Left) - (mForm.Left + mMap.Left)) \ tx) - 3
sy = (((frmMagnifier.Top + mapMagnify.Top) - (mForm.Top + mMap.Top)) \ ty) - 6
w = (mapMagnify.Width / tx) - 2
h = (mapMagnify.Height / ty) - 2

mapDC = GetDC(mapMagnify.hWnd)

' -- if mapMagnify goes beyond the edge of the underlying map ...

If sx < 0 Or sy < 0 Or sx + w > mWidth Or sy + h > mHeight Then

  ' -- create a temporary device context and bitmap that is the same pixel size
  ' -- as mapMagnify
  
  tempDC = CreateCompatibleDC(mapDC)
  bitmap = CreateCompatibleBitmap(mapDC, mapMagnify.Width / tx, mapMagnify.Height / ty)
  oldBitmap = SelectObject(tempDC, bitmap)
  
  ' -- paint the temporary bitmap a medium gray
  
  hndBrush = CreateSolidBrush(RGB(128, 128, 128))
  oldBrush = SelectObject(tempDC, hndBrush)
  Rectangle tempDC, -2, -2, mapMagnify.Width / tx + 2, mapMagnify.Height / ty + 2
  SelectObject mapDC, oldBrush
  DeleteObject hndBrush
  
  ' -- copy the underlying map graphics from the snapshot to the temporary bitmap,
  ' -- then copy the temporary bitmap to mapMagnify's device context; this entire
  ' -- process avoids flicker
  
  BitBlt tempDC, 0, 0, w, h, mDC, sx, sy, vbSrcCopy
  BitBlt mapDC, 0, 0, w, h, tempDC, 0, 0, vbSrcCopy
  
' -- otherwise, copy the underlying map graphics directly from the snapshot to
' -- mapMagnify's device context

Else
  BitBlt mapDC, 0, 0, w, h, mDC, sx, sy, vbSrcCopy
End If

' -- draw the outline of the area to magnify

hndPen = CreatePen(0, 1, RGB(0, 0, 0))
oldPen = SelectObject(mapDC, hndPen)
oldDrawMode = GetROP2(mapDC)
SetROP2 mapDC, vbInvert

mag = mMagnification * 2

MoveToEx mapDC, (w / 2) - (w / mag), (h / 2) - (h / mag), lastPoint
LineTo mapDC, (w / 2) + (w / mag), (h / 2) - (h / mag)
MoveToEx mapDC, (w / 2) + (w / mag), (h / 2) - (h / mag), lastPoint
LineTo mapDC, (w / 2) + (w / mag), (h / 2) + (h / mag)
MoveToEx mapDC, (w / 2) + (w / mag), (h / 2) + (h / mag), lastPoint
LineTo mapDC, (w / 2) - (w / mag), (h / 2) + (h / mag)
MoveToEx mapDC, (w / 2) - (w / mag), (h / 2) + (h / mag), lastPoint
LineTo mapDC, (w / 2) - (w / mag), (h / 2) - (h / mag)

' -- reset device contexts and free memory

If bitmap > 0 Then
  SelectObject tempDC, oldBitmap
  DeleteObject bitmap
  DeleteDC tempDC
End If
SelectObject mapDC, oldPen
DeleteObject hndPen
SetROP2 mapDC, oldDrawMode
ReleaseDC mapMagnify.hWnd, mapDC

End Sub

Private Sub UpdateBitmap()

Dim baseMapDC As Long

' -- create a new snapshot of the underlying map

mWidth = (mMap.Width / Screen.TwipsPerPixelX) - 6
mHeight = (mMap.Height / Screen.TwipsPerPixelY) - 7

baseMapDC = GetDC(mMap.hWnd)
mDC = CreateCompatibleDC(baseMapDC)
mBitmap = CreateCompatibleBitmap(baseMapDC, mWidth, mHeight)
mOldBitmap = SelectObject(mDC, mBitmap)
BitBlt mDC, 0, 0, mWidth, mHeight, baseMapDC, 0, 0, vbSrcCopy
ReleaseDC mMap.hWnd, baseMapDC

End Sub

Public Sub SetFormAndMap(f As Form, m As MapObjects2.Map)

Dim e As MapObjects2.Rectangle, i As Integer

' -- set underlying form and map

Set mForm = f
Set mMap = m

For i = mMap.Layers.Count - 1 To 0 Step -1
  mapMagnify.Layers.Add mMap.Layers(i)
Next i
Set e = mMap.fullextent
e.ScaleRectangle 3
mapMagnify.fullextent = e

UpdateBitmap
DrawMap

End Sub

Public Sub Update()

' -- update the snapshot of the underlying map and draw whatever is now
' -- underneath the magnifier

UpdateBitmap
DrawMap

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