QB64 Phoenix Edition

Welcome, Guest

You have to register before you can post on our site.

Search Forums

(Advanced Search)

Forum Statistics

» Members: 308
» Latest member: Donaldvem
» Forum threads: 1,741
» Forum posts: 17,901

Full Statistics

Latest Threads

The QB64 IDE shell
Forum: Utilities
Last Post: JasonPag
09-16-2024, 05:37 PM
» Replies: 9
» Views: 762

Importance regarding Ches...
Forum: Utilities
Last Post: JasonPag
09-01-2024, 06:34 PM
» Replies: 0
» Views: 31

Chess and Analysis and En...
Forum: Utilities
Last Post: JasonPag
08-28-2024, 02:37 PM
» Replies: 0
» Views: 32

DAY 009:_PutImage
Forum: Keyword of the Day!
Last Post: grymmjack
09-02-2023, 02:57 PM
» Replies: 54
» Views: 2,034

Fall Banner Contest?
Forum: Site Suggestions
Last Post: grymmjack
08-31-2023, 11:50 PM
» Replies: 36
» Views: 1,261

ColorPicker - Function th...
Forum: Dav
Last Post: Dav
08-31-2023, 11:04 PM
» Replies: 3
» Views: 315

Goals(1) = New Tile()
Forum: Works in Progress
Last Post: RhoSigma
08-31-2023, 09:45 PM
» Replies: 3
» Views: 127

micro(A)v11
Forum: QBJS, BAM, and Other BASICs
Last Post: bplus
08-31-2023, 09:14 PM
» Replies: 90
» Views: 3,589

Updating The Single Most ...
Forum: QBJS, BAM, and Other BASICs
Last Post: bplus
08-31-2023, 09:13 PM
» Replies: 7
» Views: 254

QBJS Image Question
Forum: QBJS, BAM, and Other BASICs
Last Post: bplus
08-31-2023, 05:49 PM
» Replies: 5
» Views: 155

File Menu Feature

Posted by: eoredson - 01-02-2023, 05:02 AM - Forum: Help Me! - Replies (4)

	I was thinking (again).. In the Alt-F recent files list could someone add <delete> key to remove a file from the list without deleting the actual .bas program?? That way I don't have to check for broken links.. Erik.

Happy new year.

Posted by: Fifi - 01-02-2023, 03:45 AM - Forum: General Discussion - Replies (3)

	Yep, it's a very nice banner. So, happy new 2023 year to all the QB64 Phoenix Edition members. And my best wishes to the developers. Cheers. Fifi

DAY 043: _SHHH

Posted by: SMcNeill - 01-01-2023, 07:00 PM - Forum: Keyword of the Day! - Replies (2)

_SHHH -- the keyword one uses the most on New Years Day. Usually is a result of too much celebrating on New Years Eve, which causes even the click click click of the mechanical keyboard you love so much, to sound as if the devil is tap dancing inside your brain.

Code: (Select All)
_SHHH

Usage usually results in an error while causes the programmer to just silently lay his head upon the keyboard for a while, until the world stops spinning and he doesn't feel quite so nauseous. May sometimes be used in conjecture with the keyword _Hangover for extreme results. Be cautious in this use so that _BLARF does not occur from within the aftermath of whatever was left from last night's stomach.

Now that the holidays are behind us, we'll focus on starting the KOTD back up once again seriously, come tomorrow when the _SHHH isn't so prominent.

HAPPY NEW YEAR, ONE AND ALL!!

Nice Banner!

Posted by: bplus - 01-01-2023, 03:38 PM - Forum: General Discussion - Replies (13)

	Looks great! @SMcNeill I assume ;-))

Can't compile .bas files

Posted by: PhilOfPerth - 01-01-2023, 04:12 AM - Forum: Help Me! - Replies (11)

	Help!!! I've loused something up. Suddenly I can't run any of my .bas progs (they've all run previously). I get message Failed to compile C++ on all of them. I think it's something to do with where the compiled file is placed, but I can't see how to change this. In the Run menu, the option to Output to Source Folder is selected.

Happy New Year!

Posted by: bplus - 12-31-2022, 10:43 PM - Forum: Programs - Replies (3)

	Mod for 2023 Attached Files ascii fireworks mod 2 seed n sound.bas (Size: 959.45 KB / Downloads: 29)

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

Just start the exe again to quit

Simple Menubar Shell

Posted by: Keybone - 12-31-2022, 03:46 AM - Forum: Works in Progress - No Replies

This is a simple menubar shell i am going to integrate with my gui desktop/windowing system project.
Right now it is complete and functional enough to use as a shell to operate my computer.
It is set up to run shell commands for linux but could easily be changed for windows.
I originally got this on a forum back in the day and been hacking on it for a while, forgot where i got it.

Here is a screenshot: (sorry about the huge desktop

upload a pic

Attached Files
.7z

menubar.7z (Size: 29.45 KB / Downloads: 41)

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)
Rem bad code...bad

t1 = Timer

a% = 0

a% = a% + 1

Print a%, Timer - t1

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?

Pages (165): « Previous 1 … 53 54 55 56 57 … 165 Next »

Login
Username/Email:
Password:	Lost Password?
	Remember me