and another one for your toolbox...

[bplus]

And another rather simple routine for your toolbox collection -- a quick mouse handler.

Code: QB64: [Select]

1. DO
2.     CLS
3.     held$ = ""
4.     SELECT CASE MBS
5.         CASE 1: left = left + 1
6.         CASE 2: right = right + 1
7.         CASE 3: middle = middle + 1
8.         CASE 4: held$ = "Left held"
9.         CASE 5: held$ = "Right held"
10.         CASE 6: held$ = "Middle held"
11.     END SELECT
12.  
13.     PRINT "MouseX: "; _MOUSEX
14.     PRINT "MouseY: "; _MOUSEY
15.     PRINT "Left pressed: "; left
16.     PRINT "Right pressed: "; right
17.     PRINT "Middle pressed: "; middle
18.     PRINT held$
19.     _LIMIT 10
20. LOOP
21.  
22.  
23. FUNCTION MBS 'Mouse Button Status
24.     STATIC StartTimer AS _FLOAT
25.     STATIC ButtonDown AS INTEGER
26.     STATIC ClickCount AS INTEGER
27.     CONST ClickLimit## = 0.2 '2/10th of a second to down, up a key to count as a CLICK.  Down longer counts as a HOLD event.
28.  
29.     WHILE _MOUSEINPUT: WEND 'Remark out this line, if mouse main input/clear is going to be handled manually in main program.
30.  
31.     IF StartTimer = 0 THEN
32.         IF _MOUSEBUTTON(1) THEN 'If a button is pressed, start the timer to see what it does (click or hold)
33.             ButtonDown = 1: StartTimer = TIMER(0.01)
34.         ELSEIF _MOUSEBUTTON(2) THEN
35.             ButtonDown = 2: StartTimer = TIMER(0.01)
36.         ELSEIF _MOUSEBUTTON(3) THEN
37.             ButtonDown = 3: StartTimer = TIMER(0.01)
38.         END IF
39.     ELSE
40.         BD = ButtonDown MOD 3
41.         IF BD = 0 THEN BD = 3
42.         IF TIMER(0.01) - StartTimer <= ClickLimit THEN 'Button was down, then up, within time limit.  It's a click
43.             IF _MOUSEBUTTON(BD) = 0 THEN MouseHandler = ButtonDown: ButtonDown = 0: StartTimer = 0
44.         ELSE
45.             IF _MOUSEBUTTON(BD) = 0 THEN 'hold event has now ended
46.                 MouseHandler = 0: ButtonDown = 0: StartTimer = 0
47.             ELSE 'We've now started the hold event
48.                 MouseHandler = ButtonDown + 3
49.             END IF
50.         END IF
51.     END IF
52. END SUB

One quick command to tell you if a button was clicked or held, for any of the 3 mouse buttons.

Hi Steve,

Shall we assume you intended to set the Function MBS with the ButtonDown value before exiting function?

Code: QB64: [Select]

1. _TITLE "MBS mouse button status by Steve" ' 2019-08-06
2.  
3. DO
4.     CLS
5.     held$ = ""
6.     SELECT CASE MBS
7.         CASE 1: left = left + 1
8.         CASE 2: right = right + 1
9.         CASE 3: middle = middle + 1
10.         CASE 4: held$ = "Left held"
11.         CASE 5: held$ = "Right held"
12.         CASE 6: held$ = "Middle held"
13.     END SELECT
14.  
15.     PRINT "MouseX: "; _MOUSEX
16.     PRINT "MouseY: "; _MOUSEY
17.     PRINT "Left pressed: "; left
18.     PRINT "Right pressed: "; right
19.     PRINT "Middle pressed: "; middle
20.     PRINT held$
21.     _LIMIT 10
22. LOOP
23.  
24.  
25. FUNCTION MBS 'Mouse Button Status
26.     STATIC StartTimer AS _FLOAT
27.     STATIC ButtonDown AS INTEGER
28.     STATIC ClickCount AS INTEGER
29.     CONST ClickLimit## = 0.2 '2/10th of a second to down, up a key to count as a CLICK.  Down longer counts as a HOLD event.
30.  
31.     WHILE _MOUSEINPUT: WEND 'Remark out this line, if mouse main input/clear is going to be handled manually in main program.
32.  
33.     IF StartTimer = 0 THEN
34.         IF _MOUSEBUTTON(1) THEN 'If a button is pressed, start the timer to see what it does (click or hold)
35.             ButtonDown = 1: StartTimer = TIMER(0.01)
36.         ELSEIF _MOUSEBUTTON(2) THEN
37.             ButtonDown = 2: StartTimer = TIMER(0.01)
38.         ELSEIF _MOUSEBUTTON(3) THEN
39.             ButtonDown = 3: StartTimer = TIMER(0.01)
40.         END IF
41.     ELSE
42.         BD = ButtonDown MOD 3
43.         IF BD = 0 THEN BD = 3
44.         IF TIMER(0.01) - StartTimer <= ClickLimit THEN 'Button was down, then up, within time limit.  It's a click
45.             IF _MOUSEBUTTON(BD) = 0 THEN MouseHandler = ButtonDown: ButtonDown = 0: StartTimer = 0
46.         ELSE
47.             IF _MOUSEBUTTON(BD) = 0 THEN 'hold event has now ended
48.                 MouseHandler = 0: ButtonDown = 0: StartTimer = 0
49.             ELSE 'We've now started the hold event
50.                 MouseHandler = ButtonDown + 3
51.             END IF
52.         END IF
53.     END IF
54.     MBS = ButtonDown '<<< fix set function with ButtonDown ???
55. END SUB
56.  

hmm... second time in couple days you post a fine function but don't set the value, makes me wonder how much you test code before posting... maybe it's the meds or the summer heat?

wait... just making bplus feel useful ;-))


Actually I found this mouse code and tester interesting that Steve had posted a while back:

Code: QB64: [Select]

1. _TITLE "Mouse events using device" 'Steve McNeill 2019-02-21
2. DIM SHARED MouseX AS INTEGER, MouseY AS INTEGER
3. DIM SHARED MouseWheel AS INTEGER
4. DIM SHARED LeftMouse AS INTEGER, RightMouse AS INTEGER, MiddleMouse AS INTEGER
5. DIM SHARED ClickThreshold AS SINGLE
6. ClickThreshold = 0.2 'down and up in threshold of a second to count as a click.  If down for more then threshold, we just have a hold event.
7.  
8.  
9. SCREEN _NEWIMAGE(640, 480, 32)
10. _SCREENMOVE _MIDDLE
11.  
12.  
13.  
14. DO
15.     _LIMIT 60
16.  
17.     UpdateMouseInfo
18.     LOCATE 1, 1
19.     PRINT MouseX, MouseY
20.     PRINT MouseWheel
21.     PRINT LeftMouse, MiddleMouse, RightMouse
22.     IF LeftMouse AND 2 THEN leftclick = leftclick + 1
23.     IF MiddleMouse AND 2 THEN middleclick = middleclick + 1
24.     IF RightMouse AND 2 THEN rightclick = rightclick + 1
25.     PRINT leftclick, middleclick, rightclick
26.  
27. LOOP UNTIL INKEY$ = CHR$(27) 'escape key exit
28.  
29. SUB UpdateMouseInfo
30.     DIM SW AS INTEGER, SH AS INTEGER
31.     DIM LM AS INTEGER, MM AS INTEGER, RM AS INTEGER
32.  
33.     STATIC leftdown AS SINGLE, middledown AS SINGLE, rightdown AS SINGLE
34.  
35.     WHILE _DEVICEINPUT(2): MouseWheel = MouseWheel + _WHEEL(3): WEND 'clear and update the mouse buffer
36.  
37.     SW = _WIDTH \ 2: SH = _HEIGHT \ 2
38.     MouseX = _AXIS(1) * SW + SW: MouseY = _AXIS(2) * SH + SH
39.  
40.  
41.  
42.     LM = _BUTTON(1): MM = _BUTTON(2): RM = _BUTTON(3)
43.  
44.     IF leftdown THEN 'if it was down
45.         IF LM = 0 THEN 'and is now up
46.             IF TIMER - leftdown < ClickThreshold THEN
47.                 LeftMouse = 2 'clicked
48.             ELSE 'if it's still down
49.                 LeftMouse = 0 'the mouse was just released
50.             END IF
51.             leftdown = 0 'timer is cleared either way
52.         ELSE
53.             LeftMouse = 1 'the left mouse is down , timer should have already been set
54.         END IF
55.     ELSE
56.         IF LM THEN
57.             leftdown = TIMER 'set the timer to see if we have click or hold events
58.             LeftMouse = 1 'the left mouse is down
59.         ELSE
60.             LeftMouse = 0
61.         END IF
62.     END IF
63.  
64.     IF middledown THEN 'if it was down
65.         IF MM = 0 THEN 'and is now up
66.             IF TIMER - middledown < ClickThreshold THEN
67.                 MiddleMouse = 2 'clicked
68.             ELSE 'if it's still down
69.                 MiddleMouse = 0 'the mouse was just released
70.             END IF
71.             middledown = 0 'timer is cleared either way
72.         ELSE
73.             MiddleMouse = 1 'the middle mouse is down , timer should have already been set
74.         END IF
75.     ELSE
76.         IF MM THEN
77.             middledown = TIMER 'set the timer to see if we have click or hold events
78.             MiddleMouse = 1 'the middle mouse is down
79.         ELSE
80.             MiddleMouse = 0
81.         END IF
82.     END IF
83.  
84.     IF rightdown THEN 'if it was down
85.         IF RM = 0 THEN 'and is now up
86.             IF TIMER - rightdown < ClickThreshold THEN
87.                 RightMouse = 2 'clicked
88.             ELSE 'if it's still down
89.                 RightMouse = 0 'the mouse was just released
90.             END IF
91.             rightdown = 0 'timer is cleared either way
92.         ELSE
93.             RightMouse = 1 'the right mouse is down , timer should have already been set
94.         END IF
95.     ELSE
96.         IF RM THEN
97.             rightdown = TIMER 'set the timer to see if we have click or hold events
98.             RightMouse = 1 'the right mouse is down
99.         ELSE
100.             RightMouse = 0
101.         END IF
102.     END IF
103.  
104.  
105. END SUB
106.  
107.  

I thought this useful because it handles the mouse wheel (my mouse has a wheel not a middle button) and left and right buttons.

[SMcNeill]

Hi Steve,

Shall we assume you intended to set the Function MBS with the ButtonDown value before exiting function?

hmm... second time in couple days you post a fine function but don't set the value, makes me wonder how much you test code before posting... maybe it's the meds or the summer heat?

wait... just making bplus feel useful ;-))

Actually I found this mouse code and tester interesting that Steve had posted a while back:

I blame it on the stupid medication.  :P

Tested, it works -- as long as I don't go in and halfway rename things to make them "simpler" when I finish them.  (MouseHandler was the original name for the routine, but I renamed it to a simple "MBS" and didn't change everything like I should have, like a big idiot...)

Here's the version once again -- even enhanced this time to handle the middle scroll button for you!  :P

Code: QB64: [Select]

1. _TITLE "MBS mouse button status by Steve" ' 2019-08-06
2.  
3. DO
4.     CLS
5.     held$ = ""
6.     SELECT CASE MBS
7.         CASE 1: left = left + 1
8.         CASE 2: right = right + 1
9.         CASE 3: middle = middle + 1
10.         CASE 4: held$ = "Left held"
11.         CASE 5: held$ = "Right held"
12.         CASE 6: held$ = "Middle held"
13.         CASE ELSE: scroll = scroll + MBS \ 10
14.     END SELECT
15.  
16.     PRINT "MouseX: "; _MOUSEX
17.     PRINT "MouseY: "; _MOUSEY
18.     PRINT "Left pressed: "; left
19.     PRINT "Right pressed: "; right
20.     PRINT "Middle pressed: "; middle
21.     PRINT "Mouse Wheel Scrolled: "; scroll
22.     PRINT held$
23.     _LIMIT 10
24. LOOP
25.  
26.  
27. FUNCTION MBS 'Mouse Button Status
28.     STATIC StartTimer AS _FLOAT
29.     STATIC ButtonDown AS INTEGER
30.     STATIC ClickCount AS INTEGER
31.     CONST ClickLimit## = 0.2 '2/10th of a second to down, up a key to count as a CLICK.  Down longer counts as a HOLD event.
32.  
33.     WHILE _MOUSEINPUT 'Remark out this block, if mouse main input/clear is going to be handled manually in main program.
34.         scroll = scroll + 10 * _MOUSEWHEEL
35.         IF scroll THEN MBS = scroll: EXIT FUNCTION
36.     WEND
37.  
38.     IF StartTimer = 0 THEN
39.         IF _MOUSEBUTTON(1) THEN 'If a button is pressed, start the timer to see what it does (click or hold)
40.             ButtonDown = 1: StartTimer = TIMER(0.01)
41.         ELSEIF _MOUSEBUTTON(2) THEN
42.             ButtonDown = 2: StartTimer = TIMER(0.01)
43.         ELSEIF _MOUSEBUTTON(3) THEN
44.             ButtonDown = 3: StartTimer = TIMER(0.01)
45.         END IF
46.     ELSE
47.         BD = ButtonDown MOD 3
48.         IF BD = 0 THEN BD = 3
49.         IF TIMER(0.01) - StartTimer <= ClickLimit THEN 'Button was down, then up, within time limit.  It's a click
50.             IF _MOUSEBUTTON(BD) = 0 THEN MBS = ButtonDown: ButtonDown = 0: StartTimer = 0
51.         ELSE
52.             IF _MOUSEBUTTON(BD) = 0 THEN 'hold event has now ended
53.                 MBS = 0: ButtonDown = 0: StartTimer = 0
54.             ELSE 'We've now started the hold event
55.                 MBS = ButtonDown + 3
56.             END IF
57.         END IF
58.     END IF
59. END SUB
60.  

[bplus]

Since we are talking about mouse input, here is what I have come to use or modify for specific needs of app for getting mouse clicks, getClick(mouseX, mouseY, keypress) returns whatever occurs first a left mouse click or keypress AFTER all previous key press and mouse button down detection has been cleared (before the sub was called), it also clears mouse button and key press before return execution to caller code.

This was needed when running complex dialog code like mBox or inputBox, it is important then to get the mouse and key press from dialog to NOT interfere with other mouse and key press events in caller code and vice versa...

It has been an ever evolving process to get everything to work together, here is getClick tested with latest version of mBox and inputBox from which I discovered that a _KEYCLEAR line I had commented out in last mBOX update was still needed (fixed in code above)!

Code: QB64: [Select]

1. _TITLE "getClick testing with mBox and inputBox" ' by bplus 2018-05-12"
2. '2019-01-02 added _KEYCLEAR   to clear keys hit waiting for enter press at INPUT
3. '2019-03-02 discovered this does not work with mBox, can it be tested and fixed?
4. ' Nope, impossible.
5. 'can I get mBox to use getClick? No because I want to allow mouse to move mBox by grabbing title bar
6. 'OK added stuff to clear old mb and they are now working together
7.  
8. '2019-08-06 More tests with mBox and now inputBox$()
9. ' OK test if getClick plays nice with last update of mBox (2019-07-31) and vice versa
10. ' and also inputBox. Discovered 2019-08-06 mBox did need a _KEYCLEAR! inputBox already had it.
11.  
12. CONST xmax = 800
13. CONST ymax = 600
14. SCREEN _NEWIMAGE(xmax, ymax, 32)
15. _SCREENMOVE 360, 60
16. CLS
17. m$ = "To exit this mBox click X box, press enter, spacebar or escape, to exit this tester press escape (again?) after mBox is off screen."
18. m$ = m$ + CHR$(10) + "Otherwise when this box is off screen, click screen or enter letters."
19. m$ = m$ + CHR$(10) + "Once screen is clicked or enter is pressed you should see an inputBox$ come up."
20.  
21. WHILE 1
22.     'CLS
23.     toggle = (toggle + 1) MOD 2
24.     IF toggle THEN 'test mBox
25.         mBox "Test mBox with getClick", m$
26.         PRINT "mBox (Message Box) is a sub that returns nothing, it only provides info. "
27.         PRINT "If you pressed esacpe from mBox, press again if want to quit."
28.     ELSE
29.         'test inputBox
30.         r$ = inputBox$("Enter a string for inputBox to return to main program.", "Testing getClick with inputBox function.", 76)
31.         IF r$ = "" THEN PRINT "You entered nothing or escaped inputBox." ELSE PRINT "inputBox Returned: *" + r$ + "*"
32.     END IF
33.     PRINT "     To test getClick (now), click (and drag if want) screen or make a single keypress."
34.     PRINT "What you did should be detected by getClick and reported back to you here on main screen."
35.  
36.     'x = -1: y = -1: k = 0      'need this?
37.     getClick x, y, k
38.     IF k = 27 OR (k > 31 AND k < 126) THEN
39.         PRINT "You pressed "; CHR$(k)
40.         IF k = 27 OR k = 113 OR k = 81 THEN PRINT "Goodbye": END
41.     ELSE
42.         PRINT "(" + STR$(x) + ", " + STR$(y) + ")"
43.     END IF
44.     PRINT "All additional mouse clicks or keypresses will be ignored until:"
45.     INPUT "PRESS ENTER TO CONTINUE with another mBox or inputBox$() test... "; wate$
46.     _LIMIT 30
47. WEND
48.  
49. 'getClick returns the mouse x, y position WHEN THE MOUSE WAS RELEASED! or keypress ASC 27 or 32 to 125
50. '2019-08-06 Test now with new mBox and inputBox procedures
51. 'found  mBox needed a _KEYCLEAR, how about inputBox?  OK had _KEYCLEAR already
52. SUB getClick (mx, my, q)
53.     mb = _MOUSEBUTTON(1)
54.     WHILE mb
55.         WHILE _MOUSEINPUT: WEND '<<<<<<<<<<<<<<<<<<<<  clear previous mb
56.         mb = _MOUSEBUTTON(1)
57.     WEND
58.     _KEYCLEAR 'clear previous key presses
59.     mx = -1: my = -1: q = 0
60.     DO WHILE mx = -1 AND my = -1
61.         q = _KEYHIT
62.         IF q = 27 OR (q > 31 AND q < 126) THEN _KEYCLEAR: EXIT SUB
63.         i = _MOUSEINPUT: mb = _MOUSEBUTTON(1)
64.         'IF mb THEN
65.         DO WHILE mb 'wait for release
66.             q = _KEYHIT
67.             IF q = 27 OR (q > 31 AND q < 126) THEN EXIT SUB
68.             i = _MOUSEINPUT: mb = _MOUSEBUTTON(1): mx = _MOUSEX: my = _MOUSEY
69.             _LIMIT 1000
70.         LOOP
71.         _LIMIT 1000
72.     LOOP
73. END SUB
74.  
75. 'title$ limit is 57 chars, all lines are 58 chars max, version 2019-08-06
76. 'THIS SUB NOW NEEDS SUB scnState(restoreTF) for saving and restoring screen settings
77. SUB mBox (title AS STRING, m AS STRING)
78.  
79.     DIM bg AS _UNSIGNED LONG, fg AS _UNSIGNED LONG
80.     bg = &HBB000033
81.     fg = &HFF33AAFF
82.  
83.     'first screen dimensions and items to restore at exit
84.     DIM sw AS INTEGER, sh AS INTEGER
85.     DIM curScrn AS LONG, backScrn AS LONG, mbx AS LONG 'some handles
86.     DIM ti AS INTEGER, limit AS INTEGER 'ti = text index for t$(), limit is number of chars per line
87.     DIM i AS INTEGER, j AS INTEGER, ff AS _BIT, add AS _BYTE 'index, flag and
88.     DIM bxH AS INTEGER, bxW AS INTEGER 'first as cells then as pixels
89.     DIM mb AS INTEGER, mx AS INTEGER, my AS INTEGER, mi AS INTEGER, grabx AS INTEGER, graby AS INTEGER
90.     DIM tlx AS INTEGER, tly AS INTEGER 'top left corner of message box
91.     DIM lastx AS INTEGER, lasty AS INTEGER, t AS STRING, b AS STRING, c AS STRING, tail AS STRING
92.     DIM d AS STRING, r AS SINGLE, kh AS LONG
93.  
94.     'screen and current settings to restore at end ofsub
95.     scnState 0
96.     sw = _WIDTH: sh = _HEIGHT
97.  
98.     _KEYCLEAR '<<<<<<<<<<<<<<<<<<<< do i still need this?   YES! 2019-08-06 update!
99.  
100.     'screen snapshot
101.     curScrn = _DEST
102.     backScrn = _NEWIMAGE(sw, sh, 32)
103.     _PUTIMAGE , curScrn, backScrn
104.  
105.     'setup t() to store strings with ti as index, linit 58 chars per line max, b is for build
106.     REDIM t(0) AS STRING: ti = 0: limit = 58: b = ""
107.     FOR i = 1 TO LEN(m)
108.         c = MID$(m, i, 1)
109.         'are there any new line signals, CR, LF or both? take CRLF or LFCR as one break but dbl LF or CR means blank line
110.         SELECT CASE c
111.             CASE CHR$(13) 'load line
112.                 IF MID$(m, i + 1, 1) = CHR$(10) THEN i = i + 1
113.                 t(ti) = b: b = "": ti = ti + 1: REDIM _PRESERVE t(ti) AS STRING
114.             CASE CHR$(10)
115.                 IF MID$(m, i + 1, 1) = CHR$(13) THEN i = i + 1
116.                 t(ti) = b: b = "": ti = ti + 1: REDIM _PRESERVE t(ti)
117.             CASE ELSE
118.                 IF c = CHR$(9) THEN c = SPACE$(4): add = 4 ELSE add = 1
119.                 IF LEN(b) + add > limit THEN
120.                     tail = "": ff = 0
121.                     FOR j = LEN(b) TO 1 STEP -1 'backup until find a space, save the tail end for next line
122.                         d = MID$(b, j, 1)
123.                         IF d = " " THEN
124.                             t(ti) = MID$(b, 1, j - 1): b = tail + c: ti = ti + 1: REDIM _PRESERVE t(ti)
125.                             ff = 1 'found space flag
126.                             EXIT FOR
127.                         ELSE
128.                             tail = d + tail 'the tail grows!
129.                         END IF
130.                     NEXT
131.                     IF ff = 0 THEN 'no break? OK
132.                         t(ti) = b: b = c: ti = ti + 1: REDIM _PRESERVE t(ti)
133.                     END IF
134.                 ELSE
135.                     b = b + c 'just keep building the line
136.                 END IF
137.         END SELECT
138.     NEXT
139.     t(ti) = b
140.     bxH = ti + 3: bxW = limit + 2
141.  
142.     'draw message box
143.     mbx = _NEWIMAGE(60 * 8, (bxH + 1) * 16, 32)
144.     _DEST mbx
145.     COLOR _RGB32(128, 0, 0), _RGB32(225, 225, 255)
146.     LOCATE 1, 1: PRINT LEFT$(SPACE$((bxW - LEN(title) - 3) / 2) + title + SPACE$(bxW), bxW)
147.     COLOR _RGB32(225, 225, 255), _RGB32(200, 0, 0)
148.     LOCATE 1, bxW - 2: PRINT " X "
149.     COLOR fg, bg
150.     LOCATE 2, 1: PRINT SPACE$(bxW);
151.     FOR r = 0 TO ti
152.         LOCATE 1 + r + 2, 1: PRINT LEFT$(" " + t(r) + SPACE$(bxW), bxW);
153.     NEXT
154.     LOCATE 1 + bxH, 1: PRINT SPACE$(limit + 2);
155.  
156.     'now for the action
157.     _DEST curScrn
158.  
159.     'convert to pixels the top left corner of box at moment
160.     bxW = bxW * 8: bxH = bxH * 16
161.     tlx = (sw - bxW) / 2: tly = (sh - bxH) / 2
162.     lastx = tlx: lasty = tly
163.     'now allow user to move it around or just read it
164.     WHILE 1
165.         CLS
166.         _PUTIMAGE , backScrn
167.         _PUTIMAGE (tlx, tly), mbx, curScrn
168.         _DISPLAY
169.         WHILE _MOUSEINPUT: WEND
170.         mx = _MOUSEX: my = _MOUSEY: mb = _MOUSEBUTTON(1)
171.         IF mb THEN
172.             IF mx >= tlx AND mx <= tlx + bxW AND my >= tly AND my <= tly + 16 THEN 'mouse down on title bar
173.                 IF mx >= tlx + bxW - 24 THEN EXIT WHILE
174.                 grabx = mx - tlx: graby = my - tly
175.                 DO WHILE mb 'wait for release
176.                     mi = _MOUSEINPUT: mb = _MOUSEBUTTON(1)
177.                     mx = _MOUSEX: my = _MOUSEY
178.                     IF mx - grabx >= 0 AND mx - grabx <= sw - bxW AND my - graby >= 0 AND my - graby <= sh - bxH THEN
179.                         'attempt to speed up with less updates
180.                         IF ((lastx - (mx - grabx)) ^ 2 + (lasty - (my - graby)) ^ 2) ^ .5 > 10 THEN
181.                             tlx = mx - grabx: tly = my - graby
182.                             CLS
183.                             _PUTIMAGE , backScrn
184.                             _PUTIMAGE (tlx, tly), mbx, curScrn
185.                             lastx = tlx: lasty = tly
186.                             _DISPLAY
187.                         END IF
188.                     END IF
189.                     _LIMIT 400
190.                 LOOP
191.             END IF
192.         END IF
193.         kh = _KEYHIT
194.         IF kh = 27 OR kh = 13 OR kh = 32 THEN EXIT WHILE
195.         _LIMIT 400
196.     WEND
197.  
198.     'put things back
199.     COLOR _RGB32(255, 255, 255), _RGB32(0, 0, 0): CLS '
200.     _PUTIMAGE , backScrn
201.     _DISPLAY
202.     _FREEIMAGE backScrn
203.     _FREEIMAGE mbx
204.     scnState 1 'Thanks Steve McNeill
205. END SUB
206.  
207. ' for saving and restoring screen settins
208. SUB scnState (restoreTF AS INTEGER) 'Thanks Steve McNeill
209.     STATIC Font AS LONG, DefaultColor AS _UNSIGNED LONG, BackGroundColor AS _UNSIGNED LONG, Dest AS LONG, Source AS LONG
210.     STATIC row AS INTEGER, col AS INTEGER, autodisplay AS INTEGER, mb AS INTEGER
211.     IF restoreTF THEN
212.         _FONT Font
213.         COLOR DefaultColor, BackGroundColor
214.         _DEST Dest
215.         _SOURCE Source
216.         LOCATE row, col
217.         IF autodisplay THEN _AUTODISPLAY ELSE _DISPLAY
218.         _KEYCLEAR
219.         WHILE _MOUSEINPUT: WEND 'clear mouse clicks
220.         mb = _MOUSEBUTTON(1)
221.         IF mb THEN
222.             DO
223.                 WHILE _MOUSEINPUT: WEND
224.                 mb = _MOUSEBUTTON(1)
225.                 _LIMIT 100
226.             LOOP UNTIL mb = 0
227.         END IF
228.     ELSE
229.         Font = _FONT: DefaultColor = _DEFAULTCOLOR: BackGroundColor = _BACKGROUNDCOLOR
230.         Dest = _DEST: Source = _SOURCE
231.         row = CSRLIN: col = POS(0): autodisplay = _AUTODISPLAY
232.     END IF
233. END SUB
234.  
235. ' You can grab this box by title and drag it around screen for full viewing while answering prompt.
236. ' Only one line allowed for prompt$
237. ' boxWidth is 4 more than the allowed length of input, it needs to be longer than title$ and prompt$ also
238. ' Utilities > Input Box > Input Box 1 tester v 2019-07-31
239. FUNCTION inputBox$ (prompt$, title$, boxWidth AS _BYTE)
240.     DIM ForeColor AS _UNSIGNED LONG, BackColor AS _UNSIGNED LONG, White AS _UNSIGNED LONG
241.     DIM sw AS INTEGER, sh AS INTEGER, curScrn AS LONG, backScrn AS LONG, ibx AS LONG 'some handles
242.  
243.     'colors
244.     ForeColor = &HFF000055 '<  change as desired  prompt text color, back color or type in area
245.     BackColor = &HFF6080CC '<  change as desired  used fore color in type in area
246.     White = &HFFFFFFFF
247.  
248.     'items to restore at exit
249.     scnState 0
250.  
251.     'screen snapshot
252.     sw = _WIDTH: sh = _HEIGHT: curScrn = _DEST
253.     backScrn = _NEWIMAGE(sw, sh, 32)
254.     _PUTIMAGE , curScrn, backScrn
255.  
256.     'moving box around on screen
257.     DIM bxW AS INTEGER, bxH AS INTEGER
258.     DIM mb AS INTEGER, mx AS INTEGER, my AS INTEGER, mi AS INTEGER, grabx AS INTEGER, graby AS INTEGER
259.     DIM tlx AS INTEGER, tly AS INTEGER 'top left corner of message box
260.     DIM lastx AS INTEGER, lasty AS INTEGER
261.     DIM inp$, kh&
262.  
263.     'draw message box
264.     bxW = boxWidth * 8: bxH = 7 * 16
265.     ibx = _NEWIMAGE(bxW, bxH, 32)
266.     _DEST ibx
267.     COLOR &HFF880000, White
268.     LOCATE 1, 1: PRINT LEFT$(SPACE$(INT((boxWidth - LEN(title$) - 3)) / 2) + title$ + SPACE$(boxWidth), boxWidth)
269.     COLOR White, &HFFBB0000
270.     LOCATE 1, boxWidth - 2: PRINT " X "
271.     COLOR ForeColor, BackColor
272.     LOCATE 2, 1: PRINT SPACE$(boxWidth);
273.     LOCATE 3, 1: PRINT LEFT$(SPACE$((boxWidth - LEN(prompt$)) / 2) + prompt$ + SPACE$(boxWidth), boxWidth);
274.     LOCATE 4, 1: PRINT SPACE$(boxWidth);
275.     LOCATE 5, 1: PRINT SPACE$(boxWidth);
276.     LOCATE 6, 1: PRINT SPACE$(boxWidth);
277.     inp$ = ""
278.     GOSUB finishBox
279.  
280.     'convert to pixels the top left corner of box at moment
281.     bxW = boxWidth * 8: bxH = 5 * 16
282.     tlx = (sw - bxW) / 2: tly = (sh - bxH) / 2
283.     lastx = tlx: lasty = tly
284.     _KEYCLEAR
285.     'now allow user to move it around or just read it
286.     WHILE 1
287.         CLS
288.         _PUTIMAGE , backScrn
289.         _PUTIMAGE (tlx, tly), ibx, curScrn
290.         _DISPLAY
291.         WHILE _MOUSEINPUT: WEND
292.         mx = _MOUSEX: my = _MOUSEY: mb = _MOUSEBUTTON(1)
293.         IF mb THEN
294.             IF mx >= tlx AND mx <= tlx + bxW AND my >= tly AND my <= tly + 16 THEN 'mouse down on title bar
295.                 IF mx >= tlx + bxW - 24 THEN EXIT WHILE
296.                 grabx = mx - tlx: graby = my - tly
297.                 DO WHILE mb 'wait for release
298.                     mi = _MOUSEINPUT: mb = _MOUSEBUTTON(1)
299.                     mx = _MOUSEX: my = _MOUSEY
300.                     IF mx - grabx >= 0 AND mx - grabx <= sw - bxW AND my - graby >= 0 AND my - graby <= sh - bxH THEN
301.                         'attempt to speed up with less updates
302.                         IF ((lastx - (mx - grabx)) ^ 2 + (lasty - (my - graby)) ^ 2) ^ .5 > 10 THEN
303.                             tlx = mx - grabx: tly = my - graby
304.                             CLS
305.                             _PUTIMAGE , backScrn
306.                             _PUTIMAGE (tlx, tly), ibx, curScrn
307.                             lastx = tlx: lasty = tly
308.                             _DISPLAY
309.                         END IF
310.                     END IF
311.                     _LIMIT 400
312.                 LOOP
313.             END IF
314.         END IF
315.         kh& = _KEYHIT
316.         SELECT CASE kh& 'whew not much for the main event!
317.             CASE 13: EXIT WHILE
318.             CASE 27: inp$ = "": EXIT WHILE
319.             CASE 32 TO 128: IF LEN(inp$) < boxWidth - 4 THEN inp$ = inp$ + CHR$(kh&): GOSUB finishBox ELSE BEEP
320.             CASE 8: IF LEN(inp$) THEN inp$ = LEFT$(inp$, LEN(inp$) - 1): GOSUB finishBox ELSE BEEP
321.         END SELECT
322.  
323.         _LIMIT 60
324.     WEND
325.  
326.     'put things back
327.     scnState 1 'need fg and bg colors set to cls
328.     CLS '? is this needed YES!!
329.     _PUTIMAGE , backScrn
330.     _DISPLAY
331.     _FREEIMAGE backScrn
332.     _FREEIMAGE ibx
333.     scnState 1 'because we have to call _display, we have to call this again
334.     inputBox$ = inp$
335.     EXIT FUNCTION
336.  
337.     finishBox:
338.     _DEST ibx
339.     COLOR BackColor, ForeColor
340.     LOCATE 5, 2: PRINT LEFT$(" " + inp$ + SPACE$(boxWidth - 2), boxWidth - 2)
341.     _DEST curScrn
342.     RETURN
343. END FUNCTION
344.  
345.  

[johnno56]

bplus,

Excellent menu. Very cool.

J

[bplus]

Hi Johnno,

Menu? but thanks :D

I just got a new one today (palindrome):
Never odd or even.

[SMcNeill]

How about an extended timer, to prevent those annoying bugs where you're running a program at midnight and the clock resets?

Code: QB64: [Select]

1. SHELL "https://www.epochconverter.com/"
2. DO
3.     CLS
4.     PRINT TIMER, INT(ExtendedTimer)
5.     PRINT "Compare to the time at https://www.epochconverter.com/"
6.     _DISPLAY
7.     _LIMIT 10
8. LOOP
9.  
10. FUNCTION ExtendedTimer##
11.     d$ = DATE$
12.     l = INSTR(d$, "-")
13.     l1 = INSTR(l + 1, d$, "-")
14.     m = VAL(LEFT$(d$, l))
15.     d = VAL(MID$(d$, l + 1))
16.     y = VAL(MID$(d$, l1 + 1)) - 1970
17.     FOR i = 1 TO m
18.         SELECT CASE i 'Add the number of days for each previous month passed
19.             CASE 1: d = d 'January doestn't have any carry over days.
20.             CASE 2, 4, 6, 8, 9, 11: d = d + 31
21.             CASE 3: d = d + 28
22.             CASE 5, 7, 10, 12: d = d + 30
23.         END SELECT
24.     NEXT
25.     FOR i = 1 TO y
26.         d = d + 365
27.     NEXT
28.     FOR i = 2 TO y STEP 4
29.         IF m > 2 THEN d = d + 1 'add an extra day for leap year every 4 years, starting in 1970
30.     NEXT
31.     d = d - 1 'for year 2000
32.     s~&& = d * 24 * 60 * 60 'Seconds are days * 24 hours * 60 minutes * 60 seconds
33.     ExtendedTimer## = (s~&& + TIMER)
34. END FUNCTION
35.  

[bplus]

Here is a math one, for calculating nCr without fully processed factorials to get around the 21 limit on factorials.

Code: QB64: [Select]

1. OPTION _EXPLICIT ' B+ started 2019-10-23
2. _TITLE "Alternate Calc of nCr, the number of Combinations of n things taken r at a time."
3. ' Though this method is still quite limited at least it does not depend upon the full calculation
4. ' of a factorial to return a result.
5. ' You can do n up to at least 50 with r's at 1/2 n, and smaller r's for higher n's.
6. ' Be very careful accepting returns as correct.
7.  
8. DIM n AS INTEGER, r AS INTEGER
9. PRINT "The number of hands of 13 in a deck is ";
10. PRINT USING "###,###,###,###,###.###"; nCr(52, 13)
11. PRINT "                                compare to 635,013,559,600"
12. DO
13.     INPUT "Enter n, r to calculate nCr (0's to quit) "; n, r
14.     IF n > 0 AND r > 0 AND r < n THEN
15.         PRINT " nCr = "; nCr(n, r)
16.     END IF
17. LOOP UNTIL n = 0 OR r = 0
18.  
19. FUNCTION nCr~&& (n AS INTEGER, r AS INTEGER)
20.     'Note: I am using notes from a successful calc to generalize this method.
21.     ' How many hands of 13 from a deck?
22.     ' Formula for Combination of N items taken R at a time = N!/(R! * (N-R)!) so we need
23.     ' 52! / (39! * 13!) =    52 * 51 * 50 * 49 * ... * 40  / 13 * 12 * 11 * ...      * 1
24.  
25.     DIM a AS INTEGER, i AS INTEGER, j AS INTEGER, found AS INTEGER
26.     DIM numerator AS _UNSIGNED _INTEGER64, denomenator AS _UNSIGNED LONG
27.     a = n - r
28.     IF a < r THEN r = a 'results are symmteric for r and n-r so use smaller of 2
29.     a = n - r
30.  
31.     DIM numer(1 TO r) AS INTEGER, denom(1 TO r) AS INTEGER
32.     ' DIM a52_39(1 TO 13) AS INTEGER, a13(1 TO 13) AS INTEGER
33.     FOR i = 1 TO r
34.         numer(i) = a + i ' = 40, 41, 42, 43, ... 52 numerator multipliers
35.         denom(i) = i '     =  1,  2,  3,  4, ... 13 denominator multipliers
36.     NEXT
37.  
38.     ' To keep the numerator from getting too big reduce by demoinator terms that divide evenly
39.     FOR i = r TO 2 STEP -1
40.         found = 0
41.         FOR j = 1 TO r 'is the array item divisible by i
42.             IF numer(j) MOD i = 0 THEN numer(j) = numer(j) \ i: found = 1: EXIT FOR
43.         NEXT
44.         IF found = 1 THEN denom(i) = 1
45.     NEXT
46.  
47.     ' multiply whats left in numerator and denomiator
48.     numerator = 1: denomenator = 1
49.     FOR i = 1 TO r
50.         numerator = numerator * numer(i) 'multiple numerators left
51.         denomenator = denomenator * denom(i) 'multiply denominators left
52.     NEXT
53.     nCr~&& = numerator \ denomenator
54. END FUNCTION
55.  

Here is a demo: https://www.qb64.org/forum/index.php?topic=1792.msg110362#msg110362

Update: 2019-10-28 You are safe using this function to get you past 20! with straight calculation nCR to n=52 after 52 you might want to check calculations against a ball park estimate. If nCr gets the amount of digits right then it is likely precise down to last digit. If the number of digits are off then obviously the precision doesn't matter, it wont be of use.

UPDATE: String Math$ has solved problem of extended factorials check this thread out starting about here:
https://www.qb64.org/forum/index.php?topic=2921.msg121797#msg121797

[STxAxTIC]

I like this work-around bplus. Maybe a few functions along the lines of combinatorics wouldn't be a bad idea... And the problem of large numbers reminds me of something else...

[bplus]

Thanks [banned user] for getting me to write this up. It is a must have for this collection:

Code: QB64: [Select]

1. _TITLE "Quick demo of Fisher-Yates " 'B+ 2019-10-27
2. ' 2019-10-28 slight change from Steve suggestion
3. RANDOMIZE TIMER
4.  
5. low = -5
6. high = 5
7. DIM deck(low TO high) AS INTEGER
8.  
9. PRINT "Deck: ";
10. FOR c = low TO high
11.     deck(c) = c
12.     PRINT c; ", ";
13. NEXT
14. PRINT: PRINT
15.  
16. FOR i = 1 TO 5
17.     PRINT "Shuffling..."
18.     'F-Y shuffle, now 3 liner thanks to Steve suggestion
19.     FOR c = high TO low + 1 STEP -1
20.         SWAP deck(c), deck(INT(RND * (c - low + 1)) + low)
21.     NEXT
22.  
23.     'show deck
24.     PRINT "Deck: ";
25.     FOR c = low TO high
26.         PRINT deck(c); ", ";
27.     NEXT
28.     PRINT: PRINT
29. NEXT
30.  

Update: FY Shuffle now 3 liner thanks to Steve's suggestion, removed the variable assignment.

[bplus]

A very common problem, recently brought up by acjacques
https://www.qb64.org/forum/index.php?topic=1785.0

With less keystrokes than STR$(number), you can string it and trim it!

Code: QB64: [Select]

1. FUNCTION ts$ (number)  'ts stands for trim string
2.     ts$ = _TRIM$(STR$(number))
3. END FUNCTION
4.  

[bplus]

LoadSort but you have to adjust code to the Type of Array you are building and the type of Sort ie ascending of descending. Just modify the IF line as needed for the sort condition.

Just as the _TITLE says: Load and Sort an array at the same time, handy to automatically sort an array while you are loading it. Not intended for giant arrays that need number crunching routines to save time.

Code: QB64: [Select]

1. _TITLE "LoadSort array" 'b+ 2020-06-07 from loadSortD
2. 'this better than loadSortD because you don't need to share the array nor over DIM it
3. ' It works like append filing the item into the array list
4. DO
5.     REDIM d(0) AS STRING 'clear last array, d(0) stays empty
6.     FOR i = 1 TO 10
7.         r$ = RIGHT$("  " + STR$(RND * 100 \ 1), 2)
8.         IF r$ = "00" THEN r$ = " 0" '0 to 100 range
9.         loadSort r$, d()
10.         PRINT r$
11.     NEXT
12.     PRINT "Final array:"
13.     FOR i = 1 TO 10 'note we never use d(0) left empty
14.         PRINT i, d(i)
15.     NEXT
16.     INPUT "Press enter to do again, any other quits "; quit$
17.     CLS
18. LOOP UNTIL LEN(quit$)
19.  
20. SUB loadSort (insertN AS STRING, dynArr() AS STRING) ' note this leaves dynArr(0) empty! so ubound of array is also number of items in list
21.     DIM ub, j, k
22.     ub = UBOUND(dynArr) + 1
23.     REDIM _PRESERVE dynArr(LBOUND(dynArr) TO ub) AS STRING
24.     FOR j = 1 TO ub - 1
25.         IF insertN > dynArr(j) THEN ' GT to LT according to descending or ascending sort
26.             FOR k = ub TO j + 1 STEP -1
27.                 dynArr(k) = dynArr(k - 1)
28.             NEXT
29.             EXIT FOR
30.         END IF
31.     NEXT
32.     dynArr(j) = insertN
33. END SUB
34.  
35.  

Embed code like this into place you are loading a smallish array you want sorted.

Edited with Steve's suggestion, thanks Steve!
x2 Edit thanks again Steve!
x3 Edit found another huge line savings, cut 4 lines, demo using Type Definition for array: https://www.qb64.org/forum/index.php?topic=1833.msg110748#msg110748

2020-06-07 Edit #4 now? While working on Gin Rummy, I needed to load card arrays according to highest points first. This new version is a sub routine, does not need oversized array already DIM and SHARED.

It is better than sAppend! if you need a sorted array while loading it.

[SMcNeill]

You can remove that variable “stored” in the above and save some memory and processing.

Instead of IF stored = 0 THEN, change that statement to IF j = i THEN..

When you store a value, you exit J early, so it’s always less than I, but if it searches the whole loop, it terminates at (I - 1) + 1, which is I.

It saves setting and resetting the variable each pass of I.  ;)

[bplus]

Beautiful! Thanks Steve, code has been edited.

[SMcNeill]

Actually, you can simplify it even more.  Just remove the IF completely and make n(j) = num.

In the loop, you set n(j) then exit the loop.
Outside the loop, if I = J then you set n(I)...  but since I = J, you could set n(J) instead...

And, if you set n(j) inside the loop, as well as outside the loop, you can simplify down to just *always* setting it once at the end of the loop.  No IF needed, and no need to set it inside the loop either.  ;)

[bplus]

Ha! the less lines the more I like it, thanks again Steve!

Code edited again.