01-30-2026, 11:13 PM
My version. Inspired by the BPlus program - solution with mask is perfect.
Code: (Select All)
Option _Explicit
Randomize Timer
Type POINTAPI
X As Long
Y As Long
End Type
Declare Dynamic Library "user32" ' transparent program window, clickable as in my DLL demos. Tested in 64bit IDE in Windows only.
Function GetCursorPos& (lpPoint As POINTAPI)
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 Zorder As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal Flags As Long)
Function GetAsyncKeyState% (ByVal vKey As Long)
End Declare
Const GWL_STYLE& = -16
Const GWL_EXSTYLE& = -20
Const VK_LBUTTON& = 1
Const WS_CAPTION%& = &HC00000
Const WS_THICKFRAME%& = &H40000
Const WS_SYSMENU%& = &H80000
Const WS_MINIMIZEBOX%& = &H20000
Const WS_MAXIMIZEBOX%& = &H10000
Const WS_EX_LAYERED%& = &H80000
Const LWA_COLORKEY& = 1
Const SWP_NOSIZE& = &H1
Const SWP_NOMOVE& = &H2
Const SWP_NOZORDER& = &H4
Const SWP_NOACTIVATE& = &H10
Const SWP_FRAMECHANGED& = &H20
Const SWP_SHOWWINDOW& = &H40
Const HWND_TOPMOST& = -1
Const HWND_NOTOPMOST& = -2
Dim Shared As Long W, H, N, Scrn, MaskImg, FontSize, FontH, DefaultFontH, Pad, FlameSpace, DragDX, DragDY, Fs
ReDim Shared As _Unsigned _Byte Heat(0), MaskAll(0), MaskTop(0)
ReDim Shared Wind(0) As Integer
Dim Shared As Integer PrevDown, DragOn 'program window mouse move
Dim Shared MemScr As _MEM
Dim Shared As String Txt, FontFile
Txt$ = "System's on fire! Hell yeah, Basic!"
FontFile$ = "impact.ttf" '
FontSize& = 96
Pad = 20
DefaultFontH& = _Font
FontH& = _LoadFont(FontFile$, FontSize&, "BOLD")
Fs = _NewImage(800, 600, 32)
Screen Fs
If FontH& > 0 Then
_Font FontH&
Else
_Font 16 ' fallback built-in
FontH& = _Font
End If
W = _PrintWidth(Txt$) + Pad * 2
H = _FontHeight + Pad * 8 + FlameSpace
N = W * H
Scrn& = _NewImage(W, H, 256)
Screen Scrn&
If FontH& > 0 Then _Font FontH&
_FreeImage Fs
FlameSpace = _FontHeight / 3
Cls , 0
' Make screen memory handle once (fast rendering)
MemScr = _MemImage(0)
' Palette for fire (index 0 stays black = transparent key); palette solution is inspired with BPlus fire demo!
BuildFirePalette
' Build text masks
MaskImg& = _NewImage(W, H, 256)
BuildTextMasks
' Setup window: borderless + layered colorkey black + optionally topmost
SetupLayeredBorderless 1
' Center window (safe after screen exists)
Do: Loop Until _ScreenExists
_ScreenMove _Middle
ReDim Heat(N - 1) As _Unsigned _Byte
ReDim MaskAll(N - 1) As _Unsigned _Byte
ReDim MaskTop(N - 1) As _Unsigned _Byte
ReDim Wind(H - 1) As Integer
' Copy mask bytes into MaskAll/MaskTop (once)
CopyMasksFromImage
Do
HandleDrag
UpdateWind
UpdateFire
RenderFire
_Display
_Limit 60
Loop Until _KeyDown(27)
' Cleanup
Screen 0
_MemFree MemScr
If MaskImg& < -1 Then _FreeImage MaskImg&
If Scrn& < -1 Then _FreeImage Scrn&
End
Sub SetupLayeredBorderless (TopMost As Integer)
Dim As _Offset hwnd, style, exstyle
Dim As Long flags, z, N
hwnd%& = _WindowHandle
' Remove borders/caption/system buttons
style%& = GetWindowLongPtrA%&(hwnd%&, GWL_STYLE)
style%& = style%& And Not (WS_CAPTION Or WS_THICKFRAME Or WS_SYSMENU Or WS_MINIMIZEBOX Or WS_MAXIMIZEBOX)
N = SetWindowLongPtrA%&(hwnd%&, GWL_STYLE, style%&)
' Enable layered window
exstyle%& = GetWindowLongPtrA%&(hwnd%&, GWL_EXSTYLE)
exstyle%& = exstyle%& Or WS_EX_LAYERED
N = SetWindowLongPtrA%&(hwnd%&, GWL_EXSTYLE, exstyle%&)
' Color key = black (COLORREF 0) => transparent + click-through on those pixels
N = SetLayeredWindowAttributes&(hwnd%&, 0, 0, LWA_COLORKEY)
' Apply style changes
flags = SWP_NOMOVE Or SWP_NOSIZE Or SWP_FRAMECHANGED Or SWP_SHOWWINDOW Or SWP_NOACTIVATE
If TopMost Then z = HWND_TOPMOST Else z = HWND_NOTOPMOST
N = SetWindowPos&(hwnd%&, z, 0, 0, 0, 0, flags)
End Sub
Sub BuildFirePalette
Dim As Long i, r, g, b, t
' index 0 MUST be black (transparent key)
_PaletteColor 0, _RGB32(0, 0, 0)
For i = 1 To 255
' 0..255 => black->red->yellow->white
If i < 86 Then
r = i * 3
g = 0
b = 0
ElseIf i < 171 Then
r = 255
g = (i - 85) * 3
b = 0
Else
r = 255
g = 255
b = (i - 170) * 3
End If
If r > 255 Then r = 255
If g > 255 Then g = 255
If b > 255 Then b = 255
_PaletteColor i, _RGB32(r, g, b)
Next i
End Sub
Sub BuildTextMasks
Dim tx As Long, ty As Long
_Dest MaskImg&
Cls , 0
_Font FontH&
Color 255, 0
tx = Pad
ty = FlameSpace + Pad
_PrintString (tx, ty), Txt$
_Dest 0
End Sub
Sub CopyMasksFromImage
Dim m As _MEM
Dim As Long i, x, y, idx
Dim v As _Unsigned _Byte
m = _MemImage(MaskImg&)
' Fill MaskAll from mask image bytes
For i = 0 To N - 1
v = _MemGet(m, m.OFFSET + i, _Unsigned _Byte)
If v <> 0 Then
MaskAll(i) = 1
Else
MaskAll(i) = 0
End If
Next i
' MaskTop = text pixel that has NO text pixel above it (top edge) => feeds flames
For y = 0 To H - 1
For x = 0 To W - 1
idx = y * W + x
If MaskAll(idx) Then
If y = 0 Then
MaskTop(idx) = 1
Else
If MaskAll(idx - W) = 0 Then
MaskTop(idx) = 1
Else
MaskTop(idx) = 0
End If
End If
Else
MaskTop(idx) = 0
End If
Next x
Next y
_MemFree m
End Sub
Sub UpdateWind
Dim As Long y, WindRichtung
For y = 0 To H - 1
If Rnd * 6 > 3 Then WindRichtung = -1 Else WindRichtung = 1
Wind(y) = Int(Rnd * 5) * WindRichtung - 1 ' -1,0,1
Next y
End Sub
Sub UpdateFire
Dim As Long x, y, idx, sx, v, cool, fuel, zaklad 'to jsem na to zvedavej.
' Clear last 2 rows to prevent "fire from nowhere"
zaklad = (H - 2) * W
For idx = zaklad To N - 1
Heat(idx) = 0
Next idx
' Propagate upward (top-to-bottom in-place)
For y = 0 To H - 3
cool = (y * 40) \ H ' small cooling gradient
For x = 1 To W - 2
sx = x + Wind(y)
If sx < 1 Then sx = 1
If sx > W - 2 Then sx = W - 2
idx = y * W + x
v = Heat((y + 1) * W + sx)
v = v + Heat((y + 1) * W + (sx - 1))
v = v + Heat((y + 1) * W + (sx + 1))
v = v + Heat((y + 2) * W + sx)
v = v \ 4
If v > cool Then v = v - cool Else v = 0
Heat(idx) = v
Next x
' edges
Heat(y * W) = 0
Heat(y * W + (W - 1)) = 0
Next y
' Keep letters glowing + feed flames mainly from top edges
For idx = 0 To N - 1
If MaskAll(idx) Then
If Heat(idx) < 110 Then Heat(idx) = 110
End If
If MaskTop(idx) Then
fuel = 220 + Int(Rnd * 35) ' 220..254
If Heat(idx) < fuel Then Heat(idx) = fuel
End If
Next idx
End Sub
Sub RenderFire
Dim idx As Long
Dim o As _Offset
o = MemScr.OFFSET
'make it faster
$Checking:Off
For idx = 0 To N - 1
_MemPut MemScr, o + idx, Heat(idx) As _UNSIGNED _BYTE
Next idx
$Checking:On
End Sub
Sub HandleDrag
Dim p As POINTAPI
Dim As Long wndX, wndY, mx, my, N, idx
Dim ks As Integer
Dim down As Integer
N = GetCursorPos&(p)
' Globální stav tlacitka
ks = GetAsyncKeyState%(VK_LBUTTON)
down = (ks And &H8000) <> 0
wndX = _ScreenX
wndY = _ScreenY
mx = p.X - wndX
my = p.Y - wndY
' Start drag jen na HRANE stisku (edge detect)
If down And (PrevDown = 0) Then
If mx >= 0 And mx < W And my >= 0 And my < H Then
idx = my * W + mx
' Hit-test
If Heat(idx) <> 0 Then
DragDX = p.X - wndX
DragDY = p.Y - wndY
DragOn = -1
End If
End If
End If
' Tah move
If DragOn Then
If down Then
_ScreenMove p.X - DragDX, p.Y - DragDY
Else
DragOn = 0
End If
End If
PrevDown = down
End Sub