Posts: 439
Threads: 17
Joined: Apr 2022
Reputation:
21
09-08-2022, 07:27 PM
(This post was last modified: 09-08-2022, 07:32 PM by SpriggsySpriggs.)
You don't have to put the headers in the same folder as the other includes. All you have to do is either have it with QB64 or just put it into a subfolder and use the relative path. I typically just keep headers and bas files in the QB64 parent directory. Or I make a subfolder and reference them using the relative paths. For instance, if I have a header in a folder called "Headers" and that folder is in the QB64 parent directory, the declare can look like this:
DECLARE LIBRARY ".\Headers\headername". Also, since you put the headers in the other header folders, you shouldn't use the absolute paths anyways. Just get rid of everything in the path up until the first subfolder of the QB64 parent directory.
For instance:
DECLARE LIBRARY ".\internal\c\c_compiler\x86_64-w64-mingw32\include\headername"
However, I always recommend keeping bas and header files with QB64. Not everyone likes that. I prefer it that way.
Ask me about Windows API and maybe some Linux stuff
Posts: 439
Threads: 17
Joined: Apr 2022
Reputation:
21
09-08-2022, 08:12 PM
(This post was last modified: 09-08-2022, 08:44 PM by SpriggsySpriggs.)
Here's a version that also tracks the WM_MOUSEMOVE message and displays the X and Y coordinates in the console window. I could obviously change that to just print the text in the window but decided not to. I'm not sure how WM_MOUSEMOVE handles multiple mice, to be honest. Especially considering it just returns an X, Y coordinate relative to the program window. The WM_INPUT message with GetRawInputData only grabs the relative movement from the previous X, Y coordinate. Give 'er a go and let me know.
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) + " ulButtons=" + Hex$(MAKELONG(raw.mouse.usButtonFlags, raw.mouse.usFlags)) + " usButtonFlags=" + Hex$(raw.mouse.usButtonFlags) + " usButtonData=" + Hex$(raw.mouse.usButtonData) + " ulRawButtons=" + Hex$(raw.mouse.ulRawButtons) + " lLastX=" + Str$(raw.mouse.lLastX) + " lLastY=" + Str$(raw.mouse.lLastY) + " ulExtraInformation=" + Hex$(raw.mouse.ulExtraInformation) + Chr$(13) + Str$(maxx) + Chr$(0)
End If
MemFree lpb
InvalidateRect hwnd, 0, -1
SendMessage hwnd, WM_PAINT, 0, 0
MainWndProc = 0
Exit Function
Case WM_MOUSEMOVE
Print "X"; GET_X_LPARAM(lParam)
Print "Y"; GET_Y_LPARAM(lParam)
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
'For x = 0 To UBound(rawdevs)
' Print rawdevs(x).hDevice, rawdevs(x).dwType
'Next
rawinputdevices = "Number of raw input devices:" + Str$(nDevices) + 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
Ask me about Windows API and maybe some Linux stuff
Posts: 529
Threads: 67
Joined: Apr 2022
Reputation:
11
09-08-2022, 08:43 PM
(This post was last modified: 09-08-2022, 08:51 PM by madscijr.)
(09-08-2022, 07:27 PM)Spriggsy Wrote: You don't have to put the headers in the same folder as the other includes. All you have to do is either have it with QB64 or just put it into a subfolder and use the relative path. I typically just keep headers and bas files in the QB64 parent directory. Or I make a subfolder and reference them using the relative paths. For instance, if I have a header in a folder called "Headers" and that folder is in the QB64 parent directory, the declare can look like this:
DECLARE LIBRARY ".\Headers\headername". Also, since you put the headers in the other header folders, you shouldn't use the absolute paths anyways. Just get rid of everything in the path up until the first subfolder of the QB64 parent directory.
For instance:
DECLARE LIBRARY ".\internal\c\c_compiler\x86_64-w64-mingw32\include\headername"
However, I always recommend keeping bas and header files with QB64. Not everyone likes that. I prefer it that way.
Got it, thanks.
Now for the fun part!
The code flow seems to be set up like the C program, which is event-driven.
I see around line 211 there is a DrawText to write the mousemessage to the screen (inside Function MainWndProc).
How might this be restructured to work like a regular QB64 program that uses a more straightforward linear flow?
Specifically, how would we merge your mouse magic into the below program, to make option 4 work with it?
Option 4 calls Sub MouseRawInputTest at line 104, which reads the mice to move some text characters around the screen.
That routine can be left alone, but we would need to alter these 3 routines to work with your API functions:
At line 290: Function GetRawMouseCount% ()
At line 304: Sub GetRawMouseIDs (arrRawMouseID( 8) As Long)
At line 340: Sub ReadRawMouse (MouseID&, x%, y%, left%, middle%, right%, wheel%, wheelmin%, wheelmax%)
Any thoughts?
Code: (Select All) ' #############################################################################
' MULTIMOUSE
' ----------
' A proof of concept / experiment to try to get the computer to read
' 2 or mice plugged into the computer, as separate devices,
' to control 2 or more cursors on the screen (for multiplayer games, etc.)
'
' This lets you try 3 different methods:
' 1. _MOUSEX, _MOUSEY, etc.
' 2. _DEVICE commands
' 3. RawInput API
'
' #############################################################################
' CONSTANTS
Const FALSE = 0
Const TRUE = Not FALSE
' UDT TO HOLD THE INFO FOR EACH MOUSE
Type InfoType
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
' 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)
' TRY THE MOUSE
main
' FINISH
System ' return control to the operating system
Print m_ProgramName$ + " finished."
End
' =============================================================================
' 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
' =============================================================================
' /////////////////////////////////////////////////////////////////////////////
Sub main
Dim in$: in$ = ""
Do
Cls
Print m_ProgramName$
Print
Print "How can we get separate input from 2 or more USB mice "
Print "plugged into one computer?"
Print
Print "1. Test using _MOUSEX, _MOUSEY, etc."
Print
Print "2. Test using _DEVICE commands"
Print
Print "3. Enumerate devices with _DEVICES to try and detect >1 mouse"
Print
Print "4. Test using RawInput API"
Print
Print "What to do ('q' to exit)"
Input in$: in$ = LCase$(Left$(in$, 1))
If in$ = "1" Then
MouseInputTest in$
ElseIf in$ = "2" Then
MouseInputTest in$
ElseIf in$ = "3" Then
EnumerateDevices: _KeyClear: '_DELAY 1
ElseIf in$ = "4" Then
MouseRawInputTest
End If
Loop Until in$ = "q"
End Sub ' main
' /////////////////////////////////////////////////////////////////////////////
' Gets mouse input using RawInput API
Sub MouseRawInputTest
' MIN/MAX VALUES
Const cMinX = 2
Const cMaxX = 79
Const cMinY = 16
Const cMaxY = 24
Const cMinWheel = 0
Const cMaxWheel = 255
' MAIN VARIABLES
Dim iCount As Integer ' # OF MICE ATTACHED
Dim arrRawMouseID(8) As Integer ' device IDs for mice connected to system (guessing this would be a string, dunno)
Dim arrInfo(8) As InfoType ' STORES INFO FOR EACH MOUSE
Dim left%, middle%, right% ' temp mouse variables
Dim iLoop As Integer
Dim iIndex As Integer
' TEMP VARIABLES FOR DISPLAYING FORMATTED VALUES TO SCREEN
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
' COUNT # OF MICE CONNECTED + GET DEVICE IDs
iCount = GetRawMouseCount% ' THIS FUNCTION WOULD ENUMERATE MICE, SHOULD RETURN 0 FOR NONE
If (iCount > 8) Then iCount = 8: ' FOR NOW ONLY SUPPORT UPTO 8 MICE
GetRawMouseIDs arrRawMouseID() ' GET MOUSE IDs
' INITIALIZE CURSORS, MOUSE STATE, ETC.
Restore CData
iIndex = LBound(arrInfo) - 1
For iLoop = 1 To iCount
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 iCount
iIndex = iIndex + 1
Read arrInfo(iIndex).x
Next iLoop
' INITIALIZE Y COORDINATES
Restore YData
iIndex = LBound(arrInfo) - 1
For iLoop = 1 To iCount
iIndex = iIndex + 1
Read arrInfo(iIndex).y
Next iLoop
' INITIALIZE SCROLL WHEEL
Restore WData
iIndex = LBound(arrInfo) - 1
For iLoop = 1 To iCount
iIndex = iIndex + 1
Read arrInfo(iIndex).wheel
Next iLoop
' DRAW PLAYING FIELD
_ScreenMove _Middle
Cls ' clear screen
Locate 1, 1: Print "1. PLUG 1-8 MICE INTO THE COMPUTER"
Locate 2, 1: Print "2. USE MICE TO POSITION LETTERS ON SCREEN"
Locate 3, 1: Print "3. PRESS <ESC> TO QUIT"
Locate 4, 1: Print "--------------------------------------------------------------------------------";
Locate 5, 1: Print "# X Y Wheel LeftDown MiddleDown RightDown LeftCount MiddleCount RightCount "
Locate 6, 1: Print "--------------------------------------------------------------------------------";
' 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
Do
iIndex = LBound(arrInfo) - 1
For iLoop = 1 To iCount
iIndex = iIndex + 1
' ERASE CURSORS AT CURRENT POSITION
Locate arrInfo(iIndex).y, arrInfo(iIndex).x: Print " ";
' GET NEXT MOUSE INPUT
ReadRawMouse arrRawMouseID(iIndex), x%, y%, left%, middle%, right%, wheel%, wheelmin%, wheelmax%
' HANDLE LEFT MOUSE BUTTON
If left% Then
If arrInfo(iIndex).LeftDown = FALSE Then
' BUTTON DOWN EVENT
arrInfo(iIndex).LeftDown = TRUE
arrInfo(iIndex).LeftCount = arrInfo(iIndex).LeftCount + 1
End If
Else
If arrInfo(iIndex).LeftDown = TRUE Then
' BUTTON UP EVENT
arrInfo(iIndex).LeftDown = FALSE
End If
End If
' HANDLE MIDDLE MOUSE BUTTON (SCROLL WHEEL BUTTON)
If middle% Then
If arrInfo(iIndex).MiddleDown = FALSE Then
' BUTTON DOWN EVENT
arrInfo(iIndex).MiddleDown = TRUE
arrInfo(iIndex).MiddleCount = arrInfo(iIndex).MiddleCount + 1
End If
Else
If arrInfo(iIndex).MiddleDown = TRUE Then
' BUTTON UP EVENT
arrInfo(iIndex).MiddleDown = FALSE
End If
End If
' HANDLE RIGHT MOUSE BUTTON
If right% Then
If arrInfo(iIndex).RightDown = FALSE Then
' BUTTON DOWN EVENT
arrInfo(iIndex).RightDown = TRUE
arrInfo(iIndex).RightCount = arrInfo(iIndex).RightCount + 1
End If
Else
If arrInfo(iIndex).RightDown = TRUE Then
' BUTTON UP EVENT
arrInfo(iIndex).RightDown = FALSE
End If
End If
' 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
Locate arrInfo(iIndex).y, arrInfo(iIndex).x: Print arrInfo(iIndex).c;
' DISPLAY VARIABLES
iLen = 3: sCount = Left$(LTrim$(RTrim$(Str$(iLoop))) + 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)
'LOCATE 5, 1: PRINT "# X Y Wheel LeftDown MiddleDown RightDown LeftCount MiddleCount RightCount "
Locate 6 + iLoop, 1: Print sCount + sX + sY + sWheel + sLeftDown + sMiddleDown + sRightDown + sLeftCount + sMiddleCount + sRightCount
Next iLoop
_Limit 100 ' keep loop at 100 frames per second
Loop Until _KeyDown(27) ' escape key exit
_KeyClear: '_DELAY 1
End Sub ' MouseRawInputTest
' /////////////////////////////////////////////////////////////////////////////
' 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 (really just the index)
' of each RawInput mouse device connected to the system (for now upto 8)
' and returns the IDs in an array of LONG
' If no mouse found, the ID will just be 0.
' *****************************************************************************
' 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)
Dim iLoop As Integer
' CLEAR OUT IDs
For iLoop = 1 To 8
arrRawMouseID(iLoop) = 0
Next iLoop
' GET IDs
'TODO: get this from RawInput API
arrRawMouseID(1) = 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 wheel% to be decremented to
' wheelmax% = maximum value to allow wheel% to be incremened to
' Parameters (values returned):
' x% = mouse x position
' y% = mouse y position
' left% = current state of left mouse button (up or down)
' middle% = current state of middle mouse button / scroll wheel button (up or down)
' right% = current state of right mouse button (up or down)
' wheel% = value of mouse scroll wheel (passed in and incremented/decremented by 1 if wheel move detected)
Sub ReadRawMouse (MouseID%, x%, y%, left%, middle%, right%, wheel%, 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
left% = FALSE
middle% = FALSE
right% = 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 (wheel% > wheelmin%) THEN
' wheel% = wheel% + scrollAmount%
' ELSEIF (scrollAmount% = 1) AND (wheel% < wheelmax%) THEN
' wheel% = wheel% + scrollAmount%
' END IF
'WEND
'
'' determine mouse x position
'x% = _MOUSEX
'
'' determine mouse y position
'y% = _MOUSEY
'
'' read mouse buttons
'left% = _MOUSEBUTTON(1)
'middle% = _MOUSEBUTTON(3)
'right% = _MOUSEBUTTON(2)
'
' END READ MOUSE THE OLD QB64 WAY:
' =============================================================================
End Sub ' ReadRawMouse
' /////////////////////////////////////////////////////////////////////////////
' Gets mouse input using _MOUSEX, _MOUSEY, _MOUSEBUTTON commands.
Sub MouseInputTest (in$)
' MIN/MAX VALUES
Const cMinX = 2
Const cMaxX = 79
Const cMinY = 16
Const cMaxY = 24
Const cMinWheel = 0
Const cMaxWheel = 255
' MAIN VARIABLES
Dim iCount As Integer ' # OF MICE ATTACHED
Dim arrMouseID(8) As String ' device IDs for mice connected to system (guessing this would be a string, dunno)
Dim arrInfo(8) As InfoType ' STORES INFO FOR EACH MOUSE
Dim left%, middle%, right% ' temp mouse variables
Dim iLoop As Integer
Dim iIndex As Integer
' TEMP VARIABLES FOR DISPLAYING FORMATTED VALUES TO SCREEN
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
' COUNT # OF MICE CONNECTED + GET DEVICE IDs
iCount = GetMouseCount% ' THIS FUNCTION WOULD ENUMERATE MICE, SHOULD RETURN 1+
If (iCount > 8) Then iCount = 8: ' FOR NOW ONLY SUPPORT UPTO 8 MICE
GetMouseIDs arrMouseID() ' GET MOUSE IDs
' INITIALIZE CURSORS, MOUSE STATE, ETC.
Restore CData
iIndex = LBound(arrInfo) - 1
For iLoop = 1 To iCount
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 iCount
iIndex = iIndex + 1
Read arrInfo(iIndex).x
Next iLoop
' INITIALIZE Y COORDINATES
Restore YData
iIndex = LBound(arrInfo) - 1
For iLoop = 1 To iCount
iIndex = iIndex + 1
Read arrInfo(iIndex).y
Next iLoop
' INITIALIZE SCROLL WHEEL
Restore WData
iIndex = LBound(arrInfo) - 1
For iLoop = 1 To iCount
iIndex = iIndex + 1
Read arrInfo(iIndex).wheel
Next iLoop
' DRAW PLAYING FIELD
_ScreenMove _Middle
Cls ' clear screen
Locate 1, 1: Print "1. PLUG 1-8 MICE INTO THE COMPUTER"
Locate 2, 1: Print "2. USE MICE TO POSITION LETTERS ON SCREEN"
Locate 3, 1: Print "3. PRESS <ESC> TO QUIT"
Locate 4, 1: Print "--------------------------------------------------------------------------------";
Locate 5, 1: Print "# X Y Wheel LeftDown MiddleDown RightDown LeftCount MiddleCount RightCount "
Locate 6, 1: Print "--------------------------------------------------------------------------------";
' 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
Do
iIndex = LBound(arrInfo) - 1
For iLoop = 1 To iCount
iIndex = iIndex + 1
' ERASE CURSORS AT CURRENT POSITION
Locate arrInfo(iIndex).y, arrInfo(iIndex).x: Print " ";
' GET NEXT MOUSE INPUT
If in$ = "1" Then
ReadMouse1 arrMouseID(iIndex), arrInfo(iIndex).x, arrInfo(iIndex).y, left%, middle%, right%, arrInfo(iIndex).wheel, cMinWheel, cMaxWheel
ElseIf in$ = "2" Then
ReadMouse2 arrMouseID(iIndex), arrInfo(iIndex).x, arrInfo(iIndex).y, left%, middle%, right%, arrInfo(iIndex).wheel, cMinWheel, cMaxWheel
End If
' HANDLE LEFT MOUSE BUTTON
If left% Then
If arrInfo(iIndex).LeftDown = FALSE Then
' BUTTON DOWN EVENT
arrInfo(iIndex).LeftDown = TRUE
arrInfo(iIndex).LeftCount = arrInfo(iIndex).LeftCount + 1
End If
Else
If arrInfo(iIndex).LeftDown = TRUE Then
' BUTTON UP EVENT
arrInfo(iIndex).LeftDown = FALSE
End If
End If
' HANDLE MIDDLE MOUSE BUTTON (SCROLL WHEEL BUTTON)
If middle% Then
If arrInfo(iIndex).MiddleDown = FALSE Then
' BUTTON DOWN EVENT
arrInfo(iIndex).MiddleDown = TRUE
arrInfo(iIndex).MiddleCount = arrInfo(iIndex).MiddleCount + 1
End If
Else
If arrInfo(iIndex).MiddleDown = TRUE Then
' BUTTON UP EVENT
arrInfo(iIndex).MiddleDown = FALSE
End If
End If
' HANDLE RIGHT MOUSE BUTTON
If right% Then
If arrInfo(iIndex).RightDown = FALSE Then
' BUTTON DOWN EVENT
arrInfo(iIndex).RightDown = TRUE
arrInfo(iIndex).RightCount = arrInfo(iIndex).RightCount + 1
End If
Else
If arrInfo(iIndex).RightDown = TRUE Then
' BUTTON UP EVENT
arrInfo(iIndex).RightDown = FALSE
End If
End If
' 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
Locate arrInfo(iIndex).y, arrInfo(iIndex).x: Print arrInfo(iIndex).c;
' DISPLAY VARIABLES
iLen = 3: sCount = Left$(LTrim$(RTrim$(Str$(iLoop))) + 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)
'LOCATE 5, 1: PRINT "# X Y Wheel LeftDown MiddleDown RightDown LeftCount MiddleCount RightCount "
Locate 6 + iLoop, 1: Print sCount + sX + sY + sWheel + sLeftDown + sMiddleDown + sRightDown + sLeftCount + sMiddleCount + sRightCount
Next iLoop
_Limit 100 ' keep loop at 100 frames per second
Loop Until _KeyDown(27) ' escape key exit
_KeyClear: '_DELAY 1
End Sub ' MouseInputTest
' /////////////////////////////////////////////////////////////////////////////
' Returns a count of # of mouse devices connected to the system
' *** Currently hardcoded to 1 until we figure out how to do this. ***
Function GetMouseCount% ()
GetMouseCount% = 1
End Function ' GetMouseCount%
' /////////////////////////////////////////////////////////////////////////////
' Gets ID of each mouse device connected to the system (for now upto 8)
' and returns the IDs in an array of strings
' (assuming the ID is a string and not numeric?).
' If no mouse found, the ID will just be a blank string.
' *** Currently hardcoded to "1" until we figure out how to do this. ***
Sub GetMouseIDs (arrMouseID( 8) As String)
Dim iLoop As Integer
' CLEAR OUT IDs
For iLoop = 1 To 8
arrMouseID(iLoop) = ""
Next iLoop
' GET IDs
arrMouseID(1) = "1" ' for now just fudge it!
End Sub ' GetMouseCount%
' /////////////////////////////////////////////////////////////////////////////
' Read mouse method #1, using _MOUSEX, _MOUSEY, etc.
' Gets input from mouse identified by deviceid$
' (or does that needs to be an ordinal position?)
' For version 1 we only return the input from the one mouse
' regardless of deviceid$.
' 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 (values returned):
' x% = x position of mouse pointer
' y% = y position of mouse pointer
' left% = current state of left mouse button (up or down)
' middle% = current state of middle mouse button / scroll wheel button (up or down)
' right% = current state of right mouse button (up or down)
' wheel% = value of mouse scroll wheel (passed in and incremented/decremented by 1 if wheel move detected)
' Parameters (input only):
' wheelmin% = minimum value to allow wheel% to be decremented to
' wheelmax% = maximum value to allow wheel% to be incremened to
Sub ReadMouse1 (deviceid$, x%, y%, left%, middle%, right%, wheel%, wheelmin%, wheelmax%)
Dim scrollAmount%
' 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 (wheel% > wheelmin%) Then
wheel% = wheel% + scrollAmount%
ElseIf (scrollAmount% = 1) And (wheel% < wheelmax%) Then
wheel% = wheel% + scrollAmount%
End If
Wend
' read x position
x% = _MouseX
' read y position
y% = _MouseY
' read mouse buttons
left% = _MouseButton(1)
middle% = _MouseButton(3)
right% = _MouseButton(2)
End Sub ' ReadMouse1
' /////////////////////////////////////////////////////////////////////////////
' Read mouse method #2, using _DEVICE commands.
' Gets input from mouse identified by deviceid$
' (or does that needs to be an ordinal position?)
' For version 1 we only return the input from the one mouse
' regardless of deviceid$.
' 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 (values returned):
' x% = x position of mouse pointer
' y% = y position of mouse pointer
' left% = current state of left mouse button (up or down)
' middle% = current state of middle mouse button / scroll wheel button (up or down)
' right% = current state of right mouse button (up or down)
' wheel% = value of mouse scroll wheel (passed in and incremented/decremented by 1 if wheel move detected)
' Parameters (input only):
' wheelmin% = minimum value to allow wheel% to be decremented to
' wheelmax% = maximum value to allow wheel% to be incremened to
Sub ReadMouse2 (deviceid$, x%, y%, left%, middle%, right%, wheel%, wheelmin%, wheelmax%)
Dim scrollAmount%
Dim ScreenWidth% ' screen width
Dim ScreenHeight% ' screen height
' read scroll wheel
While _DeviceInput(2) ' clear and update the mouse buffer
scrollAmount% = _Wheel(3)
If (scrollAmount% = -1) And (wheel% > wheelmin%) Then
wheel% = wheel% + scrollAmount%
ElseIf (scrollAmount% = 1) And (wheel% < wheelmax%) Then
wheel% = wheel% + scrollAmount%
End If
Wend ' clear and update the mouse buffer
' read x position
ScreenWidth% = _Width \ 2
x% = _Axis(1) * ScreenWidth% + ScreenWidth%
' read y position
ScreenHeight% = _Height \ 2
y% = _Axis(2) * ScreenHeight% + ScreenHeight%
' read mouse buttons
left% = _Button(1)
middle% = _Button(2)
right% = _Button(3)
End Sub ' ReadMouse2
' /////////////////////////////////////////////////////////////////////////////
' ORIGINAL VERSION OF FUNCTION FOR READING MOUSE WITH _DEVICE:
' Gets mouse input using _DEVICE commands (part 2 of 2, subroutine)
' SOURCE : https://www.qb64.org/forum/index.php?topic=1087.0
' Subject: Mouse demo using _DEVICE commands
' From : SMcNeill
' Date : February 21, 2019, 06:15:28 AM »
Sub UpdateMouseInfo (MouseX As Integer, MouseY As Integer, MOUSEWHEEL As Integer, LeftMouse As Integer, RightMouse As Integer, MiddleMouse As Integer, ClickThreshold As Single)
Dim SW As Integer, SH As Integer
Dim LM As Integer, MM As Integer, RM As Integer
Static leftdown As Single, middledown As Single, rightdown As Single
While _DeviceInput(2): MOUSEWHEEL = MOUSEWHEEL + _Wheel(3): Wend 'clear and update the mouse buffer
SW = _Width \ 2: SH = _Height \ 2
MouseX = _Axis(1) * SW + SW: MouseY = _Axis(2) * SH + SH
LM = _Button(1): MM = _Button(2): RM = _Button(3)
If leftdown Then 'if it was down
If LM = 0 Then 'and is now up
If Timer - leftdown < ClickThreshold Then
LeftMouse = 2 'clicked
Else 'if it's still down
LeftMouse = 0 'the mouse was just released
End If
leftdown = 0 'timer is cleared either way
Else
LeftMouse = 1 'the left mouse is down , timer should have already been set
End If
Else
If LM Then
leftdown = Timer 'set the timer to see if we have click or hold events
LeftMouse = 1 'the left mouse is down
Else
LeftMouse = 0
End If
End If
If middledown Then 'if it was down
If MM = 0 Then 'and is now up
If Timer - middledown < ClickThreshold Then
MiddleMouse = 2 'clicked
Else 'if it's still down
MiddleMouse = 0 'the mouse was just released
End If
middledown = 0 'timer is cleared either way
Else
MiddleMouse = 1 'the middle mouse is down , timer should have already been set
End If
Else
If MM Then
middledown = Timer 'set the timer to see if we have click or hold events
MiddleMouse = 1 'the middle mouse is down
Else
MiddleMouse = 0
End If
End If
If rightdown Then 'if it was down
If RM = 0 Then 'and is now up
If Timer - rightdown < ClickThreshold Then
RightMouse = 2 'clicked
Else 'if it's still down
RightMouse = 0 'the mouse was just released
End If
rightdown = 0 'timer is cleared either way
Else
RightMouse = 1 'the right mouse is down , timer should have already been set
End If
Else
If RM Then
rightdown = Timer 'set the timer to see if we have click or hold events
RightMouse = 1 'the right mouse is down
Else
RightMouse = 0
End If
End If
End Sub ' UpdateMouseInfo
' /////////////////////////////////////////////////////////////////////////////
' Example: Checking for the system's input devices.
' _DEVICES FUNCTION (QB64 REFERENCE)
' http://www.qb64.net/wiki/index_title_DEVICES/
'
' The _DEVICES function returns the number of INPUT devices on your computer
' including keyboard, mouse and game devices.
'
' Syntax:
'
' device_count% = _DEVICES
'
' Returns the number of devices that can be listed separately with the _DEVICE$
' function by the device number.
' Devices include keyboard, mouse, joysticks, game pads and multiple stick game
' controllers.
' Note: This function MUST be read before trying to use the _DEVICE$,
' _DEVICEINPUT or _LAST control functions!
' Note: The STRIG/STICK commands won't read from the keyboard
' or mouse device the above example lists.
Sub EnumerateDevices
Dim devices%
Dim iLoop%
Dim sCount$
Dim iLen As Integer
devices% = _Devices ' MUST be read in order for other 2 device functions to work!
Cls
Print "Total devices found: "; Str$(devices%)
For iLoop% = 1 To devices%
iLen = 4
sCount$ = Left$(LTrim$(RTrim$(Str$(iLoop%))) + String$(iLen, " "), iLen)
Print sCount$ + _Device$(iLoop%) + " (" + LTrim$(RTrim$(Str$(_LastButton(iLoop%)))) + " buttons)"
Next iLoop%
Print
Print "PRESS <ESC> TO CONTINUE"
Do: Loop Until _KeyDown(27) ' leave loop when ESC key pressed
_KeyClear: '_DELAY 1
End Sub ' EnumerateDevices
' /////////////////////////////////////////////////////////////////////////////
' 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$)
'bError% = FALSE
'LOCATE 2, 2: PRINT "(" + STR$(x%) + "," + STR$(y%) + ") to (" + STR$(x2%) + "," + STR$(y2%) + ") of " + CHR$(34) + c$ + CHR$(34);
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$;
Else
'PSET (x%, y%), c%
Locate x%, y%
Print 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$;
End Sub ' DrawTextLine
' ################################################################################################################################################################
' #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: 439
Threads: 17
Joined: Apr 2022
Reputation:
21
I structured it this way as a direct translation of that other C program so as to make some of the more complicated aspects easier to understand. It can definitely be edited to be closer to how a QB64 program is usually structured. I am just more used to converting C/C++ examples to QB64 so I'm now in the habit of programming like a C coder more than a BASIC coder. I'm more comfortable that way. I'll have to look at your code and see what is going so I can attempt to make it more QB64 friendly.
By the way, something I just noticed is that you have System on the line above your Print and End. Print and End won't be hit since System closes the program entirely.
Ask me about Windows API and maybe some Linux stuff
Posts: 529
Threads: 67
Joined: Apr 2022
Reputation:
11
09-08-2022, 08:56 PM
(This post was last modified: 09-08-2022, 09:05 PM by madscijr.)
(09-08-2022, 08:49 PM)Spriggsy Wrote: I structured it this way as a direct translation of that other C program so as to make some of the more complicated aspects easier to understand. It can definitely be edited to be closer to how a QB64 program is usually structured. I am just more used to converting C/C++ examples to QB64 so I'm now in the habit of programming like a C coder more than a BASIC coder. I'm more comfortable that way. I'll have to look at your code and see what is going so I can attempt to make it more QB64 friendly.
Any help or guidance with that part would be a godsend, because I am totally out of my element here...
(09-08-2022, 08:49 PM)Spriggsy Wrote: By the way, something I just noticed is that you have System on the line above your Print and End. Print and End won't be hit since System closes the program entirely.
That was something I learned since I originally made this program almost a year go, I just forgot to clean that up.
I reuse stuff a lot and cut/paste code a lot, and sometimes I miss stuff.
Just like how you mentioned how your own coding had changed since you made that old program of yours I had saved -
I look at things I wrote 2 years or even 3 months ago and it reminds me how much I've learned since then.
The real fun is looking at code you wrote back in school, or when you had your first job.
It really brings you back and shows how far you've come.
Posts: 439
Threads: 17
Joined: Apr 2022
Reputation:
21
(09-08-2022, 08:56 PM)madscijr Wrote: The real fun is looking at code you wrote back in school, or when you had your first job. It really brings you back!
Hahaha! Definitely. I sometimes find some of my first programs and I cringe so much when I see how badly they were written.
Ask me about Windows API and maybe some Linux stuff
Posts: 529
Threads: 67
Joined: Apr 2022
Reputation:
11
(09-08-2022, 09:01 PM)Spriggsy Wrote: (09-08-2022, 08:56 PM)madscijr Wrote: The real fun is looking at code you wrote back in school, or when you had your first job. It really brings you back!
Hahaha! Definitely. I sometimes find some of my first programs and I cringe so much when I see how badly they were written.
We have to learn somehow!
PS I dove into this code for a couple hours, to find out England has a new king! RIP QE2!
Posts: 439
Threads: 17
Joined: Apr 2022
Reputation:
21
I have yet again made another edit to the code. This version now prints the device handles and types to the screen as well as displays the X, Y coordinates from WM_MOUSEMOVE.
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)
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
![[Image: Screenshot-2022-09-08-171450.png]](https://i.ibb.co/JF0BnN7/Screenshot-2022-09-08-171450.png)
Ask me about Windows API and maybe some Linux stuff
Posts: 529
Threads: 67
Joined: Apr 2022
Reputation:
11
(09-08-2022, 09:15 PM)Spriggsy Wrote: I have yet again made another edit to the code. This version now prints the device handles and types to the screen as well as displays the X, Y coordinates from WM_MOUSEMOVE.
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)
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
So instead of an ordinal index to track & identify each mouse, we can use a unique device handle.
Looking good!
Posts: 529
Threads: 67
Joined: Apr 2022
Reputation:
11
09-08-2022, 10:20 PM
(This post was last modified: 09-08-2022, 10:21 PM by madscijr.)
(09-08-2022, 09:15 PM)Spriggsy Wrote: I have yet again made another edit to the code.
This version now prints the device handles and types to the screen as well as displays the X, Y coordinates from WM_MOUSEMOVE.
I don't understand all the parameters, but I think the main thing to tie in a regular QB64 program to the RawInput mouse routines, after taking away all the event-driven stuff, would be the window handle for the QB64 program. QB64 has a function _WindowHandle which provides that - will that work with RawInput? Will it return a valid window handle even in _FullScreen _SquarePixels mode?
|
