For folks who may be interested in trying their hands at writing a Sudoku puzzle, but don't have any clue about how to make a puzzle generator, I give you -- ONE MILLION GAMES OF SUDOKU!!
TYPE Sudoku
Puzzle ASSTRING * 81'the puzzle from left to right, top to bottom
Answer ASSTRING * 81'the solution from left to right, top to bottom
CRLF ASSTRING * 1'chr$(10) END TYPE
temp$ = _READFILE$("sudoku.dta") 'read the compressed data file
t$ = _INFLATE$(temp$) ' inflate it
m = _MEM(Sudoku()) ' get the memblock for the data array _MEMPUT m, m.OFFSET, t$ ' and put the data in it all at once _MEMFREE m ' free the mem handle as we don't need it any longer
Above is the simplest way I could come up with to get that whole dataset and load it into an array for use.
If you don't want to use the memory to store the whole array, or you're wanting to bypass the disk read time to read it all, feel free to extract that file and _INFLATE it. The data is stored in very simple to read and use strings.
81 characters for the puzzle.
81 characters for the answer.
1 character for the End of Line (chr$(10)) character.
You can read those files AS RANDOM and read them one at a time. You can use SEEK and read them in LINE INPUT.
Once you have your games however you want them, all that's left at that point is just to make your interface with the grids, movement, and number input.
The puzzles are all here, along with their answers. What you decide to do with them is up to you.
Print them out, so you can take them on the bus, to the doctors, or wherever you want, to play with them.
Make your own game with them.
I don't care! I just thought I'd share, in case anyone might be interested in a million games of Sudoku!
Hello,
I 'm new on this forum and I'm very happy there are a lot of programmers using QB64.
In the past I did a lot of programming with Basic PDS and ASM-routines of AJS (LA) (Multi-user access dbf files).
So I med a lot of manufacturing and color mixing software for paints.
Now retreated, I'm busy to make my own beer-brewing software (I want it good but not to complicated...).
I worked a little time with Freebasic, but it became quiet on their forum, so I switched to QB45
I'm trying to build a prog to compare different sorting algorithms (yes, I know it's been done a zillion times).
But when I try to use Timer to find the execution time, it seems to go back to the Start time, giving me expired time of zero.
I've experimented with _Limit, to see if the system was having problems keeping up or something, and these give some expired time,
but these depend on what _limit I use, so they alter the readings.
In the small sample here, what am I missing?
Code: (Select All)
DefDbl T
Randomize Timer
MakeList:
Print Tab(30); "Create 104 Unsorted elements (4 sets A to Z)"
Dim EL$(104)
For a = 1 To 26
For b = 0 To 3
EL$(a + b * 26) = Chr$(Int(Rnd * 26) + 65)
Print EL$(a + b * 26); " ";
Next
Next
T1 = Timer ' start time
Print: Print "Start time is"; T1
BubbleSort:
pass = pass + 1
For a = 1 To UBound(EL$) - 1 ' for first element to last-1 element of Orig$() array
' _Limit 30
'_limit 300
'_limit 3000
' _Limit 30000
If EL$(a) > EL$(a + 1) Then ' if this element is greater than next element, swap them,
Swap EL$(a), EL$(a + 1)
swop = 1 ' and flag that a swap was made in this pass
End If
Next
If swop = 1 Then swop = 0: GoTo BubbleSort '
T2 = Timer ' finish time
Print: Print "Finish time is"; T2
For a = 1 To 104: Print EL$(a); " ";: Next
Print: Print: Print "T1 is"; T1, "T2 is"; T2
Print: Print Tab(10); "Sorted in "; T2 - T1; "seconds, with "; pass; "passes"
Welcome to another KotD. In this edition, we're exploring _ULineSpacing. I'm hosting KotD this week. While my writing skills may not match Steve's, I will do my best. Full disclosure: I'm not a typography expert. Much of the content below is based on what I learned during the rewrite of the QB64-PE font support.
In the last KotD, Steve discussed _UFontHeight. You might be curious about the difference between _UFontHeight and _ULineSpacing, as they seem similar and can even return identical values. However, they are quite different; _UFontHeight returns the global glyph height of a font, whereas _ULineSpacing returns the height from one baseline to the next (baseline-to-baseline height).
The baseline is the imaginary line on which characters sit, serving as a reference point for glyph placement within a font. The ascent is the maximum pixel height above the baseline and is typically a positive value. The descent is the maximum pixel depth below the baseline, usually a negative value. The line gap represents the extra spacing required between two lines of text.
Therefore, baseline-to-baseline height can be expressed using the following formula:
So, what does this all mean? Essentially, it means that when printing multiple lines and needing to calculate the Y pixel positions, one should use _ULineSpacing instead of _UFontHeight.
When one spends a lot of time clacking away on keyboards, they tend to have a preference for a certain feel and sound.
What's your preferred keyboard? I don't despise membrane keyboards, but I don't ever want to go back! It's been fun customizing the look, feel, and sound. If the keyboard gets boring, or your work environment changes, you can re-customize it.
[ I promise nothing is a paid advertisement in this post. It's rambly and contains non-affiliate links in case anything is of interest. For the love of BASIC, if replying, please don't quote the whole thing!]
I've got two main keyboards, recently having swapped the key switches between them:
These retro domed key caps and the clickiness seem to be a great combo. The click of the switches doesn't reverberate in this keyboard like in the 8bitdo, which combined with the key profile, did something subtle to the sound. Sharp and ticky. I still wouldn't be comfortable using these switches in a shared office, but that's the tradeoff of a satisfyingly clicky switch.
With the brown tactile switches inside this housing, along with those flat key caps, there's a nice but not overpowered thock. The 8bitdo keyboard is a loud one with the stock white switches, and I think it was overkill with this housing and the caps. The sound of the caps themselves reaching the end of their travel is a lovely thock. Combined with the tactile bump of the new Keychron brown switches, it's satisfying feedback, while also being a keyboard you can type gently and quietly on when necessary. I also feel it's a little more theme-appropriate as the buttons on an NES controller are membrane and quiet.
I am quite pleased with the latest models of the 8bitdo keyboard, though: a Commodore 64 model, and an IBM Model M:
People complain they can't use these on MacOS or Linux as the key mapping software is just for Windows. But as long as you have any access to a Windows OS, just install the configuration software, swap some keys around, and save it as a new profile which gets stored directly on the keyboard. Push one button and now it's in Mac mode, and can toggle back to Windows just as easily. Doesn't seem like a big deal to me unless people are annoyed by the improper labels on the keys.
What I would love to be able to do, is to use The C64 Maxi with QB64 PE:
I've had three error-messages in the last few minutes: Unable to load this page (or something similar). Anyone else, or is it just me???
Trying to see last post to threads.
'Note that there are two SHARED variables which we can make use of with this set of code: 'ConvertToStandard256Palette and SaveTextAs256Color '(Long arse names, I know, but they shouldn't have any name collisions with other's code like so.)
'SaveTextAs256Color is a flag we can set to save Screen 0 screens in 256 color mode. 'If it's not TRUE (has a value of 0), then we save Screen 0 screens in 32-bit color mode. 'Dim a LONG varialbe with this name, and set it to non-zero, if you want to save in 256 colors, 'which have smaller file sizes usually.
'ConvertToStandard256Palette is a flag we set to decide if we want to reduce 32-bit color screens 'down to the standard 256-color QB64PE palette, or if we want to use whatever colors best suit 'the image. 'Set the value to 0 (FALSE) to preseve the color information perfectly, using its default palette. 'If the value is set (TRUE), then we convert our colors to as close of a match as possible, while 'preserving the standard QB64 256-color palette.
'For this brief demo here, neither are in effect, as they're completely optional flags.
FUNCTIONSaveImage (file$, image&, tx1%, ty1%, tx2%, ty2%) 'This routine can benefit/be altered if the user sets a couple of CONST or DIM SHARED variables 'to alter the behavior of things a little, as so:
'SaveTextAs256Color is a flag we can set to save Screen 0 screens in 256 color mode. 'If it's not TRUE (has a value of 0), then we save Screen 0 screens in 32-bit color mode. 'Dim a LONG varialbe with this name, and set it to non-zero, if you want to save in 256 colors, 'which have smaller file sizes usually.
'ConvertToStandard256Palette is a flag we set to decide if we want to reduce 32-bit color screens 'down to the standard 256-color QB64PE palette, or if we want to use whatever colors best suit 'the image. 'Set the value to 0 (FALSE) to preseve the color information perfectly, using its default palette. 'If the value is set (TRUE), then we convert our colors to as close of a match as possible, while 'preserving the standard QB64 256-color palette.
'ERROR CODES WHICE WE CAN GENERATE: '1 File Already Exists. As these are Binary files, we probably don't want to just overwrite the same file. '2 WINDOW coordinates not supported. Convert to standard coordinates before using SaveImage. '3 Bad x/y coordinates which are beyond the bounds of the screen. '4 Bad file format passed to be saved. '5 Image Failed to save for some unknown reason. Sorry.
ext$ = RIGHT$(file$, 3) 'get the extension SELECT CASEUCASE$(ext$) CASE"JPG", "PNG", "TGA", "BMP", "PSD", "GIF", "HDR", "PIC", "PNM", "PCX", "SVG", "QOI" 'built in _SaveImage formats. All these are good. CASE"GIF" 'this is good, as this is included in the SaveImage Library here. CASEELSE
glitch = 4'any glitch here is from an invalid extension on the file$ END SELECT
'If we've made it to here, then everything should pass muster and be good for saving. 'No other file exists that we'd try to overwrite. (Error 1) -- check! 'Window coordinates are not in play to screw up anything. (Error 2) -- check! 'Our x/y coorinates are actually on the screen. (Error 3) -- check! 'And we're in a valid and recognized format. (Error 4) -- check!
SELECT CASE bpp CASE0'we have to convert our screen 0 image to a graphic image IF SaveTextAs256Color <> 0ORUCASE$(ext$) = "GIF"THEN
tempimage& = TextScreenToImage256&(image&) ELSE
tempimage& = TextScreenToImage32&(image&) END IF
F = _FONT(image&)
FW = _FONTWIDTH(F): FH = _FONTHEIGHT(F) SaveImage = SaveImage(file$, tempimage&, (x1% - 1) * FW, (y1% - 1) * FH, x2% * FW - 1, y2% * FH - 1) _FREEIMAGE tempimage& _DEST D: _SOURCE S EXIT FUNCTION CASE1
mode = 256 IFUCASE$(ext$) = "GIF"THEN MakeGIF file$, x1%, y1%, x2%, y2%, 256
SkipCreation = -1 END IF CASE4 IFUCASE$(ext$) = "GIF"THEN'we have to convert 32-bit images down to 256 colors for a GIF
t = Image32To256(image&) 'View comments in FUNCTION Image32To256 for CONST settings to toggle behavior _DEST t: _SOURCE t 'make the converted image our source MakeGIF file$, x1%, y1%, x2%, y2%, 256 _DEST D: _SOURCE S 'restore our source _FREEIMAGE t 'free the converted image
SkipCreation = -1 END IF
mode = 32 END SELECT
IF SkipCreation = 0THEN'we didn't already make the file in GIF format. 'We still need to create it here, in whatever valid format we specified.
Xsize = x2% - x1% + 1: Ysize = y2% - y1% + 1
tempimage& = _NEWIMAGE(Xsize, Ysize, mode) _PUTIMAGE (0, 0)-(Xsize - 1, Ysize - 1), image&, tempimage&, (x1%, y1%)-(x2%, y2%) _SAVEIMAGE file$, tempimage& _FREEIMAGE tempimage& END IF
'We should have now saved our image in whatever format we chose. 'Let's test to make certain that we can load it validly.
tempimage& = _LOADIMAGE(file$) IF tempimage& = -1THEN'we didn't load the image! Something went wrong. SaveImage = 5'Error 5 here is from failure to reload the saved image, for who knows what reason. 'Disk full? Tried to save on a locked drive? USB stick got ejected? I dunno! 'I just know we passed all the tests, *should've* made a file, but when we went to load it 'back, it simply didn't load. 'Honestly, the file may have been written properly and _LOADIMAGE might be glitched, or some such. 'All we know for certain is we tried to save and load the results and something failed. 'Report it with 5, and let the end user sort it out. ELSE SaveImage = 0 _FREEIMAGE tempimage& END IF _DEST D: _SOURCE S END FUNCTION
FUNCTIONImage32To256 (image&) 'This routine can benefit/be altered if the user sets a CONST or DIM SHARED variable name ConvertToStandard256Palette, as so: ' CONST ConvertToStandard256Palette = -1 ' Set the value to 0 (FALSE) to preseve the color information perfectly, using its default palette. ' If the CONST is set (TRUE), then we convert our colors to as close of a match as possible, while ' preserving the standard QB64 256-color palette. DIM o AS_OFFSET DIM a AS_UNSIGNED_BYTE, r AS_UNSIGNED_BYTE DIM g AS_UNSIGNED_BYTE, b AS_UNSIGNED_BYTE DIM t AS_UNSIGNEDLONG, color256 AS_UNSIGNEDLONG DIM index256 AS_UNSIGNEDLONG TYPE Pal_type
c AS_UNSIGNEDLONG'color index
n ASLONG'number of times it appears END TYPE DIM Pal(255) AS_UNSIGNEDLONG
I256 = _NEWIMAGE(_WIDTH(image&), _HEIGHT(image&), 256) DIM m(1) AS_MEM: m(0) = _MEMIMAGE(image&): m(1) = _MEMIMAGE(I256) DO'get the palette and number of colors used _MEMGET m(0), m(0).OFFSET + o, t 'Get the colors from the original screen FOR i = 0TO colors 'check to see if they're in the existing palette we're making IF Pal(i) = t THENEXIT FOR NEXT IF i > colors THEN
Pal(colors) = t
colors = colors + 1'increment the index for the new color found IF colors > 255THEN'no need to check any further; it's not a normal QB64 256 color image Image32To256 = RemapImageFS(image&, I256) _FREEIMAGE I256 _MEMFREE m() EXIT FUNCTION'and we're done, with 100% image compatability saved END IF END IF
o = o + 4 LOOP UNTIL o >= m(0).SIZE
' we might be working with a standard qb64 256 color screen ' check for that first
colors = colors - 1'back up one, as we found our limit and aren't needing to set another FOR i = 0TO colors 'comparing palette against QB64 256 color palette
t = Pal(i)
index256 = _RGBA(_RED32(t), _GREEN32(t), _BLUE32(t), _ALPHA32(t), I256)
color256 = _RGBA32(_RED(index256, I256), _GREEN(index256, I256), _BLUE(index256, I256), _ALPHA(index256, I256)) IF t <> color256 THEN NSCU = -1: EXIT FOR NEXT IF NSCU THEN'it's not a standard QB64 256 color palette, but it's still less than 256 total colors. IF ConvertToStandard256Palette THEN
TI256 = RemapImageFS(image&, I256) _MEMFREE m(1) 'free the old memory _FREEIMAGE I256 'and the old image
I256 = TI256 'replace with the new image
m(1) = _MEMIMAGE(I256) 'and point the mem block to the new image ELSE FOR i = 0TO colors: _PALETTECOLOR i, Pal(i), I256: NEXT'set the palette END IF END IF 'If we didn't change the palette above, we should work 100% with qb64's internal 256 color palette
o = 0 DO'Get the colors, put them to a 256 color screen, as is _MEMGET m(0), m(0).OFFSET + o + 3, a _MEMGET m(0), m(0).OFFSET + o + 2, r _MEMGET m(0), m(0).OFFSET + o + 1, g _MEMGET m(0), m(0).OFFSET + o + 0, b _MEMPUT m(1), m(1).OFFSET + o \ 4, _RGBA(r, g, b, a, I256) AS_UNSIGNED_BYTE
o = o + 4 LOOP UNTIL o >= m(0).SIZE _MEMFREE m() Image32To256 = I256 END FUNCTION
FUNCTIONRemapImageFS& (ohan&, dhan&) 'Routine written by RhoSigma and used (with permission) for ImageSaver Library '// +---------------+---------------------------------------------------+ '// | ###### ###### | .--. . .-. | '// | ## ## ## # | | )| ( ) o | '// | ## ## ## | |--' |--. .-. `-. . .-...--.--. .-. | '// | ###### ## | | \ | |( )( ) | ( || | |( ) | '// | ## ## | ' `' `-`-' `-'-' `-`-`|' ' `-`-'`- | '// | ## ## # | ._.' | '// | ## ###### | Sources & Documents placed under the MIT License. | '// +-------------------------------------------------------------------+ '// | Done by RhoSigma, R.Heyder, provided AS IS, use at your own risk. | '// | Find me in the QB64 Forum or mail to support@rhosigma-cw.net for | '// | any questions or suggestions. Thanx for your interest in my work. | '// +-------------------------------------------------------------------+
RemapImageFS& = -1'so far return invalid handle
shan& = ohan& 'avoid side effect on given argument IF shan& < -1OR shan& = 0THEN'0 represents the visible screen '--- check/adjust source image & get new 8-bit image ---
swid% = _WIDTH(shan&): shei% = _HEIGHT(shan&) IF_PIXELSIZE(shan&) <> 4THEN
than& = _NEWIMAGE(swid%, shei%, 32) IF than& >= -1THENEXIT FUNCTION _PUTIMAGE , shan&, than&
shan& = than& ELSE
than& = -1'avoid freeing below END IF
nhan& = _NEWIMAGE(swid%, shei%, 256) '--- Floyd-Steinberg error distribution arrays ---
rhan& = _NEWIMAGE(swid%, 2, 32) 'these are missused as LONG arrays,
ghan& = _NEWIMAGE(swid%, 2, 32) 'with CHECKING:OFF this is much faster
bhan& = _NEWIMAGE(swid%, 2, 32) 'than real QB64 arrays '--- curr/next row offsets (for distribution array access) ---
cro% = 0: nro% = swid% * 4'will be swapped after each pixel row '--- the matrix values are extended by 16384 to avoid slow floating --- '--- point ops and to allow for integer storage in the above arrays --- '--- also it's a power of 2, which may be optimized into a bitshift ---
seven% = 7168'(7 / 16) * 16384 'X+1,Y+0 error fraction
three% = 3072'(3 / 16) * 16384 'X-1,Y+1 error fraction
five% = 5120'(5 / 16) * 16384 'X+0,Y+1 error fraction
one% = 1025'(1 / 16) * 16384 'X+1,Y+1 error fraction '--- if all is good, then start remapping --- $CHECKING:OFF IF nhan& < -1AND rhan& < -1AND ghan& < -1AND bhan& < -1THEN _COPYPALETTE dhan&, nhan& 'dest palette to new image '--- for speed we do direct memory access --- DIM sbuf AS_MEM: sbuf = _MEMIMAGE(shan&): soff%& = sbuf.OFFSET DIM nbuf AS_MEM: nbuf = _MEMIMAGE(nhan&): noff%& = nbuf.OFFSET DIM rbuf AS_MEM: rbuf = _MEMIMAGE(rhan&): roff%& = rbuf.OFFSET DIM gbuf AS_MEM: gbuf = _MEMIMAGE(ghan&): goff%& = gbuf.OFFSET DIM bbuf AS_MEM: bbuf = _MEMIMAGE(bhan&): boff%& = bbuf.OFFSET '--- iterate through pixels --- FOR y% = 0TO shei% - 1 FOR x% = 0TO swid% - 1 '--- curr/prev/next pixel offsets ---
cpo% = x% * 4: ppo% = cpo% - 4: npo% = cpo% + 4 '--- get pixel ARGB value from source ---
srgb~& = _MEMGET(sbuf, soff%&, _UNSIGNEDLONG) '--- add distributed error, shrink by 16384, clear error --- '--- current pixel X+0, Y+0 (= cro% (current row offset)) ---
poff% = cro% + cpo% 'pre-calc full pixel offset
sr% = ((srgb~& AND&HFF0000~&) \ 65536) + (_MEMGET(rbuf, roff%& + poff%, LONG) \ 16384) 'red
sg% = ((srgb~& AND&HFF00~&) \ 256) + (_MEMGET(gbuf, goff%& + poff%, LONG) \ 16384) 'green
sb% = (srgb~& AND&HFF~&) + (_MEMGET(bbuf, boff%& + poff%, LONG) \ 16384) 'blue _MEMPUT rbuf, roff%& + poff%, 0ASLONG'clearing each single pixel error using _MEMPUT _MEMPUT gbuf, goff%& + poff%, 0ASLONG'turns out even faster than clearing the entire _MEMPUT bbuf, boff%& + poff%, 0ASLONG'pixel row using _MEMFILL at the end of the loop '--- find nearest color ---
crgb~& = _RGBA32(sr%, sg%, sb%, 0) 'used for fast value clipping + channel merge
npen% = _RGB(sr%, sg%, sb%, nhan&) '--- put colormapped pixel to dest --- _MEMPUT nbuf, noff%&, npen% AS_UNSIGNED_BYTE '------------------------------------------ '--- Floyd-Steinberg error distribution --- '------------------------------------------ '--- You may comment this block out, to see the '--- result without applied FS matrix. '----- '--- get dest palette RGB value, calc error to clipped source ---
nrgb~& = _PALETTECOLOR(npen%, nhan&)
er% = ((crgb~& AND&HFF0000~&) - (nrgb~& AND&HFF0000~&)) \ 65536
eg% = ((crgb~& AND&HFF00~&) - (nrgb~& AND&HFF00~&)) \ 256
eb% = (crgb~& AND&HFF~&) - (nrgb~& AND&HFF~&) '--- distribute error according to FS matrix --- IF x% > 0THEN '--- X-1, Y+1 (= nro% (next row offset)) ---
poff% = nro% + ppo% 'pre-calc full pixel offset _MEMPUT rbuf, roff%& + poff%, _MEMGET(rbuf, roff%& + poff%, LONG) + (er% * three%) ASLONG'red _MEMPUT gbuf, goff%& + poff%, _MEMGET(gbuf, goff%& + poff%, LONG) + (eg% * three%) ASLONG'green _MEMPUT bbuf, boff%& + poff%, _MEMGET(bbuf, boff%& + poff%, LONG) + (eb% * three%) ASLONG'blue END IF '--- X+0, Y+1 (= nro% (next row offset)) ---
poff% = nro% + cpo% 'pre-calc full pixel offset _MEMPUT rbuf, roff%& + poff%, _MEMGET(rbuf, roff%& + poff%, LONG) + (er% * five%) ASLONG'red _MEMPUT gbuf, goff%& + poff%, _MEMGET(gbuf, goff%& + poff%, LONG) + (eg% * five%) ASLONG'green _MEMPUT bbuf, boff%& + poff%, _MEMGET(bbuf, boff%& + poff%, LONG) + (eb% * five%) ASLONG'blue IF x% < (swid% - 1) THEN '--- X+1, Y+0 (= cro% (current row offset)) ---
poff% = cro% + npo% 'pre-calc full pixel offset _MEMPUT rbuf, roff%& + poff%, _MEMGET(rbuf, roff%& + poff%, LONG) + (er% * seven%) ASLONG'red _MEMPUT gbuf, goff%& + poff%, _MEMGET(gbuf, goff%& + poff%, LONG) + (eg% * seven%) ASLONG'green _MEMPUT bbuf, boff%& + poff%, _MEMGET(bbuf, boff%& + poff%, LONG) + (eb% * seven%) ASLONG'blue '--- X+1, Y+1 (= nro% (next row offset)) ---
poff% = nro% + npo% 'pre-calc full pixel offset _MEMPUT rbuf, roff%& + poff%, _MEMGET(rbuf, roff%& + poff%, LONG) + (er% * one%) ASLONG'red _MEMPUT gbuf, goff%& + poff%, _MEMGET(gbuf, goff%& + poff%, LONG) + (eg% * one%) ASLONG'green _MEMPUT bbuf, boff%& + poff%, _MEMGET(bbuf, boff%& + poff%, LONG) + (eb% * one%) ASLONG'blue END IF '------------------------------------------ '--- End of FS ---------------------------- '------------------------------------------
noff%& = noff%& + 1'next dest pixel
soff%& = soff%& + 4'next source pixel NEXT x%
tmp% = cro%: cro% = nro%: nro% = tmp% 'exchange distribution array row offsets NEXT y% '--- memory cleanup --- _MEMFREE bbuf _MEMFREE gbuf _MEMFREE rbuf _MEMFREE nbuf _MEMFREE sbuf '--- set result --- RemapImageFS& = nhan&
nhan& = -1'avoid freeing below END IF $CHECKING:ON '--- remapping done or error, cleanup remains --- IF bhan& < -1THEN_FREEIMAGE bhan& IF ghan& < -1THEN_FREEIMAGE ghan& IF rhan& < -1THEN_FREEIMAGE rhan& IF nhan& < -1THEN_FREEIMAGE nhan& IF than& < -1THEN_FREEIMAGE than& END IF END FUNCTION
'----------------------------------------------------------------------------- ' GIFcreate.BM Compression Routine v1.00 By Rich Geldreich 1992 ' Converted into one SUB Library routine by Ted Weissgerber 2011 ' Copied from QB64 wiki and inserted into SaveImage library 2019 '----------------------------------------------------------------------------- ' For 1 BPP, 4 BPP or 8 BPP images only! 'file$ = save image output filename 'XStart = <-left hand column of area to encode 'YStart = <-upper row of area to encode 'Xend = <-right hand column of area to encode 'Yend = <-lowest row of area to encode " 'NumColors = # of colors on screen: 2(Black & White), 16(SCREEN 12), 256(SCREEN13) '
SUBMakeGIF (file$, Xstart, YStart, Xend, Yend, NumColors) IF Xend = _WIDTHTHEN Xend = _WIDTH - 1'Minor correct to prevent many simple user errors IF Yend = _WIDTHTHEN Yend = _HEIGHT - 1'
CONST True = -1, False = 0 CONST Table.size = 7177'hash table's size - must be a prime number!
temp = "GIF87a": PUT #GIF, , temp 'Put GIF87a header at beginning of file
SELECT CASE NumColors 'get color settings CASE2'monochrome (B&W) image
BitsPixel = 1'1 bit per pixel
StartSize = 3'first LZW code is 3 bits
StartCode = 4'first free code
StartMax = 8'maximum code in 3 bits CASE16'16 colors images SCREENS 7, 8, 9, 12, 13
BitsPixel = 4'4 bits per pixel
StartSize = 5'first LZW code is 5 bits
StartCode = 16'first free code
StartMax = 32'maximum code in 5 bits CASE256'256 color images SCREEN 13 or _NEWIMAGE 256
BitsPixel = 8'8 bits per pixel
StartSize = 9'first LZW code is 9 bits
StartCode = 256'first free code
StartMax = 512'maximum code in 9 bits END SELECT
'ColorBits = 2 'for EGA
ColorBits = 6'VGA monitors ONLY
PUT #GIF, , PWidth% 'put screen's dimensions PUT #GIF, , PDepth%
CP = 128 + (ColorBits - 1) * 16 + (BitsPixel - 1) 'pack colorbits and bits per pixel PUT #GIF, , CP
Zero$ = CHR$(0) 'PUT a zero into the GIF file PUT #GIF, , Zero$
OUT&H3C7, 0'start read at color 0 FOR C = 0TO NumColors - 1'Get the RGB palette from the screen and put into file
R = (INP(&H3C9) * 65280) \ 16128'C = R * 4.0476190(for 0-255)
G = (INP(&H3C9) * 65280) \ 16128
B = (INP(&H3C9) * 65280) \ 16128
temp = CHR$(R): PUT #GIF, , temp
temp = CHR$(G): PUT #GIF, , temp
temp = CHR$(B): PUT #GIF, , temp NEXT 'write out an image descriptor
temp = ","'image separator PUT #GIF, , temp 'write it PUT #GIF, , MinX 'image start locations PUT #GIF, , MinY PUT #GIF, , PWidth% 'store them into the file PUT #GIF, , PDepth%
temp = CHR$(BitsPixel - 1) '# bits per pixel in the image PUT #GIF, , temp
temp = CHR$(StartSize - 1) 'store the LZW minimum code size PUT #GIF, , temp
CurrentBit = 0: CHAR& = 0'Initialize the vars needed by PutCode
MaxCode = StartMax 'the current maximum code size
CodeSize = StartSize 'the current code size
ClearCode = StartCode 'ClearCode & EOF code are the
EOFCode = StartCode + 1'first two entries
StartCode = StartCode + 2'first free code that can be used
NextCode = StartCode 'the current code
OutBuffer$ = STRING$(5000, 32) 'output buffer; for speedy disk writes
Buff& = SADD(OutBuffer$) 'find address of buffer
Buff& = Buff& - 65536 * (Buff& < 0)
Oseg = VARSEG(OutBuffer$) + (Buff& \ 16) 'get segment + offset >> 4
OAddress = Buff& AND15'get address into segment
OEndAddress = OAddress + 5000'end of disk buffer
OStartAddress = OAddress 'current location in disk buffer DEF SEG = Oseg
GOSUB ClearTree 'clear the tree & output a
PC = ClearCode: GOSUB PutCode 'clear code
x = Xstart: y = YStart 'X & Y have the current pixel GOSUB GetByte: Prefix = GB 'the first pixel is a special case
Done = False 'True when image is complete
DO'while there are more pixels to encode DO'until we have a new string to put into the table IF Done THEN'write out the last pixel, clear the disk buffer ' 'and fix up the last block so its count is correct
PC = Prefix: GOSUB PutCode 'write last pixel
PC = EOFCode: GOSUB PutCode 'send EOF code
IF CurrentBit <> 0THEN PC = 0: GOSUB PutCode 'flush out the last code...
PB = 0: GOSUB PutByte
OutBuffer$ = LEFT$(OutBuffer$, OAddress - OStartAddress) PUT #GIF, , OutBuffer$
temp = ";" + STRING$(8, &H1A) 'the 8 EOF chars is not standard, PUT #GIF, , temp
temp = CHR$(255 - BlockLength) 'correct the last block's count PUT #GIF, LastLoc&, temp CLOSE #GIF: EXIT SUB'<<<<<<<<<<< End of procedure ELSE'get a pixel from the screen and find the new string in table GOSUB GetByte: Suffix = GB GOSUB Hash 'is it in hash table? IF Found = True THEN Prefix = Code(Index) 'replace prefixuffix string with code in table END IF LOOP WHILE Found 'don't stop unless we find a new string
PC = Prefix: GOSUB PutCode 'output the prefix to the file
Prefix(Index) = Prefix 'put the new string in the table
Suffix(Index) = Suffix
Code(Index) = NextCode 'we've got to keep track of code!
Prefix = Suffix 'Prefix = the last pixel pulled from the screen
NextCode = NextCode + 1'get ready for the next code IF NextCode = MaxCode + 1THEN'increase the code size
MaxCode = MaxCode * 2 'Note: The GIF89a spec mentions something about a deferred clear code IF CodeSize = 12THEN'is the code size too big?
PC = ClearCode: GOSUB PutCode 'yup; clear the table and GOSUB ClearTree 'start over
NextCode = StartCode
CodeSize = StartSize
MaxCode = StartMax ELSE CodeSize = CodeSize + 1'increase code size if not too high (not > 12) END IF END IF LOOP'while we have more pixels
' 'GOSUB ROUTINES
ClearTree: FOR A = 0TO Table.size - 1'clears the hashing table
Prefix(A) = -1'-1 = invalid entry
Suffix(A) = -1
Code(A) = -1 NEXT RETURN
Hash: 'hash the prefix & suffix(there are also many ways to do this...)
Index = ((Prefix * 256&) XOR Suffix) MOD Table.size
' Note: the table size(7177 in this case) must be a prime number ' Calculate an offset just in case we don't find what we want first try... IF Index = 0THEN'cannot have Table.Size 0!
Offset = 1 ELSE
Offset = Table.size - Index END IF
DO'loop until we find an empty entry or find what we're lookin for IF Code(Index) = -1THEN'is this entry blank?
Found = False ' didn't find the string RETURN ELSEIF Prefix(Index) = Prefix AND Suffix(Index) = Suffix THEN
Found = True 'found the string RETURN ELSE'didn't find anything, must retry - this slows hashing down.
Index = Index - Offset IF Index < 0THEN'too far down the table? wrap back the index to end of table
Index = Index + Table.size END IF END IF LOOP
PutByte: 'Puts a byte into the GIF file & also takes care of each block.
BlockLength = BlockLength - 1'are we at the end of a block? IF BlockLength <= 0THEN'end of block
BlockLength = 255'block length is now 255
LastLoc& = LOC(GIF) + 1 + (OAddress - OStartAddress) 'remember the position
BW = 255: GOSUB BufferWrite 'for later fixing END IF
BW = PB: GOSUB BufferWrite RETURN
BufferWrite: 'Puts a byte into the buffer IF OAddress = OEndAddress THEN'are we at the end of the buffer? PUT #GIF, , OutBuffer$ 'write it out and
OAddress = OStartAddress 'start all over END IF POKE OAddress, BW 'put byte in buffer
OAddress = OAddress + 1'increment position RETURN
GetByte: 'This routine gets one pixel from the display
GB = POINT(x, y) 'get the "byte"
x = x + 1'increment X coordinate IF x > MaxX THEN'are we too far?
x = MinX 'go back to start
y = y + 1'increment Y coordinate IF y > MaxY THEN Done = True 'flag if too far down END IF RETURN
PutCode: 'Puts an LZW variable-bit code into the output file...
CHAR& = CHAR& + PC * Shift(CurrentBit) 'put the char were it belongs;
CurrentBit = CurrentBit + CodeSize 'shifting it to its proper place DO WHILE CurrentBit > 7'do we have a least one full byte?
PB = CHAR& AND255: GOSUB PutByte 'mask it off and write it out
CHAR& = CHAR& \ 256'shift the bit buffer right 8 bits
CurrentBit = CurrentBit - 8'now we have 8 less bits LOOP'loop until we don't have a full byte RETURN END SUB
Now, as you guys probably know, I've had a SaveImage Library for use with QB64 and QB64PE for the last dozen years or so. The primary use of this library was to allow folks to quickly and easily capture whatever screen they wanted, and to save it to disk -- and it was LOVELY!!
... and then.... the evil, mean, nasty, brilliant _SAVEIMAGE command was added to the language and made the library more-or-less obsolete overall. (All that hard work and all those years maintaining it, for it to die on us! /WAAAAHHHHH!!!!)
Which leads to you guys asking, "Well then, Steve, just what the crap is this junk here??"
Well, I'm glad you asked! (Or I imagined you asked, anyway. )
This is basically an extension of what was left from my old code, and is still relevant with today's _SAVEIMAGE command being built in.
What does this offer that _SAVEIMAGE doesn't??
1) Partial screen grabs and saves -- say you just want an image from (100,100)-(300,300), and not the whole screen. This does that!
2) This saves GIF files for us. The built-in _SAVEIMAGE doesn't do that! /Nanner-nanner!
3) This has some built in image tools for us which allow us to convert text screens to graphic screens, or 32-bit screens to 256-color screens.
And what does _SAVEIMAGE do that this doesn't??
1)
And, I'll probably built in a few more useful features for this in the future, as this is just my first draft at upgrading this longstanding routine to make it relevant once again for everyone.
Here's my arcade game, Rock Jockey. Please give it a go and tell me if it's too hard or easy or buggy. I'm a Mac user, but found a PC to test it on and, after a bunch of changes, it seems to run just fine. It started out as a redo of an old Asteroids game I wrote a few years ago, but then took on a life of its own. Have fun with it!
I updated the graphic demo with the keyboard and absolute position code, and it's coming along.
Windows only so far, resolution 1024x768 or greater.
Give it a try!
Plug 2-8 USB mice into your PC.
Place "makeint.h" and "winproc.h" in same folder as programs.
Compile the mouse reader program "ReadMiceSub" first (or run it once, it will run briefly then exit).
Run the front end program "ReadMiceMain".
The main program will automatically start the subprogram "ReadMiceSub" which should have the focus.
If your PC prompts for permission say Yes. Be patient, the program takes a few seconds to start everything up and get "situated"!
Click the mouse to make sure "ReadMiceSub" has the focus (it's invisible but sitting on top of "ReadMiceMain").
Try moving each mouse.
Each mouse should control a different colored numbered block.
Try clicking the left / middle / right mouse buttons.
You should see the button states on the screen for each mouse.
Try pressing some keys on the keyboard.
The last keys pressed + released are displayed at the top.
Press Esc to quit, or delete the file "ReadMiceSub.DELETE-TO-CLOSE".
The main program creates this file at startup, and both the main and sub programs periodically check that it is present.
If it is missing, both programs shut down.
Some issues and things to fix:
The subprogram "ReadMiceSub" sends its data back to "ReadMiceMain" via TCPIP in the form of a tab-delimited string. Tab is chr$(9). Sometimes it sends multiple messages, which are separated by chr$(13). Currently "ReadMiceMain" just processes the first line. Need to split the input by chr$(13) and process each line seperately, which should make concurrent input smoother.
Hide the real mouse cursor and reactivate it when program closes.
Detect moving the scroll wheel.
Get it working with _FullScreen _SquarePixels. When I tried that mode things got really weird.
Read input from multiple keyboards - need to figure out how to do the unions in the RAWINPUT structure type in "ReadMicesub". (Just need someone to figure this out, I have tried.)
Figure out how to get the same functionality for Mac & Linux.
For anyone who doesn't want to download a zip file, here's the code for the 4 files you'll need:
' ################################################################################################################################################################
' Multimouse main program "ReadMiceMain.bas" v0.54
' ################################################################################################################################################################
' -------------------------------------------------------------------------------
' ABOUT
' -------------------------------------------------------------------------------
' Working proof of concept! (Windows only so far)
'
' HOW TO USE:
'
' 1. Plug 2-8 USB mice into your PC.
'
' 2. Place "makeint.h" and "winproc.h" in same folder as programs.
'
' 3. Compile the mouse reader program "ReadMiceSub" first
' (or run it once and exit).
'
' 4. Run the front end program "ReadMiceMain".
' The main program will automatically start the subprogram "ReadMiceSub"
' which should have the focus. If your PC prompts for permission say Yes.
'
' 5. Click the mouse to make sure "ReadMiceSub" has the focus
' (it's invisible but sitting on top of "ReadMiceMain").
'
' 6. Try moving each mouse. Each one should move a different colored numberd block.
'
' 7. Try clicking the left / middle / right mouse buttons.
' You should see the button states on the screen for each mouse.
'
' 8. Try pressing some keys on the keyboard
' The last key pressed + released is displayed at the top.
'
' 9. Press Esc to quit, or delete the file "ReadMiceSub.DELETE-TO-CLOSE".
' The main program creates this at startup, and both the main and sub
' programs check for this file. If it is missing, both programs shut down.
'
' DEBUGGING CODE:
' There is currently a ton of commented out debugging code - sorry about the
' mess! There were some horribly elusive problems to figure out.
' To enable debugging output: change Const cDebugEnabled to TRUE
' and search for "debug" and uncomment those lines.
' DebugPrint outputs to the console, DebugLog outputs to a file.
' Enabling console in "ReadMiceSub" caused all sorts of problems,
' so to debug that, just use DebugLog.
' -------------------------------------------------------------------------------
' TO DO
' -------------------------------------------------------------------------------
' Some issues and things to fix:
' * The subprogram "ReadMiceSub" sends its data back to "ReadMiceMain"
' via TCPIP in the form of a tab-delimited string. Tab is chr$(9).
' Sometimes it sends multiple messages, which are separated by chr$(13).
' Currently "ReadMiceMain" just processes the first line. Need to split the
' input by chr$(13) and process each line seperately, which should make
' concurrent input smoother.
' * Read input from multiple keyboards - need to figure out how to do the
' unions in the RAWINPUT structure type in "ReadMicesub".
' * Hide the real mouse cursor and reactivate it when program closes.
' * Detect moving the scroll wheel.
' * Get it working with _FullScreen _SquarePixels.
' * Figure out how to get the same functionality for Mac & Linux.
' -------------------------------------------------------------------------------
' THANK YOU
' -------------------------------------------------------------------------------
' Much credit and thanks are due to:
' * jstookey who started the work that made this possible
' * SpriggsySpriggs who ported the hard stuff (APIs, events) to QB64 & QB64PE
' * SMcNeill who helped with so many things, most recently keeping the main window on top, getting file attributes
' * Steffan-68 for feedback, code for managing windows and ideas
' * DSMan195276 for the network code that lets the reader and main program talk smoothly
' * euklides, Ed Davis, mdijkens for file attributes code
' * grymmjack for words of encouragement
' * the QB64 and QB64PE communities for help with everything
' * (if I forgot anyone let me know!)
' -------------------------------------------------------------------------------
' CHANGES
' -------------------------------------------------------------------------------
' DATE WHO WHAT
' 2004-04-22 jstookey added the ability to detect whether RawMouse is
' available or not so the application can either use a
' different multi-mouse system, or exit gracefully
' (thanks to Mark Healey).
' 2005-04-24 jstookey Modified the code work with the latest version of
' MinGW. The new MinGW incorporates rawinput, so my
' winuser header and library is obsolete.
' 2006-03-05 jstookey Initialized is_absolute and is_virtual_desktop to
' work better with newer versions of VStudio.
' Code at: https://jstookey.com/multiple-mice-raw-input/
' 2022-09-07 madscijr Turned into a command line EXE that is called from
' QB64 with SpriggsySpriggs' pipecom from
' https://github.com/SpriggsySpriggs/Spriggsys-API-Collection/blob/master/Cross-Platform%20(Windows%2C%20Macintosh%2C%20Linux)/pipecomqb64.bas
' This version doesn't work.
' 2022-09-08 Spriggsy Converted C to pure QB64 code.
' 2022-09-09 madscijr Added demo code to move multiple objects on screen
' with separate mice independently.
' 2022-09-09 Spriggsy Added a screen refresh.
' 2022-09-10 madscijr Added detecting mouse buttons.
' 2024-05-19 madscijr Try having the program write mice coordinates / button
' states to a file that main program "always on top"
' without focus can read.
' 2024-05-23 madscijr Now we get mice coordinates from subprogram via TCPIP.
' A lot faster than using files!
' Thanks to DSMan195276 for the networking code.
' 2024-06-19 madscijr Now we get absolute mouse coordinates not just dx, dy
' and can read the keyboard (just a single keyboard).
' Updated the graphics / display code to use layers.
' -------------------------------------------------------------------------------
' RESOURCES:
'
' Multiple Mice in Windows using Raw Input by jstookey
' * https://jstookey.com/multiple-mice-raw-input/
'
' One of the original QB64 threads
' * https://qb64phoenix.com/forum/showthread.php?tid=864
'
' Using Raw Input from C# to handle multiple keyboards by Emma Burrows, Steve Messer
' * https://www.codeproject.com/Articles/17123/Using-Raw-Input-from-C-to-handle-multiple-keyboard
'
' Microsoft's Raw Input API docs at pages around:
' * https://learn.microsoft.com/en-us/windows/win32/api/winuser/ns-winuser-rawinputheader
' * https://learn.microsoft.com/en-us/windows/win32/api/winuser/ns-winuser-rawinputdevicelist
'
' Looking at RAWINPUT for more detail (HACKADAY.IO)
' * https://hackaday.io/project/5364-cheap-windows-jogkeyboard-controller-for-cncs/log/16843-looking-at-rawinput-for-more-detail
'
' TimothyTimbers Raw Input Class for indie Game Developers:
' * https://www.unknowncheats.me/forum/c-and-c-/64318-raw-input-class-indie-game-developers.html
'
' WINDOWS PROGRAMMING: ACCESSING RAW INPUT by DAVID OREJUELA
' * https://davidorejuela.blogspot.com/2013/12/windows-programming-accessing-raw-input.html
'
' Explorations in Game Development: Why Raw Input?
' * https://explore-gamedev.blogspot.com/2013/09/why-raw-input.html
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' FOR CONTROLLING WINDOW ON TOP, ETC.
Const SWP_NOSIZE = &H0001 'ignores cx and cy size parameters
Const SWP_NOMOVE = &H0002 'ignores x and y position parameters
Const SWP_NOZORDER = &H0004 'keeps z order and ignores hWndInsertAfter parameter
Const SWP_NOREDRAW = &H0008 'does not redraw window changes
Const SWP_NOACTIVATE = &H0010 'does not activate window
Const SWP_FRAMECHANGED = &H0020
Const SWP_SHOWWINDOW = &H0040
Const SWP_HIDEWINDOW = &H0080
Const SWP_NOCOPYBITS = &H0100
Const SWP_NOOWNERZORDER = &H0200
Const SWP_NOSENDCHANGING = &H0400
Const SWP_DRAWFRAME = SWP_FRAMECHANGED
Const SWP_NOREPOSITION = SWP_NOOWNERZORDER
Const SWP_DEFERERASE = &H2000
Const SWP_ASYNCWINDOWPOS = &H4000
Const HWND_TOP = 0 'window at top of z order no focus
Const HWND_BOTTOM = 1 'window at bottom of z order no focus
Const HWND_TOPMOST = -1 'window above all others no focus unless active
Const HWND_NOTOPMOST = -2 'window below active no focus
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' BEGIN Virtual-Key Codes
' https://learn.microsoft.com/en-us/windows/win32/inputdev/virtual-key-codes
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' NOTE: raw.data.Keyboard.vKey may require set extended bit
Const VK_LBUTTON = &H01 ' dec = 1, Left mouse button
Const VK_RBUTTON = &H02 ' dec = 2, Right mouse button
Const VK_CANCEL = &H03 ' dec = 3, Control-break processing
Const VK_MBUTTON = &H04 ' dec = 4, Middle mouse button
Const VK_XBUTTON1 = &H05 ' dec = 5, X1 mouse button
Const VK_XBUTTON2 = &H06 ' dec = 6, X2 mouse button
'??? = &H07 ' dec = 7, Reserved
Const VK_BACK = &H08 ' dec = 8, BACKSPACE key
Const VK_TAB = &H09 ' dec = 9, TAB key
'??? = &H0A-0B ' dec = 10-11, Reserved
Const VK_CLEAR = &H0C ' dec = 12, CLEAR key
Const VK_RETURN = &H0D ' dec = 13, ENTER key
'??? = &H0E-0F ' dec = 14-15, Unassigned
Const VK_SHIFT = &H10 ' dec = 16, SHIFT key
Const VK_CONTROL = &H11 ' dec = 17, CTRL key
Const VK_MENU = &H12 ' dec = 18, ALT key
Const VK_PAUSE = &H13 ' dec = 19, PAUSE key
Const VK_CAPITAL = &H14 ' dec = 20, CAPS LOCK key
Const VK_KANA = &H15 ' dec = 21, IME Kana mode
Const VK_HANGUL = &H15 ' dec = 21, IME Hangul mode
Const VK_IME_ON = &H16 ' dec = 22, IME On
Const VK_JUNJA = &H17 ' dec = 23, IME Junja mode
Const VK_FINAL = &H18 ' dec = 24, IME final mode
Const VK_HANJA = &H19 ' dec = 25, IME Hanja mode
Const VK_KANJI = &H19 ' dec = 25, IME Kanji mode
Const VK_IME_OFF = &H1A ' dec = 26, IME Off
Const VK_ESCAPE = &H1B ' dec = 27, ESC key
Const VK_CONVERT = &H1C ' dec = 28, IME convert
Const VK_NONCONVERT = &H1D ' dec = 29, IME nonconvert
Const VK_ACCEPT = &H1E ' dec = 30, IME accept
Const VK_MODECHANGE = &H1F ' dec = 31, IME mode change request
Const VK_SPACE = &H20 ' dec = 32, SPACEBAR
Const VK_PRIOR = &H21 ' dec = 33, PAGE UP key
Const VK_NEXT = &H22 ' dec = 34, PAGE DOWN key
Const VK_END = &H23 ' dec = 35, END key
Const VK_HOME = &H24 ' dec = 36, HOME key
Const VK_LEFT = &H25 ' dec = 37, LEFT ARROW key
Const VK_UP = &H26 ' dec = 38, UP ARROW key
Const VK_RIGHT = &H27 ' dec = 39, RIGHT ARROW key
Const VK_DOWN = &H28 ' dec = 40, DOWN ARROW key
Const VK_SELECT = &H29 ' dec = 41, SELECT key
Const VK_PRINT = &H2A ' dec = 42, PRINT key
Const VK_EXECUTE = &H2B ' dec = 43, EXECUTE key
Const VK_SNAPSHOT = &H2C ' dec = 44, PRINT SCREEN key
Const VK_INSERT = &H2D ' dec = 45, INS key
Const VK_DELETE = &H2E ' dec = 46, DEL key
Const VK_HELP = &H2F ' dec = 47, HELP key
' MADE OUR OWN CONSTANTS FOR THESE:
Const VK_0 = &H30 ' dec = 48, 0 key
Const VK_1 = &H31 ' dec = 49, 1 key
Const VK_2 = &H32 ' dec = 50, 2 key
Const VK_3 = &H33 ' dec = 51, 3 key
Const VK_4 = &H34 ' dec = 52, 4 key
Const VK_5 = &H35 ' dec = 53, 5 key
Const VK_6 = &H36 ' dec = 54, 6 key
Const VK_7 = &H37 ' dec = 55, 7 key
Const VK_8 = &H38 ' dec = 56, 8 key
Const VK_9 = &H39 ' dec = 57, 9 key
'??? = &H3A-40 ' dec = 58-64, Undefined
Const VK_A = &H41 ' dec = 65, A key
Const VK_B = &H42 ' dec = 66, B key
Const VK_C = &H43 ' dec = 67, C key
Const VK_D = &H44 ' dec = 68, D key
Const VK_E = &H45 ' dec = 69, E key
Const VK_F = &H46 ' dec = 70, F key
Const VK_G = &H47 ' dec = 71, G key
Const VK_H = &H48 ' dec = 72, H key
Const VK_I = &H49 ' dec = 73, I key
Const VK_J = &H4A ' dec = 74, J key
Const VK_K = &H4B ' dec = 75, K key
Const VK_L = &H4C ' dec = 76, L key
Const VK_M = &H4D ' dec = 77, M key
Const VK_N = &H4E ' dec = 78, N key
Const VK_O = &H4F ' dec = 79, O key
Const VK_P = &H50 ' dec = 80, P key
Const VK_Q = &H51 ' dec = 81, Q key
Const VK_R = &H52 ' dec = 82, R key
Const VK_S = &H53 ' dec = 83, S key
Const VK_T = &H54 ' dec = 84, T key
Const VK_U = &H55 ' dec = 85, U key
Const VK_V = &H56 ' dec = 86, V key
Const VK_W = &H57 ' dec = 87, W key
Const VK_X = &H58 ' dec = 88, X key
Const VK_Y = &H59 ' dec = 89, Y key
Const VK_Z = &H5A ' dec = 90, Z key
' Microsoft's Virtual-Key Codes constants (continued):
Const VK_LWIN = &H5B ' dec = 91, Left Windows key
Const VK_RWIN = &H5C ' dec = 92, Right Windows key
Const VK_APPS = &H5D ' dec = 93, Applications key
'??? = &H5E ' dec = 94, Reserved
Const VK_SLEEP = &H5F ' dec = 95, Computer Sleep key
Const VK_NUMPAD0 = &H60 ' dec = 96, Numeric keypad 0 key
Const VK_NUMPAD1 = &H61 ' dec = 97, Numeric keypad 1 key
Const VK_NUMPAD2 = &H62 ' dec = 98, Numeric keypad 2 key
Const VK_NUMPAD3 = &H63 ' dec = 99, Numeric keypad 3 key
Const VK_NUMPAD4 = &H64 ' dec = 100, Numeric keypad 4 key
Const VK_NUMPAD5 = &H65 ' dec = 101, Numeric keypad 5 key
Const VK_NUMPAD6 = &H66 ' dec = 102, Numeric keypad 6 key
Const VK_NUMPAD7 = &H67 ' dec = 103, Numeric keypad 7 key
Const VK_NUMPAD8 = &H68 ' dec = 104, Numeric keypad 8 key
Const VK_NUMPAD9 = &H69 ' dec = 105, Numeric keypad 9 key
Const VK_MULTIPLY = &H6A ' dec = 106, Multiply key
Const VK_ADD = &H6B ' dec = 107, Add key
Const VK_SEPARATOR = &H6C ' dec = 108, Separator key
Const VK_SUBTRACT = &H6D ' dec = 109, Subtract key
Const VK_DECIMAL = &H6E ' dec = 110, Decimal key
Const VK_DIVIDE = &H6F ' dec = 111, Divide key
Const VK_F1 = &H70 ' dec = 112, F1 key
Const VK_F2 = &H71 ' dec = 113, F2 key
Const VK_F3 = &H72 ' dec = 114, F3 key
Const VK_F4 = &H73 ' dec = 115, F4 key
Const VK_F5 = &H74 ' dec = 116, F5 key
Const VK_F6 = &H75 ' dec = 117, F6 key
Const VK_F7 = &H76 ' dec = 118, F7 key
Const VK_F8 = &H77 ' dec = 119, F8 key
Const VK_F9 = &H78 ' dec = 120, F9 key
Const VK_F10 = &H79 ' dec = 121, F10 key
Const VK_F11 = &H7A ' dec = 122, F11 key
Const VK_F12 = &H7B ' dec = 123, F12 key
Const VK_F13 = &H7C ' dec = 124, F13 key
Const VK_F14 = &H7D ' dec = 125, F14 key
Const VK_F15 = &H7E ' dec = 126, F15 key
Const VK_F16 = &H7F ' dec = 127, F16 key
Const VK_F17 = &H80 ' dec = 128, F17 key
Const VK_F18 = &H81 ' dec = 129, F18 key
Const VK_F19 = &H82 ' dec = 130, F19 key
Const VK_F20 = &H83 ' dec = 131, F20 key
Const VK_F21 = &H84 ' dec = 132, F21 key
Const VK_F22 = &H85 ' dec = 133, F22 key
Const VK_F23 = &H86 ' dec = 134, F23 key
Const VK_F24 = &H87 ' dec = 135, F24 key
'??? = &H88-8F ' dec = 136-143, Reserved
Const VK_NUMLOCK = &H90 ' dec = 144, NUM LOCK key
Const VK_SCROLL = &H91 ' dec = 145, SCROLL LOCK key
'??? = &H92-96 ' dec = 146-150, OEM specific
'??? = &H97-9F ' dec = 151-159, Unassigned
Const VK_LSHIFT = &HA0 ' dec = 160, Left SHIFT key
Const VK_RSHIFT = &HA1 ' dec = 161, Right SHIFT key
Const VK_LCONTROL = &HA2 ' dec = 162, Left CONTROL key
Const VK_RCONTROL = &HA3 ' dec = 163, Right CONTROL key
Const VK_LMENU = &HA4 ' dec = 164, Left ALT key
Const VK_RMENU = &HA5 ' dec = 165, Right ALT key
Const VK_BROWSER_BACK = &HA6 ' dec = 166, Browser Back key
Const VK_BROWSER_FORWARD = &HA7 ' dec = 167, Browser Forward key
Const VK_BROWSER_REFRESH = &HA8 ' dec = 168, Browser Refresh key
Const VK_BROWSER_STOP = &HA9 ' dec = 169, Browser Stop key
Const VK_BROWSER_SEARCH = &HAA ' dec = 170, Browser Search key
Const VK_BROWSER_FAVORITES = &HAB ' dec = 171, Browser Favorites key
Const VK_BROWSER_HOME = &HAC ' dec = 172, Browser Start and Home key
Const VK_VOLUME_MUTE = &HAD ' dec = 173, Volume Mute key
Const VK_VOLUME_DOWN = &HAE ' dec = 174, Volume Down key
Const VK_VOLUME_UP = &HAF ' dec = 175, Volume Up key
Const VK_MEDIA_NEXT_TRACK = &HB0 ' dec = 176, Next Track key
Const VK_MEDIA_PREV_TRACK = &HB1 ' dec = 177, Previous Track key
Const VK_MEDIA_STOP = &HB2 ' dec = 178, Stop Media key
Const VK_MEDIA_PLAY_PAUSE = &HB3 ' dec = 179, Play/Pause Media key
Const VK_LAUNCH_MAIL = &HB4 ' dec = 180, Start Mail key
Const VK_LAUNCH_MEDIA_SELECT = &HB5 ' dec = 181, Select Media key
Const VK_LAUNCH_APP1 = &HB6 ' dec = 182, Start Application 1 key
Const VK_LAUNCH_APP2 = &HB7 ' dec = 183, Start Application 2 key
'??? = &HB8-B9 ' dec = 184-137, Reserved
Const VK_OEM_1 = &HBA ' dec = 186, Used for miscellaneous characters; it can vary by keyboard. For the US standard keyboard, the ;: key
Const VK_OEM_PLUS = &HBB ' dec = 187, For any country/region, the + key
Const VK_OEM_COMMA = &HBC ' dec = 188, For any country/region, the , key
Const VK_OEM_MINUS = &HBD ' dec = 189, For any country/region, the - key
Const VK_OEM_PERIOD = &HBE ' dec = 190, For any country/region, the . key
Const VK_OEM_2 = &HBF ' dec = 191, Used for miscellaneous characters; it can vary by keyboard. For the US standard keyboard, the /? key
Const VK_OEM_3 = &HC0 ' dec = 192, Used for miscellaneous characters; it can vary by keyboard. For the US standard keyboard, the `~ key
'??? = &HC1-DA ' dec = 193-218, Reserved
Const VK_OEM_4 = &HDB ' dec = 219, Used for miscellaneous characters; it can vary by keyboard. For the US standard keyboard, the [{ key
Const VK_OEM_5 = &HDC ' dec = 220, Used for miscellaneous characters; it can vary by keyboard. For the US standard keyboard, the \\| key
Const VK_OEM_6 = &HDD ' dec = 221, Used for miscellaneous characters; it can vary by keyboard. For the US standard keyboard, the ]} key
Const VK_OEM_7 = &HDE ' dec = 222, Used for miscellaneous characters; it can vary by keyboard. For the US standard keyboard, the '" key
Const VK_OEM_8 = &HDF ' dec = 223, Used for miscellaneous characters; it can vary by keyboard.
'??? = &HE0 ' dec = 224, Reserved
'??? = &HE1 ' dec = 225, OEM specific
Const VK_OEM_102 = &HE2 ' dec = 226, The <> keys on the US standard keyboard, or the \\| key on the non-US 102-key keyboard
'??? = &HE3-E4 ' dec = 227-228, OEM specific
Const VK_PROCESSKEY = &HE5 ' dec = 229, IME PROCESS key
'??? = &HE6 ' dec = 230, OEM specific
Const VK_PACKET = &HE7 ' dec = 231, Used to pass Unicode characters as if they were keystrokes. The VK_PACKET key is the low word of a 32-bit Virtual Key value used for non-keyboard input methods. For more information, see Remark in KEYBDINPUT, SendInput, WM_KEYDOWN, and WM_KEYUP
'??? = &HE8 ' dec = 232, Unassigned
'??? = &HE9-F5 ' dec = 233-245, OEM specific
Const VK_ATTN = &HF6 ' dec = 246, Attn key
Const VK_CRSEL = &HF7 ' dec = 247, CrSel key
Const VK_EXSEL = &HF8 ' dec = 248, ExSel key
Const VK_EREOF = &HF9 ' dec = 249, Erase EOF key
Const VK_PLAY = &HFA ' dec = 250, Play key
Const VK_ZOOM = &HFB ' dec = 251, Zoom key
Const VK_NONAME = &HFC ' dec = 252, Reserved
Const VK_PA1 = &HFD ' dec = 253, PA1 key
Const VK_OEM_CLEAR = &HFE ' dec = 254, Clear key
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' END Virtual-Key Codes
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END CONSTANTS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN TYPE DECLARATIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' UDT TO HOLD THE INFO FOR EACH MOUSE (READ MICE MAIN)
Type MouseInfoType
' ReadMiceMain, ReadMiceSub:
ID As String ' player identifier or mouse device ID
' ReadMiceMain:
char As String ' cursor character
' ReadMiceMain:
color As _Unsigned Long ' character color = ~&MyColor (OLD=Integer)
row As Integer ' line to display values at
' ReadMiceMain, ReadMiceSub:
UpdateCount As Integer ' if this value changes we know a value changed
' ReadMiceMain:
OldUpdateCount As Integer ' if this value changes we know a value changed
' ReadMiceMain:
x As Integer ' screen x position
y As Integer ' screen y position
' ReadMiceMain, ReadMiceSub:
dx As Integer ' mouse x movement -1=left, 1=right, 0=none
dy As Integer ' mouse y movement -1=up , 1=down , 0=none
' ReadMiceMain:
oldX As Integer ' tracks old x position to erase screen
oldY As Integer ' tracks old y position to erase screen
' ReadMiceMain:
countX As Integer ' increments by 1 every time mouse moves, when x movement count exceeds threshold cMouseSpeedX, send dx
countY As Integer ' increments by 1 every time mouse moves, when y movement count exceeds threshold cMouseSpeedY, send dy
' ReadMiceMain, ReadMiceSub:
pdx As Long ' x delta (hires) for absolute position of mouse from raw input api
pdy As Long ' y delta (hires) for absolute position of mouse from raw input api
' ReadMiceMain, ReadMiceSub:
px As Long ' pointer x position (hires) for absolute position of mouse from raw input api
py As Long ' pointer y position (hires) for absolute position of mouse from raw input api
' ReadMiceMain:
pxOld As Long ' old pointer x position (hires) for absolute position of mouse from raw input api
pyOld As Long ' old pointer y position (hires) for absolute position of mouse from raw input api
' ReadMiceMain, ReadMiceSub:
wheel As Integer ' mouse wheel value
' ReadMiceMain, ReadMiceSub:
LeftDown As Integer ' tracks left mouse button state, TRUE=down
MiddleDown As Integer ' tracks middle mouse button state, TRUE=down
RightDown As Integer ' tracks right mouse button state, TRUE=down
' ReadMiceMain
wheelOld As Integer ' old mouse wheel value
LeftDownOld As Integer ' tracks left mouse button state, TRUE=down
MiddleDownOld As Integer ' tracks middle mouse button state, TRUE=down
RightDownOld As Integer ' tracks right mouse button state, TRUE=down
' ReadMiceMain
LeftCount As Integer ' counts left clicks
MiddleCount As Integer ' counts middle clicks
RightCount As Integer ' counts right clicks
' Text to display
Message As String
End Type ' MouseInfoType
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END TYPE DECLARATIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN API DECLARATIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ================================================================================================================================================================
' BEGIN Dynamic Library definitions
' ================================================================================================================================================================
Declare Dynamic Library "user32"
' FOR CONTROLLING WINDOW ON TOP, ETC.:
Function FindWindowA%& (ByVal lpClassName%&, Byval lpWindowName%&)
Function SetWindowPos& (ByVal hWnd%&, Byval hWndInsertAfter%&, Byval X&, Byval Y&, Byval cx&, Byval cy&, Byval uFlags~&)
Function GetForegroundWindow%&
' FOR CONTROLLING SUB WINDOW FOCUS:
Sub ShowWindow (ByVal hWnd As _Offset, Byval nCmdShow As Long)
End Declare
Declare Dynamic Library "kernel32"
Function GetLastError~& ()
End Declare
' ================================================================================================================================================================
' END Dynamic Library definitions
' ================================================================================================================================================================
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END API DECLARATIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN GLOBAL VARIABLES
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BASIC PROGRAM METADATA
Dim Shared m_ProgramPath$: m_ProgramPath$ = Left$(Command$(0), _InStrRev(Command$(0), "\"))
Dim Shared m_ProgramName$: m_ProgramName$ = Mid$(Command$(0), _InStrRev(Command$(0), "\") + 1)
Dim Shared m_VersionNum$: m_VersionNum$ = GetVersionNum$(m_ProgramName$)
' GLOBAL VARIABLES TO TRACK ERROR STATE
Dim Shared m_sError As String: m_sError = ""
Dim Shared m_sIncludeError As String: m_sIncludeError = ""
Dim Shared m_sTriggerFile As String: m_sTriggerFile = m_ProgramPath$ + "ReadMiceSub.DELETE-TO-CLOSE"
Dim Shared m_sDebugFile As String: m_sDebugFile = m_ProgramPath$ + m_ProgramName$ + ".txt"
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END GLOBAL VARIABLES
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ****************************************************************************************************************************************************************
' BEGIN DEBUG CONSOLE
' ****************************************************************************************************************************************************************
' ENABLE / DISABLE DEBUG CONSOLE WINDOW
If cDebugEnabled = TRUE Then
$Console
_Delay 4
_Console On
_Echo "Started " + m_ProgramName$
_Echo "Debugging on..."
End If
' ****************************************************************************************************************************************************************
' END DEBUG CONSOLE
' ****************************************************************************************************************************************************************
' ****************************************************************************************************************************************************************
' DEACTIVATE DEBUGGING WINDOW
If cDebugEnabled = TRUE Then
_Console Off
End If
' ****************************************************************************************************************************************************************
'End
System ' return control to the operating system
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN GLOBAL ERROR HANDLER
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
ErrorHandler:
m_sError = "Error #" + _Trim$(Str$(Err)) + " at line " + _Trim$(Str$(_ErrorLine)) + "."
m_sIncludeError = "File " + Chr$(34) + _InclErrorFile$ + Chr$(34) + " at line " + _Trim$(Str$(_InclErrorLine)) + "."
Resume Next
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END GLOBAL ERROR HANDLER
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN MAIN ROUTINES
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Sub main
' MOUSE TEST VARIABLES
Dim arrMouse(0 To 8) As MouseInfoType ' STORES INFO FOR EACH MOUSE
Dim iMouseCount As Integer ' # OF MICE ATTACHED
' WINDOW VARIABLES
Dim hWndThis As _Offset ' hWndThis%&
Dim hWndTop As _Offset ' x%&
' OTHER VARS
Dim iLoop1 As Integer
Dim iLoop2 As Integer
Dim sNextError As String
Dim iIndex As Integer
Dim sLine As String
Dim iLineNum As Integer
Dim iCount As Integer
Dim iCol As Integer
Dim iRow As Integer
Dim iStartRow As Integer
Dim arrColor(0 To 40) As _Unsigned Long ' ~&arrColor (OLD=Integer)
Dim in$
Dim iNextX As Integer
Dim iNextY As Integer
' VARIABLES FOR READING MICE FROM CLIENT
Dim uintPort As _Unsigned Integer ' port
Dim lngHost ' h&
Dim lngConn ' c&
Dim sInput As String ' s$
Dim sMessageType As String
Dim sValue As String
' FOR LOOPING THROUGH DATA
ReDim arrMice(-1 To -1) As String
ReDim arrValues(-1 To -1) As String
Dim sNextChunk As String
Dim sNextValue As String
Dim iValuePosition As Integer
Dim sText As String
' FOR CONTROLLING WINDOW FOCUS
Dim hwndSub As _Offset
' MOUSE READER PROG
Dim sMouseReaderProg As String
' CONTROLS MIN/MAX SCREEN POSITIONS
Dim iMinX As Integer
Dim iMaxX As Integer
Dim iMinY As Integer
Dim iMaxY As Integer
' BASELINE STARTING POSITION
Dim iStartX As Integer
Dim iStartY As Integer
Dim iKeyLoop As Integer
Dim iKeyCode As Integer
Dim iLastKeyDown As Integer
Dim iLastKeyUp As Integer
Dim sLastKeyDown As String
Dim sLastKeyUp As String
Dim sResult As String
Dim MyTime##
Dim imgBackground& ' NEEDS _FREEIMAGE AT END
Dim imgWalls& ' NEEDS _FREEIMAGE AT END
Dim imgText& ' NEEDS _FREEIMAGE AT END
Dim imgPlayers& ' NEEDS _FREEIMAGE AT END
Dim imgScore& ' NEEDS _FREEIMAGE AT END
Dim screen_color~&
Dim wall_color~&
Dim screen_width%
Dim screen_height%
' =============================================================================
' SET ERROR TRAPPING
On Error GoTo ErrorHandler
' =============================================================================
' OPEN A PORT TO TALK TO THE MOUSE READER
Randomize Timer
uintPort = Rnd * 10000 + 40000 ' between 40000 and 50000
' =============================================================================
'GET SUB WINDOW HANDLE FROM CONNECTION...
'_Delay 2
'Get #lngConn, , sInput
' TRY FOR 30 SECONDS
MyTime## = ExtendedTimer + 30
sInput = ""
Do
'_Delay 2
Get #lngConn, , sInput
If Left$(sInput, 2) = "w:" Then Exit Do
Loop Until Timer > MyTime##
If Right$(sInput, 1) = Chr$(13) Then sInput = Left$(sInput, Len(sInput) - 1)
If Left$(sInput, 2) = "w:" Then
sValue = Right$(sInput, Len(sInput) - 2)
'if len( Replace$(sValue, chr$(13), "") ) <> len(sValue) then DebugLog "response had chr$(13)"
If IsNumber%(sValue) Then
hwndSub = Val(sValue)
Else
m_sError = "Mouse reader subprogram failed to return a valid window handle."
m_sError = m_sError + Chr$(13)
m_sError = m_sError + "sInput=" + Chr$(34) + sInput + Chr$(34) + Chr$(13)
m_sError = m_sError + "sValue=" + Chr$(34) + sValue + Chr$(34) + Chr$(13)
End If
ElseIf Left$(sInput, 2) = "e:" Then
If Len(sInput) > 2 Then
m_sError = Right$(sInput, Len(sInput) - 2)
Else
m_sError = "Unspecified error."
End If
Else
m_sError = "Mouse reader subprogram failed to return a window handle."
m_sError = m_sError + Chr$(13)
m_sError = m_sError + "sInput=" + Chr$(34) + sInput + Chr$(34) + Chr$(13)
End If
' IF NO ERRORS, CONTINUE
If Len(m_sError) = 0 Then
' =============================================================================
' INITIALIZE VARIABLES
' window needs to be lined up directly under the main program, so the mouse coordinates align with the display
_ScreenMove 0, 0
' CLEAR THE SCREEN
_Dest 0: Cls , cEmpty
' update screen with changes & wait for next update
_Display
'' ATTEMPT FULLSCREEN <- NOT REALLY WORKING
'_FULLSCREEN _STRETCH, _SMOOTH
'IF _FULLSCREEN = 0 THEN _FULLSCREEN _OFF 'check that a full screen mode initialized
' DRAW CENTER LINE
For y% = 44 To (screen_height% - 48) Step 20
Line ((screen_width% / 2) - 2, y%)-((screen_width% / 2) + 2, y% + 10), wall_color~&, BF
Next y%
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' DRAW THE WALLS LAYER
_Dest imgWalls&: Cls , cEmpty
' DRAW WALLS AROUND EDGES
For x% = 7 To screen_width% Step 20
Line (x%, 40)-(x% + 10, 44), wall_color~&, BF
Line (x%, screen_height% - 50)-(x% + 10, screen_height% - 54), wall_color~&, BF
Next x%
'DrawRectSolid (iX As Integer, iY As Integer, iSizeW As Integer, iSizeH As Integer, fgColor As _Unsigned Long)
'DrawBoxSolid (iX As Integer, iY As Integer, iSize As Integer, fgColor As _Unsigned Long)
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' DRAW THE INSTRUCTIONS LAYER
_Dest imgText&: Cls , cEmpty
' TEXT SCREEN AT 1024X768 IS 48 LINES X 128 CHARACTERS WIDE
' PRINT INSTRUCTIONS
Color cWhite, cEmpty
'message$ = "AVOID MISSING BALL FOR HIGH SCORE"
message$ = "PLUG IN 2 OR MORE USB MICE, MOVE THEM AROUND, CLICK BUTTONS, PRESS KEYS ON KEYBOARD."
Locate 1, 64 - (Len(message$) / 2): Print message$;
' SHOW MORE INSTRUCTIONS
Color cWhite, cEmpty
message$ = "TO EXIT PRESS <ESC> OR DELETE FILE " + Chr$(34) + "ReadMiceSub.DELETE-TO-CLOSE" + Chr$(34) + "."
Locate 47, 64 - (Len(message$) / 2): Print message$;
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' DRAW THE SCORE LAYER
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' DRAW THE PLAYERS LAYER
_Dest imgPlayers&: Cls , cEmpty
' ================================================================================================================================================================
' MAIN LOOP
Do
' KEEP READMICESUB WINDOW ON TOP
If _WindowHasFocus = TRUE Then
'_ScreenIcon
ShowWindow hwndSub, 1
End If
' -----------------------------------------------------------------------------
' READ MICE COORDINATES FROM CONNECTION...
Get #lngConn, , sInput
If Right$(sInput, 1) = Chr$(13) Then sInput = Left$(sInput, Len(sInput) - 1)
' DID IT WORK?
If Len(m_sError) = 0 Then
''DebugPrint " GOT DATA FROM CONNECTION"
''DebugPrint " sInput=" + chr$(34) + sInput + chr$(34)
' HAVE DATA?
If Len(sInput) > 0 Then
'DebugPrint " GOT DATA FROM CONNECTION"
'DebugPrint " sInput=" + chr$(34) + sInput + chr$(34)
' WHAT KIND OF MESSAGE?
sMessageType = Left$(sInput, 2)
'DebugPrint " sMessageType=" + chr$(34) + sMessageType + chr$(34)
If sMessageType = "d:" Then
' KEY DOWN
sValue = Right$(sInput, Len(sInput) - 2)
If IsNumber%(sValue) Then
iLastKeyDown = Val(sValue)
sLastKeyDown = VirtualKeyCodeToString$(iLastKeyDown)
Else
iLastKeyDown = 0
sLastKeyDown = Chr$(34) + sValue + Chr$(34) + " IS NOT A NUMGBER"
End If
ElseIf sMessageType = "u:" Then
' KEY UP
sValue = Right$(sInput, Len(sInput) - 2)
If IsNumber%(sValue) Then
iLastKeyUp = Val(sValue)
sLastKeyUp = VirtualKeyCodeToString$(iLastKeyUp)
Else
iLastKeyUp = 0
sLastKeyUp = Chr$(34) + sValue + Chr$(34) + " IS NOT A NUMGBER"
End If
' GET VALUE
sNextValue = _Trim$(arrValues(iLoop1))
'DebugPrint " sNextValue=" + Chr$(34) + sNextValue + Chr$(34)
' IS IT A VALID INTEGER?
If IsNumber%(sNextValue) Then
' DETERMINE WHICH VALUE IT IS FROM ORDINAL POSITION IN THE INPUT
' AND WRITE TO APPROPRIATE VARIABLE
Select Case iValuePosition
Case cForPlayer
' THIS VALUE TELLS US WHO IT'S FOR
iIndex = Val(sNextValue)
'DebugPrint " PLAYER #" + _Trim$(Str$(iIndex))
''Case cUpdateCount
'' ' THIS VALUE TELLS US IF THERE IS NEW INPUT
'' arrMouse(iIndex).UpdateCount = Val(sNextValue)
'' DebugPrint " UpdateCount = " + _Trim$(Str$(arrMouse(iIndex).UpdateCount))
Case cMouseDX:
' READ RAW VALUE
arrMouse(iIndex).dx = Val(sNextValue)
'DebugPrint " DX = " + _Trim$(Str$(arrMouse(iIndex).dx))
Case cMouseDY:
' READ RAW VALUE
arrMouse(iIndex).dy = Val(sNextValue)
'DebugPrint " DY = " + _Trim$(Str$(arrMouse(iIndex).dy))
Case cMousePosX:
' READ RAW VALUE
arrMouse(iIndex).px = Val(sNextValue)
Case cMousePosY:
' READ RAW VALUE
arrMouse(iIndex).py = Val(sNextValue)
Case cMouseWheel:
'' READ RAW VALUE
'arrMouse(iIndex).wheel = Val(sNextValue)
Case cMouseLeftDown:
' READ RAW VALUE
arrMouse(iIndex).LeftDown = Val(sNextValue)
' DID VALUE CHANGE?
If arrMouse(iIndex).LeftDown <> arrMouse(iIndex).LeftDownOld Then
If arrMouse(iIndex).LeftDown = TRUE Then
' CLICKED BUTTON
Else
' RELEASED BUTTON
End If
arrMouse(iIndex).LeftDownOld = arrMouse(iIndex).LeftDown
End If
Case cMouseMiddleDown:
' READ RAW VALUE
arrMouse(iIndex).MiddleDown = Val(sNextValue)
' DID VALUE CHANGE?
If arrMouse(iIndex).MiddleDown <> arrMouse(iIndex).MiddleDownOld Then
If arrMouse(iIndex).MiddleDown = TRUE Then
' CLICKED BUTTON
Else
' RELEASED BUTTON
End If
arrMouse(iIndex).MiddleDownOld = arrMouse(iIndex).MiddleDown
End If
Case cMouseRightDown:
' READ RAW VALUE
arrMouse(iIndex).RightDown = Val(sNextValue)
' DID VALUE CHANGE?
If arrMouse(iIndex).RightDown <> arrMouse(iIndex).RightDownOld Then
If arrMouse(iIndex).RightDown = TRUE Then
' CLICKED BUTTON
Else
' RELEASED BUTTON
End If
arrMouse(iIndex).RightDownOld = arrMouse(iIndex).RightDown
End If
Case Else:
' Unknown
End Select
''' EXIT IF VALUES HAVEN'T CHANGED
''If iLoop1 > cUpdateCount Then
'' If arrMouse(iIndex).UpdateCount = arrMouse(iIndex).OldUpdateCount Then
'' ' STOP THE MOUSE DX / DY
'' arrMouse(iIndex).dy = 0
'' arrMouse(iIndex).dx = 0
''
'' DebugPrint " UpdateCount HASN'T CHANGED FROM OLD:"
'' DebugPrint " OldUpdateCount = " + _Trim$(Str$(arrMouse(iIndex).OldUpdateCount))
'' DebugPrint " EXITING CHUNK..."
''
'' ' WE CAN STOP PROCESSING THIS CHUNK
'' Exit For
'' End If
''End If
Else
'DebugPrint " " + _
' "Value " + _
' chr$(34) + sNextValue + chr$(34) + " " + _
' "at position " + _
' _Trim$(Str$(iLoop1)) + " " + _
' "(" + MouseDataPositionToString(iLoop1) + ") " + _
' "is not a number."
'
''sNextValue
''DebugPrint " ** sNextValue NOT A NUMBER: " + chr$(34) + sNextValue + chr$(34)
'' (VALUE ISN'T A NUMBER)
'' (DO NOTHING)
End If
Next iLoop1
'' UPDATE OLD VALUE FOR NEXT CHANGE TEST
'If arrMouse(iIndex).UpdateCount <> arrMouse(iIndex).OldUpdateCount Then
' arrMouse(iIndex).OldUpdateCount = arrMouse(iIndex).UpdateCount
'End If
ElseIf sMessageType = "e:" Then
sValue = Right$(sInput, Len(sInput) - 2)
'DebugPrint " Received error message from subprogram: " + sValue
Else
'DebugPrint " Message type from subprogram not recognized: " + sInput
End If
Else
' RETRIEVED DATA IS EMPTY
''DebugPrint " DATA IS EMPTY"
' (JUST IGNORE FOR NOW)
' TODO:
' WE SHOULD QUIT IF NO DATA IS RETRIEVED IN A CERTAIN THRESHOLD OF TIME...
End If
Else
' ERROR RETRIEVING DATA...
'DebugPrint " ERROR RETRIEVING DATA FROM CONNECTION: " + m_sError
' SHOW VALUES FOR EACH MOUSE
For iIndex = LBound(arrMouse) To UBound(arrMouse)
If iIndex > -1 Then
Color arrMouse(iIndex).color, cEmpty
iRow = arrMouse(iIndex).row: iCol = 5
If arrMouse(iIndex).LeftDown Then
Color cEmpty, arrMouse(iIndex).color
Else
Color arrMouse(iIndex).color, cEmpty
End If
PrintString1 iRow, iCol, "1": iCol = iCol + 9
If arrMouse(iIndex).MiddleDown Then
Color cEmpty, arrMouse(iIndex).color
Else
Color arrMouse(iIndex).color, cEmpty
End If
PrintString1 iRow, iCol, "2": iCol = iCol + 9
If arrMouse(iIndex).RightDown Then
Color cEmpty, arrMouse(iIndex).color
Else
Color arrMouse(iIndex).color, cEmpty
End If
PrintString1 iRow, iCol, "3": iCol = iCol + 9
End If
Next iIndex
' SHOW KEYBOARD INPUT
Color cCyan, cEmpty
Locate 2, 32: Print "LAST KEY DOWN: " + sLastKeyDown;
Locate 2, 96: Print "LAST KEY UP : " + sLastKeyUp;
'DrawRectSolid (iX As Integer, iY As Integer, iSizeW As Integer, iSizeH As Integer, fgColor As _Unsigned Long)
'DrawBoxSolid (iX As Integer, iY As Integer, iSize As Integer, fgColor As _Unsigned Long)
DrawBoxSolid arrMouse(iIndex).px, arrMouse(iIndex).py, 32, arrMouse(iIndex).color
Color cBlack, arrMouse(iIndex).color
_PrintString (arrMouse(iIndex).px + 8, arrMouse(iIndex).py + 8), arrMouse(iIndex).Message
End If
Next iIndex
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' COPY LAYERS TO SCREEN AND UPDATE DISPLAY
' CLEAR THE SCREEN
_Dest 0: Cls , cEmpty
' Add the background
_PutImage , imgBackground&, 0
' Add the walls
_PutImage , imgWalls&, 0
' Add the instructions
_PutImage , imgText&, 0
' Add the score
_PutImage , imgScore&, 0
' Add the players
_PutImage , imgPlayers&, 0
' update screen with changes
_Display
' ================================================================================================================================================================
' QUIT ONCE PLAYER PRESSES ESC KEY
If iLastKeyDown = VK_ESCAPE Then
DeleteFile m_sTriggerFile
End If
' ================================================================================================================================================================
' QUIT IF TRIGGER FILE IS GONE
If _FileExists(m_sTriggerFile) = FALSE Then
'DebugLog "_FileExists(" + chr$(34) + m_sTriggerFile + chr$(34) + ") = FALSE, exiting"
Exit Do
End If
'_Limit 60 ' run 60 fps
Loop While _Connected(lngConn)
' RETURN TO AUTODISPLAY
_AutoDisplay
Else
' DELETE THE TRIGGER FILE SO THE SUBPROGRAM CLOSES
DeleteFile m_sTriggerFile
'If cDebugEnabled = TRUE Then
' DebugLog "ERROR:" + m_sError
'End If
' SHOW EROR MESSAGE
Screen 0
Cls
Print "ERROR:"
Print
Print m_sError
Print
Print "Press any key to exit."
Sleep
End If
End Sub ' main
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END MAIN ROUTINES
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN ERROR HANDLING HELPER FUNCTIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Sub ErrorClear
m_sError = ""
m_sIncludeError = ""
End Sub ' ErrorClear
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END ERROR HANDLING HELPER FUNCTIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Function GetVersionNum$ (sFileName$)
Const cDigits = "1234567890"
Dim sResult As String
Dim sProgName As String
Dim iLoop As Integer
sResult$ = ""
'sProgName$ = NoExt$(m_ProgramName$)
sProgName$ = NoExt$(sFileName$)
For iLoop = Len(sProgName) To 1 Step -1
If InStr(1, cDigits, Mid$(sProgName, iLoop, 1)) = 0 Then
Exit For
Else
sResult = Mid$(sProgName, iLoop, 1) + sResult
End If
Next iLoop
GetVersionNum$ = sResult
End Function ' GetVersionNum$
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN GRAPHIC PRINTING ROUTINES
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' /////////////////////////////////////////////////////////////////////////////
' Does a _PrintString at the specified row+column.
'
' iRow% and iCol% are 0-based in this version
'
' See also: PrintString, PrintString1, PutCharXY
Sub PrintAt (iRow%, iCol%, sText$)
'_PrintString (iCol% * 8, iRow% * 16), sText$
_PrintString (iCol% * 8, iRow% * 16), sText$
'_PrintString (iCol%, iRow%), sText$
End Sub ' PrintAt
' /////////////////////////////////////////////////////////////////////////////
' Does a _PrintString at the specified row+column.
' iRow and iCol are 0-based.
' See also: PrintString1
Sub PrintString0 (iRow As Integer, iCol As Integer, MyString As String)
Dim iX As Integer
Dim iY As Integer
iX = _FontWidth * iCol
iY = _FontHeight * iRow ' (iRow + 1)
_PrintString (iX, iY), MyString
End Sub ' PrintString0
' /////////////////////////////////////////////////////////////////////////////
' Does a _PrintString at the specified row+column.
' iRow and iCol are 1-based.
' See also: PrintString
Sub PrintString1 (iRow As Integer, iCol As Integer, MyString As String)
Dim iX As Integer
Dim iY As Integer
iX = _FontWidth * (iCol - 1)
iY = _FontHeight * (iRow - 1)
_PrintString (iX, iY), MyString
End Sub ' PrintString1
' /////////////////////////////////////////////////////////////////////////////
' Eliminates the math.
' Text resolution:
' 648 x 480: 80 x 30
' 720 x 480: 90 x 30
' 800 x 600: 100 x 37
' 1024 x 768: 128 x 48
' 1280 x 1024: 160 x 64
' 1920 x 1080: 240 x 67
' 2048 x 1152: 256 x 72 (truncated after 70 rows, 255 columns)
' 3840 x 2160: 480 x135 (truncated after 133 rows, 479 columns)
Sub PrintStringCR1 (iCol As Integer, iRow As Integer, MyString As String)
Dim iCols As Integer
Dim iRows As Integer
Dim iX As Integer
Dim iY As Integer
iCols = _Width(0) \ _FontWidth
iRows = _Height(0) \ _FontHeight
iX = _FontWidth * (iCol - 1)
iY = _FontHeight * (iRow - 1)
_PrintString (iX, iY), MyString
End Sub ' PrintStringCR1
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END GRAPHIC PRINTING ROUTINES
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN COLOR FUNCTIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Function cRed~& ()
cRed = _RGB32(255, 0, 0)
End Function
Function cOrangeRed~& ()
cOrangeRed = _RGB32(255, 69, 0)
End Function ' cOrangeRed~&
Function cDarkOrange~& ()
cDarkOrange = _RGB32(255, 140, 0)
End Function ' cDarkOrange~&
Function cOrange~& ()
cOrange = _RGB32(255, 165, 0)
End Function ' cOrange~&
Function cGold~& ()
cGold = _RGB32(255, 215, 0)
End Function ' cGold~&
Function cYellow~& ()
cYellow = _RGB32(255, 255, 0)
End Function ' cYellow~&
' LONG-HAIRED FRIENDS OF JESUS OR NOT,
' THIS IS NOT YELLOW ENOUGH (TOO CLOSE TO LIME)
' TO USE FOR OUR COMPLEX RAINBOW SEQUENCE:
Function cChartreuse~& ()
cChartreuse = _RGB32(127, 255, 0)
End Function ' cChartreuse~&
' WE SUBSTITUTE THIS CSS3 COLOR FOR INBETWEEN LIME AND YELLOW:
Function cOliveDrab1~& ()
cOliveDrab1 = _RGB32(192, 255, 62)
End Function ' cOliveDrab1~&
Function cLime~& ()
cLime = _RGB32(0, 255, 0)
End Function ' cLime~&
Function cMediumSpringGreen~& ()
cMediumSpringGreen = _RGB32(0, 250, 154)
End Function ' cMediumSpringGreen~&
' ADDED THIS FOR THE GAUGE COLOR:
Function cSpringGreen~& ()
cSpringGreen = _RGB32(0, 255, 160)
End Function ' cSpringGreen~&
Function cCyan~& ()
cCyan = _RGB32(0, 255, 255)
End Function ' cCyan~&
Function cDeepSkyBlue~& ()
cDeepSkyBlue = _RGB32(0, 191, 255)
End Function ' cDeepSkyBlue~&
Function cDodgerBlue~& ()
cDodgerBlue = _RGB32(30, 144, 255)
End Function ' cDodgerBlue~&
Function cSeaBlue~& ()
cSeaBlue = _RGB32(0, 64, 255)
End Function ' cSeaBlue~&
Function cBlue~& ()
cBlue = _RGB32(0, 0, 255)
End Function ' cBlue~&
Function cBluePurple~& ()
cBluePurple = _RGB32(64, 0, 255)
End Function ' cBluePurple~&
Function cDeepPurple~& ()
cDeepPurple = _RGB32(96, 0, 255)
End Function ' cDeepPurple~&
Function cPurple~& ()
cPurple = _RGB32(128, 0, 255)
End Function ' cPurple~&
Function cPurpleRed~& ()
cPurpleRed = _RGB32(128, 0, 192)
End Function ' cPurpleRed~&
Function cDarkRed~& ()
cDarkRed = _RGB32(160, 0, 64)
End Function ' cDarkRed~&
Function cBrickRed~& ()
cBrickRed = _RGB32(192, 0, 32)
End Function ' cBrickRed~&
Function cDarkGreen~& ()
cDarkGreen = _RGB32(0, 100, 0)
End Function ' cDarkGreen~&
Function cGreen~& ()
cGreen = _RGB32(0, 128, 0)
End Function ' cGreen~&
Function cOliveDrab~& ()
cOliveDrab = _RGB32(107, 142, 35)
End Function ' cOliveDrab~&
Function cLightPink~& ()
cLightPink = _RGB32(255, 182, 193)
End Function ' cLightPink~&
Function cHotPink~& ()
cHotPink = _RGB32(255, 105, 180)
End Function ' cHotPink~&
Function cDeepPink~& ()
cDeepPink = _RGB32(255, 20, 147)
End Function ' cDeepPink~&
Function cMagenta~& ()
cMagenta = _RGB32(255, 0, 255)
End Function ' cMagenta~&
Function cBlack~& ()
cBlack = _RGB32(0, 0, 0)
End Function ' cBlack~&
Function cDimGray~& ()
cDimGray = _RGB32(105, 105, 105)
End Function ' cDimGray~&
Function cGray~& ()
cGray = _RGB32(128, 128, 128)
End Function ' cGray~&
Function cDarkGray~& ()
cDarkGray = _RGB32(169, 169, 169)
End Function ' cDarkGray~&
Function cSilver~& ()
cSilver = _RGB32(192, 192, 192)
End Function ' cSilver~&
Function cLightGray~& ()
cLightGray = _RGB32(211, 211, 211)
End Function ' cLightGray~&
Function cGainsboro~& ()
cGainsboro = _RGB32(220, 220, 220)
End Function ' cGainsboro~&
Function cWhiteSmoke~& ()
cWhiteSmoke = _RGB32(245, 245, 245)
End Function ' cWhiteSmoke~&
Function cWhite~& ()
cWhite = _RGB32(255, 255, 255)
'cWhite = _RGB32(254, 254, 254)
End Function ' cWhite~&
Function cDarkBrown~& ()
cDarkBrown = _RGB32(128, 64, 0)
End Function ' cDarkBrown~&
Function cLightBrown~& ()
cLightBrown = _RGB32(196, 96, 0)
End Function ' cLightBrown~&
Function cKhaki~& ()
cKhaki = _RGB32(240, 230, 140)
End Function ' cKhaki~&
Function cEmpty~& ()
'cEmpty~& = -1
cEmpty = _RGB32(0, 0, 0, 0)
End Function ' cEmpty~&
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END COLOR FUNCTIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN FILE FUNCTIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' /////////////////////////////////////////////////////////////////////////////
' QB64 Phoenix Edition › QB64 Rising › Code and Stuff › Help Me!
' Using shell to delete a file
' https://qb64phoenix.com/forum/showthread.php?tid=2618&pid=24683#pid24683
' a740g
' #5
' 04-24-2024, 06:05 AM
'
' There are no commands to directly make copies or backup of files.
' But you could write one with a few lines of code like:
'
' Copies src to dst
' Set overwite to true if dst should be overwritten if present
Sub CopyFile (src As String, dst As String, overwrite As _Byte)
If _FileExists(src) Then
If Not _FileExists(dst) Or (_FileExists(dst) And overwrite) Then
_WriteFile dst, _ReadFile$(src)
End If
End If
End Sub ' CopyFile
' /////////////////////////////////////////////////////////////////////////////
' Convert a value to string and trim it (because normal Str$ adds spaces)
Function cstr$ (myValue)
'cstr$ = LTRIM$(RTRIM$(STR$(myValue)))
cstr$ = _Trim$(Str$(myValue))
End Function ' cstr$
Sub DebugLog (sText As String)
Dim sTime As String
Dim sResult As String
ReDim arrLines(0) As String
Dim iLoop As Integer
Dim sNextLine As String
If _FileExists(m_sDebugFile) = FALSE Then
sResult = PrintFile$(m_sDebugFile, "", FALSE)
End If
If Len(sResult) = 0 Then
sTime = GetCurrentDateTime$("{mm}/{dd}/{yyyy} {hh}:{nn}:{ss} {ampm}")
split sText, Chr$(13), arrLines()
For iLoop = LBound(arrLines) To UBound(arrLines)
sNextLine = sTime + " " + arrLines(iLoop)
sResult = PrintFile$(m_sDebugFile, sNextLine, TRUE)
Next iLoop
End If
End Sub ' DebugLog
Sub DebugLog1 (sText As String)
Dim sResult As String
If _FileExists(m_sDebugFile) Then
sResult = PrintFile$(m_sDebugFile, sText, TRUE)
Else
sResult = PrintFile$(m_sDebugFile, sText, FALSE)
End If
End Sub ' DebugLog
' /////////////////////////////////////////////////////////////////////////////
' QB64 Phoenix Edition › QB64 Rising › Code and Stuff › Help Me!
' Using shell to delete a file
' https://qb64phoenix.com/forum/showthread.php?tid=2618
Sub DeleteFile (sFile As String)
If _FileExists(sFile) Then
'Shell "DELETE " + sFile
'Shell "del " + sFile
Kill sFile
End If
End Sub ' DeleteFile
Function FileExt$ (sFile As String)
Dim iPos As Integer
iPos = _InStrRev(sFile, ".")
If iPos > 0 Then
If Len(sFile) > 1 Then
If iPos > 1 Then
FileExt$ = Right$(sFile, Len(sFile) - iPos)
Else
' dot is first character, return everything after it
FileExt$ = Right$(sFile, Len(sFile) - 1)
End If
Else
' file only has one character, the dot, the file extension is blank
FileExt$ = ""
End If
Else
' no dot found, the file extension is blank
FileExt$ = ""
End If
End Function ' FileExt$
Function NameOnly$ (sFile As String, sSlash As String)
Dim iPos As Integer
'sFile = Replace$(sFile, "/", "\")
iPos = _InStrRev(sFile, sSlash)
If iPos > 0 Then
If Len(sFile) > 1 Then
If iPos > 1 Then
NameOnly$ = Right$(sFile, Len(sFile) - iPos)
Else
' slash is first character, return everything after it
NameOnly$ = Right$(sFile, Len(sFile) - 1)
End If
Else
' file only has one character, the slash, name is blank
NameOnly$ = ""
End If
Else
' slash not found, return the entire thing
NameOnly$ = sFile
End If
End Function ' NameOnly$
Function NoExt$ (sFile As String)
Dim iPos As Integer
iPos = _InStrRev(sFile, ".")
If iPos > 0 Then
If Len(sFile) > 1 Then
If iPos > 1 Then
NoExt$ = Left$(sFile, iPos - 1)
Else
' dot is first character, removing it returns blank!
' our version will just return the name unchanged
' but you can return blank if you prefer
NoExt$ = sFile
End If
Else
' file only has one character, the dot, removing it returns blank!
' our version will just return the name unchanged
' but you can return blank if you prefer
NoExt$ = sFile
End If
Else
' no dot found
' return the name unchanged
NoExt$ = sFile
End If
End Function ' NoExt$
Function PathOnly$ (sFile As String, sSlash As String)
Dim iPos As Integer
'sFile = Replace$(sFile, "/", "\")
iPos = _InStrRev(sFile, sSlash)
If iPos > 0 Then
If Len(sFile) > 1 Then
If iPos > 1 Then
PathOnly$ = Left$(sFile, iPos)
Else
' slash is first character, so not much of a path, return blank
PathOnly$ = ""
End If
Else
' file only has one character, the slash, name is blank
PathOnly$ = ""
End If
Else
' slash not found, so not a path, return blank
PathOnly$ = ""
End If
End Function ' PathOnly$
' /////////////////////////////////////////////////////////////////////////////
' Writes sText to file sFileName.
' If bAppend=TRUE appends to file, else overwrites it.
' Returns blank if successful else returns error message.
Function PrintFile$ (sFileName As String, sText As String, bAppend As Integer)
Dim sError As String: sError = ""
If (bAppend = TRUE) Then
If _FileExists(sFileName) Then
Open sFileName For Append As #1 ' opens an existing file for appending
Else
sError = "Error in PrintFile$ : File not found. Cannot append."
End If
Else
Open sFileName For Output As #1 ' opens and clears an existing file or creates new empty file
End If
If Len(sError) = 0 Then
' NOTE: WRITE places text in quotes in the file
'WRITE #1, x, y, z$
'WRITE #1, sText
' PRINT does not put text inside quotes
Print #1, sText
Close #1
End If
PrintFile$ = sError
End Function ' PrintFile$
' /////////////////////////////////////////////////////////////////////////////
' Fastest way is always to just read the whole life at once and then parse it.
Function ReadTextFile$ (sFileName As String, sDefault As String)
Dim x$
If _FileExists(sFileName) Then
Open sFileName For Binary As #1
x$ = Space$(LOF(1))
Get #1, 1, x$
Close #1
ReadTextFile$ = x$
Else
ReadTextFile$ = sDefault
End If
End Function ' ReadTextFile$
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END FILE FUNCTIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN CONSTANT TO STRING FUNCTIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Function MouseDataPositionToString$ (MyInteger As Integer)
Dim Mystring As String
Select Case MyInteger
Case cForPlayer:
Mystring = "cForPlayer"
Case cMouseDX:
Mystring = "cMouseDX"
Case cMouseDY:
Mystring = "cMouseDY"
Case cMousePosX:
Mystring = "cMousePosX"
Case cMousePosY:
Mystring = "cMousePosY"
Case cMouseWheel:
Mystring = "cMouseWheel"
Case cMouseLeftDown:
Mystring = "cMouseLeftDown"
Case cMouseMiddleDown:
Mystring = "cMouseMiddleDown"
Case cMouseRightDown:
Mystring = "cMouseRightDown"
Case Else:
Mystring = _Trim$(Str$(MyInteger))
End Select
MouseDataPositionToString$ = Mystring
End Function ' MouseDataPositionToString$
Function VirtualKeyCodeToString$ (MyInteger As Integer)
Dim Mystring As String
Select Case MyInteger
Case VK_LBUTTON:
Mystring = "VK_LBUTTON"
Case VK_RBUTTON:
Mystring = "VK_RBUTTON"
Case VK_CANCEL:
Mystring = "VK_CANCEL"
Case VK_MBUTTON:
Mystring = "VK_MBUTTON"
Case VK_XBUTTON1:
Mystring = "VK_XBUTTON1"
Case VK_XBUTTON2:
Mystring = "VK_XBUTTON2"
Case VK_BACK:
Mystring = "VK_BACK"
Case VK_TAB:
Mystring = "VK_TAB"
Case VK_CLEAR:
Mystring = "VK_CLEAR"
Case VK_RETURN:
Mystring = "VK_RETURN"
Case VK_SHIFT:
Mystring = "VK_SHIFT"
Case VK_CONTROL:
Mystring = "VK_CONTROL"
Case VK_MENU:
Mystring = "VK_MENU"
Case VK_PAUSE:
Mystring = "VK_PAUSE"
Case VK_CAPITAL:
Mystring = "VK_CAPITAL"
Case VK_KANA:
Mystring = "VK_KANA"
Case VK_HANGUL:
Mystring = "VK_HANGUL"
Case VK_IME_ON:
Mystring = "VK_IME_ON"
Case VK_JUNJA:
Mystring = "VK_JUNJA"
Case VK_FINAL:
Mystring = "VK_FINAL"
Case VK_HANJA:
Mystring = "VK_HANJA"
Case VK_KANJI:
Mystring = "VK_KANJI"
Case VK_IME_OFF:
Mystring = "VK_IME_OFF"
Case VK_ESCAPE:
Mystring = "VK_ESCAPE"
Case VK_CONVERT:
Mystring = "VK_CONVERT"
Case VK_NONCONVERT:
Mystring = "VK_NONCONVERT"
Case VK_ACCEPT:
Mystring = "VK_ACCEPT"
Case VK_MODECHANGE:
Mystring = "VK_MODECHANGE"
Case VK_SPACE:
Mystring = "VK_SPACE"
Case VK_PRIOR:
Mystring = "VK_PRIOR"
Case VK_NEXT:
Mystring = "VK_NEXT"
Case VK_END:
Mystring = "VK_END"
Case VK_HOME:
Mystring = "VK_HOME"
Case VK_LEFT:
Mystring = "VK_LEFT"
Case VK_UP:
Mystring = "VK_UP"
Case VK_RIGHT:
Mystring = "VK_RIGHT"
Case VK_DOWN:
Mystring = "VK_DOWN"
Case VK_SELECT:
Mystring = "VK_SELECT"
Case VK_PRINT:
Mystring = "VK_PRINT"
Case VK_EXECUTE:
Mystring = "VK_EXECUTE"
Case VK_SNAPSHOT:
Mystring = "VK_SNAPSHOT"
Case VK_INSERT:
Mystring = "VK_INSERT"
Case VK_DELETE:
Mystring = "VK_DELETE"
Case VK_HELP:
Mystring = "VK_HELP"
Case VK_0:
Mystring = "VK_0"
Case VK_1:
Mystring = "VK_1"
Case VK_2:
Mystring = "VK_2"
Case VK_3:
Mystring = "VK_3"
Case VK_4:
Mystring = "VK_4"
Case VK_5:
Mystring = "VK_5"
Case VK_6:
Mystring = "VK_6"
Case VK_7:
Mystring = "VK_7"
Case VK_8:
Mystring = "VK_8"
Case VK_9:
Mystring = "VK_9"
Case VK_A:
Mystring = "VK_A"
Case VK_B:
Mystring = "VK_B"
Case VK_C:
Mystring = "VK_C"
Case VK_D:
Mystring = "VK_D"
Case VK_E:
Mystring = "VK_E"
Case VK_F:
Mystring = "VK_F"
Case VK_G:
Mystring = "VK_G"
Case VK_H:
Mystring = "VK_H"
Case VK_I:
Mystring = "VK_I"
Case VK_J:
Mystring = "VK_J"
Case VK_K:
Mystring = "VK_K"
Case VK_L:
Mystring = "VK_L"
Case VK_M:
Mystring = "VK_M"
Case VK_N:
Mystring = "VK_N"
Case VK_O:
Mystring = "VK_O"
Case VK_P:
Mystring = "VK_P"
Case VK_Q:
Mystring = "VK_Q"
Case VK_R:
Mystring = "VK_R"
Case VK_S:
Mystring = "VK_S"
Case VK_T:
Mystring = "VK_T"
Case VK_U:
Mystring = "VK_U"
Case VK_V:
Mystring = "VK_V"
Case VK_W:
Mystring = "VK_W"
Case VK_X:
Mystring = "VK_X"
Case VK_Y:
Mystring = "VK_Y"
Case VK_Z:
Mystring = "VK_Z"
Case VK_LWIN:
Mystring = "VK_LWIN"
Case VK_RWIN:
Mystring = "VK_RWIN"
Case VK_APPS:
Mystring = "VK_APPS"
Case VK_SLEEP:
Mystring = "VK_SLEEP"
Case VK_NUMPAD0:
Mystring = "VK_NUMPAD0"
Case VK_NUMPAD1:
Mystring = "VK_NUMPAD1"
Case VK_NUMPAD2:
Mystring = "VK_NUMPAD2"
Case VK_NUMPAD3:
Mystring = "VK_NUMPAD3"
Case VK_NUMPAD4:
Mystring = "VK_NUMPAD4"
Case VK_NUMPAD5:
Mystring = "VK_NUMPAD5"
Case VK_NUMPAD6:
Mystring = "VK_NUMPAD6"
Case VK_NUMPAD7:
Mystring = "VK_NUMPAD7"
Case VK_NUMPAD8:
Mystring = "VK_NUMPAD8"
Case VK_NUMPAD9:
Mystring = "VK_NUMPAD9"
Case VK_MULTIPLY:
Mystring = "VK_MULTIPLY"
Case VK_ADD:
Mystring = "VK_ADD"
Case VK_SEPARATOR:
Mystring = "VK_SEPARATOR"
Case VK_SUBTRACT:
Mystring = "VK_SUBTRACT"
Case VK_DECIMAL:
Mystring = "VK_DECIMAL"
Case VK_DIVIDE:
Mystring = "VK_DIVIDE"
Case VK_F1:
Mystring = "VK_F1"
Case VK_F2:
Mystring = "VK_F2"
Case VK_F3:
Mystring = "VK_F3"
Case VK_F4:
Mystring = "VK_F4"
Case VK_F5:
Mystring = "VK_F5"
Case VK_F6:
Mystring = "VK_F6"
Case VK_F7:
Mystring = "VK_F7"
Case VK_F8:
Mystring = "VK_F8"
Case VK_F9:
Mystring = "VK_F9"
Case VK_F10:
Mystring = "VK_F10"
Case VK_F11:
Mystring = "VK_F11"
Case VK_F12:
Mystring = "VK_F12"
Case VK_F13:
Mystring = "VK_F13"
Case VK_F14:
Mystring = "VK_F14"
Case VK_F15:
Mystring = "VK_F15"
Case VK_F16:
Mystring = "VK_F16"
Case VK_F17:
Mystring = "VK_F17"
Case VK_F18:
Mystring = "VK_F18"
Case VK_F19:
Mystring = "VK_F19"
Case VK_F20:
Mystring = "VK_F20"
Case VK_F21:
Mystring = "VK_F21"
Case VK_F22:
Mystring = "VK_F22"
Case VK_F23:
Mystring = "VK_F23"
Case VK_F24:
Mystring = "VK_F24"
Case VK_NUMLOCK:
Mystring = "VK_NUMLOCK"
Case VK_SCROLL:
Mystring = "VK_SCROLL"
Case VK_LSHIFT:
Mystring = "VK_LSHIFT"
Case VK_RSHIFT:
Mystring = "VK_RSHIFT"
Case VK_LCONTROL:
Mystring = "VK_LCONTROL"
Case VK_RCONTROL:
Mystring = "VK_RCONTROL"
Case VK_LMENU:
Mystring = "VK_LMENU"
Case VK_RMENU:
Mystring = "VK_RMENU"
Case VK_BROWSER_BACK:
Mystring = "VK_BROWSER_BACK"
Case VK_BROWSER_FORWARD:
Mystring = "VK_BROWSER_FORWARD"
Case VK_BROWSER_REFRESH:
Mystring = "VK_BROWSER_REFRESH"
Case VK_BROWSER_STOP:
Mystring = "VK_BROWSER_STOP"
Case VK_BROWSER_SEARCH:
Mystring = "VK_BROWSER_SEARCH"
Case VK_BROWSER_FAVORITES:
Mystring = "VK_BROWSER_FAVORITES"
Case VK_BROWSER_HOME:
Mystring = "VK_BROWSER_HOME"
Case VK_VOLUME_MUTE:
Mystring = "VK_VOLUME_MUTE"
Case VK_VOLUME_DOWN:
Mystring = "VK_VOLUME_DOWN"
Case VK_VOLUME_UP:
Mystring = "VK_VOLUME_UP"
Case VK_MEDIA_NEXT_TRACK:
Mystring = "VK_MEDIA_NEXT_TRACK"
Case VK_MEDIA_PREV_TRACK:
Mystring = "VK_MEDIA_PREV_TRACK"
Case VK_MEDIA_STOP:
Mystring = "VK_MEDIA_STOP"
Case VK_MEDIA_PLAY_PAUSE:
Mystring = "VK_MEDIA_PLAY_PAUSE"
Case VK_LAUNCH_MAIL:
Mystring = "VK_LAUNCH_MAIL"
Case VK_LAUNCH_MEDIA_SELECT:
Mystring = "VK_LAUNCH_MEDIA_SELECT"
Case VK_LAUNCH_APP1:
Mystring = "VK_LAUNCH_APP1"
Case VK_LAUNCH_APP2:
Mystring = "VK_LAUNCH_APP2"
Case VK_OEM_1:
Mystring = "VK_OEM_1"
Case VK_OEM_PLUS:
Mystring = "VK_OEM_PLUS"
Case VK_OEM_COMMA:
Mystring = "VK_OEM_COMMA"
Case VK_OEM_MINUS:
Mystring = "VK_OEM_MINUS"
Case VK_OEM_PERIOD:
Mystring = "VK_OEM_PERIOD"
Case VK_OEM_2:
Mystring = "VK_OEM_2"
Case VK_OEM_3:
Mystring = "VK_OEM_3"
Case VK_OEM_4:
Mystring = "VK_OEM_4"
Case VK_OEM_5:
Mystring = "VK_OEM_5"
Case VK_OEM_6:
Mystring = "VK_OEM_6"
Case VK_OEM_7:
Mystring = "VK_OEM_7"
Case VK_OEM_8:
Mystring = "VK_OEM_8"
Case VK_OEM_102:
Mystring = "VK_OEM_102"
Case VK_PROCESSKEY:
Mystring = "VK_PROCESSKEY"
Case VK_PACKET:
Mystring = "VK_PACKET"
Case VK_ATTN:
Mystring = "VK_ATTN"
Case VK_CRSEL:
Mystring = "VK_CRSEL"
Case VK_EXSEL:
Mystring = "VK_EXSEL"
Case VK_EREOF:
Mystring = "VK_EREOF"
Case VK_PLAY:
Mystring = "VK_PLAY"
Case VK_ZOOM:
Mystring = "VK_ZOOM"
Case VK_NONAME:
Mystring = "VK_NONAME"
Case VK_PA1:
Mystring = "VK_PA1"
Case VK_OEM_CLEAR:
Mystring = "VK_OEM_CLEAR"
Case Else:
Mystring = _Trim$(Str$(MyInteger))
End Select
VirtualKeyCodeToString$ = Mystring
End Function ' VirtualKeyCodeToString$
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END CONSTANT TO STRING FUNCTIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN DRAWING ROUTINES
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' /////////////////////////////////////////////////////////////////////////////
' DRAW A 2-D BOX (SOLID)
' https://www.qb64.org/wiki/LINE
' Renamed DrawBox/DrawBoxLine to DrawSolidBox
Sub DrawBoxSolid (iX As Integer, iY As Integer, iSize As Integer, fgColor As _Unsigned Long)
Line (iX, iY)-(iX + iSize, iY + iSize), fgColor, BF ' Draw a solid box
End Sub ' DrawBoxSolid
' /////////////////////////////////////////////////////////////////////////////
' DRAW A 2-D RECTANGLE (SOLID)
Sub DrawRectSolid (iX As Integer, iY As Integer, iSizeW As Integer, iSizeH As Integer, fgColor As _Unsigned Long)
Line (iX, iY)-(iX + iSizeW, iY + iSizeH), fgColor, BF ' Draw a solid rectangle
End Sub ' DrawRectSolid
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END DRAWING ROUTINES
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN GENERAL PURPOSE FUNCTIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' /////////////////////////////////////////////////////////////////////////////
' SMcNeill
' More efficient version of ExtendedTimer.
' This stores our day values and only updates them when necessary.
' We really don't need to figure out how many seconds are in today over and over endlessly
' -- just count them once, and when the clock swaps back to 0:0:0, add 24*60*60 seconds to the count.
' Re: how to time something (ie do loop for n seconds)
' https://forum.qb64.org/index.php?topic=4682.0
Function ExtendedTimer##
'modified extendedtimer to store the old day's count, and not have to recalculate it every time the routine is called.
Static olds As _Float, old_day As _Float
Dim m As Integer, d As Integer, y As Integer
Dim s As _Float, day As String
Dim oldt As Single
If olds = 0 Then 'calculate the day the first time the extended timer runs
day = Date$
m = Val(Left$(day, 2))
d = Val(Mid$(day, 4, 2))
y = Val(Right$(day, 4)) - 1970
Select Case m 'Add the number of days for each previous month passed
Case 2: d = d + 31
Case 3: d = d + 59
Case 4: d = d + 90
Case 5: d = d + 120
Case 6: d = d + 151
Case 7: d = d + 181
Case 8: d = d + 212
Case 9: d = d + 243
Case 10: d = d + 273
Case 11: d = d + 304
Case 12: d = d + 334
End Select
If (y Mod 4) = 2 And m > 2 Then d = d + 1 'add a day if this is leap year and we're past february
d = (d - 1) + 365 * y 'current month days passed + 365 days per each standard year
d = d + (y + 2) \ 4 'add in days for leap years passed
s = d * 24 * 60 * 60 'Seconds are days * 24 hours * 60 minutes * 60 seconds
old_day = s
End If
If Timer < oldt Then 'we went from 23:59:59 (a second before midnight) to 0:0:0 (midnight)
old_day = s + 83400 'add another worth of seconds to our counter
End If
oldt = Timer
olds = old_day + oldt
ExtendedTimer## = olds
End Function ' ExtendedTimer##
' /////////////////////////////////////////////////////////////////////////////
' Simple timestamp function
' Format: {YYYY}-{MM}-{DD} {hh}:[mm}:{ss}
' Uses:
' TIME$
' The TIME$ Function returns a STRING representation
' of the current computer time in a 24 hour format.
' https://qb64phoenix.com/qb64wiki/index.php/TIME$
' DATE$
' The DATE$ function returns the current computer date
' as a string in the format "mm-dd-yyyy".
' https://qb64phoenix.com/qb64wiki/index.php/DATE$
'
' TODO: support template where
' {yyyy} = 4 digit year
' {mm} = 2 digit month
' {dd} = 2 digit day
' {hh} = 2 digit hour (12-hour)
' {rr} = 2 digit hour (24-hour)
' {nn} = 2 digit minute
' {ss} = 2 digit second
' {ampm} = AM/PM
' We got the nn for minute from Microsoft > Office VBA Reference > DateDiff function
' https://docs.microsoft.com/en-us/office/vba/language/reference/user-interface-help/datediff-function
Function GetCurrentDateTime$ (sTemplate$)
Dim sDate$: sDate$ = Date$
Dim sTime$: sTime$ = Time$
Dim sYYYY$: sYYYY$ = Mid$(sDate$, 7, 4)
Dim sMM$: sMM$ = Mid$(sDate$, 1, 2)
Dim sDD$: sDD$ = Mid$(sDate$, 4, 2)
Dim sHH24$: sHH24$ = Mid$(sTime$, 1, 2)
Dim sHH$: sHH$ = ""
Dim sMI$: sMI$ = Mid$(sTime$, 4, 2)
Dim sSS$: sSS$ = Mid$(sTime$, 7, 2)
Dim iHour%: iHour% = Val(sHH24$)
Dim sAMPM$: sAMPM$ = ""
Dim result$: result$ = ""
' FIGURE OUT AM/PM
If InStr(sTemplate$, "{ampm}") > 0 Then
If iHour% = 0 Then
sAMPM$ = "AM"
iHour% = 12
ElseIf iHour% > 0 And iHour% < 12 Then
sAMPM$ = "AM"
ElseIf iHour% = 12 Then
sAMPM$ = "PM"
Else
sAMPM$ = "PM"
iHour% = iHour% - 12
End If
sHH$ = Right$("00" + _Trim$(Str$(iHour%)), 2)
End If
' RETURN RESULT
GetCurrentDateTime$ = result$
End Function ' GetCurrentDateTime$
' /////////////////////////////////////////////////////////////////////////////
' FOR BITWISE OPERATIONS
Function HasBit% (iByte As Integer, iBit As Integer)
''TODO: precalculate
'dim shared m_arrBitValue(1 To 8) As Integer
'dim iLoop as Integer
'For iLoop = 0 To 7
' m_arrBitValue(iLoop + 1) = 2 ^ iLoop
'Next iLoop
'HasBit% = ((iByte And m_arrBitValue(iBit)) = m_arrBitValue(iBit))
Dim iBitValue As Integer
iBitValue = 2 ^ (iBit - 1)
HasBit% = ((iByte And iBitValue) = iBitValue)
End Function ' HasBit%
' /////////////////////////////////////////////////////////////////////////////
' IIF function for QB for integers
Function IIF (Condition, IfTrue, IfFalse)
If Condition Then IIF = IfTrue Else IIF = IfFalse
End Function
' /////////////////////////////////////////////////////////////////////////////
' IIF function for QB for strings
Function IIFS$ (Condition, IfTrue$, IfFalse$)
If Condition Then IIFS$ = IfTrue$ Else IIFS$ = IfFalse$
End Function
' /////////////////////////////////////////////////////////////////////////////
' Returns TRUE if value OriginalString$ is numeric.
' Re: Does a Is Number function exist in QB64?
' https://www.qb64.org/forum/index.php?topic=896.15
' Version 2 by madscijr
' Returns TRUE (-1) if string is an integer, FALSE (0) if not
' Version 1 by MWheatley
' Reply #18 on: January 01, 2019, 11:24:30 AM
' returns 1 if string is an integer, 0 if not
Function IsNumber% (OriginalString$)
Dim bResult%: bResult% = FALSE
Dim iLoop%
Dim TestString$
'Dim bNegative%
Dim iDecimalCount%
Dim sNextChar$
'THEY SHOULD TRIM OUTSIDE THE FUNCTION!
'TestString$ = _TRIM$(OriginalString$)
If Len(OriginalString$) > 0 Then
TestString$ = ""
If Left$(OriginalString$, 1) = "+" Then
TestString$ = Right$(OriginalString$, Len(OriginalString$) - 1)
'bNegative% = FALSE
ElseIf Left$(OriginalString$, 1) = "-" Then
TestString$ = Right$(OriginalString$, Len(OriginalString$) - 1)
'bNegative% = TRUE
Else
TestString$ = OriginalString$
'bNegative% = FALSE
End If
If Len(TestString$) > 0 Then
bResult% = TRUE
iDecimalCount% = 0
For iLoop% = 1 To Len(TestString$)
sNextChar$ = Mid$(TestString$, iLoop%, 1)
If sNextChar$ = "." Then
iDecimalCount% = iDecimalCount% + 1
If iDecimalCount% > 1 Then
' TOO MANY DECIMAL POINTS, INVALID!
bResult% = FALSE
Exit For
End If
ElseIf Asc(sNextChar$) < 48 Or Asc(sNextChar$) > 57 Then
' NOT A NUMERAL OR A DECIMAL, INVALID!
bResult% = FALSE
Exit For
End If
Next iLoop%
End If
End If
IsNumber% = bResult%
End Function ' IsNumber%
' /////////////////////////////////////////////////////////////////////////////
' Split and join strings
' https://www.qb64.org/forum/index.php?topic=1073.0
'Combine all elements of in$() into a single string with delimiter$ separating the elements.
Function join$ (in$(), delimiter$)
Dim result$
Dim iLoop%
result$ = in$(LBound(in$))
For iLoop% = LBound(in$) + 1 To UBound(in$)
result$ = result$ + delimiter$ + in$(iLoop%)
Next iLoop%
join$ = result$
End Function ' join$
' /////////////////////////////////////////////////////////////////////////////
' FROM: String Manipulation
' found at abandoned, outdated and now likely malicious qb64 dot net website
' http://www.qb64.[net]/forum/index_topic_5964-0/
'
'SUMMARY:
' Purpose: A library of custom functions that transform strings.
' Author: Dustinian Camburides (dustinian@gmail.com)
' Platform: QB64 (www.qb64.org)
' Revision: 1.6
' Updated: 5/28/2012
'SUMMARY:
'[Replace$] replaces all instances of the [Find] sub-string with the [Add] sub-string within the [Text] string.
'INPUT:
'Text: The input string; the text that's being manipulated.
'Find: The specified sub-string; the string sought within the [Text] string.
'Add: The sub-string that's being added to the [Text] string.
Function Replace$ (Text1 As String, Find1 As String, Add1 As String)
' VARIABLES:
Dim Text2 As String
Dim Find2 As String
Dim Add2 As String
Dim lngLocation As Long ' The address of the [Find] substring within the [Text] string.
Dim strBefore As String ' The characters before the string to be replaced.
Dim strAfter As String ' The characters after the string to be replaced.
' INITIALIZE:
' MAKE COPIESSO THE ORIGINAL IS NOT MODIFIED (LIKE ByVal IN VBA)
Text2 = Text1
Find2 = Find1
Add2 = Add1
lngLocation = InStr(1, Text2, Find2)
' PROCESSING:
' While [Find2] appears in [Text2]...
While lngLocation
' Extract all Text2 before the [Find2] substring:
strBefore = Left$(Text2, lngLocation - 1)
' Extract all text after the [Find2] substring:
strAfter = Right$(Text2, ((Len(Text2) - (lngLocation + Len(Find2) - 1))))
' Locate the next instance of [Find2]:
lngLocation = InStr(1, Text2, Find2)
' Next instance of [Find2]...
Wend
' OUTPUT:
Replace$ = Text2
End Function ' Replace$
' /////////////////////////////////////////////////////////////////////////////
' Split and join strings
' https://www.qb64.org/forum/index.php?topic=1073.0
'
' FROM luke, QB64 Developer
' Date: February 15, 2019, 04:11:07 AM
'
' Given a string of words separated by spaces (or any other character),
' splits it into an array of the words. I've no doubt many people have
' written a version of this over the years and no doubt there's a million
' ways to do it, but I thought I'd put mine here so we have at least one
' version. There's also a join function that does the opposite
' array -> single string.
'
' Code is hopefully reasonably self explanatory with comments and a little demo.
' Note, this is akin to Python/JavaScript split/join, PHP explode/implode.
'Split in$ into pieces, chopping at every occurrence of delimiter$. Multiple consecutive occurrences
'of delimiter$ are treated as a single instance. The chopped pieces are stored in result$().
'
'delimiter$ must be one character long.
'result$() must have been REDIMmed previously.
' Modified to handle multi-character delimiters
Sub split (in$, delimiter$, result$())
Dim start As Integer
Dim finish As Integer
Dim iDelimLen As Integer
ReDim result$(-1)
iDelimLen = Len(delimiter$)
start = 1
Do
'While Mid$(in$, start, 1) = delimiter$
While Mid$(in$, start, iDelimLen) = delimiter$
'start = start + 1
start = start + iDelimLen
If start > Len(in$) Then
Exit Sub
End If
Wend
finish = InStr(start, in$, delimiter$)
If finish = 0 Then
finish = Len(in$) + 1
End If
ReDim _Preserve result$(0 To UBound(result$) + 1)
result$(UBound(result$)) = Mid$(in$, start, finish - start)
start = finish + 1
Loop While start <= Len(in$)
End Sub ' split
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END GENERAL PURPOSE FUNCTIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ################################################################################################################################################################
' BEGIN DEBUGGING ROUTINES #DEBUG
' ################################################################################################################################################################
' /////////////////////////////////////////////////////////////////////////////
' Prints MyString to console with linebreaks.
' Thanks to:
' SpriggsySpriggs for how to use the QB64 debug console:
' https://www.qb64.org/forum/index.php?topic=3949.0
Sub DebugPrint (MyString As String)
If cDebugEnabled = TRUE Then
ReDim arrLines(-1) As String
Dim iLoop As Integer
split MyString, Chr$(13), arrLines()
For iLoop = LBound(arrLines) To UBound(arrLines)
_Echo arrLines(iLoop)
Next iLoop
End If
End Sub ' DebugPrint
' /////////////////////////////////////////////////////////////////////////////
' Simply prints s$ to console (no linebreaks).
Sub DebugPrint1 (s$)
If cDebugEnabled = TRUE Then
_Echo s$
End If
End Sub ' DebugPrint1
' ################################################################################################################################################################
' END DEBUGGING ROUTINES @DEBUG
' ################################################################################################################################################################
' -------------------------------------------------------------------------------
' ABOUT
' -------------------------------------------------------------------------------
' (Subprogram for READMICEMAIN.BAS, see that for more info.)
' *****************************************************************************
' NOTES:
'
' The following header files must be in same folder as this program:
' "makeint.h"
' "winproc.h"
' This detects a "phantom mouse" which doesn't seem to work.
' I think it might be my laptop's touchpad or touchscreen,
' is there some way to get the input from this working,
' or if not, at least identify and ignore it?
'
' *****************************************************************************
Option Explicit
_Title "readmice"
$NoPrefix
'$Console:Only
'Console Off
' FORM ALPHA VALUES
Const cInvisible = 1 ' for some reason a value of 0 (fully invisible) doesn't let the window get the focus, so we use 1
Const cTransparent = 160
Const cVisible = 255
' CONSTANT FOR 2ND DIMENSION OF arrFile ARRAY
Const cFileName = 0
Const cFileData = 1
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END CONSTANTS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ================================================================================================================================================================
' BEGIN API CONSTANTS
' ================================================================================================================================================================
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' FOR CONTROLLING WINDOW ON TOP, ETC.
Const SWP_NOSIZE = &H0001 'ignores cx and cy size parameters
'Const SWP_NOMOVE = &H0002 'ignores x and y position parameters
'Const SWP_NOZORDER = &H0004 'keeps z order and ignores hWndInsertAfter parameter
'Const SWP_NOREDRAW = &H0008 'does not redraw window changes
Const SWP_NOACTIVATE = &H0010 'does not activate window
'Const SWP_FRAMECHANGED = &H0020
'Const SWP_SHOWWINDOW = &H0040
'Const SWP_HIDEWINDOW = &H0080
'Const SWP_NOCOPYBITS = &H0100
'Const SWP_NOOWNERZORDER = &H0200
'Const SWP_NOSENDCHANGING = &H0400
'Const SWP_DRAWFRAME = SWP_FRAMECHANGED
'Const SWP_NOREPOSITION = SWP_NOOWNERZORDER
'Const SWP_DEFERERASE = &H2000
'Const SWP_ASYNCWINDOWPOS = &H4000
Const HWND_TOP = 0 'window at top of z order no focus
Const HWND_BOTTOM = 1 'window at bottom of z order no focus
Const HWND_TOPMOST = -1 'window above all others no focus unless active
Const HWND_NOTOPMOST = -2 'window below active no focus
' CONSTANTS USED FOR WINDOWS STYLES & FEATURES, SEE:
' Window Styles
' https://learn.microsoft.com/en-us/windows/win32/winmsg/window-styles
' Window Features
' https://learn.microsoft.com/en-us/windows/win32/winmsg/window-features
Const WS_CAPTION = &H00C00000 ' dec=12582912
Const WS_CHILD = &H40000000 ' dec=1073741824
Const WS_MAXIMIZEBOX = &H00010000 ' dec=65536
Const WS_MINIMIZEBOX = &H00020000 ' dec=131072
Const WS_OVERLAPPED = &H00000000 ' dec=0
Const WS_SYSMENU = &H00080000 ' dec=524288
Const WS_THICKFRAME = &H00040000 ' dec=262144
Const WS_VISIBLE = &H10000000 ' dec=268435456
Const WS_OVERLAPPEDWINDOW = WS_OVERLAPPED Or WS_CAPTION Or WS_SYSMENU Or WS_THICKFRAME Or WS_MINIMIZEBOX Or WS_MAXIMIZEBOX
' CONSTANTS USED BY MapVirtualKey FOR PARAMETER uMapType
' https://learn.microsoft.com/en-us/windows/win32/api/winuser/nf-winuser-mapvirtualkeya
Const MAPVK_VK_TO_VSC = 0 ' The uCode parameter is a virtual-key code and is translated into a scan code. If it is a virtual-key code that does not distinguish between left- and right-hand keys, the left-hand scan code is returned. If there is no translation, the function returns 0.
Const MAPVK_VSC_TO_VK = 1 ' The uCode parameter is a scan code and is translated into a virtual-key code that does not distinguish between left- and right-hand keys. If there is no translation, the function returns 0. Windows Vista and later: the high byte of the uCode value can contain either 0xe0 or 0xe1 to specify the extended scan code.
Const MAPVK_VK_TO_CHAR = 2 ' The uCode parameter is a virtual-key code and is translated into an unshifted character value in the low order word of the return value. Dead keys (diacritics) are indicated by setting the top bit of the return value. If there is no translation, the function returns 0. See Remarks.
Const MAPVK_VSC_TO_VK_EX = 3 ' The uCode parameter is a scan code and is translated into a virtual-key code that distinguishes between left- and right-hand keys. If there is no translation, the function returns 0. Windows Vista and later: the high byte of the uCode value can contain either 0xe0 or 0xe1 to specify the extended scan code.
Const MAPVK_VK_TO_VSC_EX = 4 ' Windows Vista and later: The uCode parameter is a virtual-key code and is translated into a scan code. If it is a virtual-key code that does not distinguish between left- and right-hand keys, the left-hand scan code is returned. If the scan code is an extended scan code, the high byte of the returned value will contain either 0xe0 or 0xe1 to specify the extended scan code. If there is no translation, the function returns 0.
' ================================================================================================================================================================
' END API CONSTANTS
' ================================================================================================================================================================
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN RAW INPUT TYPES
' FOR TYPE CONVERSION SEE: "QB64PE C Libraries" at:
' https://qb64phoenix.com/qb64wiki/index.php/C_Libraries
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' Spriggsy's version:
Type RAWINPUTDEVICE
As Unsigned Integer usUsagePage, usUsage
As Unsigned Long dwFlags
As Offset hwndTarget
End Type
' ^^^ Should "Unsigned Integer" be "_UNSIGNED INTEGER"
' and "Unsigned Long" be "_UNSIGNED LONG"
' and "Offset" be "_OFFSET" like this?:
'
'TYPE RAWINPUTDEVICE
' usUsagePage AS _UNSIGNED INTEGER ' WORD
' usUsage AS _UNSIGNED INTEGER ' WORD
' dwFlags AS _UNSIGNED LONG ' DWORD
' hwndTarget AS _OFFSET ' DWORD
'END TYPE
Type MSG
As Offset hwnd
As Unsigned Long message
As Unsigned Offset wParam
As Offset lParam
As Long time
As POINT pt
As Long lPrivate
End Type
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
'WNDCLASSEXA structure (winuser.h)
'https://learn.microsoft.com/en-us/windows/win32/api/winuser/ns-winuser-wndclassexa
'typedef struct WNDCLASSEXA {
' UINT cbSize;
' UINT style;
' WNDPROC lpfnWndProc;
' int cbClsExtra;
' int cbWndExtra;
' HINSTANCE hInstance;
' HICON hIcon;
' HCURSOR hCursor;
' HBRUSH hbrBackground;
' LPCSTR lpszMenuName;
' LPCSTR lpszClassName;
' HICON hIconSm;
'} WNDCLASSEXA, *PWNDCLASSEXA, *NPWNDCLASSEXA, *LPWNDCLASSEXA;
Type WNDCLASSEX
As Unsigned Long cbSize, style
As Offset lpfnWndProc
As Long cbClsExtra, cbWndExtra
As Offset hInstance, hIcon, hCursor, hbrBackground, lpszMenuName, lpszClassName, hIconSm
End Type
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
'RECT structure (windef.h)
'https://learn.microsoft.com/en-us/windows/win32/api/windef/ns-windef-rect
'typedef struct tagRECT {
' LONG left; Specifies the x-coordinate of the upper-left corner of the rectangle.
' LONG top; Specifies the y-coordinate of the upper-left corner of the rectangle.
' LONG right; Specifies the x-coordinate of the lower-right corner of the rectangle.
' LONG bottom; Specifies the y-coordinate of the lower-right corner of the rectangle.
'} RECT, *PRECT, *NPRECT, *LPRECT;
Type RECT
As Long left, top, right, bottom
End Type
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
'PAINTSTRUCT structure (winuser.h)
'https://learn.microsoft.com/en-us/windows/win32/api/winuser/ns-winuser-paintstruct
'typedef struct tagPAINTSTRUCT {
' HDC hdc;
' BOOL fErase;
' RECT rcPaint;
' BOOL fRestore;
' BOOL fIncUpdate;
' BYTE rgbReserved[32];
'} PAINTSTRUCT, *PPAINTSTRUCT, *NPPAINTSTRUCT, *LPPAINTSTRUCT;
Type PAINTSTRUCT
As Offset hdc
As Long fErase
$If 64BIT Then
As String * 4 alignment
$End If
As RECT rcPaint
As Long fRestore, fIncUpdate
As String * 32 rgbReserved
End Type
' Spriggsy's version:
Type RAWINPUTHEADER
As Unsigned Long dwType, dwSize
As Offset hDevice
As Unsigned Offset wParam
End Type
' ^^^ Doesn't match the types I expected, should it be these?:
'TYPE RAWINPUTHEADER
' dwType AS _UNSIGNED LONG ' DWORD
' dwSize AS _UNSIGNED LONG ' DWORD
' hDevice AS _UNSIGNED LONG ' DWORD <- should this be _OFFSET ?
' wParam AS LONG
'END TYPE
' Spriggsy's simplified version:
Type RAWMOUSE
As Unsigned Integer usFlags
$If 64BIT Then
As String * 2 alignment
$End If
'As Unsigned Long ulButtons 'commented out because I'm creating this value using MAKELONG
As Unsigned Integer usButtonFlags, usButtonData
As Unsigned Long ulRawButtons
As Long lLastX, lLastY
As Unsigned Long ulExtraInformation
End Type
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
'RAWKEYBOARD structure (winuser.h)
'https://learn.microsoft.com/en-us/windows/win32/api/winuser/ns-winuser-rawkeyboard
'typedef struct tagRAWKEYBOARD {
' USHORT MakeCode;
' USHORT Flags;
' USHORT Reserved;
' USHORT VKey;
' UINT Message;
' ULONG ExtraInformation;
'} RAWKEYBOARD, *PRAWKEYBOARD, *LPRAWKEYBOARD;
Type RAWKEYBOARD
MakeCode As _Unsigned Integer ' USHORT
Flags As _Unsigned Integer ' USHORT
Reserved As _Unsigned Integer ' USHORT
VKey As _Unsigned Integer ' USHORT
Message As _Unsigned Long ' UINT
ExtraInformation As _Unsigned _Offset ' ULONG
End Type
' Spriggsy's simplified version:
Type RAWINPUT
As RAWINPUTHEADER header
As RAWMOUSE mouse
'As RAWKEYBOARD keyboard <- ADDING THIS CAUSES THE PROGRAM TO CRASH ON MOUSE INPUT
End Type
' Simplified copy for keyboard:
Type RAWINPUT_K
As RAWINPUTHEADER header
As RAWKEYBOARD keyboard
End Type
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
'RID_DEVICE_INFO_MOUSE structure (winuser.h)
'https://learn.microsoft.com/en-us/windows/win32/api/winuser/ns-winuser-rid_device_info_mouse
'typedef struct tagRID_DEVICE_INFO_MOUSE {
' DWORD dwId;
' DWORD dwNumberOfButtons;
' DWORD dwSampleRate;
' BOOL fHasHorizontalWheel;
'} RID_DEVICE_INFO_MOUSE, *PRID_DEVICE_INFO_MOUSE;
Type RID_DEVICE_INFO_MOUSE
dwId As _Unsigned Long
dwNumberOfButtons As _Unsigned Long
dwSampleRate As _Unsigned Long
fHasHorizontalWheel As Integer
End Type
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
'RID_DEVICE_INFO_KEYBOARD structure (winuser.h)
'https://learn.microsoft.com/en-us/windows/win32/api/winuser/ns-winuser-rid_device_info_keyboard
'typedef struct tagRID_DEVICE_INFO_KEYBOARD {
' DWORD dwType;
' DWORD dwSubType;
' DWORD dwKeyboardMode;
' DWORD dwNumberOfFunctionKeys;
' DWORD dwNumberOfIndicators;
' DWORD dwNumberOfKeysTotal;
'} RID_DEVICE_INFO_KEYBOARD, *PRID_DEVICE_INFO_KEYBOARD;
Type RID_DEVICE_INFO_KEYBOARD
dwType As _Unsigned Long ' DWORD
dwSubType As _Unsigned Long ' DWORD
dwKeyboardMode As _Unsigned Long ' DWORD
dwNumberOfFunctionKeys As _Unsigned Long ' DWORD
dwNumberOfIndicators As _Unsigned Long ' DWORD
dwNumberOfKeysTotal As _Unsigned Long ' DWORD
End Type
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
'RID_DEVICE_INFO_HID structure (winuser.h)
'https://learn.microsoft.com/en-us/windows/win32/api/winuser/ns-winuser-rid_device_info_hid
'typedef struct tagRID_DEVICE_INFO_HID {
' DWORD dwVendorId;
' DWORD dwProductId;
' DWORD dwVersionNumber;
' USHORT usUsagePage;
' USHORT usUsage;
'} RID_DEVICE_INFO_HID, *PRID_DEVICE_INFO_HID;
Type RID_DEVICE_INFO_HID
dwVendorId As _Unsigned Long ' DWORD
dwProductId As _Unsigned Long ' DWORD
dwVersionNumber As _Unsigned Long ' DWORD
usUsagePage As _Unsigned Integer ' USHORT
usUsage As _Unsigned Integer ' USHORT
End Type
' ^^^ NOT SURE HOW TO DEFINE THIS, SHOULD IT BE SOMETHING LIKE THIS?:
'Type DUMMYUNIONNAME1
' My_RID_DEVICE_INFO_MOUSE As _Offset ' pointer to VAR A1
' My_RID_DEVICE_INFO_KEYBOARD As _Offset ' pointer to VAR A2
' My_RID_DEVICE_INFO_HID As _Offset ' pointer to VAR A3
'End Type
'Type RID_DEVICE_INFO
' cbSize As _Unsigned Long ' DWORD
' dwType As _Unsigned Long ' DWORD
' My_DUMMYUNIONNAME1 As _Offset ' pointer to DUMMYUNIONNAME1
'End Type
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
'RAWHID structure (winuser.h)
'https://learn.microsoft.com/en-us/windows/win32/api/winuser/ns-winuser-rawhid
'typedef struct tagRAWHID {
' DWORD dwSizeHid;
' DWORD dwCount;
' BYTE bRawData[1];
'} RAWHID, *PRAWHID, *LPRAWHID;
Type RAWHID
dwSizeHid As _Unsigned Long ' DWORD
dwCount As _Unsigned Long ' DWORD
bRawData As _Unsigned _Byte ' bRawData[1] AS BYTE
End Type
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END RAW INPUT TYPES
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN CUSTOM TYPES
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' UDT TO HOLD THE INFO FOR EACH MOUSE (READ MICE SUB)
Type MouseInfoType
ID As String ' player identifier or mouse device ID
char As String ' cursor character
'' ReadMiceMain, ReadMiceSub:
'UpdateCount As Integer ' if this value changes we know a value changed
' ReadMiceMain:
'OldUpdateCount As Integer ' if this value changes we know a value changed
'x As Integer ' screen x position
'y As Integer ' screen y position
dx As Integer ' mouse x movement -1=left, 1=right, 0=none
dy As Integer ' mouse y movement -1=up , 1=down , 0=none
px As Long ' pointer x position (hires) for absolute position of mouse from raw input api
py As Long ' pointer y position (hires) for absolute position of mouse from raw input api
' Multimouse:
pdx As Long ' mouse x movement (hires) can be greater than just -1 or +1
pdy As Long ' mouse y movement (hires) can be greater than just -1 or +1
wheel As Integer ' mouse wheel value
'wheelOld As Integer ' old mouse wheel value
LeftDown As Integer ' tracks left mouse button state, TRUE=down
'LeftDownOld As Integer ' old left mouse button state, TRUE=down
MiddleDown As Integer ' tracks middle mouse button state, TRUE=down
'MiddleDownOld As Integer ' old middle mouse button state, TRUE=down
RightDown As Integer ' tracks right mouse button state, TRUE=down
'RightDownOld As Integer ' old right mouse button state, TRUE=down
End Type ' MouseInfoType
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END CUSTOM TYPES
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN API DECLARATIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ================================================================================================================================================================
' BEGIN CustomType Library definitions
' ================================================================================================================================================================
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' FOR RAW INPUT API
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
Declare CustomType Library
'DECLARE FUNCTION GetRawInputDeviceList LIB "USER32.DLL" ALIAS "GetRawInputDeviceList"( _
' BYREF pRawInputDeviceList AS RAWINPUTDEVICELIST, _
' BYREF puiNumDevices AS _UNSIGNED LONG, _
' BYVAL cbSize AS _UNSIGNED LONG _
' ) AS _UNSIGNED LONG
Function GetRawInputDeviceList~& (ByVal pRawInputDeviceList As Offset, Byval puiNumDevices As Offset, Byval cbSize As Unsigned Long)
Sub GetRawInputDeviceList (ByVal pRawInputDeviceList As Offset, Byval puiNumDevices As Offset, Byval cbSize As Unsigned Long)
'DECLARE FUNCTION RegisterRawInputDevices LIB "USER32.DLL" ALIAS "RegisterRawInputDevices"( _
' BYREF pRawInputDevices AS RAWINPUTDEVICE, _
' BYVAL uiNumDevices AS _UNSIGNED LONG, _
' BYVAL cbSize AS _UNSIGNED LONG _
' ) AS LONG
Function RegisterRawInputDevices& (ByVal pRawInputDevices As Offset, Byval uiNumDevices As Unsigned Long, Byval cbSize As Unsigned Long)
Function GetModuleHandle%& (ByVal lpModulename As Offset)
Function LoadIcon%& (ByVal hInstance As Offset, Byval lpIconName As Offset)
Function LoadCursor%& (ByVal hInstance As Offset, Byval lpCursorName As Offset)
Function RegisterClassEx~% (ByVal wndclassex As Offset)
Function CreateWindowEx%& (ByVal dwExStyle As Unsigned Long, Byval lpClassName As Offset, Byval lpWindowName As Offset, Byval dwStyle As Unsigned Long, Byval x As Long, Byval y As Long, Byval nWidth As Long, Byval nHeight As Long, Byval hWndParent As Offset, Byval hMenu As Offset, Byval hInstance As Offset, Byval lpParam As Offset)
Sub ShowWindow (ByVal hWnd As Offset, Byval nCmdShow As Long)
Sub UpdateWindow (ByVal hWnd As Offset)
Function GetMessage& (ByVal lpMsg As Offset, Byval hWnd As Offset, Byval wMsgFilterMin As Unsigned Long, Byval wMsgFilterMax As Unsigned Long)
Sub TranslateMessage (ByVal lpMsg As Offset)
Sub DispatchMessage (ByVal lpMsg As Offset)
Sub PostQuitMessage (ByVal nExitCode As Long)
Function DefWindowProc%& (ByVal hWnd As Offset, Byval Msg As Unsigned Long, Byval wParam As Unsigned Offset, Byval lParam As Offset)
'DECLARE FUNCTION GetRawInputData LIB "USER32.DLL" ALIAS "GetRawInputData"( _
' BYVAL hRawInput AS _UNSIGNED LONG, _
' BYVAL uiCommand AS _UNSIGNED LONG, _
' BYREF pData AS _OFFSET, _
' BYREF pcbSize AS _UNSIGNED LONG, _
' BYVAL cbSizeHeader AS _UNSIGNED LONG _
' ) AS _UNSIGNED LONG
Sub GetRawInputData (ByVal hRawInput As Offset, Byval uiCommand As Unsigned Long, Byval pData As Offset, Byval pcbSize As Offset, Byval cbSizeHeader As Unsigned Long)
Function GetRawInputData~& (ByVal hRawInput As Offset, Byval uiCommand As Unsigned Long, Byval pData As Offset, Byval pcbSize As Offset, Byval cbSizeHeader As Unsigned Long)
Sub InvalidateRect (ByVal hWnd As Offset, Byval lpRect As Offset, Byval bErase As Long)
'DECLARE FUNCTION SendMessage LIB "USER32.DLL" ALIAS "SendMessageA"( _
' BYVAL hWnd AS _OFFSET, _
' BYVAL Msg AS _UNSIGNED LONG, _
' BYVAL wParam AS _UNSIGNED LONG, _
' BYVAL lParam AS LONG _
' ) AS LONG
Sub SendMessage (ByVal hWnd As Offset, Byval Msg As Unsigned Long, Byval wParam As Unsigned Offset, Byval lParam As Offset)
Function BeginPaint%& (ByVal hWnd As Offset, Byval lpPaint As Offset)
'Public Declare Function GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Sub GetClientRect (ByVal hWnd As Offset, Byval lpRect As Offset)
'Public Declare Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hdc As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long
Sub DrawText (ByVal hdc As Offset, Byval lpchText As Offset, Byval cchText As Long, Byval lprc As Offset, Byval format As Unsigned Long)
'Public Declare Function OffsetRect Lib "user32" (lpRect As RECT, ByVal X As Long, ByVal Y As Long) As Long
Sub OffsetRect (ByVal lprc As Offset, Byval dx As Long, Byval dy As Long)
Sub EndPaint (ByVal hWnd As Offset, Byval lpPaint As Offset)
End Declare ' CustomType Library
' Header file "makeint.h" must be in same folder as this program.
Declare CustomType Library ".\makeint"
Function MAKEINTRESOURCE%& Alias "MAKEINTRSC" (ByVal i As _Offset)
End Declare
' ================================================================================================================================================================
' END CustomType Library definitions
' ================================================================================================================================================================
' ================================================================================================================================================================
' BEGIN Library definitions
' ================================================================================================================================================================
Declare Library
Function MAKELPARAM%& (ByVal l As Integer, Byval h As Integer)
Function MAKELONG~& (ByVal l As Unsigned Integer, Byval h As Unsigned Integer)
End Declare
$If 64BIT Then
Declare Library ".\internal\c\c_compiler\x86_64-w64-mingw32\include\windowsx"
$Else
Declare Library ".\internal\c\c_compiler\i686-w64-mingw32\include\windowsx"
$End If
Function GET_Y_LPARAM& (ByVal lp As Offset)
Function GET_X_LPARAM& (ByVal lp As Offset)
End Declare
' Header file "winproc.h" must be in same folder as this program.
Declare Library ".\winproc"
Function WindowProc%& ()
End Declare
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' Needed for acquiring the hWnd of the window
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
Declare Library
Function FindWindow& (ByVal ClassName As _Offset, WindowName$) ' To get hWnd handle
End Declare
' ================================================================================================================================================================
' END Library definitions
' ================================================================================================================================================================
' ================================================================================================================================================================
' BEGIN Dynamic Library definitions
' ================================================================================================================================================================
Declare Dynamic Library "user32"
' FOR CONTROLLING WINDOW ON TOP, ETC.:
Function FindWindowA%& (ByVal lpClassName%&, Byval lpWindowName%&)
Function SetWindowPos& (ByVal hWnd%&, Byval hWndInsertAfter%&, Byval X&, Byval Y&, Byval cx&, Byval cy&, Byval uFlags~&)
Function GetForegroundWindow%&
' To make window invisible
Function SetLayeredWindowAttributes& (ByVal hwnd As _Offset, Byval crKey As Long, Byval bAlpha As _Unsigned _Byte, Byval dwFlags As Long)
Function GetWindowLong& Alias "GetWindowLongA" (ByVal hwnd As _Offset, Byval nIndex As Long)
Function SetWindowLong& Alias "SetWindowLongA" (ByVal hwnd As _Offset, Byval nIndex As Long, Byval dwNewLong As Long)
End Declare
Declare Dynamic Library "kernel32"
Function GetLastError~& ()
End Declare
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' To keep focus on window
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
'Declare Dynamic Library "user32"
' Sub ShowWindow (ByVal hWnd As _Offset, Byval nCmdShow As Long)
'End Declare
' ================================================================================================================================================================
' END Dynamic Library definitions
' ================================================================================================================================================================
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END API DECLARATIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN GLOBAL VARIABLES
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' GLOBAL VARIABLES TO TRACK ERROR STATE
Dim Shared m_sError As String: m_sError = ""
Dim Shared m_sIncludeError As String: m_sIncludeError = ""
' BASIC PROGRAM METADATA
Dim Shared m_ProgramPath$: m_ProgramPath$ = Left$(Command$(0), _InStrRev(Command$(0), "\"))
Dim Shared m_ProgramName$: m_ProgramName$ = Mid$(Command$(0), _InStrRev(Command$(0), "\") + 1)
Dim Shared m_sTriggerFile As String: m_sTriggerFile = m_ProgramPath$ + "ReadMiceSub.DELETE-TO-CLOSE"
Dim Shared m_sDebugFile As String: m_sDebugFile = m_ProgramPath$ + m_ProgramName$ + ".txt"
' RAW INPUT VARIABLES
Dim Shared rawinputdevices As String
Dim Shared hDlg As _Unsigned Long ' DWORD
' MOUSE VARIABLES
Dim Shared arrMouse(0 To 8) As MouseInfoType ' STORES INFO FOR EACH MOUSE
Dim Shared iMouseCount As Integer ' # OF MICE ATTACHED
Dim Shared iMinX As Long
Dim Shared iMaxX As Long
Dim Shared iMinY As Long
Dim Shared iMaxY As Long
' KEYBOARD VARIABLES
'Dim Shared arrKeyIndex(8) As String ' STORES KEYBOARD ID
'Dim Shared arrLastKeyDown(8) As Integer ' STORES LAST KEY PRESSED
'Dim Shared arrLastKeyUp(8) As Integer ' STORES LAST KEY RELEASED
'Dim Shared iKeyBoardCount As Integer ' # OF KEYBOARDS ATTACHED
Dim Shared iLastKeyDown As Integer
Dim Shared iLastKeyUp As Integer
' NETWORK VARIABLES
Dim Shared uintPort As _Unsigned Integer ' port
Dim Shared lngConn As Long ' c&
Dim Shared iData As Integer ' i
Dim Shared sOutput As String ' s$
' HANDLE FOR THE PROGRAM WINDOW
Dim Shared MyHwnd As _Offset ' _Integer64 hwnd%&
Dim Shared hwndMain As _Offset
' SCREEN SIZE
Dim Shared lngScreenWidth As Long
Dim Shared lngScreenHeight As Long
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END GLOBAL VARIABLES
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' DEACTIVATE DEBUGGING WINDOW
If cDebugEnabled = TRUE Then
' _Console Off
End If
' EXIT PROGRAM
System ' return control to the operating system
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN GLOBAL ERROR HANDLER
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
ErrorHandler:
m_sError = "Error #" + _Trim$(Str$(Err)) + " at line " + _Trim$(Str$(_ErrorLine)) + "."
m_sIncludeError = "File " + Chr$(34) + _InclErrorFile$ + Chr$(34) + " at line " + _Trim$(Str$(_InclErrorLine)) + "."
Resume Next
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END GLOBAL ERROR HANDLER
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN MAIN ROUTINES
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Sub main
Dim sPort As String
Dim iLoop As Integer
Dim in$
Dim MyTime##
' MAKE SURE WE HAVE INPUT
sPort = Command$(1)
If Len(sPort) > 0 Then
If IsNumber%(sPort) = TRUE Then
' OPEN CONNECTION
uintPort = Val(sPort)
lngConn = _OpenClient("tcp/ip:" + _Trim$(Str$(uintPort)) + ":localhost")
Print lngConn
' ****************************************************************************************************************************************************************
' ****************************************************************************************************************************************************************
' SET UP WINDOW TO BE SAME SIZE AS, AND OVERLAPPED WITH HOST WINDOW
' ****************************************************************************************************************************************************************
' ****************************************************************************************************************************************************************
' SET UP WINDOW
'Screen _NewImage(1024, 768, 32)
Screen 12 ' SCREEN 12 can use 16 color attributes with a black background. 256K possible RGB color hues. Background colors can be used with QB64.
' window needs to be lined up directly under the main program, so the mouse coordinates align with the display
_ScreenMove 0, 0 ' <<< NOT WORKING, HOW DO WE DO THIS IN THE EVENT MODEL?
'' ATTEMPT FULLSCREEN <- NOT REALLY WORKING
'_FULLSCREEN _STRETCH, _SMOOTH
'IF _FULLSCREEN = 0 THEN _FULLSCREEN _OFF 'check that a full screen mode initialized
' TRY JUST SAVING THE DESKTOP SIZE AND USING THAT WHEN DOING A NEW SCREEN
' Use _DESKTOPWIDTH and _DESKTOPHEIGHT to find the current desktop resolution to place the program’s window.
lngScreenWidth = 1024 '_DesktopWidth
lngScreenHeight = 768 '_DesktopHeight
'' CLICK ON SCREEN TO GIVE IT THE FOCUS
''_SCREENCLICK column%, row%[, button%]
'_SCREENCLICK 0, 0
' CREATE TRIGGER FILE
Open m_sTriggerFile For Output As #1
Print #1, "Deleting this file will cause program " + m_ProgramName$ + " to stop running."
Close #1
' WAIT UNTIL FILE IS CREATED
' (time out after 10 seconds)
MyTime## = ExtendedTimer + 10
Do
If _FileExists(m_sTriggerFile) = TRUE Then Exit Do
Loop Until Timer > MyTime##
If _FileExists(m_sTriggerFile) = FALSE Then
m_sError = "Trigger file not found: " + Chr$(34) + m_sTriggerFile + Chr$(34)
End If
If Len(m_sError) = 0 Then
' GET HANDLE TO THE PROGRAM WINDOW
Do
MyHwnd = _WindowHandle
Loop Until MyHwnd
' GIVE CONTROL TO THE EVENT-ORIENTED CODE
System Val(Str$(WinMain))
Else
Print "ERROR: " + m_sError
End If
Else
Print "Invalid non-numeric input " + Chr$(34) + sPort + Chr$(34) + ". Exiting."
End If
Else
Print "No input. Exiting."
End If
End Sub ' main
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END MAIN ROUTINES
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN RAW INPUT FUNCTIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' /////////////////////////////////////////////////////////////////////////////
' Runs first
Function WinMain~%& ()
'Dim As Offset hwndMain
Dim As Offset hInst
Dim As Offset hWndTop
Dim As MSG msg
Dim As WNDCLASSEX wndclass
Dim As String szMainWndClass
Dim As String szWinTitle
Dim As Unsigned Integer reg
Dim sData As String
Dim iKeyLoop As Integer
Dim iKeyCode As Integer
Dim iLoop As Integer
Dim sResult As String
'DEBUG: TRY FULL SCREEN <- PROGRAM CRASHES!
'_FullScreen _SquarePixels
hInst = GetModuleHandle(0)
szMainWndClass = "WinTestWin" + Chr$(0)
szWinTitle = cProgName + Chr$(0)
wndclass.lpszClassName = Offset(szMainWndClass)
wndclass.cbSize = Len(wndclass)
wndclass.style = CS_HREDRAW Or CS_VREDRAW
wndclass.lpfnWndProc = WindowProc
wndclass.hInstance = hInst 'GetModuleHandle(0) will return the hInstance of this EXE
wndclass.hIcon = LoadIcon(0, MAKEINTRESOURCE(IDI_APPLICATION))
wndclass.hIconSm = LoadIcon(0, MAKEINTRESOURCE(IDI_APPLICATION))
wndclass.hCursor = LoadCursor(0, MAKEINTRESOURCE(IDC_ARROW))
wndclass.hbrBackground = COLOR_WINDOW + 1
reg = RegisterClassEx(Offset(wndclass)) 'I prefer to use the output of RegisterClassEx rather than the window name
' INITIALIZE RAW INPUT
InitRawInput
If Len(m_sError) = 0 Then
' SET WINDOW SiZE + INITIALIZE WINDOW
'Q: HOW CAN WE USE THE QB64PE PROGRAM'S WINDOW HANDLE e.g. _WindowHandle ?
hwndMain = CreateWindowEx( _
0, _
MAKELPARAM(reg, 0), _
Offset(szWinTitle), _
WS_OVERLAPPEDWINDOW, _
0, _
0, _
lngScreenWidth, _
lngScreenHeight, _
0, _
0, _
hInst, _
0)
ShowWindow hwndMain, SW_SHOW
' TURN SUB WINDOW INVISIBLE
''SetWindowOpacity MyHwnd, cInvisible
'SetWindowOpacity hwndMain, cTransparent ' <- USE THIS FOR TESTING
'SetWindowOpacity hwndMain, 50 ' <- USE THIS FOR TESTING
SetWindowOpacity hwndMain, cInvisible
' MOVE WINDOW TO TOP
'' GET WINDOW HANDLES
'hWndThis = _WindowHandle ' FindWindowA(0, _OFFSET(t))
hWndTop = GetForegroundWindow%& ' find currently focused process handle
' GET FOCUS
If hwndMain <> hWndTop Then
_ScreenClick 240, 240 ' add 40 to x and y to focus on positioned window
End If
' MOVE TO TOP
'Function SetWindowPos& (ByVal hWnd%&, Byval hWndInsertAfter%&, Byval X&, Byval Y&, Byval cx&, Byval cy&, Byval uFlags~&)
'If SetWindowPos(hwndMain, HWND_TOPMOST, 200, 200, 0, 0, SWP_NOSIZE Or SWP_NOACTIVATE) = 0 Then
If SetWindowPos(hwndMain, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOSIZE Or SWP_NOACTIVATE) = 0 Then
'sNextError = "SetWindowPos failed. 0x" + LCase$(Hex$(GetLastError))
m_sError = "SetWindowPos failed. 0x" + LCase$(Hex$(GetLastError))
End If
' MAIN PROGRAM LOOP
While GetMessage(Offset(msg), 0, 0, 0)
TranslateMessage Offset(msg)
DispatchMessage Offset(msg)
' QUIT IF TRIGGER FILE IS GONE
If _FileExists(m_sTriggerFile) = FALSE Then
System
End If
' KEEP WINDOW ON TOP
If _WindowHasFocus = 0 Then
_ScreenIcon
''ShowWindow MyHwnd, 1
'ShowWindow hwndMain, 1
ShowWindow hwndMain, SW_SHOW
End If
Wend
Else
'If cDebugEnabled = TRUE Then
' DebugLog "Error, can't return hwndMain: " + m_sError
'End If
End If
End If
' SEND ANY ERROR MESSAGES BACK TO MAIN
If Len(m_sError) > 0 Then
_Delay 2
sData = "e:" + m_sError + Chr$(13)
Put #lngConn, , sData
_Delay 2
' SHOW EROR MESSAGE
If cDebugEnabled Then
Screen 0
Cls
Print "Error:"
Print m_sError
Sleep
End If
End If
' RETURN A VALUE
WinMain = msg.wParam
End Function ' WinMain
' /////////////////////////////////////////////////////////////////////////////
' Handles main window events
' MESSAGE TYPES FOR READING THE KEYBOARD:
' WM_CHAR
' WM_KEYDOWN
' WM_KEYUP
' WM_SYSCHAR
' WM_SYSKEYDOWN
' WM_SYSKEYUP
Function MainWndProc%& (hwnd As Offset, nMsg As Unsigned Long, wParam As Unsigned Offset, lParam As Offset)
' EVENT HANDLER VARIABLES PART 1
Static As Offset hwndButton
Static As Long cx, cy
Dim As Offset hdc
Dim As PAINTSTRUCT ps
Dim As RECT rc
Dim As RECT TargetRect
Dim As MEM lpb
Dim As Unsigned Long dwSize
Dim As RAWINPUT rawm ' MOUSE VERSION
Dim As RAWINPUT_K rawk ' KEYBOARD VERSION
Dim As Long tmpx, tmpy
Static As Long maxx
Dim As RAWINPUTHEADER rih
' TEMP VARIABLES FOR DISPLAYING FORMATTED VALUES TO SCREEN
Dim strNextID As String
Dim iIndex As Integer
Dim iRowOffset As Integer
Dim iLine As Integer
Dim iLen As Integer
Dim iCount As Integer
Dim sCount As String
Dim sText As String
Dim sX As String
Dim sY As String
Dim sPX As String
Dim sPY As String
Dim sWheel As String
Dim sLeftDown As String
Dim sMiddleDown As String
Dim sRightDown As String
Dim sLeftCount As String
Dim sMiddleCount As String
Dim sRightCount As String
Dim sNext As String
Dim iNewX As Integer
Dim iNewY As Integer
Dim iDX As Integer
Dim iDY As Integer
Dim iInputType As Integer
' EVENT HANDLER VARIABLES PART 2
Dim pRawInput As _Offset ' RAWINPUT POINTER
Dim zKeyName As String ' ASCIIZ * 50 = NULL-terminated string
Dim sRawInput As String
Dim sBuffer As String
Dim ScanCode As _Unsigned Long ' DWORD
Static hFocusBak As _Unsigned Long ' DWORD
Dim RawInputDevCount As Long
Dim KeyboardTypeCount As Long
Dim RawInputDeviceIndex As Long
Dim ByteCount As Long
Dim int_wParam As Integer
Dim vbCrLf As String: vbCrLf = Chr$(13) + Chr$(10)
Dim vbCr As String: vbCr = Chr$(13)
Dim vbLf As String: vbLf = Chr$(10)
ReDim arrText$(0)
' HANDLE EVENT MESSAGES
Select Case nMsg
Case WM_DESTROY:
'DebugPrint "nMsg = WM_DESTROY"
PostQuitMessage 0
MainWndProc = 0
Exit Function
' KEYBOARD VERSION:
'GetRawInputData(CBLPARAM, %RID_INPUT, BYVAL %NULL, ByteCount, SIZEOF(RAWINPUTHEADER)) ' Get size of raw input buffer
lpb = MemNew(dwSize)
If lpb.SIZE = 0 Then
MainWndProc = 0
Exit Function
End If
' GET THE RAW INPUT
If GetRawInputData(lParam, RID_INPUT, lpb.OFFSET, Offset(dwSize), Len(rih)) <> dwSize Then
'TODO: BUBBLE UP THE ERROR MESSAGE?
Print "GetRawInputData doesn't return correct size!"
'DebugPrint "WRONG SIZE: GetRawInputData doesn't return correct size!"
End If
' IDENTIFY TYPE OF INPUT
Select Case dwSize
Case Len(rawm):
' MOUSE INPUT
'DebugPrint "dwSize = Len(rawm) so MOUSE INPUT DETECTED"
iInputType = RIM_TYPEMOUSE
MemGet lpb, lpb.OFFSET, rawm
Case Len(rawk):
' KEYBOARD INPUT
'DebugPrint "dwSize = Len(rawk) so KEYBOARD INPUT DETECTED"
iInputType = RIM_TYPEKEYBOARD
MemGet lpb, lpb.OFFSET, rawk
Case Else:
' SOME OTHER TYPE (MAYBE HID) BUT ONE WE CAN'T PROCESS
'DebugPrint "dwSize = SOME OTHER TYPE (MAYBE HID)"
iInputType = RIM_TYPEUNKNOWN
End Select
If iInputType = RIM_TYPEMOUSE Then
'DebugLog "iInputType = RIM_TYPEMOUSE"
If rawm.header.dwType = RIM_TYPEMOUSE Then
'DebugLog " rawm.header.dwType = RIM_TYPEMOUSE"
' UPDATE RANGE OF MOUSE COORDINATES
If GET_X_LPARAM(lParam) < iMinX Then iMinX = GET_X_LPARAM(lParam)
If GET_X_LPARAM(lParam) > iMaxX Then iMaxX = GET_X_LPARAM(lParam)
If GET_Y_LPARAM(lParam) < iMinY Then iMinY = GET_Y_LPARAM(lParam)
If GET_Y_LPARAM(lParam) > iMaxY Then iMaxY = GET_Y_LPARAM(lParam)
' CHECK HIRES CURSOR BOUNDARIES
If arrMouse(iIndex).px < cMinPX Then arrMouse(iIndex).px = cMinPX
If arrMouse(iIndex).px > cMaxPX Then arrMouse(iIndex).px = cMaxPX
If arrMouse(iIndex).py < cMinPY Then arrMouse(iIndex).py = cMinPY
If arrMouse(iIndex).py > cMaxPY Then arrMouse(iIndex).py = cMaxPY
' =============================================================================
' left button = 1 when down, 2 when released
If ((rawm.mouse.usButtonFlags And 1) = 1) Then
arrMouse(iIndex).LeftDown = TRUE
ElseIf ((rawm.mouse.usButtonFlags And 2) = 2) Then
arrMouse(iIndex).LeftDown = FALSE
End If
'DebugLog " arrMouse(iIndex).LeftDown = " + TrueFalse$(arrMouse(iIndex).LeftDown)
' =============================================================================
' middle button = 16 when down, 32 when released
If ((rawm.mouse.usButtonFlags And 16) = 16) Then
arrMouse(iIndex).MiddleDown = TRUE
ElseIf ((rawm.mouse.usButtonFlags And 32) = 32) Then
arrMouse(iIndex).MiddleDown = FALSE
End If
'DebugLog " arrMouse(iIndex).MiddleDown = " + TrueFalse$(arrMouse(iIndex).MiddleDown)
' =============================================================================
' right button = 4 when down, 8 when released
If ((rawm.mouse.usButtonFlags And 4) = 4) Then
arrMouse(iIndex).RightDown = TRUE
ElseIf ((rawm.mouse.usButtonFlags And 8) = 8) Then
arrMouse(iIndex).RightDown = FALSE
End If
'DebugLog " arrMouse(iIndex).RightDown = " + TrueFalse$(arrMouse(iIndex).RightDown)
' CLEAR MOVEMENT
arrMouse(iIndex).dx = 0
arrMouse(iIndex).dy = 0
'arrMouse(iIndex).wheelOld = arrMouse(iIndex).wheel
'arrMouse(iIndex).LeftDownOld = arrMouse(iIndex).LeftDown
'arrMouse(iIndex).MiddleDownOld = arrMouse(iIndex).MiddleDown
'arrMouse(iIndex).RightDownOld = arrMouse(iIndex).RightDown
End If
End If
'' INVOKE PAINT
'InvalidateRect hwnd, 0, -1
'SendMessage hwnd, WM_PAINT, 0, 0
End If
ElseIf iInputType = RIM_TYPEKEYBOARD Then
' *** FOR NOW RAW KEYBOARD INPUT NOT WORKING
'DebugPrint "iInputType = RIM_TYPEKEYBOARD"
'If rawk.header.dwType = RIM_TYPEKEYBOARD Then
' DebugPrint "* FOUND RAW INPUT KEYBOARD *"
'
' ' HOW DO WE READ THE KEYBOARD USING RawInputAPI ???
' DebugPrint "rawk.header.dwType = RIM_TYPEKEYBOARD"
'
' ' IDENTIFY WHICH KEYBOARD IT IS
' strNextID = _Trim$(Str$(rawk.header.hDevice))
' DebugPrint " strNextID = " + Chr$(34) + strNextID + Chr$(34)
'
' '' GET ARRAY INDEX FROM strnextID
' 'iIndex = GetKeyboardIndex%(strNextID)
' 'DebugPrint " iIndex = " + _Trim$(Str$(iIndex))
'
'End If
End If
' FINISHUP WM_INPUT
MemFree lpb
MainWndProc = 0
Exit Function
Case WM_MOUSEMOVE:
'DebugPrint "nMsg = WM_MOUSEMOVE"
Exit Function
Case WM_PAINT:
'DebugPrint "nMsg = WM_PAINT"
'hdc = BeginPaint(hwnd, Offset(ps))
'GetClientRect hwnd, Offset(rc)
'
'' -----------------------------------------------------------------------------
'' DISPLAY MOUSE INFO ON SCREEN AT MOUSE POSITIONS
'iCount = 0
'For iIndex = LBound(arrMouse) To UBound(arrMouse)
' iCount = iCount + 1
'
' If Len(arrMouse(iIndex).ID) > 0 Then
' ' CHECK CURSOR BOUNDARIES
' If arrMouse(iIndex).x < cMinX Then arrMouse(iIndex).x = cMinX
' If arrMouse(iIndex).x > cMaxX Then arrMouse(iIndex).x = cMaxX
' If arrMouse(iIndex).y < cMinY Then arrMouse(iIndex).y = cMinY
' If arrMouse(iIndex).y > cMaxY Then arrMouse(iIndex).y = cMaxY
'
' ' CHECK HIRES CURSOR BOUNDARIES
' If arrMouse(iIndex).px < cMinPX Then arrMouse(iIndex).px = cMinPX
' If arrMouse(iIndex).px > cMaxPX Then arrMouse(iIndex).px = cMaxPX
' If arrMouse(iIndex).py < cMinPY Then arrMouse(iIndex).py = cMinPY
' If arrMouse(iIndex).py > cMaxPY Then arrMouse(iIndex).py = cMaxPY
'
' ' DEFINE TARGET RECT FOR WHERE TO DRAW ON SCREEN
' TargetRect.left = rc.left + arrMouse(iIndex).px
' TargetRect.top = rc.top + arrMouse(iIndex).py
' TargetRect.right = rc.right + arrMouse(iIndex).px
' TargetRect.bottom = rc.bottom + arrMouse(iIndex).py
'
' ' COLLECT VALUES FOR THIS MOUSE IN A STRING
' sText = ""
' sText = sText + _Trim$(Str$(iCount))
' sText = sText + " ("
' sText = sText + _Trim$(Str$(arrMouse(iIndex).px))
' sText = sText + ","
' sText = sText + _Trim$(Str$(arrMouse(iIndex).py))
' sText = sText + ") "
' sText = sText + IIFS$(arrMouse(iIndex).LeftDown, "1", " ")
' sText = sText + IIFS$(arrMouse(iIndex).MiddleDown, "2", " ")
' sText = sText + IIFS$(arrMouse(iIndex).RightDown, "3", " ")
'
' 'arrMouse(iIndex).wheel
' 'arrMouse(iIndex).char
' 'arrMouse(iIndex).y
' 'arrMouse(iIndex).x
'
' ' DRAW VALUES FOR THIS MOUSE TO SCREEN AT POINTER POSITION
' DrawText hdc, Offset(sText), Len(sText), Offset(TargetRect), DT_LEFT
' OffsetRect Offset(TargetRect), arrMouse(iIndex).px, arrMouse(iIndex).px
' End If
'Next iIndex
'
'' -----------------------------------------------------------------------------
'' DISPLAY INSTRUCTIONS ON SCREEN
'' DEFINE TARGET RECT FOR WHERE TO DRAW ON SCREEN
'TargetRect.left = rc.left + 100
'TargetRect.top = rc.top + 500
'TargetRect.right = rc.right + 100
'TargetRect.bottom = rc.bottom + 500
'
'' COLLECT VALUES FOR THIS KEYBOARD IN A STRING
'sText = ""
'sText = sText + "Raw Input API multi-mouse demo:"
'sText = sText + Chr$(13)
'sText = sText + Chr$(13)
'sText = sText + "1. Plug in 2 or more USB mice"
'sText = sText + Chr$(13)
'sText = sText + "2. Move them around and click the buttons."
'sText = sText + Chr$(13)
'sText = sText + "3. Try pressing some keys on the keyboard."
'sText = sText + Chr$(13)
'sText = sText + Chr$(13)
'sText = sText + "Press ESC to exit."
'
'' DRAW VALUES FOR THIS KEYBOARD TO SCREEN AT NEXT POSITION
'DrawText hdc, Offset(sText), Len(sText), Offset(TargetRect), DT_LEFT
'OffsetRect Offset(TargetRect), 0, 0 ' y,x
'
'' -----------------------------------------------------------------------------
'' DISPLAY KEYBOARD INFO ON SCREEN
'' DEFINE TARGET RECT FOR WHERE TO DRAW ON SCREEN
'TargetRect.left = rc.left + 400
'TargetRect.top = rc.top + 100
'TargetRect.right = rc.right + 400
'TargetRect.bottom = rc.bottom + 100
'
'' COLLECT VALUES FOR THIS KEYBOARD IN A STRING
'sText = ""
'sText = sText + "Keyboard: "
'sText = sText + IIFS$(iLastKeyDown > 0, VirtualKeyCodeToString$(iLastKeyDown) + " (" + _Trim$(Str$(iLastKeyDown)) + ")", "")
''sText = sText + Chr$(13)
''sText = sText + " LAST DOWN="
''sText = sText + IIFS$(iLastKeyDown > 0, VirtualKeyCodeToString$(iLastKeyDown), "")
''sText = sText + Chr$(13)
''sText = sText + " LAST UP ="
''sText = sText + IIFS$(iLastKeyUp > 0, VirtualKeyCodeToString$(iLastKeyUp), "")
'
'' DRAW VALUES FOR THIS KEYBOARD TO SCREEN AT NEXT POSITION
'DrawText hdc, Offset(sText), Len(sText), Offset(TargetRect), DT_LEFT
'OffsetRect Offset(TargetRect), 0, 0 ' y,x
'
'' -----------------------------------------------------------------------------
'' FINISH PAINT
'EndPaint hwnd, Offset(ps)
'
MainWndProc = 0
Exit Function
Case WM_CHAR:
'DebugPrint "nMsg = WM_CHAR"
'' GET AN INTEGER FROM WPARAM
'If wParam < 32768 Then
' int_wParam = Val(_Trim$(Str$(wParam)))
'Else
' int_wParam = -1
'End If
'
'' WM_CHAR message
'' https://learn.microsoft.com/en-us/windows/win32/inputdev/wm-char
'' Posted to the window with the keyboard focus when a WM_KEYDOWN message is translated by the TranslateMessage function. The WM_CHAR message contains the character code of the key that was pressed.
'DebugPrint "nMsg = WM_CHAR"
'DebugPrint " Offset hwnd=" + _Trim$(Str$(hwnd)) + ", Unsigned Long nMsg=" + _Trim$(Str$(nMsg)) + ", Unsigned Offset wParam=" + _Trim$(Str$(wParam)) + ", Offset lParam=" + _Trim$(Str$(lParam))
'DebugPrint " Pressed key: " + VirtualKeyCodeToString$(int_wParam)
'
'' INVOKE PAINT
'InvalidateRect hwnd, 0, -1
'SendMessage hwnd, WM_PAINT, 0, 0
'MainWndProc = 0
Exit Function
Case WM_KEYDOWN:
'DebugPrint "nMsg = WM_KEYDOWN"
' GET AN INTEGER FROM WPARAM
If wParam < 32768 Then
int_wParam = Val(_Trim$(Str$(wParam)))
Else
int_wParam = -1
End If
' REMEMBER KEY
iLastKeyDown = int_wParam
' WM_KEYDOWN message
' Posted to the window with the keyboard focus when a nonsystem key is pressed. A nonsystem key is a key that is pressed when the ALT key is not pressed.
' https://learn.microsoft.com/en-us/windows/win32/inputdev/wm-keydown
'DebugPrint "nMsg = WM_KEYDOWN"
'DebugPrint " strNextID =" + Chr$(34) + strNextID + Chr$(34)
'DebugPrint " Offset hwnd=" + _Trim$(Str$(hwnd)) + ", Unsigned Long nMsg=" + _Trim$(Str$(nMsg)) + ", Unsigned Offset wParam=" + _Trim$(Str$(wParam)) + ", Offset lParam=" + _Trim$(Str$(lParam))
'DebugPrint " Pressed key: " + VirtualKeyCodeToString$(int_wParam)
' SEND KEYDOWN EVENT TO HOST
sOutput = "d:" + _Trim$(Str$(int_wParam)) + Chr$(13)
Put #lngConn, , sOutput
' WM_KEYUP message
' https://learn.microsoft.com/en-us/windows/win32/inputdev/wm-keyup
' Posted to the window with the keyboard focus when a nonsystem key is released. A nonsystem key is a key that is pressed when the ALT key is not pressed, or a keyboard key that is pressed when a window has the keyboard focus.
'DebugPrint "nMsg = WM_KEYUP"
'DebugPrint " strNextID =" + Chr$(34) + strNextID + Chr$(34)
'DebugPrint " Offset hwnd=" + _Trim$(Str$(hwnd)) + ", Unsigned Long nMsg=" + _Trim$(Str$(nMsg)) + ", Unsigned Offset wParam=" + _Trim$(Str$(wParam)) + ", Offset lParam=" + _Trim$(Str$(lParam))
'DebugPrint " Pressed key: " + VirtualKeyCodeToString$(int_wParam)
' SEND KEYUP EVENT TO HOST
sOutput = "u:" + _Trim$(Str$(int_wParam)) + Chr$(13)
Put #lngConn, , sOutput
'' EXIT WHEN USER RELEASES ESCAPE KEY
'If int_wParam = 27 Then System
Exit Function
Case WM_SYSCHAR:
'DebugPrint "nMsg = WM_SYSCHAR"
'' GET AN INTEGER FROM WPARAM
'If wParam < 32768 Then
' int_wParam = Val(_Trim$(Str$(wParam)))
'Else
' int_wParam = -1
'End If
'
'' WM_SYSCHAR message
'' https://learn.microsoft.com/en-us/windows/win32/menurc/wm-syschar
'' Posted to the window with the keyboard focus when a WM_SYSKEYDOWN message is translated by the TranslateMessage function. It specifies the character code of a system character key that is, a character key that is pressed while the ALT key is down.
'DebugPrint "nMsg = WM_SYSCHAR"
'DebugPrint " Offset hwnd=" + _Trim$(Str$(hwnd)) + ", Unsigned Long nMsg=" + _Trim$(Str$(nMsg)) + ", Unsigned Offset wParam=" + _Trim$(Str$(wParam)) + ", Offset lParam=" + _Trim$(Str$(lParam))
'DebugPrint " Pressed key: " + VirtualKeyCodeToString$(int_wParam)
'
'' INVOKE PAINT
'InvalidateRect hwnd, 0, -1
'SendMessage hwnd, WM_PAINT, 0, 0
'MainWndProc = 0
Exit Function
Case WM_SYSKEYDOWN:
'DebugPrint "nMsg = WM_SYSKEYDOWN"
' GET AN INTEGER FROM WPARAM
If wParam < 32768 Then
int_wParam = Val(_Trim$(Str$(wParam)))
Else
int_wParam = -1
End If
' REMEMBER KEY
iLastKeyDown = int_wParam
' WM_SYSKEYDOWN message
' https://learn.microsoft.com/en-us/windows/win32/inputdev/wm-syskeydown
' Posted to the window with the keyboard focus when the user presses the F10 key (which activates the menu bar) or holds down the ALT key and then presses another key. It also occurs when no window currently has the keyboard focus; in this case, the WM_SYSKEYDOWN message is sent to the active window. The window that receives the message can distinguish between these two contexts by checking the context code in the lParam parameter.
'DebugPrint "nMsg = WM_SYSKEYDOWN"
'DebugPrint " strNextID =" + Chr$(34) + strNextID + Chr$(34)
'DebugPrint " Offset hwnd=" + _Trim$(Str$(hwnd)) + ", Unsigned Long nMsg=" + _Trim$(Str$(nMsg)) + ", Unsigned Offset wParam=" + _Trim$(Str$(wParam)) + ", Offset lParam=" + _Trim$(Str$(lParam))
'DebugPrint " Pressed key: " + VirtualKeyCodeToString$(int_wParam)
' SEND KEYDOWN EVENT TO HOST
sOutput = "d:" + _Trim$(Str$(int_wParam)) + Chr$(13)
Put #lngConn, , sOutput
' WM_SYSKEYUP message
' https://learn.microsoft.com/en-us/windows/win32/inputdev/wm-syskeyup
' Posted to the window with the keyboard focus when the user releases a key that was pressed while the ALT key was held down. It also occurs when no window currently has the keyboard focus; in this case, the WM_SYSKEYUP message is sent to the active window. The window that receives the message can distinguish between these two contexts by checking the context code in the lParam parameter.
' A window receives this message through its WindowProc function.
'DebugPrint "nMsg = WM_SYSKEYUP"
'DebugPrint " strNextID =" + Chr$(34) + strNextID + Chr$(34)
'DebugPrint " Offset hwnd=" + _Trim$(Str$(hwnd)) + ", Unsigned Long nMsg=" + _Trim$(Str$(nMsg)) + ", Unsigned Offset wParam=" + _Trim$(Str$(wParam)) + ", Offset lParam=" + _Trim$(Str$(lParam))
'DebugPrint " Pressed key: " + VirtualKeyCodeToString$(int_wParam)
' SEND KEYUP EVENT TO HOST
sOutput = "u:" + _Trim$(Str$(int_wParam)) + Chr$(13)
Put #lngConn, , sOutput
Case Else:
' some other message
MainWndProc = DefWindowProc(hwnd, nMsg, wParam, lParam)
End Select
End Function ' MainWndProc
' /////////////////////////////////////////////////////////////////////////////
' Initializes raw input stuff
Sub InitRawInput ()
Dim As RAWINPUTDEVICE Rid(0 To 49)
Dim As Unsigned Long nDevices
Dim As RAWINPUTDEVICELIST RawInputDeviceList
Dim As MEM pRawInputDeviceList
ReDim As RAWINPUTDEVICELIST rawdevs(-1)
Dim As Unsigned Long x
Dim iLoop2 As Integer
Dim strNextID As String
If GetRawInputDeviceList(0, Offset(nDevices), Len(RawInputDeviceList)) <> 0 Then
Exit Sub
End If
' This small block of commented code proves that we've got the device list
ReDim As RAWINPUTDEVICELIST rawdevs(0 To nDevices - 1)
MemGet pRawInputDeviceList, pRawInputDeviceList.OFFSET, rawdevs()
' GET DEVICE INFO
rawinputdevices = "Number of raw input devices:" + Str$(nDevices) + Chr$(13)
iMouseCount = 0
'iKeyBoardCount = 0
For x = 0 To UBound(rawdevs)
rawinputdevices = rawinputdevices + Str$(rawdevs(x).hDevice) + ":" + Str$(rawdevs(x).dwType) + Chr$(13)
' RAWINPUTHEADER (winuser.h) - Win32 apps | Microsoft Learn
' https://learn.microsoft.com/en-us/windows/win32/api/winuser/ns-winuser-rawinputheader
' dwType
' Type: DWORD
' The type of raw input. It can be one of the following values:
' Constant Value Meaning
' RIM_TYPEMOUSE 0 Raw input comes from the mouse.
' RIM_TYPEKEYBOARD 1 Raw input comes from the keyboard.
' RIM_TYPEHID 2 Raw input comes from some device that is not a keyboard or a mouse.
' WHAT TYPE OF DEVICE IS IT?
If rawdevs(x).dwType = RIM_TYPEMOUSE Then
iMouseCount = iMouseCount + 1 ' INCREMENT THE MOUSE COUNT
strNextID = _Trim$(Str$(rawdevs(x).hDevice)) ' GET THE MOUSE DEVICE ID
arrMouse(iMouseCount - 1).ID = strNextID ' SAVE THE MOUSE DEVICE ID
'arrMouse(iMouseCount - 1).UpdateCount = 0
ElseIf rawdevs(x).dwType = RIM_TYPEKEYBOARD Then
'iKeyBoardCount = iKeyBoardCount + 1 ' INCREMENT THE KEYBAORD COUNT
'strNextID = _Trim$(Str$(rawdevs(x).hDevice)) ' GET THE KEYBOARD DEVICE ID
'arrKeyIndex(iKeyBoardCount - 1) = strNextID ' SAVE THE KEYBOARD DEVICE ID
'arrLastKeyDown(iKeyBoardCount - 1) = 0
End If
Next x
' FOR NOW KEYBOARD INFO IS NOT RAW INPUT, UNTIL WE FIGURE IT OUT:
iLastKeyDown = 0
iLastKeyUp = 0
If RegisterRawInputDevices(Offset(Rid()), 1, Len(Rid(0))) = 0 Then
m_sError = "RawInput init failed" + Chr$(0)
End If
End Sub ' InitRawInput
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END RAW INPUT FUNCTIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN WINDOW FUNCTIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' /////////////////////////////////////////////////////////////////////////////
' hWnd = handle to window to set opacity for
' Level = 0 TO 255, 0=totally invisible, 128=transparent, 255=100% solid
Sub SetWindowOpacity (hWnd As _Offset, Level As _Unsigned _Byte)
Const cIndex = -20
Const LWA_ALPHA = &H2
Const WS_EX_LAYERED = &H80000
Dim lngMsg As Long
Dim lngValue As Long
'Function GetWindowLong& Alias "GetWindowLongA" (ByVal hwnd As _Offset, Byval nIndex As Long)
lngMsg = GetWindowLong(hWnd, cIndex)
lngMsg = lngMsg Or WS_EX_LAYERED
'Function SetWindowLong& Alias "SetWindowLongA" (ByVal hwnd As _Offset, Byval nIndex As Long, Byval dwNewLong As Long)
lngValue = SetWindowLong(hWnd, cIndex, lngMsg)
'Function SetLayeredWindowAttributes& (ByVal hwnd As _Offset, Byval crKey As Long, Byval bAlpha As _Unsigned _Byte, Byval dwFlags As Long)
lngValue = SetLayeredWindowAttributes(hWnd, 0, Level, LWA_ALPHA)
End Sub ' SetWindowOpacity
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END WINDOW FUNCTIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN RAW INPUT VARIABLE FUNCTIONS #1
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' /////////////////////////////////////////////////////////////////////////////
' Initialize variables that store mouse + keyboard input
Sub InitInputVars
Dim iIndex As Integer
Dim iLoop As Integer
' FOR NOW ONLY SUPPORT UPTO 8 MICE
If (iMouseCount > 8) Then iMouseCount = 8
' INITIALIZE KEYBOARD STATE VARIABLES
iLastKeyDown = 0
iLastKeyUp = 0
End Sub ' InitInputVars
' /////////////////////////////////////////////////////////////////////////////
' Finds position in array arrMouse where .ID = MouseID
Function GetMouseIndex% (MouseID As String)
Dim iLoop As Integer
Dim iIndex%
iIndex% = LBound(arrMouse) - 1
For iLoop = LBound(arrMouse) To UBound(arrMouse)
If arrMouse(iLoop).ID = MouseID Then
iIndex% = iLoop
Exit For
End If
Next iLoop
GetMouseIndex% = iIndex%
End Function ' GetMouseIndex%
'' /////////////////////////////////////////////////////////////////////////////
'' Finds position in array arrKeyIndex containing KeyboardID
'
'Function GetKeyboardIndex% (KeyboardID As String)
' Dim iLoop As Integer
' Dim iIndex%
' iIndex% = LBound(arrKeyIndex) - 1
' For iLoop = LBound(arrKeyIndex) To UBound(arrKeyIndex)
' If arrKeyIndex(iLoop) = KeyboardID Then
' iIndex% = iLoop
' Exit For
' End If
' Next iLoop
' GetKeyboardIndex% = iIndex%
'End Function ' GetKeyboardIndex%
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END RAW INPUT VARIABLE FUNCTIONS #1
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN FILE FUNCTIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' /////////////////////////////////////////////////////////////////////////////
' QB64 Phoenix Edition › QB64 Rising › Code and Stuff › Help Me!
' Using shell to delete a file
' https://qb64phoenix.com/forum/showthread.php?tid=2618&pid=24683#pid24683
' a740g
' #5
' 04-24-2024, 06:05 AM
'
' There are no commands to directly make copies or backup of files.
' But you could write one with a few lines of code like:
'
' Copies src to dst
' Set overwite to true if dst should be overwritten if present
Sub CopyFile (src As String, dst As String, overwrite As _Byte)
If _FileExists(src) Then
If Not _FileExists(dst) Or (_FileExists(dst) And overwrite) Then
_WriteFile dst, _ReadFile$(src)
End If
End If
End Sub ' CopyFile
' /////////////////////////////////////////////////////////////////////////////
' Convert a value to string and trim it (because normal Str$ adds spaces)
Function cstr$ (myValue)
'cstr$ = LTRIM$(RTRIM$(STR$(myValue)))
cstr$ = _Trim$(Str$(myValue))
End Function ' cstr$
Sub DebugLog (sText As String)
Dim sTime As String
Dim sResult As String
ReDim arrLines(0) As String
Dim iLoop As Integer
Dim sNextLine As String
If _FileExists(m_sDebugFile) = FALSE Then
sResult = PrintFile$(m_sDebugFile, "", FALSE)
End If
If Len(sResult) = 0 Then
sTime = GetCurrentDateTime$("{mm}/{dd}/{yyyy} {hh}:{nn}:{ss} {ampm}")
split sText, Chr$(13), arrLines()
For iLoop = LBound(arrLines) To UBound(arrLines)
sNextLine = sTime + " " + arrLines(iLoop)
sResult = PrintFile$(m_sDebugFile, sNextLine, TRUE)
Next iLoop
End If
End Sub ' DebugLog
Sub DebugLog1 (sText As String)
Dim sResult As String
If _FileExists(m_sDebugFile) Then
sResult = PrintFile$(m_sDebugFile, sText, TRUE)
Else
sResult = PrintFile$(m_sDebugFile, sText, FALSE)
End If
End Sub ' DebugLog
' /////////////////////////////////////////////////////////////////////////////
' QB64 Phoenix Edition › QB64 Rising › Code and Stuff › Help Me!
' Using shell to delete a file
' https://qb64phoenix.com/forum/showthread.php?tid=2618
Sub DeleteFile (sFile As String)
If _FileExists(sFile) Then
'Shell "DELETE " + sFile
'Shell "del " + sFile
Kill sFile
End If
End Sub ' DeleteFile
Function FileExt$ (sFile As String)
Dim iPos As Integer
iPos = _InStrRev(sFile, ".")
If iPos > 0 Then
If Len(sFile) > 1 Then
If iPos > 1 Then
FileExt$ = Right$(sFile, Len(sFile) - iPos)
Else
' dot is first character, return everything after it
FileExt$ = Right$(sFile, Len(sFile) - 1)
End If
Else
' file only has one character, the dot, the file extension is blank
FileExt$ = ""
End If
Else
' no dot found, the file extension is blank
FileExt$ = ""
End If
End Function ' FileExt$
Function NameOnly$ (sFile As String, sSlash As String)
Dim iPos As Integer
'sFile = Replace$(sFile, "/", "\")
iPos = _InStrRev(sFile, sSlash)
If iPos > 0 Then
If Len(sFile) > 1 Then
If iPos > 1 Then
NameOnly$ = Right$(sFile, Len(sFile) - iPos)
Else
' slash is first character, return everything after it
NameOnly$ = Right$(sFile, Len(sFile) - 1)
End If
Else
' file only has one character, the slash, name is blank
NameOnly$ = ""
End If
Else
' slash not found, return the entire thing
NameOnly$ = sFile
End If
End Function ' NameOnly$
Function NoExt$ (sFile As String)
Dim iPos As Integer
iPos = _InStrRev(sFile, ".")
If iPos > 0 Then
If Len(sFile) > 1 Then
If iPos > 1 Then
NoExt$ = Left$(sFile, iPos - 1)
Else
' dot is first character, removing it returns blank!
' our version will just return the name unchanged
' but you can return blank if you prefer
NoExt$ = sFile
End If
Else
' file only has one character, the dot, removing it returns blank!
' our version will just return the name unchanged
' but you can return blank if you prefer
NoExt$ = sFile
End If
Else
' no dot found
' return the name unchanged
NoExt$ = sFile
End If
End Function ' NoExt$
Function PathOnly$ (sFile As String, sSlash As String)
Dim iPos As Integer
'sFile = Replace$(sFile, "/", "\")
iPos = _InStrRev(sFile, sSlash)
If iPos > 0 Then
If Len(sFile) > 1 Then
If iPos > 1 Then
PathOnly$ = Left$(sFile, iPos)
Else
' slash is first character, so not much of a path, return blank
PathOnly$ = ""
End If
Else
' file only has one character, the slash, name is blank
PathOnly$ = ""
End If
Else
' slash not found, so not a path, return blank
PathOnly$ = ""
End If
End Function ' PathOnly$
' /////////////////////////////////////////////////////////////////////////////
' Writes sText to file sFileName.
' If bAppend=TRUE appends to file, else overwrites it.
' Returns blank if successful else returns error message.
Function PrintFile$ (sFileName As String, sText As String, bAppend As Integer)
Dim sError As String: sError = ""
If (bAppend = TRUE) Then
If _FileExists(sFileName) Then
Open sFileName For Append As #1 ' opens an existing file for appending
Else
sError = "Error in PrintFile$ : File not found. Cannot append."
End If
Else
Open sFileName For Output As #1 ' opens and clears an existing file or creates new empty file
End If
If Len(sError) = 0 Then
' NOTE: WRITE places text in quotes in the file
'WRITE #1, x, y, z$
'WRITE #1, sText
' PRINT does not put text inside quotes
Print #1, sText
Close #1
End If
PrintFile$ = sError
End Function ' PrintFile$
' /////////////////////////////////////////////////////////////////////////////
' Fastest way is always to just read the whole life at once and then parse it.
Function ReadTextFile$ (sFileName As String, sDefault As String)
Dim x$
If _FileExists(sFileName) Then
Open sFileName For Binary As #1
x$ = Space$(LOF(1))
Get #1, 1, x$
Close #1
ReadTextFile$ = x$
Else
ReadTextFile$ = sDefault
End If
End Function ' ReadTextFile$
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END FILE FUNCTIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN CONSTANT TO STRING FUNCTIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Function VirtualKeyCodeToString$ (MyInteger As Integer)
Dim Mystring As String
Select Case MyInteger
Case VK_LBUTTON:
Mystring = "VK_LBUTTON"
Case VK_RBUTTON:
Mystring = "VK_RBUTTON"
Case VK_CANCEL:
Mystring = "VK_CANCEL"
Case VK_MBUTTON:
Mystring = "VK_MBUTTON"
Case VK_XBUTTON1:
Mystring = "VK_XBUTTON1"
Case VK_XBUTTON2:
Mystring = "VK_XBUTTON2"
Case VK_BACK:
Mystring = "VK_BACK"
Case VK_TAB:
Mystring = "VK_TAB"
Case VK_CLEAR:
Mystring = "VK_CLEAR"
Case VK_RETURN:
Mystring = "VK_RETURN"
Case VK_SHIFT:
Mystring = "VK_SHIFT"
Case VK_CONTROL:
Mystring = "VK_CONTROL"
Case VK_MENU:
Mystring = "VK_MENU"
Case VK_PAUSE:
Mystring = "VK_PAUSE"
Case VK_CAPITAL:
Mystring = "VK_CAPITAL"
Case VK_KANA:
Mystring = "VK_KANA"
Case VK_HANGUL:
Mystring = "VK_HANGUL"
Case VK_IME_ON:
Mystring = "VK_IME_ON"
Case VK_JUNJA:
Mystring = "VK_JUNJA"
Case VK_FINAL:
Mystring = "VK_FINAL"
Case VK_HANJA:
Mystring = "VK_HANJA"
Case VK_KANJI:
Mystring = "VK_KANJI"
Case VK_IME_OFF:
Mystring = "VK_IME_OFF"
Case VK_ESCAPE:
Mystring = "VK_ESCAPE"
Case VK_CONVERT:
Mystring = "VK_CONVERT"
Case VK_NONCONVERT:
Mystring = "VK_NONCONVERT"
Case VK_ACCEPT:
Mystring = "VK_ACCEPT"
Case VK_MODECHANGE:
Mystring = "VK_MODECHANGE"
Case VK_SPACE:
Mystring = "VK_SPACE"
Case VK_PRIOR:
Mystring = "VK_PRIOR"
Case VK_NEXT:
Mystring = "VK_NEXT"
Case VK_END:
Mystring = "VK_END"
Case VK_HOME:
Mystring = "VK_HOME"
Case VK_LEFT:
Mystring = "VK_LEFT"
Case VK_UP:
Mystring = "VK_UP"
Case VK_RIGHT:
Mystring = "VK_RIGHT"
Case VK_DOWN:
Mystring = "VK_DOWN"
Case VK_SELECT:
Mystring = "VK_SELECT"
Case VK_PRINT:
Mystring = "VK_PRINT"
Case VK_EXECUTE:
Mystring = "VK_EXECUTE"
Case VK_SNAPSHOT:
Mystring = "VK_SNAPSHOT"
Case VK_INSERT:
Mystring = "VK_INSERT"
Case VK_DELETE:
Mystring = "VK_DELETE"
Case VK_HELP:
Mystring = "VK_HELP"
Case VK_0:
Mystring = "VK_0"
Case VK_1:
Mystring = "VK_1"
Case VK_2:
Mystring = "VK_2"
Case VK_3:
Mystring = "VK_3"
Case VK_4:
Mystring = "VK_4"
Case VK_5:
Mystring = "VK_5"
Case VK_6:
Mystring = "VK_6"
Case VK_7:
Mystring = "VK_7"
Case VK_8:
Mystring = "VK_8"
Case VK_9:
Mystring = "VK_9"
Case VK_A:
Mystring = "VK_A"
Case VK_B:
Mystring = "VK_B"
Case VK_C:
Mystring = "VK_C"
Case VK_D:
Mystring = "VK_D"
Case VK_E:
Mystring = "VK_E"
Case VK_F:
Mystring = "VK_F"
Case VK_G:
Mystring = "VK_G"
Case VK_H:
Mystring = "VK_H"
Case VK_I:
Mystring = "VK_I"
Case VK_J:
Mystring = "VK_J"
Case VK_K:
Mystring = "VK_K"
Case VK_L:
Mystring = "VK_L"
Case VK_M:
Mystring = "VK_M"
Case VK_N:
Mystring = "VK_N"
Case VK_O:
Mystring = "VK_O"
Case VK_P:
Mystring = "VK_P"
Case VK_Q:
Mystring = "VK_Q"
Case VK_R:
Mystring = "VK_R"
Case VK_S:
Mystring = "VK_S"
Case VK_T:
Mystring = "VK_T"
Case VK_U:
Mystring = "VK_U"
Case VK_V:
Mystring = "VK_V"
Case VK_W:
Mystring = "VK_W"
Case VK_X:
Mystring = "VK_X"
Case VK_Y:
Mystring = "VK_Y"
Case VK_Z:
Mystring = "VK_Z"
Case VK_LWIN:
Mystring = "VK_LWIN"
Case VK_RWIN:
Mystring = "VK_RWIN"
Case VK_APPS:
Mystring = "VK_APPS"
Case VK_SLEEP:
Mystring = "VK_SLEEP"
Case VK_NUMPAD0:
Mystring = "VK_NUMPAD0"
Case VK_NUMPAD1:
Mystring = "VK_NUMPAD1"
Case VK_NUMPAD2:
Mystring = "VK_NUMPAD2"
Case VK_NUMPAD3:
Mystring = "VK_NUMPAD3"
Case VK_NUMPAD4:
Mystring = "VK_NUMPAD4"
Case VK_NUMPAD5:
Mystring = "VK_NUMPAD5"
Case VK_NUMPAD6:
Mystring = "VK_NUMPAD6"
Case VK_NUMPAD7:
Mystring = "VK_NUMPAD7"
Case VK_NUMPAD8:
Mystring = "VK_NUMPAD8"
Case VK_NUMPAD9:
Mystring = "VK_NUMPAD9"
Case VK_MULTIPLY:
Mystring = "VK_MULTIPLY"
Case VK_ADD:
Mystring = "VK_ADD"
Case VK_SEPARATOR:
Mystring = "VK_SEPARATOR"
Case VK_SUBTRACT:
Mystring = "VK_SUBTRACT"
Case VK_DECIMAL:
Mystring = "VK_DECIMAL"
Case VK_DIVIDE:
Mystring = "VK_DIVIDE"
Case VK_F1:
Mystring = "VK_F1"
Case VK_F2:
Mystring = "VK_F2"
Case VK_F3:
Mystring = "VK_F3"
Case VK_F4:
Mystring = "VK_F4"
Case VK_F5:
Mystring = "VK_F5"
Case VK_F6:
Mystring = "VK_F6"
Case VK_F7:
Mystring = "VK_F7"
Case VK_F8:
Mystring = "VK_F8"
Case VK_F9:
Mystring = "VK_F9"
Case VK_F10:
Mystring = "VK_F10"
Case VK_F11:
Mystring = "VK_F11"
Case VK_F12:
Mystring = "VK_F12"
Case VK_F13:
Mystring = "VK_F13"
Case VK_F14:
Mystring = "VK_F14"
Case VK_F15:
Mystring = "VK_F15"
Case VK_F16:
Mystring = "VK_F16"
Case VK_F17:
Mystring = "VK_F17"
Case VK_F18:
Mystring = "VK_F18"
Case VK_F19:
Mystring = "VK_F19"
Case VK_F20:
Mystring = "VK_F20"
Case VK_F21:
Mystring = "VK_F21"
Case VK_F22:
Mystring = "VK_F22"
Case VK_F23:
Mystring = "VK_F23"
Case VK_F24:
Mystring = "VK_F24"
Case VK_NUMLOCK:
Mystring = "VK_NUMLOCK"
Case VK_SCROLL:
Mystring = "VK_SCROLL"
Case VK_LSHIFT:
Mystring = "VK_LSHIFT"
Case VK_RSHIFT:
Mystring = "VK_RSHIFT"
Case VK_LCONTROL:
Mystring = "VK_LCONTROL"
Case VK_RCONTROL:
Mystring = "VK_RCONTROL"
Case VK_LMENU:
Mystring = "VK_LMENU"
Case VK_RMENU:
Mystring = "VK_RMENU"
Case VK_BROWSER_BACK:
Mystring = "VK_BROWSER_BACK"
Case VK_BROWSER_FORWARD:
Mystring = "VK_BROWSER_FORWARD"
Case VK_BROWSER_REFRESH:
Mystring = "VK_BROWSER_REFRESH"
Case VK_BROWSER_STOP:
Mystring = "VK_BROWSER_STOP"
Case VK_BROWSER_SEARCH:
Mystring = "VK_BROWSER_SEARCH"
Case VK_BROWSER_FAVORITES:
Mystring = "VK_BROWSER_FAVORITES"
Case VK_BROWSER_HOME:
Mystring = "VK_BROWSER_HOME"
Case VK_VOLUME_MUTE:
Mystring = "VK_VOLUME_MUTE"
Case VK_VOLUME_DOWN:
Mystring = "VK_VOLUME_DOWN"
Case VK_VOLUME_UP:
Mystring = "VK_VOLUME_UP"
Case VK_MEDIA_NEXT_TRACK:
Mystring = "VK_MEDIA_NEXT_TRACK"
Case VK_MEDIA_PREV_TRACK:
Mystring = "VK_MEDIA_PREV_TRACK"
Case VK_MEDIA_STOP:
Mystring = "VK_MEDIA_STOP"
Case VK_MEDIA_PLAY_PAUSE:
Mystring = "VK_MEDIA_PLAY_PAUSE"
Case VK_LAUNCH_MAIL:
Mystring = "VK_LAUNCH_MAIL"
Case VK_LAUNCH_MEDIA_SELECT:
Mystring = "VK_LAUNCH_MEDIA_SELECT"
Case VK_LAUNCH_APP1:
Mystring = "VK_LAUNCH_APP1"
Case VK_LAUNCH_APP2:
Mystring = "VK_LAUNCH_APP2"
Case VK_OEM_1:
Mystring = "VK_OEM_1"
Case VK_OEM_PLUS:
Mystring = "VK_OEM_PLUS"
Case VK_OEM_COMMA:
Mystring = "VK_OEM_COMMA"
Case VK_OEM_MINUS:
Mystring = "VK_OEM_MINUS"
Case VK_OEM_PERIOD:
Mystring = "VK_OEM_PERIOD"
Case VK_OEM_2:
Mystring = "VK_OEM_2"
Case VK_OEM_3:
Mystring = "VK_OEM_3"
Case VK_OEM_4:
Mystring = "VK_OEM_4"
Case VK_OEM_5:
Mystring = "VK_OEM_5"
Case VK_OEM_6:
Mystring = "VK_OEM_6"
Case VK_OEM_7:
Mystring = "VK_OEM_7"
Case VK_OEM_8:
Mystring = "VK_OEM_8"
Case VK_OEM_102:
Mystring = "VK_OEM_102"
Case VK_PROCESSKEY:
Mystring = "VK_PROCESSKEY"
Case VK_PACKET:
Mystring = "VK_PACKET"
Case VK_ATTN:
Mystring = "VK_ATTN"
Case VK_CRSEL:
Mystring = "VK_CRSEL"
Case VK_EXSEL:
Mystring = "VK_EXSEL"
Case VK_EREOF:
Mystring = "VK_EREOF"
Case VK_PLAY:
Mystring = "VK_PLAY"
Case VK_ZOOM:
Mystring = "VK_ZOOM"
Case VK_NONAME:
Mystring = "VK_NONAME"
Case VK_PA1:
Mystring = "VK_PA1"
Case VK_OEM_CLEAR:
Mystring = "VK_OEM_CLEAR"
Case Else:
Mystring = _Trim$(Str$(MyInteger))
End Select
VirtualKeyCodeToString$ = Mystring
End Function ' VirtualKeyCodeToString$
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END CONSTANT TO STRING FUNCTIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN GENERAL PURPOSE FUNCTIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' /////////////////////////////////////////////////////////////////////////////
' SMcNeill
' More efficient version of ExtendedTimer.
' This stores our day values and only updates them when necessary.
' We really don't need to figure out how many seconds are in today over and over endlessly
' -- just count them once, and when the clock swaps back to 0:0:0, add 24*60*60 seconds to the count.
' Re: how to time something (ie do loop for n seconds)
' https://forum.qb64.org/index.php?topic=4682.0
Function ExtendedTimer##
'modified extendedtimer to store the old day's count, and not have to recalculate it every time the routine is called.
Static olds As _Float, old_day As _Float
Dim m As Integer, d As Integer, y As Integer
Dim s As _Float, day As String
Dim oldt As Single
If olds = 0 Then 'calculate the day the first time the extended timer runs
day = Date$
m = Val(Left$(day, 2))
d = Val(Mid$(day, 4, 2))
y = Val(Right$(day, 4)) - 1970
Select Case m 'Add the number of days for each previous month passed
Case 2: d = d + 31
Case 3: d = d + 59
Case 4: d = d + 90
Case 5: d = d + 120
Case 6: d = d + 151
Case 7: d = d + 181
Case 8: d = d + 212
Case 9: d = d + 243
Case 10: d = d + 273
Case 11: d = d + 304
Case 12: d = d + 334
End Select
If (y Mod 4) = 2 And m > 2 Then d = d + 1 'add a day if this is leap year and we're past february
d = (d - 1) + 365 * y 'current month days passed + 365 days per each standard year
d = d + (y + 2) \ 4 'add in days for leap years passed
s = d * 24 * 60 * 60 'Seconds are days * 24 hours * 60 minutes * 60 seconds
old_day = s
End If
If Timer < oldt Then 'we went from 23:59:59 (a second before midnight) to 0:0:0 (midnight)
old_day = s + 83400 'add another worth of seconds to our counter
End If
oldt = Timer
olds = old_day + oldt
ExtendedTimer## = olds
End Function ' ExtendedTimer##
' /////////////////////////////////////////////////////////////////////////////
' Simple timestamp function
' Format: {YYYY}-{MM}-{DD} {hh}:[mm}:{ss}
' Uses:
' TIME$
' The TIME$ Function returns a STRING representation
' of the current computer time in a 24 hour format.
' https://qb64phoenix.com/qb64wiki/index.php/TIME$
' DATE$
' The DATE$ function returns the current computer date
' as a string in the format "mm-dd-yyyy".
' https://qb64phoenix.com/qb64wiki/index.php/DATE$
'
' TODO: support template where
' {yyyy} = 4 digit year
' {mm} = 2 digit month
' {dd} = 2 digit day
' {hh} = 2 digit hour (12-hour)
' {rr} = 2 digit hour (24-hour)
' {nn} = 2 digit minute
' {ss} = 2 digit second
' {ampm} = AM/PM
' We got the nn for minute from Microsoft > Office VBA Reference > DateDiff function
' https://docs.microsoft.com/en-us/office/vba/language/reference/user-interface-help/datediff-function
Function GetCurrentDateTime$ (sTemplate$)
Dim sDate$: sDate$ = Date$
Dim sTime$: sTime$ = Time$
Dim sYYYY$: sYYYY$ = Mid$(sDate$, 7, 4)
Dim sMM$: sMM$ = Mid$(sDate$, 1, 2)
Dim sDD$: sDD$ = Mid$(sDate$, 4, 2)
Dim sHH24$: sHH24$ = Mid$(sTime$, 1, 2)
Dim sHH$: sHH$ = ""
Dim sMI$: sMI$ = Mid$(sTime$, 4, 2)
Dim sSS$: sSS$ = Mid$(sTime$, 7, 2)
Dim iHour%: iHour% = Val(sHH24$)
Dim sAMPM$: sAMPM$ = ""
Dim result$: result$ = ""
' FIGURE OUT AM/PM
If InStr(sTemplate$, "{ampm}") > 0 Then
If iHour% = 0 Then
sAMPM$ = "AM"
iHour% = 12
ElseIf iHour% > 0 And iHour% < 12 Then
sAMPM$ = "AM"
ElseIf iHour% = 12 Then
sAMPM$ = "PM"
Else
sAMPM$ = "PM"
iHour% = iHour% - 12
End If
sHH$ = Right$("00" + _Trim$(Str$(iHour%)), 2)
End If
' RETURN RESULT
GetCurrentDateTime$ = result$
End Function ' GetCurrentDateTime$
' /////////////////////////////////////////////////////////////////////////////
' FOR BITWISE OPERATIONS
Function HasBit% (iByte As Integer, iBit As Integer)
''TODO: precalculate
'dim shared m_arrBitValue(1 To 8) As Integer
'dim iLoop as Integer
'For iLoop = 0 To 7
' m_arrBitValue(iLoop + 1) = 2 ^ iLoop
'Next iLoop
'HasBit% = ((iByte And m_arrBitValue(iBit)) = m_arrBitValue(iBit))
Dim iBitValue As Integer
iBitValue = 2 ^ (iBit - 1)
HasBit% = ((iByte And iBitValue) = iBitValue)
End Function ' HasBit%
' /////////////////////////////////////////////////////////////////////////////
' IIF function for QB for integers
Function IIF (Condition, IfTrue, IfFalse)
If Condition Then IIF = IfTrue Else IIF = IfFalse
End Function
' /////////////////////////////////////////////////////////////////////////////
' IIF function for QB for strings
Function IIFS$ (Condition, IfTrue$, IfFalse$)
If Condition Then IIFS$ = IfTrue$ Else IIFS$ = IfFalse$
End Function
' /////////////////////////////////////////////////////////////////////////////
' Returns TRUE if value OriginalString$ is numeric.
' Re: Does a Is Number function exist in QB64?
' https://www.qb64.org/forum/index.php?topic=896.15
' Version 2 by madscijr
' Returns TRUE (-1) if string is an integer, FALSE (0) if not
' Version 1 by MWheatley
' Reply #18 on: January 01, 2019, 11:24:30 AM
' returns 1 if string is an integer, 0 if not
Function IsNumber% (OriginalString$)
Dim bResult%: bResult% = FALSE
Dim iLoop%
Dim TestString$
'Dim bNegative%
Dim iDecimalCount%
Dim sNextChar$
'THEY SHOULD TRIM OUTSIDE THE FUNCTION!
'TestString$ = _TRIM$(OriginalString$)
If Len(OriginalString$) > 0 Then
TestString$ = ""
If Left$(OriginalString$, 1) = "+" Then
TestString$ = Right$(OriginalString$, Len(OriginalString$) - 1)
'bNegative% = FALSE
ElseIf Left$(OriginalString$, 1) = "-" Then
TestString$ = Right$(OriginalString$, Len(OriginalString$) - 1)
'bNegative% = TRUE
Else
TestString$ = OriginalString$
'bNegative% = FALSE
End If
If Len(TestString$) > 0 Then
bResult% = TRUE
iDecimalCount% = 0
For iLoop% = 1 To Len(TestString$)
sNextChar$ = Mid$(TestString$, iLoop%, 1)
If sNextChar$ = "." Then
iDecimalCount% = iDecimalCount% + 1
If iDecimalCount% > 1 Then
' TOO MANY DECIMAL POINTS, INVALID!
bResult% = FALSE
Exit For
End If
ElseIf Asc(sNextChar$) < 48 Or Asc(sNextChar$) > 57 Then
' NOT A NUMERAL OR A DECIMAL, INVALID!
bResult% = FALSE
Exit For
End If
Next iLoop%
End If
End If
IsNumber% = bResult%
End Function ' IsNumber%
' /////////////////////////////////////////////////////////////////////////////
' FROM: String Manipulation
' found at abandoned, outdated and now likely malicious qb64 dot net website
' http://www.qb64.[net]/forum/index_topic_5964-0/
'
'SUMMARY:
' Purpose: A library of custom functions that transform strings.
' Author: Dustinian Camburides (dustinian@gmail.com)
' Platform: QB64 (www.qb64.org)
' Revision: 1.6
' Updated: 5/28/2012
'SUMMARY:
'[Replace$] replaces all instances of the [Find] sub-string with the [Add] sub-string within the [Text] string.
'INPUT:
'Text: The input string; the text that's being manipulated.
'Find: The specified sub-string; the string sought within the [Text] string.
'Add: The sub-string that's being added to the [Text] string.
Function Replace$ (Text1 As String, Find1 As String, Add1 As String)
' VARIABLES:
Dim Text2 As String
Dim Find2 As String
Dim Add2 As String
Dim lngLocation As Long ' The address of the [Find] substring within the [Text] string.
Dim strBefore As String ' The characters before the string to be replaced.
Dim strAfter As String ' The characters after the string to be replaced.
' INITIALIZE:
' MAKE COPIESSO THE ORIGINAL IS NOT MODIFIED (LIKE ByVal IN VBA)
Text2 = Text1
Find2 = Find1
Add2 = Add1
lngLocation = InStr(1, Text2, Find2)
' PROCESSING:
' While [Find2] appears in [Text2]...
While lngLocation
' Extract all Text2 before the [Find2] substring:
strBefore = Left$(Text2, lngLocation - 1)
' Extract all text after the [Find2] substring:
strAfter = Right$(Text2, ((Len(Text2) - (lngLocation + Len(Find2) - 1))))
' Locate the next instance of [Find2]:
lngLocation = InStr(1, Text2, Find2)
' Next instance of [Find2]...
Wend
' OUTPUT:
Replace$ = Text2
End Function ' Replace$
' /////////////////////////////////////////////////////////////////////////////
' Split and join strings
' https://www.qb64.org/forum/index.php?topic=1073.0
'Combine all elements of in$() into a single string with delimiter$ separating the elements.
Function join$ (in$(), delimiter$)
Dim result$
Dim iLoop As Integer
result$ = in$(LBound(in$))
For iLoop = LBound(in$) + 1 To UBound(in$)
result$ = result$ + delimiter$ + in$(iLoop)
Next iLoop
join$ = result$
End Function ' join$
' /////////////////////////////////////////////////////////////////////////////
' Split and join strings
' https://www.qb64.org/forum/index.php?topic=1073.0
'
' FROM luke, QB64 Developer
' Date: February 15, 2019, 04:11:07 AM
'
' Given a string of words separated by spaces (or any other character),
' splits it into an array of the words. I've no doubt many people have
' written a version of this over the years and no doubt there's a million
' ways to do it, but I thought I'd put mine here so we have at least one
' version. There's also a join function that does the opposite
' array -> single string.
'
' Code is hopefully reasonably self explanatory with comments and a little demo.
' Note, this is akin to Python/JavaScript split/join, PHP explode/implode.
'Split in$ into pieces, chopping at every occurrence of delimiter$. Multiple consecutive occurrences
'of delimiter$ are treated as a single instance. The chopped pieces are stored in result$().
'
'delimiter$ must be one character long.
'result$() must have been REDIMmed previously.
' Modified to handle multi-character delimiters
Sub split (in$, delimiter$, result$())
Dim start As Integer
Dim finish As Integer
Dim iDelimLen As Integer
ReDim result$(-1)
iDelimLen = Len(delimiter$)
start = 1
Do
'While Mid$(in$, start, 1) = delimiter$
While Mid$(in$, start, iDelimLen) = delimiter$
'start = start + 1
start = start + iDelimLen
If start > Len(in$) Then
Exit Sub
End If
Wend
finish = InStr(start, in$, delimiter$)
If finish = 0 Then
finish = Len(in$) + 1
End If
ReDim _Preserve result$(0 To UBound(result$) + 1)
result$(UBound(result$)) = Mid$(in$, start, finish - start)
start = finish + 1
Loop While start <= Len(in$)
End Sub ' split
' /////////////////////////////////////////////////////////////////////////////
' Use to pretty print TRUE and FALSE values.
Function TrueFalse$ (myValue)
If myValue = TRUE Then
TrueFalse$ = "TRUE"
Else
TrueFalse$ = "FALSE"
End If
End Function ' TrueFalse$
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END GENERAL PURPOSE FUNCTIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN handle MEM for any type
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' QB64 GPT Just Rewrote My Code
' https://qb64phoenix.com/forum/showthread.php?tid=2728
' And the revisions QB64 GPT made (after minor changes and me asking it to redo some syntax errors):
' It separated out a lot of processing out to separate subs.
' It is quite impressive how little input I had to give it to fix its mistakes.
' The code actually worked just as well as it did before the changes, which blows my mind.
' It actually even listened to me when I told it that it would need to cast an OFFSET type by using VAL(STR$(var)).
' To be fair, I had to tell it "ByRef" was invalid and a couple of other things.
' I also had to declare "y" each time it was used. But the last iteration only required me to declare "y".
' I think that is a decent enough result. Too bad I can't get it to be this good every time.
' 1) This is the paid version of GPT4. I am on the plus plan, so whatever that one has.
' 2) I think I deleted the session. Sorry. I only used it for as long as I needed it.
' 3) I don't know what the hard limit is. It's in "tokens", which I have no idea how those are calculated.
' I got a pretty large source code from one output and it can take a lot of input. I would just say it can handle quite a bit.
' The GPT I used was one I trained using the Wiki, sample code, etc. At the time, it used GPT4.
' Custom GPTs now use 4o. I will probably need to republish it to take advantage of 4o for it.
' I guess training is the wrong word. A custom GPT has a "knowledge base".
' You can have a maximum of 20 files.
' It can use those files to create an answer. Even a zip folder can be used.
' It will basically only use the knowledge base when specifically asked. Otherwise, it is using whatever it already had in its model.
' As for testing code and such, you can create "actions" for your GPT that allow it to do things outside of ChatGPT, including REST API.
' So if dbox ever made a REST API for QBJS, you could definitely have it write QBJS code and then ask it to run it.
Sub anyArg (args() As _MEM)
Dim As _Unsigned Integer x, y
Dim As _Unsigned _Offset z
Dim As _Unsigned Long size, elementsize
For x = LBound(args) To UBound(args)
If _MemExists(args(x)) Then
z = 0
size = Val(Str$(args(x).SIZE))
elementsize = Val(Str$(args(x).ELEMENTSIZE))
If _ReadBit(args(x).TYPE, 7) And _ReadBit(args(x).TYPE, 13) = 0 Then
HandleNumericType args(x), size, elementsize, z
ElseIf _ReadBit(args(x).TYPE, 8) Then
HandleFloatingType args(x), size, elementsize, z
ElseIf _ReadBit(args(x).TYPE, 9) Then
HandleStringType args(x), size, elementsize
ElseIf _ReadBit(args(x).TYPE, 13) And _ReadBit(args(x).TYPE, 7) Then
HandleOffsetType args(x), size, elementsize, z
ElseIf args(x).TYPE = 0 And args(x).SIZE > 0 Then
HandleSoundType args(x)
ElseIf _ReadBit(args(x).TYPE, 14) Then
Print args(x).SIZE, "MEM"
' TODO: Handle other types if necessary
End If
If _ReadBit(args(x).TYPE, 11) Then
Screen args(x).IMAGE
End If
End If
Next
End Sub ' anyArg
' Subroutines for handling specific types
Sub HandleNumericType (arg As _MEM, size As _Unsigned Long, elementsize As _Unsigned Long, z As _Unsigned _Offset)
If _ReadBit(arg.TYPE, 10) Then
If _ReadBit(arg.TYPE, 16) Then
Select Case elementsize
Case 1
Dim As _Unsigned _Byte unsignedbytearray(1 To (size / elementsize))
ProcessArray_UByte unsignedbytearray(), arg, size, elementsize, z, "UBYTE ARRAY"
Case 2
Dim As _Unsigned Integer unsignedintarray(1 To (size / elementsize))
ProcessArray_UInteger unsignedintarray(), arg, size, elementsize, z, "USHORT ARRAY"
Case 4
Dim As _Unsigned Long unsignedlongarray(1 To (size / elementsize))
ProcessArray_ULong unsignedlongarray(), arg, size, elementsize, z, "ULONG ARRAY"
Case 8
Dim As _Unsigned _Integer64 unsignedint64array(1 To (size / elementsize))
ProcessArray_UInt64 unsignedint64array(), arg, size, elementsize, z, "UINT64 ARRAY"
End Select
Else
PrintSingleValue arg, size, elementsize
End If
Else
If _ReadBit(arg.TYPE, 16) Then
Select Case elementsize
Case 1
Dim As _Byte bytearray(1 To (size / elementsize))
ProcessArray_Byte bytearray(), arg, size, elementsize, z, "BYTE ARRAY"
Case 2
Dim As Integer intarray(1 To (size / elementsize))
ProcessArray_Integer intarray(), arg, size, elementsize, z, "SHORT ARRAY"
Case 4
Dim As Long longarray(1 To (size / elementsize))
ProcessArray_Long longarray(), arg, size, elementsize, z, "LONG ARRAY"
Case 8
Dim As _Integer64 int64array(1 To (size / elementsize))
ProcessArray_Int64 int64array(), arg, size, elementsize, z, "INT64 ARRAY"
End Select
Else
PrintSingleValue arg, size, elementsize
End If
End If
End Sub ' HandleNumericType
Sub HandleFloatingType (arg As _MEM, size As _Unsigned Long, elementsize As _Unsigned Long, z As _Unsigned _Offset)
If _ReadBit(arg.TYPE, 16) Then
Select Case elementsize
Case 4
Dim As Single singlearray(1 To (size / elementsize))
ProcessArray_Single singlearray(), arg, size, elementsize, z, "SINGLE ARRAY"
Case 8
Dim As Double doublearray(1 To (size / elementsize))
ProcessArray_Double doublearray(), arg, size, elementsize, z, "DOUBLE ARRAY"
Case 32
Dim As _Float floatarray(1 To (size / elementsize))
ProcessArray_Float floatarray(), arg, size, elementsize, z, "FLOAT ARRAY"
End Select
Else
Select Case size
Case 4
Print _MemGet(arg, arg.OFFSET, Single), "SINGLE"
Case 8
Print _MemGet(arg, arg.OFFSET, Double), "DOUBLE"
Case 32
Print _MemGet(arg, arg.OFFSET, _Float), "FLOAT"
End Select
End If
End Sub ' HandleFloatingType
Sub HandleStringType (arg As _MEM, size As _Unsigned Long, elementsize As _Unsigned Long)
If _ReadBit(arg.TYPE, 16) Then
Dim As String stringarray(1 To (size / elementsize))
Dim As _Unsigned Long y
For y = LBound(stringarray) To UBound(stringarray)
stringarray(y) = Space$(elementsize)
_MemGet arg, (arg.OFFSET) + (y * elementsize - elementsize), stringarray(y)
Print stringarray(y), "STRING ARRAY"
Next
Else
Dim As String stringtest: stringtest = Space$(elementsize)
_MemGet arg, arg.OFFSET, stringtest
Print stringtest
End If
End Sub ' HandleStringType
Sub HandleOffsetType (arg As _MEM, size As _Unsigned Long, elementsize As _Unsigned Long, z As _Unsigned _Offset)
If _ReadBit(arg.TYPE, 10) Then
If _ReadBit(arg.TYPE, 16) Then
Dim As _Unsigned _Offset unsignedoffsetarray(1 To (size / elementsize))
ProcessArray_UOffset unsignedoffsetarray(), arg, size, elementsize, z, "ULONG_PTR ARRAY"
Else
Print _MemGet(arg, arg.OFFSET, _Unsigned _Offset), "ULONG_PTR"
End If
Else
If _ReadBit(arg.TYPE, 16) Then
Dim As _Offset offsetarray(1 To (size / elementsize))
ProcessArray_Offset offsetarray(), arg, size, elementsize, z, "LONG_PTR ARRAY"
Else
Print _MemGet(arg, arg.OFFSET, _Offset), "LONG_PTR"
End If
End If
End Sub ' HandleOffsetType
Sub HandleSoundType (arg As _MEM)
If Not _SndPlaying(arg.SOUND) Then
_SndPlay (arg.SOUND)
End If
Print "SOUND", arg.SIZE, arg.ELEMENTSIZE
End Sub ' HandleSoundType
' Subroutines for processing arrays
Sub ProcessArray_UByte (unsignedbytearray() As _Unsigned _Byte, arg As _MEM, size As _Unsigned Long, elementsize As _Unsigned Long, z As _Unsigned _Offset, typeName As String)
Dim As _Unsigned Long y
For y = LBound(unsignedbytearray) To UBound(unsignedbytearray)
_MemGet arg, arg.OFFSET + z, unsignedbytearray(y)
z = z + elementsize
Print unsignedbytearray(y), typeName
Next
End Sub ' ProcessArray_UByte
Sub ProcessArray_UInteger (unsignedintarray() As _Unsigned Integer, arg As _MEM, size As _Unsigned Long, elementsize As _Unsigned Long, z As _Unsigned _Offset, typeName As String)
Dim As _Unsigned Long y
For y = LBound(unsignedintarray) To UBound(unsignedintarray)
_MemGet arg, arg.OFFSET + z, unsignedintarray(y)
z = z + elementsize
Print unsignedintarray(y), typeName
Next
End Sub ' ProcessArray_UInteger
Sub ProcessArray_ULong (unsignedlongarray() As _Unsigned Long, arg As _MEM, size As _Unsigned Long, elementsize As _Unsigned Long, z As _Unsigned _Offset, typeName As String)
Dim As _Unsigned Long y
For y = LBound(unsignedlongarray) To UBound(unsignedlongarray)
_MemGet arg, arg.OFFSET + z, unsignedlongarray(y)
z = z + elementsize
Print unsignedlongarray(y), typeName
Next
End Sub ' ProcessArray_ULong
Sub ProcessArray_UInt64 (unsignedint64array() As _Unsigned _Integer64, arg As _MEM, size As _Unsigned Long, elementsize As _Unsigned Long, z As _Unsigned _Offset, typeName As String)
Dim As _Unsigned Long y
For y = LBound(unsignedint64array) To UBound(unsignedint64array)
_MemGet arg, arg.OFFSET + z, unsignedint64array(y)
z = z + elementsize
Print unsignedint64array(y), typeName
Next
End Sub ' ProcessArray_UInt64
Sub ProcessArray_Byte (bytearray() As _Byte, arg As _MEM, size As _Unsigned Long, elementsize As _Unsigned Long, z As _Unsigned _Offset, typeName As String)
Dim As _Unsigned Long y
For y = LBound(bytearray) To UBound(bytearray)
_MemGet arg, arg.OFFSET + z, bytearray(y)
z = z + elementsize
Print bytearray(y), typeName
Next
End Sub ' ProcessArray_Byte
Sub ProcessArray_Integer (intarray() As Integer, arg As _MEM, size As _Unsigned Long, elementsize As _Unsigned Long, z As _Unsigned _Offset, typeName As String)
Dim As _Unsigned Long y
For y = LBound(intarray) To UBound(intarray)
_MemGet arg, arg.OFFSET + z, intarray(y)
z = z + elementsize
Print intarray(y), typeName
Next
End Sub ' ProcessArray_Integer
Sub ProcessArray_Long (longarray() As Long, arg As _MEM, size As _Unsigned Long, elementsize As _Unsigned Long, z As _Unsigned _Offset, typeName As String)
Dim As _Unsigned Long y
For y = LBound(longarray) To UBound(longarray)
_MemGet arg, arg.OFFSET + z, longarray(y)
z = z + elementsize
Print longarray(y), typeName
Next
End Sub ' ProcessArray_Long
Sub ProcessArray_Int64 (int64array() As _Integer64, arg As _MEM, size As _Unsigned Long, elementsize As _Unsigned Long, z As _Unsigned _Offset, typeName As String)
Dim As _Unsigned Long y
For y = LBound(int64array) To UBound(int64array)
_MemGet arg, arg.OFFSET + z, int64array(y)
z = z + elementsize
Print int64array(y), typeName
Next
End Sub ' ProcessArray_Int64
Sub ProcessArray_Single (singlearray() As Single, arg As _MEM, size As _Unsigned Long, elementsize As _Unsigned Long, z As _Unsigned _Offset, typeName As String)
Dim As _Unsigned Long y
For y = LBound(singlearray) To UBound(singlearray)
_MemGet arg, arg.OFFSET + z, singlearray(y)
z = z + elementsize
Print singlearray(y), typeName
Next
End Sub ' ProcessArray_Single
Sub ProcessArray_Double (doublearray() As Double, arg As _MEM, size As _Unsigned Long, elementsize As _Unsigned Long, z As _Unsigned _Offset, typeName As String)
Dim As _Unsigned Long y
For y = LBound(doublearray) To UBound(doublearray)
_MemGet arg, arg.OFFSET + z, doublearray(y)
z = z + elementsize
Print doublearray(y), typeName
Next
End Sub ' ProcessArray_Double
Sub ProcessArray_Float (floatarray() As _Float, arg As _MEM, size As _Unsigned Long, elementsize As _Unsigned Long, z As _Unsigned _Offset, typeName As String)
Dim As _Unsigned Long y
For y = LBound(floatarray) To UBound(floatarray)
_MemGet arg, arg.OFFSET + z, floatarray(y)
z = z + elementsize / 2
Print floatarray(y), typeName
Next
End Sub ' ProcessArray_Float
Sub ProcessArray_UOffset (unsignedoffsetarray() As _Unsigned _Offset, arg As _MEM, size As _Unsigned Long, elementsize As _Unsigned Long, z As _Unsigned _Offset, typeName As String)
Dim As _Unsigned Long y
For y = LBound(unsignedoffsetarray) To UBound(unsignedoffsetarray)
_MemGet arg, arg.OFFSET + z, unsignedoffsetarray(y)
z = z + elementsize
Print unsignedoffsetarray(y), typeName
Next
End Sub ' ProcessArray_UOffset
Sub ProcessArray_Offset (offsetarray() As _Offset, arg As _MEM, size As _Unsigned Long, elementsize As _Unsigned Long, z As _Unsigned _Offset, typeName As String)
Dim As _Unsigned Long y
For y = LBound(offsetarray) To UBound(offsetarray)
_MemGet arg, arg.OFFSET + z, offsetarray(y)
z = z + elementsize
Print offsetarray(y), typeName
Next
End Sub ' ProcessArray_Offset
Sub PrintSingleValue (arg As _MEM, size As _Unsigned Long, elementsize As _Unsigned Long)
Select Case size
Case 1
Print _MemGet(arg, arg.OFFSET, _Byte), "BYTE"
Case 2
Print _MemGet(arg, arg.OFFSET, Integer), "SHORT"
Case 4
Print _MemGet(arg, arg.OFFSET, Long), "LONG"
Case 8
Print _MemGet(arg, arg.OFFSET, _Integer64), "INT64"
End Select
End Sub ' PrintSingleValue
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END handle MEM for any type
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ################################################################################################################################################################
' BEGIN DEBUGGING ROUTINES #DEBUG
' ################################################################################################################################################################
' /////////////////////////////////////////////////////////////////////////////
' Prints MyString to console with linebreaks.
' Thanks to:
' SpriggsySpriggs for how to use the QB64 debug console:
' https://www.qb64.org/forum/index.php?topic=3949.0
Sub DebugPrint (MyString As String)
'If cDebugEnabled = TRUE Then
' ReDim arrLines(-1) As String
' Dim iLoop As Integer
' split MyString, Chr$(13), arrLines()
' For iLoop = LBound(arrLines) To UBound(arrLines)
' _Echo arrLines(iLoop)
' Next iLoop
'End If
End Sub ' DebugPrint
' /////////////////////////////////////////////////////////////////////////////
' Simply prints s$ to console (no linebreaks).
Sub DebugPrint1 (s$)
'If cDebugEnabled = TRUE Then
' _Echo s$
'End If
End Sub ' DebugPrint1
' ################################################################################################################################################################
' END DEBUGGING ROUTINES @DEBUG
' ################################################################################################################################################################
' ################################################################################################################################################################
' BEGIN REFERENCE #REFERENCE
' ################################################################################################################################################################
' SOME USEFUL STUFF FOR REFERENCE:
' Type Name Type suffix symbol Minimum value Maximum value Size in Bytes
' --------------------- ------------------ ---------------------------- -------------------------- -------------
' _BIT ` -1 0 1/8
' _BIT * n `n -128 127 n/8
' _UNSIGNED _BIT ~` 0 1 1/8
' _BYTE %% -128 127 1
' _UNSIGNED _BYTE ~%% 0 255 1
' INTEGER % -32,768 32,767 2
' _UNSIGNED INTEGER ~% 0 65,535 2
' LONG & -2,147,483,648 2,147,483,647 4
' _UNSIGNED LONG ~& 0 4,294,967,295 4
' _INTEGER64 && -9,223,372,036,854,775,808 9,223,372,036,854,775,807 8
' _UNSIGNED _INTEGER64 ~&& 0 18,446,744,073,709,551,615 8
' SINGLE ! or none -2.802597E-45 +3.402823E+38 4
' DOUBLE # -4.490656458412465E-324 +1.797693134862310E+308 8
' _FLOAT ## -1.18E-4932 +1.18E+4932 32(10 used)
' _OFFSET %& -9,223,372,036,854,775,808 9,223,372,036,854,775,807 Use LEN
' _UNSIGNED _OFFSET ~%& 0 18,446,744,073,709,551,615 Use LEN
' _MEM none combined memory variable type N/A Use LEN
' LoadInitialValues
FOR y = 1 TO 5
FOR x = 1 TO 5
counter = counter + 1
Grid(y, x) = counter
NEXT
NEXT
ShowArrayValues
REDIM _PRESERVE Grid(10, 10)
ShowArrayValues
END
SUB ShowArrayValues
PRINT "Array Values:": PRINT
FOR y = 1 TO UBOUND(Grid, 1)
PRINT USING "Row ## "; y,
FOR x = 1 TO UBOUND(Grid, 2)
PRINT USING " ##"; Grid(y, x);
NEXT
PRINT
NEXT
PRINT
END SUB
Am I misunderstanding something, or is this a bug? How can I make this work so that the initial values stay in their respective spots?
![[Image: textpg-intro-2x.png]](https://i.ibb.co/7j47FHx/textpg-intro-2x.png)
![[Image: fontmetrics6-4072431861.gif]](https://i.ibb.co/9rzNG1g/fontmetrics6-4072431861.gif)
![[Image: NwRxFe0LQpubwoUpJKem_MT3-3277_9301-copy-...b=444&q=70]](https://massdrop-s3.imgix.net/product-images/drop-matt3o-mt3-3277-custom-keycap-set/FP/NwRxFe0LQpubwoUpJKem_MT3-3277_9301-copy-pdp.jpg?auto=format&fm=jpg&fit=fill&w=820&h=547&bg=f0f0f0&dpr=1&chromasub=444&q=70)
![[Image: 61m5pXHc+6L._AC_SL1500_.jpg]](https://m.media-amazon.com/images/I/61m5pXHc+6L._AC_SL1500_.jpg)
![[Image: 61zQatjqsPL._AC_SL1500_.jpg]](https://m.media-amazon.com/images/I/61zQatjqsPL._AC_SL1500_.jpg)
![[Image: 61ObmcWZudL._AC_SL1500_.jpg]](https://m.media-amazon.com/images/I/61ObmcWZudL._AC_SL1500_.jpg)
![[Image: 2.jpg]](https://retrogames.biz/images/thec64/showcase/2.jpg)
uffix string with code in table
