12-22-2025, 08:23 PM (This post was last modified: 12-22-2025, 08:25 PM by Petr.)
The OpenGL version is now available. It is designed for 64-bit IDEs only. The zip file contains the BI, BM, and BAS files, as well as qbvlc_synchro64.dll.
Since we're using OpenGL, the playback is rendered directly on the surface of the flag
I know you dont like me much but mate! Hats off to ya! WELL DONE!
AND TO ME we need an Extensions forum or something where these MAJOR extensions can be stored and easily got to...heck even an option in the GUI for packages would be AWESOME!
Heres your new challenge....as for the life off me i cant make it work!
Before you look there, re-read the second sentence in the first post of this thread a few times. In all honesty, that's the first thing I've written publicly here:
The following dynamic libraries are written in collaboration with AI.
I'm going to open a new thread for DirectX11. If there are any other challenges, please post them there.
static void qb64_tray_load_shell_notifyicon(void) {
if (qb64_Shell_NotifyIconA_p) return;
qb64_tray_shell32 = LoadLibraryA("shell32.dll");
if (!qb64_tray_shell32) return;
qb64_Shell_NotifyIconA_p = (qb64_Shell_NotifyIconA_t)GetProcAddress(qb64_tray_shell32, "Shell_NotifyIconA");
}
static HICON qb64_tray_get_window_icon(HWND hwnd) {
HICON h = (HICON)SendMessageA(hwnd, WM_GETICON, ICON_SMALL, 0);
if (!h) h = (HICON)(uintptr_t)GetClassLongPtrA(hwnd, GCLP_HICONSM);
if (!h) h = (HICON)SendMessageA(hwnd, WM_GETICON, ICON_BIG, 0);
if (!h) h = (HICON)(uintptr_t)GetClassLongPtrA(hwnd, GCLP_HICON);
if (!h) h = LoadIconA(NULL, IDI_APPLICATION);
return h;
}
Declare Library "tray"
Function Tray_Enable% (ByVal hwnd As _Offset, tip As String)
Sub Tray_Disable
Sub Tray_Hide
Sub Tray_Show
Sub Tray_SetTip (tip As String)
End Declare
Dim ok%
ok% = Tray_Enable(_WindowHandle, "My Apllication" + Chr$(0))
If ok% = 0 Then Print "Tray_Enable fail."
Print "H = Hide to tray, S = show, ESC = end"
Dim k$
Do
k$ = UCase$(InKey$)
If k$ = "H" Then Tray_Hide
If k$ = "S" Then Tray_Show
If k$ = Chr$(27) Then Exit Do
_Limit 60
Loop
Let me introduce another utility. This one focuses on system-wide keyboard shortcuts (Global Hotkeys) that the program registers upon startup and - crucially - unregisters when the program is closed properly.
Why is this useful?
Imagine a program running in the background, minimized (for example, to the system tray). In this state, it cannot respond to standard keyboard input because it lacks window focus. A perfect example is a Screen Recorder: you need to control it while it's minimized because you don't want the recorder's own interface to be visible in the recording, obstructing the view.
How Windows Handles Hotkeys:
The Windows operating system does not allow programs to simply "take" any shortcut they want. Once a shortcut is registered by an application, no other program can use it. This is why it is extremely important to ensure the program exits gracefully. In QB64PE, this is handled by the _EXIT function. This ensures that the hotkey is unregistered from the system before the process terminates, making it available again for other applications.
The Blacklist
This program includes a "blacklist" for combinations such as Ctrl + Alt + F1 through Ctrl + Alt + F12 Why? Because many of these are already reserved. For instance,
Ctrl + Alt + F8 is frequently used by Intel graphics drivers, and other system utilities use similar combinations. Remember: a shortcut can only be unregistered by the same application that registered it.
How to test this program:
Startup: When you run the following code, it will automatically find and select the first three available shortcuts and display their combinations to you. Background Test: Minimize the program to the taskbar, switch to a completely different application (e.g., a web browser or text editor), and press one of the shortcuts shown earlier. You should hear a beep (Sound). Verification: Maximize the program window again. You will see that it successfully detected and logged the key presses even while it was in the background.
Multi-instance Test: * Run the program; it will list certain shortcuts.
- Leave it running and launch a second instance of the same program.
- The second instance will display completely different shortcuts.
- This happens because the shortcuts from the first instance are still occupied and will remain so until that first instance is closed correctly and unregisters them.
- This approach is the ideal solution for building system-level applications and background utilities.
static volatile LONG qb64_hk_q_head = 0;
static volatile LONG qb64_hk_q_tail = 0;
static int qb64_hk_queue[64];
typedef struct { int id; int used; } qb64_hk_reg_t;
static qb64_hk_reg_t qb64_hk_regs[64];
static void qb64_hk_push(int id) {
LONG head = qb64_hk_q_head;
LONG next = (head + 1) & 63;
if (next == qb64_hk_q_tail) return; /* full -> drop */
qb64_hk_queue[head] = id;
qb64_hk_q_head = next;
}
static int qb64_hk_add_reg(int id) {
for (int i = 0; i < 64; i++) {
if (!qb64_hk_regs[i].used) { qb64_hk_regs[i].used = 1; qb64_hk_regs[i].id = id; return 1; }
}
return 0;
}
static void qb64_hk_clear_regs(void) {
for (int i = 0; i < 64; i++) { qb64_hk_regs[i].used = 0; qb64_hk_regs[i].id = 0; }
}
#ifdef __cplusplus
extern "C" {
#endif
/* Zavolej 1x na startu – vytvoří message queue pro thread (PeekMessage to zařídí). */
int Hotkey_Enable(void) {
qb64_hk_last_error = 0;
qb64_hk_q_head = qb64_hk_q_tail = 0;
qb64_hk_clear_regs();
/* Globální hotkey pro tento thread: WM_HOTKEY bude v thread message queue. */
int Hotkey_Register(int id, unsigned int modifiers, unsigned int vk) {
qb64_hk_last_error = 0;
void Hotkey_Disable(void) {
for (int i = 0; i < 64; i++) {
if (qb64_hk_regs[i].used) UnregisterHotKey(NULL, qb64_hk_regs[i].id);
}
qb64_hk_clear_regs();
qb64_hk_q_head = qb64_hk_q_tail = 0;
}
/* Poll: vysaje WM_HOTKEY z thread queue a vrátí další ID (0 = nic). */
int Hotkey_Pop(void) {
MSG msg;
while (PeekMessageA(&msg, NULL, WM_HOTKEY, WM_HOTKEY, PM_REMOVE)) {
qb64_hk_push((int)msg.wParam); /* wParam = hotkey ID */
}
LONG tail = qb64_hk_q_tail;
if (tail == qb64_hk_q_head) return 0;
int id = qb64_hk_queue[tail];
qb64_hk_q_tail = (tail + 1) & 63;
return id;
}
unsigned long Hotkey_GetLastError(void) {
return (unsigned long)qb64_hk_last_error;
}
' ---- hotkey.h API ----
Declare Library "hotkey"
Function Hotkey_Enable% ()
Function Hotkey_Register% (ByVal id As Long, ByVal modifiers As Long, ByVal vk As Long)
Sub Hotkey_Unregister (ByVal id As Long)
Function Hotkey_Pop% ()
Function Hotkey_GetLastError~& ()
End Declare
Print
Print "Press selected hotkeys. ESC end."
Do
Dim id As Long
id = Hotkey_Pop
If id Then
Select Case id
Case 1: Print "Function #1 (ID=1) run: "; GlobalKeyText$(1): Sound 150, .5
Case 2: Print "Function #2 (ID=2) run: "; GlobalKeyText$(2): Sound 300, .5
Case 3: Print "Function #3 (ID=3) run: "; GlobalKeyText$(3): Sound 450, .5
End Select
End If
_Limit 200
Loop Until InKey$ = Chr$(27) Or _Exit
'erase it and unregister it
Dim i As Long
For i = 1 To 3
Hotkey_Unregister i
Next i
System
Function ModName$ (m As Long)
Dim s As String
If (m And MOD_CONTROL) Then s = s + "Ctrl+"
If (m And MOD_ALT) Then s = s + "Alt+"
If (m And MOD_SHIFT) Then s = s + "Shift+"
If (m And MOD_WIN) Then s = s + "Win+"
If Len(s) Then s = Left$(s, Len(s) - 1)
ModName$ = s
End Function
Function VkName$ (vk As Long)
' F1-F12
If vk >= VK_F1 And vk <= VK_F12 Then
VkName$ = "F" + LTrim$(Str$(vk - VK_F1 + 1))
Exit Function
End If
' Numpad 0-9
If vk >= VK_NUMPAD0 And vk <= (VK_NUMPAD0 + 9) Then
VkName$ = "Num" + LTrim$(Str$(vk - VK_NUMPAD0))
Exit Function
End If
' A-Z
If vk >= &H41 And vk <= &H5A Then VkName$ = Chr$(vk): Exit Function
' 0-9
If vk >= &H30 And vk <= &H39 Then VkName$ = Chr$(vk): Exit Function
VkName$ = "VK_" + Hex$(vk)
End Function
Function KeyText$ (mods As Long, vk As Long)
KeyText$ = ModName$(mods) + "+" + VkName$(vk)
End Function
' return -1 if ok, 0 if fail
Function TryRegisterAndStore% (id As Long, mods As Long, vk As Long)
' To be on the safe side, if it is called multiple times: unregister the old ID
Hotkey_Unregister id
If Hotkey_Register(id, mods, vk) Then
GlobalMods(id) = mods
GlobalVK(id) = vk
GlobalKeyText$(id) = KeyText$(mods, vk)
TryRegisterAndStore% = -1
Else
TryRegisterAndStore% = 0
End If
End Function
' Main: finds the first n free ones from a predefined order and registers them under ID 1..n
Sub SetGlobalKeys (n As Long)
Dim modSet(1 To 6) As Long
' Order = preference (cleanest/least collision first)
modSet(1) = MOD_CONTROL Or MOD_ALT Or MOD_NOREPEAT
modSet(2) = MOD_CONTROL Or MOD_ALT Or MOD_SHIFT Or MOD_NOREPEAT
modSet(3) = MOD_CONTROL Or MOD_ALT Or MOD_WIN Or MOD_NOREPEAT
modSet(4) = MOD_CONTROL Or MOD_ALT Or MOD_SHIFT Or MOD_WIN Or MOD_NOREPEAT
modSet(5) = MOD_CONTROL Or MOD_SHIFT Or MOD_NOREPEAT ' a× pozdýji (bý×nýjÜÝ)
modSet(6) = MOD_ALT Or MOD_SHIFT Or MOD_NOREPEAT ' a× pozdýji
' Candidate keys (no F13+; no "killers" like Ctrl+C etc.)
' 1) F-keys (often best for recorders)
' 2) Numpad (if user has one)
' 3) A few letters that usually have no global meaning (R,P,M,K,J,...)
Dim vkList(1 To 12 + 10 + 8) As Long
Dim idx As Long: idx = 0
Dim vk As Long
For vk = VK_F12 To VK_F1 Step -1 ' start from F12 down so you can see what is occupied right away
idx = idx + 1: vkList(idx) = vk
Next vk
For vk = VK_NUMPAD0 To (VK_NUMPAD0 + 9)
idx = idx + 1: vkList(idx) = vk
Next vk
Dim need As Long: need = n
Dim id As Long, mi As Long, vi As Long
Dim found As Long
For id = 1 To need
found = 0
For mi = 1 To 6
For vi = 1 To idx
If IsBlacklisted%(modSet(mi), vkList(vi)) Then
' p°eskoŔ
Else
If TryRegisterAndStore%(id, modSet(mi), vkList(vi)) Then
found = -1
Exit For
End If
End If
Next vi
If found Then Exit For
Next mi
If Not found Then
GlobalKeyText$(id) = "NOT FOUND (all occupied)"
End If
Next id
' program list to program window
Cls
For id = 1 To need
Print "GlobalKey("; id; ") = "; GlobalKeyText$(id)
Next id
End Sub
Function IsBlacklisted% (mods As Long, vk As Long) 'disable combinations as CTRL + ALT + Fx (often used with graphic drivers and graphic system calls)
If (mods And (MOD_CONTROL Or MOD_ALT)) = (MOD_CONTROL Or MOD_ALT) Then
If vk >= VK_F1 And vk <= VK_F12 Then
IsBlacklisted% = -1
Exit Function
End If
End If
IsBlacklisted% = 0
End Function
// default: dnešní datum
GetLocalTime(&ctx.stInit);
ctx.hasInit = 1;
// pokud je initialISO zadáno jako YYYY-MM-DD, použij ho
if (initialISO && initialISO[0]) {
int y=0, m=0, d=0;
if (sscanf(initialISO, "%d-%d-%d", &y, &m, &d) == 3) {
if (y >= 1601 && m >= 1 && m <= 12 && d >= 1 && d <= 31) {
ctx.stInit.wYear = (WORD)y;
ctx.stInit.wMonth = (WORD)m;
ctx.stInit.wDay = (WORD)d;
}
}
}
// modal-ish smyčka: pumpuje zprávy, dokud okno existuje
MSG msg;
while (IsWindow(hwnd) && GetMessageA(&msg, NULL, 0, 0) > 0) {
TranslateMessage(&msg);
DispatchMessageA(&msg);
}
if (!ctx.ok) return 0;
// Zapiš výsledek
int n = snprintf(outISO, (size_t)outISOBytes, "%04u-%02u-%02u",
(unsigned)ctx.stSel.wYear, (unsigned)ctx.stSel.wMonth, (unsigned)ctx.stSel.wDay);
// pojistka NUL
outISO[outISOBytes - 1] = 0;
return (n > 0) ? 1 : 0;
}
#endif // QB64PE_PICKDATE_H
pdate.bas:
Code: (Select All)
$Console
Declare CustomType Library "pdate"
Function PickDate% Alias qb64_pickdate (outISO As String, ByVal outISOBytes As Long, initialISO As String)
End Declare
12-27-2025, 01:35 PM (This post was last modified: 12-27-2025, 01:35 PM by Petr.)
5.1 Sound in QB64PE
Hello, I would like to inquire whether anyone has a 5.1 sound output configured on their PC. I could only perform a partial test because I am limited to a stereo setup. To utilize 5.1, one must activate the 5.1 mode in the sound settings or the dedicated sound card application. This is the initial version.
I know that surround sound was discussed here previously, specifically by @MasterGy, so I have try do something in this way.
Zip file contains 3x BAS, BI file, 32bit and 64bit DLL file, and testings S3M music file. DLL's source files also included.
(12-27-2025, 01:35 PM)Petr Wrote: 5.1 Sound in QB64PE
Hello, I would like to inquire whether anyone has a 5.1 sound output configured on their PC. I could only perform a partial test because I am limited to a stereo setup. To utilize 5.1, one must activate the 5.1 mode in the sound settings or the dedicated sound card application. This is the initial version.
I know that surround sound was discussed here previously, specifically by @MasterGy, so I have try do something in this way.
Zip file contains 3x BAS, BI file, 32bit and 64bit DLL file, and testings S3M music file. DLL's source files also included.
Yes, I've dealt with it. But it's not a true 4-channel control. Two sound samples are running at the same time. The original, and one modified (without the high notes). And the program changes the balance and the volume ratio of the two sound samples depending on where the observer is.
01-07-2026, 06:31 PM (This post was last modified: 01-07-2026, 09:17 PM by Petr.
Edit Reason: typo
)
Transparent program window
Code: (Select All)
Declare Dynamic Library "user32"
Function GetWindowLongPtrA%& (ByVal hWnd As _Offset, ByVal nIndex As Long)
Function SetWindowLongPtrA%& (ByVal hWnd As _Offset, ByVal nIndex As Long, ByVal dwNewLong As _Offset)
Function SetLayeredWindowAttributes& (ByVal hWnd As _Offset, ByVal crKey As Long, ByVal bAlpha As _Unsigned _Byte, ByVal dwFlags As Long)
Function SetWindowPos& (ByVal hWnd As _Offset, ByVal hWndInsertAfter As _Offset, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal uFlags As Long)
End Declare
Dim hWnd As _Offset
Dim exStyle As _Offset
Dim opacity As Integer
Screen _NewImage(800, 600, 32)
_Title "QB64PE - transparent program window"
hWnd = _WindowHandle
opacity = 255 ' 0 = full transparent, 255 = not transparent
exStyle = GetWindowLongPtrA(hWnd, GWL_EXSTYLE)
exStyle = exStyle Or WS_EX_LAYERED
N = SetWindowLongPtrA(hWnd, GWL_EXSTYLE, exStyle)
' některé změny stylů se projeví až po SetWindowPos :contentReference[oaicite:3]{index=3}
N = SetWindowPos(hWnd, 0, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE Or SWP_NOZORDER Or SWP_FRAMECHANGED)
N = SetLayeredWindowAttributes(hWnd, 0, opacity, LWA_ALPHA)
Do
Locate 1
Print "Use mousewheel..."
oldopacity = opacity
While _MouseInput
opacity = opacity + _MouseWheel
Wend
opacity = _IIf(opacity > 254, 254, opacity)
opacity = _IIf(opacity < 1, 1, opacity)
If oldopacity <> opacity Then
oldopacity = opacity
N = SetLayeredWindowAttributes(hWnd, 0, opacity, LWA_ALPHA)
End If
The following 4 programs show that in Windows you are not limited to rectangular or square program windows. How about a circular program window? The first example is the clock program. Yeah. There were those. But - where is the program window?
Code: (Select All)
Option _Explicit
' Circular window + analog clock demo for QB64PE (Windows)
'
' Key concept:
' Windows normally treats a window as a rectangle. You can "shape" the
' window by assigning it a region (HRGN). Anything outside that region is:
' - not visible (clipped away)
' - not hit-testable (mouse clicks fall through to whatever is underneath)
'
' This program does two important window-level operations:
' 1) Removes the standard window frame (title bar, borders, system buttons)
' because a non-rectangular region would otherwise cut those parts off.
' 2) Creates a circular region (CreateEllipticRgn) and applies it via
' SetWindowRgn, turning the window into a circle.
' POINTAPI is used by GetCursorPos()
' It stores the cursor position in SCREEN coordinates (desktop coordinate space).
Type POINTAPI
x As Long
y As Long
End Type
' RECT is used by GetWindowRect()
' It stores the window rectangle in SCREEN coordinates: Left/Top/Right/Bottom.
Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
' GetWindowLongPtrA / SetWindowLongPtrA:
' Read/modify window attributes stored inside the HWND.
'
' Important notes:
' - On 64-bit Windows, styles and pointers are "pointer-sized".
' - In QB64PE, _Offset is used to safely hold pointer-sized values.
'
' nIndex selects what you read/write:
' GWL_STYLE = base (standard) style flags (WS_*)
' GWL_EXSTYLE= extended style flags (WS_EX_*)
Function GetWindowLongPtrA%& (ByVal hWnd As _Offset, ByVal nIndex As Long)
Function SetWindowLongPtrA%& (ByVal hWnd As _Offset, ByVal nIndex As Long, ByVal dwNewLong As _Offset)
' SetWindowPos:
' Repositions/resizes a window and/or tells Windows to re-evaluate
' certain aspects (like frame changes) depending on flags.
'
' We use it for two reasons:
' - Apply the changed style immediately (SWP_FRAMECHANGED)
' - Optionally position the window (X,Y) and show it (SWP_SHOWWINDOW)
Function SetWindowPos& (ByVal hWnd As _Offset, ByVal hWndInsertAfter As _Offset, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal uFlags As Long)
' SetWindowRgn:
' Assigns a clipping region to the window.
' The system uses this region to determine:
' - what part of the window is visible
' - what part receives mouse input
'
' After a successful call, Windows owns the region handle (HRGN).
' You must NOT delete it yourself (in C you would normally NOT call DeleteObject).
Function SetWindowRgn& (ByVal hWnd As _Offset, ByVal hRgn As _Offset, ByVal bRedraw As Long)
' GetCursorPos:
' Returns current cursor position in SCREEN coordinates.
' Used for dragging the window around with the mouse.
Function GetCursorPos& (lpPoint As POINTAPI)
' GetWindowRect:
' Returns the window's rectangle in SCREEN coordinates.
' Used to remember the original window position before dragging.
Function GetWindowRect& (ByVal hWnd As _Offset, lpRect As RECT)
' CreateEllipticRgn:
' Creates an elliptical region that fits inside the given bounding box.
' If the bounding box is a square (width == height), the region is a circle.
'
' Parameters are in CLIENT coordinates of the window region:
' (0,0) is top-left of the window
' (diam, diam) is bottom-right
'
' Returns HRGN handle (pointer-sized) -> stored in _Offset
Function CreateEllipticRgn%& (ByVal nLeftRect As Long, ByVal nTopRect As Long, ByVal nRightRect As Long, ByVal nBottomRect As Long)
End Declare
' Constants: window style manipulation
' GWL_STYLE selects the standard window style flags (WS_*).
Const GWL_STYLE = -16
' Standard style bits (WS_*):
' These control title bar, borders, and system buttons.
Const WS_CAPTION = &HC00000 ' Title bar area (caption)
Const WS_THICKFRAME = &H40000 ' Resizable border frame
Const WS_MINIMIZEBOX = &H20000 ' Minimize button
Const WS_MAXIMIZEBOX = &H10000 ' Maximize button
Const WS_SYSMENU = &H80000 ' System menu (icon/menu on the title bar)
' WS_POPUP:
' A top-level window without the standard overlapped frame.
' This is the typical base for shaped windows (no title bar to be cut off).
Const WS_POPUP = &H80000000
' SWP_FRAMECHANGED:
' Tells Windows: "the frame/style changed; recompute non-client area".
' This is the key flag after changing window styles using SetWindowLongPtrA.
Const SWP_FRAMECHANGED = &H20
' SWP_SHOWWINDOW:
' Ensures the window is shown after style/position changes.
Const SWP_SHOWWINDOW = &H40
Dim diam As Long ' Diameter of the circular window (and client area)
Dim cx As Long, cy As Long ' Center coordinates (client space)
Dim r As Long ' Radius used for drawing the clock face
Dim hWnd As _Offset ' HWND (window handle) - pointer-sized
Dim style As _Offset ' Style bitfield - pointer-sized
Dim hRgn As _Offset ' HRGN (region handle) - pointer-sized
Dim N As Long ' Return values from WinAPI calls (success/failure codes)
' Dragging state variables
Dim dragActive As Long
Dim ptStart As POINTAPI, ptNow As POINTAPI
Dim rcStart As RECT
Dim wndStartLeft As Long, wndStartTop As Long
Dim startX As Long, startY As Long
Dim dx As Long, dy As Long
' Create QB64PE window / backbuffer
diam = 420
' Create a 32-bit image and use it as the screen.
' In QB64PE this becomes the window client area (your drawable surface).
Screen _NewImage(diam, diam, 32)
_Title "Circular Clock (ESC = konec)"
' Obtain HWND of the QB64PE window so we can call WinAPI on it.
hWnd = _WindowHandle
' 1) Convert the normal window into a borderless popup window
'
' Why this matters:
' If you apply a circular region to a normal "framed" window, Windows will
' also clip the title bar and borders. The result is visually broken:
' half a title bar, cut buttons, etc.
'
' So the correct approach for shaped windows is:
' - remove caption and borders
' - use WS_POPUP
' - provide your own close/drag behavior (ESC to close, click-drag to move)
' Read current standard style bits.
style = GetWindowLongPtrA(hWnd, GWL_STYLE)
' Clear the bits that define the standard frame.
' AND NOT(mask) clears those bits.
style = style And Not (WS_CAPTION Or WS_THICKFRAME Or WS_MINIMIZEBOX Or WS_MAXIMIZEBOX Or WS_SYSMENU)
' Add WS_POPUP to make it a clean borderless top-level window.
style = style Or WS_POPUP
' Write the modified style back to the window.
N = SetWindowLongPtrA(hWnd, GWL_STYLE, style)
' Force Windows to re-apply/recalculate the window frame after style change.
' Also set an initial position and size (200,150) and show the window.
'
' Note:
' Without SWP_FRAMECHANGED, style changes may not visually apply immediately.
N = SetWindowPos(hWnd, 0, 200, 150, diam, diam, SWP_FRAMECHANGED Or SWP_SHOWWINDOW)
' 2) Create and apply a circular window region (HRGN)
'
' CreateEllipticRgn(0,0,diam,diam) makes an ellipse inside the client rectangle.
' Since width == height, that ellipse is a circle.
'
' SetWindowRgn then tells Windows: "this window exists only inside this region".
' Everything outside becomes:
' - not painted
' - not clickable (mouse input passes through)
'
' Ownership note (important):
' After SetWindowRgn succeeds, Windows owns the region object.
' You should NOT free/delete it yourself.
' --- Exit key: ESC ---
If _KeyHit = 27 Then Exit Do
' --- Pump mouse events ---
' QB64PE requires consuming _MouseInput in a loop to keep state updated.
While _MouseInput
' Just pumping the input queue; no work needed here.
Wend
' Custom window dragging (since we removed title bar)
'
' When left mouse button is down:
' - On first frame: remember cursor position + window top-left
' - On subsequent frames: move window by cursor delta using SetWindowPos
'
' Coordinates:
' GetCursorPos and GetWindowRect both operate in SCREEN coordinates.
If _MouseButton(1) Then
If dragActive = 0 Then
dragActive = -1
N = GetCursorPos(ptStart)
N = GetWindowRect(hWnd, rcStart)
startX = ptStart.x
startY = ptStart.y
Else
N = GetCursorPos(ptNow)
dx = ptNow.x - startX
dy = ptNow.y - startY
' Move only (no resize), keep z-order unchanged.
N = SetWindowPos(hWnd, 0, wndStartLeft + dx, wndStartTop + dy, 0, 0, SWP_NOSIZE Or SWP_NOZORDER)
End If
Else
dragActive = 0
End If
' --- Draw clock into the circular client area ---
Call DrawClock(cx, cy, r)
_Display
_Limit 60
Loop
End
' Analog clock drawing routine
Sub DrawClock (cx As Long, cy As Long, r As Long)
Dim t As String
Dim hh As Long, mm As Long, ss As Long
Dim hour12 As Long
Dim pi As Double
Dim aSec As Double, aMin As Double, aHour As Double
Dim radSec As Double, radMin As Double, radHour As Double
Dim x1 As Long, y1 As Long, x2 As Long, y2 As Long
Dim i As Long
Dim tickIn As Double, tickOut As Double
Dim angDeg As Double, angRad As Double
Dim s As String
Dim tx As Long, ty As Long
pi = 3.141592653589793#
Cls , _RGB32(10, 10, 14)
' Clock face border + fill
Circle (cx, cy), r, _RGB32(220, 220, 230)
Paint (cx, cy), _RGB32(30, 30, 40), _RGB32(220, 220, 230)
' Tick marks: 60 markers; every 5th is longer (hour tick)
For i = 0 To 59
angDeg = i * 6
angRad = angDeg * pi / 180#
tickOut = r * 0.98
If (i Mod 5) = 0 Then
tickIn = r * 0.86
Else
tickIn = r * 0.92
End If
' Read current time in HH:MM:SS
t = Time$
hh = Val(Left$(t, 2))
mm = Val(Mid$(t, 4, 2))
ss = Val(Right$(t, 2))
hour12 = hh Mod 12
' Convert to angles (degrees):
' second hand: 6 degrees per second
' minute hand: 6 degrees per minute + fractional by seconds
' hour hand : 30 degrees per hour + fractional by minutes/seconds
aSec = ss * 6#
aMin = (mm + ss / 60#) * 6#
aHour = (hour12 + mm / 60# + ss / 3600#) * 30#
' Convert degrees -> radians for SIN/COS
radSec = aSec * pi / 180#
radMin = aMin * pi / 180#
radHour = aHour * pi / 180#
' Second hand
x2 = cx + Sin(radSec) * (r * 0.88)
y2 = cy - Cos(radSec) * (r * 0.88)
Line (cx, cy)-(x2, y2), _RGB32(255, 80, 80)
' Center cap
Circle (cx, cy), 4, _RGB32(255, 255, 255)
Paint (cx, cy), _RGB32(255, 255, 255), _RGB32(255, 255, 255)
' Digital time at the bottom (inside the circle)
s = t
tx = cx - (Len(s) * 4)
ty = cy + r \ 2
_PrintString (tx, ty), s
End Sub
Sub PutNumber (cx As Long, cy As Long, r As Long, angDeg As Long, txt As String)
Dim pi As Double
Dim angRad As Double
Dim rr As Double
Dim x As Long, y As Long
pi = 3.141592653589793#
rr = r * 0.70
angRad = angDeg * pi / 180#
x = cx + Sin(angRad) * rr
y = cy - Cos(angRad) * rr
' Rough centering for the default QB64 font
x = x - (Len(txt) * 4)
y = y - 8
_PrintMode _KeepBackground
_PrintString (x, y), txt
End Sub
The second program shows how to do the same thing, with a transparent background. Slow version, notice the edge of the clock. The edge is still visible.
Code: (Select All)
Option _Explicit
' CIRCULAR CLOCK WINDOW WITH SOFT (ANTI-ALIASED) TRANSPARENT EDGES
'
' What we want:
' - A circular "floating" clock window on the desktop.
' - Smooth/feathered transparency at the outer edge (soft edge),
' so the background under the window is visible gradually.
'
' Why SetWindowRgn alone is NOT enough:
' - SetWindowRgn (HRGN) can only "hard-clip" the window to a shape.
' The result is a sharp, jagged edge (no alpha blending).
' - HRGN is binary: a pixel is either inside (fully visible) or outside
' (fully invisible). No gradual transparency.
'
' The correct method for smooth transparency in Windows:
' 1) Turn the window into a *layered window* by adding WS_EX_LAYERED.
' A layered window can be composited by the Desktop Window Manager (DWM)
' using per-pixel alpha (transparency) information.
'
' 2) Create a 32-bit bitmap (DIB section) that contains your final pixels:
' - 8-bit Alpha
' - 8-bit Red
' - 8-bit Green
' - 8-bit Blue
'
' 3) Build the image each frame:
' - Draw the clock normally into an offscreen QB64 image.
' - For each pixel, compute a circular alpha mask:
' * alpha = 255 inside the circle
' * alpha fades from 255 -> 0 within a "feather band" (edgeFeather)
' * alpha = 0 outside the outer radius
' - Apply alpha to the color using *premultiplied alpha*:
' R' = R * alpha / 255
' G' = G * alpha / 255
' B' = B * alpha / 255
'
' Premultiplied alpha is important because UpdateLayeredWindow expects
' pixels in premultiplied form when AC_SRC_ALPHA is used.
'
' 4) Push the 32-bit pixel buffer into the DIB section memory, then call
' UpdateLayeredWindow(..., ULW_ALPHA).
' Windows will composite the window with per-pixel alpha, giving smooth
' transparent edges.
'
' Optional: SetWindowRgn is still useful
' - We keep a circular HRGN mainly for input hit-testing:
' clicks outside the circle will pass through to windows behind.
' - Visual soft edge is still done by per-pixel alpha, not by the region.
'
' Performance note:
' - This demo does per-pixel CPU work each frame (diam*diam pixels).
' - For 420x420 it is usually fine. If needed, it can be optimized by
' precomputing the alpha mask once and reusing it.
' WinAPI / GDI structs
' Used by GetCursorPos() (screen coordinates).
Type POINTAPI
x As Long
y As Long
End Type
' Used by UpdateLayeredWindow(): the size of the bitmap.
Type SIZEAPI
cx As Long
cy As Long
End Type
' Used by GetWindowRect() (screen coordinates).
Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
' Used by UpdateLayeredWindow() to describe how alpha blending is applied.
Type BLENDFUNCTION
BlendOp As _Unsigned _Byte ' Usually AC_SRC_OVER
BlendFlags As _Unsigned _Byte ' Must be 0
SourceConstantAlpha As _Unsigned _Byte ' Global alpha multiplier (255 = no change)
AlphaFormat As _Unsigned _Byte ' AC_SRC_ALPHA = per-pixel alpha is present
End Type
' Color entry used inside BITMAPINFO (we only need one dummy entry).
Type RGBQUAD
rgbBlue As _Unsigned _Byte
rgbGreen As _Unsigned _Byte
rgbRed As _Unsigned _Byte
rgbReserved As _Unsigned _Byte
End Type
' Describes the DIB section format (32-bit, width/height, etc.).
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
Type BITMAPINFO
bmiHeader As BITMAPINFOHEADER
bmiColors As RGBQUAD
End Type
Declare Dynamic Library "user32"
' Get/SetWindowLongPtrA:
' Read/write window attributes (styles) stored in the HWND.
' We use:
' - GWL_STYLE for standard style bits (WS_*)
' - GWL_EXSTYLE for extended style bits (WS_EX_*)
Function GetWindowLongPtrA%& (ByVal hWnd As _Offset, ByVal nIndex As Long)
Function SetWindowLongPtrA%& (ByVal hWnd As _Offset, ByVal nIndex As Long, ByVal dwNewLong As _Offset)
' SetWindowPos:
' Moves/resizes a window and/or forces Windows to re-evaluate the frame.
' SWP_FRAMECHANGED is critical after changing style flags.
Function SetWindowPos& (ByVal hWnd As _Offset, ByVal hWndInsertAfter As _Offset, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal uFlags As Long)
' SetWindowRgn:
' Assigns an HRGN to the window. This clips the window AND affects hit-test.
' After success, Windows owns the region object (do not delete it yourself).
Function SetWindowRgn& (ByVal hWnd As _Offset, ByVal hRgn As _Offset, ByVal bRedraw As Long)
' Used for custom dragging (cursor position in screen coords).
Function GetCursorPos& (lpPoint As POINTAPI)
' Used for custom dragging (window rectangle in screen coords).
Function GetWindowRect& (ByVal hWnd As _Offset, lpRect As RECT)
' GetDC/ReleaseDC:
' Get a device context. We use the screen DC (hWnd=0) as reference for GDI.
Function GetDC%& (ByVal hWnd As _Offset)
Function ReleaseDC& (ByVal hWnd As _Offset, ByVal hDC As _Offset)
' UpdateLayeredWindow:
' The key function for per-pixel alpha layered windows.
' It takes a source DC containing a 32-bit bitmap and composites it to the
' target window using alpha (ULW_ALPHA).
Function UpdateLayeredWindow& (ByVal hWnd As _Offset, ByVal hdcDst As _Offset, pptDst As POINTAPI, psize As SIZEAPI, ByVal hdcSrc As _Offset, pptSrc As POINTAPI, ByVal crKey As Long, pblend As BLENDFUNCTION, ByVal dwFlags As Long)
End Declare
Declare Dynamic Library "gdi32"
' CreateEllipticRgn:
' Creates an ellipse region inside the rectangle (left,top,right,bottom).
' If width == height, it is a circle.
Function CreateEllipticRgn%& (ByVal nLeftRect As Long, ByVal nTopRect As Long, ByVal nRightRect As Long, ByVal nBottomRect As Long)
' CreateCompatibleDC:
' Creates a memory DC compatible with a given DC. We will select a DIB into it.
Function CreateCompatibleDC%& (ByVal hdc As _Offset)
Function DeleteDC& (ByVal hdc As _Offset)
' SelectObject:
' Selects a GDI object (bitmap) into a DC and returns previous selection.
Function SelectObject%& (ByVal hdc As _Offset, ByVal hObject As _Offset)
' DeleteObject:
' Deletes a GDI object (bitmap, region, etc). Note: region is owned by Windows
' after SetWindowRgn success, so we do not delete the region ourselves.
Function DeleteObject& (ByVal hObject As _Offset)
' CreateDIBSection:
' Creates a bitmap (DIB) and returns a pointer to its pixel memory (ppvBits).
' We use 32bpp BI_RGB (BGRA in memory).
Function CreateDIBSection%& (ByVal hdc As _Offset, bmi As BITMAPINFO, ByVal iUsage As Long, ppvBits As _Offset, ByVal hSection As _Offset, ByVal dwOffset As Long)
End Declare
' Fast memory copy
Declare Dynamic Library "kernel32"
' RtlMoveMemory:
' Copies raw bytes from src -> dest. We use it to copy our pixel array
' into the DIB section memory (pBits) efficiently.
Sub RtlMoveMemory (ByVal dest As _Offset, ByVal src As _Offset, ByVal cb As Long)
End Declare
' Indices for GetWindowLongPtr/SetWindowLongPtr
Const GWL_STYLE = -16
Const GWL_EXSTYLE = -20
' Window / clock geometry
Dim diam As Long
Dim cx As Long, cy As Long
Dim rClock As Long
' Window handle and style words
Dim hWnd As _Offset
Dim style As _Offset
Dim exStyle As _Offset
Dim N As Long
' Dragging state
Dim dragActive As Long
Dim ptStart As POINTAPI, ptNow As POINTAPI
Dim rcStart As RECT
Dim wndStartLeft As Long, wndStartTop As Long
Dim startX As Long, startY As Long
Dim dx As Long, dy As Long
' Layered window / DIB objects
Dim hdcScreen As _Offset ' DC for the entire screen (desktop)
Dim hdcMem As _Offset ' Memory DC that will hold our DIB section
Dim hBmp As _Offset ' The DIB section bitmap handle
Dim hBmpOld As _Offset ' Previous bitmap selected into hdcMem
Dim pBits As _Offset ' Pointer to raw DIB pixel memory
Dim bmi As BITMAPINFO
Dim sz As SIZEAPI
Dim ptSrc As POINTAPI
Dim ptDst As POINTAPI
Dim blend As BLENDFUNCTION
' Offscreen QB64 image (we draw the clock here using QB64 primitives)
Dim img As Long
Dim memImg As _MEM
' Pixel buffer:
' We build a 32-bit AARRGGBB value per pixel in an array,
' then copy it into the DIB memory (pBits) using RtlMoveMemory.
Dim pixels As _Unsigned Long
Dim pixelCount As Long
Dim bytesCount As Long
' Soft-edge mask parameters
Dim Shared edgeFeather As Long ' Width (in pixels) of the alpha fade band
Dim Shared rEdge As Long ' Outer radius (alpha==0 outside)
Dim Shared rEdge2 As Long ' rEdge squared
Dim Shared rInner As Long ' Inner radius (alpha==255 inside)
Dim Shared rInner2 As Long ' rInner squared
' Loop variables / per-pixel work
Dim x As Long, y As Long
Dim idx As Long
Dim dxp As Long, dyp As Long
Dim d2 As Long
Dim dist As Single
Dim a As Long ' alpha 0..255 for current pixel
' Color channels / packing
Dim c~& ' QB64 pixel read from _MemGet
Dim rr As Long, gg As Long, bb As Long
Dim rp As Long, gp As Long, bp As Long
Dim outpt~&
' Create an offscreen image for the clock drawing.
' We will draw into this image, then read pixels from it.
img = _NewImage(diam, diam, 32)
memImg = _MemImage(img)
' 1) Make the QB64PE window borderless (WS_POPUP)
'
' Why:
' - A shaped/layered window usually looks wrong with a normal title bar.
' - We remove caption/borders/buttons and replace with WS_POPUP.
' - Since there is no title bar, we implement dragging manually (mouse).
style = GetWindowLongPtrA(hWnd, GWL_STYLE)
' Remove standard frame bits
style = style And Not (WS_CAPTION Or WS_THICKFRAME Or WS_MINIMIZEBOX Or WS_MAXIMIZEBOX Or WS_SYSMENU)
' Add popup style
style = style Or WS_POPUP
N = SetWindowLongPtrA(hWnd, GWL_STYLE, style)
' 2) Enable WS_EX_LAYERED (required for per-pixel alpha)
'
' Without WS_EX_LAYERED:
' - UpdateLayeredWindow will not provide per-pixel transparency for the window.
' With WS_EX_LAYERED:
' - The window content can be composited from a 32-bit bitmap with alpha.
exStyle = GetWindowLongPtrA(hWnd, GWL_EXSTYLE)
exStyle = exStyle Or WS_EX_LAYERED
N = SetWindowLongPtrA(hWnd, GWL_EXSTYLE, exStyle)
' Apply style changes and show the window at initial position.
ptDst.x = 200
ptDst.y = 150
N = SetWindowPos(hWnd, 0, ptDst.x, ptDst.y, diam, diam, SWP_FRAMECHANGED Or SWP_SHOWWINDOW)
' 3) Optional: assign a circular window region (HRGN)
'
' Visual soft edge is done by alpha (UpdateLayeredWindow).
' The region is kept mainly for input behavior:
' - outside the circle, the window does not receive mouse clicks
' - clicks "fall through" to windows behind
Dim hRgn As _Offset
hRgn = CreateEllipticRgn(0, 0, diam, diam)
N = SetWindowRgn(hWnd, hRgn, -1)
' 4) Create a 32bpp DIB section that will be used as the source bitmap
' for UpdateLayeredWindow.
'
' Why DIB section:
' - It gives us a pointer (pBits) to raw pixel memory.
' - We can fill pixels directly, then Windows can use it for compositing.
'
' Important: top-down DIB
' - biHeight negative => the first scanline is the top row (y=0).
' - This matches the natural coordinate system we use in our loops.
hdcScreen = GetDC(0) ' Screen DC (desktop)
hdcMem = CreateCompatibleDC(hdcScreen)
' Geometry for the clock and the soft edge mask
cx = diam \ 2
cy = diam \ 2
rClock = (diam \ 2) - 6
' Soft edge settings:
' edgeFeather is the width of the fade ring at the outer edge.
' Small values (4..12) look like anti-aliasing.
' Large values (like 120) create a huge halo where the whole clock area
' gradually fades out (often too much, but it is your dial).
edgeFeather = 120
' Prepare output pixel buffer
pixelCount = diam * diam
bytesCount = pixelCount * 4
ReDim pixels(0 To pixelCount - 1) As _Unsigned Long
dragActive = 0
Do
If _KeyHit = 27 Then Exit Do
' Pump mouse input queue so _MouseButton/_MouseWheel etc. stay current.
While _MouseInput
Wend
' Custom dragging:
' Because the window is WS_POPUP (no title bar), we move it ourselves.
' We do NOT call SetWindowPos every frame here:
' - ptDst is passed into UpdateLayeredWindow
' - UpdateLayeredWindow can reposition the layered window for us
If _MouseButton(1) Then
If dragActive = 0 Then
dragActive = -1
N = GetCursorPos(ptStart)
N = GetWindowRect(hWnd, rcStart)
startX = ptStart.x
startY = ptStart.y
Else
N = GetCursorPos(ptNow)
dx = ptNow.x - startX
dy = ptNow.y - startY
ptDst.x = wndStartLeft + dx
ptDst.y = wndStartTop + dy
End If
Else
dragActive = 0
End If
' (1) Draw the clock into an offscreen QB64 image
'
' We use normal QB64 drawing primitives. This image is NOT
' directly shown. It is only a source of RGB color data.
_Dest img
Call DrawClock(cx, cy, rClock)
_Dest 0
' (2) Build premultiplied 32-bit pixels for UpdateLayeredWindow
'
' For each pixel:
' - Compute alpha based on distance from center:
' * 255 inside the inner radius
' * fade to 0 across the feather ring
' * 0 outside the outer radius
'
' - Read the RGB color from the QB64 offscreen image.
'
' - Premultiply:
' rp = rr * alpha / 255
' gp = gg * alpha / 255
' bp = bb * alpha / 255
'
' - Pack as AARRGGBB in a 32-bit integer.
' In memory (little-endian), this becomes BGRA byte order, which is
' exactly what the 32bpp BI_RGB DIB expects.
idx = 0
For y = 0 To diam - 1
dyp = y - cy
For x = 0 To diam - 1
dxp = x - cx
d2 = dxp * dxp + dyp * dyp
' Alpha mask with a fast squared-distance test:
' - avoid Sqr() unless we are in the feather band
If d2 >= rEdge2 Then
a = 0
ElseIf d2 <= rInner2 Then
a = 255
Else
dist = Sqr(d2)
a = (rEdge - dist) / edgeFeather * 255
If a < 0 Then a = 0
If a > 255 Then a = 255
End If
If a = 0 Then
' Fully transparent pixel -> ARGB = 0
pixels(idx) = 0
Else
' Read QB64 pixel (32-bit) from the offscreen image memory.
' Each pixel is 4 bytes. idx is linear index.
c~& = _MemGet(memImg, memImg.OFFSET + idx * 4, _Unsigned Long)
' Premultiply RGB by alpha
rp = (rr * a + 127) \ 255
gp = (gg * a + 127) \ 255
bp = (bb * a + 127) \ 255
' Pack to AARRGGBB (numeric). In memory this is BGRA bytes.
outpt~& = (a * &H1000000~&) Or (rp * &H10000~&) Or (gp * &H100~&) Or bp
pixels(idx) = outpt~&
End If
idx = idx + 1
Next x
Next y
' Copy our array into the DIB section memory. This is the buffer
' UpdateLayeredWindow will read from.
Call RtlMoveMemory(pBits, _Offset(pixels(0)), bytesCount)
' (3) Present the layered window (per-pixel alpha)
'
' UpdateLayeredWindow composites the source bitmap (hdcMem/hBmp)
' into our window at position ptDst using alpha (ULW_ALPHA).
s = t
tx = cx - (Len(s) * 4)
ty = cy + r / 2
_PrintString (tx, ty), s
End Sub
Sub PutNumber (cx As Long, cy As Long, r As Long, angDeg As Long, txt As String)
Dim pi As Double
Dim angRad As Double
Dim rr As Double
Dim x As Long, y As Long
pi = 3.141592653589793#
rr = r * 0.70
angRad = angDeg * pi / 180#
x = cx + Sin(angRad) * rr
y = cy - Cos(angRad) * rr
x = x - (Len(txt) * 4)
y = y - 8
_PrintMode _KeepBackground
_PrintString (x, y), txt
End Sub
The third version already includes a pre-calculated mask, so the program is less demanding on the processor. The clock border has also disappeared.
Code: (Select All)
Option _Explicit
' CIRCULAR CLOCK WINDOW WITH HALO/FADE TRANSPARENT EDGES (Windows 10/11)
' ---------------------------------------------------------------------
'
' GOAL
' We want a circular clock window where the outer edge is not a hard cut,
' but a smooth "halo" fade: fully opaque inside, gradually transparent
' towards the outside, so the desktop behind is visible through the edge.
'
' WHY SetWindowRgn ALONE IS NOT ENOUGH
' SetWindowRgn (HRGN) can only hard-clip the window to a shape:
' - inside = fully visible
' - outside = fully invisible
' There is no per-pixel alpha, so no smooth fading.
'
' THE CORRECT METHOD: LAYERED WINDOW + UpdateLayeredWindow (per-pixel alpha)
' 1) Make the window WS_EX_LAYERED.
' This allows Windows DWM to composite the window from a 32-bit bitmap
' using alpha per pixel (0..255).
'
' 2) Create a 32bpp DIB section (CreateDIBSection) and obtain pointer pBits.
' That is raw pixel memory that Windows will read from.
'
' 3) Each frame:
' a) Draw clock normally into an offscreen QB64 image (img).
' b) Read its pixels (we copy them into srcPixels()).
' c) For each pixel compute final alpha from a precomputed alpha mask:
' alphaMask(idx) = 0..255
' This mask encodes the circular halo/fade.
' d) Premultiply RGB by alpha (required by UpdateLayeredWindow):
' R' = R * A / 255
' G' = G * A / 255
' B' = B * A / 255
' e) Store final pixel as AARRGGBB (in memory this becomes BGRA).
' f) Copy the final pixel buffer into pBits.
' g) Call UpdateLayeredWindow(..., ULW_ALPHA).
'
' PRECOMPUTING THE HALO MASK (IMPORTANT OPTIMIZATION)
' The circular alpha mask depends only on:
' - window size (diam)
' - center (cx, cy)
' - outer radius rEdge
' - feather width edgeFeather
' These are constant, so alphaMask(idx) can be computed ONCE at startup.
' Then each frame we reuse alphaMask(idx) without doing sqrt() repeatedly.
'
' OPTIONAL: SetWindowRgn still helps
' Even though visuals come from per-pixel alpha, we keep a circular region
' so that mouse clicks outside the circle fall through to windows behind.
Type POINTAPI
x As Long
y As Long
End Type
Type SIZEAPI
cx As Long
cy As Long
End Type
Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Type BLENDFUNCTION
BlendOp As _Unsigned _Byte
BlendFlags As _Unsigned _Byte
SourceConstantAlpha As _Unsigned _Byte
AlphaFormat As _Unsigned _Byte
End Type
Type RGBQUAD
rgbBlue As _Unsigned _Byte
rgbGreen As _Unsigned _Byte
rgbRed As _Unsigned _Byte
rgbReserved As _Unsigned _Byte
End Type
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
Type BITMAPINFO
bmiHeader As BITMAPINFOHEADER
bmiColors As RGBQUAD
End Type
Declare Dynamic Library "user32"
Function GetWindowLongPtrA%& (ByVal hWnd As _Offset, ByVal nIndex As Long)
Function SetWindowLongPtrA%& (ByVal hWnd As _Offset, ByVal nIndex As Long, ByVal dwNewLong As _Offset)
Function SetWindowPos& (ByVal hWnd As _Offset, ByVal hWndInsertAfter As _Offset, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal uFlags As Long)
Function SetWindowRgn& (ByVal hWnd As _Offset, ByVal hRgn As _Offset, ByVal bRedraw As Long)
Function GetCursorPos& (lpPoint As POINTAPI)
Function GetWindowRect& (ByVal hWnd As _Offset, lpRect As RECT)
Function GetDC%& (ByVal hWnd As _Offset)
Function ReleaseDC& (ByVal hWnd As _Offset, ByVal hDC As _Offset)
Function UpdateLayeredWindow& (ByVal hWnd As _Offset, ByVal hdcDst As _Offset, pptDst As POINTAPI, psize As SIZEAPI, ByVal hdcSrc As _Offset, pptSrc As POINTAPI, ByVal crKey As Long, pblend As BLENDFUNCTION, ByVal dwFlags As Long)
End Declare
Declare Dynamic Library "gdi32"
Function CreateEllipticRgn%& (ByVal nLeftRect As Long, ByVal nTopRect As Long, ByVal nRightRect As Long, ByVal nBottomRect As Long)
Function CreateCompatibleDC%& (ByVal hdc As _Offset)
Function DeleteDC& (ByVal hdc As _Offset)
Function SelectObject%& (ByVal hdc As _Offset, ByVal hObject As _Offset)
Function DeleteObject& (ByVal hObject As _Offset)
Function CreateDIBSection%& (ByVal hdc As _Offset, bmi As BITMAPINFO, ByVal iUsage As Long, ppvBits As _Offset, ByVal hSection As _Offset, ByVal dwOffset As Long)
End Declare
Declare Dynamic Library "kernel32"
Sub RtlMoveMemory (ByVal dest As _Offset, ByVal src As _Offset, ByVal cb As Long)
End Declare
Dim diam As Long
Dim cx As Long, cy As Long
Dim rClock As Long
Dim hWnd As _Offset
Dim style As _Offset
Dim exStyle As _Offset
Dim hRgn As _Offset
Dim N As Long
' Dragging
Dim dragActive As Long
Dim ptStart As POINTAPI, ptNow As POINTAPI
Dim rcStart As RECT
Dim wndStartLeft As Long, wndStartTop As Long
Dim startX As Long, startY As Long
Dim dx As Long, dy As Long
' Layered window / DIB
Dim hdcScreen As _Offset
Dim hdcMem As _Offset
Dim hBmp As _Offset
Dim hBmpOld As _Offset
Dim pBits As _Offset
Dim bmi As BITMAPINFO
Dim sz As SIZEAPI
Dim ptSrc As POINTAPI
Dim ptDst As POINTAPI
Dim blend As BLENDFUNCTION
' Offscreen QB64 image
Dim img As Long
Dim memImg As _MEM
' Source pixels (raw clock drawing copied from QB64 image)
Dim srcPixels As _Unsigned Long
' Output pixels (premultiplied + alpha mask applied)
Dim pixels As _Unsigned Long
Dim pixelCount As Long
Dim bytesCount As Long
' Precomputed alpha mask (halo/fade)
Dim alphaMask As _Unsigned _Byte
' Mask geometry parameters
Dim edgeFeather As Long
Dim rEdge As Long
Dim rEdge2 As Long
Dim rInner As Long
Dim rInner2 As Long
' Loop variables (kept here to respect "no DIM inside loops")
Dim idx As Long
Dim x As Long, y As Long
Dim a As Long
Dim c~&
Dim rr As Long, gg As Long, bb As Long
Dim rp As Long, gp As Long, bp As Long
Dim outpt~&
' Offscreen image where we draw the clock using QB64 primitives.
img = _NewImage(diam, diam, 32)
memImg = _MemImage(img)
' Pixel counts (used for copying blocks of memory)
pixelCount = diam * diam
bytesCount = pixelCount * 4
ReDim srcPixels(0 To pixelCount - 1) As _Unsigned Long
ReDim pixels(0 To pixelCount - 1) As _Unsigned Long
ReDim alphaMask(0 To pixelCount - 1) As _Unsigned _Byte
' 1) Make the window borderless (WS_POPUP)
style = GetWindowLongPtrA(hWnd, GWL_STYLE)
style = style And Not (WS_CAPTION Or WS_THICKFRAME Or WS_MINIMIZEBOX Or WS_MAXIMIZEBOX Or WS_SYSMENU)
style = style Or WS_POPUP
N = SetWindowLongPtrA(hWnd, GWL_STYLE, style)
' 2) Enable layered window (WS_EX_LAYERED) so per-pixel alpha is possible
exStyle = GetWindowLongPtrA(hWnd, GWL_EXSTYLE)
exStyle = exStyle Or WS_EX_LAYERED
N = SetWindowLongPtrA(hWnd, GWL_EXSTYLE, exStyle)
' Apply style changes and show at initial position
ptDst.x = 200
ptDst.y = 150
N = SetWindowPos(hWnd, 0, ptDst.x, ptDst.y, diam, diam, SWP_FRAMECHANGED Or SWP_SHOWWINDOW)
' 3) Optional: region for hit-test (click-through outside the circle)
hRgn = CreateEllipticRgn(0, 0, diam, diam)
N = SetWindowRgn(hWnd, hRgn, -1)
' 4) Create DIB section (32bpp) that UpdateLayeredWindow will use
hdcScreen = GetDC(0)
hdcMem = CreateCompatibleDC(hdcScreen)
' HALO/Fade settings:
' edgeFeather defines how wide the fade band is.
' Large values produce a big halo; small values produce only slight AA.
edgeFeather = 120
' Inner radius (fully opaque inside). Clamp to 0 in case feather is huge.
rInner = rEdge - edgeFeather
If rInner < 0 Then rInner = 0
rInner2 = rInner * rInner
' Build alpha mask ONCE (no per-frame sqrt needed)
Call BuildAlphaMask(alphaMask(), diam, cx, cy, rInner2, rEdge2, rInner, rEdge, edgeFeather)
dragActive = 0
Do
If _KeyHit = 27 Then Exit Do
While _MouseInput
Wend
' Custom window dragging (left mouse button), since WS_POPUP has no titlebar
If _MouseButton(1) Then
If dragActive = 0 Then
dragActive = -1
N = GetCursorPos(ptStart)
N = GetWindowRect(hWnd, rcStart)
wndStartLeft = rcStart.Left
wndStartTop = rcStart.Top
startX = ptStart.x
startY = ptStart.y
Else
N = GetCursorPos(ptNow)
dx = ptNow.x - startX
dy = ptNow.y - startY
ptDst.x = wndStartLeft + dx
ptDst.y = wndStartTop + dy
End If
Else
dragActive = 0
End If
' 1) Draw the clock into the offscreen QB64 image (img)
_Dest img
Call DrawClock(cx, cy, rClock)
_Dest 0
' Copy raw pixels from QB64 offscreen image into srcPixels() in one go.
' This avoids calling _MemGet per pixel (usually faster).
Call RtlMoveMemory(_Offset(srcPixels(0)), memImg.OFFSET, bytesCount)
' - 255 inside the inner radius
' - smooth fade through the feather band
' - 0 outside the outer radius
'--------------- ------------------------------------------------------
idx = 0
For y = 0 To diam - 1
For x = 0 To diam - 1
a = alphaMask(idx)
If a = 0 Then
pixels(idx) = 0
Else
c~& = srcPixels(idx)
' Premultiply RGB by alpha (required for AC_SRC_ALPHA)
rp = (rr * a + 127) \ 255
gp = (gg * a + 127) \ 255
bp = (bb * a + 127) \ 255
' Pack AARRGGBB (little-endian memory = BGRA bytes)
outpt~& = (a * &H1000000~&) Or (rp * &H10000~&) Or (gp * &H100~&) Or bp
pixels(idx) = outpt~&
End If
idx = idx + 1
Next x
Next y
' Copy final pixels into DIB section memory and present
Call RtlMoveMemory(pBits, _Offset(pixels(0)), bytesCount)
N = UpdateLayeredWindow(hWnd, hdcScreen, ptDst, sz, hdcMem, ptSrc, 0, blend, ULW_ALPHA)
_Limit 30
Loop
N = SelectObject(hdcMem, hBmpOld)
N = DeleteObject(hBmp)
N = DeleteDC(hdcMem)
N = ReleaseDC(0, hdcScreen)
_MemFree memImg
_FreeImage img
End
' BuildAlphaMask
' Precomputes alphaMask(idx) for a circular halo/fade.
'
' Inputs:
' diam : window width/height (square)
' cx, cy : circle center in pixels
' rInner2 : inner radius squared (alpha=255 inside)
' rEdge2 : outer radius squared (alpha=0 outside)
' rInner : inner radius (not squared)
' rEdge : outer radius
' edgeFeather : width of fade band (pixels)
'
' Alpha profile:
' - Inside rInner => A = 255
' - Outside rEdge => A = 0
' - Between => smooth fade using smoothstep to reduce visible banding:
' t = (rEdge - dist) / edgeFeather (t in 0..1)
' t = t*t*(3 - 2*t) (smoothstep)
' A = t * 255
Sub BuildAlphaMask (alphaMask() As _Unsigned _Byte, diam As Long, cx As Long, cy As Long, rInner2 As Long, rEdge2 As Long, rInner As Long, rEdge As Long, edgeFeather As Long)
Dim x As Long, y As Long
Dim idx As Long
Dim dxp As Long, dyp As Long
Dim d2 As Long
Dim dist As Single
Dim t As Single
Dim a As Long
idx = 0
For y = 0 To diam - 1
dyp = y - cy
For x = 0 To diam - 1
dxp = x - cx
d2 = dxp * dxp + dyp * dyp
If d2 >= rEdge2 Then
alphaMask(idx) = 0
ElseIf d2 <= rInner2 Then
alphaMask(idx) = 255
Else
' Only the fade band needs sqrt()
dist = Sqr(d2)
' Normalize to 0..1 across the feather band
t = (rEdge - dist) / edgeFeather
If t < 0! Then t = 0!
If t > 1! Then t = 1!
' Smoothstep easing (visually nicer halo, less "ring banding")
t = t * t * (3! - 2! * t)
a = CInt(t * 255!)
If a < 0 Then a = 0
If a > 255 Then a = 255
alphaMask(idx) = a
End If
idx = idx + 1
Next x
Next y
End Sub
'the same again...
Sub DrawClock (cx As Long, cy As Long, r As Long)
Dim t As String
Dim hh As Long, mm As Long, ss As Long
Dim hour12 As Long
Dim pi As Double
Dim aSec As Double, aMin As Double, aHour As Double
Dim radSec As Double, radMin As Double, radHour As Double
Dim x1 As Long, y1 As Long, x2 As Long, y2 As Long
Dim i As Long
Dim tickIn As Double, tickOut As Double
Dim angDeg As Double, angRad As Double
s = t
tx = cx - (Len(s) * 4)
ty = cy + r / 2
_PrintString (tx, ty), s
End Sub
Sub PutNumber (cx As Long, cy As Long, r As Long, angDeg As Long, txt As String)
Dim pi As Double
Dim angRad As Double
Dim rr As Double
Dim x As Long, y As Long
pi = 3.141592653589793#
rr = r * 0.70
angRad = angDeg * pi / 180#
x = cx + Sin(angRad) * rr
y = cy - Cos(angRad) * rr
x = x - (Len(txt) * 4)
y = y - 8
_PrintMode _KeepBackground
_PrintString (x, y), txt
End Sub
And finally, the latest version, here you can smoothly change the transparency of the clock edges with the mouse wheel.
Code: (Select All)
Option _Explicit
' CIRCULAR CLOCK WINDOW WITH HALO/FADE TRANSPARENT EDGES (Windows 10/11)
' ---------------------------------------------------------------------
'
' GOAL
' We want a circular clock window where the outer edge is not a hard cut,
' but a smooth "halo" fade: fully opaque inside, gradually transparent
' towards the outside, so the desktop behind is visible through the edge.
'
' WHY SetWindowRgn ALONE IS NOT ENOUGH
' SetWindowRgn (HRGN) can only hard-clip the window to a shape:
' - inside = fully visible
' - outside = fully invisible
' There is no per-pixel alpha, so no smooth fading.
'
' THE CORRECT METHOD: LAYERED WINDOW + UpdateLayeredWindow (per-pixel alpha)
' 1) Make the window WS_EX_LAYERED.
' This allows Windows DWM to composite the window from a 32-bit bitmap
' using alpha per pixel (0..255).
'
' 2) Create a 32bpp DIB section (CreateDIBSection) and obtain pointer pBits.
' That is raw pixel memory that Windows will read from.
'
' 3) Each frame:
' a) Draw clock normally into an offscreen QB64 image (img).
' b) Read its pixels (we copy them into srcPixels()).
' c) For each pixel compute final alpha from a precomputed alpha mask:
' alphaMask(idx) = 0..255
' This mask encodes the circular halo/fade.
' d) Premultiply RGB by alpha (required by UpdateLayeredWindow):
' R' = R * A / 255
' G' = G * A / 255
' B' = B * A / 255
' e) Store final pixel as AARRGGBB (in memory this becomes BGRA).
' f) Copy the final pixel buffer into pBits.
' g) Call UpdateLayeredWindow(..., ULW_ALPHA).
'
' PRECOMPUTING THE HALO MASK (IMPORTANT OPTIMIZATION)
' The circular alpha mask depends only on:
' - window size (diam)
' - center (cx, cy)
' - outer radius rEdge
' - feather width edgeFeather
' These are constant, so alphaMask(idx) can be computed ONCE at startup.
' Then each frame we reuse alphaMask(idx) without doing sqrt() repeatedly.
'
' OPTIONAL: SetWindowRgn still helps
' Even though visuals come from per-pixel alpha, we keep a circular region
' so that mouse clicks outside the circle fall through to windows behind.
Type POINTAPI
x As Long
y As Long
End Type
Type SIZEAPI
cx As Long
cy As Long
End Type
Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Type BLENDFUNCTION
BlendOp As _Unsigned _Byte
BlendFlags As _Unsigned _Byte
SourceConstantAlpha As _Unsigned _Byte
AlphaFormat As _Unsigned _Byte
End Type
Type RGBQUAD
rgbBlue As _Unsigned _Byte
rgbGreen As _Unsigned _Byte
rgbRed As _Unsigned _Byte
rgbReserved As _Unsigned _Byte
End Type
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
Type BITMAPINFO
bmiHeader As BITMAPINFOHEADER
bmiColors As RGBQUAD
End Type
Declare Dynamic Library "user32"
Function GetWindowLongPtrA%& (ByVal hWnd As _Offset, ByVal nIndex As Long)
Function SetWindowLongPtrA%& (ByVal hWnd As _Offset, ByVal nIndex As Long, ByVal dwNewLong As _Offset)
Function SetWindowPos& (ByVal hWnd As _Offset, ByVal hWndInsertAfter As _Offset, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal uFlags As Long)
Function SetWindowRgn& (ByVal hWnd As _Offset, ByVal hRgn As _Offset, ByVal bRedraw As Long)
Function GetCursorPos& (lpPoint As POINTAPI)
Function GetWindowRect& (ByVal hWnd As _Offset, lpRect As RECT)
Function GetDC%& (ByVal hWnd As _Offset)
Function ReleaseDC& (ByVal hWnd As _Offset, ByVal hDC As _Offset)
Function UpdateLayeredWindow& (ByVal hWnd As _Offset, ByVal hdcDst As _Offset, pptDst As POINTAPI, psize As SIZEAPI, ByVal hdcSrc As _Offset, pptSrc As POINTAPI, ByVal crKey As Long, pblend As BLENDFUNCTION, ByVal dwFlags As Long)
End Declare
Declare Dynamic Library "gdi32"
Function CreateEllipticRgn%& (ByVal nLeftRect As Long, ByVal nTopRect As Long, ByVal nRightRect As Long, ByVal nBottomRect As Long)
Function CreateCompatibleDC%& (ByVal hdc As _Offset)
Function DeleteDC& (ByVal hdc As _Offset)
Function SelectObject%& (ByVal hdc As _Offset, ByVal hObject As _Offset)
Function DeleteObject& (ByVal hObject As _Offset)
Function CreateDIBSection%& (ByVal hdc As _Offset, bmi As BITMAPINFO, ByVal iUsage As Long, ppvBits As _Offset, ByVal hSection As _Offset, ByVal dwOffset As Long)
End Declare
Declare Dynamic Library "kernel32"
Sub RtlMoveMemory (ByVal dest As _Offset, ByVal src As _Offset, ByVal cb As Long)
End Declare
Dim diam As Long
Dim cx As Long, cy As Long
Dim rClock As Long
Dim hWnd As _Offset
Dim style As _Offset
Dim exStyle As _Offset
Dim hRgn As _Offset
Dim N As Long
' Dragging
Dim dragActive As Long
Dim ptStart As POINTAPI, ptNow As POINTAPI
Dim rcStart As RECT
Dim wndStartLeft As Long, wndStartTop As Long
Dim startX As Long, startY As Long
Dim dx As Long, dy As Long
' Layered window / DIB
Dim hdcScreen As _Offset
Dim hdcMem As _Offset
Dim hBmp As _Offset
Dim hBmpOld As _Offset
Dim pBits As _Offset
Dim bmi As BITMAPINFO
Dim sz As SIZEAPI
Dim ptSrc As POINTAPI
Dim ptDst As POINTAPI
Dim blend As BLENDFUNCTION
' Offscreen QB64 image
Dim img As Long
Dim memImg As _MEM
' Source pixels (raw clock drawing copied from QB64 image)
Dim srcPixels As _Unsigned Long
' Output pixels (premultiplied + alpha mask applied)
Dim pixels As _Unsigned Long
Dim pixelCount As Long
Dim bytesCount As Long
' Precomputed alpha mask (halo/fade)
Dim alphaMask As _Unsigned _Byte
Dim gammaEdge As Single
gammaEdge = 0.6! ' <1 = fatter/brighter halo, >1 = tighter halo
' Mask geometry parameters
Dim edgeFeather As Long
Dim rEdge As Long
Dim rEdge2 As Long
Dim rInner As Long
Dim rInner2 As Long
' Loop variables
Dim idx As Long
Dim x As Long, y As Long
Dim a As Long
Dim c~&
Dim rr As Long, gg As Long, bb As Long
Dim rp As Long, gp As Long, bp As Long
Dim outpt~&
Dim Shared oldGammaEdge As Single
Dim Shared gammaStep As Single
Dim Shared gammaMin As Single
Dim Shared gammaMax As Single
Dim Shared wheelDelta As Long
' Offscreen image where we draw the clock using QB64 primitives.
img = _NewImage(diam, diam, 32)
memImg = _MemImage(img)
' Pixel counts (used for copying blocks of memory)
pixelCount = diam * diam
bytesCount = pixelCount * 4
ReDim srcPixels(0 To pixelCount - 1) As _Unsigned Long
ReDim pixels(0 To pixelCount - 1) As _Unsigned Long
ReDim alphaMask(0 To pixelCount - 1) As _Unsigned _Byte
' 1) Make the window borderless (WS_POPUP)
style = GetWindowLongPtrA(hWnd, GWL_STYLE)
style = style And Not (WS_CAPTION Or WS_THICKFRAME Or WS_MINIMIZEBOX Or WS_MAXIMIZEBOX Or WS_SYSMENU)
style = style Or WS_POPUP
N = SetWindowLongPtrA(hWnd, GWL_STYLE, style)
' 2) Enable layered window (WS_EX_LAYERED) so per-pixel alpha is possible
exStyle = GetWindowLongPtrA(hWnd, GWL_EXSTYLE)
exStyle = exStyle Or WS_EX_LAYERED
N = SetWindowLongPtrA(hWnd, GWL_EXSTYLE, exStyle)
' Apply style changes and show at initial position
ptDst.x = 200
ptDst.y = 150
N = SetWindowPos(hWnd, 0, ptDst.x, ptDst.y, diam, diam, SWP_FRAMECHANGED Or SWP_SHOWWINDOW)
' 3) Optional: region for hit-test (click-through outside the circle)
hRgn = CreateEllipticRgn(0, 0, diam, diam)
N = SetWindowRgn(hWnd, hRgn, -1)
' 4) Create DIB section (32bpp) that UpdateLayeredWindow will use
hdcScreen = GetDC(0)
hdcMem = CreateCompatibleDC(hdcScreen)
' HALO/Fade settings:
' edgeFeather defines how wide the fade band is.
' Large values produce a big halo; small values produce only slight AA.
edgeFeather = 120
gammaEdge = 0.6!
oldGammaEdge = gammaEdge
gammaStep = 0.05! ' wheel step; try 0.02 for finer control
gammaMin = 0.2!
gammaMax = 5.0!
Do
If _KeyHit = 27 Then Exit Do
wheelDelta = 0
While _MouseInput
wheelDelta = wheelDelta + _MouseWheel
Wend
' --- Mouse wheel: change gammaEdge and rebuild halo mask only when needed ---
If wheelDelta <> 0 Then
gammaEdge = gammaEdge + wheelDelta * gammaStep
If gammaEdge < gammaMin Then gammaEdge = gammaMin
If gammaEdge > gammaMax Then gammaEdge = gammaMax
' Recompute mask only if gamma actually changed (avoid useless work)
If gammaEdge <> oldGammaEdge Then
oldGammaEdge = gammaEdge
Call BuildAlphaMask(alphaMask(), diam, cx, cy, rInner2, rEdge2, rInner, rEdge, edgeFeather, gammaEdge)
End If
End If
' Custom window dragging (left mouse button), since WS_POPUP has no titlebar
If _MouseButton(1) Then
If dragActive = 0 Then
dragActive = -1
N = GetCursorPos(ptStart)
N = GetWindowRect(hWnd, rcStart)
wndStartLeft = rcStart.Left
wndStartTop = rcStart.Top
startX = ptStart.x
startY = ptStart.y
Else
N = GetCursorPos(ptNow)
dx = ptNow.x - startX
dy = ptNow.y - startY
ptDst.x = wndStartLeft + dx
ptDst.y = wndStartTop + dy
End If
Else
dragActive = 0
End If
' 1) Draw the clock into the offscreen QB64 image (img)
_Dest img
Call DrawClock(cx, cy, rClock)
_Dest 0
' Copy raw pixels from QB64 offscreen image into srcPixels() in one go.
' This avoids calling _MemGet per pixel (usually faster).
Call RtlMoveMemory(_Offset(srcPixels(0)), memImg.OFFSET, bytesCount)
' - 255 inside the inner radius
' - smooth fade through the feather band
' - 0 outside the outer radius
'--------------- ------------------------------------------------------
idx = 0
For y = 0 To diam - 1
For x = 0 To diam - 1
a = alphaMask(idx)
If a = 0 Then
pixels(idx) = 0
Else
c~& = srcPixels(idx)
' Premultiply RGB by alpha (required for AC_SRC_ALPHA)
rp = (rr * a + 127) \ 255
gp = (gg * a + 127) \ 255
bp = (bb * a + 127) \ 255
' Pack AARRGGBB (little-endian memory = BGRA bytes)
outpt~& = (a * &H1000000~&) Or (rp * &H10000~&) Or (gp * &H100~&) Or bp
pixels(idx) = outpt~&
End If
idx = idx + 1
Next x
Next y
' Copy final pixels into DIB section memory and present
Call RtlMoveMemory(pBits, _Offset(pixels(0)), bytesCount)
N = UpdateLayeredWindow(hWnd, hdcScreen, ptDst, sz, hdcMem, ptSrc, 0, blend, ULW_ALPHA)
_Limit 30
Loop
N = SelectObject(hdcMem, hBmpOld)
N = DeleteObject(hBmp)
N = DeleteDC(hdcMem)
N = ReleaseDC(0, hdcScreen)
_MemFree memImg
_FreeImage img
End
' BuildAlphaMask
' Precomputes alphaMask(idx) for a circular halo/fade.
'
' Inputs:
' diam : window width/height (square)
' cx, cy : circle center in pixels
' rInner2 : inner radius squared (alpha=255 inside)
' rEdge2 : outer radius squared (alpha=0 outside)
' rInner : inner radius (not squared)
' rEdge : outer radius
' edgeFeather : width of fade band (pixels)
'
' Alpha profile:
' - Inside rInner => A = 255
' - Outside rEdge => A = 0
' - Between => smooth fade using smoothstep to reduce visible banding:
' t = (rEdge - dist) / edgeFeather (t in 0..1)
' t = t*t*(3 - 2*t) (smoothstep)
' A = t * 255
Sub BuildAlphaMask (alphaMask() As _Unsigned _Byte, diam As Long, cx As Long, cy As Long, rInner2 As Long, rEdge2 As Long, rInner As Long, rEdge As Long, edgeFeather As Long, gammaEdge As Single)
Dim x As Long, y As Long
Dim idx As Long
Dim dxp As Long, dyp As Long
Dim d2 As Long
Dim dist As Single
Dim t As Single
Dim a As Long
' Safety: gamma must be > 0
If gammaEdge <= 0! Then gammaEdge = 1!
idx = 0
For y = 0 To diam - 1
dyp = y - cy
For x = 0 To diam - 1
dxp = x - cx
d2 = dxp * dxp + dyp * dyp
If d2 >= rEdge2 Then
alphaMask(idx) = 0
ElseIf d2 <= rInner2 Then
alphaMask(idx) = 255
Else
' Fade band only: we need sqrt() to get actual distance
dist = Sqr(d2)
' Normalize across feather band:
' dist = rInner -> t = 1
' dist = rEdge -> t = 0
t = (rEdge - dist) / edgeFeather
If t < 0! Then t = 0!
If t > 1! Then t = 1!
' Exponential profile:
' gamma < 1 : "fatter" halo (brighter further outward)
' gamma > 1 : tighter halo (drops faster)
t = t ^ gammaEdge
a = CInt(t * 255!)
If a < 0 Then a = 0
If a > 255 Then a = 255
alphaMask(idx) = a
End If
idx = idx + 1
Next x
Next y
End Sub
'the same again...
Sub DrawClock (cx As Long, cy As Long, r As Long)
Dim t As String
Dim hh As Long, mm As Long, ss As Long
Dim hour12 As Long
Dim pi As Double
Dim aSec As Double, aMin As Double, aHour As Double
Dim radSec As Double, radMin As Double, radHour As Double
Dim x1 As Long, y1 As Long, x2 As Long, y2 As Long
Dim i As Long
Dim tickIn As Double, tickOut As Double
Dim angDeg As Double, angRad As Double
s = t
tx = cx - (Len(s) * 4)
ty = cy + r / 2
_PrintString (tx, ty), s
_PrintString (tx - 20, cy - r / 2), "Use mousewheel!"
End Sub
Sub PutNumber (cx As Long, cy As Long, r As Long, angDeg As Long, txt As String)
Dim pi As Double
Dim angRad As Double
Dim rr As Double
Dim x As Long, y As Long
pi = 3.141592653589793#
rr = r * 0.70
angRad = angDeg * pi / 180#
x = cx + Sin(angRad) * rr
y = cy - Cos(angRad) * rr
x = x - (Len(txt) * 4)
y = y - 8
_PrintMode _KeepBackground
_PrintString (x, y), txt
End Sub
![[Image: image.png]](https://i.ibb.co/YBF5L9vg/image.png)
![[Image: image.png]](https://i.ibb.co/ZRHqrD2W/image.png)
![[Image: image.png]](https://i.ibb.co/My5STcT7/image.png)
![[Image: image.png]](https://i.ibb.co/sJzJdSVJ/image.png)
