| Welcome, Guest |
You have to register before you can post on our site.
|
|
|
| DAY 022: CLEAR |
|
Posted by: Pete - 12-03-2022, 12:47 AM - Forum: Keyword of the Day!
- Replies (3)
|
 |
Do you have a clear idea of what the KEYWORD CLEAR does? If not, clear your
schedule while I clear up what CLEAR does in a clear and concise manner. So let's
clear the way and get started with some helpful do's and don't's (Hey, a double apostrophe siting!)
when using CLEAR; clear enough? If not, clear out now...
CLEAR zeros every numeric variable and nullifies every string.
CLEAR zeros the value of all arrays and also removes (de-initializes) the dimension range. All arrays will need to be re-diminsioned.
CLEAR zeros and nullifies all STATIC variables. (Variables that would otherwise retain their values in a sub-routine).
CLEAR cannot be used in a sub routine or function, only in the main.
CLEAR does not affect settings like VIEW PRINT, colors with PALETTE of fonts, window size, or cursor position, etc.
CLEAR does not destroy TYPE structure. It just makes all TYPE variables zero and all TYPE strings null.
For example...
Code: (Select All) CONST pi = 3.14
PALETTE 0, 8 ' Black background to dark blue.
PALETTE 8, 63 ' Gray to bright white text.
DIM pete AS Perfect
TYPE Perfect
s AS STRING
v AS INTEGER
END TYPE
pete.s = "Pete"
COLOR 8, 0
101
PRINT pete.s;
SLEEP
CLEAR: pete.s = " is better than Steve and pi is " + LTRIM$(STR$(pi))
GOTO 101
CLEAR in QuickBasic had 2 parameters that are ignored in QB64. They were used to clear up specified amounts of stack space and memory.
CLEAR does not remove any PCOPY info.
CLEAR does not close any open files.
CLEAR acts a bit different than RUN in certain situations...
Code: (Select All) ' Let's locate and print off-screen and try to redo it. This works with CLEAR but not with RUN.
101
LOCATE 30, 1
PRINT "PRINT "Press a key loop again."
SLEEP
CLEAR
GOTO 101
Try doing that with RUN and it errors out at the LOCATE statement.
Code: (Select All) ' Let's locate and print off-screen and try to redo it. This works with CLEAR but not with RUN.
LOCATE 30, 1
PRINT "PRINT "Press a key loop again."
SLEEP
RUN
So in the first run QB64 acts like QBasic, it adjusts the screen to accommodate the off-screen print location.With CLEAR, it works but with RUN it does not duplicate that initial accommodation.
So here is the most interesting event I've found working with CLEAR over the years, the need to re-initialize a STATIC array.
Code: (Select All) 101
testsub
PRINT: PRINT "Okay, press a key..."
SLEEP
CLS
_DELAY .5
CLEAR
REDIM SHARED testarray(20) '<----------- We must remember to reinitialize our array.
GOTO 101
SUB testsub
STATIC testarray(20)
FOR i = 1 TO 20
testarray(i) = i
PRINT testarray(i): _DELAY .05
NEXT
END SUB
For fun, try that again with the REDIM line REMmed out. It will error out at line 15.
What I think the developers should look at is RUN. RUN should not require we reinitialize anything.
This error out...
Code: (Select All) testsub
PRINT: PRINT "Okay, press a key..."
SLEEP
CLS
_DELAY .5
RUN
SUB testsub
STATIC testarray(20)
FOR i = 1 TO 20
testarray(i) = i
PRINT testarray(i): _DELAY .05
NEXT
END SUB
Now to get that to work would require we once again initialize our array, but this time at the top of the program.
REDIM SHARED testarray(20) ' <----------- Place this at the top of the code above and it will work.
Other differences between CLEAR and RUN are...
RUN can have a line number like RUN 101. CLEAR would need to be written as: CLEAR: GOTO 101
RUN sets the cursor to the top left. CLEAR maintains the current position.
RUN resets the RANDOMIZE sequence to the starting RND function value. (From the wiki). Clear does not reset the RND pattern.
RUN does not preserve the PALETTE or COLOR, but CLEAR does.
RUN does not preserve VIEW PRINT, but CLEAR does.
RUN and CLEAR both preserve PCOPY memory.
In general it is better practice to keep a list of all your variables and "clear" the ones you need cleared, but CLEAR
is a quick way of obtaining the same results when all your variables need to be cleared.
Another advantage of CLEAR over RUN is you can insert program control flow variables after the CLEAR statement.
Code: (Select All) PRINT "What is my route? ": PRINT
101
SELECT CASE myroute
CASE 0
PRINT "Route 1"
CASE 1
PRINT "Route 2"
END SELECT
SLEEP
CLEAR: myroute = 1
GOTO 101
Finally RUN can be used in a SUB or FUNCTION, but CLEAR cannot. This is considered bad practice, because it creates a stack leak, which in time with excessive use will cause your program to crash.
Pete
|
|
|
| SHOWDRAW |
|
Posted by: James D Jarvis - 12-02-2022, 02:24 PM - Forum: Utilities
- Replies (2)
|
 |
I enjoy "drawing" in text mode but it can be a pain juggling the print commands. I've posted and developed all sorts of complicated schemes for doing just that and I realized it is fairly simple to use ANY QB graphics commands to draw on a text screen. All one has to do is draw to an image buffer (which is a 32 bit image) with any standard graphics command, scan that and convert it to text "graphics".
Here's one way to do that:
Code: (Select All) '---------------------------------------------------
'show draw header
'---------------------------------------------------
Dim Shared dspace& 'this is the drawing space/canvas that allows mixed mode graphics routines to function
Dim Shared ts& 'the text screen
Dim Shared stwd, stht
stwd = 80: stht = 40 'resize as you wish, on my monitor 2pixels wide per 1 vertical looks decent
ts& = _NewImage(stwd, stht, 0)
dspace& = _NewImage(stwd + 1, stht + 1, 32)
Screen ts&
_FullScreen
'-------------------------------------
'demo code
'-------------------------------------
Print "Plain old text screen set to 80 characters wide by 40 characters high."
Input "Enter a your name"; uname$
_Dest dspace& 'set the destination so graphics commands will be drawn into space&
Line (1, 1)-(stwd, stht), _RGB32(3, 176, 7), BF
Color _RGB32(15, 48, 0)
_PrintString (1, 1), "GIANT TEXT"
Circle (15, 15), 8, _RGB32(8, 72, 0)
Line (2, 2)-(20, 20), _RGB32(31, 176, 15), B
Color _RGB32(15, 48, 0)
_Dest ts& 'set the screen to the text screen
showdraw 1, 1, stwd, stht 'show dspace on the textscreen rendered in characters
Color 15, 0 'change the color it may be changed in showdraw
_Delay 1
Print "WELL WELL WELL"
_Delay 1
Cls
Print "WELL WELL WELL... you can use any standard graphics command."
Print
For cx = -5 To 90
Print "An animated circle, on a text screem."
_Limit 24
_Dest dspace& 'rember to set the destination to dspace& before you call showdraw
Line (1, 1)-(stwd, stht), _RGB32(8, 177, 7), BF
For bl = -20 To 80 Step 5
Line (bl, 1)-(bl + 6, stht), _RGB32(12, Asc("*"), 2)
Next bl
Circle (cx, 21), 5, _RGB32(15, 219, 0)
showdraw 1, 1, stwd, stht 'showdraw always writes to ts& so you don't have to change destination manually
Next cx
_Dest dspace& 'writitng to dspace& again
Color _RGB32(15, 219, 0) 'use color _RGB32( FOREGROUND_COLOR, DRAWN_CHARACTER, background_color) before printing to dspace&
_PrintString (1, 1), uname$
showdraw 1, 1, stwd, stht
Color 15, 0 'restoring to text mode colors white and black for foreground and background
Locate 1, 1: Print "BYE"
_Delay 1
'-----------------------------------------
'SHOWDRAW
'copies the image from the drawing space onto the text screen
'each pixel in dspace& will hold the text screen character and colors
'-----------------------------------------
Sub showdraw (xa, ya, xb, yb)
Dim tk As _Unsigned Long
'render from xa,ya to xb,yb from dspace& to the ts&
x1 = xa: x2 = xb: y1 = ya: y2 = yb
If x1 < 1 Then x1 = 1
If y1 < 1 Then x1 = 1
If y2 > stht Then y2 = stht
If x2 > stwd Then x2 = stwd
For x = x1 To x2
For y = y1 To y2
_Source dspace&
tk = Point(x, y)
Locate 1, 1
tc = _Red32(tk) 'the red color channel is foreground color for the text screen
ac = _Green32(tk) 'the green color channel is the ascii character to be drawn to the text screen
bc = _Blue32(tk) 'the blue color background color for the text screen
If tc > 0 Then
_Dest ts&
Color tc, bc
_PrintString (x, y), Chr$(ac)
End If
Next y
Next x
_Source ts&
End Sub
|
|
|
|
| DAY 021: LOCATE |
|
Posted by: Pete - 12-02-2022, 04:50 AM - Forum: Keyword of the Day!
- Replies (2)
|
|
Since I'd rather code than write, I decided to present the KEYWORD of the Day, LOCATE in a brief demo. Reading the code window is also an easy option to obtain the various descriptions.
Just press a key during a pause to move on...
Code: (Select All) ' LOCATE Demo
WIDTH 100, 42
_SCREENMOVE 50, 50
'-------------------------------------------------------------------------------------------------------------
PRINT "Locate is used in text screens to locate the cursor by row and column."
PRINT: PRINT "Let's print a message at the 5th row and 2nd column of this window..."
SLEEP
LOCATE 5, 2: PRINT "Hello World!"
SLEEP
PRINT: PRINT "Locate can be used to center text. Let's center our message horizontally..."
SLEEP
msg$ = "Hello World!"
COLOR 14
LOCATE 9, _WIDTH \ 2 - LEN(msg$) \ 2: PRINT msg$
COLOR 7
PRINT: PRINT "CSRLIN denotes the current row and POS(0) for current column...";
SLEEP
LOCATE CSRLIN, POS(0): PRINT " See?..."
SLEEP
PRINT: PRINT "Just be sure you add a semi-colon to the end of your text to stay at the end of the print line."
SLEEP 6: _KEYCLEAR
PRINT: PRINT "If you are already on the row you want, you can also just leave the 1st parameter blank...";
SLEEP
LOCATE , POS(0): PRINT " See?..."
SLEEP
PRINT: PRINT "You can show or hide the cursor, too..."
SLEEP
LOCATE , , 1
PRINT: PRINT "LOCATE , , 1 where our 3rd parameter '1' means let's show the default cursor...";
SLEEP
LOCATE , POS(0), 1
PRINT: PRINT: PRINT "The two last parameters change the cursor shape: cursorStart%, cursorStop%...";
SLEEP 6
PRINT: PRINT: PRINT "The start and end parameters range from 0 to 30. Press to see a medium cursor...";
SLEEP
LOCATE , POS(0), 1, 7, 30
PRINT: PRINT: PRINT "Now press again for a thick cursor...";
SLEEP
LOCATE , POS(0), 1, 0, 30
PRINT: PRINT: PRINT "Note that '7, 7' is the default cursor and 0, 30 is full.";
SLEEP 3
PRINT: PRINT: PRINT "We can hide the cursor with '0' as the 3rd parameter. Press a key to hide it now...";
SLEEP
LOCATE , , 0
SLEEP 3: _KEYCLEAR
LOCATE , , 1
PRINT: PRINT: PRINT "And bring it back again with "; 1; " to its last state LOCATE , , 1, 0, 30...";
SLEEP
LOCATE , , 0
PRINT: PRINT: PRINT "LOCATE also has the ability to print to the last row on a VIEW PRINT restricted screen..."
VIEW PRINT 1 TO 20
SLEEP
LOCATE _HEIGHT, _WIDTH \ 2 - LEN(msg$) \ 2: PRINT msg$;
SLEEP
VIEW PRINT: CLS
PRINT "Finally we need to note some behavior that could screw up your printing.";
SLEEP 4
PRINT: PRINT: PRINT "LOCATE may wrap some text but mostly prints an entire text line to next line...";
LOCATE , , 1, 0, 30
SLEEP
LOCATE , , 0 ' Hide cursor.
PRINT "See? I'm on the next line this time."
SLEEP 6
PRINT: PRINT "This next demo will show what happens when printing an '*' to the last row and column..."
SLEEP
WIDTH 80, 25
CLS
LOCATE 15, 1: PRINT "HEIGHT ="; _HEIGHT, "WIDTH ="; _WIDTH
PRINT: PRINT "Printing an '*' to the right bottom corner with a semi colon works,"
PRINT: PRINT "but look where the next cursor row is."
LOCATE _HEIGHT, _WIDTH
COLOR 14 + 16: PRINT "*";: COLOR 7
y = CSRLIN: x = POS(0)
LOCATE 17: PRINT "Current cursor row is"; y; "instead of"; y + 1; "and the"
PRINT: PRINT "cursor column is"; x; "as expected."
SLEEP
LOCATE y, 1: PRINT "Here's where the next line of text will appear if you don't code a solution."
PRINT: PRINT "See? it's above the asterisk!...";
SLEEP
CLS
PRINT: PRINT "Our final demo will show how to overcome this restriction"
PRINT: PRINT "When trying to fill the screen..."
SLEEP
CLS
a$ = STRING$(_WIDTH, "*")
FOR i = 1 TO _HEIGHT
PRINT a$;
NEXT
SLEEP
CLS
PRINT "Well that didn't work. The last row was empty because the screen scrolled."
PRINT: PRINT "Hmm, let's use LOCATE to fix that..."
SLEEP
CLS
a$ = STRING$(_WIDTH, "*")
FOR i = 1 TO _HEIGHT
LOCATE i, 1 ' <---------------------------Fixes scrolling issue.
PRINT a$;
NEXT
SLEEP
CLS
PRINT "Yep, that worked..."
_DELAY 1
msg$ = "That concludes this portion of our KEYWORD for the Day!"
LOCATE _HEIGHT \ 2, _WIDTH \ 2 - LEN(msg$) \ 2: PRINT msg$
END
Now naturally I did this for SCREEN 0. If anyone wants to elaborate on the use of LOCATE in a graphics environment, feel free.
Pete
|
|
|
|
| Buttons and Boxes |
|
Posted by: James D Jarvis - 12-01-2022, 07:13 PM - Forum: Works in Progress
- No Replies
|
|
A simple control and display scheme for text mode. Currently only supports one active dialog at a time.
Has a number of built-in styles.
Use the mouse or the up and down arrow keys to make a selection.
Code: (Select All) 'Buttons_N_Boxes
'by James D. Jarvis, December 2022
'this demo shows a couple subroutines for simple text boxes and selection boxes in text mode
'if you can read this code and have QB64 you are of course perfectly welcome to use it as you wish.
'
'currently supports just one active button dialog ( Button box) at a time.
'$dynamic
Screen _NewImage(80, 30, 0)
_Title "Buttons and Boxes"
'------------------------------------------------------
'header must be included to use these subroutines
'------------------------------------------------------
Dim Shared bchar$(15, 9)
buildbchar
'------------------------------------------------------
'demo code
'------------------------------------------------------
Randomize Timer
Dim bb$(7)
Dim ob$(1)
bb$(1) = "One": bb$(2) = "Two": bb$(3) = "Three": bb$(4) = "Four"
bb$(5) = "Five": bb$(6) = "Six": bb$(7) = "Seven"
demotext$ = "Please make a selection."
bpick = buttonbox(11, 2, 60, 10, 5, bb$(), demotext$)
Locate 1, 1
If bpick > 0 Then
mtext$ = "You selected button " + bb$(bpick)
Else
mtext$ = "No option selected"
End If
Cls
ob$(1) = "OKAY"
bpick = buttonbox(3, 3, 32, 5, 1, ob$(), mtext$)
ReDim bb$(2)
bb$(1) = "YES": bb$(2) = "QUIT"
bpick = buttonbox(5, 4, 32, 5, 1, bb$(), "Want to see a bunch of Printboxes?")
If bpick = 1 Then
Cls
demotext$ = "The quick brown fox took a ride on the cow as it jumped over the moon and the owl found out how many licks it took to get to the center of a tootsie pop."
Randomize Timer
For n = 1 To 30
boxX = Int(1 + Rnd * 60): boxY = Int(1 + Rnd * 20)
boxW = Int(12 + Rnd * 30): boxH = Int(3 + Rnd * 9)
bstyle = Int(1 + Rnd * 15)
bklr = Int(Rnd * 16) - 8: If bklr < 0 Then bklr = 0
Do
fklr = Int(Rnd * 20): If fklr > 15 Then fklr = 15
Loop Until fklr <> bklr
Color fklr, bklr
printbox boxX, boxY, boxW, boxH, bstyle, demotext$
_Delay 0.5
Next n
Color 15, 0
printbox 11, 8, 60, 4, 1, "That's it, a nice simple demonstration of PRINTBOX"
printbox 11, 12, 60, 4, 5, "Text is clipped to fit the printbox. While text will wrap within the box any extra characters will be lost."
ob$(1) = "QUIT"
dummy = buttonbox(11, 16, 60, 3, 7, ob$(), "BYE")
End If
System
'------------------------------------------------------
' Printbox draws a fixed text box for a text mode screem
' there are 15 styles programmed into this.
' Each is defined by a string array where corners, top and sides are defined in bchar$
'
'text will wrap inside the print box butwill not printoutside the printbox, that would be another subroutine
'the box may screen wrap the text will not.
'------------------------------------------------------
Sub printbox (bx, by, ww, hh, bb, txt$)
topbar$ = bchar$(bb, 1) + String$(ww - 2, Asc(bchar$(bb, 2))) + bchar$(bb, 3)
midbar$ = bchar$(bb, 4) + String$(ww - 2, Asc(bchar$(bb, 5))) + bchar$(bb, 6)
btmbar$ = bchar$(bb, 7) + String$(ww - 2, Asc(bchar$(bb, 8))) + bchar$(bb, 9)
_PrintString (bx, by), topbar$
For r = 1 To hh - 2: _PrintString (bx, by + r), midbar$: Next r
_PrintString (bx, by + hh - 1), btmbar$
ml = Len(txt$)
If ml < ww - 2 Then
cx = bx + ww / 2 - ml \ 2
_PrintString (cx, by + 1), txt$
Else
cx = bx + 2
cy = by + 1
For c = 1 To ml
If cy < _Height - 1 And cx < _Width - 1 Then
If cy < (by + hh - 1) Then _PrintString (cx, cy), Mid$(txt$, c, 1)
End If
cx = cx + 1
If cx > bx + ww - 3 Or cx > _Width - 1 Then
cx = bx + 2
cy = cy + 1
End If
Next c
End If
End Sub
Sub buildbchar
bchar$(1, 1) = Chr$(219): bchar$(1, 2) = Chr$(223): bchar$(1, 3) = Chr$(219)
bchar$(1, 4) = Chr$(219): bchar$(1, 5) = Chr$(32): bchar$(1, 6) = Chr$(219)
bchar$(1, 7) = Chr$(219): bchar$(1, 8) = Chr$(220): bchar$(1, 9) = Chr$(219)
bchar$(2, 1) = Chr$(178): bchar$(2, 2) = Chr$(178): bchar$(2, 3) = Chr$(178)
bchar$(2, 4) = Chr$(178): bchar$(2, 5) = Chr$(32): bchar$(2, 6) = Chr$(178)
bchar$(2, 7) = Chr$(178): bchar$(2, 8) = Chr$(178): bchar$(2, 9) = Chr$(178)
bchar$(3, 1) = Chr$(177): bchar$(3, 2) = Chr$(177): bchar$(3, 3) = Chr$(177)
bchar$(3, 4) = Chr$(177): bchar$(3, 5) = Chr$(32): bchar$(3, 6) = Chr$(177)
bchar$(3, 7) = Chr$(177): bchar$(3, 8) = Chr$(177): bchar$(3, 9) = Chr$(177)
bchar$(4, 1) = Chr$(176): bchar$(4, 2) = Chr$(176): bchar$(4, 3) = Chr$(176)
bchar$(4, 4) = Chr$(176): bchar$(4, 5) = Chr$(32): bchar$(4, 6) = Chr$(176)
bchar$(4, 7) = Chr$(176): bchar$(4, 8) = Chr$(176): bchar$(4, 9) = Chr$(176)
bchar$(5, 1) = Chr$(218): bchar$(5, 2) = Chr$(196): bchar$(5, 3) = Chr$(191)
bchar$(5, 4) = Chr$(179): bchar$(5, 5) = Chr$(32): bchar$(5, 6) = Chr$(179)
bchar$(5, 7) = Chr$(192): bchar$(5, 8) = Chr$(196): bchar$(5, 9) = Chr$(217)
bchar$(6, 1) = Chr$(213): bchar$(6, 2) = Chr$(205): bchar$(6, 3) = Chr$(184)
bchar$(6, 4) = Chr$(179): bchar$(6, 5) = Chr$(32): bchar$(6, 6) = Chr$(179)
bchar$(6, 7) = Chr$(212): bchar$(6, 8) = Chr$(205): bchar$(6, 9) = Chr$(190)
bchar$(7, 1) = Chr$(201): bchar$(7, 2) = Chr$(205): bchar$(7, 3) = Chr$(187)
bchar$(7, 4) = Chr$(186): bchar$(7, 5) = Chr$(32): bchar$(7, 6) = Chr$(186)
bchar$(7, 7) = Chr$(200): bchar$(7, 8) = Chr$(205): bchar$(7, 9) = Chr$(188)
bchar$(8, 1) = Chr$(219): bchar$(8, 2) = Chr$(196): bchar$(8, 3) = Chr$(219)
bchar$(8, 4) = Chr$(179): bchar$(8, 5) = Chr$(32): bchar$(8, 6) = Chr$(179)
bchar$(8, 7) = Chr$(219): bchar$(8, 8) = Chr$(196): bchar$(8, 9) = Chr$(219)
bchar$(9, 1) = Chr$(219): bchar$(9, 2) = Chr$(42): bchar$(9, 3) = Chr$(219)
bchar$(9, 4) = Chr$(42): bchar$(9, 5) = Chr$(32): bchar$(9, 6) = Chr$(42)
bchar$(9, 7) = Chr$(219): bchar$(9, 8) = Chr$(42): bchar$(9, 9) = Chr$(219)
bchar$(10, 1) = Chr$(42): bchar$(10, 2) = Chr$(42): bchar$(10, 3) = Chr$(42)
bchar$(10, 4) = Chr$(42): bchar$(10, 5) = Chr$(32): bchar$(10, 6) = Chr$(42)
bchar$(10, 7) = Chr$(42): bchar$(10, 8) = Chr$(42): bchar$(10, 9) = Chr$(42)
bchar$(11, 1) = Chr$(240): bchar$(11, 2) = Chr$(240): bchar$(11, 3) = Chr$(240)
bchar$(11, 4) = Chr$(240): bchar$(11, 5) = Chr$(32): bchar$(11, 6) = Chr$(240)
bchar$(11, 7) = Chr$(240): bchar$(11, 8) = Chr$(240): bchar$(11, 9) = Chr$(240)
bchar$(12, 1) = Chr$(240): bchar$(12, 2) = Chr$(240): bchar$(12, 3) = Chr$(240)
bchar$(12, 4) = Chr$(32): bchar$(12, 5) = Chr$(32): bchar$(12, 6) = Chr$(32)
bchar$(12, 7) = Chr$(240): bchar$(12, 8) = Chr$(240): bchar$(12, 9) = Chr$(240)
bchar$(13, 1) = Chr$(240): bchar$(13, 2) = Chr$(240): bchar$(13, 3) = Chr$(240)
bchar$(13, 4) = Chr$(46): bchar$(13, 5) = Chr$(46): bchar$(13, 6) = Chr$(46)
bchar$(13, 7) = Chr$(240): bchar$(13, 8) = Chr$(240): bchar$(13, 9) = Chr$(240)
bchar$(14, 1) = Chr$(46): bchar$(14, 2) = Chr$(46): bchar$(14, 3) = Chr$(46)
bchar$(14, 4) = Chr$(46): bchar$(14, 5) = Chr$(46): bchar$(14, 6) = Chr$(46)
bchar$(14, 7) = Chr$(46): bchar$(14, 8) = Chr$(46): bchar$(14, 9) = Chr$(46)
bchar$(15, 1) = Chr$(176): bchar$(15, 2) = Chr$(176): bchar$(15, 3) = Chr$(176)
bchar$(15, 4) = Chr$(176): bchar$(15, 5) = Chr$(176): bchar$(15, 6) = Chr$(176)
bchar$(15, 7) = Chr$(176): bchar$(15, 8) = Chr$(176): bchar$(15, 9) = Chr$(176)
End Sub
'-----------------------------------------------------------
'Button box
'uses pritnbox to display a an array of bottons passed in the array btn$()
'the id number of the button selected is returned
'if <esc> is used bypass the selection a value of 0 is returned.
'make selection with a mouse or using the up and down arrow keys with <return>
'-----------------------------------------------------------
Function buttonbox (bx, by, ww, hh, bb, btn$(), txt$)
bi& = _NewImage(_Width + 1, _Height + 1, 256)
ds& = _Dest
bcount = UBound(btn$)
fk = _DefaultColor
thh = hh
tnh = Len(txt$) / (ww - 3)
If tnh < 1 Then tnh = 1
bby = by + tnh + 2
If thh < bby + bcount * 3 Then thh = tnh + bcount * 3 + 4
printbox bx, by, ww, thh, bb, txt$
For b = 1 To bcount
printbox bx + 2, bby, ww - 4, 3, bb, btn$(b)
_Dest bi&
Line (bx + 2, bby)-(bx + ww - 4, bby + 2), b, BF
_Dest ds&
bby = bby + 3
Next b
bselect = 0
Do
_Limit 60
bkk = _KeyHit
Select Case bkk
Case -18432 'up
If bselect > 0 Then
btpy = by + tnh + 2 + (bselect - 1) * 3
printbox bx + 2, btpy, ww - 4, 3, bb, btn$(bselect)
End If
bselect = bselect - 1
If bselect < 1 Then bselect = bcount
btpy = by + tnh + 2 + (bselect - 1) * 3
Color fk + 16
printbox bx + 2, btpy, ww - 4, 3, bb, btn$(bselect)
Color fk
Case -20480 'down
If bselect > 0 Then
btpy = by + tnh + 2 + (bselect - 1) * 3
printbox bx + 2, btpy, ww - 4, 3, bb, btn$(bselect)
End If
bselect = bselect + 1
If bselect > bcount Then bselect = 1
btpy = by + tnh + 2 + (bselect - 1) * 3
fk = _DefaultColor
Color fk + 16
printbox bx + 2, btpy, ww - 4, 3, bb, btn$(bselect)
Color fk
End Select
lasto = 0
Do While _MouseInput
_Source bi&
pbx = _MouseX
pby = _MouseY
optt = Point(pbx, pby)
If optt > 0 And bptt < bcount + 1 Then
If lasto <> optt And lasto > 0 Then
Color fk
printbox bx + 2, btpy, ww - 4, 3, bb, btn$(lasto)
End If
If bselect > 0 Then
btpy = by + tnh + 2 + (bselect - 1) * 3
Color fk
printbox bx + 2, btpy, ww - 4, 3, bb, btn$(bselect)
End If
Color fk + 16
btpy = by + tnh + 2 + (optt - 1) * 3
printbox bx + 2, btpy, ww - 4, 3, bb, btn$(optt)
Color fk
lasto = optt
If optt > 0 Then bselect = optt
End If
If _MouseButton(1) Then
Do
_Limit 60
i = _MouseInput
Loop Until Not _MouseButton(1)
pbx = _MouseX
pby = _MouseY
bptt = Point(pbx, pby)
Locate 1, 4: Print bptt
End If
If bptt > 0 And bptt < bcount + 1 Then
btpy = by + tnh + 2 + (bptt - 1) * 3
printbox bx + 2, btpy, ww - 4, 3, bb, btn$(bptt)
bselect = bptt
btpy = by + tnh + 2 + (bselect - 1) * 3
fk = _DefaultColor
Color fk + 16
printbox bx + 2, btpy, ww - 4, 3, bb, btn$(bselect)
Color fk
_Delay 0.05
bkk = -13
GoTo mdone
End If
Loop
mdone:
Loop Until bkk = -27 Or bkk = -13
Locate 2, 2: Print bselect
_Dest ds&
_Source ds&
_FreeImage bi&
buttonbox = bselect
End Function
|
|
|
|
| You never CALL |
|
Posted by: Pete - 12-01-2022, 04:37 PM - Forum: General Discussion
- Replies (13)
|
|
So when it comes to subs and functions, which convention do you employ?
CALL MySub(Parameters)
or...
MySub Paramenters
Certainly the later is less typing. It also looks neater. That stated, I almost always write apps with 20 to 30 sub routines and maybe 40+ calls. For the simple reason of ease of search, I use the CALL convention. F3, type "CALL" and check match case and whole word. Easy peasy.
I have a feeling I'm going to be in the minority on this one, but let's find out.
So which convention do you prefer?
Pete
- You can CALL me Betty, and Betty when you CALL me you can CALL me Al, CALL me Al...
|
|
|
|
| Custom Popup Window for Windows OS |
|
Posted by: Pete - 12-01-2022, 11:02 AM - Forum: Works in Progress
- No Replies
|
|
This program required Win32 API calls, so it will only run on a Windows system.
Custom window in that the code generates a small borderless window text window and adds a custom menu plus drag to move and drag to resize features. It does NOT use the QB64 RESIZE commands but does make use of the mouse cursor appearance changes. Thanks a ton to the dev who provided that neat QB64 mouse feature.
The top pseudo-title bar is functional. The three horizontal lines represent a pop-open menu. Click to open. The menu options are mostly for demo only, but close and quit do work. The symbols from top left to right are "-" Minimize, [] Fullscreen, and "X" Close.
Code: (Select All) DIM SHARED WinMse AS POINTAPI
TYPE POINTAPI
X_Pos AS LONG
Y_Pos AS LONG
END TYPE
DECLARE DYNAMIC LIBRARY "User32"
FUNCTION GetWindowLongA& (BYVAL hwnd AS LONG, BYVAL nIndex AS LONG)
FUNCTION SetWindowLongA& (BYVAL hwnd AS LONG, BYVAL nIndex AS LONG, BYVAL dwNewLong AS LONG)
FUNCTION SetWindowPos& (BYVAL hwnd AS LONG, BYVAL hWndInsertAfter AS LONG, BYVAL x AS LONG, BYVAL y AS LONG, BYVAL cx AS LONG, BYVAL cy AS LONG, BYVAL wFlags AS LONG)
FUNCTION ShowWindow& (BYVAL hwnd AS LONG, BYVAL nCmdShow AS LONG)
FUNCTION GetAsyncKeyState% (BYVAL vkey AS LONG)
FUNCTION GetCursorPos (lpPoint AS POINTAPI)
FUNCTION SetCursorPos% (BYVAL x AS INTEGER, BYVAL y AS INTEGER)
END DECLARE
TYPE Win_Control
X_IN AS INTEGER
Y_IN AS INTEGER
oldxIN AS INTEGER
oldyIN AS INTEGER
my AS INTEGER
mx AS INTEGER
lb AS INTEGER
tbicon AS INTEGER
wintp AS INTEGER
winrt AS INTEGER
winbt AS INTEGER
winlt AS INTEGER
setxy AS INTEGER
sizeit AS INTEGER
x AS INTEGER
y AS INTEGER
fw AS INTEGER
fh AS INTEGER
w AS INTEGER
h AS INTEGER
dragx AS INTEGER
dragy AS INTEGER
S_orig AS LONG
tmp AS STRING
END TYPE
DIM WinCon AS Win_Control
DIM SHARED hWnd AS LONG
WinCon.S_orig = _NEWIMAGE(50, 25, 0) ' SCREEN 0 with _NEWIMAGE.
SCREEN WinCon.S_orig
DO: LOOP UNTIL _SCREENEXISTS
CALL borderless_window
CALL sam_titlebar
CALL borderless_variables(WinCon)
DO ' Main Loop ====================================================================================
_LIMIT 60
CALL mouse_borderless(1, WinCon)
CALL mouse_borderless(2, WinCon)
CALL titlebar_icons(WinCon)
CALL size_n_drag(WinCon, side$)
CALL mouse_borderless(3, WinCon)
IF LEN(INKEY$) THEN SYSTEM
LOOP '=============================================================================================
SUB sam_titlebar
PALETTE 5, 63 ' Bright white.
PALETTE 6, 8 ' Dark blue.
LOCATE 1, 1
COLOR 0, 5
PRINT SPACE$(_WIDTH);
LOCATE 1, 2: PRINT CHR$(240);
LOCATE , 4: PRINT "Menu";
msg$ = "Sam-Clip"
LOCATE , _WIDTH / 2 - LEN(msg$) / 2 + 1: PRINT msg$;
LOCATE , _WIDTH - 7: PRINT "Ä þ X";
COLOR 15, 6
VIEW PRINT 2 TO _HEIGHT
CLS 2
VIEW PRINT
END SUB
SUB sam_menu ' Self-contained subroutine.
y = CSRLIN: x = POS(0)
LOCATE , , 0 ' Hide cursor
DIM atmp AS STRING
noi = 6 ' Number of menu items
REDIM menu$(noi)
menu$(1) = "Open"
menu$(2) = "Settings"
menu$(3) = "Recycled"
menu$(4) = "Help"
menu$(5) = "Close"
menu$(6) = "Quit"
h = 5 ' Variable to determine margin spaces from the right of menu.
FOR i = 1 TO noi
j = LEN(menu$(i))
IF j > k THEN k = j
NEXT
mwidth = k + h
mheight = noi * 2 + 1 ' Add one for the separate border element.
MenuT = 1: MenuL = 1: MenuR = MenuL + mwidth: MenuB = MenuT + mheight
DO
_LIMIT 30
z = GetCursorPos(WinMse)
SELECT CASE menu.var
CASE -1
WHILE _MOUSEINPUT: WEND
my = _MOUSEY
mx = _MOUSEX
IF my > MenuT AND my < MenuB AND mx > MenuL AND mx < MenuR THEN
IF my \ 2 = my / 2 AND my AND my <> oldmy THEN
IF MenuHL THEN
atmp = SPACE$(mwidth - 2)
LOCATE MenuHL, MenuL + 2 - 1
COLOR 0, 7
MID$(atmp, 2, LEN(menu$((MenuHL - MenuT) \ 2 + 1))) = menu$((MenuHL - MenuT) \ 2 + 1)
PRINT atmp;
END IF
atmp = SPACE$(mwidth - 2)
LOCATE my, MenuL + 2 - 1
COLOR 7, 0
MID$(atmp, 2, LEN(menu$((my - MenuT) \ 2 + 1))) = menu$((my - MenuT) \ 2 + 1)
PRINT atmp;
COLOR 0, 7
MenuHL = my
END IF
IF _MOUSEBUTTON(1) THEN
menu.var = (my - MenuT) \ 2 + 1
EXIT DO
END IF
ELSE
' Toggle close menu.
IF GetAsyncKeyState(1) < 0 THEN
IF WinMse.Y_Pos >= _SCREENY AND WinMse.Y_Pos <= _SCREENY + 24 AND WinMse.X_Pos >= _SCREENX + 36 AND WinMse.X_Pos <= _SCREENX + 48 THEN
menu.var = 0: EXIT DO ' Close menu.
ELSE
IF WinMse.Y_Pos >= _SCREENY AND WinMse.Y_Pos <= _SCREENY + _FONTHEIGHT * (_HEIGHT + 1) AND WinMse.X_Pos >= _SCREENX AND WinMse.X_Pos <= _SCREENX + _FONTWIDTH * _WIDTH THEN
ELSE ' Outside of app window.
menu.var = 0: EXIT DO ' Close menu.
END IF
END IF
END IF
IF _MOUSEBUTTON(1) THEN ' Outside of menu closes menu.
menu.var = 0 ' Close.
EXIT DO
END IF
END IF
oldmy = WinCon.my
CASE 0
menu.var = -1 ' Menu open.
PCOPY 0, 1
PALETTE 7, 63 ' Bright white.
PALETTE 3, 56 ' Grey shadow.
PALETTE 0, 8 ' Dark blue highlight on hover.
COLOR 0, 7
LOCATE MenuT, MenuL
PRINT CHR$(218) + STRING$(mwidth - 2, 196) + CHR$(191)
FOR i = 1 TO mheight - 2
COLOR 0, 7
PRINT CHR$(179); SPACE$(mwidth - 2) + CHR$(179);
COLOR 7, 3: PRINT CHR$(SCREEN(CSRLIN, POS(0))) + CHR$(SCREEN(CSRLIN, POS(0) + 1)): COLOR 1, 7
NEXT
COLOR 0, 7
PRINT CHR$(192) + STRING$(mwidth - 2, 196) + CHR$(217);: COLOR 7, 3: PRINT CHR$(SCREEN(CSRLIN, POS(0))) + CHR$(SCREEN(CSRLIN, POS(0) + 1))
LOCATE , MenuL + 2
FOR i = 1 TO mheight ' Bottom shadow.
PRINT CHR$(SCREEN(CSRLIN, POS(0)));
NEXT
COLOR 0, 7
LOCATE MenuT + 2, MenuL + 2
FOR i = 0 TO noi - 1
LOCATE MenuT + 1 + i * 2, 3
PRINT menu$(i + 1)
LOCATE , MenuL
IF i + 1 < noi THEN PRINT "Ã" + STRING$(mwidth - 2, CHR$(196)) + "´";
NEXT
DO: _LIMIT 10: LOOP UNTIL GetAsyncKeyState(1) = 0 ' Wait for button release to avoid continuous toggle event.
END SELECT
LOOP
PCOPY 1, 0
LOCATE y, x
_KEYCLEAR
IF menu.var = 6 THEN SYSTEM
DO: _LIMIT 10: LOOP UNTIL GetAsyncKeyState(1) = 0
PALETTE 7, 7 ' Re-establish color 7.
END SUB
SUB borderless_window
GWL_STYLE = -16
ws_border = &H800000
WS_VISIBLE = &H10000000
_TITLE "No Border"
hWnd& = _WINDOWHANDLE
DO
winstyle& = GetWindowLongA&(hWnd&, GWL_STYLE)
LOOP UNTIL winstyle&
DO
a& = SetWindowLongA&(hWnd&, GWL_STYLE, winstyle& AND WS_VISIBLE)
LOOP UNTIL a&
END SUB
SUB borderless_variables (WinCon AS Win_Control)
WinCon.x = _SCREENX
WinCon.y = _SCREENY
WinCon.w = _WIDTH
WinCon.h = _HEIGHT
WinCon.fw = _FONTWIDTH
WinCon.fh = _FONTHEIGHT
WinCon.wintp = _SCREENY \ WinCon.fh: WinCon.winbt = _SCREENY \ WinCon.fh + _HEIGHT: WinCon.winlt = _SCREENX \ WinCon.fw: WinCon.winrt = _SCREENX \ WinCon.fw + _WIDTH
END SUB
SUB mouse_borderless (mouse_switch AS INTEGER, WinCon AS Win_Control)
SELECT CASE mouse_switch
CASE 1
WHILE _MOUSEINPUT: WEND
WinCon.mx = _MOUSEX
WinCon.my = _MOUSEY
z& = GetCursorPos(WinMse)
REM setcurx = WinMse.X_Pos: setcury = WinMse.Y_Pos
WinCon.X_IN = WinMse.X_Pos \ WinCon.fw
WinCon.Y_IN = WinMse.Y_Pos \ WinCon.fh
CASE 2
IF GetAsyncKeyState(1) < 0 THEN
IF WinCon.lb = 0 THEN WinCon.lb = 1
ELSE
IF WinCon.lb THEN WinCon.lb = 0: WinCon.dragx = 0: WinCon.dragy = 0
END IF
CASE 3
WinCon.oldyIN = WinCon.Y_IN: WinCon.oldxIN = WinCon.X_IN
END SELECT
END SUB
SUB titlebar_icons (WinCon AS Win_Control)
IF WinCon.lb THEN
IF WinCon.tbicon THEN
COLOR 8, 5: LOCATE WinCon.my, WinCon.tbicon - 1: PRINT WinCon.tmp;: WinCon.tbicon = 0
DO: LOOP UNTIL GetAsyncKeyState(1) = 0: WinCon.lb = 0
_DELAY .1
SELECT CASE MID$(WinCon.tmp, 2, 1)
CASE "X"
SYSTEM
CASE "þ"
IF _FULLSCREEN THEN
_FULLSCREEN OFF
_SCREENMOVE _MIDDLE
_DELAY .5
REM DO: LOOP UNTIL _SCREENEXISTS is not sufficient here. It registers the window as upper right corner. WinCon.winlt and WinCon.winrt = 0 but window appears in middle.
CALL borderless_variables(WinCon)
CALL mouse_borderless(1, WinCon) ' Renew variables
CALL mouse_borderless(3, WinCon)
ELSE
SCREEN WinCon.S_orig&
DO: LOOP UNTIL _SCREENEXISTS
_FULLSCREEN
END IF
CASE "Ä"
x& = ShowWindow&(hWnd&, 2)
DO: _LIMIT 1: LOOP UNTIL _SCREENICON = 0
CALL sam_titlebar
CASE "ð"
CALL sam_menu
CALL borderless_variables(WinCon)
CALL mouse_borderless(1, WinCon) ' Renew variables
CALL mouse_borderless(3, WinCon)
END SELECT
WinCon.tmp = ""
END IF
ELSE
IF WinCon.my = 1 THEN
IF WinCon.lb = 0 AND WinCon.dragx = 0 AND side$ = "" THEN
' ID by screen character.
IF WinCon.mx <> WinCon.tbicon THEN
SELECT CASE CHR$(SCREEN(WinCon.my, WinCon.mx))
CASE "X", "þ", "Ä"
IF WinCon.tbicon THEN COLOR 8, 5: LOCATE WinCon.my, WinCon.tbicon - 1: PRINT WinCon.tmp;
WinCon.tmp = SPACE$(3): MID$(WinCon.tmp, 2, 1) = CHR$(SCREEN(WinCon.my, WinCon.mx))
IF MID$(WinCon.tmp, 2, 1) = "X" THEN: COLOR 15, 12 ELSE COLOR 15, 7
WinCon.tbicon = WinCon.mx: LOCATE WinCon.my, WinCon.mx - 1: PRINT WinCon.tmp;
CASE "ð", "M", "e", "n", "u" ' Menu.
IF WinCon.tbicon THEN COLOR 8, 5: LOCATE WinCon.my, WinCon.tbicon - 1: PRINT WinCon.tmp;
' Exception.
WinCon.tmp = SPACE$(3): MID$(WinCon.tmp, 2, 1) = "ð"
WinCon.tbicon = 2: COLOR 15, 7: LOCATE WinCon.my, 1: PRINT WinCon.tmp;
CASE ELSE
IF WinCon.tbicon THEN COLOR 8, 5: LOCATE WinCon.my, WinCon.tbicon - 1: PRINT WinCon.tmp;
WinCon.tbicon = 0
END SELECT
END IF
END IF
ELSE
IF WinCon.tbicon THEN CALL sam_titlebar: WinCon.tbicon = 0
END IF
END IF
END SUB
SUB size_n_drag (WinCon AS Win_Control, side$)
IF WinCon.lb THEN
IF LEN(side$) THEN
DO
_LIMIT 45
z& = GetCursorPos(WinMse)
WinCon.X_IN = WinMse.X_Pos \ WinCon.fw
WinCon.Y_IN = WinMse.Y_Pos \ WinCon.fh
IF WinCon.oldxIN <> WinCon.X_IN OR WinCon.oldyIN <> WinCon.Y_IN THEN
REM setcurx = WinMse.X_Pos: setcury = WinMse.Y_Pos
SELECT CASE side$
CASE "left-top"
WinCon.sizeit = -SGN(WinCon.oldyIN - WinCon.Y_IN) * ABS(WinCon.wintp - WinCon.Y_IN)
IF WinCon.sizeit THEN GOSUB topsize
WinCon.sizeit = SGN(WinCon.oldxIN - WinCon.X_IN) * ABS(WinCon.winlt - WinCon.X_IN)
IF WinCon.sizeit THEN GOSUB leftsize
CASE "right-top"
WinCon.sizeit = -SGN(WinCon.oldyIN - WinCon.Y_IN) * ABS(WinCon.wintp - WinCon.Y_IN)
IF WinCon.sizeit THEN GOSUB topsize
WinCon.sizeit = -SGN(WinCon.oldxIN - WinCon.X_IN) * ABS(WinCon.winrt - WinCon.X_IN)
IF WinCon.sizeit THEN GOSUB rightsize
CASE "left-bottom"
WinCon.sizeit = SGN(WinCon.oldxIN - WinCon.X_IN) * ABS(WinCon.winlt - WinCon.X_IN)
IF WinCon.sizeit THEN GOSUB leftsize
WinCon.sizeit = SGN(WinCon.oldyIN - WinCon.Y_IN) * ABS(WinCon.winbt - WinCon.Y_IN)
IF WinCon.sizeit THEN GOSUB bottomsize
CASE "right-bottom"
WinCon.sizeit = -SGN(WinCon.oldxIN - WinCon.X_IN) * ABS(WinCon.winrt - WinCon.X_IN)
IF WinCon.sizeit THEN GOSUB rightsize
WinCon.sizeit = SGN(WinCon.oldyIN - WinCon.Y_IN) * ABS(WinCon.winbt - WinCon.Y_IN)
IF WinCon.sizeit THEN GOSUB bottomsize
CASE "top" ' up/down
WinCon.sizeit = -SGN(WinCon.oldyIN - WinCon.Y_IN) * ABS(WinCon.wintp - WinCon.Y_IN)
IF WinCon.sizeit THEN GOSUB topsize
CASE "bottom"
WinCon.sizeit = SGN(WinCon.oldyIN - WinCon.Y_IN) * ABS(WinCon.winbt - WinCon.Y_IN)
IF WinCon.sizeit THEN GOSUB bottomsize
CASE "left"
WinCon.sizeit = SGN(WinCon.oldxIN - WinCon.X_IN) * ABS(WinCon.winlt - WinCon.X_IN)
IF WinCon.sizeit THEN GOSUB leftsize
CASE "right"
WinCon.sizeit = -SGN(WinCon.oldxIN - WinCon.X_IN) * ABS(WinCon.winrt - WinCon.X_IN)
IF WinCon.sizeit THEN GOSUB rightsize
END SELECT
WinCon.wintp = WinCon.y \ WinCon.fh: WinCon.winbt = WinCon.y \ WinCon.fh + _HEIGHT: WinCon.winlt = WinCon.x \ WinCon.fw: WinCon.winrt = WinCon.x \ WinCon.fw + _WIDTH
END IF
WinCon.oldyIN = WinCon.Y_IN: WinCon.oldxIN = WinCon.X_IN
LOOP UNTIL GetAsyncKeyState(1) = 0
ELSE
IF WinCon.dragx THEN
DO
_SCREENMOVE WinMse.X_Pos - WinCon.dragx, WinMse.Y_Pos - WinCon.dragy
z& = GetCursorPos(WinMse)
WinCon.setxy = SetCursorPos(WinMse.X_Pos, WinMse.Y_Pos)
LOOP UNTIL GetAsyncKeyState(1) = 0
WinCon.x = _SCREENX: WinCon.y = _SCREENY
WinCon.wintp = _SCREENY \ WinCon.fh: WinCon.winbt = _SCREENY \ WinCon.fh + _HEIGHT: WinCon.winlt = _SCREENX \ WinCon.fw: WinCon.winrt = _SCREENX \ WinCon.fw + _WIDTH
EXIT SUB
ELSEIF WinMse.Y_Pos >= _SCREENY AND WinMse.Y_Pos <= _SCREENY + WinCon.fh AND side$ = "" AND WinCon.lb THEN
WinCon.x = _SCREENX: WinCon.y = _SCREENY
WinCon.dragx = WinMse.X_Pos - WinCon.x
WinCon.dragy = WinMse.Y_Pos - WinCon.y
EXIT SUB
END IF
END IF
ELSE
IF WinCon.X_IN = WinCon.winlt AND WinCon.Y_IN = WinCon.wintp THEN
_MOUSESHOW "TOPLEFT_BOTTOMRIGHT": side$ = "left-top"
ELSEIF WinCon.X_IN = WinCon.winlt AND WinCon.Y_IN = WinCon.winbt THEN _MOUSESHOW "TOPRIGHT_BOTTOMLEFT": side$ = "left-bottom"
ELSEIF WinCon.X_IN = WinCon.winrt AND WinCon.Y_IN = WinCon.wintp THEN _MOUSESHOW "TOPRIGHT_BOTTOMLEFT": side$ = "right-top"
ELSEIF WinCon.X_IN = WinCon.winrt AND WinCon.Y_IN = WinCon.winbt THEN _MOUSESHOW "TOPleft_BOTTOMRIGHT": side$ = "right-bottom"
ELSEIF WinCon.X_IN = WinCon.winlt THEN _MOUSESHOW "HORIZONTAL": side$ = "left"
ELSEIF WinCon.X_IN = WinCon.winrt THEN _MOUSESHOW "HORIZONTAL": side$ = "right"
ELSEIF WinMse.Y_Pos = _SCREENY THEN _MOUSESHOW "VERTICAL": side$ = "top"
ELSEIF WinCon.Y_IN = WinCon.winbt THEN _MOUSESHOW "VERTICAL": side$ = "bottom"
ELSE
IF LEN(side$) THEN side$ = "": _MOUSESHOW "default"
END IF
END IF
EXIT SUB
topsize:
IF LEN(side_suspend$) THEN IF WinCon.wintp < WinCon.Y_IN THEN RETURN
IF WinCon.h - WinCon.sizeit < 15 THEN side_suspend$ = side$: RETURN
side_suspend$ = ""
WinCon.h = WinCon.h - WinCon.sizeit
WinCon.x = _SCREENX
WinCon.y = _SCREENY + WinCon.sizeit * WinCon.fh
S& = _NEWIMAGE(WinCon.w, WinCon.h, 0)
SCREEN S&
CALL sam_titlebar
_SCREENMOVE WinCon.x, WinCon.y
REM z% = SetCursorPos%(setcurx, setcury)
RETURN
leftsize:
IF LEN(side_suspend$) THEN IF WinCon.winlt < WinCon.X_IN THEN RETURN
IF WinCon.w + WinCon.sizeit < 15 THEN side_suspend$ = side$: RETURN
side_suspend$ = ""
WinCon.w = WinCon.w + WinCon.sizeit
WinCon.x = _SCREENX - WinCon.sizeit * WinCon.fw
WinCon.y = _SCREENY
S& = _NEWIMAGE(WinCon.w, WinCon.h, 0)
SCREEN S&
CALL sam_titlebar
_SCREENMOVE WinCon.x, WinCon.y
REM z% = SetCursorPos%(WinCon.x, setcury)
RETURN
rightsize:
IF LEN(side_suspend$) THEN IF WinCon.winrt > WinCon.X_IN THEN RETURN
IF WinCon.w + WinCon.sizeit < 15 THEN side_suspend$ = side$: RETURN
side_suspend$ = ""
WinCon.w = WinCon.w + WinCon.sizeit
WinCon.x = _SCREENX - WinCon.sizeit * WinCon.fw
WinCon.y = _SCREENY
S& = _NEWIMAGE(WinCon.w, WinCon.h, 0)
SCREEN S&
CALL sam_titlebar
WinCon.x = _SCREENX: WinCon.y = _SCREENY
REM z% = SetCursorPos%(WinCon.x + _WIDTH * WinCon.fw, setcury)
RETURN
bottomsize:
IF LEN(side_suspend$) THEN IF WinCon.winbt > WinCon.Y_IN THEN RETURN
IF WinCon.h - WinCon.sizeit < 15 THEN side_suspend$ = side$: RETURN
side_suspend$ = ""
WinCon.h = WinCon.h - WinCon.sizeit
S& = _NEWIMAGE(WinCon.w, WinCon.h, 0)
SCREEN S&
CALL sam_titlebar
WinCon.x = _SCREENX: WinCon.y = _SCREENY
REM z% = SetCursorPos%(setcurx, WinCon. + _HEIGHT * WinCon.fh)
RETURN
END SUB
Pete
|
|
|
|
| The QB64 IDE shell |
|
Posted by: eoredson - 12-01-2022, 05:04 AM - Forum: Utilities
- Replies (5)
|
 |
Find attached the QB64 shell program.
Installed in this package is Qb64shell.bas which is the source..
The file contents are as follows:
Code: (Select All) Information file for:
QB64SHELL - command line prompt shell windows program for QB64
Purpose:
Provides a low level DOS-like command shell program similar to the one
used by Windows CMD.EXE prompt. Tries to improve on most DOS functions,
such as: DIR, COPY, DELETE, MKDIR, etc. Also supports standard I/O
between commands and a full screen editor.
Installation:
Copy the QB64shell archive to C:\QB64 and extract contents there.
Load/Start or make .EXE then enter the shell at the command line.
Since QB64shell starts with user profiles activated, enter SYSOP
and PASSWORD to logon.
Files used:
QB64shell attempts to create the folder QB64shell in the \program files
group. The files in the folder are:
filemenu.cfg - config data for the file menu box
profiles.dat - user profiles data file
qb64shell.cfg - current state of QB64shell after exit
filename.cfg is written the first time QB64shell starts.
profiles.dat is written with SYSOP the first time QB64shell starts.
qb64shell.cfg is written every time the QB64shell exits and contains
such variables as the windows coordinates, statusbar setting, etc.
Any of these files may be safely deleted.
Compiling QB64shell:
The following files are required to make the QB64shell.exe program:
QB64shell.bas -- main QB64shell code
QB64shell.inc -- the QB64shell include file
QB64shell.ico -- the QB64shell icon file
QB64shell.new -- new version list file
QB64shell.txt -- readme file
Mem.h -- memory and cpu usage include file
THX_Sound_Effect.mp3 - intro sound
(only plays the first time QB64shell starts)
Author notes:
Program is published 11/30/2022 and is public domain BASIC source code.
Written and maintained by Erik Jon Oredson who can be reached at:
eoredson@gmail.com
-end-
The QBshell commands are:
Code: (Select All) QB64shell commands:
Basic commands:
CLS CPU KEY MEM VER TOGGLE
CLOCK DATE TIME MENU HELP EDIT
DEBUG COLOR PROMPT STATUS SYSTEM QUIT
ASCII HEXCHART HEXCALC REDRAW WHATIS COUNT
MONITOR PROFILES SCREENSAVER
Filters: FIND MORE SORT TYPE
Filename commands:
COMPFILE COPY DELETE DIR MKFILE RENAME
ENCRYPT DECRYPT GETATTR SETATTR LISTFILE TOUCH
Directory commands: COMPDIR LISTDIR PUSHD POPD
TREE TREEDEL TOUCHDIR CHDIR MKDIR RMDIR
Volume commands:
DRIVES LABEL VOL LISTDRIVE
The version history is:
Code: (Select All) QB64shell - command line prompt shell windows program for QB64
First release:
Version v.0001 Release r.001
Build 11-21-2017.01
New release:
Build 11-24-2017.01
Edits TREE to reflect TREEDIR
New release:
Build 11-29-2017.01
Copyit v9.0a r4.0a updates:
Adds quit option to disk full error.
Now copies ambiguated unicode filenames.
Fixes switches in moreprompt.
New release:
Build 12-02-2017.01
Copyit v9.0a r5.0a updates:
Now preserves unicode filenames.
Now also preserves unicode directories.
Adds break option to break trap.
New release:
Build 12-05-2017.01
Adds Unicode to rename.
New release:
Build 12-15-2017.01
Fixes recursive loop in Stree.
Adds more Unicode to recursive searches.
Repairs Stdout in Getattr.
New release:
Build 12-16-2017.01
Fixes missing toolbar.
Adds features to ScrnEdit:
Adds Control-Break during fileload,
Adds percent file loaded in title.
Forces alternate filename in redirection.
New release:
Build 12-30-2017.01
Adds switches to detect compressed/encrypted files.
New release:
Build 01-01-2018.01
Modifies attribute to _unsigned long.
New release:
Build 04-20-2022.01
Fixes syntax errors in GetDateTime and FormatX$
New release:
Build 12-10-2022.01
Adds dialog box to file menu.
Removes file menu box.
New release:
Build 12-17-2022.01
Edits SendMessage for screensaver.
Removes LocateF, PrintF, ColorF, ColorF2.
Adds (C)ount to Sub Menu.
Fixes problem with displaytoolbar in dropdown file menu.
New release:
Build 12-20-2022.01
Write critical error to error log file.
Adds some userprofile reserved values.
Add help copy stats.
Fixes recursive clock$ function.
New release:
Build 12-24-2022.01
Removes 150 lines of unused code.
Edits prompt $W[<exp$>] parsing.
New release:
Build 02-20-2023.01
Adds parameter to GetOpenFileName$
Adds keypad-5 trap.
New release: (qbshell8.zip)
Build 03-20-2023.01
Adds Serial and Fattype displays to volume commands.
Fixes setting/displaying volume in Sub Label.
Adds /A, /B, /1:d to Sub Label.
Wrote documentation files:
QB64shell.doc and QB64shell.cmd
New release: (qbshell9.zip)
Build 03-28-2023.01
Modifies titlebar icon.
-end-
![[Image: qbshell.png]](https://i.ibb.co/cwvyL59/qbshell.png)
![[Image: qbshell2.png]](https://i.ibb.co/QJP636y/qbshell2.png)
Code: (Select All) (QbshellA.zip);
New release:
Build 04-28-2023.01
Fixes Inkeyx$ function.
Updates ReadConfig and WriteConfig removing GetConfigFilename$
Replaces CreateFile and CreateFileA library function calls with
custom Sub CreateFileA function.
Removes call to GrabURL.
Moves _Limit calls to Function Inkeyx$
Adds Inkeyz$ and Keypad-5 centering to all boxes.
New release:
Build 05-04-2023.01
Removes _DirExists when directory semantics flag could be used
with Sub CreateFileA instead.
Removes all f$=keyboardline$ and g$=keyboardline$ when using
dialog box instead.
Adds more keyboard scancodes to Sub HexCalc.
New release:
Build 05-05-2023.01
Adds chdir to Sub NewDir to store in DriveTable.
Fixes SwitchDrive with C: declared without path.
New release:
Build 05-15-2023.01
Edits critical error trap.
Adds "debug errorlog" to display error log file.
Fixes blank line when <down> is at end of history array.
New release:
Build 05-20-2023.01
Fixes history array when up/down selected.
New release: (qbshellb)
Build 05-23-2023.01
Adds up/down scancodes to some message boxes.
New release: (qbshellc)
Build 05-26-2023.01
Adds WhatisBox to enter equations.
Adds CheckAlarms timer trap and AlarmMenu.
Adds KeyboardLine$ function support for AlarmMenu.
New release: (qbshelld)
Build 06-03-2023.01
Adds Table command to list drivetable/netpathtable.
Adds search string option to Table command.
(may contain ? and * characters).
Adjusts NetPathHistory in KeyboardLine$
New release: (qbshelle)
Build 06-20-2023.01
Fixes problem when started from netpath/cdrom.
Adds filename entry to GrabURL in debug.
Fixes problem when started from netpath.
New release: (qbshellf)
Build 07-01-2023.01
Fixes retracting multidots in CD/RD/MD.
Fixes possible cascade in error.routine trap.
New release: (qbshellg)
Build 07-07-2023.01
Remove Cls from GetOpenFilename$
Adds percent display in VerifyFiles2.
Adds /F"file" and /G"file" to compfile.
Adds /F"path" and /G"path" to compdir.
Fixes some display in compdir.
New release: (qbshellh)
Build 07-15-2023.01
Adds more titlebar display in Compfile and Conpdir.
Adds MouseWheel and WheelReverse to all 16 boxes.
Adds <test> <function> to DebugFunc:
Adds $X and $Z and $A[<n>] to DisplayPrompt.
Adds "debug mouse" to test mouse functions.
Adds ViewFile function to simple array.
Fixes attribute assignment in ListFiles.
New release: (qbshellh)
Build 07-20-2023.01
Converts sound effect file to 8-bit stored as 88KB.
Compresses qbshellh.zip from 880K to 330K.
Fixes Strip.Blanks in More function.
New release: (qbshelli)
Build 08-03-2023.01
Fixes [Removable] drive in Sub ListDrives.
Adds MediaExists in Sub FreeSpace and Sub TotalSpace.
Improves drive display in Volume in Sub Menu.
New release: (qbshellj)
Build 08-25-2023.01
Fixes display in Sub FindY during streaming.
Now allows multiple filenames in ListFile.
Tweaks some monitorbox function calls.
New release: (qbshellk)
Build 09-20-2023.01
Replaced call to Whereis with Stree.
Retools Sub EditProfiles.
Fixes AddProfile for new usernames.
Adds (I)nit to Sub EditProfiles.
Adds MessageBox to ViewFileInfo.
Adds double bar to MessageBox.
Edits critical error trap with System selection.
Adds TeeFunction to redirect Stdout.
New release: (qbshelll)
Build 10-10-2023.01
Adds ReadConfig during edit config.
Modifies Sub Menu.
Adds (Z)viewfile to Files.
Adds (Y)randomize volume labels in Volume.
Adds (Z)ap volume labels in Volume.
Moves _ControlChr off to top of program.
Fixes possible cascade error in Sub Copyit_DisplayError.
Adds more debug functions.
Adds Const CopyitConfig$ = "COPYIT.CFG"
Edits date/time override using SetLocalTime.
Adds MonitorSuffix for k/m/g/t in monitor display.
And adds to config file in Qb64shell.cfg and to
user profiles in Profiles.dat
Replaces all Color statements with constants.
Replaces all Chr$(34) with Quote constant.
Adds Const TabStop=8 to Keyboardline$ and Scrnedit.
Adds ctrl-k appendfile and ctrl-l insertfile to Sub ScrnEdit.
Fixes SearchReplace in Sub ScrnEdit.
Now allows realtime display prompt in Function KeyBoardLine$
New release: (qbshellm)
Build 01-10-2024.01
Adds Search to commands and SearchFiles.
Adds F4 AppendFile and F5 InsertFile to ScrnEdit.
Fixes array in insertfile in Sub ScrnEdit.
Adds VersionInfo settings to QB64shell.inc
Adds '-/+', 'a-z', 'A-Z', '0-9' to scan filename in SearchFiles.
Adds F3 to search filename in SearchFile. And Ctrl-F3 to repeat search.
Extends Search command with filespec parameter.
New release: (qbshelln)
Build 03-10-2024.01
Replaces LoadIcon with Icon2BMP.
Adds F4 and F5 to SortOrder for Dirs and Files in SearchFiles.
Adds F6 to recursively call SearchFiles.
Adds dirspec prompt to SearchFiles.
Replaces all Kill with DeleteFileA.
Replaces Name AS with MoveFile.
Replaces MkDir with CreateDirectory.
Rewrote LoadDrives, LoadFiles, and SortFiles in SearchFiles.
Adds missing DisplayStatusLine function in SearchFiles.
Adds missing PercentDisplay function in SearchFiles and ScrnEdit2.
Now checks drive exists/added/removed realtime in SearchFiles.
Now parses command line switch to append slash in several functions.
New release: (qbshello)
Build 05-20-2024.01
More mods for Sub SearchFiles:
Enables support for Midi files.
Adds Sub VerifyPlay function to check sound filename extension.
Adds Play Pause and Play Resume to toggle playmode.
Adds Sub VerifyFile to check system file.
Adds Sub VerifyFile2 to check library file.
Adds Sub VerifyFile3 to check source file.
Adds Sub VerifyFile4 to check document file.
Adds Sub VerifyFile5 to check compressed file.
Adds Sub VerifyFile6 to check video file.
Adds Sub VerifyFile7 to check image file.
Adds Sub VerifyFile8 to check web file.
Adds Sub VerifyFile9 to check database file.
Adds PlayFile to play sound files.
And Ctrl-P = pause/resume soundfile.
And Ctrl-Q = set soundfile plus 10 seconds.
And Ctrl-R = set soundfile minus 10 seconds.
And Ctrl-X = exit with soundfile remaining.
And Ctrl-Y = increase sound volume.
And Ctrl-Z = decrease sound volume.
Adds left/right to MessageBox and HelpBox.
Adds Quote constant assignment.
Fixes _ControlChr in backspace display.
Fixes GrabUrl with read-only bit set in download file.
Fixes Hex Screen.Print and File.Print in Sub ScrnEdit.
Adds _SelectFolderDialog$ for directory options in Sub Menu.
Prevents WhatisBox from hanging by adding a special error trap.
Now displays <token error> and <quote error> in WhatError trap.
Traps exponent dual binary parsing error in Whatis numeric processor.
New release: (qbshellp)
Build 10-10-2024.01
Fixes date/time settings when hangs.
Affects DateFunc and TimeFunc.
Edits Escape function in LineInput$
New release: (qbshellq)
Build 12-10-2024.01
Removes $Unstable:Midi and replaces with
_MIDISoundBank "steelgit.sf2", "sf2"
Adds Const MaxSoundFileExtensions = 31
-end-
QB64shell.bas is now 53,670 lines.
The file can be found at: https://bit.ly/QB64shell
|
|
|
|
| tweak Str$ for single and double |
|
Posted by: Jack - 12-01-2022, 02:09 AM - Forum: General Discussion
- Replies (9)
|
 |
I think that this is worth looking into
Code: (Select All) Dim As Single x
For x = 1 To .05 Step -.05
Print x
Next x
output
Code: (Select All) 1
.95
.9
.85
.8
.7499999
.6999999
.6499999
.5999999
.5499999
.4999999
.4499999
.3999999
.3499998
.2999998
.2499998
.1999998
.1499998
9.999985E-02
if you change the format string in the function qbs *qbs_str(float value) in libqb.cpp from "% .6E" to "% .6G" you get
Code: (Select All) 1
0.95
0.9
0.85
0.8
0.75
0.7
0.65
0.6
0.55
0.5
0.45
0.4
0.35
0.3
0.25
0.2
0.15
0.0999998
before change
Code: (Select All) 1
.95
.9
.85
.7999999999999998
.7499999999999998
.6999999999999997
.6499999999999997
.5999999999999996
.5499999999999996
.4999999999999996
.4499999999999996
.3999999999999996
.3499999999999996
.2999999999999997
.2499999999999997
.1999999999999997
.1499999999999997
.0999999999999997
after changing "E" to "G"
the change to G messes up if the exponent goes above 99 so more work is needed to make it work for the full range
Code: (Select All) 1
0.95
0.9
0.85
0.8
0.75
0.7
0.65
0.6
0.55
0.5
0.45
0.4
0.35
0.3
0.25
0.2
0.15
0.1
|
|
|
|
|
