Inspired by the thread started by mnrvovrfc (https://qb64phoenix.com/forum/showthread.php?tid=2112), I converted the whole Rick Astley - Never Gonna Give You Up music video to an ASCII animation.

And the code:

Option Explicit

$NoPrefix



Screen NewImage(80, 25)



'You know the rules and so do I

Sleep

Open "B", 1, "rickroll.txt"

Dim As Long x

Dim As String pic, buf

Dim As Long s: s = SndOpen("02 - Rick Astley - Never Gonna Give You Up.flac", "STREAM")

If s Then SndPlay (s)

While Not EOF(1)

    For x = 0 To 24

        If EOF(1) = 0 Then

            Line Input #1, buf

            pic = pic + buf

        End If

    Next

    Cls

    Print Mid$(pic, 2)

    Limit 60

    pic = ""

    If EOF(1) Then Exit While

Wend

Close

I just saw where Spriggsy posted this great new algorithm.

Click this link to try it out in QBJS.

Attached Files

  rr.zip (Size: 93.86 KB / Downloads: 144)

So here's something that was glitching the heck out of one of my programs earlier, that you guys might not be aware of:

$Console:Only



Dim f As _Float, i As _Integer64

f = 1: i = 1: g = 1

For x = 1 To 10

    Print x, f,

    Locate , 30: Print i

    f = f * 10 + x

    i = i * 10 + x

Next

Have there been any thoughts on making a "WITH" keyword for QB64 for assigning values to UDT members?

Another of my Steve's Overengineered Routines:

Option _Explicit





Screen _NewImage(1280, 720, 32)

$Color:32



'Box (Mode As Integer, X1 As Integer, Y1 As Integer, X2 As Integer, Y2 As Integer, Caption As String, _

'     FontColor As _Unsigned Long, FontBackground As _Unsigned Long, BoxColor As _Unsigned Long, _

'     BoxHighLight As _Unsigned Long, XOffset As Integer, YOffset As Integer

'Mode 0 (or any unsupported number) will tell the box to size itself from X1,Y1 to X2,Y2

'Mode 1 will tell the box to autosize itself according to whatever text is placed within it.

'Mode 2 will tell the box to use X2 and Y2 as relative coordinates and not absolute coordinates.  (Width and Height of box.)

'Mode 3 will tell the box to autocenter text with X2, Y2 being absolute coordinates.

'Mode 4 will tell the box to autocenter text with X2, Y2 being relative coordinates.  (Width and Height of box.)

'X1/Y1 carries the X/Y location of where we want to place our box on the screen.

'X2/Y2 is the X/Y boundry of our box on the screen, depending on our mode.

'Caption is the text that we want our box to contain.

'FontColor is our font color for our caption and FontBackground is the font background color for our caption

'BoxColor is our box color and BoxHighlight is our box highligh colors



'XOffset/YOFFSET  is used to offset our text # pixels from the X1/Y1 position.



Dim i As Long



For i = 0 To 4

    Print "Showcasing diffferent modes for Box.  This is mode #"; i

    Box i, 100, 100, 200, 200, "Hello World", Red, Blue, Gold, Silver, 0, 0

    Sleep

    Cls

Next



Sub Box (Mode As Integer, X1 As Integer, Y1 As Integer, X2 As Integer, Y2 As Integer, Caption As String, FontColor As _Unsigned Long, FontBackground As _Unsigned Long, BoxColor As _Unsigned Long, BoxHighLight As _Unsigned Long, XOffset As Integer, YOffset As Integer)

    'This is an upgrade version of my original Button routine.

    'It's more versitile (but complex) than the original.

    'Mode 0 (or any unsupported number) will tell the box to size itself from X1,Y1 to X2,Y2

    'Mode 1 will tell the box to autosize itself according to whatever text is placed within it.

    'Mode 2 will tell the box to use X2 and Y2 as relative coordinates and not absolute coordinates.

    'Mode 3 will tell the box to autocenter text with X2, Y2 being absolute coordinates.

    'Mode 4 will tell the box to autocenter text with X2, Y2 being relative coordinates.

    'Mode otherwise is unused, but available for expanded functionality.

    'X1 carries the X location of where we want to place our box on the screen.

    'Y2 carries the Y location of where we want to place our box on the screen.

    'X2 is the X boundry of our box on the screen, depending on our mode.

    'Y2 is the Y boundry of our box on the screen, depending on our mode.



    'Caption is the text that we want our box to contain.



    'FontColor is our font color for our caption

    'FontBackground is the font background color for our caption

    'NOTE: IF FONTCOLOR OR FONTBACKGROUND IS SET TO ZERO, THEY WILL **NOT** AFFECT THE COLOR BEHIND THEM.

    'This can be used to mimic the function of _KEEPBACKGROUND, _FILLBACKGROUND, or _ONLYBACKGROUND





    'BoxColor is our box color

    'BoxHighlight is our box highligh colors

    'NOTE: SAME WITH BOXCOLOR AND BOXHIGHLIGHT.  IF SET TO ZERO, THEY WILL HAVE **NO** COLOR AT ALL TO THEM, AND WILL NOT AFFECT THE BACKGROUND OF ANYTHING BEHIND THEM.



    'XOffset is used to offset our text # pixels from the X1 top.

    'YOffset is used to offset our text # pixels from the Y1 top.

    'These can be used to place our text wherever we want on our box.

    'But remember, if Mode = 3 or 4, the box will autocenter the text and ignore these parameters completely.



    Dim BoxBlack As _Unsigned Long

    Dim As Long dc, bg, cw, ch

    dc& = _DefaultColor: bg& = _BackgroundColor

    BoxBlack = _RGB32(0, 0, 0)

    cw = _PrintWidth(Caption): ch = _FontHeight



    Select Case Mode

        Case 0

            'We use the X2, Y2 coordinates provided as absolute coordinates

        Case 1

            X2 = X1 + cw + 8

            Y2 = Y1 + ch + 8

            XOffset = 5: YOffset = 5

        Case 2

            X2 = X1 + X2

            Y2 = Y1 + Y2

        Case 3

            XOffset = (X2 - X1 - cw) \ 2

            YOffset = (Y2 - Y1 - ch) \ 2

        Case 4

            X2 = X1 + X2

            Y2 = Y1 + Y2

            XOffset = (X2 - X1 - cw) \ 2

            YOffset = (Y2 - Y1 - ch) \ 2

    End Select

    Line (X1, Y1)-(X2, Y2), BoxBlack, BF

    Line (X1 + 1, Y1 + 1)-(X2 - 1, Y2 - 1), BoxHighLight, B

    Line (X1 + 2, Y1 + 2)-(X2 - 2, Y2 - 2), BoxHighLight, B

    Line (X1 + 3, Y1 + 3)-(X2 - 3, Y2 - 3), BoxBlack, B

    Line (X1, Y1)-(X1 + 3, Y1 + 3), BoxBlack

    Line (X2, Y1)-(X2 - 3, Y1 + 3), BoxBlack

    Line (X1, Y2)-(X1 + 3, Y2 - 3), BoxBlack

    Line (X2, Y2)-(X2 - 3, Y2 - 3), BoxBlack

    Line (X1 + 3, Y1 + 3)-(X2 - 3, Y2 - 3), BoxColor, BF

    Color FontColor, FontBackground

    _PrintString (X1 + XOffset, Y1 + YOffset), Caption$

    Color dc&, bg&

End Sub









Function BoxImage& (Mode As Integer, X As Integer, Y As Integer, Caption As String, FontColor As _Unsigned Long, FontBackground As _Unsigned Long, BoxColor As _Unsigned Long, BoxHighLight As _Unsigned Long, XOffset As Integer, YOffset As Integer)

    'This creates our box as an image so we can manipulate it however we wish before placing it on the screen.



    'Mode 0 will tell the box to draw itself X,Y size, and autocenter the text.

    'Mode 1 will tell the box to autosize itself according to whatever text is placed within it.

    'Mode 2 will tell the box to draw itself X,Y size, and place the text at the offsets.



    'Mode otherwise is unused, but available for expanded functionality.



    'Caption is the text that we want our box to contain.



    'FontColor is our font color for our caption

    'FontBackground is the font background color for our caption

    'NOTE: IF FONTCOLOR OR FONTBACKGROUND IS SET TO ZERO, THEY WILL **NOT** AFFECT THE COLOR BEHIND THEM.

    'This can be used to mimic the function of _KEEPBACKGROUND, _FILLBACKGROUND, or _ONLYBACKGROUND



    'BoxColor is our box color

    'BoxHighlight is our box highligh colors

    'NOTE: SAME WITH BOXCOLOR AND BOXHIGHLIGHT.  IF SET TO ZERO, THEY WILL HAVE **NO** COLOR AT ALL TO THEM, AND WILL NOT AFFECT THE BACKGROUND OF ANYTHING BEHIND THEM.



    'XOffset is used to offset our text # pixels from the X1 top.

    'YOffset is used to offset our text # pixels from the Y1 top.

    'These can be used to place our text wherever we want on our box.

    'But remember, if Mode = 3 or 4, the box will autocenter the text and ignore these parameters completely.



    Dim BoxBlack As _Unsigned Long

    Dim As Long dc, bg, cw, ch

    Dim As Long X1, Y1, X2, Y2, tempBoxImage

    dc& = _DefaultColor: bg& = _BackgroundColor

    BoxBlack = _RGB32(0, 0, 0)



    cw = _PrintWidth(Caption): ch = _FontHeight



    X1 = 0: Y1 = 0

    X2 = X: Y2 = Y



    Select Case Mode

        Case 0

            X2 = X1 + cw + 8

            Y2 = Y1 + ch + 8

            XOffset = 5: YOffset = 5

        Case 2

            XOffset = (X2 - cw) \ 2

            YOffset = (Y2 - ch) \ 2

    End Select

    tempBoxImage& = _NewImage(X, Y, 32)

    _Dest tempBoxImage&

    Line (X1, Y1)-(X2, Y2), BoxBlack, BF

    Line (X1 + 1, Y1 + 1)-(X2 - 1, Y2 - 1), BoxHighLight, B

    Line (X1 + 2, Y1 + 2)-(X2 - 2, Y2 - 2), BoxHighLight, B

    Line (X1 + 3, Y1 + 3)-(X2 - 3, Y2 - 3), BoxBlack, B

    Line (X1, Y1)-(X1 + 3, Y1 + 3), BoxBlack

    Line (X2, Y1)-(X2 - 3, Y1 + 3), BoxBlack

    Line (X1, Y2)-(X1 + 3, Y2 - 3), BoxBlack

    Line (X2, Y2)-(X2 - 3, Y2 - 3), BoxBlack

    Line (X1 + 3, Y1 + 3)-(X2 - 3, Y2 - 3), BoxColor, BF

    Color FontColor, FontBackground

    _PrintString (X1 + XOffset, Y1 + YOffset), Caption$

    Color dc&, bg&

    _Dest 0

    BoxImage = tempBoxImage

End Function



Function TextScreenToImage256& (image&)

    Dim As Long d, s, i, f, fw, fh, w, h, l

    Dim As Long tempScreen, Screen0to256

    Dim m As _MEM, b As _Unsigned _Byte, t As String * 1

    Dim o As _Offset



    d& = _Dest: s& = _Source

    Dim Plt(15) As Long

    _Source image&: _Dest image&

    For i = 0 To 15: Plt(i) = _PaletteColor(i, image&): Next

    f& = _Font(image&)

    _Font f&

    fw& = _FontWidth

    fh& = _FontHeight

    w& = _Width * _FontWidth

    h& = _Height * _FontHeight '+ _HEIGHT

    l& = (_Width * _Height) * 2 'The screen is width * height in pixels.  (80X25) = 2000 X 2 bytes each = 4000 total bytes to hold a page of screen 0 text and color

    tempScreen& = _NewImage(w&, h& + _Height, 256)

    Screen0to256& = _NewImage(w&, h&, 256)



    m = _MemImage(image&)

    o = m.OFFSET



    _Dest (tempScreen&)

    For i = 0 To 15: _PaletteColor i, Plt(i): Next

    _Font f&



    For i = 0 To l& - 2 Step 2

        _MemGet m, m.OFFSET + i, t

        _MemGet m, m.OFFSET + i + 1, b

        If b > 127 Then b = b - 128

        Color b Mod 16, b \ 16

        Print t;

    Next

    _PutImage , tempScreen&, Screen0to256&, (0, 0)-(w&, h&)

    _FreeImage tempScreen&

    _Dest d&: _Source s&

    _MemFree m

    TextScreenToImage256 = Screen0to256&

End Function



Function TextScreenToImage32& (image&)

    Dim As Long d, s, i, f, fw, fh, w, h, l, fgc, bgc

    Dim As Long tempScreen, Screen0To32

    d& = _Dest: s& = _Source

    Dim Plt(15) As Long

    _Source image&

    For i = 0 To 15: Plt(i) = _PaletteColor(i, image&): Next

    f& = _Font(image&)

    _Font f&

    fw& = _FontWidth

    fh& = _FontHeight

    w& = _Width * _FontWidth

    h& = _Height * _FontHeight '+ _HEIGHT

    l& = (_Width * _Height) * 2 'The screen is width * height in pixels.  (80X25) = 2000 X 2 bytes each = 4000 total bytes to hold a page of screen 0 text and color

    tempScreen& = _NewImage(w&, h& + _Height, 32)

    Screen0To32& = _NewImage(w&, h&, 32)

    _Dest tempScreen&



    Dim m As _MEM, b As _Unsigned _Byte, t As String * 1

    Dim o As _Offset

    m = _MemImage(image&)

    o = m.OFFSET



    _Font f&



    For i = 0 To l& - 2 Step 2

        _MemGet m, m.OFFSET + i, t

        _MemGet m, m.OFFSET + i + 1, b

        If b > 127 Then b = b - 128

        fgc = b Mod 16: bgc = b \ 16

        Color _RGB32(_Red(fgc, image&), _Green(fgc, image&), _Blue(fgc, image&)), _RGB32(_Red(bgc, image&), _Green(bgc, image&), _Blue(bgc, image&))

        Print t;

    Next

    _PutImage , tempScreen&, Screen0To32&, (0, 0)-(w&, h&)

    _FreeImage tempScreen&

    _Dest d&: _Source s&

    _MemFree m

    TextScreenToImage32 = Screen0To32&

End Function



Function BinaryStringSearch (search$, Array() As String)

    'These routines work with actual indexes, so we can search from Array(-10 to 10), if we want to.

    'When the search string is found, it'll return a value = to the index proper.

    'When it's not found, it'll return a value LESS THAN the LBOUND limit of the array,

    'And the point where the string WOULD'VE appeared, if it existed, is after the shared variable LastIndex



    BinaryStringSearch = BinaryStringSearchSome(search$, Array(), LBound(Array), UBound(Array))

End Function



Function BinaryStringSearchSome (search$, Array() As String, StartIndex As Long, EndIndex As Long)

    'These routines work with actual indexes, so we can search from Array(-10 to 10), if we want to.

    'When the search string is found, it'll return a value = to the index proper.

    'When it's not found, it'll return a value LESS THAN the LBOUND limit of the array,

    'And the point where the string WOULD'VE appeared, if it existed, is after the shared variable LastIndex

    Dim As Long min, max, compare, LastIndex, found

    Dim As _Float gap

    min = StartIndex

    max = EndIndex



    Do

        gap = (max + min) \ 2

        compare = _StrCmp(search$, Array(gap))

        If compare > 0 Then

            min = gap + 1

        ElseIf compare < 0 Then

            max = gap - 1

        Else

            BinaryStringSearchSome = gap

            Exit Function

        End If

        If max - min < 1 Then

            If search$ = Array(min) Then

                BinaryStringSearchSome = min

            Else

                BinaryStringSearchSome = LBound(Array) - 1

                If search$ < Array(min) Then

                    LastIndex = min - 1

                Else

                    LastIndex = min

                End If

            End If

            found = -1

        End If

    Loop Until found

End Function



Sub StringSortSome (Array() As String, StartIndex As Long, EndIndex As Long)

    Dim As Long min, max, i, swapped

    Dim As _Float gap

    min = StartIndex

    max = EndIndex



    gap = EndIndex - StartIndex + 1

    Do

        gap = 10 * gap \ 13

        If gap < 1 Then gap = 1

        i = StartIndex

        swapped = 0

        Do

            If _StrCmp(Array(i), Array(i + gap)) > 0 Then

                Swap Array(i), Array(i + gap)

                swapped = -1

            End If

            i = i + 1

        Loop Until i + gap > EndIndex

    Loop Until swapped = 0 And gap = 1

End Sub



Sub StringSort (Array() As String)

    StringSortSome Array(), LBound(Array), UBound(Array)

End Sub

@SMcNeill, @RhoSigma and @TerryRitchie

I don't remember seeing this discussion for Libraries and would very much like to review the results you agreed upon (if you did) actually the thinking and reasoning behind the guidelines would be best for review.

A review might aid Terry's tutorial as well.

I do have some ideas for guidelines in building Toolboxes.

1. Have code that tests each sub and function perhaps against other methods. I have a folder called Test just for that purpose each file is a routine or related few. Make notes why you did this and that. If something goes wrong using the routine go back to this test file and update the routine. Rule of thumb question: "Can you ever test enough?"

2. All the best subs and function are pasted into 000Handy at the top of my QB64 Work Folder for easy access and helps see if they can coexist ie no name conflicts.

3. If the routine needs another sub or function be sure to make note of it.

4. Avoiding dependence of constants from Main program but list inside sub if you are using a UDT or constant or anything that needs inclusion in main code so routine works.

That's a few from the top of my head for toolboxes, I am big fan of copy / paste from toolbox to get just the routines I need into the app I am working so no extra library files needed. But I don't write giant programs either except GUI, oh Interpreter and FVal$ is getting there specially when finish adding String Math and Astring Functions.

Toolbox Advantage: after pasted into app, you can modify as needed for app without screwing up the toolbox code. That is pretty hard to do with Library Code, I found out over and over with GUI stuff.

Before I saw the correct version of Cube from Morristown I thought the game would benefit from a mapping display for "You are here." But the way input was setup with Morristown code it was clear where you've been and where you could go next. Anyway here is my version made from scratch.

Oh a couple of mods to game:
1. to make input as easy and simple as possible you only enter one letter for your move
2. that one letter increases player one step on x, y or z plane
3. Wager is out but when you succeed to 3,3,3 you earn 1000 first time and are offered the opportunity to play again to double your money or lose it all and end game.

A multi-window program to draw ASCII-art. 
The program consists of the main program and 2 other programs that must also be compiled for this to function properly.

sorry V0.2 for Windows only due to the clipboard use.  V0.3 doesn't use the clipboard commands

Thanks to SMcNeil for the excellent text screen saving routines.

EDIT: V0.3 entries for all 3 programs are in a later post to this thread. Hopefully it will work on other systems.

'Ascii Clipdoodle  V 0.2

'an ascii doodle pad that opens control panel apps in other windows

'

'sorry windows only

'

'loadtextimage and savetextimage from SMcNeil at  https://qb64phoenix.com/forum/showthread.php?tid=2022

'

'pickclip.exe and colorpick16.exe must be compiled before this program will function properly



Dim Shared reflag

reflag = -1

Dim Shared helpscreen As Long

Dim Shared twd, tht



twd = 80: tht = 25

helpscreen = _NewImage(twd, tht, 0)



Dim Shared mainscreen As Long

mainscreen = _NewImage(80, 25, 0) 'default size text screen. feel free to change it.

Screen mainscreen

_Title "Ascii ClipDoodle"

Cls

_Clipboard$ = "ClipDoodleOn" ' "clears" clipboard for use

Shell _DontWait "pickclip.exe" ' Open the pickclip control panel

Shell _DontWait "colorpick16.exe" ' Open the colorpick16 control panel

_ControlChr Off

AK = 42

Do

    _Limit 100

    Do While _MouseInput 'mouse status changes only

        _Limit 2000

        x = _MouseX

        y = _MouseY

        px = _MouseX: py = _MouseY

        If _MouseButton(1) Then

            _PrintString (x, y), brush$

        End If

    Loop

    kk$ = InKey$

    Select Case kk$

        Case "t", "T" 'type on current line with current color characteristics

            _KeyClear

            Do

                Do

                    _Limit 60

                    tk$ = InKey$

                Loop Until tk$ <> ""

                If tk$ = Chr$(8) Then

                    tk$ = ""

                    px = px - 1

                End If

                If tk$ <> Chr$(13) And tk$ <> "" Then

                    _PrintString (px, py), tk$

                    px = px + 1

                    If px > _Width Then tk$ = Chr$(13) 'exit type input if attempting to type outside screen

                End If

            Loop Until tk$ = Chr$(13)

        Case "S" 'save text screen

            filef = 0

            file$ = _SaveFileDialog$("Save File", "", "*.SAV", "SAved text screen")

            If file$ <> "" Then

                filef = 1

                _MessageBox "Information", "File will be saved to " + file$

            End If

            If filef = 1 Then

                SaveTextImage 0, file$

                _MessageBox "Image SAved", "Text Images SAVED to " + file$

            End If

            filef = 0

        Case "L", "O" 'load text screen

            file$ = _OpenFileDialog$("Open File", "", "*.SAV", "SAVed text screen", -1)

            If file$ <> "" Then

                _MessageBox "Information", "You selected " + file$

                'mainscreen = LoadTextImage(file$)

                Screen LoadTextImage(file$)

                tht = _Height

                twid = _Width

            End If



        Case "C" 'clear screen

            cc = _MessageBox("CLEAR SCREEN", "Are you sure you want to clear the screen? The image will be lost if it has not been saved. ", "yesnocancel", "warning", 0)

            If cc = 1 Then Cls

        Case Chr$(27)

            cc = _MessageBox("QUIT !", "Are you sure you wish to QUIT? The image will be lost if it has not been saved. ", "yesnocancel", "warning", 0)

            If cc = 1 Then Else kk$ = ""



        Case "R"

            do_resize

        Case "?" 'help

            do_help

    End Select



    ik$ = _Clipboard$

    If Left$(ik$, 2) = "AC" Then AK = Val(Right$(ik$, Len(ik$) - 2))

    If Left$(ik$, 2) = "CK" Then

        ff$ = " "

        n = 2

        Do

            n = n + 1

            A$ = Mid$(ik$, n, 1)

            If A$ <> "/" Then ff$ = ff$ + A$

        Loop Until A$ = "/"

        bb$ = ""

        Do

            A$ = Mid$(ik$, n, 1)

            If A$ <> "/" Then bb$ = bb$ + A$

            n = n + 1

        Loop Until n > Len(ik$)

        FG = Val(ff$): BG = Val(bb$)

        Color FG, BG

    End If

    brush$ = Chr$(AK)

Loop Until kk$ = Chr$(27)

_Clipboard$ = "QUITCOLORPICK16"

Sleep 1

_Clipboard$ = "QUITCLIPPICK"

System

Sub do_help

    ls& = _Dest

    Screen helpscreen

    Cls

    Print "HELP"

    Print "------------------"

    Print "use mouse to draw with ascii characters"

    Print "select character to draw and colors from control panels"

    Print " "

    Print "<ESC> to quit program"

    Print "t,T  -  To type a line of text in colors picked"

    Print

    Print "S    - To Save Screen"

    Print "L,O  - to Load Saved Screen"

    Print "C    - to clear screen"

    print "R    - to Resize Screen   (WARNING : DESTRUCTIVE)"

    Print

    Print "press any key to continue"

    Sleep

    Screen ls&

End Sub

Sub do_resize

    ls& = _Dest

    Screen helpscreen

    Cls

    Print "Resize"

    Print "------------------"

    Print "Current size "

    Print "width "; twd, "Height "; tht

    Print "Enter new coordinates"

    Input "Width "; twd

    Input "Height"; tht

    _FreeImage ls&



    Screen _NewImage(twd, tht, 0)

End Sub









Function LoadTextImage& (SaveFile As String) 'create and load to a new Screen 0 screen with our saved image

    Dim As Integer Wide, Tall, Flag: Wide = 80: Tall = 25: Flag = 0

    Dim As String ImageData

    Dim As _MEM M

    f = FreeFile

    Open SaveFile For Binary As #f

    compress$ = Space$(LOF(f))

    Get #f, 1, compress$

    Close #f

    temp$ = _Inflate$(compress$)

    Flag = Asc(temp$, 1): p = 2



    If Flag And 1 Then Wide = CVI(Mid$(temp$, p, 2)): p = p + 2

    If Flag And 2 Then Tall = CVI(Mid$(temp$, p, 2)): p = p + 2

    If Flag And 4 Then _Blink On Else _Blink Off

    If Flag And 8 Then _Font Asc(temp$, p): p = p + 1

    ImageData = Mid$(temp$, p)

    TempImage = _NewImage(Wide, Tall, 0)

    M = _MemImage(TempImage): _MemPut M, M.OFFSET, ImageData: _MemFree M

    LoadTextImage = TempImage

End Function



Sub SaveTextImage (ImageHandle As Long, SaveFile As String)

    Dim As Integer Wide, Tall, Flag

    Dim As Long ImageSize

    Dim As String ImageData

    Dim As _MEM M

    If _PixelSize(ImageHandle) <> 0 Then Error 5: Exit Sub 'only text images for this routine



    M = _MemImage(ImageHandle)

    Wide = _Width(ImageHandle): Tall = _Height(ImageHandle)

    temp$ = "0" 'placeholder for our finalized image flag which holds custom information



    If Wide <> 80 Then Flag = Flag + 1: temp$ = temp$ + MKI$(Wide)

    If Tall <> 25 Then Flag = Flag + 2: temp$ = temp$ + MKI$(Tall)

    If _Blink Then Flag = Flag + 4 'Set a flag saying that this image uses _Blink

    Select Case _Font(ImageHandle)

        Case 8: Flag = Flag + 8: temp$ = temp$ + Chr$(8)

        Case 9: Flag = Flag + 8: temp$ = temp$ + Chr$(9)

        Case 14: Flag = Flag + 8: temp$ = temp$ + Chr$(14)

        Case 15: Flag = Flag + 8: temp$ = temp$ + Chr$(15)

        Case 16 '16 needs no flag as it's the default for screen 0

        Case 17: Flag = Flag + 8: temp$ = temp$ + Chr$(17)

        Case Else

            'To be added once we get a _MemFont to retrieve custom font data back from QB64PE

    End Select

    ImageSize = Wide * Tall * 2

    ImageData = Space$(ImageSize): _MemGet M, M.OFFSET, ImageData: _MemFree M

    temp$ = temp$ + ImageData

    Mid$(temp$, 1) = Chr$(Flag) 'replace our placeholder with the proper value of the custom flag

    compress$ = _Deflate$(temp$)

    f = FreeFile

    Open SaveFile For Output As #f: Close #f

    Open SaveFile For Binary As #f: Put #f, 1, compress$: Close #f

End Sub

'colorpick16  0.2

'

'a color picker for mode 0 screens.

'compile as colorpick16.exe

'

Screen _NewImage(32, 8, 0)

_ScreenMove 600, 400

_Title "colorpick16"

blinkflag = -1

hflag = -1

FB = 0

BB = 0



print_picker FB, BB

Do

    _Limit 100

    Do While _MouseInput 'mouse status changes only

        x = _MouseX

        y = _MouseY

        If _MouseButton(1) Then

            If y >= 1 And y <= 2 Then

                fk = (y - 1) * 8 + Int(x / 4) + FB

            End If

            Color fk, 0

            If fk = 0 Then Color fk, 8

            _PrintString (12, 4), "    "

            _PrintString (12, 4), Str$(fk)

            If y = 7 Then

                bk = Int(x / 4) + BB

            End If

            Color fk, bk

            _PrintString (12, 5), "    "

            _PrintString (12, 5), Str$(bk)

            _Clipboard$ = "CK" + _Trim$(Str$(fk)) + "/" + _Trim$(Str$(bk))

            If x = 31 And y = 4 Then

                blinkflag = blinkflag * -1

                Select Case blinkflag

                    Case -1

                        FB = 0

                        BB = 0

                        print_picker FB, BB



                    Case 1

                        FB = 16

                        BB = 8

                        print_picker FB, BB



                End Select

            End If

        End If

    Loop

    kk$ = InKey$

    Select Case kk$

        Case "B"

            FB = 16

            BB = 8

            print_picker FB, BB

        Case "b"

            FB = 0

            BB = 0

            print_picker FB, BB

        Case Chr$(27)

            cc = _MessageBox("QUIT !", "Are you sure you wish to QUIT? The program will lose functionality. ", "yesnocancel", "warning", 0)

            If cc = 1 Then cc = 1 Else kk$ = ""

    End Select

    ccheck$ = _Clipboard$

    If ccheck$ = "QUITCOLORPICK16" Then kk$ = "QUITCOLORPICK16"

Loop Until kk$ = Chr$(27) Or kk$ = "QUITCOLORPICK16"

_Clipboard$ = "pickcolor quit"



System

Sub print_picker (f, b)

    For y = 0 To 1

        For x = 0 To 7

            fk = y * 8 + x + f

            p$ = "[  ]"

            a$ = _Trim$(Str$(fk))

            If Len(a$) = 1 Then

                Mid$(p$, 3, 1) = a$

            Else

                Mid$(p$, 2, 2) = a$

            End If

            Color fk, 0

            If fk = 0 Then Color 0, 7

            _PrintString ((x + 1) * 4 - 3, y + 1), p$

        Next

    Next

    _PrintString (31, 4), "B"

    _PrintString (1, 4), "Foreground"

    _PrintString (1, 5), "Background"

    For x = 0 To 7

        bk = x + b

        p$ = "[  ]"

        a$ = _Trim$(Str$(bk))

        If bk < 8 Then Mid$(p$, 3, 1) = a$ Else Mid$(p$, 2, 2) = a$

        Color 0, bk

        If bk = 0 Then Color 15, 0

        _PrintString ((x + 1) * 4 - 3, 7), p$

    Next

    fk = 15: bk = 0







End Sub

'colorpick16  0.2

'

'a color picker for mode 0 screens.

'compile as colorpick16.exe

'

Screen _NewImage(32, 8, 0)

_ScreenMove 600, 400

_Title "colorpick16"

blinkflag = -1

hflag = -1

FB = 0

BB = 0



print_picker FB, BB

Do

    _Limit 100

    Do While _MouseInput 'mouse status changes only

        x = _MouseX

        y = _MouseY

        If _MouseButton(1) Then

            If y >= 1 And y <= 2 Then

                fk = (y - 1) * 8 + Int(x / 4) + FB

            End If

            Color fk, 0

            If fk = 0 Then Color fk, 8

            _PrintString (12, 4), "    "

            _PrintString (12, 4), Str$(fk)

            If y = 7 Then

                bk = Int(x / 4) + BB

            End If

            Color fk, bk

            _PrintString (12, 5), "    "

            _PrintString (12, 5), Str$(bk)

            _Clipboard$ = "CK" + _Trim$(Str$(fk)) + "/" + _Trim$(Str$(bk))

            If x = 31 And y = 4 Then

                blinkflag = blinkflag * -1

                Select Case blinkflag

                    Case -1

                        FB = 0

                        BB = 0

                        print_picker FB, BB



                    Case 1

                        FB = 16

                        BB = 8

                        print_picker FB, BB



                End Select

            End If

        End If

    Loop

    kk$ = InKey$

    Select Case kk$

        Case "B"

            FB = 16

            BB = 8

            print_picker FB, BB

        Case "b"

            FB = 0

            BB = 0

            print_picker FB, BB

        Case Chr$(27)

            cc = _MessageBox("QUIT !", "Are you sure you wish to QUIT? The program will lose functionality. ", "yesnocancel", "warning", 0)

            If cc = 1 Then cc = 1 Else kk$ = ""

    End Select

    ccheck$ = _Clipboard$

    If ccheck$ = "QUITCOLORPICK16" Then kk$ = "QUITCOLORPICK16"

Loop Until kk$ = Chr$(27) Or kk$ = "QUITCOLORPICK16"

_Clipboard$ = "pickcolor quit"



System

Sub print_picker (f, b)

    For y = 0 To 1

        For x = 0 To 7

            fk = y * 8 + x + f

            p$ = "[  ]"

            a$ = _Trim$(Str$(fk))

            If Len(a$) = 1 Then

                Mid$(p$, 3, 1) = a$

            Else

                Mid$(p$, 2, 2) = a$

            End If

            Color fk, 0

            If fk = 0 Then Color 0, 7

            _PrintString ((x + 1) * 4 - 3, y + 1), p$

        Next

    Next

    _PrintString (31, 4), "B"

    _PrintString (1, 4), "Foreground"

    _PrintString (1, 5), "Background"

    For x = 0 To 7

        bk = x + b

        p$ = "[  ]"

        a$ = _Trim$(Str$(bk))

        If bk < 8 Then Mid$(p$, 3, 1) = a$ Else Mid$(p$, 2, 2) = a$

        Color 0, bk

        If bk = 0 Then Color 15, 0

        _PrintString ((x + 1) * 4 - 3, 7), p$

    Next

    fk = 15: bk = 0

End Sub

From game by D.Ahl BASIC COMPUTER GAMES

Can someone explain this game to me? I've seen Davids Morristown version (Before QB) and now MG's QB64 update, I don't get what's going on.

I'd share QB64 code from another forum but might upset mnr's cohorts so I better not ;-))
I just wanna have fun!

I thought a few of you guys might have use for some of these inside your own works.  (Note that these are all going into my toolbox project as well.  I just thought I'd share them independent here for a preview of sorts for folks to enjoy.)

Print "Is the date in proper format?  The skies say "; CheckDayFormat(Date$)

Print "The Date = "; Date$

Print "Weekday  = "; GetWeekDayName(Date$); ", which is day number"; GetWeekDay(Date$); "of the week."

Print "Day      ="; GetDay(Date$)

Print "Month    ="; GetMonth(Date$)

Print "Year    ="; GetYear(Date$)

Print

Print "And to reverse the process we take those values and make them a date with :"; MakeDate(GetMonth(Date$), GetDay(Date$), GetYear(Date$))

Print

Print

Print

Print "And we can always fancify our date to universal formats: "

Print UniDate$("mm/dd/yyyy", Date$)

Print UniDate$("w, MM dd, YYYY", Date$)

Print UniDate$("W, MM DD, YYYY", Date$)

Print UniDate$("dd/mm/yyyy", Date$)

Print UniDate$("W, E D, YYYY", Date$)

Print UniDate$("mm-dd-yy", Date$)





Function CheckDayFormat (Day As String) 'use MM/DD/YYYY format

    Dim As String DD, MM, YYYY, TD, TM, TY

    If Len(Day$) <> 10 Then Glitch = -1

    DD = Left$(Day, 2)

    MM = Mid$(Day, 4, 2)

    YYYY = Right$(Day, 4)

    TD = Right$("00" + _Trim$(Str$(Val(DD))), 2)

    TM = Right$("00" + _Trim$(Str$(Val(MM))), 2)

    TY = Right$("0000" + _Trim$(Str$(Val(YYYY))), 4)

    If TD <> DD Then Glitch = -1

    If TM <> MM Then Glitch = -1

    If TY <> YYYY Then Glitch = -1

    If Glitch = 0 Then CheckDayFormat = -1

End Function



Function GetDay& (Day As String) 'use MM/DD/YYYY format

    If CheckDayFormat(Day$) = 0 Then GetDay = 0: Exit Function

    GetDay = Val(Mid$(Day, 4, 2))

End Function



Function GetMonth& (Day As String) 'use MM/DD/YYYY format

    If CheckDayFormat(Day$) = 0 Then GetMonth = 0: Exit Function

    GetMonth = Val(Left$(Day, 2))

End Function



Function GetYear& (Day As String) 'use MM/DD/YYYY format

    If CheckDayFormat(Day$) = 0 Then GetYear = 0: Exit Function

    GetYear = Val(Right$(Day, 4))

End Function



Function GetWeekDay& (Day$) 'use MM/DD/YYYY format

    'From Zeller's congruence: https://en.wikipedia.org/wiki/Zeller%27s_congruence

    If CheckDayFormat(Day$) = 0 Then GetWeekDay = 0: Exit Function

    Dim As Long century, zerocentury, result

    Dim As Long MM, DD, YYYY

    MM = GetMonth(Day$): DD = GetDay(Day$): YYYY = GetYear(Day$)

    If MM < 3 Then MM = MM + 12: YYYY = YYYY - 1

    century = YYYY Mod 100

    zerocentury = YYYY \ 100

    result = (DD + Int(13 * (MM + 1) / 5) + century + Int(century / 4) + Int(zerocentury / 4) + 5 * zerocentury) Mod 7

    If result = 0 Then result = 7

    GetWeekDay& = result 'results are 1 to 7, from Sunday to Saturday

End Function



Function GetWeekDayName$ (Day$) 'use MM/DD/YYYY format

    Dim result As Long

    result = GetWeekDay(Day$)

    Select Case result

        Case 1: GetWeekDayName = "Sunday"

        Case 2: GetWeekDayName = "Monday"

        Case 3: GetWeekDayName = "Tuesday"

        Case 4: GetWeekDayName = "Wednesday"

        Case 5: GetWeekDayName = "Thursday"

        Case 6: GetWeekDayName = "Friday"

        Case 7: GetWeekDayName = "Saturday"

    End Select

End Function



Function MakeDate$ (MM As _Unsigned Long, DD As _Unsigned Long, YYYY As _Unsigned Long)

    Dim As String TD, TM, TY

    TM = Right$("00" + _Trim$(Str$(MM)), 2)

    TD = Right$("00" + _Trim$(Str$(DD)), 2)

    TY = Right$("0000" + _Trim$(Str$(YYYY)), 4)

    MakeDate = TM + "-" + TD + "-" + TY

End Function



Function UniDate$ (format$, userdate$)

    'some basic documentation for formatting:

    'dates sent via userdate$ should be in the standardized QB64 DATE$ format -- MM/DD/YYYY

    'To customize your return date format, use the following syntax

    'w = short weekday names.  (Mon, Tue, Wed, Thu, Fri, Sat, Sun)

    'W = long weekday names.  (Monday, Tuesday, Wednesday, Thursday, Friday, Saturday, Sunday)

    'E = Extended month names.  (January, February, March....)

    'M = long month names.  (Jan, Feb, Mar...)

    'm = short month names.  (01, 02, 03...)

    'D = long day names.  (01st, 02nd, 03rd...)

    'd = short day names.  (01, 02, 03...)

    'Y or y (case insensitive) = year.  Number of Yy present determines the number of digits we return.

    '      YY = 2-digit year

    '      YYYY = 4 digit year

    '      Y with any additional number of y's = 4 digit year by default, so a typo of YYYYY is the same as YYYY.

    'Any other character is simply considered part of the desired output and faithfully carried over into the proper spot.

    '      For example, "mm/dd/yyyy" gives us "02/10/2023" for Feb 10th, 2023.

    '      Second example, "dd.mm.yyyy" gives us "10.02.2023" for the same date.

    '      Third example, "dd EE YYYY" gives us "02 February 2023" for that same date.

    'Note:  Extra digits of most of these codes are simply ignored for error proofing purposes, with only the initial code being accepted.

    '      For example "mM YYYY" is actually processed as a simple "m YYYY".  The process won't mix short, long, or extended results.

    '      Also for example, "m YY" is the *exact* same as "mm YY".

    '      Feel free to use extra digits as you desire to help you keep track of positional spacing in your format string.

    '      Even though "M D, yyyy" may process the same as "MMM DDDD, YYYY", the second may work better for you if you're trying to track

    '            position of formatted objects.  (The output would be "Feb 10th, 2023", and those extra characters help hold that

    '            positioning for us easily.)



    'And, I think that's it.  Enjoy, guys!



    Dim As String temp, m, d, y, firstchar, Day

    Dim out$

    Dim As Long MonthSet, DaySet, WeekdaySet, result, YearSet, mm, dd, yyyy, century, zerocentury



    temp$ = userdate$

    If temp$ = "" Then temp$ = Date$

    m$ = Left$(temp$, 2)

    d$ = Mid$(temp$, 4, 2)

    y$ = Right$(temp$, 4)

    temp$ = format$

    Do

        firstchar$ = Left$(temp$, 1)

        Select Case firstchar$

            Case "E" 'extended month

                temp$ = Mid$(temp$, 2)

                If Not MonthSet Then

                    MonthSet = -1

                    Select Case Val(m$)

                        Case 1: out$ = out$ + "January"

                        Case 2: out$ = out$ + "February"

                        Case 3: out$ = out$ + "March"

                        Case 4: out$ = out$ + "April"

                        Case 5: out$ = out$ + "May"

                        Case 6: out$ = out$ + "June"

                        Case 7: out$ = out$ + "July"

                        Case 8: out$ = out$ + "August"

                        Case 9: out$ = out$ + "September"

                        Case 10: out$ = out$ + "October"

                        Case 11: out$ = out$ + "November"

                        Case 12: out$ = out$ + "December"

                    End Select

                End If

            Case "M" 'long month

                temp$ = Mid$(temp$, 2)

                If Not MonthSet Then

                    MonthSet = -1

                    Select Case Val(m$)

                        Case 1: out$ = out$ + "Jan"

                        Case 2: out$ = out$ + "Feb"

                        Case 3: out$ = out$ + "Mar"

                        Case 4: out$ = out$ + "Apr"

                        Case 5: out$ = out$ + "May"

                        Case 6: out$ = out$ + "Jun"

                        Case 7: out$ = out$ + "Jul"

                        Case 8: out$ = out$ + "Aug"

                        Case 9: out$ = out$ + "Sep"

                        Case 10: out$ = out$ + "Oct"

                        Case 11: out$ = out$ + "Nov"

                        Case 12: out$ = out$ + "Dec"

                    End Select

                End If

            Case "m" 'short month

                temp$ = Mid$(temp$, 2)

                If Not MonthSet Then

                    MonthSet = -1

                    Select Case Val(m$)

                        Case 1: out$ = out$ + "01"

                        Case 2: out$ = out$ + "02"

                        Case 3: out$ = out$ + "03"

                        Case 4: out$ = out$ + "04"

                        Case 5: out$ = out$ + "05"

                        Case 6: out$ = out$ + "06"

                        Case 7: out$ = out$ + "07"

                        Case 8: out$ = out$ + "08"

                        Case 9: out$ = out$ + "09"

                        Case 10: out$ = out$ + "10"

                        Case 11: out$ = out$ + "11"

                        Case 12: out$ = out$ + "12"

                    End Select

                End If

            Case "D" 'long day

                temp$ = Mid$(temp$, 2)

                If Not DaySet Then

                    DaySet = -1

                    out$ = out$ + Right$("00" + _Trim$(d$), 2)

                    Select Case Val(d$)

                        Case 1, 11, 21, 31: out$ = out$ + "st"

                        Case 2, 22: out$ = out$ + "nd"

                        Case 3, 23: out$ = out$ + "rd"

                        Case Else: out$ = out$ + "th"

                    End Select

                End If

            Case "d" 'short day

                temp$ = Mid$(temp$, 2)

                If Not DaySet Then

                    DaySet = -1

                    out$ = out$ + Right$("00" + _Trim$(d$), 2)

                End If



            Case "W" 'long weekday

                temp$ = Mid$(temp$, 2)

                If Not WeekdaySet Then

                    GoSub getday

                    Select Case result

                        Case 0: Day$ = "Saturday"

                        Case 1: Day$ = "Sunday"

                        Case 2: Day$ = "Monday"

                        Case 3: Day$ = "Tuesday"

                        Case 4: Day$ = "Wednesday"

                        Case 5: Day$ = "Thursday"

                        Case 6: Day$ = "Friday"

                    End Select

                    out$ = out$ + Day$

                End If

            Case "w" 'short weekday

                temp$ = Mid$(temp$, 2)

                If Not WeekdaySet Then

                    GoSub getday

                    Select Case result

                        Case 0: Day$ = "Sat"

                        Case 1: Day$ = "Sun"

                        Case 2: Day$ = "Mon"

                        Case 3: Day$ = "Tue"

                        Case 4: Day$ = "Wed"

                        Case 5: Day$ = "Thr"

                        Case 6: Day$ = "Fri"

                    End Select

                    out$ = out$ + Day$

                End If

            Case "Y", "y" 'year

                If Not YearSet Then

                    YearSet = -1

                    If Left$(UCase$(temp$), 4) = "YYYY" Then

                        temp$ = Mid$(temp$, 5)

                        out$ = out$ + y$

                    ElseIf Left$(UCase$(temp$), 2) = "YY" Then

                        temp$ = Mid$(temp$, 3)

                        out$ = out$ + Right$(y$, 2)

                    Else

                        temp$ = Mid$(temp$, 2)

                        out$ = out$ + y$

                    End If

                Else

                    temp$ = Mid$(temp$, 2)

                End If

            Case Else 'seperator

                temp$ = Mid$(temp$, 2)

                out$ = out$ + firstchar$

        End Select

    Loop Until temp$ = ""

    UniDate$ = out$

    Exit Function



    getday:

    WeekdaySet = -1

    'From Zeller's congruence: https://en.wikipedia.org/wiki/Zeller%27s_congruence

    mm = Val(m$): dd = Val(d$): yyyy = Val(y$)

    If mm < 3 Then mm = mm + 12: yyyy = yyyy - 1

    century = yyyy Mod 100

    zerocentury = yyyy \ 100

    result = (dd + Int(13 * (mm + 1) / 5) + century + Int(century / 4) + Int(zerocentury / 4) + 5 * zerocentury) Mod 7

    Return

End Function