Thread Rating:
  • 0 Vote(s) - 0 Average
  • 1
  • 2
  • 3
  • 4
  • 5
Nostalgia: Mouse chased by cat
#1
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
45y and 2M lines of MBASIC>BASICA>QBASIC>QBX>QB64 experience
Reply
#2
Thumbs Up 
+1 Well I thought it pretty cute until I couldn't get rid of it. It doesn't show up in Task Master.

Now I see the instruction to quit ;-))
b = b + ...
Reply
#3
(12-31-2022, 07:17 PM)bplus Wrote: +1 Well I thought it pretty cute until I couldn't get rid of it. It doesn't show up in Task Master.

Now I see the instruction to quit ;-))

It shows up as untitled.exe in background processes.
DO: LOOP: DO: LOOP
sha_na_na_na_na_na_na_na_na_na:
Reply
#4
That depends on the name you gave the .bas  Wink
And you don't need taskmanage, just start program again to quit
45y and 2M lines of MBASIC>BASICA>QBASIC>QBX>QB64 experience
Reply




Users browsing this thread: 1 Guest(s)