Posts: 730
Threads: 30
Joined: Apr 2022
Reputation:
43
WindowHandle does indeed return the handle to the QB64 window and should work just fine. I'll look at this more this weekend and get back to you as soon as I can.
Happy coding!
Tread on those who tread on you
Posts: 733
Threads: 103
Joined: Apr 2022
Reputation:
14
09-09-2022, 07:45 PM
(This post was last modified: 09-09-2022, 08:07 PM by madscijr.)
(09-08-2022, 10:21 PM)Spriggsy Wrote: WindowHandle does indeed return the handle to the QB64 window and should work just fine. I'll look at this more this weekend and get back to you as soon as I can.
Happy coding!
I hacked your code for a working proof of concept -
I have 3 mice plugged in and am able to move 3 different objects at the same time, independently!
Some issues and things to fix - detect mouse button clicks (left, middle, right buttons)
- detect moving the scroll wheel
- rework code from event-driven to linear (ie call a routine to get the latest coordinates / button states / scroll wheel for mouse n)
- 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
Anyway, give it a try.
It's A L I V E ! ! ! ! !!
Code: (Select All) ' ################################################################################################################################################################
' Multimouse
' ################################################################################################################################################################
' Working proof of concept! (Windows only so far)
' Plug in 2 or more USB mice and try moving them around
' -------------------------------------------------------------------------------
' TO DO
' -------------------------------------------------------------------------------
' Some issues and things to fix:
' * detect mouse button clicks (left, middle, right buttons)
' * detect moving the scroll wheel
' * rework code from event-driven to linear (ie call a routine to get the
' latest coordinates / button states / scroll wheel for mouse n)
' * 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.
Option Explicit
_Title "multimouse"
$NoPrefix
$Console:Only
Console Off
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN CONSTANTS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Const FALSE = 0
Const TRUE = Not FALSE
Const CS_HREDRAW = &H0002
Const CS_VREDRAW = &H0001
Const IDI_APPLICATION = 32512
Const IDC_ARROW = 32512
Const COLOR_WINDOW = 5
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
Const MOUSE_MOVE_RELATIVE = &H00
Const MOUSE_MOVE_ABSOLUTE = &H01
Const MOUSE_VIRTUAL_DESKTOP = &H02
Const MOUSE_ATTRIBUTES_CHANGED = &H04
Const MOUSE_MOVE_NOCOALESCE = &H08
Const WM_MOUSEMOVE = &H0200
Const WM_PAINT = &H000F
Const DT_CENTER = &H00000001
' MIN/MAX VALUES FOR MOUSE TEST
Const cMinX = 2
Const cMaxX = 79
Const cMinY = 16
Const cMaxY = 24
Const cMinWheel = 0
Const cMaxWheel = 255
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' 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 InfoType
ID As String ' mouse device ID
c As String ' cursor character
x As Integer ' screen x position
y As Integer ' screen y position
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 UDTs
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN API DECLARATIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
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
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ENABLE / DISABLE DEBUG CONSOLE
Dim Shared m_bDebug As Integer: m_bDebug = FALSE
' 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)
' RAW INPUT VARIABLES
Dim Shared mousemessage As String
Dim Shared rawinputdevices As String
' MOUSE TEST VARIABLES
Dim Shared arrInfo(8) As InfoType ' 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
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
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END GLOBAL VARIABLES
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ****************************************************************************************************************************************************************
' BEGIN ACTIVATE DEBUGGING WINDOW
' ****************************************************************************************************************************************************************
'If m_bDebug = TRUE Then
' $Console
' _Delay 4
' _Console On
' _Echo "Started " + m_ProgramName$
' _Echo "Debugging on..."
'End If
' ****************************************************************************************************************************************************************
' END ACTIVATE DEBUGGING WINDOW
' ****************************************************************************************************************************************************************
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' EXECUTION STARTS HERE!
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
iMinX = 0
iMaxX = 3583
iMinY = 0
iMaxY = 8202
System Val(Str$(WinMain))
' ****************************************************************************************************************************************************************
' BEGIN DEACTIVATE DEBUGGING WINDOW
' ****************************************************************************************************************************************************************
'If m_bDebug = TRUE Then
' _Console Off
'End If
' ****************************************************************************************************************************************************************
' END DEACTIVATE DEBUGGING WINDOW
' ****************************************************************************************************************************************************************
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN CLEANUP + FINISH
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
System ' return control to the operating system
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END CLEANUP + FINISH
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN DATA
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' 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
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' 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
hInst = GetModuleHandle(0)
szMainWndClass = "WinTestWin" + Chr$(0)
szWinTitle = "Hello" + Chr$(0)
wndclass.lpszClassName = Offset(szMainWndClass)
wndclass.cbSize = Len(wndclass)
wndclass.style = CS_HREDRAW Or CS_VREDRAW
wndclass.lpfnWndProc = WindowProc
wndclass.hInstance = hInst 'GetModuleHandle(0) will return the hInstance of this EXE
wndclass.hIcon = LoadIcon(0, MAKEINTRESOURCE(IDI_APPLICATION))
wndclass.hIconSm = LoadIcon(0, MAKEINTRESOURCE(IDI_APPLICATION))
wndclass.hCursor = LoadCursor(0, MAKEINTRESOURCE(IDC_ARROW))
wndclass.hbrBackground = COLOR_WINDOW + 1
reg = RegisterClassEx(Offset(wndclass)) 'I prefer to use the output of RegisterClassEx rather than the window name
'DEBUG: SUBSTITUTE _WindowHandle
hwndMain = CreateWindowEx(0, MAKELPARAM(reg, 0), Offset(szWinTitle), WS_OVERLAPPEDWINDOW, CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, 0, 0, hInst, 0)
'hwndMain = _WindowHandle
'DEBUG: SUBSTITUTE _WindowHandle
ShowWindow hwndMain, SW_SHOW
'ShowWindow _WindowHandle, SW_SHOW
'DEBUG: SUBSTITUTE _WindowHandle
UpdateWindow hwndMain
'UpdateWindow _WindowHandle
InitRawInput
InitMouseTest 'TODO: SAVE_MOUSE_INFO
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
' 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!"
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
'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(arrInfo) Then
If iIndex <= UBound(arrInfo) Then
' =============================================================================
' UPDATE ABSOLUTE POSITION
' 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)
'arrInfo(iIndex).x = iNewX
'arrInfo(iIndex).y = iNewY
' WORKS BUT NOT THAT ACCURATE:
' METHOD #2: INCREMENT/DECREMENT DELTA
If raw.mouse.lLastX < 0 Then
arrInfo(iIndex).x = arrInfo(iIndex).x - 1
ElseIf raw.mouse.lLastX > 0 Then
arrInfo(iIndex).x = arrInfo(iIndex).x + 1
End If
If raw.mouse.lLastY < 0 Then
arrInfo(iIndex).y = arrInfo(iIndex).y - 1
ElseIf raw.mouse.lLastY > 0 Then
arrInfo(iIndex).y = arrInfo(iIndex).y + 1
End If
' =============================================================================
'TODO: SAVE SCROLL WHEEL + BUTTONS
'arrInfo(iIndex).wheel =
'arrInfo(iIndex).LeftDown =
'arrInfo(iIndex).MiddleDown =
'arrInfo(iIndex).RightDown =
End If
End If
' ================================================================================================================================================================
' BEGIN DRAW PLAYING FIELD
' ================================================================================================================================================================
ClearText
WriteText 1, 1, "1. PLUG 1-8 MICE INTO THE COMPUTER"
WriteText 2, 1, "2. USE MICE TO POSITION LETTERS ON SCREEN"
WriteText 3, 1, "3. PRESS <ESC> TO QUIT"
WriteText 4, 1, "--------------------------------------------------------------------------------"
WriteText 5, 1, "# X Y Wheel LeftDown MiddleDown RightDown LeftCount MiddleCount RightCount "
WriteText 6, 1, "--------------------------------------------------------------------------------"
' NOTE: LEAVE THE NEXT 8 LINES FREE (ROWS 8-15)
' TO DISPLAY TEST VALUES FOR UPTO 8 MICE
' DRAW BORDER AROUND PLAYING FIELD
DrawTextLine cMinX - 1, cMinY - 1, cMinX - 1, cMaxY + 1, "#"
DrawTextLine cMinX - 1, cMinY - 1, cMaxX + 1, cMinY - 1, "#"
DrawTextLine cMaxX + 1, cMaxY + 1, cMaxX + 1, cMinY - 1, "#"
DrawTextLine cMaxX + 1, cMaxY + 1, cMinX - 1, cMaxY + 1, "#"
' GET INPUT AND MOVE PLAYERS
iRowOffset = 0
For iIndex = LBound(arrInfo) To UBound(arrInfo)
' CHECK BOUNDARIES
If arrInfo(iIndex).x < cMinX Then arrInfo(iIndex).x = cMinX
If arrInfo(iIndex).x > cMaxX Then arrInfo(iIndex).x = cMaxX
If arrInfo(iIndex).y < cMinY Then arrInfo(iIndex).y = cMinY
If arrInfo(iIndex).y > cMaxY Then arrInfo(iIndex).y = cMaxY
' PLOT CURSOR
WriteText arrInfo(iIndex).y, arrInfo(iIndex).x, arrInfo(iIndex).c
' DISPLAY VARIABLES
iLen = 3: sCount = Left$(LTrim$(RTrim$(Str$(iRowOffset + 1))) + String$(iLen, " "), iLen)
iLen = 3: sX = Left$(LTrim$(RTrim$(Str$(arrInfo(iIndex).x))) + String$(iLen, " "), iLen)
iLen = 3: sY = Left$(LTrim$(RTrim$(Str$(arrInfo(iIndex).y))) + String$(iLen, " "), iLen)
iLen = 6: sWheel = Left$(LTrim$(RTrim$(Str$(arrInfo(iIndex).wheel))) + String$(iLen, " "), iLen)
iLen = 9: sLeftDown = Left$(LTrim$(RTrim$(Str$(arrInfo(iIndex).LeftDown))) + String$(iLen, " "), iLen)
iLen = 11: sMiddleDown = Left$(LTrim$(RTrim$(Str$(arrInfo(iIndex).MiddleDown))) + String$(iLen, " "), iLen)
iLen = 10: sRightDown = Left$(LTrim$(RTrim$(Str$(arrInfo(iIndex).RightDown))) + String$(iLen, " "), iLen)
iLen = 10: sLeftCount = Left$(LTrim$(RTrim$(Str$(arrInfo(iIndex).LeftCount))) + String$(iLen, " "), iLen)
iLen = 12: sMiddleCount = Left$(LTrim$(RTrim$(Str$(arrInfo(iIndex).MiddleCount))) + String$(iLen, " "), iLen)
iLen = 11: sRightCount = Left$(LTrim$(RTrim$(Str$(arrInfo(iIndex).RightCount))) + String$(iLen, " "), iLen)
'sNext = sCount + sX + sY + sWheel + sLeftDown + sMiddleDown + sRightDown + sLeftCount + sMiddleCount + sRightCount
WriteText 6 + iRowOffset, 1, sCount + sX + sY + sWheel + sLeftDown + sMiddleDown + sRightDown + sLeftCount + sMiddleCount + sRightCount
iRowOffset = iRowOffset + 1
Next iIndex
' UPDATE mousemessage WITH PLAYING FIELD
mousemessage = ScreenToString$
' ================================================================================================================================================================
' END DRAW PLAYING FIELD
' ================================================================================================================================================================
End If
MemFree lpb
MainWndProc = 0
Exit Function
Case WM_MOUSEMOVE
'mousemessage = mousemessage + "X:" + Str$(GET_X_LPARAM(lParam))
'mousemessage = mousemessage + " Y:" + Str$(GET_Y_LPARAM(lParam))
'mousemessage = mousemessage + Chr$(0)
' SAVE 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(arrInfo) Then
If iIndex <= UBound(arrInfo) Then
' =============================================================================
' UPDATE ABSOLUTE POSITION
' DOESN'T WORK, MOVES ALL OVER THE PLACE:
'' METHOD #1: SCALE MOUSE POSITION TO 80X25 POSITION
''iNewX = ( (GET_X_LPARAM(lParam) + 1) * 80) \ 1520
'iNewX = ( (GET_X_LPARAM(lParam) + 1) * 80) \ (iMaxX+1)
''iNewY = ( (GET_Y_LPARAM(lParam) + 1) * 25) \ 782
'iNewY = ( (GET_Y_LPARAM(lParam) + 1) * 25) \ (iMaxY+1)
'arrInfo(iIndex).x = iNewX
'arrInfo(iIndex).y = iNewY
' 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?)
'arrInfo(iIndex).wheel =
'arrInfo(iIndex).LeftDown =
'arrInfo(iIndex).MiddleDown =
'arrInfo(iIndex).RightDown =
End If
End If
'DEBUG: SUBSTITUTE _WindowHandle
InvalidateRect hwnd, 0, -1
'InvalidateRect _WindowHandle, 0, -1
'DEBUG: SUBSTITUTE _WindowHandle
SendMessage hwnd, WM_PAINT, 0, 0
'SendMessage _WindowHandle, WM_PAINT, 0, 0
MainWndProc = 0
Exit Function
Case WM_PAINT
'DEBUG: SUBSTITUTE _WindowHandle
hdc = BeginPaint(hwnd, Offset(ps))
'hdc = BeginPaint(_WindowHandle, Offset(ps))
'DEBUG: SUBSTITUTE _WindowHandle
GetClientRect hwnd, Offset(rc)
'GetClientRect _WindowHandle, Offset(rc)
DrawText hdc, Offset(mousemessage), Len(mousemessage), Offset(rc), DT_CENTER
OffsetRect Offset(rc), 0, 200
'' PRINT LIST OF RawInput DEVICES:
'DrawText hdc, Offset(rawinputdevices), Len(rawinputdevices), Offset(rc), DT_CENTER
'DEBUG: SUBSTITUTE _WindowHandle
EndPaint hwnd, Offset(ps)
'EndPaint _WindowHandle, Offset(ps)
MainWndProc = 0
Exit Function
Case Else
'DEBUG: SUBSTITUTE _WindowHandle
MainWndProc = DefWindowProc(hwnd, nMsg, wParam, lParam)
'MainWndProc = DefWindowProc(_WindowHandle, nMsg, wParam, lParam)
End Select
End Function ' MainWndProc
' /////////////////////////////////////////////////////////////////////////////
' Initializes raw input stuff
Sub InitRawInput ()
Dim As RAWINPUTDEVICE Rid(0 To 49)
Dim As Unsigned Long nDevices
Dim As RAWINPUTDEVICELIST RawInputDeviceList
Dim As MEM pRawInputDeviceList
ReDim As RAWINPUTDEVICELIST rawdevs(-1)
Dim As Unsigned Long x
Dim strNextID As String
'dim lngNextID as long
If GetRawInputDeviceList(0, Offset(nDevices), Len(RawInputDeviceList)) <> 0 Then
Exit Sub
End If
pRawInputDeviceList = MemNew(Len(RawInputDeviceList) * nDevices)
GetRawInputDeviceList pRawInputDeviceList.OFFSET, Offset(nDevices), Len(RawInputDeviceList)
' 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 INFO
iMouseCount = 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)
' Is it a mouse?
'TODO: SAVE_MOUSE_INFO
If rawdevs(x).dwType = 0 Then
iMouseCount = iMouseCount + 1
strNextID = _Trim$(Str$(rawdevs(x).hDevice))
'lngNextID = Val(strNextID)
'arrInfo(iMouseCount-1).ID = lngNextID
arrInfo(iMouseCount - 1).ID = strNextID
End If
Next x
rawinputdevices = rawinputdevices + Chr$(0)
MemFree pRawInputDeviceList
Rid(0).usUsagePage = &H01
Rid(0).usUsage = &H02
Rid(0).dwFlags = 0
'DEBUG: SUBSTITUTE _WindowHandle
Rid(0).hwndTarget = 0
'Rid(0).hwndTarget = _WindowHandle
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 CURSORS, MOUSE STATE, ETC.
Restore CData
iIndex = LBound(arrInfo) - 1
For iLoop = 1 To iMouseCount
iIndex = iIndex + 1
Read arrInfo(iIndex).c
' INITIALIZED BELOW: arrInfo(iIndex).x = 0
' INITIALIZED BELOW: arrInfo(iIndex).y = 0
' INITIALIZED BELOW: arrInfo(iIndex).wheel = 127
arrInfo(iIndex).LeftDown = FALSE
arrInfo(iIndex).MiddleDown = FALSE
arrInfo(iIndex).RightDown = FALSE
arrInfo(iIndex).LeftCount = 0
arrInfo(iIndex).MiddleCount = 0
arrInfo(iIndex).RightCount = 0
Next iLoop
' INITIALIZE X COORDINATES
Restore XData
iIndex = LBound(arrInfo) - 1
For iLoop = 1 To iMouseCount
iIndex = iIndex + 1
Read arrInfo(iIndex).x
Next iLoop
' INITIALIZE Y COORDINATES
Restore YData
iIndex = LBound(arrInfo) - 1
For iLoop = 1 To iMouseCount
iIndex = iIndex + 1
Read arrInfo(iIndex).y
Next iLoop
' INITIALIZE SCROLL WHEEL
Restore WData
iIndex = LBound(arrInfo) - 1
For iLoop = 1 To iMouseCount
iIndex = iIndex + 1
Read arrInfo(iIndex).wheel
Next iLoop
End Sub ' InitMouseTest
' /////////////////////////////////////////////////////////////////////////////
' Finds position in array arrInfo where .ID = MouseID
Function GetMouseIndex% (MouseID As String)
Dim iLoop As Integer
Dim iIndex%
iIndex% = LBound(arrInfo) - 1
For iLoop = LBound(arrInfo) To UBound(arrInfo)
If arrInfo(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
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' /////////////////////////////////////////////////////////////////////////////
' 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
While e% >= 0
y% = y% + sy%: e% = e% - 2 * dx%
Wend
x% = x% + sx%: e% = e% + 2 * dy%
Next
''PSET (x2%, y2%), c%
'Locate x2%, y2% : Print c$;
WriteText x2%, y2%, c$
End Sub ' DrawTextLine
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END TEST OUTPUT FUNCTIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' 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
'arrInfo(iLoop).ID = 0
arrInfo(iLoop).ID = ""
Next iLoop
' GET IDs
'TODO: get this from RawInput API
''arrRawMouseID(1) = 1 ' for now just fudge it!
'arrInfo(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 GENERAL PURPOSE FUNCTIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' /////////////////////////////////////////////////////////////////////////////
' 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 #DEBUGGING
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'' /////////////////////////////////////////////////////////////////////////////
'
'Sub DebugPrint (MyString As String)
' If m_bDebug = TRUE Then
' '_Echo MyString
' 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
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END DEBUGGING ROUTINES @DEBUGGING
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ################################################################################################################################################################
' #REFERENCE
' =============================================================================
' SOME USEFUL STUFF FOR REFERENCE:
' Type Name Type suffix symbol Minimum value Maximum value Size in Bytes
' --------------------- ------------------ ---------------------------- -------------------------- -------------
' _BIT ` -1 0 1/8
' _BIT * n `n -128 127 n/8
' _UNSIGNED _BIT ~` 0 1 1/8
' _BYTE %% -128 127 1
' _UNSIGNED _BYTE ~%% 0 255 1
' INTEGER % -32,768 32,767 2
' _UNSIGNED INTEGER ~% 0 65,535 2
' LONG & -2,147,483,648 2,147,483,647 4
' _UNSIGNED LONG ~& 0 4,294,967,295 4
' _INTEGER64 && -9,223,372,036,854,775,808 9,223,372,036,854,775,807 8
' _UNSIGNED _INTEGER64 ~&& 0 18,446,744,073,709,551,615 8
' SINGLE ! or none -2.802597E-45 +3.402823E+38 4
' DOUBLE # -4.490656458412465E-324 +1.797693134862310E+308 8
' _FLOAT ## -1.18E-4932 +1.18E+4932 32(10 used)
' _OFFSET %& -9,223,372,036,854,775,808 9,223,372,036,854,775,807 Use LEN
' _UNSIGNED _OFFSET ~%& 0 18,446,744,073,709,551,615 Use LEN
' _MEM none combined memory variable type N/A Use LEN
' div: int1% = num1% \ den1%
' mod: rem1% = num1% MOD den1%
' @END
Posts: 730
Threads: 30
Joined: Apr 2022
Reputation:
43
09-09-2022, 08:27 PM
(This post was last modified: 09-09-2022, 08:30 PM by SpriggsySpriggs.)
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...r-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.
Code: (Select All) Option Explicit
$NoPrefix
$Console:Only
Console Off
Const CS_HREDRAW = &H0002
Const CS_VREDRAW = &H0001
Const IDI_APPLICATION = 32512
Const IDC_ARROW = 32512
Const COLOR_WINDOW = 5
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
Const MOUSE_MOVE_RELATIVE = &H00
Const MOUSE_MOVE_ABSOLUTE = &H01
Const MOUSE_VIRTUAL_DESKTOP = &H02
Const MOUSE_ATTRIBUTES_CHANGED = &H04
Const MOUSE_MOVE_NOCOALESCE = &H08
Const WM_MOUSEMOVE = &H0200
Const WM_PAINT = &H000F
Const DT_CENTER = &H00000001
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
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
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
Declare Library "winproc"
Function WindowProc%& ()
End Declare
Dim Shared As String mousemessage, rawinputdevices
System Val(Str$(WinMain))
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
Select Case nMsg
Case WM_DESTROY
PostQuitMessage 0
MainWndProc = 0
Exit Function
Case WM_INPUT
Dim As RAWINPUTHEADER rih
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!"
End If
MemGet lpb, lpb.OFFSET, raw
If raw.header.dwType = RIM_TYPEMOUSE Then
tmpx = raw.mouse.lLastX
tmpy = raw.mouse.lLastY
maxx = tmpx
mousemessage = "Mouse:hDevice" + Str$(raw.header.hDevice) + " usFlags=" + Hex$(raw.mouse.usFlags)
mousemessage = mousemessage + " ulButtons=" + Hex$(MAKELONG(raw.mouse.usButtonFlags, raw.mouse.usFlags))
mousemessage = mousemessage + " usButtonFlags=" + Hex$(raw.mouse.usButtonFlags) + " usButtonData=" + Hex$(raw.mouse.usButtonData)
mousemessage = mousemessage + " ulRawButtons=" + Hex$(raw.mouse.ulRawButtons) + " lLastX=" + Str$(raw.mouse.lLastX)
mousemessage = mousemessage + " lLastY=" + Str$(raw.mouse.lLastY) + " ulExtraInformation=" + Hex$(raw.mouse.ulExtraInformation) + Chr$(13)
InvalidateRect hwnd, 0, -1
SendMessage hwnd, WM_PAINT, 0, 0
MainWndProc = 0
End If
MemFree lpb
MainWndProc = 0
Exit Function
Case WM_MOUSEMOVE
mousemessage = mousemessage + "X:" + Str$(GET_X_LPARAM(lParam))
mousemessage = mousemessage + " Y:" + Str$(GET_Y_LPARAM(lParam))
mousemessage = mousemessage + Chr$(0)
InvalidateRect hwnd, 0, -1
SendMessage hwnd, WM_PAINT, 0, 0
MainWndProc = 0
Exit Function
Case WM_PAINT
hdc = BeginPaint(hwnd, Offset(ps))
GetClientRect hwnd, Offset(rc)
DrawText hdc, Offset(mousemessage), Len(mousemessage), Offset(rc), DT_CENTER
OffsetRect Offset(rc), 0, 200
DrawText hdc, Offset(rawinputdevices), Len(rawinputdevices), Offset(rc), DT_CENTER
EndPaint hwnd, Offset(ps)
MainWndProc = 0
Exit Function
Case Else
MainWndProc = DefWindowProc(hwnd, nMsg, wParam, lParam)
End Select
End Function
Function WinMain~%& ()
Dim As Offset hwndMain, hInst: hInst = GetModuleHandle(0)
Dim As MSG msg
Dim As WNDCLASSEX wndclass
Dim As String szMainWndClass: szMainWndClass = "WinTestWin" + Chr$(0)
Dim As String szWinTitle: szWinTitle = "Hello" + Chr$(0)
wndclass.lpszClassName = Offset(szMainWndClass)
wndclass.cbSize = Len(wndclass)
wndclass.style = CS_HREDRAW Or CS_VREDRAW
wndclass.lpfnWndProc = WindowProc
wndclass.hInstance = hInst 'GetModuleHandle(0) will return the hInstance of this EXE
wndclass.hIcon = LoadIcon(0, MAKEINTRESOURCE(IDI_APPLICATION))
wndclass.hIconSm = LoadIcon(0, MAKEINTRESOURCE(IDI_APPLICATION))
wndclass.hCursor = LoadCursor(0, MAKEINTRESOURCE(IDC_ARROW))
wndclass.hbrBackground = COLOR_WINDOW + 1
Dim As Unsigned Integer reg: reg = RegisterClassEx(Offset(wndclass)) 'I prefer to use the output of RegisterClassEx rather than the window name
hwndMain = CreateWindowEx(0, MAKELPARAM(reg, 0), Offset(szWinTitle), WS_OVERLAPPEDWINDOW, CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, 0, 0, hInst, 0)
ShowWindow hwndMain, SW_SHOW
UpdateWindow hwndMain
InitRawInput
While GetMessage(Offset(msg), 0, 0, 0)
TranslateMessage Offset(msg)
DispatchMessage Offset(msg)
Wend
WinMain = msg.wParam
End Function
Sub InitRawInput ()
Dim As RAWINPUTDEVICE Rid(0 To 49)
Dim As Unsigned Long nDevices
Dim As RAWINPUTDEVICELIST RawInputDeviceList
If GetRawInputDeviceList(0, Offset(nDevices), Len(RawInputDeviceList)) <> 0 Then
Exit Sub
End If
Dim As MEM pRawInputDeviceList: pRawInputDeviceList = MemNew(Len(RawInputDeviceList) * nDevices)
GetRawInputDeviceList pRawInputDeviceList.OFFSET, Offset(nDevices), Len(RawInputDeviceList)
'This small block of commented code proves that we've got the device list
Dim As RAWINPUTDEVICELIST rawdevs(0 To nDevices - 1)
MemGet pRawInputDeviceList, pRawInputDeviceList.OFFSET, rawdevs()
Dim As Unsigned Long x
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)
Next
rawinputdevices = rawinputdevices + Chr$(0)
MemFree pRawInputDeviceList
Rid(0).usUsagePage = &H01
Rid(0).usUsage = &H02
Rid(0).dwFlags = 0
Rid(0).hwndTarget = 0
If RegisterRawInputDevices(Offset(Rid()), 1, Len(Rid(0))) = 0 Then
mousemessage = "RawInput init failed" + Chr$(0)
End If
End Sub
Tread on those who tread on you
Posts: 733
Threads: 103
Joined: Apr 2022
Reputation:
14
09-12-2022, 04:05 PM
(This post was last modified: 09-12-2022, 04:07 PM by madscijr.)
(09-09-2022, 08: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...r-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?
Code: (Select All) ' ################################################################################################################################################################
' Multimouse
' ################################################################################################################################################################
' Working proof of concept! (Windows only so far)
' Plug in 2 or more USB mice and try moving them around
' -------------------------------------------------------------------------------
' TO DO
' -------------------------------------------------------------------------------
' DONE:
' * detect mouse button clicks (left, middle, right buttons)
' Some issues and things to fix:
' * 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.
Option Explicit
_Title "multimouse"
$NoPrefix
$Console:Only
Console Off
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN CONSTANTS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Const FALSE = 0
Const TRUE = Not FALSE
Const CS_HREDRAW = &H0002
Const CS_VREDRAW = &H0001
Const IDI_APPLICATION = 32512
Const IDC_ARROW = 32512
Const COLOR_WINDOW = 5
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
Const MOUSE_MOVE_RELATIVE = &H00
Const MOUSE_MOVE_ABSOLUTE = &H01
Const MOUSE_VIRTUAL_DESKTOP = &H02
Const MOUSE_ATTRIBUTES_CHANGED = &H04
Const MOUSE_MOVE_NOCOALESCE = &H08
Const WM_MOUSEMOVE = &H0200
Const WM_PAINT = &H000F
Const DT_CENTER = &H00000001
' MIN/MAX VALUES FOR MOUSE TEST
Const cMinX = 2
Const cMaxX = 79
Const cMinY = 16
Const cMaxY = 24
Const cMinWheel = 0
Const cMaxWheel = 255
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' 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 InfoType
ID As String ' mouse device ID
c As String ' cursor character
x As Integer ' screen x position
y As Integer ' screen y position
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 UDTs
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN API DECLARATIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
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
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ENABLE / DISABLE DEBUG CONSOLE
Dim Shared m_bDebug As Integer: m_bDebug = FALSE
' 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)
' RAW INPUT VARIABLES
Dim Shared mousemessage As String
Dim Shared rawinputdevices As String
' MOUSE TEST VARIABLES
Dim Shared arrInfo(8) As InfoType ' 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
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
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END GLOBAL VARIABLES
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ****************************************************************************************************************************************************************
' BEGIN ACTIVATE DEBUGGING WINDOW
' ****************************************************************************************************************************************************************
'If m_bDebug = TRUE Then
' $Console
' _Delay 4
' _Console On
' _Echo "Started " + m_ProgramName$
' _Echo "Debugging on..."
'End If
' ****************************************************************************************************************************************************************
' END ACTIVATE DEBUGGING WINDOW
' ****************************************************************************************************************************************************************
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' EXECUTION STARTS HERE!
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
iMinX = 0
iMaxX = 3583
iMinY = 0
iMaxY = 8202
System Val(Str$(WinMain))
' ****************************************************************************************************************************************************************
' BEGIN DEACTIVATE DEBUGGING WINDOW
' ****************************************************************************************************************************************************************
'If m_bDebug = TRUE Then
' _Console Off
'End If
' ****************************************************************************************************************************************************************
' END DEACTIVATE DEBUGGING WINDOW
' ****************************************************************************************************************************************************************
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN CLEANUP + FINISH
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
System ' return control to the operating system
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END CLEANUP + FINISH
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN DATA
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' 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
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' 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
hInst = GetModuleHandle(0)
szMainWndClass = "WinTestWin" + Chr$(0)
szWinTitle = "Hello" + Chr$(0)
wndclass.lpszClassName = Offset(szMainWndClass)
wndclass.cbSize = Len(wndclass)
wndclass.style = CS_HREDRAW Or CS_VREDRAW
wndclass.lpfnWndProc = WindowProc
wndclass.hInstance = hInst 'GetModuleHandle(0) will return the hInstance of this EXE
wndclass.hIcon = LoadIcon(0, MAKEINTRESOURCE(IDI_APPLICATION))
wndclass.hIconSm = LoadIcon(0, MAKEINTRESOURCE(IDI_APPLICATION))
wndclass.hCursor = LoadCursor(0, MAKEINTRESOURCE(IDC_ARROW))
wndclass.hbrBackground = COLOR_WINDOW + 1
reg = RegisterClassEx(Offset(wndclass)) 'I prefer to use the output of RegisterClassEx rather than the window name
'DEBUG: SUBSTITUTE _WindowHandle
hwndMain = CreateWindowEx(0, MAKELPARAM(reg, 0), Offset(szWinTitle), WS_OVERLAPPEDWINDOW, CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, 0, 0, hInst, 0)
'hwndMain = _WindowHandle
'DEBUG: SUBSTITUTE _WindowHandle
ShowWindow hwndMain, SW_SHOW
'ShowWindow _WindowHandle, SW_SHOW
'DEBUG: SUBSTITUTE _WindowHandle
UpdateWindow hwndMain
'UpdateWindow _WindowHandle
InitRawInput
InitMouseTest 'TODO: SAVE_MOUSE_INFO
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
' 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!"
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(arrInfo) Then
If iIndex <= UBound(arrInfo) Then
' =============================================================================
' UPDATE ABSOLUTE POSITION
' 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)
'arrInfo(iIndex).x = iNewX
'arrInfo(iIndex).y = iNewY
' WORKS BUT NOT THAT ACCURATE:
' METHOD #2: INCREMENT/DECREMENT DELTA
If raw.mouse.lLastX < 0 Then
arrInfo(iIndex).x = arrInfo(iIndex).x - 1
ElseIf raw.mouse.lLastX > 0 Then
arrInfo(iIndex).x = arrInfo(iIndex).x + 1
End If
If raw.mouse.lLastY < 0 Then
arrInfo(iIndex).y = arrInfo(iIndex).y - 1
ElseIf raw.mouse.lLastY > 0 Then
arrInfo(iIndex).y = arrInfo(iIndex).y + 1
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
arrInfo(iIndex).LeftDown = TRUE
ElseIf ((raw.mouse.usButtonFlags And 2) = 2) Then
arrInfo(iIndex).LeftDown = FALSE
End If
' middle button = 16 when down, 32 when released
If ((raw.mouse.usButtonFlags And 16) = 16) Then
arrInfo(iIndex).MiddleDown = TRUE
ElseIf ((raw.mouse.usButtonFlags And 32) = 32) Then
arrInfo(iIndex).MiddleDown = FALSE
End If
' right button = 4 when down, 8 when released
If ((raw.mouse.usButtonFlags And 4) = 4) Then
arrInfo(iIndex).RightDown = TRUE
ElseIf ((raw.mouse.usButtonFlags And 8) = 8) Then
arrInfo(iIndex).RightDown = FALSE
End If
' scroll wheel = ???
'arrInfo(iIndex).wheel = ???
End If
End If
' ================================================================================================================================================================
' BEGIN DRAW PLAYING FIELD
' ================================================================================================================================================================
ClearText
WriteText 1, 1, "1. PLUG 1-8 MICE INTO THE COMPUTER"
WriteText 2, 1, "2. USE MICE TO POSITION LETTERS ON SCREEN"
WriteText 3, 1, "3. PRESS <ESC> TO QUIT"
WriteText 4, 1, "--------------------------------------------------------------------------------"
WriteText 5, 1, "# X Y Wheel LeftDown MiddleDown RightDown LeftCount MiddleCount RightCount "
WriteText 6, 1, "--------------------------------------------------------------------------------"
' NOTE: LEAVE THE NEXT 8 LINES FREE (ROWS 8-15)
' TO DISPLAY TEST VALUES FOR UPTO 8 MICE
' DRAW BORDER AROUND PLAYING FIELD
DrawTextLine cMinX - 1, cMinY - 1, cMinX - 1, cMaxY + 1, "#"
DrawTextLine cMinX - 1, cMinY - 1, cMaxX + 1, cMinY - 1, "#"
DrawTextLine cMaxX + 1, cMaxY + 1, cMaxX + 1, cMinY - 1, "#"
DrawTextLine cMaxX + 1, cMaxY + 1, cMinX - 1, cMaxY + 1, "#"
' GET INPUT AND MOVE PLAYERS
iRowOffset = 0
For iIndex = LBound(arrInfo) To UBound(arrInfo)
' CHECK BOUNDARIES
If arrInfo(iIndex).x < cMinX Then arrInfo(iIndex).x = cMinX
If arrInfo(iIndex).x > cMaxX Then arrInfo(iIndex).x = cMaxX
If arrInfo(iIndex).y < cMinY Then arrInfo(iIndex).y = cMinY
If arrInfo(iIndex).y > cMaxY Then arrInfo(iIndex).y = cMaxY
' PLOT CURSOR
WriteText arrInfo(iIndex).y, arrInfo(iIndex).x, arrInfo(iIndex).c
' DISPLAY VARIABLES
iLen = 3: sCount = Left$(LTrim$(RTrim$(Str$(iRowOffset + 1))) + String$(iLen, " "), iLen)
iLen = 3: sX = Left$(LTrim$(RTrim$(Str$(arrInfo(iIndex).x))) + String$(iLen, " "), iLen)
iLen = 3: sY = Left$(LTrim$(RTrim$(Str$(arrInfo(iIndex).y))) + String$(iLen, " "), iLen)
iLen = 6: sWheel = Left$(LTrim$(RTrim$(Str$(arrInfo(iIndex).wheel))) + String$(iLen, " "), iLen)
iLen = 9: sLeftDown = Left$(LTrim$(RTrim$(Str$(arrInfo(iIndex).LeftDown))) + String$(iLen, " "), iLen)
iLen = 11: sMiddleDown = Left$(LTrim$(RTrim$(Str$(arrInfo(iIndex).MiddleDown))) + String$(iLen, " "), iLen)
iLen = 10: sRightDown = Left$(LTrim$(RTrim$(Str$(arrInfo(iIndex).RightDown))) + String$(iLen, " "), iLen)
iLen = 10: sLeftCount = Left$(LTrim$(RTrim$(Str$(arrInfo(iIndex).LeftCount))) + String$(iLen, " "), iLen)
iLen = 12: sMiddleCount = Left$(LTrim$(RTrim$(Str$(arrInfo(iIndex).MiddleCount))) + String$(iLen, " "), iLen)
iLen = 11: sRightCount = Left$(LTrim$(RTrim$(Str$(arrInfo(iIndex).RightCount))) + String$(iLen, " "), iLen)
'sNext = sCount + sX + sY + sWheel + sLeftDown + sMiddleDown + sRightDown + sLeftCount + sMiddleCount + sRightCount
WriteText 6 + iRowOffset, 1, sCount + sX + sY + sWheel + sLeftDown + sMiddleDown + sRightDown + sLeftCount + sMiddleCount + sRightCount
iRowOffset = iRowOffset + 1
Next iIndex
' UPDATE mousemessage WITH PLAYING FIELD
mousemessage = ScreenToString$
' ================================================================================================================================================================
' END DRAW PLAYING FIELD
' ================================================================================================================================================================
InvalidateRect hwnd, 0, -1
SendMessage hwnd, WM_PAINT, 0, 0
MainWndProc = 0
End If
MemFree lpb
MainWndProc = 0
Exit Function
Case WM_MOUSEMOVE
'mousemessage = mousemessage + "X:" + Str$(GET_X_LPARAM(lParam))
'mousemessage = mousemessage + " Y:" + Str$(GET_Y_LPARAM(lParam))
'mousemessage = mousemessage + Chr$(0)
' SAVE 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(arrInfo) Then
If iIndex <= UBound(arrInfo) Then
' =============================================================================
' UPDATE ABSOLUTE POSITION
' DOESN'T WORK, MOVES ALL OVER THE PLACE:
'' METHOD #1: SCALE MOUSE POSITION TO 80X25 POSITION
''iNewX = ( (GET_X_LPARAM(lParam) + 1) * 80) \ 1520
'iNewX = ( (GET_X_LPARAM(lParam) + 1) * 80) \ (iMaxX+1)
''iNewY = ( (GET_Y_LPARAM(lParam) + 1) * 25) \ 782
'iNewY = ( (GET_Y_LPARAM(lParam) + 1) * 25) \ (iMaxY+1)
'arrInfo(iIndex).x = iNewX
'arrInfo(iIndex).y = iNewY
' 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?)
'arrInfo(iIndex).wheel =
'arrInfo(iIndex).LeftDown =
'arrInfo(iIndex).MiddleDown =
'arrInfo(iIndex).RightDown =
End If
End If
'DEBUG: SUBSTITUTE _WindowHandle
InvalidateRect hwnd, 0, -1
'InvalidateRect _WindowHandle, 0, -1
'DEBUG: SUBSTITUTE _WindowHandle
SendMessage hwnd, WM_PAINT, 0, 0
'SendMessage _WindowHandle, WM_PAINT, 0, 0
MainWndProc = 0
Exit Function
Case WM_PAINT
'DEBUG: SUBSTITUTE _WindowHandle
hdc = BeginPaint(hwnd, Offset(ps))
'hdc = BeginPaint(_WindowHandle, Offset(ps))
'DEBUG: SUBSTITUTE _WindowHandle
GetClientRect hwnd, Offset(rc)
'GetClientRect _WindowHandle, Offset(rc)
DrawText hdc, Offset(mousemessage), Len(mousemessage), Offset(rc), DT_CENTER
OffsetRect Offset(rc), 0, 200
'' PRINT LIST OF RawInput DEVICES:
'DrawText hdc, Offset(rawinputdevices), Len(rawinputdevices), Offset(rc), DT_CENTER
'DEBUG: SUBSTITUTE _WindowHandle
EndPaint hwnd, Offset(ps)
'EndPaint _WindowHandle, Offset(ps)
MainWndProc = 0
Exit Function
Case Else
'DEBUG: SUBSTITUTE _WindowHandle
MainWndProc = DefWindowProc(hwnd, nMsg, wParam, lParam)
'MainWndProc = DefWindowProc(_WindowHandle, nMsg, wParam, lParam)
End Select
End Function ' MainWndProc
' /////////////////////////////////////////////////////////////////////////////
' Initializes raw input stuff
Sub InitRawInput ()
Dim As RAWINPUTDEVICE Rid(0 To 49)
Dim As Unsigned Long nDevices
Dim As RAWINPUTDEVICELIST RawInputDeviceList
Dim As MEM pRawInputDeviceList
ReDim As RAWINPUTDEVICELIST rawdevs(-1)
Dim As Unsigned Long x
Dim strNextID As String
'dim lngNextID as long
If GetRawInputDeviceList(0, Offset(nDevices), Len(RawInputDeviceList)) <> 0 Then
Exit Sub
End If
pRawInputDeviceList = MemNew(Len(RawInputDeviceList) * nDevices)
GetRawInputDeviceList pRawInputDeviceList.OFFSET, Offset(nDevices), Len(RawInputDeviceList)
' 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 INFO
iMouseCount = 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)
' Is it a mouse?
'TODO: SAVE_MOUSE_INFO
If rawdevs(x).dwType = 0 Then
iMouseCount = iMouseCount + 1
strNextID = _Trim$(Str$(rawdevs(x).hDevice))
'lngNextID = Val(strNextID)
'arrInfo(iMouseCount-1).ID = lngNextID
arrInfo(iMouseCount - 1).ID = strNextID
End If
Next x
rawinputdevices = rawinputdevices + Chr$(0)
MemFree pRawInputDeviceList
Rid(0).usUsagePage = &H01
Rid(0).usUsage = &H02
Rid(0).dwFlags = 0
'DEBUG: SUBSTITUTE _WindowHandle
Rid(0).hwndTarget = 0
'Rid(0).hwndTarget = _WindowHandle
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 CURSORS, MOUSE STATE, ETC.
Restore CData
iIndex = LBound(arrInfo) - 1
For iLoop = 1 To iMouseCount
iIndex = iIndex + 1
Read arrInfo(iIndex).c
' INITIALIZED BELOW: arrInfo(iIndex).x = 0
' INITIALIZED BELOW: arrInfo(iIndex).y = 0
' INITIALIZED BELOW: arrInfo(iIndex).wheel = 127
arrInfo(iIndex).LeftDown = FALSE
arrInfo(iIndex).MiddleDown = FALSE
arrInfo(iIndex).RightDown = FALSE
arrInfo(iIndex).LeftCount = 0
arrInfo(iIndex).MiddleCount = 0
arrInfo(iIndex).RightCount = 0
Next iLoop
' INITIALIZE X COORDINATES
Restore XData
iIndex = LBound(arrInfo) - 1
For iLoop = 1 To iMouseCount
iIndex = iIndex + 1
Read arrInfo(iIndex).x
Next iLoop
' INITIALIZE Y COORDINATES
Restore YData
iIndex = LBound(arrInfo) - 1
For iLoop = 1 To iMouseCount
iIndex = iIndex + 1
Read arrInfo(iIndex).y
Next iLoop
' INITIALIZE SCROLL WHEEL
Restore WData
iIndex = LBound(arrInfo) - 1
For iLoop = 1 To iMouseCount
iIndex = iIndex + 1
Read arrInfo(iIndex).wheel
Next iLoop
End Sub ' InitMouseTest
' /////////////////////////////////////////////////////////////////////////////
' Finds position in array arrInfo where .ID = MouseID
Function GetMouseIndex% (MouseID As String)
Dim iLoop As Integer
Dim iIndex%
iIndex% = LBound(arrInfo) - 1
For iLoop = LBound(arrInfo) To UBound(arrInfo)
If arrInfo(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
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' /////////////////////////////////////////////////////////////////////////////
' 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
While e% >= 0
y% = y% + sy%: e% = e% - 2 * dx%
Wend
x% = x% + sx%: e% = e% + 2 * dy%
Next
''PSET (x2%, y2%), c%
'Locate x2%, y2% : Print c$;
WriteText x2%, y2%, c$
End Sub ' DrawTextLine
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END TEST OUTPUT FUNCTIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' 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
'arrInfo(iLoop).ID = 0
arrInfo(iLoop).ID = ""
Next iLoop
' GET IDs
'TODO: get this from RawInput API
''arrRawMouseID(1) = 1 ' for now just fudge it!
'arrInfo(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 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%
' /////////////////////////////////////////////////////////////////////////////
' 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 #DEBUGGING
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'' /////////////////////////////////////////////////////////////////////////////
'
'Sub DebugPrint (MyString As String)
' If m_bDebug = TRUE Then
' '_Echo MyString
' 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
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END DEBUGGING ROUTINES @DEBUGGING
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ################################################################################################################################################################
' #REFERENCE
' =============================================================================
' SOME USEFUL STUFF FOR REFERENCE:
' Type Name Type suffix symbol Minimum value Maximum value Size in Bytes
' --------------------- ------------------ ---------------------------- -------------------------- -------------
' _BIT ` -1 0 1/8
' _BIT * n `n -128 127 n/8
' _UNSIGNED _BIT ~` 0 1 1/8
' _BYTE %% -128 127 1
' _UNSIGNED _BYTE ~%% 0 255 1
' INTEGER % -32,768 32,767 2
' _UNSIGNED INTEGER ~% 0 65,535 2
' LONG & -2,147,483,648 2,147,483,647 4
' _UNSIGNED LONG ~& 0 4,294,967,295 4
' _INTEGER64 && -9,223,372,036,854,775,808 9,223,372,036,854,775,807 8
' _UNSIGNED _INTEGER64 ~&& 0 18,446,744,073,709,551,615 8
' SINGLE ! or none -2.802597E-45 +3.402823E+38 4
' DOUBLE # -4.490656458412465E-324 +1.797693134862310E+308 8
' _FLOAT ## -1.18E-4932 +1.18E+4932 32(10 used)
' _OFFSET %& -9,223,372,036,854,775,808 9,223,372,036,854,775,807 Use LEN
' _UNSIGNED _OFFSET ~%& 0 18,446,744,073,709,551,615 Use LEN
' _MEM none combined memory variable type N/A Use LEN
' div: int1% = num1% \ den1%
' mod: rem1% = num1% MOD den1%
' @END
Posts: 730
Threads: 30
Joined: Apr 2022
Reputation:
43
09-12-2022, 04:09 PM
(This post was last modified: 09-12-2022, 04:19 PM by SpriggsySpriggs.)
@madscijr
The main thing is the callback stuff. You're going to want a main loop like a DO or a WHILE. We'd still have to grab those WM_MOUSEMOVE and WM_INPUT messages with that SELECT CASE block, though. Getting the callback stuff changed over is what will jumpstart everything else.
P.S. I replied to your thread about MIDI/WAV stuff. https://qb64phoenix.com/forum/showthread...43#pid6543
Tread on those who tread on you
Posts: 733
Threads: 103
Joined: Apr 2022
Reputation:
14
(09-12-2022, 04:09 PM)Spriggsy Wrote: @madscijr
The main thing is the callback stuff. You're going to want a main loop like a DO or a WHILE. We'd still have to grab those WM_MOUSEMOVE and WM_INPUT messages with that SELECT CASE block, though. Getting the callback stuff changed over is what will jumpstart everything else.
P.S. I replied to your thread about MIDI/WAV stuff. https://qb64phoenix.com/forum/showthread...43#pid6543
If you get a second, can you maybe demonstrate?
I am still not sure how or when the different parts should all get fired, initialized, etc.
I will try messing with it later but it will be guesswork. But I will try.
RE: WAV file, thanks! I will check that out too, when back on the PC!
Posts: 730
Threads: 30
Joined: Apr 2022
Reputation:
43
In order to properly demonstrate, I think I'd have to almost start over again because changing the code from where it is might be more difficult than starting from scratch but just knowing how to use the functions. I ended up not having any time to jump back into it over the weekend, unfortunately.
Tread on those who tread on you
Posts: 733
Threads: 103
Joined: Apr 2022
Reputation:
14
09-12-2022, 05:53 PM
(This post was last modified: 09-12-2022, 06:04 PM by madscijr.)
(09-12-2022, 05:17 PM)Spriggsy Wrote: In order to properly demonstrate, I think I'd have to almost start over again because changing the code from where it is might be more difficult than starting from scratch but just knowing how to use the functions. I ended up not having any time to jump back into it over the weekend, unfortunately.
Well as a start, I moved it into a loop like you described - see code below.
Everything happens in sub main at line 367.
Questions:
- There are various values being supplied as event parameters, which I am not sure how to populate, such as:
MainWndProc%& (hwnd As Offset, nMsg As Unsigned Long, wParam As Unsigned Offset, lParam As Offset)
I am guessing hwnd can come from _WindowHandle, but no idea about the others...
- There are things happening that look like they could maybe be removed (ShowWindow, UpdateWindow, etc.)
however I am not knowledgeable enough about this way of doing things, to know which.
Here are the specific places in the below code that I am not sure about: - line 442: do we populate hwndMain with _WindowHandle?
- lines 445-446: still needed?
- lines 452-455: still needed?
- line 458: what do we do with this value?
- line 477: use _WindowHandle?
- lines 482-484: how do we get these values?
- lines 493-495: what do we do for WM_DESTROY?
- lines 503-504: can we just exit do here?
- line 509: needs lParam to work
- line 655: still needed?
- line 658: still needed?
- line 713: still needed?
- line 716: still needed?
- lines 723-743: can we remove?
- line 747: cal we remove?
Any assistance would be most appreciated if and whenever you can get a minute to give this a look.
Code: (Select All) ' ################################################################################################################################################################
' Multimouse
' ################################################################################################################################################################
' Working proof of concept! (Windows only so far)
' Plug in 2 or more USB mice and try moving them around
' TEMPORARILY BROKEN WHILE WE CHANGE THIS FROM EVENT-DRIVEN TO LINEAR CODE
' -------------------------------------------------------------------------------
' TO DO
' -------------------------------------------------------------------------------
' DONE:
' * detect mouse button clicks (left, middle, right buttons)
' Some issues and things to fix:
' * 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.
Option Explicit
_Title "multimouse"
$NoPrefix
$Console:Only
Console Off
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN CONSTANTS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Const FALSE = 0
Const TRUE = Not FALSE
Const CS_HREDRAW = &H0002
Const CS_VREDRAW = &H0001
Const IDI_APPLICATION = 32512
Const IDC_ARROW = 32512
Const COLOR_WINDOW = 5
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
Const MOUSE_MOVE_RELATIVE = &H00
Const MOUSE_MOVE_ABSOLUTE = &H01
Const MOUSE_VIRTUAL_DESKTOP = &H02
Const MOUSE_ATTRIBUTES_CHANGED = &H04
Const MOUSE_MOVE_NOCOALESCE = &H08
Const WM_MOUSEMOVE = &H0200
Const WM_PAINT = &H000F
Const DT_CENTER = &H00000001
' MIN/MAX VALUES FOR MOUSE TEST
Const cMinX = 2
Const cMaxX = 79
Const cMinY = 16
Const cMaxY = 24
Const cMinWheel = 0
Const cMaxWheel = 255
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' 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 InfoType
ID As String ' mouse device ID
c As String ' cursor character
x As Integer ' screen x position
y As Integer ' screen y position
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 UDTs
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN API DECLARATIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
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
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ENABLE / DISABLE DEBUG CONSOLE
Dim Shared m_bDebug As Integer: m_bDebug = FALSE
' 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)
' RAW INPUT VARIABLES
Dim Shared mousemessage As String
Dim Shared rawinputdevices As String
' MOUSE TEST VARIABLES
Dim Shared arrInfo(8) As InfoType ' 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
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
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END GLOBAL VARIABLES
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ****************************************************************************************************************************************************************
' BEGIN ACTIVATE DEBUGGING WINDOW
' ****************************************************************************************************************************************************************
'If m_bDebug = TRUE Then
' $Console
' _Delay 4
' _Console On
' _Echo "Started " + m_ProgramName$
' _Echo "Debugging on..."
'End If
' ****************************************************************************************************************************************************************
' END ACTIVATE DEBUGGING WINDOW
' ****************************************************************************************************************************************************************
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' EXECUTION STARTS HERE!
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
iMinX = 0
iMaxX = 3583
iMinY = 0
iMaxY = 8202
' THE ORIGINAL (EVENT-ORIENTED) WAY OF STARTING THINGS:
'System Val(Str$(WinMain))
' SIMPLER (LINEAR/PROCEDURAL) WAY OF DOING THINGS:
main
' ****************************************************************************************************************************************************************
' BEGIN DEACTIVATE DEBUGGING WINDOW
' ****************************************************************************************************************************************************************
'If m_bDebug = TRUE Then
' _Console Off
'End If
' ****************************************************************************************************************************************************************
' END DEACTIVATE DEBUGGING WINDOW
' ****************************************************************************************************************************************************************
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN CLEANUP + FINISH
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
System ' return control to the operating system
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END CLEANUP + FINISH
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN DATA
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' 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
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN RAW INPUT FUNCTIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' /////////////////////////////////////////////////////////////////////////////
Sub main
' VARIABLES FOR function: WinMain~%& ()
Dim hwndMain As Offset
Dim hInst As Offset
Dim msg As MSG
Dim wndclass As WNDCLASSEX
Dim szMainWndClass As String
Dim szWinTitle As String
Dim reg As Unsigned Integer
' PARAMETERS THAT WENT TO function: MainWndProc%& (hwnd As Offset, nMsg As Unsigned Long, wParam As Unsigned Offset, lParam As Offset)
Dim hwnd As Offset
Dim nMsg As Unsigned Long
Dim wParam As Unsigned Offset
Dim lParam As Offset
' VARIABLES for function: MainWndProc%&
Static hwndButton As Offset
Static cx As Long
Static cy As Long
Dim hdc As Offset
Dim ps As PAINTSTRUCT
Dim rc As RECT
Dim lpb As MEM
Dim dwSize As Unsigned Long
Dim raw As RAWINPUT
Dim tmpx As Long
Dim tmpy As Long
Static maxx As Long
Dim rih As RAWINPUTHEADER
' 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
' ================================================================================================================================================================
' BEGIN WinMain~%& ()
' ================================================================================================================================================================
'DEBUG: TRY FULL SCREEN <- PROGRAM CRASHES!
'_FullScreen _SquarePixels
hInst = GetModuleHandle(0)
szMainWndClass = "WinTestWin" + Chr$(0)
szWinTitle = "Hello" + Chr$(0)
wndclass.lpszClassName = Offset(szMainWndClass)
wndclass.cbSize = Len(wndclass)
wndclass.style = CS_HREDRAW Or CS_VREDRAW
wndclass.lpfnWndProc = WindowProc
wndclass.hInstance = hInst 'GetModuleHandle(0) will return the hInstance of this EXE
wndclass.hIcon = LoadIcon(0, MAKEINTRESOURCE(IDI_APPLICATION))
wndclass.hIconSm = LoadIcon(0, MAKEINTRESOURCE(IDI_APPLICATION))
wndclass.hCursor = LoadCursor(0, MAKEINTRESOURCE(IDC_ARROW))
wndclass.hbrBackground = COLOR_WINDOW + 1
reg = RegisterClassEx(Offset(wndclass)) 'I prefer to use the output of RegisterClassEx rather than the window name
' *** NOT SURE IF WE SHOULD SUBSTITUTE _WindowHandle FOR THIS NEXT LINE? ***
hwndMain = CreateWindowEx(0, MAKELPARAM(reg, 0), Offset(szWinTitle), WS_OVERLAPPEDWINDOW, CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, 0, 0, hInst, 0)
' *** NOT SURE IF WE STILL NEED THESE NEXT 2 LINES?
ShowWindow hwndMain, SW_SHOW
UpdateWindow hwndMain
InitRawInput
InitMouseTest 'TODO: SAVE_MOUSE_INFO
' *** NOT SURE IF WE NEED THIS, OR HOW TO MAKE IT WORk, WHAT IS msg ?
While GetMessage(Offset(msg), 0, 0, 0)
TranslateMessage Offset(msg)
DispatchMessage Offset(msg)
Wend
' *** NOT SURE WHAT WE SHOULD DO WITH THIS VALUE? ***
'WinMain = msg.wParam
' ================================================================================================================================================================
' END WinMain~%& ()
' ================================================================================================================================================================
' INITIALIZE SCREEN
ClearText
WriteText 1, 1, "1. PLUG 1-8 MICE INTO THE COMPUTER"
WriteText 2, 1, "2. USE MICE TO POSITION LETTERS ON SCREEN"
WriteText 3, 1, "3. PRESS <ESC> TO QUIT"
WriteText 4, 1, "--------------------------------------------------------------------------------"
WriteText 5, 1, "# X Y Wheel LeftDown MiddleDown RightDown LeftCount MiddleCount RightCount "
WriteText 6, 1, "--------------------------------------------------------------------------------"
' MAIN LOOP
Do
' POPULATE THE WINDOW PARAMETERS:
' hwnd As Offset
hwnd = _WindowHandle
' *****************************************************************************
' Q: where do these come from?
' *****************************************************************************
' nMsg As Unsigned Long
' wParam As Unsigned Offset
' lParam As Offset
' ================================================================================================================================================================
' BEGIN Function MainWndProc%&
' ================================================================================================================================================================
' HANDLE EVENTS
Select Case nMsg
Case WM_DESTROY
' *** NOT SURE WHAT WE SHOULD DO HERE? ***
'PostQuitMessage 0
'MainWndProc = 0
'Exit Function
Exit Do
Case WM_INPUT
GetRawInputData lParam, RID_INPUT, 0, Offset(dwSize), Len(rih)
lpb = MemNew(dwSize)
If lpb.SIZE = 0 Then
' *** NOT SURE WHAT WE SHOULD DO HERE? ***
'MainWndProc = 0
'Exit Function
Exit Do
End If
' *** NEED lParam ***
If GetRawInputData(lParam, RID_INPUT, lpb.OFFSET, Offset(dwSize), Len(rih)) <> dwSize Then
Print "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(arrInfo) Then
If iIndex <= UBound(arrInfo) Then
' =============================================================================
' UPDATE ABSOLUTE POSITION
' 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)
'arrInfo(iIndex).x = iNewX
'arrInfo(iIndex).y = iNewY
' WORKS BUT NOT THAT ACCURATE:
' METHOD #2: INCREMENT/DECREMENT DELTA
If raw.mouse.lLastX < 0 Then
arrInfo(iIndex).x = arrInfo(iIndex).x - 1
ElseIf raw.mouse.lLastX > 0 Then
arrInfo(iIndex).x = arrInfo(iIndex).x + 1
End If
If raw.mouse.lLastY < 0 Then
arrInfo(iIndex).y = arrInfo(iIndex).y - 1
ElseIf raw.mouse.lLastY > 0 Then
arrInfo(iIndex).y = arrInfo(iIndex).y + 1
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
arrInfo(iIndex).LeftDown = TRUE
ElseIf ((raw.mouse.usButtonFlags And 2) = 2) Then
arrInfo(iIndex).LeftDown = FALSE
End If
' middle button = 16 when down, 32 when released
If ((raw.mouse.usButtonFlags And 16) = 16) Then
arrInfo(iIndex).MiddleDown = TRUE
ElseIf ((raw.mouse.usButtonFlags And 32) = 32) Then
arrInfo(iIndex).MiddleDown = FALSE
End If
' right button = 4 when down, 8 when released
If ((raw.mouse.usButtonFlags And 4) = 4) Then
arrInfo(iIndex).RightDown = TRUE
ElseIf ((raw.mouse.usButtonFlags And 8) = 8) Then
arrInfo(iIndex).RightDown = FALSE
End If
' scroll wheel = ???
'arrInfo(iIndex).wheel = ???
End If
End If
' ================================================================================================================================================================
' BEGIN DRAW PLAYING FIELD
' ================================================================================================================================================================
ClearText
WriteText 1, 1, "1. PLUG 1-8 MICE INTO THE COMPUTER"
WriteText 2, 1, "2. USE MICE TO POSITION LETTERS ON SCREEN"
WriteText 3, 1, "3. PRESS <ESC> TO QUIT"
WriteText 4, 1, "--------------------------------------------------------------------------------"
WriteText 5, 1, "# X Y Wheel LeftDown MiddleDown RightDown LeftCount MiddleCount RightCount "
WriteText 6, 1, "--------------------------------------------------------------------------------"
' NOTE: LEAVE THE NEXT 8 LINES FREE (ROWS 8-15)
' TO DISPLAY TEST VALUES FOR UPTO 8 MICE
' DRAW BORDER AROUND PLAYING FIELD
DrawTextLine cMinX - 1, cMinY - 1, cMinX - 1, cMaxY + 1, "#"
DrawTextLine cMinX - 1, cMinY - 1, cMaxX + 1, cMinY - 1, "#"
DrawTextLine cMaxX + 1, cMaxY + 1, cMaxX + 1, cMinY - 1, "#"
DrawTextLine cMaxX + 1, cMaxY + 1, cMinX - 1, cMaxY + 1, "#"
' GET INPUT AND MOVE PLAYERS
iRowOffset = 0
For iIndex = LBound(arrInfo) To UBound(arrInfo)
' CHECK BOUNDARIES
If arrInfo(iIndex).x < cMinX Then arrInfo(iIndex).x = cMinX
If arrInfo(iIndex).x > cMaxX Then arrInfo(iIndex).x = cMaxX
If arrInfo(iIndex).y < cMinY Then arrInfo(iIndex).y = cMinY
If arrInfo(iIndex).y > cMaxY Then arrInfo(iIndex).y = cMaxY
' PLOT CURSOR
WriteText arrInfo(iIndex).y, arrInfo(iIndex).x, arrInfo(iIndex).c
' DISPLAY VARIABLES
iLen = 3: sCount = Left$(LTrim$(RTrim$(Str$(iRowOffset + 1))) + String$(iLen, " "), iLen)
iLen = 3: sX = Left$(LTrim$(RTrim$(Str$(arrInfo(iIndex).x))) + String$(iLen, " "), iLen)
iLen = 3: sY = Left$(LTrim$(RTrim$(Str$(arrInfo(iIndex).y))) + String$(iLen, " "), iLen)
iLen = 6: sWheel = Left$(LTrim$(RTrim$(Str$(arrInfo(iIndex).wheel))) + String$(iLen, " "), iLen)
iLen = 9: sLeftDown = Left$(LTrim$(RTrim$(Str$(arrInfo(iIndex).LeftDown))) + String$(iLen, " "), iLen)
iLen = 11: sMiddleDown = Left$(LTrim$(RTrim$(Str$(arrInfo(iIndex).MiddleDown))) + String$(iLen, " "), iLen)
iLen = 10: sRightDown = Left$(LTrim$(RTrim$(Str$(arrInfo(iIndex).RightDown))) + String$(iLen, " "), iLen)
iLen = 10: sLeftCount = Left$(LTrim$(RTrim$(Str$(arrInfo(iIndex).LeftCount))) + String$(iLen, " "), iLen)
iLen = 12: sMiddleCount = Left$(LTrim$(RTrim$(Str$(arrInfo(iIndex).MiddleCount))) + String$(iLen, " "), iLen)
iLen = 11: sRightCount = Left$(LTrim$(RTrim$(Str$(arrInfo(iIndex).RightCount))) + String$(iLen, " "), iLen)
'sNext = sCount + sX + sY + sWheel + sLeftDown + sMiddleDown + sRightDown + sLeftCount + sMiddleCount + sRightCount
WriteText 6 + iRowOffset, 1, sCount + sX + sY + sWheel + sLeftDown + sMiddleDown + sRightDown + sLeftCount + sMiddleCount + sRightCount
iRowOffset = iRowOffset + 1
Next iIndex
'' UPDATE mousemessage WITH PLAYING FIELD
'mousemessage = ScreenToString$
' ================================================================================================================================================================
' END DRAW PLAYING FIELD
' ================================================================================================================================================================
' *** DO WE STILL NEED THIS?
InvalidateRect hwnd, 0, -1
' *** DO WE STILL NEED THIS?
SendMessage hwnd, WM_PAINT, 0, 0
' *** NOT SURE WHAT WE SHOULD DO HERE? ***
'MainWndProc = 0
End If
MemFree lpb
' *** NOT SURE WHAT WE SHOULD DO HERE? ***
'MainWndProc = 0
'Exit Function
Case WM_MOUSEMOVE
'mousemessage = mousemessage + "X:" + Str$(GET_X_LPARAM(lParam))
'mousemessage = mousemessage + " Y:" + Str$(GET_Y_LPARAM(lParam))
'mousemessage = mousemessage + Chr$(0)
' SAVE 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(arrInfo) Then
If iIndex <= UBound(arrInfo) Then
' =============================================================================
' UPDATE ABSOLUTE POSITION
' DOESN'T WORK, MOVES ALL OVER THE PLACE:
'' METHOD #1: SCALE MOUSE POSITION TO 80X25 POSITION
''iNewX = ( (GET_X_LPARAM(lParam) + 1) * 80) \ 1520
'iNewX = ( (GET_X_LPARAM(lParam) + 1) * 80) \ (iMaxX+1)
''iNewY = ( (GET_Y_LPARAM(lParam) + 1) * 25) \ 782
'iNewY = ( (GET_Y_LPARAM(lParam) + 1) * 25) \ (iMaxY+1)
'arrInfo(iIndex).x = iNewX
'arrInfo(iIndex).y = iNewY
' 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?)
'arrInfo(iIndex).wheel =
'arrInfo(iIndex).LeftDown =
'arrInfo(iIndex).MiddleDown =
'arrInfo(iIndex).RightDown =
End If
End If
' *** DO WE STILL NEED THIS?
InvalidateRect hwnd, 0, -1
' *** DO WE STILL NEED THIS?
SendMessage hwnd, WM_PAINT, 0, 0
' *** NOT SURE WHAT WE SHOULD DO HERE? ***
'MainWndProc = 0
'Exit Function
Case WM_PAINT
' *** I ASSUME WE CAN LEAVE OUT THIS MANUAL SCREEN REFRESH STUFF? ***
''DEBUG: SUBSTITUTE _WindowHandle
'hdc = BeginPaint(hwnd, Offset(ps))
''hdc = BeginPaint(_WindowHandle, Offset(ps))
'
''DEBUG: SUBSTITUTE _WindowHandle
'GetClientRect hwnd, Offset(rc)
''GetClientRect _WindowHandle, Offset(rc)
'
'DrawText hdc, Offset(mousemessage), Len(mousemessage), Offset(rc), DT_CENTER
'OffsetRect Offset(rc), 0, 200
'
''' PRINT LIST OF RawInput DEVICES:
''DrawText hdc, Offset(rawinputdevices), Len(rawinputdevices), Offset(rc), DT_CENTER
'
''DEBUG: SUBSTITUTE _WindowHandle
'EndPaint hwnd, Offset(ps)
''EndPaint _WindowHandle, Offset(ps)
'
'MainWndProc = 0
'Exit Function
Case Else
' *** NOT SURE WHAT WE SHOULD DO HERE? ***
'MainWndProc = DefWindowProc(hwnd, nMsg, wParam, lParam)
End Select
' ================================================================================================================================================================
' END Function MainWndProc%&
' ================================================================================================================================================================
Loop
End Sub ' main
' /////////////////////////////////////////////////////////////////////////////
' Initializes raw input stuff
Sub InitRawInput ()
Dim Rid(0 To 49) As RAWINPUTDEVICE
Dim nDevices As Unsigned Long
Dim RawInputDeviceList As RAWINPUTDEVICELIST
Dim pRawInputDeviceList As MEM
ReDim rawdevs(-1) As RAWINPUTDEVICELIST
Dim x As Unsigned Long
Dim strNextID As String
'dim lngNextID as long
If GetRawInputDeviceList(0, Offset(nDevices), Len(RawInputDeviceList)) <> 0 Then
Exit Sub
End If
pRawInputDeviceList = MemNew(Len(RawInputDeviceList) * nDevices)
GetRawInputDeviceList pRawInputDeviceList.OFFSET, Offset(nDevices), Len(RawInputDeviceList)
' 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 INFO
iMouseCount = 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)
' Is it a mouse?
'TODO: SAVE_MOUSE_INFO
If rawdevs(x).dwType = 0 Then
iMouseCount = iMouseCount + 1
strNextID = _Trim$(Str$(rawdevs(x).hDevice))
'lngNextID = Val(strNextID)
'arrInfo(iMouseCount-1).ID = lngNextID
arrInfo(iMouseCount - 1).ID = strNextID
End If
Next x
rawinputdevices = rawinputdevices + Chr$(0)
MemFree pRawInputDeviceList
Rid(0).usUsagePage = &H01
Rid(0).usUsage = &H02
Rid(0).dwFlags = 0
'DEBUG: SUBSTITUTE _WindowHandle
Rid(0).hwndTarget = 0
'Rid(0).hwndTarget = _WindowHandle
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 CURSORS, MOUSE STATE, ETC.
Restore CData
iIndex = LBound(arrInfo) - 1
For iLoop = 1 To iMouseCount
iIndex = iIndex + 1
Read arrInfo(iIndex).c
' INITIALIZED BELOW: arrInfo(iIndex).x = 0
' INITIALIZED BELOW: arrInfo(iIndex).y = 0
' INITIALIZED BELOW: arrInfo(iIndex).wheel = 127
arrInfo(iIndex).LeftDown = FALSE
arrInfo(iIndex).MiddleDown = FALSE
arrInfo(iIndex).RightDown = FALSE
arrInfo(iIndex).LeftCount = 0
arrInfo(iIndex).MiddleCount = 0
arrInfo(iIndex).RightCount = 0
Next iLoop
' INITIALIZE X COORDINATES
Restore XData
iIndex = LBound(arrInfo) - 1
For iLoop = 1 To iMouseCount
iIndex = iIndex + 1
Read arrInfo(iIndex).x
Next iLoop
' INITIALIZE Y COORDINATES
Restore YData
iIndex = LBound(arrInfo) - 1
For iLoop = 1 To iMouseCount
iIndex = iIndex + 1
Read arrInfo(iIndex).y
Next iLoop
' INITIALIZE SCROLL WHEEL
Restore WData
iIndex = LBound(arrInfo) - 1
For iLoop = 1 To iMouseCount
iIndex = iIndex + 1
Read arrInfo(iIndex).wheel
Next iLoop
End Sub ' InitMouseTest
' /////////////////////////////////////////////////////////////////////////////
' Finds position in array arrInfo where .ID = MouseID
Function GetMouseIndex% (MouseID As String)
Dim iLoop As Integer
Dim iIndex%
iIndex% = LBound(arrInfo) - 1
For iLoop = LBound(arrInfo) To UBound(arrInfo)
If arrInfo(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
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' /////////////////////////////////////////////////////////////////////////////
' Clears global array arrScreen
Sub ClearText
' ARRAY METHOD:
'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
' DIRECT METHOD:
Cls
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
' ARRAY METHOD:
'arrScreen(iPos, iRow) = Mid$(MyString, iLoop, 1)
' DIRECT METHOD:
Locate iRow, iColumn: Print 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
While e% >= 0
y% = y% + sy%: e% = e% - 2 * dx%
Wend
x% = x% + sx%: e% = e% + 2 * dy%
Next
''PSET (x2%, y2%), c%
'Locate x2%, y2% : Print c$;
WriteText x2%, y2%, c$
End Sub ' DrawTextLine
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END TEST OUTPUT FUNCTIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' 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
'arrInfo(iLoop).ID = 0
arrInfo(iLoop).ID = ""
Next iLoop
' GET IDs
'TODO: get this from RawInput API
''arrRawMouseID(1) = 1 ' for now just fudge it!
'arrInfo(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 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%
' /////////////////////////////////////////////////////////////////////////////
' 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 #DEBUGGING
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'' /////////////////////////////////////////////////////////////////////////////
'
'Sub DebugPrint (MyString As String)
' If m_bDebug = TRUE Then
' '_Echo MyString
' 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
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END DEBUGGING ROUTINES @DEBUGGING
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ################################################################################################################################################################
' #REFERENCE
' =============================================================================
' SOME USEFUL STUFF FOR REFERENCE:
' Type Name Type suffix symbol Minimum value Maximum value Size in Bytes
' --------------------- ------------------ ---------------------------- -------------------------- -------------
' _BIT ` -1 0 1/8
' _BIT * n `n -128 127 n/8
' _UNSIGNED _BIT ~` 0 1 1/8
' _BYTE %% -128 127 1
' _UNSIGNED _BYTE ~%% 0 255 1
' INTEGER % -32,768 32,767 2
' _UNSIGNED INTEGER ~% 0 65,535 2
' LONG & -2,147,483,648 2,147,483,647 4
' _UNSIGNED LONG ~& 0 4,294,967,295 4
' _INTEGER64 && -9,223,372,036,854,775,808 9,223,372,036,854,775,807 8
' _UNSIGNED _INTEGER64 ~&& 0 18,446,744,073,709,551,615 8
' SINGLE ! or none -2.802597E-45 +3.402823E+38 4
' DOUBLE # -4.490656458412465E-324 +1.797693134862310E+308 8
' _FLOAT ## -1.18E-4932 +1.18E+4932 32(10 used)
' _OFFSET %& -9,223,372,036,854,775,808 9,223,372,036,854,775,807 Use LEN
' _UNSIGNED _OFFSET ~%& 0 18,446,744,073,709,551,615 Use LEN
' _MEM none combined memory variable type N/A Use LEN
' div: int1% = num1% \ den1%
' mod: rem1% = num1% MOD den1%
' @END
Posts: 730
Threads: 30
Joined: Apr 2022
Reputation:
43
Good news (for me, not you)! We cannot retrieve these messages without this "event-driven" code. So, you're kind of stuck with how it is structured but we can still change up some stuff.
Tread on those who tread on you
Posts: 733
Threads: 103
Joined: Apr 2022
Reputation:
14
(09-12-2022, 06:23 PM)Spriggsy Wrote: Good news (for me, not you)! We cannot retrieve these messages without this "event-driven" code. So, you're kind of stuck with how it is structured but we can still change up some stuff.
Ha!
Well then, I suppose it is also good news in that we learn a new way of doing things in QB64 (events) which might be useful for other tasks as well.
I'll give it a look later and see if I can get it working as a regular QB64 program, while leaving in the event stuff.
Wish me luck! 
|
kind of works? reading multiple mice: any c programmers want to look at this?
