[VB6] Another "magnifier"

[dilettante]

The topic of writing screen magnifiers came up the other day, and I thought I might trot out this old approach.

Basically it shows simple use of a GDI Region object with StretchBlt. I had another example using StretchBlt then MaskBlt, but this is actually far simpler and less code.

A Timer is used here only to catch any movement at 5 frames/sec to keep overhead low, but even 10 fps shouldn't be too expensive on most PCs. The demo does a "4x" magnification.



Here "DrawGrid" was just a simple program with some colors for me to magnify.

The "MagnifyX4" program is the grey square with the red arrow pointing at the magnified region, which can be dragged around to magnify different parts of the screen.

The circular GDI Region was only used to produce the "clever" circular magnification. You could just use StretchBlt without it to get a square magnifier.

Option Explicit
'
'Form1 is borderless, mainly to help draw an "arrow" to indicate the captured area of the
'desktop in this demo.  With a border the arrow would be off a bit (too low by the caption
'bar height and outline).
'
'We use a Timer control here in order to accomodate magnifying anything animated or moving.
'
'Assumptions:
'
'   o Form1's client area is square.
'

Private Const WIN32NULL As Long = 0

Private Declare Function CreateEllipticRgn Lib "gdi32" ( _
    ByVal nLeftRect As Long, _
    ByVal nTopRect As Long, _
    ByVal nRightRect As Long, _
    ByVal nBottomRect As Long) As Long

Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long

Private Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long

Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

Private Declare Function GetWindowRect Lib "user32" ( _
    ByVal hWnd As Long, _
    ByRef RECT As RECT) As Long

Private Declare Function ReleaseDC Lib "user32" ( _
    ByVal hWnd As Long, _
    ByVal hDC As Long) As Long

Private Declare Function SelectClipRgn Lib "gdi32" ( _
    ByVal hDC As Long, _
    ByVal hRgn As Long) As Long

Private Declare Function StretchBlt Lib "gdi32" ( _
    ByVal hdcDest As Long, _
    ByVal nXOriginDest As Long, _
    ByVal nYOriginDest As Long, _
    ByVal nWidthDest As Long, _
    ByVal nHeightDest As Long, _
    ByVal hdcSrc As Long, _
    ByVal nXOriginSrc As Long, _
    ByVal nYOriginSrc As Long, _
    ByVal nWidthSrc As Long, _
    ByVal nHeightSrc As Long, _
    Optional ByVal dwRop As RasterOpConstants = vbSrcCopy) As Long

Private CaptureWH As Long
Private GrabX As Single
Private GrabY As Single
Private MagnifyWH As Long

Private Sub Peek()
    Dim hDCScreen As Long
    Dim hRgn As Long
    Dim RECT As RECT

    hDCScreen = GetDC(WIN32NULL)
    hRgn = CreateEllipticRgn(0, 0, MagnifyWH, MagnifyWH)
    SelectClipRgn hDC, hRgn
    GetWindowRect hWnd, RECT
    With RECT
        StretchBlt hDC, _
                   0, _
                   0, _
                   MagnifyWH, _
                   MagnifyWH, _
                   hDCScreen, _
                   .Left - CaptureWH, _
                   .Top - CaptureWH, _
                   CaptureWH, _
                   CaptureWH
    End With
    SelectClipRgn hDC, WIN32NULL
    DeleteObject hRgn
    ReleaseDC WIN32NULL, hDCScreen
    Set Picture = Image
End Sub

Private Sub Form_Load()
    AutoRedraw = True
    ScaleMode = vbTwips
    BackColor = &H808080
    ForeColor = vbRed
    DrawWidth = 3
    Line (30, 30)-(360, 360)
    Line (30, 30)-(360, 30)
    Line (30, 30)-(30, 360)
    MagnifyWH = ScaleX(ScaleWidth, ScaleMode, vbPixels)
    CaptureWH = MagnifyWH / 4

    Show
    DoEvents
    Peek
    MsgBox "Left-click and drag to move, shift-left-click to exit"
    With Timer1
        .Interval = 200 '5 fps capture.
        .Enabled = True
    End With
End Sub

Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Shift And vbShiftMask Then
        Unload Me
    ElseIf Button = vbLeftButton Then
        GrabX = X
        GrabY = Y
    End If
End Sub

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    Dim NewLeft As Single
    Dim NewTop As Single

    If Button = vbLeftButton Then
        NewLeft = Left + X - GrabX
        NewTop = Top + Y - GrabY
        Move NewLeft, NewTop
        'Commented out since we're using Timer1 to magnify anything animated
        'such as a video we're watching:
        'Peek
    End If
End Sub

Private Sub Form_Unload(Cancel As Integer)
    Timer1.Enabled = False
End Sub

Private Sub Timer1_Timer()
    Peek
End Sub