Hi guys.
I still need help.
I play a 1991 DOS game that has been modded a bit. Because of that, the setup/installer program doesn't function anymore.
Installation can be done with xcopy, but that is a bit crude and unselective. (windows and Linux users can use drag and drop combined with dosbox)
So only for DOS users there is 'need' for something better. It would be nice to have a complete game again with all parts functional as intended.
The setup part is already rewritten (in QB), so only the installation part is needed (in QB, because it's for DOS and DOS only).
It needs to be able to.
1 - install(copy) the game (set file list from file) from A, to B.
2 - recognize track files and be able to list them (so one, a selection or all can be moved/copied/deleted from A to B)
3 - recognize car files (4 per car) and be able to list them (so one, a selection or all can be moved/copied/deleted from A to B)
4 - list all files that are not game, track or car and be able to list them (so one, a selection or all can be moved/copied/deleted from A to B)
5 - unpack zip files to any location.
6 - Backup (part eg game ,tracks or cars) of the installation.
7 - store deleted files in a recycle bin Dir.
I hope there are still some old school programmers active.
Vince is fine programmer with specially clean style of coding. Hate to see his work get buried (= lost) in Programs section, so I offered and he accepted a little place of his own. He has very nice graphics both 2D and 3D and a fan of FreeBasic and JustBasic (really?) or just being an independent program language type guy...
So vince thankyou, this thread is yours. (If you don't like the title let me know.)
If you can see in the thumbnail there, we've added a new option to the start menu for "Run only (no exe)". This option allows you to compile your file, run it, and then cleans it off your drive when it's finished. I saw a request somewhere about compiling to temp files, and so I took a while to come up with this for us.
Currently it's only in my personal fork of the repo, and I've only tested it and verified that it's working as intended for Windows. Tomorrow I'll test to get it up and going for Linux (and hopefully Mac, though I don't have a Mac to test things on), and then I'll push it into our repo and it'll be one of the features added in to our next build release.
Posted by: Dav - 04-29-2022, 03:20 AM - Forum: Dav
- No Replies
RightClickMenu is an easy way to add a small right click popup menu to you programs. There are several menu styles to choose from - or set your own custom menu colors. Just define your menu items and call the function by right clicking on the screen. There are menu separators and items can be disabled/enabled on the fly. The demo code below show how to call and use the function. If you need any help just ask.
This is an older version, I lost the newer one that had more menu styles.
- Dav
Code: (Select All)
'====================
'RIGHT-CLICK-MENU.BAS
'====================
'Easy to use right click popup menu.
'Coded by Dav JULY/2013
'Here's a single FUNCTION easy to add to your programs to have a right click popup menu.
'Several menu styles to choose from - or set your own custom menu colors (See FUNCTION).
'Menu lets you enable/disble items on the fly and you can also have menu separators.
'Supports many screen sizes, never off screen, and restores original background on exit.
'To use simply add the RightClickMenu% FUNCTION and its defines below to your program.
'Study the demo code below to see how to call and use the function.
'========================================================================================
'================== DEFINES FOR RIGHT CLICK MENU - CHANGE TO SUIT =======================
'========================================================================================
DECLARE FUNCTION RightClickMenu% (menustyle%) ' (not really needed, but it feels good)
DIM SHARED RightClickItems: RightClickItems = 9 ' <----- Number of items in your menu
DIM SHARED RightClickList$(1 TO RightClickItems) ' (change it to your number)
RightClickList$(1) = "New" ' <------------ List all your menu items here
RightClickList$(2) = "Open..."
RightClickList$(3) = "-Save" ' <------------ Leading minus makes these Disabled Items (-)
RightClickList$(4) = "-Save As..."
RightClickList$(5) = "---" ' <------------ This means it's a separator (---)
RightClickList$(6) = "Settings..."
RightClickList$(7) = "About"
RightClickList$(8) = "---" ' <------------ (another separator)
RightClickList$(9) = "Exit"
' menustyle% values: 1 = Old Windows style
' 2 = New Windows style
' 3 = Dark grey Linux
' 4 = Blue Glass (semi-transparent)
' 5 = Custom colors (user defined)
'========================================================================================
'NOTE: menustyle% #5 is for user defined colors. You can set your own custom colors by
' changing the menu variables inside the RightClickMenu% FUNCTION (look in there).
' Then, call RighClickMenu(5) to use your custom colored menu style.
'========================================================================================
'=== draw stuff
FOR x = 25 TO 610 STEP 3
FOR y = 25 TO 300 STEP 3
PSET (x, y), _RGB(RND * 255, RND * 255, RND * 255)
NEXT
NEXT
LOCATE 23, 24: COLOR _RGB(255, 255, 255), _RGB(33, 66, 99)
PRINT "Right Click Anywhere for Popup menu."
LOCATE 25, 30: PRINT "Select EXIT to quit."
LOCATE 27, 24: PRINT "Press 3 to Enable/Disable: Save"
LOCATE 28, 24: PRINT "Press 4 to Enable/Disable: Save As..."
LOCATE 30, 10: PRINT "(keep making selections to cycle through different menu styles)";
style% = 5 'Start with menu style 5
DO
a% = RightClickMenu%(style%) ' <----- Check for rightclick menu
'=== what did you select?
IF a% > 0 THEN
COLOR _RGB(255, 155, 55), _RGB(33, 66, 99)
LOCATE 21, 25: PRINT "You last selected: "; RightClickList$(a%); SPACE$(25);
style% = style% + 1: IF style% = 6 THEN style% = 1 'cycle mnu styles
END IF
'===============================================================================
'NOTE: You can re-enabled a disabled menu item by removing the leading minus '-'
'from it's name. And you can disable an item by adding a leading minus.
'===============================================================================
'=== Here we disable/enable items 3 & 4 on the fly by pressing 3 or 4.
COLOR _RGB(255, 155, 55), _RGB(33, 66, 99)
SELECT CASE INKEY$
CASE IS = "3" ' Toggle Save menu on off
LOCATE 27, 63
IF RightClickList$(3) = "-Save" THEN
RightClickList$(3) = "Save": PRINT "ENABLED ";
ELSE
RightClickList$(3) = "-Save": PRINT "DISABLED";
END IF
CASE IS = "4"
LOCATE 28, 63
IF RightClickList$(4) = "-Save As..." THEN
RightClickList$(4) = "Save As...": PRINT "ENABLED ";
ELSE
RightClickList$(4) = "-Save As...": PRINT "DISABLED";
END IF
END SELECT
LOOP UNTIL a% = 9 'Item 9 (EXIT) exits demo...
END
'========================================================================================
'================================= END DEMO CODE ========================================
'========================================================================================
'========================================================================================
'==================================== FUNCTION ==========================================
'========================================================================================
FUNCTION RightClickMenu% (menustyle%)
'
'Creates a popup menu at the current mouse x/y position when right button is clicked.
'
'This function returns the value of the menu item seleted. If no selection is made,
'then the function will return a value of 0. REQUIRES RightClickList$() array defined.
'
'menustyle% = Number of menu style to use. There are 5, and #5 is a custom color menu.
' You can set custom menu colors by changing the variables in this FUNCTION.
' (look lower down in this function to find those variables noted).
'
'SAMPLE USE: ClickMe% = RightClickMenu%(3) '<--- Use menu 3. If any selection is made,
' the menu item selected is put into
' the ClickMe% variable.
'
' - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Cheese = _MOUSEINPUT ' Check for mouse activity.
IF _MOUSEBUTTON(2) THEN ' If user clicked right button, draw menu....
'============================================================================
'Set Custom menu colors for menustyle% #5 here...
'============================================================================
RCMBorder~& = _RGB(255, 255, 255) ' <--- Border around menu
RCMBack~& = _RGB(0, 0, 255) ' <--- Basic menu background color
'menu item colors
RCMEnText~& = _RGB(255, 255, 255) ' <--- Enabled menu item color
RCMDisText~& = _RGB(190, 190, 190) ' <--- Disabled menu item color
'below is the active row colors
RCMHighBack~& = _RGB(255, 255, 255) ' <--- Highlight background color
RCMHighEnText~& = _RGB(0, 0, 255) ' <--- Highlight Enabled Text color
RCMHighDisText~& = _RGB(190, 190, 190) ' <----Highlight Disabled text color
'============================================================================
'=== fail safes values for failing memories
IF menustyle% < 1 THEN menustyle% = 1
IF menustyle% > 5 THEN menustyle% = 5
'Compute Row & Col for LOCATE, and x & y for drawing
Row = FIX(_MOUSEY / 16): Col = FIX(_MOUSEX / 8)
x = Col * 8 - 8: y = Row * 16 - 16
'=== Compute BoxWidth based on longest menu item string length
BoxWidth = 0
FOR t = 1 TO RightClickItems
temp = LEN(RightClickList$(t))
IF LEFT$(RightClickList$(t), 1) = "-" THEN temp = temp - 1
IF temp > BoxWidth THEN BoxWidth = temp
NEXT: BoxWidth = BoxWidth * 8
'=== Compute BoxHeight based on num of menu items
BoxHeight = RightClickItems * 16
'===== Make sure Mouse not too close to edge of screen
'===== If it is, Adjust position here, move in closer...
IF _MOUSEX < 20 THEN
Col = 3: x = Col * 8 - 8:
END IF
IF _MOUSEX + BoxWidth + 20 > _WIDTH THEN
xm = _WIDTH - (BoxWidth + 10)
Col = FIX(xm / 8): x = Col * 8 - 8:
END IF
IF _MOUSEY < 20 THEN
Row = 2: y = Row * 16 - 16
END IF
IF _MOUSEY + BoxHeight + 20 > _HEIGHT THEN
xy = _HEIGHT - (BoxHeight + 10)
Row = FIX(xy / 16): y = Row * 16 - 16
END IF
FirstRow = Row - 1
'=== copy screen using _mem (thanks Steve!)
DIM m AS _MEM, n AS _MEM
m = _MEMIMAGE(0)
n = _MEMNEW(m.SIZE)
_MEMCOPY m, m.OFFSET, m.SIZE TO n, n.OFFSET
'=== trap until buttons up
DO
nibble = _MOUSEINPUT
LOOP UNTIL NOT _MOUSEBUTTON(2)
SELECT CASE menustyle%
CASE 1: 'Classic menu
'=== Draw Box (10 pix padding)
LINE (x - 10, y - 10)-(x + 10 + BoxWidth, y + 10 + BoxHeight), _RGB(214, 211, 206), BF
LINE (x + 10 + BoxWidth, y - 10)-(x + 10 + BoxWidth, y + 10 + BoxHeight), _RGB(66, 65, 66), B
LINE (x - 10, y + 10 + BoxHeight)-(x + 10 + BoxWidth, y + 10 + BoxHeight), _RGB(66, 65, 66), B
LINE (x - 9, y - 9)-(x + 9 + BoxWidth, y + 9 + BoxHeight), _RGB(255, 255, 255), B
LINE (x - 9, y - 9)-(x + 9 + BoxWidth, y + 9 + BoxHeight), _RGB(255, 255, 255), B
LINE (x + 9 + BoxWidth, y - 9)-(x + 9 + BoxWidth, y + 9 + BoxHeight), _RGB(127, 127, 127), B
LINE (x - 9, y + 9 + BoxHeight)-(x + 9 + BoxWidth, y + 9 + BoxHeight), _RGB(127, 127, 127), B
CASE 2: 'Win7 style
'=== Draw Box (10 pix padding)
LINE (x - 10, y - 10)-(x + 9 + BoxWidth, y + 10 + BoxHeight), _RGB(151, 151, 151), B
LINE (x - 9, y - 9)-(x + 8 + BoxWidth, y + 9 + BoxHeight), _RGB(245, 245, 245), B
LINE (x - 8, y - 8)-(x + 7 + BoxWidth, y + 8 + BoxHeight), _RGB(241, 241, 241), BF
CASE 3: 'Dark Grey Linux style
'=== Draw Box (10 pix padding)
LINE (x - 11, y - 10)-(x + 10 + BoxWidth, y + 10 + BoxHeight), _RGB(85, 85, 85), BF
LINE (x - 9, y - 8)-(x + 8 + BoxWidth, y + 8 + BoxHeight), _RGB(55, 55, 55), BF
CASE 4: 'Transparent style
'=== Draw Box (10 pix padding)
LINE (x - 11, y - 10)-(x + 10 + BoxWidth, y + 10 + BoxHeight), _RGBA32(0, 0, 0, 150), BF
LINE (x - 9, y - 8)-(x + 8 + BoxWidth, y + 8 + BoxHeight), _RGBA32(100, 200, 255, 100), BF
'=== save original printmode
printmodestatus = _PRINTMODE
_PRINTMODE _KEEPBACKGROUND
CASE 5 'custom colors
LINE (x - 11, y - 10)-(x + 10 + BoxWidth, y + 10 + BoxHeight), RCMBorder~&, BF
LINE (x - 9, y - 8)-(x + 8 + BoxWidth, y + 8 + BoxHeight), RCMBack~&, BF
END SELECT
'draw right drop shadow edge
LINE (x + 11 + BoxWidth, y - 4)-(x + 11 + BoxWidth, y + 11 + BoxHeight), _RGBA32(0, 0, 0, 90), B
LINE (x + 12 + BoxWidth, y - 3)-(x + 12 + BoxWidth, y + 12 + BoxHeight), _RGBA32(0, 0, 0, 60), B
LINE (x + 13 + BoxWidth, y - 2)-(x + 13 + BoxWidth, y + 13 + BoxHeight), _RGBA32(0, 0, 0, 40), B
LINE (x + 14 + BoxWidth, y - 1)-(x + 14 + BoxWidth, y + 14 + BoxHeight), _RGBA32(0, 0, 0, 25), B
LINE (x + 15 + BoxWidth, y)-(x + 15 + BoxWidth, y + 15 + BoxHeight), _RGBA32(0, 0, 0, 10), B
'draw bottom drop shadow edge
LINE (x - 4, y + 11 + BoxHeight)-(x + 10 + BoxWidth, y + 11 + BoxHeight), _RGBA32(0, 0, 0, 90), B
LINE (x - 3, y + 12 + BoxHeight)-(x + 11 + BoxWidth, y + 12 + BoxHeight), _RGBA32(0, 0, 0, 60), B
LINE (x - 2, y + 13 + BoxHeight)-(x + 12 + BoxWidth, y + 13 + BoxHeight), _RGBA32(0, 0, 0, 40), B
LINE (x - 1, y + 14 + BoxHeight)-(x + 13 + BoxWidth, y + 14 + BoxHeight), _RGBA32(0, 0, 0, 25), B
LINE (x, y + 15 + BoxHeight)-(x + 14 + BoxWidth, y + 15 + BoxHeight), _RGBA32(0, 0, 0, 10), B
DO
Cheese = _MOUSEINPUT
'=== if in bounds of menu space
IF _MOUSEX > x AND _MOUSEX < x + BoxWidth AND _MOUSEY > y AND _MOUSEY < y + BoxHeight THEN
'=== Draw items
IF CurRow <> FIX(_MOUSEY / 16) THEN
FOR t = 0 TO RightClickItems - 1
IF Row + t - FirstRow = FIX(_MOUSEY / 16) - FirstRow + 1 THEN
'If highlighted row, draw highlight colors...
SELECT CASE menustyle%
CASE 1: COLOR _RGB(255, 255, 255), _RGB(8, 36, 107) 'classic
IF LEFT$(RightClickList$(t + 1), 1) = "-" THEN COLOR _RGB(127, 127, 127), _RGB(8, 36, 107)
CASE 2: COLOR _RGB(0, 0, 0), _RGB(215, 225, 235) 'win7
IF LEFT$(RightClickList$(t + 1), 1) = "-" THEN COLOR _RGB(127, 127, 127), _RGB(215, 225, 235)
CASE 3: COLOR _RGB(50, 50, 50), _RGB(180, 180, 180) 'dark grey linux
IF LEFT$(RightClickList$(t + 1), 1) = "-" THEN COLOR _RGB(127, 127, 127), _RGB(180, 180, 180)
CASE 4: COLOR _RGB(130, 255, 255) 'transparent
IF LEFT$(RightClickList$(t + 1), 1) = "-" THEN COLOR _RGB(127, 127, 127)
CASE 5
COLOR RCMHighEnText~&, RCMHighBack~& 'custom
IF LEFT$(RightClickList$(t + 1), 1) = "-" THEN COLOR RCMHighDisText~&, RCMHighBack~&
END SELECT
ELSE
IF LEFT$(RightClickList$(t + 1), 1) = "-" THEN
SELECT CASE menustyle%
CASE 1: COLOR _RGB(127, 127, 127), _RGB(214, 211, 206) 'classic
CASE 2: COLOR _RGB(127, 127, 127), _RGB(240, 240, 240) 'win7
CASE 3: COLOR _RGB(127, 127, 127), _RGB(55, 55, 55) 'dark grey
CASE 4: COLOR _RGB(127, 127, 127)
CASE 5: COLOR RCMDisText~&, RCMBack~&
END SELECT
ELSE
SELECT CASE menustyle%
CASE 1: COLOR _RGB(0, 0, 0), _RGB(214, 211, 206)
CASE 2: COLOR _RGB(0, 0, 0), _RGB(240, 240, 240)
CASE 3: COLOR _RGB(213, 209, 199), _RGB(55, 55, 55)
CASE 4: COLOR _RGB(200, 200, 200)
CASE 5: COLOR RCMEnText~&, RCMBack~&
END SELECT
END IF
END IF
padme = BoxWidth / 8 - LEN(RightClickList$(t + 1))
IF LEFT$(RightClickList$(t + 1), 1) = "-" THEN padme = padme + 1
IF padme > 0 THEN pad$ = SPACE$(padme) ELSE pad$ = ""
LOCATE Row + t, Col - 1
IF RightClickList$(t + 1) = "---" THEN
SELECT CASE menustyle%
CASE 1: COLOR _RGB(127, 127, 127), _RGB(214, 211, 206)
CASE 2: COLOR _RGB(208, 208, 208), _RGB(240, 240, 240)
CASE 3: COLOR _RGB(127, 127, 127), _RGB(55, 55, 55)
CASE 4: COLOR _RGB(0, 0, 0)
CASE 5: COLOR RCMDisText~&, RCMBack~&
END SELECT
PRINT STRING$((BoxWidth / 8) + 2, 196);
ELSE
IF LEFT$(RightClickList$(t + 1), 1) = "-" THEN
PRINT " "; RIGHT$(RightClickList$(t + 1), LEN(RightClickList$(t + 1)) - 1); pad$; " ";
ELSE
PRINT " "; RightClickList$(t + 1); pad$; " ";
END IF
SELECT CASE menustyle%
CASE 2: 'win7 box around highlight area
'=== Draw box around highlighted
IF Row + t - FirstRow = FIX(_MOUSEY / 16) - FirstRow + 1 THEN
BoxRow = FIX(_MOUSEY / 16): by = BoxRow * 16 - 16
LINE (x - 8, by + 16)-(x + BoxWidth + 7, by + 31), _RGB(174, 207, 247), B
END IF
CASE 3: 'dark grey
'=== Draw box around highlighted
IF Row + t - FirstRow = FIX(_MOUSEY / 16) - FirstRow + 1 THEN
BoxRow = FIX(_MOUSEY / 16): by = BoxRow * 16 - 16
LINE (x - 8, by + 16)-(x + BoxWidth + 7, by + 31), _RGB(240, 240, 240), B
END IF
END SELECT
END IF
NEXT
END IF
'=== left click makes a selection
IF _MOUSEBUTTON(1) THEN
sel = FIX(_MOUSEY / 16) - FirstRow + 1
'only select if not a seperator and not disabled
IF RightClickList$(sel) <> "---" THEN
IF LEFT$(RightClickList$(sel), 1) <> "-" THEN
RightClickMenu% = sel: EXIT DO
END IF
END IF
END IF
'=== right click closes menu
IF _MOUSEBUTTON(2) THEN EXIT DO
ELSE
'=== Draw items
IF FIX(_MOUSEY / 16) <> CurRow THEN
FOR t = 0 TO RightClickItems - 1
padme = BoxWidth / 8 - LEN(RightClickList$(t + 1))
IF LEFT$(RightClickList$(t + 1), 1) = "-" THEN padme = padme + 1
IF padme > 0 THEN pad$ = SPACE$(padme) ELSE pad$ = ""
LOCATE Row + t, Col - 1
IF RightClickList$(t + 1) = "---" THEN
SELECT CASE menustyle%
CASE 1: COLOR _RGB(127, 127, 127), _RGB(214, 211, 206) 'classic
CASE 2: COLOR _RGB(208, 208, 208), _RGB(240, 240, 240) 'win7
CASE 3: COLOR _RGB(127, 127, 127), _RGB(55, 55, 55) 'dark grey
CASE 4: COLOR _RGB(0, 0, 0)
CASE 5: COLOR RCMDisText~&, RCMBack~&
END SELECT
PRINT STRING$((BoxWidth / 8) + 2, 196);
ELSE
IF LEFT$(RightClickList$(t + 1), 1) = "-" THEN
SELECT CASE menustyle%
CASE 1: COLOR _RGB(127, 127, 127), _RGB(214, 211, 206) 'classic
CASE 2: COLOR _RGB(127, 127, 127), _RGB(240, 240, 240) 'win7
CASE 3: COLOR _RGB(127, 127, 127), _RGB(55, 55, 55) 'dark grey
CASE 4: COLOR _RGB(127, 127, 127)
CASE 5: COLOR RCMDisText~&, RCMBack~&
END SELECT
PRINT " "; RIGHT$(RightClickList$(t + 1), LEN(RightClickList$(t + 1)) - 1); pad$; " ";
ELSE
SELECT CASE menustyle%
CASE 1: COLOR _RGB(0, 0, 0), _RGB(214, 211, 206) 'classic
CASE 2: COLOR _RGB(0, 0, 0), _RGB(240, 240, 240) 'win7
CASE 3: COLOR _RGB(213, 209, 199), _RGB(55, 55, 55) 'dark grey
CASE 4: COLOR _RGB(200, 200, 200)
CASE 5: COLOR RCMEnText~&, RCMBack~&
END SELECT
PRINT " "; RightClickList$(t + 1); pad$; " ";
END IF
END IF
NEXT
END IF
IF _MOUSEBUTTON(1) OR _MOUSEBUTTON(2) THEN EXIT DO
END IF
'=== Mark current row mouse is in
CurRow = FIX(_MOUSEY / 16)
LOOP
'=== restore screen
_MEMCOPY n, n.OFFSET, n.SIZE TO m, m.OFFSET
_MEMFREE m: _MEMFREE n
'=== restore original printmode
IF menustyle% = 4 THEN
SELECT CASE printmodestatus
CASE 1: _PRINTMODE _KEEPBACKGROUND
CASE 2: _PRINTMODE _ONLYBACKGROUND
CASE 3: _PRINTMODE _FILLBACKGROUND
END SELECT
END IF
END IF
END FUNCTION
'================================================================================
'================================================================================
Posted by: Dav - 04-29-2022, 02:28 AM - Forum: Dav
- No Replies
PPRINT lets you print with QB64's built-in screen font in various sizes, not just the default size. I use this little SUB often in my programs because it's small, easy to use, and no external FONT files are needed to make large text sizes. It works by turning printed text to images that _PUTIMAGE can use. Steve has made a better text to image program that blows mine away, so be sure to check his out HERE.
This demo just PPRINT's the DATE$ on the screen in various sizes.
- Dav
Code: (Select All)
'==========
'PPRINT.BAS v1.1
'==========
'A SUB that prints larger text sizes using _PUTIMAGE.
'Uses QB64's built-in font, no external FONT needed.
'Coded by Dav, APR/2022
'This demo just prints the DATE$ in various sizes
'=== Set screen mode, and color
SCREEN _NEWIMAGE(600, 600, 32)
'=== draw stuff
FOR x = 1 TO 600 STEP 3
FOR y = 1 TO 600 STEP 3
PSET (x, y), _RGB(RND * 255, RND * 255, RND * 255)
NEXT
NEXT
'pprint date
FOR d = 40 TO 540 STEP 60
size = 20 + RND * 30 'make random sizes
PPRINT 84, d + 4, size, _RGB(1, 1, 1), 0, DATE$ 'this line gives it the shadow
PPRINT 80, d, size, _RGB(RND * 255, RND * 255, RND * 255), 0, DATE$
NEXT
_LIMIT 3 'show 3 pages a second
_DISPLAY 'update display (so it doesn't flicker screen)
LOOP
END
SUB PPRINT (x, y, size, clr&, trans&, text$)
'This sub outputs to the current _DEST set
'It makes trans& the transparent color
'x/y is where to print text
'size is the font size to use
'clr& is the color of your text
'trans& is the background transparent color
'text$ is the string to print
'=== get users current write screen
orig& = _DEST
'=== if you are using an 8 or 32 bit screen
bit = 32: IF _PIXELSIZE(0) = 1 THEN bit = 256
'=== step through your text
FOR t = 0 TO LEN(text$) - 1
'=== make a temp screen to use
pprintimg& = _NEWIMAGE(16, 16, bit)
_DEST pprintimg&
'=== set colors and print text
CLS , trans&: COLOR clr&
PRINT MID$(text$, t + 1, 1);
'== make background color the transprent one
_CLEARCOLOR _RGB(0, 0, 0), pprintimg&
'=== go back to original screen to output
_DEST orig&
'=== set it and forget it
x1 = x + (t * size): x2 = x1 + size
y1 = y: y2 = y + size
_PUTIMAGE (x1 - (size / 2), y1)-(x2, y2 + (size / 3)), pprintimg&
_FREEIMAGE pprintimg&
NEXT
END SUB
FileSelect$ is a simple to use file selector function that you can use to list all files in the current directory and select a filename from that list. This is an updated version that allows user defined colors, so it's fully customizable now. The function pops up a scroll-able box, allows the user to navigate (using the keyboard) and select a file, and it returns that filename as a variable to use. The screen background is preserved. The program below contains an example of using the function. Tested under Windows and Linux.
(Personally I'd recommend Steve's file list routine over this one, but here's mine to play with anyway)
- Dav
Code: (Select All)
'==============
'FILESELECT.BAS v1.2
'==============
'A simple file selector box function.
'Coded by Dav for QB64, APR/2022
'NEW for v1.2: Added user defined colors.
'Works under windows & Linux (havent tested Mac).
'Works in text and graphical screen modes.
'
'Lists files in current directory in a scroll box.
'Use arrows, page up/down, home/end to navigate.
'ENTER selects highlighted filename, ESC cancels.
'Selecting a directory will navigate to that
'directory and list files under it.
'The background screen is preserved and restored.
PRINT
IF a$ <> "" THEN
PRINT "You selected: "; a$
ELSE
PRINT "No file selected."
END IF
END
FUNCTION FileSelect$ (y, x, y2, x2, Filespec$, fsborder&, fsback&, fsfile&, fsdir&, fshigh&)
'==============================================
'FileSelect$ function v1.2 by Dav, APR/2022
'==============================================
'This function returns a selected filename.
'Show files in current directory in a scroll box.
'Use arrows, page up/down, home/end to navigate.
'ENTER selects highlighted filename, ESC cancels.
'Selecting a directory will navigate to that dir
'and list files under that directory.
'The background screen is preserved and restored.
'y,x = top left of box
'y2,x2 = bottom right of box
'Filespec$ = spec of files to list in box ( do "*.*" for all)
'fsborder& = color of box border
'fsback& = background color of file box.
'fsfile& = color of filenames
'fsdir& = color of directories
'fshigh& = color of highlighted line
'=================================================
'=== save original place of cursor
origy = CSRLIN
origx = POS(1)
'=== save colors
fg& = _DEFAULTCOLOR
bg& = _BACKGROUNDCOLOR
'=== Save whole screen
DIM scr1 AS _MEM, scr2 AS _MEM
scr1 = _MEMIMAGE(0): scr2 = _MEMNEW(scr1.SIZE)
_MEMCOPY scr1, scr1.OFFSET, scr1.SIZE TO scr2, scr2.OFFSET
'=== Generate a unique temp filename to use based on date + timer
tmp$ = "_qb64_" + DATE$ + "_" + LTRIM$(STR$(INT(TIMER))) + ".tmp"
IF INSTR(_OS$, "LINUX") THEN tmp$ = "/tmp/" + tmp$
loadagain:
top = 0
selection = 0
'=== list directories
IF INSTR(_OS$, "LINUX") THEN
SHELL _HIDE "find . -maxdepth 1 -type d > " + tmp$
ELSE
SHELL _HIDE "dir /b /A:D > " + tmp$
END IF
'=== make room for names
REDIM FileNames$(10000) 'space for 10000 filenames
'=== only show the ".." when not at root dir
IF LEN(_CWD$) <> 3 THEN
FileNames$(0) = ".."
LineCount = 1
ELSE
LineCount = 0
END IF
'=== Open temp file
FF = FREEFILE
OPEN tmp$ FOR INPUT AS #FF
WHILE ((LineCount < UBOUND(FileNames$)) AND (NOT EOF(FF)))
LINE INPUT #FF, rl$
'=== load, ignoring the . entry added under Linux
IF rl$ <> "." THEN
'also remove the ./ added at the beginning when under linux
IF INSTR(_OS$, "LINUX") THEN
IF LEFT$(rl$, 2) = "./" THEN
rl$ = RIGHT$(rl$, LEN(rl$) - 2)
END IF
END IF
'=== now grab list of files...
IF INSTR(_OS$, "LINUX") THEN
SHELL _HIDE "rm " + tmp$
IF Filespec$ = "*.*" THEN Filespec$ = ""
SHELL _HIDE "find -maxdepth 1 -type f -name '" + Filespec$ + "*' > " + tmp$
ELSE
SHELL _HIDE "del " + tmp$
SHELL _HIDE "dir /b /A:-D " + Filespec$ + " > " + tmp$
END IF
'=== open temp file
FF = FREEFILE
OPEN tmp$ FOR INPUT AS #FF
WHILE ((LineCount < UBOUND(FileNames$)) AND (NOT EOF(FF)))
LINE INPUT #FF, rl$
'=== load, ignoring the generated temp file...
IF rl$ <> tmp$ THEN
'also remove the ./ added at the beginning when under linux
IF INSTR(_OS$, "LINUX") THEN
IF LEFT$(rl$, 2) = "./" THEN
rl$ = RIGHT$(rl$, LEN(rl$) - 2)
END IF
END IF
FileNames$(LineCount) = rl$
LineCount = LineCount + 1
END IF
WEND
CLOSE #FF
'=== Remove the temp file created
IF INSTR(_OS$, "LINUX") THEN
SHELL _HIDE "rm " + tmp$
ELSE
SHELL _HIDE "del " + tmp$
END IF
'=== draw a box
COLOR fsborder&
FOR l = 0 TO y2 + 1
LOCATE y + l, x: PRINT STRING$(x2 + 4, CHR$(219));
NEXT
'=== show current working dir at top
COLOR fsfile&, fsborder&
CurDir$ = _CWD$
'=== Shorten it is too long, for display purposes
IF LEN(CurDir$) > x2 - x THEN
CurDir$ = MID$(CurDir$, 1, x2 - x - 3) + "..."
END IF
LOCATE y, x + 2: PRINT CurDir$;
'=== scroll through list...
DO
FOR l = 0 TO (y2 - 1)
LOCATE (y + 1) + l, (x + 2)
IF l + top = selection THEN
COLOR fsback&, fshigh& 'selected line
ELSE
COLOR fsfile&, fsback& 'regular
'=== directories get a different color...
IF MID$(FileNames$(top + l), 1, 1) = "[" THEN
COLOR fsdir&, fsback&
END IF
END IF
CASE IS = CHR$(0) + CHR$(72) 'Up arrow
IF selection > 0 THEN selection = selection - 1
IF selection < top THEN top = selection
CASE IS = CHR$(0) + CHR$(80) 'Down Arrow
IF selection < (LineCount - 1) THEN selection = selection + 1
IF selection > (top + (y2 - 2)) THEN top = selection - y2 + 1
CASE IS = CHR$(0) + CHR$(73) 'Page up
top = top - y2
selection = selection - y2
IF top < 0 THEN top = 0
IF selection < 0 THEN selection = 0
CASE IS = CHR$(0) + CHR$(81) 'Page Down
top = top + y2
selection = selection + y2
IF top >= LineCount - y2 THEN top = LineCount - y2
IF top < 0 THEN top = 0
IF selection >= LineCount THEN selection = LineCount - 1
CASE IS = CHR$(0) + CHR$(71) 'Home
top = 0: selection = 0
CASE IS = CHR$(0) + CHR$(79) 'End
selection = LineCount - 1
top = selection - y2 + 1
IF top < 0 THEN top = 0
CASE IS = CHR$(27) ' ESC cancels
FileSelect$ = ""
EXIT DO
CASE IS = CHR$(13) 'Enter
'=== if .. then go up one dir
IF RTRIM$(FileNames$(selection)) = ".." THEN
cd$ = _CWD$
IF INSTR(_OS$, "LINUX") THEN
cd$ = LEFT$(cd$, _INSTRREV(cd$, "/"))
ELSE
cd$ = LEFT$(cd$, _INSTRREV(cd$, "\"))
END IF
CHDIR cd$
ERASE FileNames$
GOTO loadagain
END IF
'see if directory
test$ = RTRIM$(FileNames$(selection))
IF LEFT$(test$, 1) = "[" THEN
test$ = MID$(test$, 2, LEN(test$) - 2)
CHDIR test$
ERASE FileNames$
GOTO loadagain
ELSE
IF INSTR(_OS$, "LINUX") THEN
IF RIGHT$(_CWD$, 1) = "/" THEN
C$ = _CWD$
ELSE
C$ = _CWD$ + "/"
END IF
ELSE
IF RIGHT$(_CWD$, 1) = "\" THEN
C$ = _CWD$
ELSE
C$ = _CWD$ + "\"
END IF
END IF
FileSelect$ = C$ + RTRIM$(FileNames$(selection))
EXIT DO
END IF
END SELECT
LOOP
_KEYCLEAR
'=== Restore the whole screen
_MEMCOPY scr2, scr2.OFFSET, scr2.SIZE TO scr1, scr1.OFFSET
_MEMFREE scr1: _MEMFREE scr2
'=== restore original y,x and color
LOCATE origy, origx
![[Image: image.png]](https://i.ibb.co/7SYRmcn/image.png)
