The desktop will be captured and used for the magnifier. That means any update of the desktop will not be shown within the magnifier.
The full executable code can be viewed here: Pastebin
Here the code fragment without the data section (not compilable!):
Code: Select all
'Coded by UEZ build 2020-03-05
#Ifdef __Fb_64bit__
#Inclib "gdiplus"
#Include Once "win/gdiplus-c.bi"
#Else
#Include Once "win/gdiplus.bi"
Using Gdiplus
#Endif
'some global variables
Dim Shared As ULONG_PTR gdipToken
Dim Shared As GdiplusStartupInput GDIp
Dim Shared As Any Ptr hImage_Magnifier, hImage_Desktop
Dim Shared As HWND hGUI
Dim Shared As Size pSize
Dim Shared As Point pSource
Dim Shared As BLENDFUNCTION pBlend
Dim Shared As Integer ScreenL, ScreenT, ScreenR, ScreenB, ScreenW, ScreenH
Dim Shared As Single w, h, dpi, zoom = 4.0
Dim Shared As HCURSOR CustomCursor
Const WM_DPICHANGED = &h02E0
Enum PROCESS_DPI_AWARENESS
DPI_AWARENESS_INVALID = -1, PROCESS_DPI_UNAWARE = 0, PROCESS_SYSTEM_DPI_AWARE, PROCESS_PER_MONITOR_DPI_AWARE
End Enum
Function _WinAPI_GetDPI() As Single
Dim As HDC hDC = GetDC(0)
Dim As Single hPixelsPerInch = GetDeviceCaps(hDC, LOGPIXELSX), vPixelsPerInch = GetDeviceCaps(hDC, LOGPIXELSY)
ReleaseDC(0, hDC)
Return (hPixelsPerInch + vPixelsPerInch) / 2
End Function
Function _WinAPI_GetDpiForWindow(hWnd As HWND) As Ubyte 'requires Win10 v1607+ / no server support
Dim As Any Ptr pLib = Dylibload("User32.dll")
If pLib = NULL Then Exit Function
Dim pGetDpiForWindow As Function (Byval hWND As HWND) As UINT
pGetDpiForWindow = Dylibsymbol(pLib, "GetDpiForWindow")
If pGetDpiForWindow Then Function = pGetDpiForWindow(hWnd)
Dylibfree(pLib)
End Function
Function _WinAPI_SetProcessDpiAwareness(DPIAware As Integer) As Ubyte 'requires Windows 8.1+ / no server support
Dim As Any Ptr pLib = Dylibload("Shcore.dll")
If pLib = NULL Then Exit Function
Dim pSetProcessDpiAwareness As Function (Byval DPIAware As Integer) As HRESULT
pSetProcessDpiAwareness = Dylibsymbol(pLib, "SetProcessDpiAwareness")
If pSetProcessDpiAwareness Then Function = pSetProcessDpiAwareness(DPIAware)
Dylibfree(pLib)
End Function
Function _WinAPI_SetProcessDPIAware() As BOOL 'requires Vista+ / Server 2008
Dim As Any Ptr pLib = Dylibload("user32.dll")
If pLib = NULL Then Exit Function
Dim pSetProcessDPIAware As Function () As BOOL
pSetProcessDPIAware = Dylibsymbol(pLib, "SetProcessDPIAware")
If pSetProcessDPIAware Then Function = pSetProcessDPIAware()
Dylibfree(pLib)
End Function
Function _GDIPlus_Startup() As Bool
GDIp.GdiplusVersion = 1
If GdiplusStartup(@gdipToken, @GDIp, NULL) <> 0 Then
Error 1
Return False
Endif
Return True
End Function
Sub _GDIPlus_Shutdown()
GdiplusShutdown(gdipToken)
End Sub
Function _GDIPlus_BitmapCreateFromMemory3(aBinImage As Ubyte Ptr, iLen As Ulong, bBitmap_GDI As Bool = False) As Any Ptr
Dim As HGLOBAL hGlobal
Dim As LPSTREAM hStream
Dim As Any Ptr hImage_Stream
Dim As Any Ptr hMemory = GlobalAlloc(GMEM_MOVEABLE, iLen)
Dim As Any Ptr lpMemory = GlobalLock(hMemory)
RtlCopyMemory(lpMemory, @aBinImage[0], iLen)
GlobalUnlock(hMemory)
CreateStreamOnHGlobal(hMemory, 0, @hStream)
GdipCreateBitmapFromStream(hStream, @hImage_Stream)
IUnknown_Release(hStream)
If bBitmap_GDI = TRUE Then
Dim hImage_GDI As Any Ptr
GdipCreateHBITMAPFromBitmap(hImage_Stream, @hImage_GDI, &hFF000000)
GdipDisposeImage(hImage_Stream)
Return hImage_GDI
Endif
Return hImage_Stream
End Function
'original code by D.J.Peters
Function Base64Decode(sString As String, Byref iBase64Len As Ulong) As Ubyte Ptr
#Define P0(p) Instr(B64, Chr(sString[n + p])) - 1
Dim As String*64 B64 = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"
Dim As String sDecoded
Dim As Long nChars = Len(sString) - 1
If nChars < 0 Then Return 0
For n As Long = 0 To nChars Step 4
Var b = P0(1), c = P0(2), d = P0(3)
If b >-1 Then
Var a = P0(0)
sDecoded += Chr((a Shl 2 + b Shr 4))
End If
If c > -1 Then sDecoded += Chr((b Shl 4 + c Shr 2))
If d > -1 Then sDecoded += Chr((c Shl 6 + d ))
Next
iBase64Len = Len(sDecoded)
'workaround For multiple embedded file other crash will occure
Static As Ubyte aReturn(0 To iBase64Len - 1)
Redim aReturn(0 To iBase64Len - 1) As Ubyte
For i As Ulong = 0 To Len(sDecoded) - 1 'convert result String To ascii code values
aReturn(i) = Asc(sDecoded, i + 1)
Next
Return @aReturn(0) 'Return Pointer To the array
End Function
Function CaptureWholeDesktop() As Any Ptr 'capture whole desktop without mouse pointer as GDIp bitmap handle
Dim As Any Ptr hDtWin = GetDesktopWindow(), _
hDCSource = GetDC(hDtWin), _
hDCDest = CreateCompatibleDC(hDCSource), _
hHBitmap = CreateCompatibleBitmap(hDCSource, ScreenW, ScreenH), hBitmap
Var hObjOld = SelectObject(hDCDest, hHBitmap)
BitBlt(hDCDest, 0, 0, ScreenW, ScreenH, hDCSource, ScreenL, ScreenT, SRCCOPY)
GdipCreateBitmapFromHBITMAP(hHBitmap, 0, @hBitmap)
SelectObject(hDCDest, hObjOld)
ReleaseDC(hDtWin, hDCSource)
DeleteDC(hDCDest)
DeleteDC(hDCSource)
DeleteObject(hHBitmap)
Return hBITMAP
End Function
Sub Draw_Magnifier(fZoom As Single = 4.0)
Dim As Any Ptr hGDIBitmap, hScrDC, hMemDC, hBitmap_Mag, hCanvas, hTexture
Dim As RECT WndPos
GetWindowRect(hGUI, @WndPos)
'MapWindowPoints(GetDesktopWindow(), GetParent(hGUI), Cast(LPPOINT, @WndPos), 2)
GdipCreateBitmapFromScan0(w, h, 0, PixelFormat32bppARGB, 0, @hBitmap_Mag) 'create empty bitmap
GdipGetImageGraphicsContext(hBitmap_Mag, @hCanvas)
'set bitmap quality
GdipSetInterpolationMode(hCanvas, InterpolationModeNearestNeighbor)
GdipSetPixelOffsetMode(hCanvas, PixelOffsetModeHalf)
GdipSetTextRenderingHint(hCanvas, TextRenderingHintAntiAlias)
GdipSetSmoothingMode(hCanvas, SmoothingModeAntiAlias)
Dim As Single zoomW = w / fZoom * dpi, zoomH = h / fZoom * dpi
GdipDrawImageRectRect(hCanvas, hImage_Desktop, _ 'copy appropiate portion of background to the empty bitmap
0, 0, w, h, _
WndPos.Left + Abs(ScreenL) - zoomW / 2 + 110, WndPos.Top + Abs(ScreenT) - zoomH / 2 + 110, zoomW, zoomH, 2, 0, 0, 0)
GdipCreateTexture(hBitmap_Mag, WrapModeTile, @hTexture) 'generate texture brush to draw filled circle
GdipGraphicsClear(hCanvas, 0) 'clear bitmap
GdipFillEllipse(hCanvas, hTexture, 5, 3, 211, 211) 'draw desktop
'draw zoom level text info to the bitmap
Dim As Any Ptr hFamily, hStringFormat, hFont, hBrush, hPen, hPath
Dim As GpRectF tLayout
tLayout.x = -39
tLayout.y = 198
tLayout.Width = w
tLayout.height = 12
GdipCreatePath(0, @hPath)
GdipCreateSolidFill(&hF0FFFFFF, @hBrush)
GdipCreatePen1(&hE0000000, 1, 2, @hPen)
GdipCreateFontFamilyFromName("Impact", Null, @hFamily)
GdipCreateStringFormat(0, 0, @hStringFormat)
GdipSetStringFormatAlign(hStringFormat, StringAlignmentCenter)
GdipAddPathString(hPath, "Zoom Level: " & fZoom, -1, hFamily, FontStyleRegular, 8.5, @tLayout, hStringFormat)
GdipDrawPath(hCanvas, hPen, hPath)
GdipFillPath(hCanvas, hBrush, hPath)
GdipDrawImageRect(hCanvas, hImage_Magnifier, 0, 0, w, h) 'draw magnifier bitmap onto the texture
GdipCreateHBITMAPFromBitmap(hBitmap_Mag, @hGDIBitmap, &hFF000000) 'convert GDI+ bitmap to GDI format
hScrDC = GetDC(GetDesktopWindow())
hMemDC = CreateCompatibleDC(hScrDC)
Var hObjOld = SelectObject(hMemDC, hGDIBitmap)
UpdateLayeredWindow(hGUI, hScrDC, NULL, Cast(Any Ptr, @pSize), hMemDC, Cast(Any Ptr, @pSource), 0, Cast(Any Ptr, @pBlend), ULW_ALPHA) 'updates the position, size, shape, content, and translucency of a layered window
'release all resources
SelectObject(hMemDC, hObjOld)
ReleaseDC(GetDesktopWindow(), hScrDC)
DeleteDC(hMemDC)
DeleteObject(hGDIBitmap)
GdipDeleteBrush(hTexture)
GdipDeleteGraphics(hCanvas)
GdipDisposeImage(hBitmap_Mag)
GdipDeleteFontFamily(hFamily)
GdipDeleteStringFormat(hStringFormat)
GdipDeleteBrush(hBrush)
GdipDeletePen(hPen)
GdipDeletePath(hPath)
End Sub
Function WndProc(hWnd As HWND, uMsg As UINT, wParam As WPARAM, lParam As LPARAM) As Integer
Select Case uMsg
Case WM_SETCURSOR
SetCursor(CustomCursor)
Return 0
Case WM_DPICHANGED 'Windows 8.1+ / Windows Server 2012 R2+ required
dpi = Hiword(wParam) / 96
Return 0
Case WM_CLOSE
PostQuitMessage(0)
Return 0
Case WM_KEYDOWN
Select Case wParam
Case VK_ESCAPE
PostMessage(hWnd, WM_CLOSE, 0, 0)
Case VK_F5 'F5 to manuel refresh of the desktop screen capture image
ShowWindow(hGUI, SW_HIDE)
GdipDisposeImage(hImage_Desktop)
hImage_Desktop = CaptureWholeDesktop()
Draw_Magnifier()
ShowWindow(hGUI, SW_SHOWNORMAL)
End Select
Return 0
Case WM_NCHITTEST
Return HTCAPTION
Case WM_WINDOWPOSCHANGED
Draw_Magnifier(zoom)
Return 0
Case WM_MOUSEWHEEL
Dim As Short w = Hiword(wParam)
If w < 0 Then
zoom += 1.0
Else
zoom -= 1.0
End If
zoom = Iif(zoom < 1, 1, Iif(zoom > 16, 16, zoom))
Draw_Magnifier(zoom)
Return 0
Case Else
Return DefWindowProc(hWnd, uMsg, wParam, lParam)
End Select
End Function
Dim As OSVERSIONINFO OS
OS.dwOSVersionInfoSize = Sizeof(OS)
GetVersionEx(@OS)
If OS.dwBuildNumber < 9200 Then
_WinAPI_SetProcessDPIAware()
Else
_WinAPI_SetProcessDpiAwareness(PROCESS_PER_MONITOR_DPI_AWARE)
End If
'Decode base64 string
Dim As Ulong iLines, bCompressed, iFileSize, iCompressedSize
Dim As String aB64(1), sB64, sBaseVersion
Restore __Label0:
Read iLines
Read bCompressed
Read iFileSize
Read iCompressedSize
Read sBaseVersion
For i As Ubyte = 0 To iLines
Read aB64(0)
sB64 &= aB64(0)
Next
Dim as UByte Ptr aBinaryImgMag = Base64Decode(sB64, iCompressedSize)
'______________________________________________________________________
_GDIPlus_Startup()
'load image from memory using GDIp to get width and height
hImage_Magnifier = _GDIPlus_BitmapCreateFromMemory3(aBinaryImgMag, iFileSize)
GdipGetImageDimension(hImage_Magnifier, @w, @h)
aBinaryImgMag = 0
'set values for UpdateLayeredWindow parameters
pSize.cx = w
pSize.cy = h
With pBlend
.BlendOp = AC_SRC_OVER
.BlendFlags = 0
.SourceConstantAlpha = 255
.AlphaFormat = AC_SRC_ALPHA
End With
'get desktop size and create GUI
Dim GUI As WNDCLASSEX
Dim As Integer sW, sH
ScreenInfo(sW, sH) 'get primary desktop size
Dim As HWND hHWND_Dt
Dim As RECT tDesktop
hHWND_Dt = FindWindow("Progman","Program Manager") 'get size of the whole desktop
GetWindowRect(hHWND_Dt, @tDesktop)
ScreenL = tDesktop.left
ScreenR = tDesktop.right
ScreenT = tDesktop.top
ScreenB = tDesktop.bottom
ScreenW = tDesktop.right + Abs(ScreenL)
ScreenH = tDesktop.bottom + Abs(ScreenT)
hImage_Desktop = CaptureWholeDesktop()
Dim szAppName As ZString * 30 => "FB GUI"
Dim As String sTitle = "Magnifier by UEZ"
With GUI
.style = CS_HREDRAW Or CS_VREDRAW
.lpfnWndProc = @WndProc
.cbClsExtra = NULL
.cbWndExtra = NULL
.hInstance = GetModuleHandle(NULL)
.hIcon = LoadIcon(NULL, IDI_APPLICATION)
.hCursor = LoadCursor(NULL, IDC_ARROW)
.hbrBackground = GetStockObject(WHITE_BRUSH)
.lpszMenuName = NULL
.lpszClassName = @szAppName
.cbSize = SizeOf(WNDCLASSEX)
End With
Dim As Long ExStyle = WS_EX_TOPMOST Or WS_EX_LAYERED, Style = WS_OVERLAPPEDWINDOW Or WS_VISIBLE
RegisterClassEx(@GUI)
hGUI = CreateWindowEx(ExStyle, GUI.lpszClassName, sTitle, _
Style, _
(sW - w) / 2, (sH - h) / 2, _
w, h, _
NULL, NULL, GUI.hInstance, NULL)
ShowWindow(hGUI, SW_SHOWNORMAL)
'______________________________________________________________________
If OS.dwBuildNumber < 9600 Then
dpi = _WinAPI_GetDPI() / 96
Else
dpi = _WinAPI_GetDpiForWindow(hGUI) / 96
End If
CustomCursor = LoadCursor(Null, IDC_SIZEALL)
Draw_Magnifier(zoom)
Dim uMsg As MSG
While GetMessage(@uMsg, NULL, NULL, NULL) = 1
TranslateMessage(@uMsg)
DispatchMessage(@uMsg)
Wend
GdipDisposeImage(hImage_Magnifier)
GdipDisposeImage(hImage_Desktop)
_GDIPlus_Shutdown()
End
'Code below was generated by: FB File2Bas Code Generator v1.01 build 2020-02-27 beta
Should work also on multi monitors with different DPI settings.
My test environment: Win10 1903