[VB6] - Desktop lens.

[The trick]

Hello everyone! With this software, you can view a certain part of the screen increases, the increase can change the wheel, exit - ESC* module:

    cy As Long
    flags As Long
End Type
Private Type RGBQUAD
    rgbBlue As Byte
    rgbGreen As Byte
    rgbRed As Byte
    rgbReserved As Byte
End Type
Private Type BITMAPINFOHEADER
    biSize As Long
    biWidth As Long
    biHeight As Long
    biPlanes As Integer
    biBitCount As Integer
    biCompression As Long
    biSizeImage As Long
    biXPelsPerMeter As Long
    biYPelsPerMeter As Long
    biClrUsed As Long
    biClrImportant As Long
End Type
Private Type BITMAPINFO
    bmiHeader As BITMAPINFOHEADER
    bmiColors As RGBQUAD
End Type
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam 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 BeginPaint Lib "user32" (ByVal hwnd As Long, lpPaint As PAINTSTRUCT) As Long
Private Declare Function EndPaint Lib "user32" (ByVal hwnd As Long, lpPaint As PAINTSTRUCT) As Long
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 Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Private Declare Function InvertRect Lib "user32" (ByVal hdc As Long, lpRect As RECT) As Long
Private Declare Function SetRect Lib "user32" (lpRect As RECT, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (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
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
Private Declare Function ScrollDC Lib "user32" (ByVal hdc As Long, ByVal dx As Long, ByVal dy As Long, lprcScroll As Any, lprcClip As Any, ByVal hrgnUpdate As Long, lprcUpdate As Any) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function RedrawWindow Lib "user32" (ByVal hwnd As Long, lprcUpdate As Any, ByVal hrgnUpdate As Long, ByVal fuRedraw As Long) As Long
Private Declare Function GetDIBits Lib "gdi32" (ByVal aHDC As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As BITMAPINFO, ByVal wUsage As Long) As Long
Private Declare Function SetDIBitsToDevice Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal dx As Long, ByVal dy As Long, ByVal SrcX As Long, ByVal SrcY As Long, ByVal Scan As Long, ByVal NumScans As Long, Bits As Any, BitsInfo As BITMAPINFO, ByVal wUsage As Long) As Long
Private Declare Function SetWindowRgn Lib "user32" (ByVal hwnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long
Private Declare Function CreateEllipticRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function Ellipse 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 GetStockObject Lib "gdi32" (ByVal nIndex As Long) As Long
Private Declare Function SetDCPenColor Lib "gdi32" (ByVal hdc As Long, ByVal colorref As Long) As Long
 
Private Const DC_PEN = 19
Private Const RDW_INVALIDATE = &H1
Private Const RDW_UPDATENOW = &H100
Private Const WM_WINDOWPOSCHANGING = &H46
Private Const HWND_TOPMOST = -1
Private Const SWP_NOSIZE = &H1
Private Const SWP_NOMOVE = &H2
 
Private Const GWL_WNDPROC = &HFFFFFFFC
Private Const WM_PAINT = &HF
Private Const WM_MOUSEWHEEL = &H20A&
 
Private Const HTCAPTION = 2
Private Const WM_NCHITTEST = &H84
 
Dim lpPrevWndProc As Long
Dim bBmp As Long
Dim oBmp As Long
Dim tDc As Long
Dim oPos As WINDOWPOS
Dim w As Long, h As Long, bi As BITMAPINFO, pix() As Long, out() As Long, Strength As Single
 
Public Sub Hook()
    Dim hRgn As Long
    Strength = 0.2
    w = frmTest.ScaleWidth: h = frmTest.ScaleHeight
    bi.bmiHeader.biSize = Len(bi.bmiHeader)
    bi.bmiHeader.biBitCount = 32
    bi.bmiHeader.biPlanes = 1
    bi.bmiHeader.biWidth = w
    bi.bmiHeader.biHeight = h
    ReDim pix(w * h - 1)
    ReDim out(UBound(pix))
    tDc = CreateCompatibleDC(frmTest.hdc)
    bBmp = CreateCompatibleBitmap(frmTest.hdc, w, h)
    oBmp = SelectObject(tDc, bBmp)
    Prepare frmTest.Left / Screen.TwipsPerPixelX, frmTest.Top / Screen.TwipsPerPixelY
    hRgn = CreateEllipticRgn(0, 0, w, h)
    SetWindowRgn frmTest.hwnd, hRgn, False
    SetWindowPos frmTest.hwnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOSIZE Or SWP_NOMOVE
    lpPrevWndProc = SetWindowLong(frmTest.hwnd, GWL_WNDPROC, AddressOf WndProc)
End Sub
Public Sub UnHook()
    SetWindowLong frmTest.hwnd, GWL_WNDPROC, lpPrevWndProc
    SelectObject tDc, oBmp
    DeleteDC tDc
    DeleteObject bBmp
End Sub
Private Function WndProc(ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    'Debug.Print Msg
    Select Case Msg
    Case WM_WINDOWPOSCHANGING
        Dim wp As WINDOWPOS
        CopyMemory wp, ByVal lParam, Len(wp)
        WndProc = OnPosChanging(hwnd, wp)
    Case WM_NCHITTEST
        WndProc = HTCAPTION
    Case WM_PAINT
        WndProc = OnPaint(hwnd)
    Case WM_MOUSEWHEEL
        WndProc = OnWheel(hwnd, (wParam \ &H10000))
    Case Else
        WndProc = CallWindowProc(lpPrevWndProc, hwnd, Msg, wParam, lParam)
    End Select
End Function
Private Function OnWheel(ByVal hwnd As Long, ByVal Value As Integer) As Long
    Value = Value \ 120
    Strength = Strength + Value / 30
    If Strength > 1 Then Strength = 1 Else If Strength < 0 Then Strength = 0
    MakeLens
    RedrawWindow hwnd, ByVal 0, 0, RDW_INVALIDATE
End Function
Private Function OnPosChanging(ByVal hwnd As Long, Pos As WINDOWPOS) As Long
    Dim dx As Long, dy As Long
    
    If Pos.flags And SWP_NOMOVE Then Exit Function
    
    dx = Pos.x - oPos.x
    dy = Pos.y - oPos.y
    
    Prepare dx, dy
    RedrawWindow hwnd, ByVal 0, 0, RDW_INVALIDATE Or RDW_UPDATENOW
     
    oPos = Pos
End Function
Private Function OnPaint(ByVal hwnd As Long) As Long
    Dim ps As PAINTSTRUCT, opn As Long
    BeginPaint hwnd, ps
    SetDIBitsToDevice ps.hdc, 0, 0, w, h, 0, 0, 0, h, out(0), bi, 0
    opn = SelectObject(ps.hdc, GetStockObject(DC_PEN))
    SetDCPenColor ps.hdc, &HE0E0E0
    Ellipse ps.hdc, 1, 1, w - 2, h - 2
    SelectObject ps.hdc, opn
    EndPaint hwnd, ps
End Function
Private Sub MakeLens()
    Dim x As Long, y As Long
    Dim cx As Single, cy As Single
    Dim nx As Long, ny As Long
    Dim r As Single
    Dim pt As Long
    
    SelectObject tDc, oBmp
    GetDIBits tDc, bBmp, 0, h, pix(0), bi, 0
    SelectObject tDc, bBmp
    
    For y = 0 To h - 1: For x = 0 To w - 1
        cx = x / w - 0.5: cy = y / h - 0.5
        r = Sqr(cx * cx + cy * cy)
        nx = (cx + 0.5 + Strength * cx * ((r - 1) / 0.5)) * (w - 1)
        ny = (cy + 0.5 + Strength * cy * ((r - 1) / 0.5)) * (h - 1)
        out(pt) = pix(ny * w + nx)
        pt = pt + 1
    Next: Next
 
End Sub
Private Sub Prepare(ByVal dx As Long, ByVal dy As Long)
    Dim dDC As Long, x As Long, y As Long
    dDC = GetDC(0)
    
    ScrollDC tDc, -dx, -dy, ByVal 0, ByVal 0, ByVal 0, ByVal 0
    Select Case dx
    Case Is > 0
        x = oPos.x + w: y = oPos.y + dy
        BitBlt tDc, w - dx, 0, dx, h, dDC, x, y, vbSrcCopy
    Case Is < 0
        x = oPos.x + dx: y = oPos.y + dy
        BitBlt tDc, 0, 0, -dx, h, dDC, x, y, vbSrcCopy
    End Select
    Select Case dy
    Case Is > 0
        x = oPos.x + dx: y = oPos.y + h
        BitBlt tDc, 0, h - dy, w, dy, dDC, x, y, vbSrcCopy
    Case Is < 0
        x = oPos.x + dx: y = oPos.y + dy
        BitBlt tDc, 0, 0, w, -dy, dDC, x, y, vbSrcCopy
    End Select
    ReleaseDC 0, dDC
    MakeLens
End Sub

Form:

Option Explicit
 
Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
    If KeyCode = vbKeyEscape Then Unload Me
End Sub
Private Sub Form_Load()
    Me.Move (Screen.Width - Me.Width) \ 2, (Screen.Height - Me.Height) \ 2
    Hook
End Sub
Private Sub Form_Unload(Cancel As Integer)
    UnHook
End Sub

Good luck!

Lens.zip

[Black_Storm]

- every time the first performance, it also takes a picture of itself
- When changes are made under the form, such as moving the windows under the form, the program is still displaying the last image it took.

how can fix these problem? there is need always a timer for refresh live?

[yereverluvinuncleber]

Superb. I do wish it could also magnify all the other visual program elements I have installed, eg. my dock, Yahoo widgets and Xwidget engines - all probably GDI+ and not part of the Windows desktop. Otherwise rather a fun utility.


Needs a handle and a surround...

[Black_Storm]

I created a thread here about (not solved yet) :

How to take a picture from the back of the form while the form is being displayed to?

And in the answers, he introduced the trick of the current page, which, of course, has the same bug in my program


Regarding the magnifying glass, I had many examples such as:

or some examples like as sbutton in vb :

but sill other samples have same problem too as I shown in post 2.

[yereverluvinuncleber]

I just retested this on Win10+Nvidia GTX1080 graphics and it worked perfectly. Not quite sure why it earlier failed to capture my dock, the X and Y widgets, possibly due to a different GPU on my older Win 7 machine?

Regardless, this works now but it does not take into account DPI scaling on larger screens.