Welcome, Guest |
You have to register before you can post on our site.
|
Latest Threads |
MBA Assignment Help in Du...
Forum: General Discussion
Last Post: hafsahomar
06-11-2025, 07:05 AM
» Replies: 0
» Views: 12
|
лучшие песни медляки слуш...
Forum: Petr
Last Post: WillieTop
06-08-2025, 02:21 AM
» Replies: 0
» Views: 27
|
пинк слушать онлайн беспл...
Forum: SMcNeill
Last Post: WillieTop
06-08-2025, 02:20 AM
» Replies: 0
» Views: 22
|
скачать музыку российскую...
Forum: madscijr
Last Post: WillieTop
06-08-2025, 02:18 AM
» Replies: 0
» Views: 23
|
нежная музыка mp3 скачать
Forum: Keybone
Last Post: WillieTop
06-08-2025, 02:17 AM
» Replies: 0
» Views: 23
|
лучшая песня слушать онла...
Forum: bplus
Last Post: WillieTop
06-08-2025, 02:16 AM
» Replies: 0
» Views: 27
|
пикник слушать онлайн луч...
Forum: Spriggsy
Last Post: WillieTop
06-08-2025, 02:15 AM
» Replies: 0
» Views: 22
|
какая сейчас популярная м...
Forum: RhoSigma
Last Post: WillieTop
06-08-2025, 02:14 AM
» Replies: 0
» Views: 18
|
хит лета 2019 музыка на т...
Forum: Christmas Code
Last Post: WillieTop
06-08-2025, 02:12 AM
» Replies: 0
» Views: 29
|
бесплатная музыка mp3 рег...
Forum: Works in Progress
Last Post: WillieTop
06-08-2025, 02:11 AM
» Replies: 0
» Views: 18
|
|
|
Vince's Corner Takeout |
Posted by: bplus - 04-29-2022, 02:12 PM - Forum: bplus
- Replies (34)
|
 |
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.)
|
|
|
RightClickMenu - Small right click popup menu function |
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.
'========================================================================================
'========================================================================================
'=============================== START DEMO CODE ========================================
'========================================================================================
SCREEN _NEWIMAGE(640, 480, 32)
PAINT (0, 0), _RGB(33, 66, 99)
'=== 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
'================================================================================
'================================================================================
|
|
|
PPRINT - Print larger text on screen using _PUTIMAGE |
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
'=== save background
back& = _COPYIMAGE(_DISPLAY)
'=== cycle DATE$ on screen
DO
CLS , _RGB(32, 32, 32) 'clear
_PUTIMAGE (0, 0), back& 'show background
'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$ - Simple to use file selection function |
Posted by: Dav - 04-28-2022, 10:52 PM - Forum: Dav
- No Replies
|
 |
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.
'=== DEMO FOLLOWS...
SCREEN _NEWIMAGE(700, 500, 32)
_SCREENMOVE _MIDDLE
'=== draw a background
CLS , _RGB(32, 32, 32)
FOR x = 1 TO _WIDTH STEP 3
FOR y = 1 TO _HEIGHT STEP 3
PSET (x, y), _RGB(RND * 255, RND * 255, RND * 255)
NEXT
NEXT
PRINT "Use arrows to navigate to a filename. "
PRINT "Press ENTER to select highlighted file."
PRINT "Press ESC to cancel and close file box."
'=== Define filebox colors here...
fsborder& = _RGB(255, 0, 0) 'filebox order color
fsfile& = _RGB(255, 255, 255) 'filename color
fsdir& = _RGB(255, 255, 64) 'directories color
fsback& = _RGB(64, 0, 0) 'Background color
fshigh& = _RGB(255, 255, 128) 'highlighted line color
'=== Ask user to select a file
a$ = FileSelect$(5, 15, 20, 55, "*.*", fsborder&, fsback&, fsfile&, fsdir&, fshigh&)
'=== Show results...
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
FileNames$(LineCount) = "[" + rl$ + "]"
LineCount = LineCount + 1
END IF
WEND
CLOSE #FF
'=== 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
PRINT LEFT$(FileNames$(top + l) + STRING$(x2, " "), x2);
NEXT
'=== Get user input
k$ = INKEY$
SELECT CASE k$
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
COLOR fg&, bg&
END FUNCTION
|
|
|
Accumulation of many *.exe files |
Posted by: dcromley - 04-28-2022, 03:52 PM - Forum: Help Me!
- Replies (4)
|
 |
I know QBPE is a compiler, which makes it great, but I end up with MANY *.exe files that accumulate that I don't want. Can I choose to have a "temp.exe" for example that would overwrite the previous version?
|
|
|
Math Function Plot |
Posted by: dcromley - 04-28-2022, 03:46 PM - Forum: Programs
- No Replies
|
 |
Working (playing) with the "PSET hat" program, I wanted to see some math functions. So another QB64 program was needed.
I know there are online function plotting and other QBPE programs, but I like simplicity, and I like my own. So here is what I use for plotting functions. Since you have to compile it to put in your functions, I put in comments to document the use of it. I hope it is clear. This version has a variety of functions for demonstration. I reserve the right to edit this to later versions.
Code: (Select All) _Title "FunctionPlot" ' V1.0 dcromley 2022
Option _Explicit
DefSng A-Z: DefInt I-N: DefStr S
Screen _NewImage(1000, 750, 256)
Cls 0, 15: Color 0, 15
Dim Shared ulo, uhi, vlo, vhi, xlo, xhi, ylo, yhi
Dim Shared u, v, x, y, c, nfunc, xold, yold
ulo = 10: uhi = 989: vlo = 739: vhi = 10 ' screen limits
xyinit -8, 8, 1, -6, 6, 1 ' xlo xhi xdel; ylo yhi ydel =#= world limits
' the above line means x from -8 to +8 and grid lines every 1; 0 would be no grid lines
For nfunc = 1 To 9
c = 0 ' default color
For u = ulo To uhi: x = zxu(u) ' x
If nfunc = 1 Then y = 1 - x ^ 2 / 2
If nfunc = 2 Then y = Cos(x)
If nfunc = 3 Then c = 2: y = Sin(x)
If nfunc = 4 Then GoTo continue1 ' skip
If nfunc = 5 Then y = func5(x)
If nfunc = 6 Then y = func6(x, 1)
If nfunc = 7 Then GoTo continue1
If nfunc = 8 Then GoTo continue1
If nfunc = 9 Then GoTo continue1
If u > ulo Then zline xold, yold, x, y, c ' the plot lines
xold = x: yold = y
continue1:
Next u
Next nfunc
zSystem ' end
Function func5 (x) '
If x < 0 Then func5 = 0: Exit Function
c = 1 ' blue
Dim t: t = Sqr(x)
func5 = Sqr(x) ' Sin(t) + .4 * Sin(3 * x)
End Function
Function func6 (x, N) ' 2 options in this function
c = 4 ' red
If N = 1 Then func6 = 8 * (1 / 2 * Cos(x) - 1 / 7 * Cos(3 * x) + 1 / 8 * Cos(5 * x))
If N = 2 Then func6 = 8 * (.5 * Cos(x) - .125 * Cos(3 * x) + .07 * Cos(5 * x))
End Function
Sub xyinit (xxlo, xxhi, xdel, yylo, yyhi, ydel)
xlo = xxlo: xhi = xxhi: ylo = yylo: yhi = yyhi ' save to globals
If xdel > 0 Then ' vertial grid lines
zline 0, ylo, 0, yhi, c ' y axis
For x = xdel To zMax(Abs(xlo), Abs(xhi)) Step xdel ' other
If zBetween(x, xlo, xhi) Then zline x, ylo, x, yhi, 7
If zBetween(-x, xlo, xhi) Then zline -x, ylo, -x, yhi, 7
Next x
End If
If ydel > 0 Then ' horizontal grid lines
zline xlo, 0, xhi, 0, c ' x axis
For y = ydel To zMax(Abs(ylo), Abs(yhi)) Step ydel ' other
If zBetween(y, ylo, yhi) Then zline xlo, y, xhi, y, 7
If zBetween(-y, ylo, yhi) Then zline xlo, -y, xhi, -y, 7
Next y
End If
End Sub
Sub zline (x1, y1, x2, y2, c)
Line (zux(x1), zvy(y1))-(zux(x2), zvy(y2)), c
End Sub
Function zux (x)
zux = zLerplh(ulo, uhi, x, xlo, xhi)
End Function
Function zvy (y)
zvy = zLerplh(vlo, vhi, y, ylo, yhi)
End Function
Function zxu (u)
zxu = zLerplh(xlo, xhi, u, ulo, uhi)
End Function
Function zyv (y)
zyv = zLerplh(ylo, yhi, v, vlo, vhi)
End Function
Function zLerplh (ylo, yhi, x, xlo, xhi)
zLerplh = ylo + (x - xlo) / (xhi - xlo) * (yhi - ylo)
End Function
Function zBetween (x, a, b)
If x >= a And x <= b Then zBetween = 1
End Function
Function zMax (a, b)
If a > b Then zMax = a Else zMax = b
End Function
Function zMin (a, b)
If a < b Then zMin = a Else zMin = b
End Function
Sub zSystem
While InKey$ = "": _Limit 60: Wend
System
End Sub
|
|
|
Who and What is The Phoenix Edition |
Posted by: SMcNeill - 04-28-2022, 02:48 PM - Forum: Announcements
- Replies (9)
|
 |
Since QB64 Phoenix Edition is a newly created offshoot of QB64, people have had various questions about who we are, what we're doing, and what ties we have with QB64 -- and they want to know what's up with our new releases. Let me address those things one at a time for everyone:
Since Fellippe just walked away from the QB64 Team, things turned into a mess almost overnight with the new CEO. Issues arose on the Discord, and I'm not going into any details over those things here as it'd just be rehashing the same old news over and over by now. In the end, QB64 as it existed previously was destroyed. The old team was completely removed from the repo, with all rights to push, pull, merge, or do releases taken from them. The forums were shut down. The wiki was taken offline. QB64 was burnt to the ground.
Until we stepped in. The Phoenix Edition worked hard to get the first editable wiki back up on the internet, from an old off-line that had been preserved, so people could have a working reference for the QB64 commands. We worked to get up a new set of forums so the community could regather and not fragment into a thousand broken pieces. We've worked hard on gathering up and making all the old resources as available to the public as we possibly can, and hosting as much old information on our servers as we can possibly find and share such as the old Podcasts and transcripts from those.
Most importantly, we've cloned the old repo and have been working fairly fervently to update the source to bring QB64 once again up to a stable version. If you look at our repo, we've already had 54 commits pushed into it, showing there's been a LOT of activity by the recent team working on things. We're the new team working hard so that QB64 doesn't die, as the new CEO obviously intended for it to do!
Now, as to who we are, let me reassure the folks that are out there worrying -- we're not some random strangers who just popped up overnight and decided to steal QB64 for our own nefarious gains. I've personally been with QB64 since about version 0.5, and I've been pushing code into the source and developing QB64 for about 10 years now. For the folks who don't believe it (there's always a few naysayers out there), here's a simple test you can use to check the verity of my words: Open the oldest version of QB64.bas that you can find, and simply do a search for "Steve". Almost instantly you'll see multiple places like " '### STEVE EDIT FOR CONST EXPANSION 10/11/2013" in the source.
That goes all the way back and predates the "QB64 Team" by several years!
And I'm not the only member of The Phoenix Edition who has been working and pushing changes into QB64 since about forever!
![[Image: Git-History.png]](https://i.ibb.co/d5mL8Z5/Git-History.png)
As you can see from the above, it's a screenshot taken from the github commit history with Galleon (the original creator of QB64), me, and DSMan all working on pushing changes and enhancements into QB64. DSMan (Matt) is now back and rejoined The Phoenix Edition, and is working to help us restore QB64 back to a fully stable, working version, once again. Just like me, he's been around forever and ever, and he's always been one of the people most welcome to help develop the language.
As for the rest of our team -- Spriggsy, Cobalt, and Maxine, they're a little newer on the QB64 development history than we are, but you'll find their contributions in the old team's source as well. None of us are "new" to QB64, and all of us have deep ties to the old QB64 Team, and we've worked on the language for ages.
So if we were part of the QB64 team, why aren't we now? Why did we migrate over to become "The Phoenix Edition"?
![[Image: image.png]](https://i.ibb.co/rpm4tpH/image.png)
![[Image: image.png]](https://i.ibb.co/6tKVT9P/image.png)
As you can see from the two screenshots above, before RC Cola burned down all the old QB64 content -- the forums, wiki, twitter, youtube, podcasts, and all else he could destroy -- he made a point of kicking and removing everyone from the project. With the old sites and repo no longer available for us, we had to move on to somewhere, and the domain name and such for qb64phoenix.com was available, so why not it? QB64.com as a domain name was for sell for close to $2000. qb64phoenix.com cost $15.00, or so. Since we were trying to rise up out of the ashes that RC Cola had left us in, it seemed like a fitting new name for the project moving forward.
So, why didn't we just stick with the plain old "QB64" that everyone is used to and knew? Several reasons.
First -- to distance ourselves from that drama. QB64 Team was burned to the ground and destroyed by its CEO. Who wants to be associated with such an act, and actor?
Second -- so that people won't think they're supporting us if they donate to the "QB64 Team". If you're sending money to their patreon, buying cups or mugs with the old logo on them, you're not supporting us one bit. Several people have offered to help donate and pay to help get the new project up and going, but that's not neccessary. We're hobbyists, and this is our hobby. We do what we do out of love for the language, and for the fun of expanding upon a language we love, and we don't do it for money. Nobody is earning a cent anywhere to work for us, and help develop the Phoenix Edition. Our overhead costs are just what it costs us to host the server and such, and that's all covered here: Forum Costs and Donations (qb64phoenix.com)
Third -- Even though RC Cola thoroughly kicked and destroyed the old team, he's still the CEO of "Team QB64". Unlike Galleon, who walked away and passed over the reigns to a new team of developers with his blessing, RC Cola left things in as messy of a state as he possibly could. His last post on the patreon ended with:
Quote:We will keep the Github Repo up and if their is enough people wanting to keep it alive please keep developing and we may come back.
...we may come back.
So there you have it! What's the future on that? MAY??
If we were to just pick up and continue to develop under the plain QB64 banner as before, and RC Cola suddenly decides to come back with a new team in the year or two, where would we be left standing? How much confusion would that generate for the public?
"Hey Frank, what version of QB64 did you compile your code under?"
"Version 2.7."
"2.7?? But I'm compiling under version 3.2!"
"OH.. You must have that other QB64..."
No thanks. Not interested in even thinking about that type scenario.
RC Cola hasn't passed on "QB64" to anyone, and in an attempt to prevent any issues before they could ever arise from that, we're calling ourselves "QB64 Phoenix Edition" or "QBPE" for short.
(04-28-2022, 10:16 AM)Coolman Wrote: thank you for your work. is this version based on qb64 2.01?
To address this concern, let me say, "It absolutely is." In fact, our version 0.5 picks directly up from the last version of the QB64 team and builds upon it from there. We're not officially ready to say we're at a version 1.0 (which should tend to state it's a fully stable version), but we're working our way towards that end goal. When we cloned the repo, we chose to continue work off the development branch, rather than the stable branch. We didn't want to lose anyone's contributions to the language since v2.02, as the team was moving closer to a version 2.1 release later this year.
Unfortunately though, some of the people who were developing for v2.1 have walked away from the project for good, like Fellippe. Before we feel confident in saying everything is 100% stable and glitch free, we need some time to go over what those missing developers were attempting to work on and push into the language. We need to hunt down anything that connects to the old site and remove dead links, html calls, and all that good stuff. The QB64 source code has a LOT of lines to sort through, and we're not 100% confident that we've purged all those old, dead, references and such, and we're not 100% certain that all the old works in development are glitch free, so we're not confident about saying we're at version 1.0
IF we'd continued on as just QB64, our version number would probably now be version 2.0.5, but as things stand with the uncertainty about what RC Cola plans to do with the "Team QB64" which he now solely controls, we instead are calling this QB64 Phoenix Edition v0.5.
You can think, in many ways, of "Phoenix Edition" being 2.0, if you like. 
(04-28-2022, 10:44 AM)PhilOfPerth Wrote: Pardon my ignorance, but what's the simplest way to transition from the old tQB64 to the new one? Will I need to move my "home-grown" files, or anything else, into a new directory?
Simplest way is the same as always -- just download and extract the new version from our github. If you have your own files saved in a different directory, just be certain to check the option under "RUN" in the IDE for "Export EXE to source folder", so that your EXE will be placed in the proper folders of your choosing.
Feel free to ask any and all questions and concerns that you guys might have, and I'll be happy to answer them to the best of my ability here for everyone.
|
|
|
|