| Welcome, Guest |
You have to register before you can post on our site.
|
| Latest Threads |
QBJS v0.9.0 - Release
Forum: QBJS, BAM, and Other BASICs
Last Post: dbox
58 minutes ago
» Replies: 13
» Views: 157
|
Fun with Ray Casting
Forum: a740g
Last Post: a740g
2 hours ago
» Replies: 2
» Views: 63
|
Big problem for me.
Forum: General Discussion
Last Post: bplus
4 hours ago
» Replies: 7
» Views: 56
|
discover graphics with xa...
Forum: Programs
Last Post: hsiangch_ong
6 hours ago
» Replies: 0
» Views: 19
|
another variation of "10 ...
Forum: Programs
Last Post: Jack002
7 hours ago
» Replies: 37
» Views: 542
|
Aloha from Maui guys.
Forum: General Discussion
Last Post: doppler
Yesterday, 03:32 PM
» Replies: 14
» Views: 328
|
Cautionary tale of open, ...
Forum: General Discussion
Last Post: doppler
Yesterday, 03:28 PM
» Replies: 0
» Views: 20
|
Extended KotD #22: _MOUSE...
Forum: Keyword of the Day!
Last Post: SMcNeill
Yesterday, 12:29 AM
» Replies: 0
» Views: 49
|
micro(A)v11
Forum: QBJS, BAM, and Other BASICs
Last Post: aurel
01-13-2025, 09:10 PM
» Replies: 111
» Views: 5,578
|
QB64PE v4.0 is now live!!
Forum: Announcements
Last Post: Kernelpanic
01-13-2025, 04:08 PM
» Replies: 44
» Views: 2,245
|
|
|
| Nostalgia: Mouse chased by cat |
|
Posted by: mdijkens - 12-31-2022, 05:27 PM - Forum: Programs
- Replies (3)
|
 |
I remembered having this ages ago on WfW
Now a (simple) QB64 version:
Code: (Select All) DefInt A-Z
'Print image2data("E:\TEMP\Cats.png"): End
ReDim Shared icon(1 To 1) As Long
init
main
System
Sub init
Declare CustomType Library
Function FindWindow%& (ByVal ClassName As _Offset, WindowName$)
Function ShowWindow& (ByVal hwnd As _Offset, Byval nCmdShow As Long) 'maximize process
Function GetForegroundWindow%& 'find currently focused process handle
Function SetForegroundWindow& (ByVal hwnd As _Offset) 'set foreground window process(focus)
Sub SENDKEYS Alias keybd_event (ByVal bVk As Long, Byval bScan As Long, Byval dwFlags As Long, Byval dwExtraInfo As Long)
End Declare
title$ = "mdChaseMouse"
hwnd%& = FindWindow(0, title$ + Chr$(0))
If hwnd%& > 0 Then
FGwin%& = GetForegroundWindow%& 'get current process in focus
y& = ShowWindow&(hwnd&, 1) 'maximize minimized program
If FGwin%& <> hwnd%& Then z& = SetForegroundWindow&(hwnd%&) 'set focus when necessary
SENDKEYS &H1B, 0, 0, 0: SENDKEYS &H1B, 0, &H2, 0 'Esc
System
End If
n% = getIcons(icon())
Screen _NewImage(_DesktopWidth, _DesktopHeight, 32): Do: _Delay .1: Loop Until _ScreenExists: _Delay .1: _FullScreen
'Screen _NewImage(_DesktopWidth - 6, _DesktopHeight - 69, 32): Do: _Delay .1: Loop Until _ScreenExists: _Delay .1: _ScreenMove 0, 0
' alphaLevel 0=Transparent; initial focus once, >0=Less transparent; has focus
' zorder 1=bottom, -1=always on top 0=normal
' titlebar 0=no
_Title title$
setWindow 0, -1, 0
End Sub
Sub main ()
Type mpType
x As Long
y As Long
End Type
Dim mp As mpType
Declare Dynamic Library "user32"
Function getMouse%% Alias GetCursorPos (lpPoint As mpType)
End Declare
x = _Width / 2
y = _Height / 2
s = 10
Do
_Limit 10
r = getMouse(mp): xd = (mp.x - x): yd = (mp.y - y)
If Abs(xd) > 0 Or Abs(yd) > 0 Or i < 13 Or i > 15 Then
If Abs(xd) > s Then xd = Sgn(xd) * s
If Abs(yd) > s Then yd = Sgn(yd) * s
i = ((Sgn(yd) + 1) * 3 + (Sgn(xd) + 1)) * 3 + 1
If i <> 13 Then
it = (it + 1) Mod 3: i = i + it
t! = Timer
End If
x = x + xd
y = y + yd
Cls
_PutImage (x - 32, y + 1)-Step(64, 64), icon(i)
_Display
ElseIf (Timer - t!) > 5 Then
Cls
_PutImage (x - 32, y + 1)-Step(64, 64), icon(14)
_Display
t! = 86400
End If
Loop Until InKey$ <> ""
End Sub
Function getIcons% (icon() As Long)
iw% = 32: ih% = 32
Cats: 'E:\TEMP\Cats.png' (288x96)
Data 288,96
Data "eJzlncuOHEkVhkt09dV9dfs+ttse8QAzjIVA4hFmgcQrIPEIgDS7kZBgyyPMAiQk2PIeLIc1G94B42j6b3/99Ym8VJU9HuNWqSojzy3O+eNEZOTJ9NH24nTxevH6s1efvd5bvP39DX4/w++X+H13UfPex+9//+vby++dou1+h/+4o492fIHfX3/91eX3J0XbRdF2OtG+e2j721++ufw0Oh6bbkje4UT7qn78SLaYLm0XRdvpCv348sufX+pudO18+93a5vjlcKJ9VT+eX7VtXcnd1vG+/Nts2x/h2S1icmcFPacr+Km1x09NTmjn+D3+bMexf6zPd4o+707s8xw9B+JJHJuu2L9X+NK6Kr5qLN1ZUd/pCjFpbe08aZZXPD36ntwqhrST9je+2F3FcWcCXxXLKfoYzy30o33acXAZ3l3Qx1/WP0XOTmHvnQ3Z4tiPxfQc9IxraCLXckJ/Ln2UHznUZ2ykX8xb6Wf6TT/0sNLadmbKMG5WteUA9Owz6ew3xi88zsVTZQ3haRM2nWwII4vFzdxB3vg1fI12CJuVbus1Rtp5x5dy6Rf2pZJlvE2V47l2HZsOhFPm4vjCcxntn8O/HMHYKvrPNoiL8PQwMQWPlW7qPSp84DUCZcUfydkVhpYz+L3+mKuf/I1uu5hnPFd43lxHTnzr+W4dW047WGj/5mKhl1toyxD+ejnROg8Xt3NAxlj8YR+0T3yUecp4sq+nyDjYkC378kmjORJP8kQvH/b4PB8drKjrTLHOv94cVsXbcz/HMXUZV0PzFrF1JF0cv5FzJF32CeeVIZ5qrTFFF9dNrX0p3+/r2Gu2KXzxy1w+6jtD/4Lj/BuK3d2ReFdjouLjWnhojeR5pdcv2mm/UO5cvqn6qrHKPh4U8euN1yG+6JvLF31nRfwY86nxMw4ZtyqOPdx4XWG9HPOUe4C+GqOeh+m7qXzr6KMPov9Q8+ThO6Z3nKvxPTVevragT3vjdoifx9W8wrhnjmD/yJM59vAd0x/J/6E7vuLzGngdmrHcPNX3TVbl+6Gc23jGYlf5qcrZTVb6xWsG+nNdmhPQxN4KZ+17Dz4+fs98Z0VMuMaqYpJ2xoT8nhMYk5zv8dvu6K7yAXHbfu8tbs9JlpfrwuP3zGc/h8Z+21W+PNkAH+0b46OdXIu2f714BvOOZ9Zp5ttCW8XjPEx+Yij8zsnsE7HCuFQ+2jSf/X5exDLnMh/ymjr96+Eg6xXG1Ou/8B8P6E77FDnGRxXf+IC48J5zfNX4vZfja7FggvNSvpfCErFADNOvGZOJT+J12uGlLxptfG7+k4n8Oe/x2ZvnbsTqKkZcUy+v7Dnp8C2Bka2Cj/e1jdn8bXVkxKZefDlXMI65Zr0nXJKv0TAf0H/VvUnijXghrtJX+mRZ9Icx4Z7VmC97fIwd+eLX6z/lDY4F5tzIY8ySLyMzOCc2KGMJOsugfGLENmwt3u5lDsm6PxBnrlkq+iq+vfaKL32o9B4rPo02ffE6kv7k/OQ9cdpnfuOk0Xj+M0/s2QId+b3XRVzRR5e2AWc539pPChnbPRni9f4X/bsUPiyrfRwzYydjvP1+WKwXPX7Y/lCyY3+lh3mQOMsf9405zoIr72N4HJF3u+Bl3u/pWnbGka+vrJ9rOWMp56vrlsjYkh8ji3H1tRH59zr87fcD4ZpzT3zhWHIdzNiz/aFsuca/9DA30mceb14LEU9nksE1Avnsx/DfBb957LvwnCuGnsPjh6XoznS8BO7I63VF6Hv3u9u5B7L12l/gfzQQ76r9UdFPy/c8uyywcp3DQRcfpq9lvi7oK9p90T6U7Ocjx+5nk/m0aGM+SvtTxMR+jvwnI8d/33sr41PIo+xf4PcftOZr3y+KtidFG+sGnxfnfy+MWXbanhRtnxfynhV0rOH8FX63mFpf2p4UbZ8Xsp+NyPOeVNpSn5DzPx45f7Ihu9PGOdD2Dcl3TWXm1SXs5Vh5NZP+WDozL16ovbW5r6F9OaFvvE/msZbx7v72fFfV85Jv8cM/3tjjYt6/vh55Q2N/zeHbhN+eruGT"
Data "PeE3MhL3Zmfi39qqesKpMfF1bMYI7frJz/5x7b8b131v2to5+3oKfTUG59a/tr5NrX+do2d3A/53DJvsy3n3ygftew7/mA3VuDxSTLh/xL23xOTxFT3rSM9nyqiuiexTY3AL+nj96dq+G9cBM2V5/bWOXcbHOrH1fld8XNnN6545+PI8U82jrZ1788zFVW1c/FXtN3Hfjtf6PT3eg+N1bupzYsP1PsoV/tP35PIKO2lbVZZjsAn7XHu7LgZaG/fUm8yDxdtauciag70D6a3mjNxL99zNnMVxxPEVu51PLGtIh3HHnJR+XF5nYVx4n554qbC8qkz7b1Nyd9eIezuf+hfa47pE8jp3DumrxnSj/c2Xry4/6U+Oh7CTcRO5nvPab9Z+eu04V2flh+hp8diFLmNmLq+xMZd/d4147snuLfmHmGOtlPEwRXeeJzAmEqNv//TLWzFqbcwR5HPOquY7YtT5alW9rQ/EffzANT/xMEbr+I/R76wQs6kxb/0mP+ujNoGXU/Ez93EeYLvHM32aeaqK9cmKurhGcX6jjvQ5sg7eM9/2jDhWsfCaIfjLmM16jjjwmJ+jt7pXwnG8U9A6js2+fdg3Nr7HZJ92fG9sxPfuK8d62wNcV8Y6duzMiOe+dPh5Lj/jSAxUe9g9XQfSw33mxDO0rEXgOd9bik5fO1RzJzExV6efr2aeCMa51vc8wjxzABs2JWsTdhkzVdzpzyUw4GehqlzqNfRWIetyPfdG3hgGh+YTX0Nkv8n6q5wSGo+7YMF2595ohck5unOc6ymu0VwvTX+l77GPNa/ryrqzYdv2V8CIn6eNvibD9UmRGxl8vr6a8+fidtnBK69pGU/eVzZ+Y2+FG/aZ19fGYXJW/GwcTtFPe/mML3NofELcVj6Nba6P8/XaHFmH78C+wxHc7HVww7Vn7j+7f7zfTXuq2pipOZHjiDHjvfNghbmG8xfnMO43GdfEWPrMazXnu7k2uC6ENMHs9b3ZN9/bV37k848nRQzGeA43oLeKPecfy/HeTvxA+yObOLjG0evbvq1s8diIDNpFW9JOHLhWhfmXx+mja1d74436eZ+f6272ea4dFRbiD9ZBcH3knM24V/tNtpUyXB949I7t4R7YNd4KLHFcVHgjHmJrNaa8RifGmf+MU/bD6zOuTZgz3XZXY7Z9M7fEBvbZc1z1rMCQTttIf9tPXA85dh6nxlPFnzo2z5/r2uD9Ks9V1/n56o/+db4knjyP5PxycTs39LB4Q7fyZi8Hsp04SX4Jpnl91X6zPpr5muOQ9nOODq1rlnq6/Kw1aXc68WNMqvhFFv0Q2R5zPd517AguQ3vd99c341EeF/q9jqENxlGPt6r5Th6wbs4bD6TbNuf8zpX85yP057Jnr2N7chhzDecQX5/wvOmn6DgWzx0d39Xxjo4fdPwc+V8VNgQ/9LGx9WKA75/S+UjHn+r4pzs3r6H+s7h5zPoxzk9/Rjvr8liv52cxwkt6+v1Cun8n/vZd1fC9KNrudnT0dLv2L+2nnb5RjmvIbGfaXhRtc+10PJi/PFf1fFP58AvpM13aXhRt6/Sh2tMc81nl23dtP3Pg0yIG7ffZRH2VXalDzVxt2lxTcpyYtnoHwdR+sP1D7Qffg+mc4vND/cma8ELtra1XexjMvouaOPpk7vs27a/KL48XN/GavfrQPB7hdw3AOv6L/KyLhupYXBOWeLp2Z4os3uOjLNc0rWOX30tgPz/U+ewr9s6bv6rj/VDqO6uYDNWasP6NewTE3iZkRlYV53Xt8/Wp48n3N0du9p1Dx/nm/oi8/4c60Oo+x1BdSmLn/TPv4/l9hevK9T2eTdpa3S8dwg2fQZ5Tk+/3VOd89IQneo6FT84RH2tNqfHYq5dpH97f7eFuKn+Fr7m6TzeAiynPHayKv6pGeWh8JG4fU93pvmzNvfnEdndxcw7we7R69MTPVNmna8R9ynMMc3FV7b1+X2pJWRPWPqk3GqpLs973wXe2Rgxbu2uH5mLiQ6oH5VhMrY/rMjnWPY64R/hdynBcx+LEmsSx+Pbq"
Data "/Iyt77qm02tPYpB1yVznRzZ92+Ix9C7J70qWY9yLIX3Tq9nvYYH3877vNZ2eN5MTXL/RvnkvlPKzx+53TX4IsoKnuc9r+H3UrX1KHf/5TD3EkrH8sdSAGmOWxzjlnK89govjDcjivkX1Xs0p8nguGKz2I1bBTnK481oVi0a7KlZ77y5M/z6WGlE+e5rr3dRi5R5p7vEGZycTeVhD4HvaY7y8hrWMVZ8tMRbC33s+YVXMuQZmnXrMo8LmD62+0+9vjez0v5KXOo/gkTUltCt8rL+i7bxP7/qZHn/+LGfu8yvER3yRPbfQ8txc/FX1jxwjVc3kUL3nGO9ozSZ83JPhZwTt8+QFr2mG8MA9X/PdkF/ULfn9dkMytqSTclyD5Vhzb7r6v/yyPvP+kukjp4chv18z54fmdY5L4py4og8spxojt3gR30rGDRwtFreeKUz7Uv3jdRD30FhLQ4yQp6pVok3GB+dS+m5KXRRzZBXrRlu9R7J6TuC+9FEefd7DgvuSNvqBfu/VP3JcJT6WGznGhuVwbA3JYkzi/23xJgacZ5yLTec6K+cFx3VvgJ7rqYzj9PNB4YPUUjOf+F1z1bVaaP1/u1BO7E6fl+pX/Or3TLOv+UtfLbOKr2Us5S+Ppdb2eFGPNfujOv+k4I3uZ0Usk1sjL78faczwGobHjwq85nfsSvs99T00tGFbNK4T9P/HyTVZ87/rL4dqEenr0Pv4qY4vCv9yXnD84uOc4/FjxZJ5OVigf42Ti4Fz7fNJ0fec/7V445NPCpmRx2PXAxl/8ddLHT/X8W/lg2c6Zi6uzv/1B/87/i+VKk6+"
Data "*"
Restore Cats
hImg& = data2image ' Screen hImg&: Sleep: End '@@
_ClearColor &HFF00FF00, hImg&
i% = 0
If hImg& < -1 Then
iws% = _Width(hImg&) \ iw%
ihs% = _Height(hImg&) \ ih%
ReDim icon(1 To iws% * ihs%) As Long
For y% = 1 To ihs%
For x% = 1 To iws%
i% = i% + 1
icon(i%) = _NewImage(iw%, ih%, 32)
_PutImage (0, 0), hImg&, icon(i%), ((x% - 1) * iw%, (y% - 1) * ih%)-Step(iw% - 1, ih% - 1)
Next x%
Next y%
End If
getIcons = i%
End Function
Sub setWindow (alphaLevel As _Unsigned _Byte, zorder As Integer, titlebar As Integer)
'alphaLevel: 0=alphaColor, 1..255 whole window transparent..solid
'zorder: 0=normal, 1=bottom, -1=topmost (alphaLevel 0=initial focus once)
'titlebar: 0=none 1=titlebar
Const GWL_STYLE = -16
Const GWL_EXSTYLE = -20
Const WS_BORDER = &H800000
Const WS_POPUP = &H80000000
Const WS_VISIBLE = &H10000000
Const WS_EX_LAYERED = &H00080000
Const WS_EX_NOACTIVATE = &H08000000 'background prc: no clickable & no icon
Const HWND_TOP = 0 'Normal
Const HWND_BOTTOM = 1 'Bottom
Const HWND_TOPMOST = -1 'Always on top
Const LWA_COLORKEY = &H1
Const LWA_ALPHA = &H2
Const SWP_SHOWWINDOW = &H0040
Const SWP_HIDEWINDOW = &H0080
Const SWP_NOSIZE = &H0001 'ignores cx and cy size parameters
Const SWP_NOMOVE = &H0002 'ignores X and Y parameters
Const SWP_NOACTIVATE = &H0010 'does not activate window
Declare Dynamic Library "User32"
Function getWinLong& Alias GetWindowLongA (ByVal hwnd As Long, Byval nIndex As Long)
Function setWinLong& Alias SetWindowLongA (ByVal hwnd As Long, Byval nIndex As Long, Byval dwNewLong As Long)
Function setLayWinAttr& Alias SetLayeredWindowAttributes (ByVal hwnd As Long, Byval crKey As Long, Byval bAlpha As _Unsigned _Byte, Byval dwFlags As Long)
Function setWinPos& Alias SetWindowPos (ByVal hWnd%&, Byval hWndInsertAfter%&, Byval X&, Byval Y&, Byval cx&, Byval cy&, Byval uFlags~&)
End Declare
'alphaColor = transparent background used when alphaLevel=0
Dim As Long hWnd, alphaColor: hWnd = _WindowHandle: alphaColor = &HFF000000
If titlebar = 0 Then
a& = getWinLong&(hWnd, GWL_STYLE)
a& = setWinLong&(hWnd, GWL_STYLE, WS_POPUP Or WS_VISIBLE)
End If
If alphaLevel <> 255 Then
a& = getWinLong&(hWnd, GWL_EXSTYLE)
a& = setWinLong&(hWnd, GWL_EXSTYLE, a& Or WS_EX_LAYERED Or WS_EX_NOACTIVATE)
If alphaLevel > 0 Then
a& = setLayWinAttr&(hWnd, alphaColor, alphaLevel, LWA_ALPHA)
Else
a& = setLayWinAttr&(hWnd, alphaColor, alphaLevel, LWA_COLORKEY)
End If
End If
If zorder <> 0 Then
a& = setWinPos(_WindowHandle, zorder, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE Or SWP_NOACTIVATE)
End If
End Sub
Function image2data (image$)
Const I2DBLOCK = 2048
hImg& = _LoadImage(image$, 32): If hImg& < -1 Then _Source hImg& Else Print "LOAD ERROR": Exit Function
iWidth% = _Width(hImg&): iHeight% = _Height(hImg&)
pathsep$ = Mid$("/\", 1 - (Left$(_OS$, 4) = "[WIN"), 1)
in% = _InStrRev(image$, pathsep$): If in% > 0 Then datafile$ = Mid$(image$, in% + 1) Else datafile$ = image$
in% = _InStrRev(datafile$, "."): If in% > 0 Then lbl$ = Left$(datafile$, in% - 1) Else lbl$ = datafile$
datafile$ = lbl$ + ".img"
Print "Generating "; datafile$; " ("; _Trim$(Str$(iWidth%)); "x"; _Trim$(Str$(iHeight%)); "x32) ... ";
Dim alpha As _Byte, cval As Long, imgArray(iWidth% * iHeight%) As Long
Get (0, 0)-(iWidth% - 1, iHeight% - 1), imgArray(): _Source 0: _FreeImage hImg&
alpha = _Alpha32(imgArray(1)): If alpha = &H10 Then imgArray(1) = imgArray(1) + (2 ^ 24)
cn& = 1: cval = imgArray(1): o$ = String$(4 * iWidth% * iHeight%, 0): opos~& = 1
For n& = 2 To iWidth% * iHeight%
alpha = _Alpha32(imgArray(n&)): If alpha = &H10 Then imgArray(n&) = imgArray(n&) + (2 ^ 24)
it& = n& - cn&
If cval <> imgArray(n&) Or it& = (2 ^ 24) - 1 Then
If it& > 2 Then
Mid$(o$, opos~&, 8) = MKL$(&H10000000 + it&) + MKL$(cval): opos~& = opos~& + 8
ElseIf it& = 2 Then
Mid$(o$, opos~&, 8) = MKL$(cval) + MKL$(cval): opos~& = opos~& + 8
Else
Mid$(o$, opos~&, 4) = MKL$(cval): opos~& = opos~& + 4
End If
cn& = n&: cval = imgArray(n&)
End If
Next n&
it& = n& - cn&
If it& > 2 Then
Mid$(o$, opos~&, 8) = MKL$(&H10000000 + it&) + MKL$(cval): opos~& = opos~& + 8
ElseIf it& = 2 Then
Mid$(o$, opos~&, 8) = MKL$(cval) + MKL$(cval): opos~& = opos~& + 8
Else
Mid$(o$, opos~&, 4) = MKL$(cval): opos~& = opos~& + 4
End If
o64$ = base64encode$(_Deflate$(Left$(o$, opos~& - 1)))
Print Using "##,###,### bytes"; Len(o64$)
Open datafile$ For Output As #1
Print #1, lbl$ + ": '"; image$; "' ("; _Trim$(Str$(iWidth%)); "x"; _Trim$(Str$(iHeight%)); ")"
Print #1, "Data"; RTrim$(Str$(iWidth%)); ","; RTrim$(Str$(iHeight%))
For n& = 1 To Len(o64$) Step I2DBLOCK
Print #1, "Data " + Chr$(34) + Mid$(o64$, n&, I2DBLOCK) + Chr$(34)
Next n&
Print #1, "Data " + Chr$(34) + "*" + Chr$(34)
Print #1, "Restore "; lbl$
Close #1: image2data = -1
End Function
Function data2image&
Read iWidth%, iHeight%
Dim alpha As _Byte, cval As Long, imgArray(iWidth% * iHeight%) As Long: imgArray(0) = iHeight% * 2 ^ 16 + iWidth%
Read lin$: i64$ = String$(6 * iWidth% * iHeight%, 0): i64pos~& = 1
Do While lin$ <> "*"
l& = Len(lin$): Mid$(i64$, i64pos~&, l&) = lin$: i64pos~& = i64pos~& + l&: Read lin$
Loop
i$ = _Inflate$(base64decode$(Left$(i64$, i64pos~& - 1))): cn& = -3
Do While n& < iWidth% * iHeight%
cn& = cn& + 4: cval = CVL(Mid$(i$, cn&, 4)): alpha = _Alpha32(cval)
If alpha = &H10 Then
it& = cval - &H10000000: cn& = cn& + 4: cval = CVL(Mid$(i$, cn&, 4))
Do While it& > 0
n& = n& + 1: imgArray(n&) = cval: it& = it& - 1
Loop
Else
n& = n& + 1: imgArray(n&) = cval
End If
Loop
hImg& = _NewImage(iWidth%, iHeight%, 32): _Dest hImg&: Put (0, 0), imgArray(): _Dest 0: data2image& = hImg&
End Function
Function base64encode$ (b$)
' elke 3 bytes > 4 bytes
' +1 + elke overige byte
d$ = b$: dl~& = Len(d$): d$ = d$ + String$((3 - (Len(b$) Mod 3)) Mod 3, 0): e$ = Space$(_Ceil((dl~& * 4) / 3)): ep~& = 0
For i3~& = 1 To dl~& Step 3
v~& = 0
For p = 0 To 2
c = Asc(Mid$(d$, i3~& + p, 1)): x2~& = 2 ^ ((2 - p) * 8): v~& = v~& + c * x2~&
Next p
For p1 = 3 To 0 Step -1
c1 = v~& \ 2 ^ (p1 * 6): v~& = v~& - c1 * 2 ^ (p1 * 6): ep~& = ep~& + 1
Select Case c1
Case 0 To 25
Mid$(e$, ep~&, 1) = Chr$(c1 + Asc("A"))
Case 26 To 51
Mid$(e$, ep~&, 1) = Chr$(c1 - 26 + Asc("a"))
Case 52 To 61
Mid$(e$, ep~&, 1) = Chr$(c1 - 52 + Asc("0"))
Case 62
Mid$(e$, ep~&, 1) = "+"
Case 63
Mid$(e$, ep~&, 1) = "/"
Case Else
End Select
Next p1
Next i3~&
e$ = Left$(e$, _Ceil((dl~& * 4) / 3)): base64encode$ = e$ + String$((4 - (Len(e$) Mod 4)) Mod 4, "=")
End Function
Function base64decode$ (b$)
' elke 4 bytes > 3 bytes
' + Int(overige bytes*3/4)
e$ = b$ + String$((4 - (Len(b$) Mod 4)) Mod 4, "="): el~& = Len(e$): d$ = Space$(el~& / 4 * 3): dp~& = -2
For i4~& = 1 To el~& Step 4
v~& = 0
For p = 0 To 3
c = Asc(Mid$(e$, i4~& + p, 1)): x2~& = 2 ^ ((3 - p) * 6)
Select Case c
Case Asc("A") To Asc("Z")
v~& = v~& + (c - Asc("A")) * x2~&
Case Asc("a") To Asc("z")
v~& = v~& + (c - Asc("a") + 26) * x2~&
Case Asc("0") To Asc("9")
v~& = v~& + (c - Asc("0") + 52) * x2~&
Case Asc("+")
v~& = v~& + (c - Asc("+") + 62) * x2~&
Case Asc("/")
v~& = v~& + (c - Asc("/") + 63) * x2~&
Case Asc("=")
el~& = el~& - 1
Case Else
End Select
Next p
c1 = v~& \ 2 ^ 16: v~& = v~& - c1 * 2 ^ 16: c2 = v~& \ 2 ^ 8: v~& = v~& - c2 * 2 ^ 8: c3 = v~&: dp~& = dp~& + 3
Mid$(d$, dp~&, 3) = Chr$(c1) + Chr$(c2) + Chr$(c3)
Next i4~&
base64decode$ = Left$(d$, Int(el~& / 4 * 3))
End Function
|
|
|
| Coverting GOSUB to GOTO? |
|
Posted by: James D Jarvis - 12-30-2022, 06:38 PM - Forum: General Discussion
- Replies (15)
|
|
Does the compiler convert simple GOSUB commands into GOTO commands? This little bit of code refuses to die, I thought there would be a stack overflow but nope, not while I was running it. just keeps wrapping around to -32K and counting back up until it wraps aroundound again and again.
Code: (Select All) 10 Rem bad code...bad
t1 = Timer
20 a% = 0
30 a% = a% + 1
40 Print a%, Timer - t1
50 GoSub 30
|
|
|
|
| _NotifyPopup disappears |
|
Posted by: mdijkens - 12-30-2022, 12:49 PM - Forum: Help Me!
- Replies (2)
|
|
I have several utilities run automatically at logon (Win) and started to include _NotifyPopup to inform me of warnings/errors.
This raises some questions:
1. Every now and then, a notification is created but automatically disappears from the notifications pane. What could cause this?
2. _NotifyPopup also creates an icon on the taskbar (right side) but when I hover over that icon, it disappears and so does the notification in the notification pane.
3. When I click on a notification in the notification pane, it disappears. Can it be linked to something?
4. When notifications disappear, is there any place I can still find them? For example in the Windows Event Viewer?
|
|
|
|
| Auto relaunch of running program |
|
Posted by: Richard - 12-30-2022, 03:14 AM - Forum: Help Me!
- Replies (3)
|
|
Looking for suggestions...
With windows 22H2 (and similar) - various things just are not working like they used to - getting worse as time goes on.
Previously I could have a program run continuously for 3 days - now this does not seem to be possible.
I am looking for suggestions/ideas (that might work) to have a running program gracefully shut itself down and restart itself - the on-going log files generated by the program will assist in the restarted program continuing as if nothing had happened.
Various things I tried such as Task Scheduler and so appears to be unstable (because of Windows updates).
So, for example, program X starts off (manually run) - then say after 10 minutes (+/- 1 minute) it shuts itself down in a controlled manner, and then restarts itself.
|
|
|
|
| custom desktop |
|
Posted by: MrCreemy - 12-29-2022, 10:32 PM - Forum: Works in Progress
- Replies (3)
|
|
https://www81.zippyshare.com/v/13pCCwvq/file.html
above link, is a tiny video, showing my "custom desktop" I was going to use to deploy my software.
was inspired to post this, after reading the "windowing" thread
I was trying, at one time, to find a "teeny tiny" linux.
it was something like "minimal linux live" or something.
I was able to run QB64 programs that did *not* use any graphics screens.
I was thinking about trying to get "X" onto it... which *should* allow me to run compiled QB64 graphics programs.
which would allow my DESKTOP to run...
==========================================
this idea, combined with the other guy doing to "windowing" project? Might make a pretty cool result.
you boot into either your software, or, the desktop and your software.
absolute minimum *anything* other than just what you need to run your software... absolutely *nothing* would be able to disrupt it. software thus? would be beyond cross platform... if theres a 64 bit computer? it runs your software. period.
|
|
|
|
| incorporate sound files in code |
|
Posted by: mdijkens - 12-29-2022, 10:50 AM - Forum: Help Me!
- Replies (6)
|
|
I always like to distribute my final program as just one single exe.
Therefore I include (small)images in DATA statements most of the time, by reading them in a Long array and _PutImage that array:
Code: (Select All) Function data2image&
Read iWidth%, iHeight%
Dim alpha As _Byte, cval As Long, imgArray(iWidth% * iHeight%) As Long: imgArray(0) = iHeight% * 2 ^ 16 + iWidth%
Read lin$: i64$ = String$(6 * iWidth% * iHeight%, 0): i64pos~& = 1
Do While lin$ <> "*"
l% = Len(lin$): Mid$(i64$, i64pos~&, l%) = lin$: i64pos~& = i64pos~& + l%: Read lin$
Loop
i$ = _Inflate$(base64decode$(Left$(i64$, i64pos~& - 1))): cn& = -3
Do While n& < iWidth% * iHeight%
cn& = cn& + 4: cval = CVL(Mid$(i$, cn&, 4)): alpha = _Alpha32(cval)
If alpha = &H10 Then
it& = cval - &H10000000: cn& = cn& + 4: cval = CVL(Mid$(i$, cn&, 4))
Do While it& > 0
n& = n& + 1: imgArray(n&) = cval: it& = it& - 1
Loop
Else
n& = n& + 1: imgArray(n&) = cval
End If
Loop
hImg& = _NewImage(iWidth%, iHeight%, 32): _Dest hImg&: Put (0, 0), imgArray(): _Dest 0: data2image& = hImg&
End Function
Is something like that also possible for ogg/wav/mp3 files?
Storing them in code in DATA statements, reading them in the correct (_MEM) structure and provide a Long pointer to that?
|
|
|
|
| using QB64 to make "end credits" to a movie |
|
Posted by: MrCreemy - 12-29-2022, 04:36 AM - Forum: Works in Progress
- No Replies
|
|
so... I was starting to get into video editing. Then? I got an *itch* to try to do "professional" end credits. Like you see at the end of the movie.
wrote a little program to let me do "rolling credits". I record it, and use it to insert into the video editor, then mix my music in with it.
This? Is the ending of the movie "Shooter"... except, I edited in my own "end credits", with my own music too. I don;t think my "end credits demo:" came out too bad, but, thats for the viewer to decide.
But? Thats "powered by QB64" doing the end credits...
https://www10.zippyshare.com/v/jieU7aAe/file.html
|
|
|
|
|
![[Image: launcher.png]](https://i.ibb.co/4pzDTn1/launcher.png)
