frmmagnifier.vb

VB开发的基于mo控件的例子

Option Strict Off
Option Explicit On
Friend Class frmMagnifier
	Inherits System.Windows.Forms.Form
	'
	'  Module Name:  frmMagnifier
	'
	'  Description:  Magnifier form
	'
	'     Requires:  (nothing)
	'
	'      Methods:  SetFormAndMap - sets underlying form and map
	'                Update - updates the internal snapshot of the underlying map and
	'                   draws on the magnifier whatever is currently underneath the
	'                   magnifier
	'                StayOnTop - sets the "always on top" mode for this form
	'
	'      History:  Peter Girard, ESRI - 9/99 - original coding
	'
	'=============================================================================
	
	
	' == Windows API calls and constants
	
	' -- window position and state
	
	Private Declare Function SetWindowPos Lib "user32" (ByVal hWnd As Integer, ByVal hWndInsertAfter As Integer, ByVal X As Integer, ByVal Y As Integer, ByVal cx As Integer, ByVal cy As Integer, ByVal wFlags As Integer) As Integer
	
	Private Const HWND_TOPMOST As Short = -1
	Private Const HWND_NOTOPMOST As Short = -2
	
	' -- device contexts
	
	Private Declare Function GetDC Lib "user32" (ByVal hWnd As Integer) As Integer
	Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Integer) As Integer
	Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Integer, ByVal hDC As Integer) As Integer
	Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Integer) As Integer
	Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Integer, ByVal hObject As Integer) As Integer
	Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Integer) As Integer
	
	' -- bit map manipulation
	
	Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hDC As Integer, ByVal nWidth As Integer, ByVal nHeight As Integer) As Integer
	Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Integer, ByVal X As Integer, ByVal Y As Integer, ByVal nWidth As Integer, ByVal nHeight As Integer, ByVal hSrcDC As Integer, ByVal xSrc As Integer, ByVal ySrc As Integer, ByVal dwRop As Integer) As Integer
	
	' -- drawing
	
	Private Declare Function CreatePen Lib "gdi32" (ByVal nPenStyle As Integer, ByVal nWidth As Integer, ByVal crColor As Integer) As Integer
	Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Integer) As Integer
	'UPGRADE_WARNING: 结构 POINTAPI 可能要求封送处理属性作为此 Declare 语句中的参数传递。 单击以获得更多信息:“ms-help://MS.VSCC.v80/dv_commoner/local/redirect.htm?keyword="C429C3A5-5D47-4CD9-8F51-74A1616405DC"”
	Private Declare Function MoveToEx Lib "gdi32" (ByVal hDC As Integer, ByVal X As Integer, ByVal Y As Integer, ByRef lpPoint As POINTAPI) As Integer
	Private Declare Function LineTo Lib "gdi32" (ByVal hDC As Integer, ByVal X As Integer, ByVal Y As Integer) As Integer
	Private Declare Function Rectangle Lib "gdi32" (ByVal hDC As Integer, ByVal X1 As Integer, ByVal Y1 As Integer, ByVal X2 As Integer, ByVal Y2 As Integer) As Integer
	
	Private Declare Function GetROP2 Lib "gdi32" (ByVal hDC As Integer) As Integer
	Private Declare Function SetROP2 Lib "gdi32" (ByVal hDC As Integer, ByVal nDrawMode As Integer) As Integer
	
	Private Structure POINTAPI
		Dim X As Integer
		Dim Y As Integer
	End Structure
	
	' == module variables
	
	Dim mForm As System.Windows.Forms.Form
	Dim mMap As AxMapObjects2.AxMap
	Dim mWidth, mHeight As Integer
	
	Dim mMagnification As Double
	
	Dim mDC As Integer ' device context for the snapshot
	Dim mBitmap As Integer ' bitmap snapshot of the underlying map
	Dim mOldBitmap As Integer
	
	Private Sub frmMagnifier_Load(ByVal eventSender As System.Object, ByVal eventArgs As System.EventArgs) Handles MyBase.Load
		
		StayOnTop(True)
		mMagnification = 4
		
	End Sub
	
	Private Sub frmMagnifier_FormClosed(ByVal eventSender As System.Object, ByVal eventArgs As System.Windows.Forms.FormClosedEventArgs) Handles Me.FormClosed
		
		' -- 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_MouseDownEvent(ByVal eventSender As System.Object, ByVal eventArgs As AxMapObjects2._DMapEvents_MouseDownEvent) Handles mapMagnify.MouseDownEvent
		
		If eventArgs.Button = 1 Then
			MoveMagnifier(eventArgs.X, eventArgs.Y)
		End If
		
	End Sub
	
	Private Sub mapMagnify_MouseMoveEvent(ByVal eventSender As System.Object, ByVal eventArgs As AxMapObjects2._DMapEvents_MouseMoveEvent) Handles mapMagnify.MouseMoveEvent
		
		If eventArgs.Button = 1 Then
			MoveMagnifier(eventArgs.X, eventArgs.Y)
		End If
		
	End Sub
	
	Private Sub mapMagnify_MouseUpEvent(ByVal eventSender As System.Object, ByVal eventArgs As AxMapObjects2._DMapEvents_MouseUpEvent) Handles mapMagnify.MouseUpEvent
		
		DrawMap()
		
	End Sub
	
	Private Sub DrawMap()
		
		Dim sx, sy As Single
		Dim p As MapObjects2.Point
		Dim e As MapObjects2.Rectangle
		
		' -- draw the magnified map; determine the screen location of mapMagnify
		' -- relative to the underlying map
		
		e = New MapObjects2.Rectangle
		sx = (VB6.PixelsToTwipsX(Me.Left) + VB6.PixelsToTwipsX(mapMagnify.Left)) - (VB6.PixelsToTwipsX(mForm.Left) + VB6.PixelsToTwipsX(mMap.Left)) - (3 * VB6.TwipsPerPixelX)
		sy = (VB6.PixelsToTwipsY(Me.Top) + VB6.PixelsToTwipsY(mapMagnify.Top)) - (VB6.PixelsToTwipsY(mForm.Top) + VB6.PixelsToTwipsY(mMap.Top)) - (6 * VB6.TwipsPerPixelY)
		
		' -- get the map extent from the underlying map based on the pixel extent
		' -- of mapMagnify
		
		p = mMap.ToMapPoint(sx, sy)
		e.Left = p.X
		e.Top = p.Y
		p = mMap.ToMapPoint(sx + VB6.PixelsToTwipsX(mapMagnify.Width), sy + VB6.PixelsToTwipsY(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(ByRef X As Single, ByRef Y As Single)
		
		Dim bitmap, mapDC, tempDC, oldBitmap As Integer
		Dim dx, dy As Single
		Dim w, sx, sy, h As Integer
		Dim tx, ty As Integer
		
		Dim mag As Single
		Dim oldBrush, hndBrush As Integer
		Dim oldPen, hndPen As Integer
		Dim lastPoint As POINTAPI
		Dim oldDrawMode As Integer
		
		' -- if the specified coordinates do not represent the center of mapMagnify, move
		' -- the form to recenter
		
		dx = X - (VB6.PixelsToTwipsX(mapMagnify.Width) / 2)
		dy = Y - (VB6.PixelsToTwipsY(mapMagnify.Height) / 2)
		If dx <> 0 Or dy <> 0 Then
			Me.SetBounds(VB6.TwipsToPixelsX(VB6.PixelsToTwipsX(Me.Left) + dx), VB6.TwipsToPixelsY(VB6.PixelsToTwipsY(Me.Top) + dy), 0, 0, Windows.Forms.BoundsSpecified.X Or Windows.Forms.BoundsSpecified.Y)
		End If
		
		' -- determine the screen location of mapMagnify relative to the underlying map
		
		tx = VB6.TwipsPerPixelX
		ty = VB6.TwipsPerPixelY
		
		sx = (((VB6.PixelsToTwipsX(Me.Left) + VB6.PixelsToTwipsX(mapMagnify.Left)) - (VB6.PixelsToTwipsX(mForm.Left) + VB6.PixelsToTwipsX(mMap.Left))) \ tx) - 3
		sy = (((VB6.PixelsToTwipsY(Me.Top) + VB6.PixelsToTwipsY(mapMagnify.Top)) - (VB6.PixelsToTwipsY(mForm.Top) + VB6.PixelsToTwipsY(mMap.Top))) \ ty) - 6
		w = (VB6.PixelsToTwipsX(mapMagnify.Width) / tx) - 2
		h = (VB6.PixelsToTwipsY(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, VB6.PixelsToTwipsX(mapMagnify.Width) / tx, VB6.PixelsToTwipsY(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, VB6.PixelsToTwipsX(mapMagnify.Width) / tx + 2, VB6.PixelsToTwipsY(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
			
			'UPGRADE_ISSUE: 常量 vbSrcCopy 未升级。 单击以获得更多信息:“ms-help://MS.VSCC.v80/dv_commoner/local/redirect.htm?keyword="55B59875-9A95-4B71-9D6A-7C294BF7139D"”
			BitBlt(tempDC, 0, 0, w, h, mDC, sx, sy, vbSrcCopy)
			'UPGRADE_ISSUE: 常量 vbSrcCopy 未升级。 单击以获得更多信息:“ms-help://MS.VSCC.v80/dv_commoner/local/redirect.htm?keyword="55B59875-9A95-4B71-9D6A-7C294BF7139D"”
			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
			'UPGRADE_ISSUE: 常量 vbSrcCopy 未升级。 单击以获得更多信息:“ms-help://MS.VSCC.v80/dv_commoner/local/redirect.htm?keyword="55B59875-9A95-4B71-9D6A-7C294BF7139D"”
			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)
		'UPGRADE_ISSUE: 常量 vbInvert 未升级。 单击以获得更多信息:“ms-help://MS.VSCC.v80/dv_commoner/local/redirect.htm?keyword="55B59875-9A95-4B71-9D6A-7C294BF7139D"”
		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 Integer
		
		' -- create a new snapshot of the underlying map
		
		mWidth = (VB6.PixelsToTwipsX(mMap.Width) / VB6.TwipsPerPixelX) - 6
		mHeight = (VB6.PixelsToTwipsY(mMap.Height) / VB6.TwipsPerPixelY) - 7
		
		baseMapDC = GetDC(mMap.hWnd)
		mDC = CreateCompatibleDC(baseMapDC)
		mBitmap = CreateCompatibleBitmap(baseMapDC, mWidth, mHeight)
		mOldBitmap = SelectObject(mDC, mBitmap)
		'UPGRADE_ISSUE: 常量 vbSrcCopy 未升级。 单击以获得更多信息:“ms-help://MS.VSCC.v80/dv_commoner/local/redirect.htm?keyword="55B59875-9A95-4B71-9D6A-7C294BF7139D"”
		BitBlt(mDC, 0, 0, mWidth, mHeight, baseMapDC, 0, 0, vbSrcCopy)
		ReleaseDC(mMap.hWnd, baseMapDC)
		
	End Sub
	
	Public Sub SetFormAndMap(ByRef f As System.Windows.Forms.Form, ByRef m As AxMapObjects2.AxMap)
		
		Dim e As MapObjects2.Rectangle
		Dim i As Short
		
		' -- set underlying form and map
		
		mForm = f
		mMap = m
		
		For i = mMap.Layers.Count - 1 To 0 Step -1
			mapMagnify.Layers.Add(mMap.Layers._Item(i))
		Next i
		e = mMap.FullExtent
		e.ScaleRectangle(3)
		mapMagnify.FullExtent = e
		
		UpdateBitmap()
		DrawMap()
		
	End Sub
	
	'UPGRADE_NOTE: Update 已升级到 Update_Renamed。 单击以获得更多信息:“ms-help://MS.VSCC.v80/dv_commoner/local/redirect.htm?keyword="A9E4979A-37FA-4718-9994-97DD76ED70A7"”
	Public Sub Update_Renamed()
		
		' -- update the snapshot of the underlying map and draw whatever is now
		' -- underneath the magnifier
		
		UpdateBitmap()
		DrawMap()
		
	End Sub
	
	Public Sub StayOnTop(ByRef onTop As Boolean)
		
		Dim fWidth, fLeft, fTop, fHeight As Integer
		Dim fState As Integer
		
		' -- set the "always on top" mode for this form
		
		fLeft = VB6.PixelsToTwipsX(Me.Left) / VB6.TwipsPerPixelX
		fTop = VB6.PixelsToTwipsY(Me.Top) / VB6.TwipsPerPixelY
		fWidth = VB6.PixelsToTwipsX(Me.Width) / VB6.TwipsPerPixelX
		fHeight = VB6.PixelsToTwipsY(Me.Height) / VB6.TwipsPerPixelY
		
		If onTop Then
			fState = HWND_TOPMOST
		Else
			fState = HWND_NOTOPMOST
		End If
		
		SetWindowPos(Me.Handle.ToInt32, fState, fLeft, fTop, fWidth, fHeight, 0)
		
	End Sub
End Class