Yes, it IS possible to read seperate input from two or more USB mice plugged into your PC from your BASIC programs running on Windows!
So far, I have tested it with 5 mice plugged in simultaneously and no issues. I have some more mice laying around somewhere, will test with more when I locate them!
You need 2 programs for this, below.
Also place the files "makeint.h" and "winproc.h" in the same folder.
Compile the 2nd subprogram before running the main program.
(It won't run on its own but that's OK.)
Plug 2-8 USB mice into your PC. (You may need a USB hub for more ports!)
Run "ReadMiceMain" and if your PC prompts for permission say yes.
The main program will automatically open the subprogram which should have the focus.
NOTE: Make sure the subprogram has the focus - clicking the mouse button will shift focus to the main prog and the sub program won't be able to read mice - if that happens, click back on ReadMiceSub.
Try moving the different mice around.
When you quit be sure to close both programs.
It works a lot better with DSMan195276's network piece (no more messy temp files).
(Maybe Spriggsy's Pipecom will work better than using network?)
Still need to do and/or figure out
Capturing mouse clicks and keyboard input (from ReadMiceSub, send to main)
Making ReadMiceSub window invisible (but keep focus on mouse clicks)
and hiding the mouse pointer.
(Steffan-68 shared some code that may help with that, haven't gotten to looking at it yet.)
Line up the windows or else maximize ReadMiceSub so it captures mouse movement across entire screen
Capturing input in full screen mode???
Automatically kill ReadMouseSub when user closes main program.
Feel free to play around and make any improvements or share feedback!
Use it to make your own Pong Doubles, QuadraPong, OctoPong, 8-player Foosball Pong, Warlords, Spacewar!, Space Duel, multiplayer Tempest, cooperative puzzle solving or drawing game, weird multi-mouse musical instrument, or 8-player Duck Hunt games! Use the mice to make simple racing wheel controllers (see pics below, that thing works!) and create your own Super Sprint 8 racing game. The possibilities are endless, LoL.
"ReadMiceMain.bas" main program:
Code: (Select All)
' ################################################################################################################################################################
' Multimouse main program "ReadMiceMain.bas" v0.30
' ################################################################################################################################################################
' -------------------------------------------------------------------------------
' ABOUT
' -------------------------------------------------------------------------------
' Working proof of concept! (Windows only so far)
'
' 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.bas" 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. Make sure the "ReadMiceSub" has the focus - currently, clicking the mouse
' buttons will shift focus "ReadMiceMain" and "ReadMiceSub" won't be able
' to read mice - if that happens, click back on "ReadMiceSub".
'
' 6. Try moving each mouse. Each one should move a different letter.
'
' 7. When quitting be sure to close both programs.
' To enable debugging output: change Const cDebugEnabled to TRUE
' It will output debugging info to the console.
' -------------------------------------------------------------------------------
' TO DO
' -------------------------------------------------------------------------------
' Some issues and things to fix:
' * Make the "ReadMiceSub" window invisible (but still have the focus to detect mice)
' and get "ReadMiceSub" to receive clicking the mouse button (left, middle, right)
' without losing focus (currently clicking the mouse changes focus to "ReadMiceMain"
' and then "ReadMiceSub" can't read mice). Steffan-68 posted some code that might help.
' * Read keypresses and send those as well
' ("ReadMiceSub" has focus so "ReadMiceMain" can't detect keypresses)
' * Hide the real mouse cursor and reactivate it when program closes
' * control the window of "ReadMiceSub" to match "ReadMiceMain" window size and position directly over it.
' * when "ReadMiceMain" quits, have it kill the "ReadMiceSub" subprogram.
' * detect moving the scroll wheel
' * get this 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 Updated program to get mice coordinates via network calls
' Thanks to DSMan195276 for the networking code.
' -------------------------------------------------------------------------------
' 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
'' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
'' CONSTANT FOR 2ND DIMENSION OF arrFile ARRAY
'Const cFileName = 0
'Const cFileData = 1
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' CONSTANT FOR WHAT DATA IS EXPECTED FROM THIS LINE IN FILE
Const cForPlayer = 1
Const cUpdateCount = 2
Const cMouseDX = 3
Const cMouseDY = 4
Const cMouseWheel = 5
Const cMouseLeftDown = 6
Const cMouseMiddleDown = 7
Const cMouseRightDown = 8
Const cMouseSpeedX = 1 ' smaller = faster
Const cMouseSpeedY = 3 ' smaller = faster
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END CONSTANTS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN API DECLARATIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' FOR CONTROLLING WINDOW ON TOP, ETC.
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
Declare Dynamic Library "user32"
Function FindWindowA%& (ByVal lpClassName%&, Byval lpWindowName%&)
Function SetWindowPos& (ByVal hWnd%&, Byval hWndInsertAfter%&, Byval X&, Byval Y&, Byval cx&, Byval cy&, Byval uFlags~&)
Function GetForegroundWindow%&
End Declare
Declare Dynamic Library "kernel32"
Function GetLastError~& ()
End Declare
' UDT TO HOLD THE INFO FOR EACH MOUSE
Type InfoType
ID As String ' player identifier or mouse device ID
char As String ' cursor character
color As Integer ' character color
row As Integer ' line to display values at
UpdateCount As Integer ' if this value changes we know a value changed
OldUpdateCount As Integer ' if this value changes we know a value changed
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
dx As Integer ' mouse x position
dy As Integer ' mouse y position
x As Integer ' screen x position
y As Integer ' screen y position
oldX As Integer
oldY As Integer
wheel As Integer ' mouse wheel value
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
LeftCount As Integer ' counts left clicks
MiddleCount As Integer ' counts middle clicks
RightCount As Integer ' counts right clicks
End Type ' InfoType
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' 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)
' GLOBAL VARIABLES TO TRACK ERROR STATE
Dim Shared m_sError As String: m_sError = ""
Dim Shared m_sIncludeError As String: m_sIncludeError = ""
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' 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
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' MOUSE TEST VARIABLES
Dim arrMouse(0 To 8) As InfoType ' 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 arrColor(0 To 31) As 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$
' 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
' =============================================================================
' 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
' =============================================================================
' MOVE WINDOW TO TOP
' GET WINDOW HANDLES
hWndThis = _WindowHandle ' FindWindowA(0, _OFFSET(t))
hWndTop = GetForegroundWindow%& ' find currently focused process handle
' GET FOCUS
If hWndThis <> hWndTop Then
_ScreenClick 240, 240 ' add 40 to x and y to focus on positioned window
End If
' MOVE TO TOP
If SetWindowPos(hWndThis, HWND_TOPMOST, 200, 200, 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
' =============================================================================
' INIT SCREEN
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.
'Screen _NewImage(1024, 768, 32)
' window needs to be lined up directly under the main program, so the mouse coordinates align with the display
_ScreenMove 0, 0
'_SCREENMOVE _MIDDLE
Cls , cBlack
' =============================================================================
' MAIN LOOP
Do
' PRINT MESSAGE
iRow = 1: iCol = 1
Color cLtRed, cBlack
PrintString1 iRow, iCol, "*** MAKE SURE PROGRAM READMICE HAS THE FOCUS ***"
iRow = 2: iCol = 1
Color cCyan, cBlack
PrintString1 iRow, iCol, "Plug in 2 or more USB mice and move them around over the window."
' -----------------------------------------------------------------------------
' READ MICE COORDINATES FROM CONNECTION...
Get #lngConn, , sInput
' DID IT WORK?
If Len(m_sError) = 0 Then
DebugPrint " GOT DATA FROM CONNECTION"
' HAVE DATA?
If Len(sInput) > 0 Then
DebugPrint " DATA NOT EMPTY"
' BREAK UP INPUT INTO CHUNKS (1 CHUNK PER MOUSE)
split sInput, Chr$(13), arrMice() ' SPLIT OUTPUT INTO PAGES
' PROCESS CHUNKS
For iLoop1 = LBound(arrMice) To UBound(arrMice)
DebugPrint " PROCESSING CHUNK arrMice(" + _Trim$(Str$(iLoop1)) + ")"
sNextChunk = _Trim$(arrMice(iLoop1))
' DOES IT CONTAIN DATA?
If Len(sNextChunk) > 0 Then
' BREAK UP CHUNK INTO VALUES
' COORDINATES COME IN THE TAB-DELIMITED FORMAT:
' {mouse #}\t{count}\t{dx}\t{dy}\t{wheel}\t{leftDown}\t{middleDown}\t{rightDown}\n
split sNextChunk, Chr$(9), arrValues() ' SPLIT OUTPUT INTO PAGES
' PROCESS VALUES
iIndex = -1
iValuePosition = 0
For iLoop2 = LBound(arrValues) To UBound(arrValues)
' TRACK WHAT VALUE # WE'RE ON
iValuePosition = iValuePosition + 1
' GET VALUE
sNextValue = _Trim$(arrValues(iLoop2))
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))
' CONTROL SPEED (MOVE AFTER NUMBER MOVEMENTS EXCEEDS THRESHOLD)
arrMouse(iIndex).countX = arrMouse(iIndex).countX + 1
DebugPrint " COUNT = " + _Trim$(Str$(arrMouse(iIndex).countX)) + "/" + _Trim$(Str$(cMouseSpeedX))
If arrMouse(iIndex).countX > cMouseSpeedX Then
DebugPrint " MOVE NOW"
' ADJUST COORDINATES BASED ON MOVEMENT
arrMouse(iIndex).x = arrMouse(iIndex).x + arrMouse(iIndex).dx
' CHECK BOUNDARIES
If arrMouse(iIndex).x < cMinX Then
arrMouse(iIndex).x = cMinX
ElseIf arrMouse(iIndex).x > cMaxX Then
arrMouse(iIndex).x = cMaxX
End If
' RESET SPEED COUNTER
arrMouse(iIndex).countX = 0
Else
DebugPrint " DON'T MOVE YET"
End If
Case cMouseDY:
' READ RAW VALUE
arrMouse(iIndex).dy = Val(sNextValue)
DebugPrint " DY = " + _Trim$(Str$(arrMouse(iIndex).dy))
' CONTROL SPEED (MOVE AFTER NUMBER MOVEMENTS EXCEEDS THRESHOLD)
arrMouse(iIndex).countY = arrMouse(iIndex).countY + 1
DebugPrint " COUNT = " + _Trim$(Str$(arrMouse(iIndex).countY)) + "/" + _Trim$(Str$(cMouseSpeedY))
If arrMouse(iIndex).countY > cMouseSpeedY Then
DebugPrint " MOVE NOW"
' ADJUST COORDINATES BASED ON MOVEMENT
arrMouse(iIndex).y = arrMouse(iIndex).y + arrMouse(iIndex).dy
' CHECK BOUNDARIES
If arrMouse(iIndex).y < cMinY Then
arrMouse(iIndex).y = cMinY
ElseIf arrMouse(iIndex).y > cMaxY Then
arrMouse(iIndex).y = cMaxY
End If
' RESET SPEED COUNTER
arrMouse(iIndex).countY = 0
Else
DebugPrint " DON'T MOVE YET"
End If
Case cMouseWheel:
'' READ RAW VALUE
'arrMouse(iIndex).wheel = Val(sNextValue)
Case cMouseLeftDown:
'' READ RAW VALUE
'arrMouse(iIndex).LeftDown = Val(sNextValue)
Case cMouseMiddleDown:
'' READ RAW VALUE
'arrMouse(iIndex).MiddleDown = Val(sNextValue)
Case cMouseRightDown:
'' READ RAW VALUE
'arrMouse(iIndex).RightDown = Val(sNextValue)
Case Else:
' Unknown
End Select
' EXIT IF VALUES HAVEN'T CHANGED
If iLoop2 > cUpdateCount Then
If arrMouse(iIndex).UpdateCount = arrMouse(iIndex).OldUpdateCount Then
' STOP THE MOUSE DX / DY
arrMouse(iIndex).dy = 0
arrMouse(iIndex).dx = 0
' WE CAN STOP PROCESSING THIS CHUNK
Exit For
End If
End If
Else
DebugPrint " (VALUE ISN'T A NUMBER)"
'DebugPrint " ** sNextValue NOT A NUMBER: " + chr$(34) + sNextValue + chr$(34)
' (VALUE ISN'T A NUMBER)
' (DO NOTHING)
End If
Next iLoop2
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
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
' -----------------------------------------------------------------------------
' REDRAW AND SAVE OLD COORDINATES
PrintString1 arrMouse(iIndex).oldY, arrMouse(iIndex).oldX, " "
PrintString1 arrMouse(iIndex).y, arrMouse(iIndex).x, arrMouse(iIndex).char
If arrMouse(iIndex).oldX <> arrMouse(iIndex).x Or arrMouse(iIndex).oldY <> arrMouse(iIndex).y Then
arrMouse(iIndex).oldY = arrMouse(iIndex).y
arrMouse(iIndex).oldX = arrMouse(iIndex).x
End If
Next iIndex
' -----------------------------------------------------------------------------
' GET KEYBOARD INPUT
While _DeviceInput(1): Wend ' clear and update the keyboard buffer
If _KeyDown(27) Then
DebugPrint "DETECTED ESC = _KeyDown(27) = EXITING"
Exit Do ' leave loop when ESC key pressed
End If
_Limit 60 ' run 60 fps
Loop While _Connected(lngConn)
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
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN GRAPHIC PRINTING ROUTINES
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' /////////////////////////////////////////////////////////////////////////////
' 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: PrintString0
Sub PrintString1g (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 ' PrintString1g
' /////////////////////////////////////////////////////////////////////////////
' Prints a string at the specified row+column.
' iRow and iCol are 1-based.
' See also: PrintString0
Sub PrintString1 (iRow As Integer, iCol As Integer, MyString As String)
Locate iRow, iCol
Print 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 GENERAL PURPOSE FUNCTIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' /////////////////////////////////////////////////////////////////////////////
' 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%
' /////////////////////////////////////////////////////////////////////////////
' 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$
' /////////////////////////////////////////////////////////////////////////////
' 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.)
Option Explicit
_Title "ReadMiceSub"
$NoPrefix
'$Console:Only
'Console Off
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN CONSTANTS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Const cProgName = "ReadMiceSub"
Const FALSE = 0
Const TRUE = Not FALSE
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' USED TO CONVERT MOUSE POSITION TO GET SCREEN POSITION
' ScreenPos = MousePos / ScaleValue
' This doesn't really work too accurately!
Const cScaleX = 3
Const cScaleY = 4
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' FOR RAW INPUT API
Const CS_HREDRAW = &H0002
Const CS_VREDRAW = &H0001
Const WS_OVERLAPPED = &H00000000
Const WS_CAPTION = &H00C00000
Const WS_SYSMENU = &H00080000
Const WS_THICKFRAME = &H00040000
Const WS_MINIMIZEBOX = &H00020000
Const WS_MAXIMIZEBOX = &H00010000
Const WS_CHILD = &H40000000
Const WS_VISIBLE = &H10000000
Const WS_OVERLAPPEDWINDOW = WS_OVERLAPPED Or WS_CAPTION Or WS_SYSMENU Or WS_THICKFRAME Or WS_MINIMIZEBOX Or WS_MAXIMIZEBOX
Const CW_USEDEFAULT = &H80000000
Const WM_DESTROY = &H0002
Const WM_INPUT = &H00FF
Const SW_SHOW = 5
Const RID_INPUT = &H10000003
Const RIM_TYPEMOUSE = 0 ' Raw input comes from the mouse.
Const RIM_TYPEKEYBOARD = 1 ' Raw input comes from the keyboard.
Const RIM_TYPEHID = 2 ' Raw input comes from some device that is not a keyboard or a mouse.
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' CONSTANT FOR 2ND DIMENSION OF arrFile ARRAY
Const cFileName = 0
Const cFileData = 1
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END CONSTANTS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN UDTs
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Type RAWINPUTDEVICE
As Unsigned Integer usUsagePage, usUsage
As Unsigned Long dwFlags
As Offset hwndTarget
End Type
Type RAWINPUTDEVICELIST
As Offset hDevice
As Unsigned Long dwType
$If 64BIT Then
As String * 4 alignment
$End If
End Type
Type POINT
As Long x, y
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
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
Type RECT
As Long left, top, right, bottom
End Type
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
Type RAWINPUTHEADER
As Unsigned Long dwType, dwSize
As Offset hDevice
As Unsigned Offset wParam
End Type
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
Type RAWINPUT
As RAWINPUTHEADER header
As RAWMOUSE mouse
End Type
' UDT TO HOLD THE INFO FOR EACH MOUSE
Type MouseInfoType
UpdateCount As Integer ' if this value changes we know a value changed
ID As String ' mouse device ID
c As String ' cursor character
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
wheel As Integer ' mouse wheel value
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
LeftCount As Integer ' counts left clicks
MiddleCount As Integer ' counts middle clicks
RightCount As Integer ' counts right clicks
End Type ' MouseInfoType
' UDT TO HOLD THE INFO FOR EACH KEYBOARD
Type KeyboardInfoType
UpdateCount As Integer ' if this value changes we know a value changed
ID As String ' keyboard device ID
'TBD
End Type ' KeyboardInfoType
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END UDTs
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN API DECLARATIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' FOR RAW INPUT API
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
Declare CustomType Library
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)
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)
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)
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)
Sub GetClientRect (ByVal hWnd As Offset, Byval lpRect As Offset)
Sub DrawText (ByVal hdc As Offset, Byval lpchText As Offset, Byval cchText As Long, Byval lprc As Offset, Byval format As Unsigned 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
' 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
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
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' 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)
' GLOBAL VARIABLES TO TRACK ERROR STATE
Dim Shared m_sError As String: m_sError = ""
Dim Shared m_sIncludeError As String: m_sIncludeError = ""
' RAW INPUT VARIABLES
Dim Shared mousemessage As String
Dim Shared rawinputdevices As String
' MOUSE VARIABLES
Dim Shared arrMouse(0 To 8) As MouseInfoType ' STORES INFO FOR EACH MOUSE
'Dim Shared arrRawMouseID(8) As Long ' device IDs for mice connected to system (guessing this would be a string, dunno)
Dim Shared iMouseCount As Integer ' # OF MICE ATTACHED
' KEYBOARD VARIABLES
Dim Shared arrKeyboard(0 To 8) As KeyboardInfoType ' STORES INFO FOR EACH KEYBOARD
Dim Shared iKeyboardCount As Integer ' # OF KEYBOARDS ATTACHED
Dim Shared arrKeyState(0 To 8, 1 To 512) As Integer ' arrKeyState({device#}, {keyCode}) = TRUE if key {keyCode} on keyboard {device#} is currently held down.
Dim Shared arrScreen(1 To 80, 1 To 25) As String ' STORES TEXT FOR SCREEN
Dim Shared iMinX As Long
Dim Shared iMaxX As Long
Dim Shared iMinY As Long
Dim Shared iMaxY As Long
' RAW FILE NAMES
Dim Shared arrFile(0 To 31, 0 To 1) As String
' 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$
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END GLOBAL VARIABLES
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' =============================================================================
' START THE MAIN ROUTINE
main
' =============================================================================
' FINISH
Print m_ProgramName$ + " finished."
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 DATA STATEMENTS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' MOUSE CURSORS (JUST SOME LETTERS)
CData:
Data A,b,C,D,E,f,G,H
' DEFAULT/INTIAL X COORDINATE OF EACH CURSOR ON SCREEN
XData:
Data 5,15,25,35,45,55,65,75
' DEFAULT/INTIAL Y COORDINATE OF EACH CURSOR ON SCREEN
YData:
Data 17,17,19,19,21,21,23,23
' DEFAULT/INITIAL VALUE OF EACH SCROLL WHEEL
WData:
Data 224,192,160,128,96,64,32,0
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END DATA STATEMENTS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN MAIN ROUTINES
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Sub main
Dim sPort As String
Dim iLoop As Integer
Dim in$
' 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
' ****************************************************************************************************************************************************************
' ****************************************************************************************************************************************************************
' RETHINK DATA STRUCTURE
' ****************************************************************************************************************************************************************
' ****************************************************************************************************************************************************************
' INITIALIZE
For iLoop = LBound(arrFile) To UBound(arrFile)
arrFile(iLoop, cFileName) = m_ProgramPath$ + "mouse" + _Trim$(Str$(iLoop)) + ".txt"
arrFile(iLoop, cFileData) = ""
Next iLoop
' ****************************************************************************************************************************************************************
' ****************************************************************************************************************************************************************
' 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?
' GIVE CONTROL TO THE EVENT-ORIENTED CODE
System Val(Str$(WinMain))
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, hInst
Dim As MSG msg
Dim As WNDCLASSEX wndclass
Dim As String szMainWndClass
Dim As String szWinTitle
Dim As Unsigned Integer reg
'DEBUG: TRY FULL SCREEN <- PROGRAM CRASHES!
'_FullScreen _SquarePixels
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
'DEBUG: SUBSTITUTE _WindowHandle
'Function CreateWindowEx%& (
' ByVal dwExStyle As Unsigned Long = 0
' Byval lpClassName As Offset = MAKELPARAM(reg, 0)
' Byval lpWindowName As Offset = Offset(szWinTitle)
' Byval dwStyle As Unsigned Long = WS_OVERLAPPEDWINDOW
' Byval x As Long = CW_USEDEFAULT
' Byval y As Long = CW_USEDEFAULT
' Byval nWidth As Long = CW_USEDEFAULT
' Byval nHeight As Long = CW_USEDEFAULT
' Byval hWndParent As Offset = 0
' Byval hMenu As Offset = 0
' Byval hInstance As Offset = hInst
' Byval lpParam As Offset = 0
While GetMessage(Offset(msg), 0, 0, 0)
TranslateMessage Offset(msg)
DispatchMessage Offset(msg)
Wend
WinMain = msg.wParam
End Function ' WinMain
' /////////////////////////////////////////////////////////////////////////////
' Handles main window events
Function MainWndProc%& (hwnd As Offset, nMsg As Unsigned Long, wParam As Unsigned Offset, lParam As Offset)
Static As Offset hwndButton
Static As Long cx, cy
Dim As Offset hdc
Dim As PAINTSTRUCT ps
Dim As RECT rc
Dim As MEM lpb
Dim As Unsigned Long dwSize
Dim As RAWINPUT raw
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 iLen As Integer
Dim sCount As String
Dim sX As String
Dim sY 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
' MORE TEMP VARIABLES
Dim iMouseNum As Integer
' HANDLE EVENTS
Select Case nMsg
Case WM_DESTROY
PostQuitMessage 0
MainWndProc = 0
Exit Function
Case WM_INPUT
GetRawInputData lParam, RID_INPUT, 0, Offset(dwSize), Len(rih)
lpb = MemNew(dwSize)
If lpb.SIZE = 0 Then
MainWndProc = 0
Exit Function
End If
If GetRawInputData(lParam, RID_INPUT, lpb.OFFSET, Offset(dwSize), Len(rih)) <> dwSize Then
'Print "GetRawInputData doesn't return correct size!"
mousemessage = "GetRawInputData doesn't return correct size!"
End If
MemGet lpb, lpb.OFFSET, raw
If raw.header.dwType = RIM_TYPEMOUSE Then
tmpx = raw.mouse.lLastX
tmpy = raw.mouse.lLastY
maxx = tmpx
' GET MOUSE INFO
' NOTES:
' ulButtons and usButtonFlags both return the same thing (buttons)
' usButtonData changes value when scroll wheel moved (just stays at one value)
'mousemessage = ""
'mousemessage = mousemessage + "Mouse:hDevice" + Str$(raw.header.hDevice)
'mousemessage = mousemessage + "usFlags=" + Hex$(raw.mouse.usFlags)
'mousemessage = mousemessage + "ulButtons=" + Hex$(MAKELONG(raw.mouse.usButtonFlags, raw.mouse.usFlags))
'mousemessage = mousemessage + "usButtonFlags=" + Hex$(raw.mouse.usButtonFlags)
'mousemessage = mousemessage + "usButtonData=" + Hex$(raw.mouse.usButtonData)
'mousemessage = mousemessage + "ulRawButtons=" + Hex$(raw.mouse.ulRawButtons)
'mousemessage = mousemessage + "lLastX=" + Str$(raw.mouse.lLastX)
'mousemessage = mousemessage + "lLastY=" + Str$(raw.mouse.lLastY)
'mousemessage = mousemessage + "ulExtraInformation=" + Hex$(raw.mouse.ulExtraInformation) + Chr$(13)
' 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)
' IDENTIFY WHICH MOUSE IT IS
strNextID = _Trim$(Str$(raw.header.hDevice))
iIndex = GetMouseIndex%(strNextID)
If iIndex >= LBound(arrMouse) Then
If iIndex <= UBound(arrMouse) Then
' =============================================================================
' READ MOUSE MOVEMENT
' DOESN'T WORK, MOVES ALL OVER THE PLACE:
'' METHOD #1: SCALE MOUSE POSITION TO 80X25 POSITION
'iNewX = ( (GET_X_LPARAM(lParam) + 1) * 80) \ (iMaxX+1)
'iNewY = ( (GET_Y_LPARAM(lParam) + 1) * 25) \ (iMaxY+1)
'arrMouse(iIndex).x = iNewX
'arrMouse(iIndex).y = iNewY
' WORKS BUT NOT THAT ACCURATE:
' METHOD #2: INCREMENT/DECREMENT DELTA
If raw.mouse.lLastX < 0 Then
arrMouse(iIndex).dx = -1
ElseIf raw.mouse.lLastX > 0 Then
arrMouse(iIndex).dx = 1
Else
arrMouse(iIndex).dx = 0
End If
If raw.mouse.lLastY < 0 Then
arrMouse(iIndex).dy = -1
ElseIf raw.mouse.lLastY > 0 Then
arrMouse(iIndex).dy = 1
Else
arrMouse(iIndex).dy = 0
End If
' =============================================================================
'TODO: SAVE SCROLL WHEEL + BUTTONS
'Hex$(raw.mouse.usButtonFlags)
' left button = 1 when down, 2 when released
If ((raw.mouse.usButtonFlags And 1) = 1) Then
arrMouse(iIndex).LeftDown = TRUE
ElseIf ((raw.mouse.usButtonFlags And 2) = 2) Then
arrMouse(iIndex).LeftDown = FALSE
End If
' middle button = 16 when down, 32 when released
If ((raw.mouse.usButtonFlags And 16) = 16) Then
arrMouse(iIndex).MiddleDown = TRUE
ElseIf ((raw.mouse.usButtonFlags And 32) = 32) Then
arrMouse(iIndex).MiddleDown = FALSE
End If
' right button = 4 when down, 8 when released
If ((raw.mouse.usButtonFlags And 4) = 4) Then
arrMouse(iIndex).RightDown = TRUE
ElseIf ((raw.mouse.usButtonFlags And 8) = 8) Then
arrMouse(iIndex).RightDown = FALSE
End If
' DID VALUE CHANGE?
If arrMouse(iIndex).UpdateCount = 32767 Then
arrMouse(iIndex).UpdateCount = 1
Else
arrMouse(iIndex).UpdateCount = arrMouse(iIndex).UpdateCount + 1
End If
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' SEND VALUES FOR THIS MOUSE TO HOST
Put #lngConn, , sOutput
' UPDATE mousemessage WITH PLAYING FIELD
mousemessage = ScreenToString$
' ================================================================================================================================================================
' END WRITE OUTPUT FILE
' ================================================================================================================================================================
' WinAPI Raw Input confusion - For Beginners - GameDev.net
' https://www.gamedev.net/forums/topic/700010-winapi-raw-input-confusion/
'iKeyboardCount = iKeyboardCount + 1 ' # KEYBOARDS ATTACHED
'strNextID = _Trim$(Str$(rawdevs(x).hDevice))
'arrKeyboard(iKeyboardCount - 1).ID = strNextID
' TODO: READ KEYBOARD AND STORE KEYBOARD STATE
'arrKeyState(0 To 8, 1 To 512) As Integer ' arrKeyState({device#}, {keyCode}) = TRUE if key {keyCode} on keyboard {device#} is currently held down.
' SAVE RANGE OF MOUSE COORDINATES
If GET_X_LPARAM(lParam) < iMinX Then
iMinX = GET_X_LPARAM(lParam)
arrMouse(iIndex).dx = -1
ElseIf GET_X_LPARAM(lParam) > iMaxX Then
iMaxX = GET_X_LPARAM(lParam)
arrMouse(iIndex).dx = 1
Else
arrMouse(iIndex).dx = 0
End If
If GET_Y_LPARAM(lParam) < iMinY Then
iMinY = GET_Y_LPARAM(lParam)
arrMouse(iIndex).dy = -1
ElseIf GET_Y_LPARAM(lParam) > iMaxY Then
iMaxY = GET_Y_LPARAM(lParam)
arrMouse(iIndex).dy = 1
Else
arrMouse(iIndex).dy = 0
End If
' IDENTIFY WHICH MOUSE IT IS
strNextID = _Trim$(Str$(raw.header.hDevice))
iIndex = GetMouseIndex%(strNextID)
If iIndex >= LBound(arrMouse) Then
If iIndex <= UBound(arrMouse) Then
' =============================================================================
' UPDATE ABSOLUTE POSITION
' WORKS BUT NOT THAT ACCURATE:
' METHOD #2: INCREMENT/DECREMENT DELTA
' (should we update here too?)
'TODO: SAVE SCROLL WHEEL + BUTTONS
' (should we update here too?)
'arrMouse(iIndex).wheel =
'arrMouse(iIndex).LeftDown =
'arrMouse(iIndex).MiddleDown =
'arrMouse(iIndex).RightDown =
End If
End If
Case Else
'DEBUG: SUBSTITUTE _WindowHandle
MainWndProc = DefWindowProc(hwnd, nMsg, wParam, lParam)
'MainWndProc = DefWindowProc(_WindowHandle, nMsg, wParam, lParam)
End Select
If _KeyDown(27) Then End
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 strNextID As String
'dim lngNextID as long
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 MOUSE / KEYBOARD INFO
iMouseCount = 0
iKeyboardCount = 0
rawinputdevices = "Number of raw input devices:" + Str$(nDevices) + Chr$(13)
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 = 0 Then
If rawdevs(x).dwType = RIM_TYPEMOUSE Then
iMouseCount = iMouseCount + 1
strNextID = _Trim$(Str$(rawdevs(x).hDevice))
'lngNextID = Val(strNextID)
'arrMouse(iMouseCount-1).ID = lngNextID
arrMouse(iMouseCount - 1).ID = strNextID
arrMouse(iMouseCount - 1).UpdateCount = 0
'TODO: SAVE_MOUSE_INFO
ElseIf rawdevs(x).dwType = RIM_TYPEKEYBOARD Then
iKeyboardCount = iKeyboardCount + 1 ' # KEYBOARDS ATTACHED
strNextID = _Trim$(Str$(rawdevs(x).hDevice))
arrKeyboard(iKeyboardCount - 1).ID = strNextID
arrKeyboard(iKeyboardCount - 1).UpdateCount = 0
' TODO: READ KEYBOARD AND STORE KEYBOARD STATE
'arrKeyState(0 To 8, 1 To 512) As Integer ' arrKeyState({device#}, {keyCode}) = TRUE if key {keyCode} on keyboard {device#} is currently held down.
End If
Next x
rawinputdevices = rawinputdevices + Chr$(0)
If RegisterRawInputDevices(Offset(Rid()), 1, Len(Rid(0))) = 0 Then
mousemessage = "RawInput init failed" + Chr$(0)
End If
End Sub ' InitRawInput
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END RAW INPUT FUNCTIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN MOUSE TEST FUNCTIONS #1
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' /////////////////////////////////////////////////////////////////////////////
' Initialize mouse test stuff
'TODO: SAVE_MOUSE_INFO
Sub InitMouseTest
Dim iIndex As Integer
Dim iLoop As Integer
' FOR NOW ONLY SUPPORT UPTO 8 MICE
If (iMouseCount > 8) Then iMouseCount = 8
' INITIALIZE X COORDINATES
Restore XData
iIndex = LBound(arrMouse) - 1
For iLoop = 1 To iMouseCount
iIndex = iIndex + 1
Read arrMouse(iIndex).x
Next iLoop
' INITIALIZE Y COORDINATES
Restore YData
iIndex = LBound(arrMouse) - 1
For iLoop = 1 To iMouseCount
iIndex = iIndex + 1
Read arrMouse(iIndex).y
Next iLoop
' INITIALIZE SCROLL WHEEL
Restore WData
iIndex = LBound(arrMouse) - 1
For iLoop = 1 To iMouseCount
iIndex = iIndex + 1
Read arrMouse(iIndex).wheel
Next iLoop
End Sub ' InitMouseTest
' /////////////////////////////////////////////////////////////////////////////
' 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
Else
' not it
End If
Next iLoop
GetMouseIndex% = iIndex%
End Function ' GetMouseIndex%
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END MOUSE TEST FUNCTIONS #1
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN TEST OUTPUT FUNCTIONS FOR API CONTROLLED UI
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' /////////////////////////////////////////////////////////////////////////////
' Clears global array arrScreen
Sub ClearText
Dim iColNum As Integer
Dim iRowNum As Integer
For iColNum = LBound(arrScreen, 1) To UBound(arrScreen, 1)
For iRowNum = LBound(arrScreen, 2) To UBound(arrScreen, 2)
arrScreen(iColNum, iRowNum) = " "
Next iRowNum
Next iColNum
End Sub ' ClearText
' /////////////////////////////////////////////////////////////////////////////
' Plots string MyString to position (iX, iY) in global array arrScreen.
Sub WriteText (iRow As Integer, iColumn As Integer, MyString As String)
Dim iPos As Integer
Dim iLoop As Integer
If iColumn > 0 And iColumn < 81 Then
If iRow > 0 And iRow < 26 Then
For iLoop = 1 To Len(MyString)
iPos = iColumn + (iLoop - 1)
If iPos < 81 Then
arrScreen(iPos, iRow) = Mid$(MyString, iLoop, 1)
Else
Exit For
End If
Next iLoop
End If
End If
End Sub ' WriteText
' /////////////////////////////////////////////////////////////////////////////
' Converts global array arrScreen to a string.
Function ScreenToString$
Dim sResult As String
Dim iColNum As Integer
Dim iRowNum As Integer
sResult = ""
For iRowNum = LBound(arrScreen, 2) To UBound(arrScreen, 2)
For iColNum = LBound(arrScreen, 1) To UBound(arrScreen, 1)
sResult = sResult + arrScreen(iColNum, iRowNum)
Next iColNum
sResult = sResult + Chr$(13)
Next iRowNum
ScreenToString$ = sResult
End Function ' ScreenToString$
' /////////////////////////////////////////////////////////////////////////////
' based on code from:
' Qbasic Programs - Download free bas source code
' http://www.thedubber.altervista.org/qbsrc.htm
Sub DrawTextLine (y%, x%, y2%, x2%, c$)
Dim i%
Dim steep%
Dim e%
Dim sx%
Dim dx%
Dim sy%
Dim dy%
i% = 0: steep% = 0: e% = 0
If (x2% - x%) > 0 Then sx% = 1: Else sx% = -1
dx% = Abs(x2% - x%)
If (y2% - y%) > 0 Then sy% = 1: Else sy% = -1
dy% = Abs(y2% - y%)
If (dy% > dx%) Then
steep% = 1
Swap x%, y%
Swap dx%, dy%
Swap sx%, sy%
End If
e% = 2 * dy% - dx%
For i% = 0 To dx% - 1
If steep% = 1 Then
''PSET (y%, x%), c%:
'Locate y%, x% : Print c$;
WriteText y%, x%, c$
Else
''PSET (x%, y%), c%
'Locate x%, y% : Print c$;
WriteText x%, y%, c$
End If
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END TEST OUTPUT FUNCTIONS FOR API CONTROLLED UI
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN MOUSE FUNCTIONS TO COME
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' /////////////////////////////////////////////////////////////////////////////
' Returns a count of # of RawInput mouse devices connected to the system
' *****************************************************************************
' TODO: GET COUNT FROM RawInput API
' For now, hardcoded to 1 until we figure out how to do this.
' *****************************************************************************
Function GetRawMouseCount% ()
GetRawMouseCount% = 1
End Function ' GetRawMouseCount%
' /////////////////////////////////////////////////////////////////////////////
' Gets ID of each RawInput mouse device connected to the system (for now upto 8)
' Returns the IDs in an array of LONG <- may change depending on whether
' we save each the device handle for each mouse or the index
' If no mouse found, the ID will just be 0 <- or whatever value we decide as default/none
' *****************************************************************************
' TODO: GET THIS FROM RawInput API
' For now, hardcoded arrRawMouseID(1) to 1, and the rest 0, until we figure out how to do this.
' *****************************************************************************
'Sub GetRawMouseIDs (arrRawMouseID( 8) As Integer)
Sub GetRawMouseIDs ()
Dim iLoop As Integer
' CLEAR OUT IDs
For iLoop = 1 To 8
''arrRawMouseID(iLoop) = 0
'arrMouse(iLoop).ID = 0
arrMouse(iLoop).ID = ""
Next iLoop
' GET IDs
'TODO: get this from RawInput API
''arrRawMouseID(1) = 1 ' for now just fudge it!
'arrMouse(0).ID = 1 ' for now just fudge it!
End Sub ' GetRawMouseIDs
' /////////////////////////////////////////////////////////////////////////////
' Read mouse using RawInput API
' Gets input from mouse, MouseID% = which mouse
' NOTE: click events (mouse up/mouse down) are handled by the calling sub,
' this routine just sends back
' TRUE if the given button is currently down or FALSE if it is up.
' Parameters (input only):
' MouseID% = which mouse to return input for
' wheelMin% = minimum value to allow wheelValue% to be decremented to
' wheelMax% = maximum value to allow wheelValue% to be incremened to
' Parameters (values returned):
' x% = mouse x position
' y% = mouse y position
' leftButton% = current state of left mouse button (up or down)
' middleButton% = current state of middle mouse button / scroll wheel button (up or down)
' rightButton% = current state of right mouse button (up or down)
' wheelValue% = value of mouse scroll wheel (passed in and incremented/decremented by 1 if wheel move detected)
Sub ReadRawMouse (MouseID%, x%, y%, leftButton%, middleButton%, rightButton%, wheelValue%, wheelMin%, wheelMax%)
Dim scrollAmount%
Dim dx%
Dim dy%
' =============================================================================
' BEGIN READ MOUSE THE NEW RawInput WAY:
' read scroll wheel
'TODO: get this from RawInput API
' determine mouse x position
'TODO: get this from RawInput API
dx% = 0 ' = getMouseDx(MouseID%)
x% = x% + dx% ' adjust mouse value by dx
' determine mouse y position
'TODO: get this from RawInput API
dy% = 0 ' = getMouseDy(MouseID%)
y% = y% + dy% ' adjust mouse value by dx
' read mouse buttons
'TODO: get this from RawInput API
leftButton% = FALSE
middleButton% = FALSE
rightButton% = FALSE
' END READ MOUSE THE NEW RawInput WAY:
' =============================================================================
' =============================================================================
' BEGIN READ MOUSE THE OLD QB64 WAY:
'
'' read scroll wheel
'WHILE _MOUSEINPUT ' get latest mouse information
' scrollAmount% = _MOUSEWHEEL ' (Returns -1 when scrolling up and 1 when scrolling down with 0 indicating no movement since last read.)
' IF (scrollAmount% = -1) AND (wheelValue% > wheelMin%) THEN
' wheelValue% = wheelValue% + scrollAmount%
' ELSEIF (scrollAmount% = 1) AND (wheelValue% < wheelMax%) THEN
' wheelValue% = wheelValue% + scrollAmount%
' END IF
'WEND
'
'' determine mouse x position
'x% = _MOUSEX
'
'' determine mouse y position
'y% = _dy
'
'' read mouse buttons
'leftButton% = _MOUSEBUTTON(1)
'middleButton% = _MOUSEBUTTON(3)
'rightButton% = _MOUSEBUTTON(2)
'
' END READ MOUSE THE OLD QB64 WAY:
' =============================================================================
End Sub ' ReadRawMouse
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END MOUSE FUNCTIONS TO COME
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN ERROR HANDLING HELPER FUNCTIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Sub ErrorClear
m_sError = ""
m_sIncludeError = ""
End Sub ' ErrorClear
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END ERROR HANDLING HELPER FUNCTIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN GENERAL PURPOSE FUNCTIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' /////////////////////////////////////////////////////////////////////////////
' 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%
' /////////////////////////////////////////////////////////////////////////////
' 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$
' /////////////////////////////////////////////////////////////////////////////
' 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
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
I gave QB64 GPT my sub for handling any argument as a MEM block. I asked it to rewrite the sub. Here is the original code:
Code: (Select All)
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 '_BYTE, INTEGER, LONG, _INTEGER64
If _ReadBit(args(x).TYPE, 10) Then
If _ReadBit(args(x).TYPE, 16) Then
Select Case args(x).ELEMENTSIZE
Case 1
Dim As _Unsigned _Byte unsignedbytearray(1 To (size / elementsize))
For y = LBound(unsignedbytearray) To UBound(unsignedbytearray)
_MemGet args(x), args(x).OFFSET + z, unsignedbytearray(y)
z = z + args(x).ELEMENTSIZE
Print unsignedbytearray(y), "UBYTE ARRAY"
Next
Exit Select
Case 2
Dim As _Unsigned Integer unsignedintarray(1 To (size / elementsize))
For y = LBound(unsignedintarray) To UBound(unsignedintarray)
_MemGet args(x), args(x).OFFSET + z, unsignedintarray(y)
z = z + args(x).ELEMENTSIZE
Print unsignedintarray(y), "USHORT ARRAY"
Next
Exit Select
Case 4
Dim As _Unsigned Long unsignedlongarray(1 To (size / elementsize))
For y = LBound(unsignedlongarray) To UBound(unsignedlongarray)
_MemGet args(x), args(x).OFFSET + z, unsignedlongarray(y)
z = z + args(x).ELEMENTSIZE
Print unsignedlongarray(y), "ULONG ARRAY"
Next
Exit Select
Case 8
Dim As _Unsigned _Integer64 unsignedint64array(1 To (size / elementsize))
For y = LBound(unsignedint64array) To UBound(unsignedint64array)
_MemGet args(x), args(x).OFFSET + z, unsignedint64array(y)
z = z + args(x).ELEMENTSIZE
Print unsignedint64array(y), "UINT64 ARRAY"
Next
Exit Select
End Select
Else
Select Case args(x).SIZE
Case 1
Print _MemGet(args(x), args(x).OFFSET, _Unsigned _Byte), "UBYTE"
Exit Select
Case 2
Print _MemGet(args(x), args(x).OFFSET, _Unsigned Integer), "USHORT"
Exit Select
Case 4
Print _MemGet(args(x), args(x).OFFSET, _Unsigned Long), "ULONG"
Exit Select
Case 8
Print _MemGet(args(x), args(x).OFFSET, _Unsigned _Integer64), "UINT64"
Exit Select
End Select
End If
Else
If _ReadBit(args(x).TYPE, 16) Then
Select Case args(x).ELEMENTSIZE
Case 1
Dim As _Byte bytearray(1 To (size / elementsize))
For y = LBound(bytearray) To UBound(bytearray)
_MemGet args(x), args(x).OFFSET + z, bytearray(y)
z = z + args(x).ELEMENTSIZE
Print bytearray(y), "BYTE ARRAY"
Next
Exit Select
Case 2
Dim As Integer intarray(1 To (size / elementsize))
For y = LBound(intarray) To UBound(intarray)
_MemGet args(x), args(x).OFFSET + z, intarray(y)
z = z + args(x).ELEMENTSIZE
Print unsignedintarray(y), "SHORT ARRAY"
Next
Exit Select
Case 4
Dim As Long longarray(1 To (size / elementsize))
For y = LBound(longarray) To UBound(longarray)
_MemGet args(x), args(x).OFFSET + z, longarray(y)
z = z + args(x).ELEMENTSIZE
Print longarray(y), "LONG ARRAY"
Next
Exit Select
Case 8
Dim As _Integer64 int64array(1 To (size / elementsize))
For y = LBound(int64array) To UBound(int64array)
_MemGet args(x), args(x).OFFSET + z, int64array(y)
z = z + args(x).ELEMENTSIZE
Print int64array(y), "INT64 ARRAY"
Next
Exit Select
End Select
Else
Select Case args(x).SIZE
Case 1
Print _MemGet(args(x), args(x).OFFSET, _Byte), "BYTE"
Exit Select
Case 2
Print _MemGet(args(x), args(x).OFFSET, Integer), "SHORT"
Exit Select
Case 4
Print _MemGet(args(x), args(x).OFFSET, Long), "LONG"
Exit Select
Case 8
Print _MemGet(args(x), args(x).OFFSET, _Integer64), "INT64"
Exit Select
End Select
End If
End If
ElseIf _ReadBit(args(x).TYPE, 8) Then 'SINGLE, DOUBLE, FLOAT
If _ReadBit(args(x).TYPE, 16) Then
Select Case args(x).ELEMENTSIZE
Case 4
Dim As Single singlearray(1 To (size / elementsize))
For y = LBound(singlearray) To UBound(singlearray)
_MemGet args(x), args(x).OFFSET + z, singlearray(y)
z = z + args(x).ELEMENTSIZE
Print singlearray(y), "SINGLE ARRAY"
Next
Exit Select
Case 8
Dim As Double doublearray(1 To (size / elementsize))
For y = LBound(doublearray) To UBound(doublearray)
_MemGet args(x), args(x).OFFSET + z, doublearray(y)
z = z + args(x).ELEMENTSIZE
Print doublearray(y), "DOUBLE ARRAY"
Next
Exit Select
Case 32
Dim As _Float floatarray(1 To (size / elementsize))
For y = LBound(floatarray) To UBound(floatarray)
_MemGet args(x), args(x).OFFSET + z, floatarray(y)
z = z + args(x).ELEMENTSIZE / 2
Print floatarray(y), "FLOAT ARRAY"
Next
Exit Select
End Select
Else
Select Case args(x).SIZE
Case 4
Print _MemGet(args(x), args(x).OFFSET, Single), "SINGLE"
Exit Select
Case 8
Print _MemGet(args(x), args(x).OFFSET, Double), "DOUBLE"
Exit Select
Case 32
Print _MemGet(args(x), args(x).OFFSET, _Float), "FLOAT"
Exit Select
End Select
End If
ElseIf _ReadBit(args(x).TYPE, 9) Then 'STRING
If _ReadBit(args(x).TYPE, 16) Then
Dim As String stringarray(1 To (size / elementsize))
For y = LBound(stringarray) To UBound(stringarray)
stringarray(y) = Space$(args(x).ELEMENTSIZE)
_MemGet args(x), (args(x).OFFSET) + (y * args(x).ELEMENTSIZE - args(x).ELEMENTSIZE), stringarray(y)
Print stringarray(y), "STRING ARRAY"
Next
Else
Dim As String stringtest: stringtest = Space$(args(x).ELEMENTSIZE)
_MemGet args(x), args(x).OFFSET, stringtest
Print stringtest
End If
ElseIf _ReadBit(args(x).TYPE, 13) And _ReadBit(args(x).TYPE, 7) Then '_OFFSET
If _ReadBit(args(x).TYPE, 10) Then
If _ReadBit(args(x).TYPE, 16) Then
Dim As _Unsigned _Offset unsignedoffsetarray(1 To (size / elementsize))
For y = LBound(unsignedoffsetarray) To UBound(unsignedoffsetarray)
_MemGet args(x), args(x).OFFSET + z, unsignedoffsetarray(y)
z = z + args(x).ELEMENTSIZE
Print unsignedoffsetarray(y), "ULONG_PTR ARRAY"
Next
Else
Print _MemGet(args(x), args(x).OFFSET, _Unsigned _Offset), "ULONG_PTR"
End If
Else
If _ReadBit(args(x).TYPE, 16) Then
Dim As _Offset offsetarray(1 To (size / elementsize))
For y = LBound(offsetarray) To UBound(offsetarray)
_MemGet args(x), args(x).OFFSET + z, offsetarray(y)
z = z + args(x).ELEMENTSIZE
Print unsignedoffsetarray(y), "LONG_PTR ARRAY"
Next
Else
Print _MemGet(args(x), args(x).OFFSET, _Offset), "LONG_PTR"
End If
End If
ElseIf args(x).TYPE = 0 And args(x).SIZE > 0 Then '_MEMSOUND
If Not _SndPlaying(args(x).SOUND) Then
_SndPlay (args(x).SOUND)
End If
Print "SOUND", args(x).SIZE, args(x).ELEMENTSIZE
ElseIf _ReadBit(args(x).TYPE, 14) Then
Print args(x).SIZE, "MEM"
'todo
End If
If _ReadBit(args(x).TYPE, 11) Then '_MEMIMAGE
Screen args(x).IMAGE
End If
End If
Next
End Sub
And the revisions QB64 GPT made (after minor changes and me asking it to redo some syntax errors):
Code: (Select All)
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
' 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
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
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
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
Sub HandleSoundType (arg As _MEM)
If Not _SndPlaying(arg.SOUND) Then
_SndPlay (arg.SOUND)
End If
Print "SOUND", arg.SIZE, arg.ELEMENTSIZE
End Sub
' 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
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
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
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
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
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
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
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
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
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
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
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
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
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
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.
Note: I didn't post the sample code I used.
It actually even listened to me when I told it that it would need to cast an OFFSET type by using VAL(STR$(var)).
As we work our way backwards to cover our newest keywords in the language, we start to move back to version 3.11, where _FILES$ was added fro us. At first, I thought this would just be a quick show-n-tell type entry in our list of KotD, but it seems like I was mistaken. There's actually several points that need to be brought up and emphasized that everyone needs to be aware of with this newest way to get a file listing.
First, let's cover the fact that _FILE$ is a dual-usage command. One has to use it for two very distinct uses inside their code, for it to be very functional at all.
First, _FILES$ must be called once, to set the type of files that one is looking for. This isn't a hard step, but it's an essential one:
Code: (Select All)
x$ = _FILES$("*.bas")
The above is all that's needed to set the Path and types that we're looking for. For the above, it says that we basically want to get a listing of all the files that end with a ".bas" extension, and since we didn't specify the path, we want to use the Current Working Directory (_CWD$).
If we wanted to get a listing of all txt files from the "C:\My Documents\" folder, we'd want to call _FILE$ with those options to set the path and directory. Basically:
Code: (Select All)
x$ = _FILES$("C:\My Documents\*.txt")
Now note that this first use of _FILES$ is to set the path and type of what we're looking for. After this, we can now call _FILE$ -- with no parameters -- to get back the files that meet those options for us, one at a time, until we come back with a null string.
The way this looks is basically:
Code: (Select All)
x$ = _FILES$("C:\My Documents\*.txt")
DO UNTIL x$ = "" 'repeat until we get a null string response
PRINT x$ 'display the file name we get back
x$ = _FILES$ 'no param needed here
LOOP
It's honestly that simple, and I was thinking at first that the above would basically be all that one would need to be able to use the command properly....
HOWEVER....
There's one more important issue that I need to stress for folks, or else things may not end up performing as they'd expect them to!
Let's now take a moment to back up into the ancient past of coding. Back all the ways to the days of DOS and GWBASIC and QB45... Back, into the dim recesses of history, when the skies were still dark swirling masses of energy and the universe was just forming. Back... GASP.... even before the internet existed!! LONG... LONG... LONG AGO....
A lot of our user base problably remembers those days quite well.
Back in those days, one would type something into the commnad line such as:
Code: (Select All)
DIR *.*
And, from that code, they'd get a listing of ALL their files and folders. That star (the * symbol) represented a wildcard which meant <anything>, so "*.*" was a search for a file named <anything> with an extension of <anything>... in otherwords, "*.*" represented EVERYTHING.
DIR *.* would give you a listing of ALL files and folders for the ciurrent directory.
And with that history out of the way, let's move forward in time a bit, to when those 8-character filenames became obsolete. At some point in time, we started to be able to use 256 character long file names. And then, as folks wanted even more characters, we even expanded beyond that to 65,535 character file names (in some cases/formats).
No longer were files limited to juse being <name> <dot> <extension>. You could now write and create a file and call it "My.dot.filled.file.txt", if you wanted too, and the OS and your hard drive didn't care!!
And keeping those two points in mind, how do you think that's affected _FILES$ and how it behaves now??
Let me sidetrack for a second, before answering that, to ask, "What do you think you'd get if you did the following:"
Code: (Select All)
DIR *e*
With the modern limits on file names, wouldn't the above basically be <anything> <then an e> <anything>.... So it's basically a search for any file or folder that has an "e" in it.
Now, to back back up, let's ask, "What do you think you'd get if you do the following:"
Code: (Select All)
DIR *.*
And this one is a little trickier to answer. Some legacy routines will do like it used to do ages ago and list ALL files and folders. Some of the newer routines will filter it, just as they would with that "*e* -- it'd give you a list of files WHICH INCLUDE A DOT IN THEM!!
To highlight this difference, let's take a moment to look at a file list. Pretend this is my drive:
Code: (Select All)
C:\
C:\Temp\
C:\Temp.Stuff\
C:\temp.txt
Now, according to legacy rules, DIR *.* would list:
Code: (Select All)
C:\
C:\Temp\
C:\Temp.Stuff\
C:\temp.txt
But accoring to modern tules, DIR *.* would list:
Code: (Select All)
C:\Temp.Stuff\
C:\temp.txt
Notice that C:\ and C:\Temp are missing from the modern way of processing *.*?? It's because they have no DOT in their filename.
"*.*" isn't what it used to be. It no longer represents a file named <ANYTHING> and an extension named <ANYTHING>.
"*.*" now represents <a DOT with ANYTHING before it and ANYTHING after it>.
And that's an important distinction for folks to realize, when using _FILES$, as _FILES$ uses this more modern interpretation of the command syntax.
If you want a list of <EVERYTHING>, the easiest way to get this with the modern ruleset is to simply
Code: (Select All)
x$ = _FILE$("*")
Notice you're just looking for * (<ANYTHING>), and not *.* (<ANYTHING before><DOT><ANYTHING after>).
This is a very important difference and something that everyone should note. Don't use "*.*" just because you're on old foggie like Steve, who got used to that in the age of the dinosaurs of programming. If you want a list of ALL files, just use "*" for your search limiter.
This works pretty well until it doesn't. It could be 30 seconds or 2 minutes, but eventually it seems to stop updating the display and I've tracked it down to an Error #75 at line 425 in "MAINPROG.BAS":
Code: (Select All)
Open arrFile(iIndex, cFileName) For Input As #1
after which it then just keeps getting Error #55 at line 425.
If you kill "MAINPROG.BAS" and run it again (leave "READMICE.BAS" running) it works again (as long as you give "READMICE.BAS" the focus) but eventually the error happens again.
The way it works is, two programs run simultaneously:
"READMICE.BAS" reads mice input using the Raw Input API, and continually writes the mouse input to files (1 file per mouse). This window must have the focus but the other program is set to always display on top, as it is what draws the graphics and handles the main logic.
"MAINPROG.BAS" continually reads the mouse input from the files, and uses it to position some text on the screen. This window is set to always display on top, but the other program must have the focus so that it can read the mice.
I suspect what's happening is that the one program is trying to read the file at the exact same time the other one is writing it.
I think there has to be a better way than writing/reading files to get the two programs to talk to each other, either somehow using some shared environmental variables in memory or maybe talking via LAN calls, but I don't know much about those things.
Any help getting this working would be much appreciated!
PS Currently "MAINPROG" is set up to output error messages to the console window for debugging, this can be turned off from the line
Code: (Select All)
Dim Shared m_bDebug As Integer: m_bDebug = TRUE
by setting m_bDebug to FALSE.
The 2 programs follow:
Program A "READMICE.BAS". This should have the focus but be hidden underneath Program B (which controls the display and is always on top).
Code: (Select All)
' ################################################################################################################################################################
' Multimouse program A "readmice.bas" = mouse reader
' ################################################################################################################################################################
' Working proof of concept! (Windows only so far)
' 1. Plug 2 or more USB mice into your computer.
' 2. Run the mouse reader program "readmice.bas"
' 3. Run the front end program "mainprog.bas"
' 4. Drag the windows and make sure they line up, one on top of the other.
' 5. Set the focus to "readmice.bas" (it will be hidden underneath "mainprog", so use the taskbar or ALT+TAB).
' 6. Try moving each mouse. Each one should move a different letter.
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' madscijr - Mini-Mod
' #34
' 09-12-2022, 12:05 PM (This post was last modified: 09-12-2022, 12:07 PM by madscijr.)
' (09-09-2022, 04:27 PM) Spriggsy Wrote:
' >The button catching was working in the example I gave you so you might want to take a look at that mousemessage string. My version displayed the current button being pressed. Here is the relevant link for the RAWMOUSE struct.
' >https://docs.microsoft.com/en-us/windows/win32/api/winuser/ns-winuser-rawmouse
' >You can see the value for each button state listed there.
' >Edit.... Weird. Now it isn't wanting to work on my machine. It was working yesterday just fine.
' >Edit again.... Ah, I wasn't drawing the button information again. I accidentally erased the update. See below and you can try it out. The code does catch the buttons.
'
' Aha, thanks. The mouse button up/down are now being detected and I have it saving the state for left/middle/right clicks (code below).
'
' Now what black magic are we going to have to do, to get this out of the "event driven" code, and working like a regular QB64 program?
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' McNeill - Super Moderator
' #2
' 05-17-2024, 07:27 PM (This post was last modified: 05-17-2024, 07:28 PM by SMcNeill.)
' https://qb64phoenix.com/qb64wiki/index.php/Windows_Libraries#Top_Most_Window
' SMcNeill - Super Moderator
' #11
' 2 hours ago
' Const SWP_NOMOVE = &H0002 'ignores x and y position parameters
' Steffan-68 - Junior Member
' #12
' 2 hours ago
' Do both programs have to be in the same place on the monitor?
' If not, you can change these lines.
' If 0 = SetWindowPos(hWnd, HWND_TOPMOST, 840, 200, 0, 0, SWP_NOSIZE Or SWP_NOACTIVATE) Then
' und
' _ScreenClick 880, 240 ' add 40 to x and y to focus on positioned window
'
' This means that both programs would be next to each other,
' but only the one that is set to foreground remains in the foreground
' and the other one could then fade into the background.
' I don't know what you're trying to do, maybe you could also
' play around with the command (_SCREENICON).
' So that the program that is not in the foreground disappears from the monitor?
' SMcNeill - Super Moderator
' #13
' 2 hours ago
' Sorry. I didn't notice the need for _SCREENCLICK.
' What you're looking for is:
' https://qb64phoenix.com/qb64wiki/index.php/SCREENX
' https://qb64phoenix.com/qb64wiki/index.php/SCREENY
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' -------------------------------------------------------------------------------
' TO DO
' -------------------------------------------------------------------------------
' Some issues and things to fix:
' * detect mouse button clicks (left, middle, right buttons) without losing focus
' and the focus going to "mainprog.bas" which is in front but must not have the focus.
' * rework code from event-driven to linear (ie call a routine to get the
' latest coordinates / button states / scroll wheel for mouse n)
' * detect moving the scroll wheel
' * hide the real mouse cursor
' * get this working with _FullScreen _SquarePixels
' * scale the dx and dy of each mouse to 80x25 (or whatever target range is)
' * read the absolute position rather than dx and dy & fix scaling mouse
' coordinates to 80x25 (or whatever our target range is)
' * the code is seeing an extra (phantom) mouse - might be the disabled
' trackpad on my laptop. Is there a way to determine which mice or devices
' are disabled or can be ignored?
' * (later) Figure out how to do this for reading multiple keyboards.
' * (later) Figure out how to get the same functionality for Mac & Linux
' -------------------------------------------------------------------------------
' 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.
' 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.
Option Explicit
_Title "readmice"
$NoPrefix
'$Console:Only
'Console Off
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN CONSTANTS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Const cProgName = "readmice"
Const FALSE = 0
Const TRUE = Not FALSE
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' USED TO CONVERT MOUSE POSITION TO GET SCREEN POSITION
' ScreenPos = MousePos / ScaleValue
' This doesn't really work too accurately!
Const cScaleX = 3
Const cScaleY = 4
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' FOR RAW INPUT API
Const CS_HREDRAW = &H0002
Const CS_VREDRAW = &H0001
Const WS_OVERLAPPED = &H00000000
Const WS_CAPTION = &H00C00000
Const WS_SYSMENU = &H00080000
Const WS_THICKFRAME = &H00040000
Const WS_MINIMIZEBOX = &H00020000
Const WS_MAXIMIZEBOX = &H00010000
Const WS_CHILD = &H40000000
Const WS_VISIBLE = &H10000000
Const WS_OVERLAPPEDWINDOW = WS_OVERLAPPED Or WS_CAPTION Or WS_SYSMENU Or WS_THICKFRAME Or WS_MINIMIZEBOX Or WS_MAXIMIZEBOX
Const CW_USEDEFAULT = &H80000000
Const WM_DESTROY = &H0002
Const WM_INPUT = &H00FF
Const SW_SHOW = 5
Const RID_INPUT = &H10000003
Const RIM_TYPEMOUSE = 0 ' Raw input comes from the mouse.
Const RIM_TYPEKEYBOARD = 1 ' Raw input comes from the keyboard.
Const RIM_TYPEHID = 2 ' Raw input comes from some device that is not a keyboard or a mouse.
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' CONSTANT FOR 2ND DIMENSION OF arrFile ARRAY
Const cFileName = 0
Const cFileData = 1
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END CONSTANTS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN UDTs
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Type RAWINPUTDEVICE
As Unsigned Integer usUsagePage, usUsage
As Unsigned Long dwFlags
As Offset hwndTarget
End Type
Type RAWINPUTDEVICELIST
As Offset hDevice
As Unsigned Long dwType
$If 64BIT Then
As String * 4 alignment
$End If
End Type
Type POINT
As Long x, y
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
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
Type RECT
As Long left, top, right, bottom
End Type
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
Type RAWINPUTHEADER
As Unsigned Long dwType, dwSize
As Offset hDevice
As Unsigned Offset wParam
End Type
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
Type RAWINPUT
As RAWINPUTHEADER header
As RAWMOUSE mouse
End Type
' UDT TO HOLD THE INFO FOR EACH MOUSE
Type MouseInfoType
UpdateCount As Integer ' if this value changes we know a value changed
ID As String ' mouse device ID
c As String ' cursor character
x As Integer ' screen x position
y As Integer ' screen y position
mouseX As Integer ' mouse x movement -1=left, 1=right, 0=none
mouseY As Integer ' mouse y movement -1=up , 1=down , 0=none
wheel As Integer ' mouse wheel value
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
LeftCount As Integer ' counts left clicks
MiddleCount As Integer ' counts middle clicks
RightCount As Integer ' counts right clicks
End Type ' MouseInfoType
' UDT TO HOLD THE INFO FOR EACH KEYBOARD
Type KeyboardInfoType
UpdateCount As Integer ' if this value changes we know a value changed
ID As String ' keyboard device ID
'TBD
End Type ' KeyboardInfoType
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END UDTs
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN API DECLARATIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' FOR RAW INPUT API
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
Declare CustomType Library
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)
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)
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)
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)
Sub GetClientRect (ByVal hWnd As Offset, Byval lpRect As Offset)
Sub DrawText (ByVal hdc As Offset, Byval lpchText As Offset, Byval cchText As Long, Byval lprc As Offset, Byval format As Unsigned 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
' 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
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
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' 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)
' GLOBAL VARIABLES TO TRACK ERROR STATE
Dim Shared m_sError As String: m_sError = ""
Dim Shared m_sIncludeError As String: m_sIncludeError = ""
' RAW INPUT VARIABLES
Dim Shared mousemessage As String
Dim Shared rawinputdevices As String
' MOUSE VARIABLES
Dim Shared arrMouse(0 To 8) As MouseInfoType ' STORES INFO FOR EACH MOUSE
'Dim Shared arrRawMouseID(8) As Long ' device IDs for mice connected to system (guessing this would be a string, dunno)
Dim Shared iMouseCount As Integer ' # OF MICE ATTACHED
' KEYBOARD VARIABLES
Dim Shared arrKeyboard(0 To 8) As KeyboardInfoType ' STORES INFO FOR EACH KEYBOARD
Dim Shared iKeyboardCount As Integer ' # OF KEYBOARDS ATTACHED
Dim Shared arrKeyState(0 To 8, 1 To 512) As Integer ' arrKeyState({device#}, {keyCode}) = TRUE if key {keyCode} on keyboard {device#} is currently held down.
Dim Shared arrScreen(1 To 80, 1 To 25) As String ' STORES TEXT FOR SCREEN
Dim Shared iMinX As Long
Dim Shared iMaxX As Long
Dim Shared iMinY As Long
Dim Shared iMaxY As Long
' RAW FILE NAMES
Dim Shared arrFile(0 To 31, 0 To 1) As String
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END GLOBAL VARIABLES
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' =============================================================================
' START THE MAIN ROUTINE
main
' =============================================================================
' FINISH
Print m_ProgramName$ + " finished."
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 DATA STATEMENTS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' MOUSE CURSORS (JUST SOME LETTERS)
CData:
Data A,b,C,D,E,f,G,H
' DEFAULT/INTIAL X COORDINATE OF EACH CURSOR ON SCREEN
XData:
Data 5,15,25,35,45,55,65,75
' DEFAULT/INTIAL Y COORDINATE OF EACH CURSOR ON SCREEN
YData:
Data 17,17,19,19,21,21,23,23
' DEFAULT/INITIAL VALUE OF EACH SCROLL WHEEL
WData:
Data 224,192,160,128,96,64,32,0
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END DATA STATEMENTS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN MAIN ROUTINES
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' 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?
' GIVE CONTROL TO THE EVENT-ORIENTED CODE
System Val(Str$(WinMain))
End Sub ' main
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END MAIN ROUTINES
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN RAW INPUT FUNCTIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' /////////////////////////////////////////////////////////////////////////////
' Runs first
Function WinMain~%& ()
Dim As Offset hwndMain, hInst
Dim As MSG msg
Dim As WNDCLASSEX wndclass
Dim As String szMainWndClass
Dim As String szWinTitle
Dim As Unsigned Integer reg
'DEBUG: TRY FULL SCREEN <- PROGRAM CRASHES!
'_FullScreen _SquarePixels
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
'DEBUG: SUBSTITUTE _WindowHandle
'Function CreateWindowEx%& (
' ByVal dwExStyle As Unsigned Long = 0
' Byval lpClassName As Offset = MAKELPARAM(reg, 0)
' Byval lpWindowName As Offset = Offset(szWinTitle)
' Byval dwStyle As Unsigned Long = WS_OVERLAPPEDWINDOW
' Byval x As Long = CW_USEDEFAULT
' Byval y As Long = CW_USEDEFAULT
' Byval nWidth As Long = CW_USEDEFAULT
' Byval nHeight As Long = CW_USEDEFAULT
' Byval hWndParent As Offset = 0
' Byval hMenu As Offset = 0
' Byval hInstance As Offset = hInst
' Byval lpParam As Offset = 0
While GetMessage(Offset(msg), 0, 0, 0)
TranslateMessage Offset(msg)
DispatchMessage Offset(msg)
Wend
WinMain = msg.wParam
End Function ' WinMain
' /////////////////////////////////////////////////////////////////////////////
' Handles main window events
Function MainWndProc%& (hwnd As Offset, nMsg As Unsigned Long, wParam As Unsigned Offset, lParam As Offset)
Static As Offset hwndButton
Static As Long cx, cy
Dim As Offset hdc
Dim As PAINTSTRUCT ps
Dim As RECT rc
Dim As MEM lpb
Dim As Unsigned Long dwSize
Dim As RAWINPUT raw
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 iLen As Integer
Dim sCount As String
Dim sX As String
Dim sY 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
' MORE TEMP VARIABLES
Dim iMouseNum As Integer
' HANDLE EVENTS
Select Case nMsg
Case WM_DESTROY
PostQuitMessage 0
MainWndProc = 0
Exit Function
Case WM_INPUT
GetRawInputData lParam, RID_INPUT, 0, Offset(dwSize), Len(rih)
lpb = MemNew(dwSize)
If lpb.SIZE = 0 Then
MainWndProc = 0
Exit Function
End If
If GetRawInputData(lParam, RID_INPUT, lpb.OFFSET, Offset(dwSize), Len(rih)) <> dwSize Then
'Print "GetRawInputData doesn't return correct size!"
mousemessage = "GetRawInputData doesn't return correct size!"
End If
MemGet lpb, lpb.OFFSET, raw
If raw.header.dwType = RIM_TYPEMOUSE Then
tmpx = raw.mouse.lLastX
tmpy = raw.mouse.lLastY
maxx = tmpx
' GET MOUSE INFO
' NOTES:
' ulButtons and usButtonFlags both return the same thing (buttons)
' usButtonData changes value when scroll wheel moved (just stays at one value)
'mousemessage = ""
'mousemessage = mousemessage + "Mouse:hDevice" + Str$(raw.header.hDevice)
'mousemessage = mousemessage + "usFlags=" + Hex$(raw.mouse.usFlags)
'mousemessage = mousemessage + "ulButtons=" + Hex$(MAKELONG(raw.mouse.usButtonFlags, raw.mouse.usFlags))
'mousemessage = mousemessage + "usButtonFlags=" + Hex$(raw.mouse.usButtonFlags)
'mousemessage = mousemessage + "usButtonData=" + Hex$(raw.mouse.usButtonData)
'mousemessage = mousemessage + "ulRawButtons=" + Hex$(raw.mouse.ulRawButtons)
'mousemessage = mousemessage + "lLastX=" + Str$(raw.mouse.lLastX)
'mousemessage = mousemessage + "lLastY=" + Str$(raw.mouse.lLastY)
'mousemessage = mousemessage + "ulExtraInformation=" + Hex$(raw.mouse.ulExtraInformation) + Chr$(13)
' 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)
' IDENTIFY WHICH MOUSE IT IS
strNextID = _Trim$(Str$(raw.header.hDevice))
iIndex = GetMouseIndex%(strNextID)
If iIndex >= LBound(arrMouse) Then
If iIndex <= UBound(arrMouse) Then
' =============================================================================
' READ MOUSE MOVEMENT
' DOESN'T WORK, MOVES ALL OVER THE PLACE:
'' METHOD #1: SCALE MOUSE POSITION TO 80X25 POSITION
'iNewX = ( (GET_X_LPARAM(lParam) + 1) * 80) \ (iMaxX+1)
'iNewY = ( (GET_Y_LPARAM(lParam) + 1) * 25) \ (iMaxY+1)
'arrMouse(iIndex).x = iNewX
'arrMouse(iIndex).y = iNewY
' WORKS BUT NOT THAT ACCURATE:
' METHOD #2: INCREMENT/DECREMENT DELTA
If raw.mouse.lLastX < 0 Then
arrMouse(iIndex).mouseX = -1
ElseIf raw.mouse.lLastX > 0 Then
arrMouse(iIndex).mouseX = 1
Else
arrMouse(iIndex).mouseX = 0
End If
If raw.mouse.lLastY < 0 Then
arrMouse(iIndex).mouseY = -1
ElseIf raw.mouse.lLastY > 0 Then
arrMouse(iIndex).mouseY = 1
Else
arrMouse(iIndex).mouseY = 0
End If
' =============================================================================
'TODO: SAVE SCROLL WHEEL + BUTTONS
'Hex$(raw.mouse.usButtonFlags)
' left button = 1 when down, 2 when released
If ((raw.mouse.usButtonFlags And 1) = 1) Then
arrMouse(iIndex).LeftDown = TRUE
ElseIf ((raw.mouse.usButtonFlags And 2) = 2) Then
arrMouse(iIndex).LeftDown = FALSE
End If
' middle button = 16 when down, 32 when released
If ((raw.mouse.usButtonFlags And 16) = 16) Then
arrMouse(iIndex).MiddleDown = TRUE
ElseIf ((raw.mouse.usButtonFlags And 32) = 32) Then
arrMouse(iIndex).MiddleDown = FALSE
End If
' right button = 4 when down, 8 when released
If ((raw.mouse.usButtonFlags And 4) = 4) Then
arrMouse(iIndex).RightDown = TRUE
ElseIf ((raw.mouse.usButtonFlags And 8) = 8) Then
arrMouse(iIndex).RightDown = FALSE
End If
' DID VALUE CHANGE?
If arrMouse(iIndex).UpdateCount = 32767 Then
arrMouse(iIndex).UpdateCount = 1
Else
arrMouse(iIndex).UpdateCount = arrMouse(iIndex).UpdateCount + 1
End If
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' WRITE VALUES FOR THIS MOUSE TO FILE
' UPDATE mousemessage WITH PLAYING FIELD
mousemessage = ScreenToString$
' ================================================================================================================================================================
' END WRITE OUTPUT FILE
' ================================================================================================================================================================
' WinAPI Raw Input confusion - For Beginners - GameDev.net
' https://www.gamedev.net/forums/topic/700010-winapi-raw-input-confusion/
'iKeyboardCount = iKeyboardCount + 1 ' # KEYBOARDS ATTACHED
'strNextID = _Trim$(Str$(rawdevs(x).hDevice))
'arrKeyboard(iKeyboardCount - 1).ID = strNextID
' TODO: READ KEYBOARD AND STORE KEYBOARD STATE
'arrKeyState(0 To 8, 1 To 512) As Integer ' arrKeyState({device#}, {keyCode}) = TRUE if key {keyCode} on keyboard {device#} is currently held down.
' SAVE RANGE OF MOUSE COORDINATES
If GET_X_LPARAM(lParam) < iMinX Then
iMinX = GET_X_LPARAM(lParam)
arrMouse(iIndex).mouseX = -1
ElseIf GET_X_LPARAM(lParam) > iMaxX Then
iMaxX = GET_X_LPARAM(lParam)
arrMouse(iIndex).mouseX = 1
Else
arrMouse(iIndex).mouseX = 0
End If
If GET_Y_LPARAM(lParam) < iMinY Then
iMinY = GET_Y_LPARAM(lParam)
arrMouse(iIndex).mouseY = -1
ElseIf GET_Y_LPARAM(lParam) > iMaxY Then
iMaxY = GET_Y_LPARAM(lParam)
arrMouse(iIndex).mouseY = 1
Else
arrMouse(iIndex).mouseY = 0
End If
' IDENTIFY WHICH MOUSE IT IS
strNextID = _Trim$(Str$(raw.header.hDevice))
iIndex = GetMouseIndex%(strNextID)
If iIndex >= LBound(arrMouse) Then
If iIndex <= UBound(arrMouse) Then
' =============================================================================
' UPDATE ABSOLUTE POSITION
' WORKS BUT NOT THAT ACCURATE:
' METHOD #2: INCREMENT/DECREMENT DELTA
' (should we update here too?)
'TODO: SAVE SCROLL WHEEL + BUTTONS
' (should we update here too?)
'arrMouse(iIndex).wheel =
'arrMouse(iIndex).LeftDown =
'arrMouse(iIndex).MiddleDown =
'arrMouse(iIndex).RightDown =
End If
End If
Case Else
'DEBUG: SUBSTITUTE _WindowHandle
MainWndProc = DefWindowProc(hwnd, nMsg, wParam, lParam)
'MainWndProc = DefWindowProc(_WindowHandle, nMsg, wParam, lParam)
End Select
If _KeyDown(27) Then End
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 strNextID As String
'dim lngNextID as long
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 MOUSE / KEYBOARD INFO
iMouseCount = 0
iKeyboardCount = 0
rawinputdevices = "Number of raw input devices:" + Str$(nDevices) + Chr$(13)
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 = 0 Then
If rawdevs(x).dwType = RIM_TYPEMOUSE Then
iMouseCount = iMouseCount + 1
strNextID = _Trim$(Str$(rawdevs(x).hDevice))
'lngNextID = Val(strNextID)
'arrMouse(iMouseCount-1).ID = lngNextID
arrMouse(iMouseCount - 1).ID = strNextID
arrMouse(iMouseCount - 1).UpdateCount = 0
'TODO: SAVE_MOUSE_INFO
ElseIf rawdevs(x).dwType = RIM_TYPEKEYBOARD Then
iKeyboardCount = iKeyboardCount + 1 ' # KEYBOARDS ATTACHED
strNextID = _Trim$(Str$(rawdevs(x).hDevice))
arrKeyboard(iKeyboardCount - 1).ID = strNextID
arrKeyboard(iKeyboardCount - 1).UpdateCount = 0
' TODO: READ KEYBOARD AND STORE KEYBOARD STATE
'arrKeyState(0 To 8, 1 To 512) As Integer ' arrKeyState({device#}, {keyCode}) = TRUE if key {keyCode} on keyboard {device#} is currently held down.
End If
Next x
rawinputdevices = rawinputdevices + Chr$(0)
If RegisterRawInputDevices(Offset(Rid()), 1, Len(Rid(0))) = 0 Then
mousemessage = "RawInput init failed" + Chr$(0)
End If
End Sub ' InitRawInput
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END RAW INPUT FUNCTIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN MOUSE TEST FUNCTIONS #1
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' /////////////////////////////////////////////////////////////////////////////
' Initialize mouse test stuff
'TODO: SAVE_MOUSE_INFO
Sub InitMouseTest
Dim iIndex As Integer
Dim iLoop As Integer
' FOR NOW ONLY SUPPORT UPTO 8 MICE
If (iMouseCount > 8) Then iMouseCount = 8
' INITIALIZE X COORDINATES
Restore XData
iIndex = LBound(arrMouse) - 1
For iLoop = 1 To iMouseCount
iIndex = iIndex + 1
Read arrMouse(iIndex).x
Next iLoop
' INITIALIZE Y COORDINATES
Restore YData
iIndex = LBound(arrMouse) - 1
For iLoop = 1 To iMouseCount
iIndex = iIndex + 1
Read arrMouse(iIndex).y
Next iLoop
' INITIALIZE SCROLL WHEEL
Restore WData
iIndex = LBound(arrMouse) - 1
For iLoop = 1 To iMouseCount
iIndex = iIndex + 1
Read arrMouse(iIndex).wheel
Next iLoop
End Sub ' InitMouseTest
' /////////////////////////////////////////////////////////////////////////////
' 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
Else
' not it
End If
Next iLoop
GetMouseIndex% = iIndex%
End Function ' GetMouseIndex%
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END MOUSE TEST FUNCTIONS #1
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN TEST OUTPUT FUNCTIONS FOR API CONTROLLED UI
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' /////////////////////////////////////////////////////////////////////////////
' Clears global array arrScreen
Sub ClearText
Dim iColNum As Integer
Dim iRowNum As Integer
For iColNum = LBound(arrScreen, 1) To UBound(arrScreen, 1)
For iRowNum = LBound(arrScreen, 2) To UBound(arrScreen, 2)
arrScreen(iColNum, iRowNum) = " "
Next iRowNum
Next iColNum
End Sub ' ClearText
' /////////////////////////////////////////////////////////////////////////////
' Plots string MyString to position (iX, iY) in global array arrScreen.
Sub WriteText (iRow As Integer, iColumn As Integer, MyString As String)
Dim iPos As Integer
Dim iLoop As Integer
If iColumn > 0 And iColumn < 81 Then
If iRow > 0 And iRow < 26 Then
For iLoop = 1 To Len(MyString)
iPos = iColumn + (iLoop - 1)
If iPos < 81 Then
arrScreen(iPos, iRow) = Mid$(MyString, iLoop, 1)
Else
Exit For
End If
Next iLoop
End If
End If
End Sub ' WriteText
' /////////////////////////////////////////////////////////////////////////////
' Converts global array arrScreen to a string.
Function ScreenToString$
Dim sResult As String
Dim iColNum As Integer
Dim iRowNum As Integer
sResult = ""
For iRowNum = LBound(arrScreen, 2) To UBound(arrScreen, 2)
For iColNum = LBound(arrScreen, 1) To UBound(arrScreen, 1)
sResult = sResult + arrScreen(iColNum, iRowNum)
Next iColNum
sResult = sResult + Chr$(13)
Next iRowNum
ScreenToString$ = sResult
End Function ' ScreenToString$
' /////////////////////////////////////////////////////////////////////////////
' based on code from:
' Qbasic Programs - Download free bas source code
' http://www.thedubber.altervista.org/qbsrc.htm
Sub DrawTextLine (y%, x%, y2%, x2%, c$)
Dim i%
Dim steep%
Dim e%
Dim sx%
Dim dx%
Dim sy%
Dim dy%
i% = 0: steep% = 0: e% = 0
If (x2% - x%) > 0 Then sx% = 1: Else sx% = -1
dx% = Abs(x2% - x%)
If (y2% - y%) > 0 Then sy% = 1: Else sy% = -1
dy% = Abs(y2% - y%)
If (dy% > dx%) Then
steep% = 1
Swap x%, y%
Swap dx%, dy%
Swap sx%, sy%
End If
e% = 2 * dy% - dx%
For i% = 0 To dx% - 1
If steep% = 1 Then
''PSET (y%, x%), c%:
'Locate y%, x% : Print c$;
WriteText y%, x%, c$
Else
''PSET (x%, y%), c%
'Locate x%, y% : Print c$;
WriteText x%, y%, c$
End If
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END TEST OUTPUT FUNCTIONS FOR API CONTROLLED UI
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN MOUSE FUNCTIONS TO COME
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' /////////////////////////////////////////////////////////////////////////////
' Returns a count of # of RawInput mouse devices connected to the system
' *****************************************************************************
' TODO: GET COUNT FROM RawInput API
' For now, hardcoded to 1 until we figure out how to do this.
' *****************************************************************************
Function GetRawMouseCount% ()
GetRawMouseCount% = 1
End Function ' GetRawMouseCount%
' /////////////////////////////////////////////////////////////////////////////
' Gets ID of each RawInput mouse device connected to the system (for now upto 8)
' Returns the IDs in an array of LONG <- may change depending on whether
' we save each the device handle for each mouse or the index
' If no mouse found, the ID will just be 0 <- or whatever value we decide as default/none
' *****************************************************************************
' TODO: GET THIS FROM RawInput API
' For now, hardcoded arrRawMouseID(1) to 1, and the rest 0, until we figure out how to do this.
' *****************************************************************************
'Sub GetRawMouseIDs (arrRawMouseID( 8) As Integer)
Sub GetRawMouseIDs ()
Dim iLoop As Integer
' CLEAR OUT IDs
For iLoop = 1 To 8
''arrRawMouseID(iLoop) = 0
'arrMouse(iLoop).ID = 0
arrMouse(iLoop).ID = ""
Next iLoop
' GET IDs
'TODO: get this from RawInput API
''arrRawMouseID(1) = 1 ' for now just fudge it!
'arrMouse(0).ID = 1 ' for now just fudge it!
End Sub ' GetRawMouseIDs
' /////////////////////////////////////////////////////////////////////////////
' Read mouse using RawInput API
' Gets input from mouse, MouseID% = which mouse
' NOTE: click events (mouse up/mouse down) are handled by the calling sub,
' this routine just sends back
' TRUE if the given button is currently down or FALSE if it is up.
' Parameters (input only):
' MouseID% = which mouse to return input for
' wheelMin% = minimum value to allow wheelValue% to be decremented to
' wheelMax% = maximum value to allow wheelValue% to be incremened to
' Parameters (values returned):
' x% = mouse x position
' y% = mouse y position
' leftButton% = current state of left mouse button (up or down)
' middleButton% = current state of middle mouse button / scroll wheel button (up or down)
' rightButton% = current state of right mouse button (up or down)
' wheelValue% = value of mouse scroll wheel (passed in and incremented/decremented by 1 if wheel move detected)
Sub ReadRawMouse (MouseID%, x%, y%, leftButton%, middleButton%, rightButton%, wheelValue%, wheelMin%, wheelMax%)
Dim scrollAmount%
Dim dx%
Dim dy%
' =============================================================================
' BEGIN READ MOUSE THE NEW RawInput WAY:
' read scroll wheel
'TODO: get this from RawInput API
' determine mouse x position
'TODO: get this from RawInput API
dx% = 0 ' = getMouseDx(MouseID%)
x% = x% + dx% ' adjust mouse value by dx
' determine mouse y position
'TODO: get this from RawInput API
dy% = 0 ' = getMouseDy(MouseID%)
y% = y% + dy% ' adjust mouse value by dx
' read mouse buttons
'TODO: get this from RawInput API
leftButton% = FALSE
middleButton% = FALSE
rightButton% = FALSE
' END READ MOUSE THE NEW RawInput WAY:
' =============================================================================
' =============================================================================
' BEGIN READ MOUSE THE OLD QB64 WAY:
'
'' read scroll wheel
'WHILE _MOUSEINPUT ' get latest mouse information
' scrollAmount% = _MOUSEWHEEL ' (Returns -1 when scrolling up and 1 when scrolling down with 0 indicating no movement since last read.)
' IF (scrollAmount% = -1) AND (wheelValue% > wheelMin%) THEN
' wheelValue% = wheelValue% + scrollAmount%
' ELSEIF (scrollAmount% = 1) AND (wheelValue% < wheelMax%) THEN
' wheelValue% = wheelValue% + scrollAmount%
' END IF
'WEND
'
'' determine mouse x position
'x% = _MOUSEX
'
'' determine mouse y position
'y% = _MOUSEY
'
'' read mouse buttons
'leftButton% = _MOUSEBUTTON(1)
'middleButton% = _MOUSEBUTTON(3)
'rightButton% = _MOUSEBUTTON(2)
'
' END READ MOUSE THE OLD QB64 WAY:
' =============================================================================
End Sub ' ReadRawMouse
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END MOUSE FUNCTIONS TO COME
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN ERROR HANDLING HELPER FUNCTIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Sub ErrorClear
m_sError = ""
m_sIncludeError = ""
End Sub ' ErrorClear
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END ERROR HANDLING HELPER FUNCTIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN GENERAL PURPOSE FUNCTIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' /////////////////////////////////////////////////////////////////////////////
' 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%
' /////////////////////////////////////////////////////////////////////////////
' 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$
' /////////////////////////////////////////////////////////////////////////////
' 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
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Program B "MAINPROG.BAS" - this is set to always on top, but Program A "READMICE.BAS" must have the actual focus.
Code: (Select All)
' ################################################################################################################################################################
' Multimouse program B "mainprog.bas" = front end
' ################################################################################################################################################################
' Working proof of concept! (Windows only so far)
' 1. Plug 2 or more USB mice into your computer.
' 2. Run the mouse reader program "readmice.bas"
' 3. Run the front end program "mainprog.bas"
' 4. Drag the windows and make sure they line up, one on top of the other.
' 5. Set the focus to "readmice.bas" (it will be hidden underneath "mainprog", so use the taskbar or ALT+TAB).
' 6. Try moving each mouse. Each one should move a different letter.
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' madscijr - Mini-Mod
' #34
' 09-12-2022, 12:05 PM (This post was last modified: 09-12-2022, 12:07 PM by madscijr.)
' (09-09-2022, 04:27 PM) Spriggsy Wrote:
' >The button catching was working in the example I gave you so you might want to take a look at that mousemessage string. My version displayed the current button being pressed. Here is the relevant link for the RAWMOUSE struct.
' >https://docs.microsoft.com/en-us/windows/win32/api/winuser/ns-winuser-rawmouse
' >You can see the value for each button state listed there.
' >Edit.... Weird. Now it isn't wanting to work on my machine. It was working yesterday just fine.
' >Edit again.... Ah, I wasn't drawing the button information again. I accidentally erased the update. See below and you can try it out. The code does catch the buttons.
'
' Aha, thanks. The mouse button up/down are now being detected and I have it saving the state for left/middle/right clicks (code below).
'
' Now what black magic are we going to have to do, to get this out of the "event driven" code, and working like a regular QB64 program?
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' McNeill - Super Moderator
' #2
' 05-17-2024, 07:27 PM (This post was last modified: 05-17-2024, 07:28 PM by SMcNeill.)
' https://qb64phoenix.com/qb64wiki/index.php/Windows_Libraries#Top_Most_Window
' SMcNeill - Super Moderator
' #11
' 2 hours ago
' Const SWP_NOMOVE = &H0002 'ignores x and y position parameters
' Steffan-68 - Junior Member
' #12
' 2 hours ago
' Do both programs have to be in the same place on the monitor?
' If not, you can change these lines.
' If 0 = SetWindowPos(hWnd, HWND_TOPMOST, 840, 200, 0, 0, SWP_NOSIZE Or SWP_NOACTIVATE) Then
' und
' _ScreenClick 880, 240 ' add 40 to x and y to focus on positioned window
'
' This means that both programs would be next to each other,
' but only the one that is set to foreground remains in the foreground
' and the other one could then fade into the background.
' I don't know what you're trying to do, maybe you could also
' play around with the command (_SCREENICON).
' So that the program that is not in the foreground disappears from the monitor?
' SMcNeill - Super Moderator
' #13
' 2 hours ago
' Sorry. I didn't notice the need for _SCREENCLICK.
' What you're looking for is:
' https://qb64phoenix.com/qb64wiki/index.php/SCREENX
' https://qb64phoenix.com/qb64wiki/index.php/SCREENY
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
Option Explicit
_Title "mainprog"
$NoPrefix
'$Console:Only
'Console Off
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN CONSTANTS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Const cProgName = "mainprog"
Const FALSE = 0
Const TRUE = Not FALSE
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' USED TO CONVERT MOUSE POSITION TO GET SCREEN POSITION
' ScreenPos = MousePos / ScaleValue
' This doesn't really work too accurately!
Const cScaleX = 3
Const cScaleY = 6
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' 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
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' CONSTANT FOR 2ND DIMENSION OF arrFile ARRAY
Const cFileName = 0
Const cFileData = 1
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' CONSTANT FOR WHAT DATA IS EXPECTED FROM THIS LINE IN FILE
Const cUpdateCount = 1
Const cMouseX = 2
Const cMouseY = 3
Const cMouseWheel = 4
Const cMouseLeftDown = 5
Const cMouseMiddleDown = 6
Const cMouseRightDown = 7
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END CONSTANTS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN API DECLARATIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' FOR CONTROLLING WINDOW ON TOP, ETC.
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
Declare Dynamic Library "user32"
Function FindWindowA%& (ByVal lpClassName%&, Byval lpWindowName%&)
Function SetWindowPos& (ByVal hWnd%&, Byval hWndInsertAfter%&, Byval X&, Byval Y&, Byval cx&, Byval cy&, Byval uFlags~&)
Function GetForegroundWindow%&
End Declare
Declare Dynamic Library "kernel32"
Function GetLastError~& ()
End Declare
' UDT TO HOLD THE INFO FOR EACH MOUSE
Type InfoType
ID As String ' player identifier or mouse device ID
char As String ' cursor character
color As Integer ' character color
row As Integer ' line to display values at
UpdateCount As Integer ' if this value changes we know a value changed
OldUpdateCount As Integer ' if this value changes we know a value changed
mouseX As Integer ' mouse x position
mouseY As Integer ' mouse y position
x As Integer ' screen x position
y As Integer ' screen y position
oldX As Integer
oldY As Integer
wheel As Integer ' mouse wheel value
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
LeftCount As Integer ' counts left clicks
MiddleCount As Integer ' counts middle clicks
RightCount As Integer ' counts right clicks
End Type ' InfoType
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' 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)
' GLOBAL VARIABLES TO TRACK ERROR STATE
Dim Shared m_sError As String: m_sError = ""
Dim Shared m_sIncludeError As String: m_sIncludeError = ""
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END GLOBAL VARIABLES
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ****************************************************************************************************************************************************************
' BEGIN DEBUG CONSOLE
' ****************************************************************************************************************************************************************
' ENABLE / DISABLE DEBUG CONSOLE
Dim Shared m_bDebug As Integer: m_bDebug = TRUE
' ACTIVATE DEBUGGING WINDOW
If m_bDebug = TRUE Then
$Console
_Delay 4
_Console On
_Echo "Started " + m_ProgramName$
_Echo "Debugging on..."
End If
' ****************************************************************************************************************************************************************
' END DEBUG CONSOLE
' ****************************************************************************************************************************************************************
' ****************************************************************************************************************************************************************
' DEACTIVATE DEBUGGING WINDOW
If m_bDebug = 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 arrInfo(0 To 8) As InfoType ' STORES INFO FOR EACH MOUSE
'Dim arrRawMouseID(8) As Long ' device IDs for mice connected to system (guessing this would be a string, dunno)
Dim iMouseCount As Integer ' # OF MICE ATTACHED
'Dim arrScreen(1 To 80, 1 To 25) As String ' STORES TEXT FOR SCREEN
Dim iMinX As Long
Dim iMaxX As Long
Dim iMinY As Long
Dim iMaxY As Long
' RAW FILE NAMES
Dim arrFile(0 To 31, 0 To 1) As String
' WINDOW VARIABLES
Dim hWndThis As _Offset ' hWndThis%&
Dim hWndTop As _Offset ' x%&
' OTHER VARS
Dim iLoop 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 arrColor(0 To 31) As Integer
Dim in$
' =============================================================================
' SET ERROR TRAPPING
On Error GoTo ErrorHandler
' =============================================================================
' MOVE WINDOW TO TOP
' GET WINDOW HANDLES
hWndThis = _WindowHandle ' FindWindowA(0, _OFFSET(t))
hWndTop = GetForegroundWindow%& ' find currently focused process handle
' GET FOCUS
If hWndThis <> hWndTop Then
_ScreenClick 240, 240 ' add 40 to x and y to focus on positioned window
End If
' MOVE TO TOP
If SetWindowPos(hWndThis, HWND_TOPMOST, 200, 200, 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
' =============================================================================
' INIT SCREEN
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.
'Screen _NewImage(1024, 768, 32)
' window needs to be lined up directly under the main program, so the mouse coordinates align with the display
_ScreenMove 0, 0
'_SCREENMOVE _MIDDLE
Cls , cBlack
' =============================================================================
' MAIN LOOP
Do
' PRINT MESSAGE
iRow = 1: iCol = 1
Color cLtRed, cBlack
PrintString1 iRow, iCol, "*** MAKE SURE PROGRAM READMICE HAS THE FOCUS ***"
iRow = 2: iCol = 1
Color cCyan, cBlack
PrintString1 iRow, iCol, "Plug in 2 or more USB mice and move them around over the window."
' PROCESS EACH USER'S INPUT
For iIndex = LBound(arrInfo) To UBound(arrInfo)
DebugPrint "READ INPUT #" + _Trim$(Str$(iIndex))
DebugPrint " FILENAME " + Chr$(34) + arrFile(iIndex, cFileName) + Chr$(34)
' -----------------------------------------------------------------------------
' DISPLAY VALUES TO NEXT ROW
iRow = arrInfo(iIndex).row: iCol = 1
Color arrInfo(iIndex).color, cBlack
PrintString1 iRow, iCol, arrInfo(iIndex).char + " ": iCol = iCol + 9
' -----------------------------------------------------------------------------
' REDRAW AND SAVE OLD COORDINATES
If arrInfo(iIndex).oldX <> arrInfo(iIndex).x Or arrInfo(iIndex).oldY <> arrInfo(iIndex).y Then
PrintString1 arrInfo(iIndex).oldY, arrInfo(iIndex).oldX, " "
PrintString1 arrInfo(iIndex).y, arrInfo(iIndex).x, arrInfo(iIndex).char
arrInfo(iIndex).oldY = arrInfo(iIndex).y
arrInfo(iIndex).oldX = arrInfo(iIndex).x
End If
If Len(m_sError) > 0 Then
' (OUTPUT ERROR TO LOG HERE)
'cls
'color cLtRed, cBlack
'print m_sError
''PrintString1 1,1, m_sError
'input "PRESS ENTER TO CONTINUE"; in$
ErrorClear
End If
' -----------------------------------------------------------------------------
' READ MICE COORDINATES FROM FILE...
' FOUND FILE?
If _FileExists(arrFile(iIndex, cFileName)) = TRUE Then
DebugPrint " FILE FOUND"
' OPEN FILE
Open arrFile(iIndex, cFileName) For Input As #1
' DID IT WORK?
If Len(m_sError) = 0 Then
DebugPrint " FILE OPENED"
' READ EACH LINE
iLineNum = 0
While Not EOF(1)
If Len(m_sError) = 0 Then
' TRACK WHAT LINE # WE'RE ON
iLineNum = iLineNum + 1
DebugPrint " READ LINE #" + _Trim$(Str$(iLineNum))
' READ LINE
Line Input #1, sLine ' read entire text file line
' IS IT A VALID INTEGER?
If IsNumber%(sLine) Then
' DETERMINE WHICH VALUE IT IS FROM ORDINAL POSITION (LINE #) IN FILE
' AND SAVE TO APPROPRIATE VARIABLE
Select Case iLineNum
Case cUpdateCount
' THIS VALUE TELLS US IF THERE IS NEW INPUT
arrInfo(iIndex).UpdateCount = Val(sLine)
Case cMouseX:
' READ RAW VALUE
arrInfo(iIndex).mouseX = Val(sLine)
'' SCALE MOUSE POSITION TO SCREEN POSITION
'' ScreenPos = MousePos / ScaleValue
'arrInfo(iIndex).x = arrInfo(iIndex).mouseX / cScaleX
' ADJUST COORDINATES BASED ON MOVEMENT
arrInfo(iIndex).x = arrInfo(iIndex).x + arrInfo(iIndex).mouseX
' CHECK BOUNDARIES
If arrInfo(iIndex).x < iMinX Then
arrInfo(iIndex).x = iMinX
ElseIf arrInfo(iIndex).x > iMaxX Then
arrInfo(iIndex).x = iMaxX
End If
' DISPLAY VALUES
PrintString1 iRow, iCol, sLine + " ": iCol = iCol + 9
Case Else:
' Unknown
End Select
End If
If Len(m_sError) <> 0 Then
DebugPrint " ERROR AT Line Input #1: " + m_sError
' SOME OTHER ERROR HAPPENED
' (OUTPUT ERROR TO LOG HERE)
ErrorClear
End If
Else
DebugPrint " ERROR AT While Not EOF(1): " + m_sError
' ERROR READING LINE...
' (OUTPUT ERROR TO LOG HERE)
ErrorClear
End If
' EXIT IF VALUES HAVEN'T CHANGED
If arrInfo(iIndex).UpdateCount = arrInfo(iIndex).OldUpdateCount Then
' STOP THE MOUSE DX / DY
arrInfo(iIndex).mouseY = 0
arrInfo(iIndex).mouseX = 0
' WE CAN STOP READING THE FILE
Exit While
End If
Wend
Close #1
' UPDATE OLD VALUE FOR NEXT CHANGE TEST
If arrInfo(iIndex).UpdateCount <> arrInfo(iIndex).OldUpdateCount Then
arrInfo(iIndex).OldUpdateCount = arrInfo(iIndex).UpdateCount
End If
' (OUTPUT ERROR TO LOG HERE)
'color cLtRed, cBlack
'PrintString1 1, 1, "Error opening file " + chr$(34) + arrFile(iIndex, cFileName) + chr$(34)
'PrintString1 1, 1, m_sError
ErrorClear
End If
Else
DebugPrint " FILE NOT FOUND"
' FILE NOT FOUND
' JUST IGNORE
'' DEBUG OUTPUT:
'color cLtRed, cBlack
''PrintString1 1,1, m_sError
''Print "File not found: " + chr$(34) + arrFile(iIndex, cFileName) + chr$(34)
'PrintString1 1, 1, "File not found: " + chr$(34) + arrFile(iIndex, cFileName) + chr$(34)
End If
' -----------------------------------------------------------------------------
' GET KEYBOARD INPUT
While _DeviceInput(1): Wend ' clear and update the keyboard buffer
If _KeyDown(27) Then
DebugPrint "DETECTED ESC = _KeyDown(27) = EXITING"
Exit Do ' leave loop when ESC key pressed
End If
Next iIndex
_Limit 60 ' run 60 fps
Loop
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
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN GRAPHIC PRINTING ROUTINES
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' /////////////////////////////////////////////////////////////////////////////
' 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: PrintString0
Sub PrintString1g (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 ' PrintString1g
' /////////////////////////////////////////////////////////////////////////////
' Prints a string at the specified row+column.
' iRow and iCol are 1-based.
' See also: PrintString0
Sub PrintString1 (iRow As Integer, iCol As Integer, MyString As String)
Locate iRow, iCol
Print 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 GENERAL PURPOSE FUNCTIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' /////////////////////////////////////////////////////////////////////////////
' 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%
' /////////////////////////////////////////////////////////////////////////////
' 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$
' /////////////////////////////////////////////////////////////////////////////
' 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 m_bDebug = 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 m_bDebug = TRUE Then
_Echo s$
End If
End Sub ' DebugPrint1
' ################################################################################################################################################################
' END DEBUGGING ROUTINES @DEBUG
' ################################################################################################################################################################
I'm close to having a new game ready for the Works in Progress thread. Level 1 is done! Today though I was working on the cleanUp sub and am having a couple issues. One font that I'm trying to free is crashing the prog with an illegal function message. The sub closes four other fonts that are similarly dimmed and loaded no problem, but not this one. Also in trying to _freeimage one particular array of hardware images, same deal. It closes other image arrays just fine, but not this one. Anything I should be looking for?
The indexing of the arrays is right, so that's not an issue. Freeing them one at a time or in a loop to ubound gives the same error. I'm now a fairly flummoxed ape... Thanks for any help offered.
One other thing, the wiki claims that all loaded sounds are freed upon prog termination, though I see some of us are closing out sounds on wrap up. Is it necessary to close sounds or not? Thnx.
EDIT: Nevermind about the FREEFONT issue. I realized I forgot to switch to a system font before attempting ti free em.
Does anyone know how to do this in native QB64PE?
It would be useful to get all the file attributes, but last modified date/time and size in bytes is what I'm looking for right now.
Native QB64 would be best but I'll take whatever method is most reliable and cross-platform if possible.
Any help much appreciated...
I forgot to include the correct paths in all the source code that deals with pixel collisions.
I had to update the tutorial asset file again. If you downloaded it recently download it again. Sorry, I should have caught that before I published the new content.
Steve's recent keyword of the day post about $INCLUDEONCE ( https://qb64phoenix.com/forum/showthread.php?tid=2685 ) got me working on updating lesson 20 discussing libraries. After a few hours of ham-fisting this new metacommand in I realized I needed to completely abandon the current lesson and rewrite it from scratch.
So over the past 5 days (that's why I've been scarce on the forum) I rewrote the entire lesson and all of the code and libraries associated with it. Lesson 20 now guides the reader through the process of taking individual code snippets and turning them into a full library. $INCLUDEONCE has been added to explain how to incorporate its functionality as well (which is awesome by the way).
The tutorial asset file has been updated to include all of the new code and libraries associated with lesson 20.
I also added a FAQ link in the top bar menu for frequently asked questions I receive.
I left 2 instances of the QB64PE IDE (v3.10.0 - guess I'm due for an update!)
open with the program A and program B code listed here,
and when I opend my PC today, saw 2 alert boxes open saying "gluBuild2DMipmaps failed.png: 1285".
Clicking OK on either of them just re-opens the popup, and I ended up having to kill QB64PE to make them go away.
Does anyone recognize this error message as indicating something specific, that might help track down the cause?
QB64.ORG Forums
<-- After only one or two... okies... maybe ten or twenty.... or a few more than that even... months since the old QB64.ORG Forums were burnt down and shuttered for good, I *cough* *cough* FINALLY put together an offline version for everyone who might want to keep a personal backup of all that information. Grab the archive via the link to the top left, but be aware of the size of everything you're getting here!!
The *compressed* file is almost 2GB in size.
Uncompressed, this comes in at around 10GB, give or take a bit.
This is.... EVERYTHING that was on the old forums, before they were deleted. For ages now, Luke has been so kind as to host a mirror of these forums for everyone, and that mirror is still up and available for folks at: https://qb64forum.alephc.xyz/index.php
So, I can hear some of you guys asking, "So why would anyone want to grab a 2GB archive of that set of forums, if they're already up on the web??"
I dunno! I guess that'd be up to each person to answer for themselves. Maybe someone just wants an offline version so they'll always have all these old posts, samples, and discussions. Maybe someone wants to convert all this information over to a different format -- PDF, EPUB, CHM, whatever!
I'm just offering the OPTION here to make it easy for folks who want a copy -- for whatever reason -- to be able to just grab it and enjoy it. No one has to grab a copy of this. I don't imagine that Luke's mirror is going to go anywhere , anytime soon. It's just here now, for those who might want it for themselves, for whatever reason.
NOTE that this is too large for the forums to handle, so this is stored on my OneDrive account. Don't be surprised if you get redirected and have to click, "Yes, I really do want to download this.", depending on your browser and security settings and whatnot.
![[Image: diy-optical-mouse-racing-wheel-1.png]](https://i.ibb.co/qn6bTqc/diy-optical-mouse-racing-wheel-1.png)
![[Image: diy-optical-mouse-racing-wheel-2.png]](https://i.ibb.co/k6J683j/diy-optical-mouse-racing-wheel-2.png)
