+- QB64 Phoenix Edition (https://qb64phoenix.com/forum)
+-- Forum: QB64 Rising (https://qb64phoenix.com/forum/forumdisplay.php?fid=1)
+--- Forum: Code and Stuff (https://qb64phoenix.com/forum/forumdisplay.php?fid=3)
+---- Forum: Help Me! (https://qb64phoenix.com/forum/forumdisplay.php?fid=10)
+---- Thread: why are these API declarations causing compilation to fail? (/showthread.php?tid=2733)
why are these API declarations causing compilation to fail? - madscijr - 05-24-2024
The program "readmicesub35.bas" in the code listing below is giving a "c++ compilation failed" error.
"compilelog.txt":
Code: (Select All)
internal\c\c_compiler\bin\c++.exe -std=gnu++17 -fno-strict-aliasing -Wno-conversion-null -DGLEW_STATIC -DFREEGLUT_STATIC -Iinternal\c\libqb/include -Iinternal\c/parts/core/freeglut/include -Iinternal\c/parts/core/glew/include -DDEPENDENCY_SOCKETS -DDEPENDENCY_NO_PRINTER -DDEPENDENCY_NO_ICON -DDEPENDENCY_NO_SCREENIMAGE -DDEPENDENCY_AUDIO_MINIAUDIO internal\c/qbx.cpp -c -o internal\c/qbx.o
In file included from internal\c/qbx.cpp:739:
internal\c/../temp/regsf.txt:62:11: error: redefinition of 'HINSTANCE__* DLL_user32'
62 | HINSTANCE DLL_user32=NULL;
| ^~~~~~~~~~
internal\c/../temp/regsf.txt:54:11: note: 'HINSTANCE__* DLL_user32' previously defined here
54 | HINSTANCE DLL_user32=NULL;
| ^~~~~~~~~~
mingw32-make: *** [Makefile:402: internal\c/qbx.o] Error 1I did a file comparison and the only difference with the previous version that compiles & runs are a few short lines:
![[Image: readmisesub34c-vs-35.png]](https://i.ibb.co/tpfQK2K/readmisesub34c-vs-35.png)
New lines causing "readmicesub35.bas" compilation to fail:
Code: (Select All)
273 ' FOR CONTROLLING WINDOW ON TOP, ETC.
274 ' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
275 Declare Dynamic Library "user32"
276 'Function FindWindowA%& (ByVal lpClassName%&, Byval lpWindowName%&)
277 Function SetWindowPos& (ByVal hWnd%&, Byval hWndInsertAfter%&, Byval X&, Byval Y&, Byval cx&, Byval cy&, Byval uFlags~&)
278 Function GetForegroundWindow%&
279 End Declare
280
281 Declare Dynamic Library "kernel32"
282 Function GetLastError~& ()
283 End Declare
586 SetWindowOpacity hwndMain, cTransparent
601 ' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
602 ' MOVE WINDOW TO TOP
603 ' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
604 '' GET WINDOW HANDLES
605 'hWndThis = _WindowHandle ' FindWindowA(0, _OFFSET(t))
606 hWndTop = GetForegroundWindow%& ' find currently focused process handle
608 ' GET FOCUS
609 If hwndMain <> hWndTop Then
610 _ScreenClick 240, 240 ' add 40 to x and y to focus on positioned window
611 End If
613 ' MOVE TO TOP
614 If SetWindowPos(hwndMain, HWND_TOPMOST, 200, 200, 0, 0, SWP_NOSIZE Or SWP_NOACTIVATE) = 0 Then
615 'sNextError = "SetWindowPos failed. 0x" + LCase$(Hex$(GetLastError))
616 m_sError = "SetWindowPos failed. 0x" + LCase$(Hex$(GetLastError))
617 End IfI added those API calls to try to force the ReadMiceSub window to keep the focus, and also make the window transparent (invisible) so that the ReadMiceMain window is what the user sees, but when they move their mouse, the ReadMiceSub can read the mice values since it has the focus. Steffan-68 provided some sample code which I had success with and I wanted to use that for this program.
If anyone can shed some light on why those lines are causing it to fail, that would be great, because I just used those same API functions in another program (see here) and they worked fine.
Why won't it compile in a different program?
ANY help would be much appreciated because I've been banging my head against a wall for the past hour...
Below are the 2 files - the readmicesub35 that won't compile, and the previous version readmicesub34c that works.
(The attached ZIP file has everything for the project).
"ReadMiceSub35.bas" compilation failed:
Code: (Select All)
' ################################################################################################################################################################
' Multimouse sub-program "ReadMiceSub.bas"
' ################################################################################################################################################################
' -------------------------------------------------------------------------------
' ABOUT
' -------------------------------------------------------------------------------
' (Subprogram for READMICEMAIN.BAS, see that for more info.)
Option Explicit
_Title "readmice"
$NoPrefix
'$Console:Only
'Console Off
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN CONSTANTS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Const cProgName = "ReadMiceSub"
Const FALSE = 0
Const TRUE = Not FALSE
Const cInvisible = 0
Const cTransparent = 160
Const cVisible = 255
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' FOR CONTROLLING WINDOW ON TOP, ETC.
Const SWP_NOSIZE = &H0001 'ignores cx and cy size parameters
'Const SWP_NOMOVE = &H0002 'ignores x and y position parameters
'Const SWP_NOZORDER = &H0004 'keeps z order and ignores hWndInsertAfter parameter
'Const SWP_NOREDRAW = &H0008 'does not redraw window changes
Const SWP_NOACTIVATE = &H0010 'does not activate window
'Const SWP_FRAMECHANGED = &H0020
'Const SWP_SHOWWINDOW = &H0040
'Const SWP_HIDEWINDOW = &H0080
'Const SWP_NOCOPYBITS = &H0100
'Const SWP_NOOWNERZORDER = &H0200
'Const SWP_NOSENDCHANGING = &H0400
'Const SWP_DRAWFRAME = SWP_FRAMECHANGED
'Const SWP_NOREPOSITION = SWP_NOOWNERZORDER
'Const SWP_DEFERERASE = &H2000
'Const SWP_ASYNCWINDOWPOS = &H4000
Const HWND_TOP = 0 'window at top of z order no focus
Const HWND_BOTTOM = 1 'window at bottom of z order no focus
Const HWND_TOPMOST = -1 'window above all others no focus unless active
Const HWND_NOTOPMOST = -2 'window below active no focus
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' FOR RAW INPUT API
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 ' Raw input comes from the mouse.
Const RIM_TYPEKEYBOARD = 1 ' Raw input comes from the keyboard.
Const RIM_TYPEHID = 2 ' Raw input comes from some device that is not a keyboard or a mouse.
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 = 1
Const cMaxX = 80
Const cMinY = 1
Const cMaxY = 30 ' 24
Const cMinWheel = 0
Const cMaxWheel = 255
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' CONSTANT FOR 2ND DIMENSION OF arrFile ARRAY
Const cFileName = 0
Const cFileData = 1
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END CONSTANTS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN UDTs
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Type RAWINPUTDEVICE
As Unsigned Integer usUsagePage, usUsage
As Unsigned Long dwFlags
As Offset hwndTarget ' <- WHAT IS Offset VS _Offset ?
End Type
Type RAWINPUTDEVICELIST
As Offset hDevice
As Unsigned Long dwType
$If 64BIT Then
As String * 4 alignment
$End If
End Type
Type POINT
As Long x, y
End Type
Type MSG
As Offset hwnd
As Unsigned Long message
As Unsigned Offset wParam
As Offset lParam
As Long time
As POINT pt
As Long lPrivate
End Type
Type WNDCLASSEX
As Unsigned Long cbSize, style
As Offset lpfnWndProc
As Long cbClsExtra, cbWndExtra
As Offset hInstance, hIcon, hCursor, hbrBackground, lpszMenuName, lpszClassName, hIconSm
End Type
Type RECT
As Long left, top, right, bottom
End Type
Type PAINTSTRUCT
As Offset hdc
As Long fErase
$If 64BIT Then
As String * 4 alignment
$End If
As RECT rcPaint
As Long fRestore, fIncUpdate
As String * 32 rgbReserved
End Type
Type RAWINPUTHEADER
As Unsigned Long dwType, dwSize
As Offset hDevice
As Unsigned Offset wParam
End Type
Type RAWMOUSE
As Unsigned Integer usFlags
$If 64BIT Then
As String * 2 alignment
$End If
'As Unsigned Long ulButtons 'commented out because I'm creating this value using MAKELONG
As Unsigned Integer usButtonFlags, usButtonData
As Unsigned Long ulRawButtons
As Long lLastX, lLastY
As Unsigned Long ulExtraInformation
End Type
Type RAWINPUT
As RAWINPUTHEADER header
As RAWMOUSE mouse
End Type
' UDT TO HOLD THE INFO FOR EACH MOUSE
Type MouseInfoType
UpdateCount As Integer ' if this value changes we know a value changed
ID As String ' mouse device ID
c As String ' cursor character
x As Integer ' screen x position
y As Integer ' screen y position
dx As Integer ' mouse x movement -1=left, 1=right, 0=none
dy As Integer ' mouse y movement -1=up , 1=down , 0=none
wheel As Integer ' mouse wheel value
LeftDown As Integer ' tracks left mouse button state, TRUE=down
MiddleDown As Integer ' tracks middle mouse button state, TRUE=down
RightDown As Integer ' tracks right mouse button state, TRUE=down
LeftCount As Integer ' counts left clicks
MiddleCount As Integer ' counts middle clicks
RightCount As Integer ' counts right clicks
End Type ' MouseInfoType
' UDT TO HOLD THE INFO FOR EACH KEYBOARD
Type KeyboardInfoType
UpdateCount As Integer ' if this value changes we know a value changed
ID As String ' keyboard device ID
'TBD
End Type ' KeyboardInfoType
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END UDTs
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN API DECLARATIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' FOR RAW INPUT API
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
Declare CustomType Library
Function GetRawInputDeviceList~& (ByVal pRawInputDeviceList As Offset, Byval puiNumDevices As Offset, Byval cbSize As Unsigned Long)
Sub GetRawInputDeviceList (ByVal pRawInputDeviceList As Offset, Byval puiNumDevices As Offset, Byval cbSize As Unsigned Long)
Function RegisterRawInputDevices& (ByVal pRawInputDevices As Offset, Byval uiNumDevices As Unsigned Long, Byval cbSize As Unsigned Long)
Function GetModuleHandle%& (ByVal lpModulename As Offset)
Function LoadIcon%& (ByVal hInstance As Offset, Byval lpIconName As Offset)
Function LoadCursor%& (ByVal hInstance As Offset, Byval lpCursorName As Offset)
Function RegisterClassEx~% (ByVal wndclassex As Offset)
Function CreateWindowEx%& (ByVal dwExStyle As Unsigned Long, Byval lpClassName As Offset, Byval lpWindowName As Offset, Byval dwStyle As Unsigned Long, Byval x As Long, Byval y As Long, Byval nWidth As Long, Byval nHeight As Long, Byval hWndParent As Offset, Byval hMenu As Offset, Byval hInstance As Offset, Byval lpParam As Offset)
Sub ShowWindow (ByVal hWnd As Offset, Byval nCmdShow As Long)
Sub UpdateWindow (ByVal hWnd As Offset)
Function GetMessage& (ByVal lpMsg As Offset, Byval hWnd As Offset, Byval wMsgFilterMin As Unsigned Long, Byval wMsgFilterMax As Unsigned Long)
Sub TranslateMessage (ByVal lpMsg As Offset)
Sub DispatchMessage (ByVal lpMsg As Offset)
Sub PostQuitMessage (ByVal nExitCode As Long)
Function DefWindowProc%& (ByVal hWnd As Offset, Byval Msg As Unsigned Long, Byval wParam As Unsigned Offset, Byval lParam As Offset)
Sub GetRawInputData (ByVal hRawInput As Offset, Byval uiCommand As Unsigned Long, Byval pData As Offset, Byval pcbSize As Offset, Byval cbSizeHeader As Unsigned Long)
Function GetRawInputData~& (ByVal hRawInput As Offset, Byval uiCommand As Unsigned Long, Byval pData As Offset, Byval pcbSize As Offset, Byval cbSizeHeader As Unsigned Long)
Sub InvalidateRect (ByVal hWnd As Offset, Byval lpRect As Offset, Byval bErase As Long)
Sub SendMessage (ByVal hWnd As Offset, Byval Msg As Unsigned Long, Byval wParam As Unsigned Offset, Byval lParam As Offset)
Function BeginPaint%& (ByVal hWnd As Offset, Byval lpPaint As Offset)
Sub GetClientRect (ByVal hWnd As Offset, Byval lpRect As Offset)
Sub DrawText (ByVal hdc As Offset, Byval lpchText As Offset, Byval cchText As Long, Byval lprc As Offset, Byval format As Unsigned Long)
Sub OffsetRect (ByVal lprc As Offset, Byval dx As Long, Byval dy As Long)
Sub EndPaint (ByVal hWnd As Offset, Byval lpPaint As Offset)
End Declare
' Header file "makeint.h" must be in same folder as this program.
Declare CustomType Library ".\makeint"
Function MAKEINTRESOURCE%& Alias "MAKEINTRSC" (ByVal i As _Offset)
End Declare
Declare Library
Function MAKELPARAM%& (ByVal l As Integer, Byval h As Integer)
Function MAKELONG~& (ByVal l As Unsigned Integer, Byval h As Unsigned Integer)
End Declare
$If 64BIT Then
Declare Library ".\internal\c\c_compiler\x86_64-w64-mingw32\include\windowsx"
$Else
Declare Library ".\internal\c\c_compiler\i686-w64-mingw32\include\windowsx"
$End If
Function GET_Y_LPARAM& (ByVal lp As Offset)
Function GET_X_LPARAM& (ByVal lp As Offset)
End Declare
' Header file "winproc.h" must be in same folder as this program.
Declare Library ".\winproc"
Function WindowProc%& ()
End Declare
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' FOR CONTROLLING WINDOW ON TOP, ETC.
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
Declare Dynamic Library "user32"
'Function FindWindowA%& (ByVal lpClassName%&, Byval lpWindowName%&)
Function SetWindowPos& (ByVal hWnd%&, Byval hWndInsertAfter%&, Byval X&, Byval Y&, Byval cx&, Byval cy&, Byval uFlags~&)
Function GetForegroundWindow%&
End Declare
Declare Dynamic Library "kernel32"
Function GetLastError~& ()
End Declare
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' To keep focus on window
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
'Declare Dynamic Library "user32"
' Sub ShowWindow (ByVal hWnd As _Offset, Byval nCmdShow As Long)
'End Declare
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' To make window invisible
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
Declare Dynamic Library "user32"
Function SetLayeredWindowAttributes& (ByVal hwnd As _Offset, Byval crKey As Long, Byval bAlpha As _Unsigned _Byte, Byval dwFlags As Long)
Function GetWindowLong& Alias "GetWindowLongA" (ByVal hwnd As _Offset, Byval nIndex As Long)
Function SetWindowLong& Alias "SetWindowLongA" (ByVal hwnd As _Offset, Byval nIndex As Long, Byval dwNewLong As Long)
End Declare
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' Needed for acquiring the hWnd of the window
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
Declare Library
Function FindWindow& (ByVal ClassName As _Offset, WindowName$) ' To get hWnd handle
End Declare
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END API DECLARATIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN GLOBAL VARIABLES
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BASIC PROGRAM METADATA
Dim Shared m_ProgramPath$: m_ProgramPath$ = Left$(Command$(0), _InStrRev(Command$(0), "\"))
Dim Shared m_ProgramName$: m_ProgramName$ = Mid$(Command$(0), _InStrRev(Command$(0), "\") + 1)
Dim Shared m_sTriggerFile As String: m_sTriggerFile = m_ProgramPath$ + "ReadMiceSub.DELETE-TO-CLOSE"
' GLOBAL VARIABLES TO TRACK ERROR STATE
Dim Shared m_sError As String: m_sError = ""
Dim Shared m_sIncludeError As String: m_sIncludeError = ""
' RAW INPUT VARIABLES
Dim Shared mousemessage As String
Dim Shared rawinputdevices As String
' MOUSE VARIABLES
Dim Shared arrMouse(0 To 8) As MouseInfoType ' STORES INFO FOR EACH MOUSE
'Dim Shared arrRawMouseID(8) As Long ' device IDs for mice connected to system (guessing this would be a string, dunno)
Dim Shared iMouseCount As Integer ' # OF MICE ATTACHED
' KEYBOARD VARIABLES
Dim Shared arrKeyboard(0 To 8) As KeyboardInfoType ' STORES INFO FOR EACH KEYBOARD
Dim Shared iKeyboardCount As Integer ' # OF KEYBOARDS ATTACHED
Dim Shared arrKeyState(0 To 8, 1 To 512) As Integer ' arrKeyState({device#}, {keyCode}) = TRUE if key {keyCode} on keyboard {device#} is currently held down.
Dim Shared arrScreen(1 To 80, 1 To 25) As String ' STORES TEXT FOR SCREEN
Dim Shared iMinX As Long
Dim Shared iMaxX As Long
Dim Shared iMinY As Long
Dim Shared iMaxY As Long
' RAW FILE NAMES
Dim Shared arrFile(0 To 31, 0 To 1) As String
' NETWORK VARIABLES
Dim Shared uintPort As _Unsigned Integer ' port
Dim Shared lngConn As Long ' c&
Dim Shared iData As Integer ' i
Dim Shared sOutput As String ' s$
' HANDLE FOR THE PROGRAM WINDOW
Dim Shared MyHwnd As _Offset ' _Integer64 hwnd%&
'Dim As Offset hwndMain
Dim Shared hwndMain As _Offset
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END GLOBAL VARIABLES
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' EXECUTION STARTS HERE!
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' =============================================================================
' START THE MAIN ROUTINE
main
' =============================================================================
' FINISH
'Print m_ProgramName$ + " finished."
'End
System ' return control to the operating system
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN GLOBAL ERROR HANDLER
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
ErrorHandler:
m_sError = "Error #" + _Trim$(Str$(Err)) + " at line " + _Trim$(Str$(_ErrorLine)) + "."
m_sIncludeError = "File " + Chr$(34) + _InclErrorFile$ + Chr$(34) + " at line " + _Trim$(Str$(_InclErrorLine)) + "."
Resume Next
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END GLOBAL ERROR HANDLER
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN DATA STATEMENTS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' MOUSE CURSORS (JUST SOME LETTERS)
CData:
Data A,b,C,D,E,f,G,H
' DEFAULT/INTIAL X COORDINATE OF EACH CURSOR ON SCREEN
XData:
Data 5,15,25,35,45,55,65,75
' DEFAULT/INTIAL Y COORDINATE OF EACH CURSOR ON SCREEN
YData:
Data 17,17,19,19,21,21,23,23
' DEFAULT/INITIAL VALUE OF EACH SCROLL WHEEL
WData:
Data 224,192,160,128,96,64,32,0
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END DATA STATEMENTS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN MAIN ROUTINES
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' /////////////////////////////////////////////////////////////////////////////
Sub main
Dim sPort As String
Dim iLoop As Integer
Dim in$
' MAKE SURE WE HAVE INPUT
sPort = Command$(1)
If Len(sPort) > 0 Then
If IsNumber%(sPort) = TRUE Then
' OPEN CONNECTION
uintPort = Val(sPort)
lngConn = _OpenClient("tcp/ip:" + _Trim$(Str$(uintPort)) + ":localhost")
Print lngConn
' ****************************************************************************************************************************************************************
' ****************************************************************************************************************************************************************
' RETHINK DATA STRUCTURE
' ****************************************************************************************************************************************************************
' ****************************************************************************************************************************************************************
' INITIALIZE
For iLoop = LBound(arrFile) To UBound(arrFile)
arrFile(iLoop, cFileName) = m_ProgramPath$ + "mouse" + _Trim$(Str$(iLoop)) + ".txt"
arrFile(iLoop, cFileData) = ""
Next iLoop
' INITIALIZE
iMinX = 0
iMaxX = 3583
iMinY = 0
iMaxY = 8202
' ****************************************************************************************************************************************************************
' ****************************************************************************************************************************************************************
' SET UP WINDOW TO BE SAME SIZE AS, AND OVERLAPPED WITH HOST WINDOW
' ****************************************************************************************************************************************************************
' ****************************************************************************************************************************************************************
' SET UP WINDOW
'Screen _NewImage(1024, 768, 32)
Screen 12 ' SCREEN 12 can use 16 color attributes with a black background. 256K possible RGB color hues. Background colors can be used with QB64.
' window needs to be lined up directly under the main program, so the mouse coordinates align with the display
_ScreenMove 0, 0 ' <<< NOT WORKING, HOW DO WE DO THIS IN THE EVENT MODEL?
' CREATE TRIGGER FILE
Open m_sTriggerFile For Output As #1
Print #1, "Deleting this file will cause program " + m_ProgramName$ + " to stop running."
Close #1
' GET HANDLE TO THE PROGRAM WINDOW
Do
MyHwnd = _WindowHandle
Loop Until MyHwnd
' GIVE CONTROL TO THE EVENT-ORIENTED CODE
System Val(Str$(WinMain))
Else
Print "Invalid non-numeric input " + Chr$(34) + sPort + Chr$(34) + ". Exiting."
End If
Else
Print "No input. Exiting."
End If
End Sub ' main
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END MAIN ROUTINES
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN RAW INPUT FUNCTIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' /////////////////////////////////////////////////////////////////////////////
' Runs first
Function WinMain~%& ()
'Dim As Offset hwndMain
Dim As Offset hInst
Dim As Offset hWndTop
Dim As MSG msg
Dim As WNDCLASSEX wndclass
Dim As String szMainWndClass
Dim As String szWinTitle
Dim As Unsigned Integer reg
Dim sData As String
'DEBUG: TRY FULL SCREEN <- PROGRAM CRASHES!
'_FullScreen _SquarePixels
hInst = GetModuleHandle(0)
szMainWndClass = "WinTestWin" + Chr$(0)
'szWinTitle = "Hello" + Chr$(0)
szWinTitle = cProgName + Chr$(0)
wndclass.lpszClassName = Offset(szMainWndClass)
wndclass.cbSize = Len(wndclass)
wndclass.style = CS_HREDRAW Or CS_VREDRAW
wndclass.lpfnWndProc = WindowProc
wndclass.hInstance = hInst 'GetModuleHandle(0) will return the hInstance of this EXE
wndclass.hIcon = LoadIcon(0, MAKEINTRESOURCE(IDI_APPLICATION))
wndclass.hIconSm = LoadIcon(0, MAKEINTRESOURCE(IDI_APPLICATION))
wndclass.hCursor = LoadCursor(0, MAKEINTRESOURCE(IDC_ARROW))
wndclass.hbrBackground = COLOR_WINDOW + 1
reg = RegisterClassEx(Offset(wndclass)) 'I prefer to use the output of RegisterClassEx rather than the window name
'DEBUG: SUBSTITUTE _WindowHandle
'Function CreateWindowEx%& (
' ByVal dwExStyle As Unsigned Long = 0
' Byval lpClassName As Offset = MAKELPARAM(reg, 0)
' Byval lpWindowName As Offset = Offset(szWinTitle)
' Byval dwStyle As Unsigned Long = WS_OVERLAPPEDWINDOW
' Byval x As Long = CW_USEDEFAULT
' Byval y As Long = CW_USEDEFAULT
' Byval nWidth As Long = CW_USEDEFAULT
' Byval nHeight As Long = CW_USEDEFAULT
' Byval hWndParent As Offset = 0
' Byval hMenu As Offset = 0
' Byval hInstance As Offset = hInst
' Byval lpParam As Offset = 0
' hwndMain = CreateWindowEx( _
' 0, _
' MAKELPARAM(reg, 0), _
' Offset(szWinTitle), _
' WS_OVERLAPPEDWINDOW, _
' CW_USEDEFAULT, _
' CW_USEDEFAULT, _
' CW_USEDEFAULT, _
' CW_USEDEFAULT, _
' 0, _
' 0, _
' hInst, _
' 0)
hwndMain = CreateWindowEx( _
0, _
MAKELPARAM(reg, 0), _
Offset(szWinTitle), _
WS_OVERLAPPEDWINDOW, _
0, _
0, _
1024, _
768, _
0, _
0, _
hInst, _
0)
'hwndMain = _WindowHandle
ShowWindow hwndMain, SW_SHOW
' TURN SUB WINDOW INVISIBLE
''SetWindowOpacity MyHwnd, cInvisible
'SetWindowOpacity hwndMain, cInvisible
SetWindowOpacity hwndMain, cTransparent
' KEEP WINDOW VISIBLE
UpdateWindow hwndMain
'DEBUG: SUBSTITUTE _WindowHandle
'UpdateWindow _WindowHandle
'' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
'' SEND SUB WINDOW HANDLE BACK TO MAIN
'sData = _Trim$(Str$(hwndMain))
'Put #lngConn, , sData
'' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' MOVE WINDOW TO TOP
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
'' GET WINDOW HANDLES
'hWndThis = _WindowHandle ' FindWindowA(0, _OFFSET(t))
hWndTop = GetForegroundWindow%& ' find currently focused process handle
' GET FOCUS
If hwndMain <> hWndTop Then
_ScreenClick 240, 240 ' add 40 to x and y to focus on positioned window
End If
' MOVE TO TOP
If SetWindowPos(hwndMain, HWND_TOPMOST, 200, 200, 0, 0, SWP_NOSIZE Or SWP_NOACTIVATE) = 0 Then
'sNextError = "SetWindowPos failed. 0x" + LCase$(Hex$(GetLastError))
m_sError = "SetWindowPos failed. 0x" + LCase$(Hex$(GetLastError))
End If
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' START THE INPUT ROUTINES
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
InitRawInput
InitMouseTest 'TODO: SAVE_MOUSE_INFO
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' MAIN LOOP
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
While GetMessage(Offset(msg), 0, 0, 0)
TranslateMessage Offset(msg)
DispatchMessage Offset(msg)
' QUIT IF TRIGGER FILE IS GONE
If _FileExists(m_sTriggerFile) = FALSE Then
System
End If
' SEE IF WE CAN DETECT KEYPRESSES
' IF USER PRESSES A THEN SHOW WINDOW
If _KeyDown(65) Or _KeyDown(97) Then
Beep
'SetWindowOpacity MyHwnd, cVisible
End If
' IF USER PRESSES B THEN MAKE WINDOW TRANSPARENT
If _KeyDown(66) Or _KeyDown(98) Then
Beep
Beep
'SetWindowOpacity MyHwnd, cTransparent
End If
' IF USER PRESSES C THEN HIDE WINDOW
If _KeyDown(67) Or _KeyDown(99) Then
Beep
Beep
Beep
'SetWindowOpacity MyHwnd, cInvisible
End If
' IF USER PRESSES ESCAPE THEN EXIT
If _KeyDown(27) Then
DeleteFile m_sTriggerFile
'System
End If
' KEEP WINDOW ON TOP
If _WindowHasFocus = 0 Then
_ScreenIcon
''ShowWindow MyHwnd, 1
'ShowWindow hwndMain, 1
ShowWindow hwndMain, SW_SHOW
End If
Wend
WinMain = msg.wParam
End Function ' WinMain
' /////////////////////////////////////////////////////////////////////////////
' Handles main window events
Function MainWndProc%& (hwnd As Offset, nMsg As Unsigned Long, wParam As Unsigned Offset, lParam As Offset)
Static As Offset hwndButton
Static As Long cx, cy
Dim As Offset hdc
Dim As PAINTSTRUCT ps
Dim As RECT rc
Dim As MEM lpb
Dim As Unsigned Long dwSize
Dim As RAWINPUT raw
Dim As Long tmpx, tmpy
Static As Long maxx
Dim As RAWINPUTHEADER rih
' TEMP VARIABLES FOR DISPLAYING FORMATTED VALUES TO SCREEN
Dim strNextID As String
Dim iIndex As Integer
Dim iRowOffset As Integer
Dim iLen As Integer
Dim sCount As String
Dim sX As String
Dim sY As String
Dim sWheel As String
Dim sLeftDown As String
Dim sMiddleDown As String
Dim sRightDown As String
Dim sLeftCount As String
Dim sMiddleCount As String
Dim sRightCount As String
Dim sNext As String
Dim iNewX As Integer
Dim iNewY As Integer
Dim iDX As Integer
Dim iDY As Integer
' MORE TEMP VARIABLES
Dim iMouseNum As Integer
' HANDLE EVENTS
Select Case nMsg
Case WM_DESTROY
PostQuitMessage 0
MainWndProc = 0
Exit Function
Case WM_INPUT
GetRawInputData lParam, RID_INPUT, 0, Offset(dwSize), Len(rih)
lpb = MemNew(dwSize)
If lpb.SIZE = 0 Then
MainWndProc = 0
Exit Function
End If
If GetRawInputData(lParam, RID_INPUT, lpb.OFFSET, Offset(dwSize), Len(rih)) <> dwSize Then
'Print "GetRawInputData doesn't return correct size!"
mousemessage = "GetRawInputData doesn't return correct size!"
End If
MemGet lpb, lpb.OFFSET, raw
If raw.header.dwType = RIM_TYPEMOUSE Then
tmpx = raw.mouse.lLastX
tmpy = raw.mouse.lLastY
maxx = tmpx
' GET MOUSE INFO
' NOTES:
' ulButtons and usButtonFlags both return the same thing (buttons)
' usButtonData changes value when scroll wheel moved (just stays at one value)
'mousemessage = ""
'mousemessage = mousemessage + "Mouse:hDevice" + Str$(raw.header.hDevice)
'mousemessage = mousemessage + "usFlags=" + Hex$(raw.mouse.usFlags)
'mousemessage = mousemessage + "ulButtons=" + Hex$(MAKELONG(raw.mouse.usButtonFlags, raw.mouse.usFlags))
'mousemessage = mousemessage + "usButtonFlags=" + Hex$(raw.mouse.usButtonFlags)
'mousemessage = mousemessage + "usButtonData=" + Hex$(raw.mouse.usButtonData)
'mousemessage = mousemessage + "ulRawButtons=" + Hex$(raw.mouse.ulRawButtons)
'mousemessage = mousemessage + "lLastX=" + Str$(raw.mouse.lLastX)
'mousemessage = mousemessage + "lLastY=" + Str$(raw.mouse.lLastY)
'mousemessage = mousemessage + "ulExtraInformation=" + Hex$(raw.mouse.ulExtraInformation) + Chr$(13)
' UPDATE RANGE OF MOUSE COORDINATES
If GET_X_LPARAM(lParam) < iMinX Then iMinX = GET_X_LPARAM(lParam)
If GET_X_LPARAM(lParam) > iMaxX Then iMaxX = GET_X_LPARAM(lParam)
If GET_Y_LPARAM(lParam) < iMinY Then iMinY = GET_Y_LPARAM(lParam)
If GET_Y_LPARAM(lParam) > iMaxY Then iMaxY = GET_Y_LPARAM(lParam)
' IDENTIFY WHICH MOUSE IT IS
strNextID = _Trim$(Str$(raw.header.hDevice))
iIndex = GetMouseIndex%(strNextID)
If iIndex >= LBound(arrMouse) Then
If iIndex <= UBound(arrMouse) Then
' =============================================================================
' READ MOUSE MOVEMENT
' DOESN'T WORK, MOVES ALL OVER THE PLACE:
'' METHOD #1: SCALE MOUSE POSITION TO 80X25 POSITION
'iNewX = ( (GET_X_LPARAM(lParam) + 1) * 80) \ (iMaxX+1)
'iNewY = ( (GET_Y_LPARAM(lParam) + 1) * 25) \ (iMaxY+1)
'arrMouse(iIndex).x = iNewX
'arrMouse(iIndex).y = iNewY
' WORKS BUT NOT THAT ACCURATE:
' METHOD #2: INCREMENT/DECREMENT DELTA
If raw.mouse.lLastX < 0 Then
arrMouse(iIndex).dx = -1
ElseIf raw.mouse.lLastX > 0 Then
arrMouse(iIndex).dx = 1
Else
arrMouse(iIndex).dx = 0
End If
If raw.mouse.lLastY < 0 Then
arrMouse(iIndex).dy = -1
ElseIf raw.mouse.lLastY > 0 Then
arrMouse(iIndex).dy = 1
Else
arrMouse(iIndex).dy = 0
End If
' =============================================================================
'TODO: SAVE SCROLL WHEEL + BUTTONS
'Hex$(raw.mouse.usButtonFlags)
' left button = 1 when down, 2 when released
If ((raw.mouse.usButtonFlags And 1) = 1) Then
arrMouse(iIndex).LeftDown = TRUE
ElseIf ((raw.mouse.usButtonFlags And 2) = 2) Then
arrMouse(iIndex).LeftDown = FALSE
End If
' middle button = 16 when down, 32 when released
If ((raw.mouse.usButtonFlags And 16) = 16) Then
arrMouse(iIndex).MiddleDown = TRUE
ElseIf ((raw.mouse.usButtonFlags And 32) = 32) Then
arrMouse(iIndex).MiddleDown = FALSE
End If
' right button = 4 when down, 8 when released
If ((raw.mouse.usButtonFlags And 4) = 4) Then
arrMouse(iIndex).RightDown = TRUE
ElseIf ((raw.mouse.usButtonFlags And 8) = 8) Then
arrMouse(iIndex).RightDown = FALSE
End If
' scroll wheel = ???
'arrMouse(iIndex).wheel = ???
' DID VALUE CHANGE?
If arrMouse(iIndex).UpdateCount = 32767 Then
arrMouse(iIndex).UpdateCount = 1
Else
arrMouse(iIndex).UpdateCount = arrMouse(iIndex).UpdateCount + 1
End If
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' COLLECT VALUES FOR THIS MOUSE TO SEND
' IN THE FOLOWING TAB-DELIMITED FORMAT:
' {mouse #}\t{count}\t{dx}\t{dy}\t{wheel}\t{leftDown}\t{middleDown}\t{rightDown}\n
sOutput = ""
sOutput = sOutput + _Trim$(Str$(iIndex)) + Chr$(9)
sOutput = sOutput + _Trim$(Str$(arrMouse(iIndex).UpdateCount)) + Chr$(9)
sOutput = sOutput + _Trim$(Str$(arrMouse(iIndex).dx)) + Chr$(9)
sOutput = sOutput + _Trim$(Str$(arrMouse(iIndex).dy)) + Chr$(9)
sOutput = sOutput + _Trim$(Str$(arrMouse(iIndex).wheel)) + Chr$(9)
sOutput = sOutput + _Trim$(Str$(arrMouse(iIndex).LeftDown)) + Chr$(9)
sOutput = sOutput + _Trim$(Str$(arrMouse(iIndex).MiddleDown)) + Chr$(9)
sOutput = sOutput + _Trim$(Str$(arrMouse(iIndex).RightDown)) + Chr$(13)
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' SEND VALUES FOR THIS MOUSE TO HOST
Put #lngConn, , sOutput
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' CLEAR MOVEMENT
arrMouse(iIndex).dx = 0
arrMouse(iIndex).dy = 0
End If
End If
' UPDATE mousemessage WITH PLAYING FIELD
mousemessage = ScreenToString$
' ================================================================================================================================================================
' END WRITE OUTPUT FILE
' ================================================================================================================================================================
InvalidateRect hwnd, 0, -1
SendMessage hwnd, WM_PAINT, 0, 0
MainWndProc = 0
ElseIf raw.header.dwType = RIM_TYPEKEYBOARD Then
' TODO: READ KEYBOARD INPUT
' SEE:
' https://www.codeproject.com/Articles/17123/Using-Raw-Input-from-C-to-handle-multiple-keyboard
' https://forum.powerbasic.com/forum/user-to-user-discussions/powerbasic-for-windows/55985-raw-keyboard-hid-input-discussion
' https://hackaday.io/project/5364-cheap-windows-jogkeyboard-controller-for-cncs/log/16843-looking-at-rawinput-for-more-detail
' WinAPI Raw Input confusion - For Beginners - GameDev.net
' https://www.gamedev.net/forums/topic/700010-winapi-raw-input-confusion/
'iKeyboardCount = iKeyboardCount + 1 ' # KEYBOARDS ATTACHED
'strNextID = _Trim$(Str$(rawdevs(x).hDevice))
'arrKeyboard(iKeyboardCount - 1).ID = strNextID
' TODO: READ KEYBOARD AND STORE KEYBOARD STATE
'arrKeyState(0 To 8, 1 To 512) As Integer ' arrKeyState({device#}, {keyCode}) = TRUE if key {keyCode} on keyboard {device#} is currently held down.
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)
arrMouse(iIndex).dx = -1
ElseIf GET_X_LPARAM(lParam) > iMaxX Then
iMaxX = GET_X_LPARAM(lParam)
arrMouse(iIndex).dx = 1
Else
arrMouse(iIndex).dx = 0
End If
If GET_Y_LPARAM(lParam) < iMinY Then
iMinY = GET_Y_LPARAM(lParam)
arrMouse(iIndex).dy = -1
ElseIf GET_Y_LPARAM(lParam) > iMaxY Then
iMaxY = GET_Y_LPARAM(lParam)
arrMouse(iIndex).dy = 1
Else
arrMouse(iIndex).dy = 0
End If
' IDENTIFY WHICH MOUSE IT IS
strNextID = _Trim$(Str$(raw.header.hDevice))
iIndex = GetMouseIndex%(strNextID)
If iIndex >= LBound(arrMouse) Then
If iIndex <= UBound(arrMouse) Then
' =============================================================================
' UPDATE ABSOLUTE POSITION
' 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)
'arrMouse(iIndex).x = iNewX
'arrMouse(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?)
'arrMouse(iIndex).wheel =
'arrMouse(iIndex).LeftDown =
'arrMouse(iIndex).MiddleDown =
'arrMouse(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
If _KeyDown(27) Then End
End Function ' MainWndProc
' /////////////////////////////////////////////////////////////////////////////
' Initializes raw input stuff
Sub InitRawInput ()
Dim As RAWINPUTDEVICE Rid(0 To 49)
Dim As Unsigned Long nDevices
Dim As RAWINPUTDEVICELIST RawInputDeviceList
Dim As MEM pRawInputDeviceList
ReDim As RAWINPUTDEVICELIST rawdevs(-1)
Dim As Unsigned Long x
Dim strNextID As String
'dim lngNextID as long
If GetRawInputDeviceList(0, Offset(nDevices), Len(RawInputDeviceList)) <> 0 Then
Exit Sub
End If
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 / KEYBOARD INFO
iMouseCount = 0
iKeyboardCount = 0
rawinputdevices = "Number of raw input devices:" + Str$(nDevices) + Chr$(13)
For x = 0 To UBound(rawdevs)
rawinputdevices = rawinputdevices + Str$(rawdevs(x).hDevice) + ":" + Str$(rawdevs(x).dwType) + Chr$(13)
' RAWINPUTHEADER (winuser.h) - Win32 apps | Microsoft Learn
' https://learn.microsoft.com/en-us/windows/win32/api/winuser/ns-winuser-rawinputheader
' dwType
' Type: DWORD
' The type of raw input. It can be one of the following values:
' Constant Value Meaning
' RIM_TYPEMOUSE 0 Raw input comes from the mouse.
' RIM_TYPEKEYBOARD 1 Raw input comes from the keyboard.
' RIM_TYPEHID 2 Raw input comes from some device that is not a keyboard or a mouse.
' WHAT TYPE OF DEVICE IS IT?
'If rawdevs(x).dwType = 0 Then
If rawdevs(x).dwType = RIM_TYPEMOUSE Then
iMouseCount = iMouseCount + 1
strNextID = _Trim$(Str$(rawdevs(x).hDevice))
'lngNextID = Val(strNextID)
'arrMouse(iMouseCount-1).ID = lngNextID
arrMouse(iMouseCount - 1).ID = strNextID
arrMouse(iMouseCount - 1).UpdateCount = 0
'TODO: SAVE_MOUSE_INFO
ElseIf rawdevs(x).dwType = RIM_TYPEKEYBOARD Then
iKeyboardCount = iKeyboardCount + 1 ' # KEYBOARDS ATTACHED
strNextID = _Trim$(Str$(rawdevs(x).hDevice))
arrKeyboard(iKeyboardCount - 1).ID = strNextID
arrKeyboard(iKeyboardCount - 1).UpdateCount = 0
' TODO: READ KEYBOARD AND STORE KEYBOARD STATE
'arrKeyState(0 To 8, 1 To 512) As Integer ' arrKeyState({device#}, {keyCode}) = TRUE if key {keyCode} on keyboard {device#} is currently held down.
End If
Next x
rawinputdevices = rawinputdevices + Chr$(0)
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 WINDOW FUNCTIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' /////////////////////////////////////////////////////////////////////////////
' hWnd = handle to window to set opacity for
' Level = 0 TO 255, 0=totally invisible, 128=transparent, 255=100% solid
Sub SetWindowOpacity (hWnd As _Offset, Level As _Unsigned _Byte)
Const cIndex = -20
Const LWA_ALPHA = &H2
Const WS_EX_LAYERED = &H80000
Dim lngMsg As Long
Dim lngValue As Long
'Function GetWindowLong& Alias "GetWindowLongA" (ByVal hwnd As _Offset, Byval nIndex As Long)
lngMsg = GetWindowLong(hWnd, cIndex)
lngMsg = lngMsg Or WS_EX_LAYERED
'Function SetWindowLong& Alias "SetWindowLongA" (ByVal hwnd As _Offset, Byval nIndex As Long, Byval dwNewLong As Long)
lngValue = SetWindowLong(hWnd, cIndex, lngMsg)
'Function SetLayeredWindowAttributes& (ByVal hwnd As _Offset, Byval crKey As Long, Byval bAlpha As _Unsigned _Byte, Byval dwFlags As Long)
lngValue = SetLayeredWindowAttributes(hWnd, 0, Level, LWA_ALPHA)
End Sub ' SetWindowOpacity
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END WINDOW FUNCTIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN 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(arrMouse) - 1
For iLoop = 1 To iMouseCount
iIndex = iIndex + 1
Read arrMouse(iIndex).c
' INITIALIZED BELOW: arrMouse(iIndex).x = 0
' INITIALIZED BELOW: arrMouse(iIndex).y = 0
' INITIALIZED BELOW: arrMouse(iIndex).wheel = 127
arrMouse(iIndex).LeftDown = FALSE
arrMouse(iIndex).MiddleDown = FALSE
arrMouse(iIndex).RightDown = FALSE
arrMouse(iIndex).LeftCount = 0
arrMouse(iIndex).MiddleCount = 0
arrMouse(iIndex).RightCount = 0
arrMouse(iIndex).UpdateCount = 1
Next iLoop
' INITIALIZE X COORDINATES
Restore XData
iIndex = LBound(arrMouse) - 1
For iLoop = 1 To iMouseCount
iIndex = iIndex + 1
Read arrMouse(iIndex).x
Next iLoop
' INITIALIZE Y COORDINATES
Restore YData
iIndex = LBound(arrMouse) - 1
For iLoop = 1 To iMouseCount
iIndex = iIndex + 1
Read arrMouse(iIndex).y
Next iLoop
' INITIALIZE SCROLL WHEEL
Restore WData
iIndex = LBound(arrMouse) - 1
For iLoop = 1 To iMouseCount
iIndex = iIndex + 1
Read arrMouse(iIndex).wheel
Next iLoop
End Sub ' InitMouseTest
' /////////////////////////////////////////////////////////////////////////////
' Finds position in array arrMouse where .ID = MouseID
Function GetMouseIndex% (MouseID As String)
Dim iLoop As Integer
Dim iIndex%
iIndex% = LBound(arrMouse) - 1
For iLoop = LBound(arrMouse) To UBound(arrMouse)
If arrMouse(iLoop).ID = MouseID Then
iIndex% = iLoop
Exit For
Else
' not it
End If
Next iLoop
GetMouseIndex% = iIndex%
End Function ' GetMouseIndex%
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END MOUSE TEST FUNCTIONS #1
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN TEST OUTPUT FUNCTIONS FOR API CONTROLLED UI
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' /////////////////////////////////////////////////////////////////////////////
' Clears global array arrScreen
Sub ClearText
Dim iColNum As Integer
Dim iRowNum As Integer
For iColNum = LBound(arrScreen, 1) To UBound(arrScreen, 1)
For iRowNum = LBound(arrScreen, 2) To UBound(arrScreen, 2)
arrScreen(iColNum, iRowNum) = " "
Next iRowNum
Next iColNum
End Sub ' ClearText
' /////////////////////////////////////////////////////////////////////////////
' Plots string MyString to position (iX, iY) in global array arrScreen.
Sub WriteText (iRow As Integer, iColumn As Integer, MyString As String)
Dim iPos As Integer
Dim iLoop As Integer
If iColumn > 0 And iColumn < 81 Then
If iRow > 0 And iRow < 26 Then
For iLoop = 1 To Len(MyString)
iPos = iColumn + (iLoop - 1)
If iPos < 81 Then
arrScreen(iPos, iRow) = Mid$(MyString, iLoop, 1)
Else
Exit For
End If
Next iLoop
End If
End If
End Sub ' WriteText
' /////////////////////////////////////////////////////////////////////////////
' Converts global array arrScreen to a string.
Function ScreenToString$
Dim sResult As String
Dim iColNum As Integer
Dim iRowNum As Integer
sResult = ""
For iRowNum = LBound(arrScreen, 2) To UBound(arrScreen, 2)
For iColNum = LBound(arrScreen, 1) To UBound(arrScreen, 1)
sResult = sResult + arrScreen(iColNum, iRowNum)
Next iColNum
sResult = sResult + Chr$(13)
Next iRowNum
ScreenToString$ = sResult
End Function ' ScreenToString$
' /////////////////////////////////////////////////////////////////////////////
' based on code from:
' Qbasic Programs - Download free bas source code
' http://www.thedubber.altervista.org/qbsrc.htm
Sub DrawTextLine (y%, x%, y2%, x2%, c$)
Dim i%
Dim steep%
Dim e%
Dim sx%
Dim dx%
Dim sy%
Dim dy%
i% = 0: steep% = 0: e% = 0
If (x2% - x%) > 0 Then sx% = 1: Else sx% = -1
dx% = Abs(x2% - x%)
If (y2% - y%) > 0 Then sy% = 1: Else sy% = -1
dy% = Abs(y2% - y%)
If (dy% > dx%) Then
steep% = 1
Swap x%, y%
Swap dx%, dy%
Swap sx%, sy%
End If
e% = 2 * dy% - dx%
For i% = 0 To dx% - 1
If steep% = 1 Then
''PSET (y%, x%), c%:
'Locate y%, x% : Print c$;
WriteText y%, x%, c$
Else
''PSET (x%, y%), c%
'Locate x%, y% : Print c$;
WriteText x%, y%, c$
End If
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 FOR API CONTROLLED UI
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN MOUSE FUNCTIONS TO COME
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' /////////////////////////////////////////////////////////////////////////////
' Returns a count of # of RawInput mouse devices connected to the system
' *****************************************************************************
' TODO: GET COUNT FROM RawInput API
' For now, hardcoded to 1 until we figure out how to do this.
' *****************************************************************************
Function GetRawMouseCount% ()
GetRawMouseCount% = 1
End Function ' GetRawMouseCount%
' /////////////////////////////////////////////////////////////////////////////
' Gets ID of each RawInput mouse device connected to the system (for now upto 8)
' Returns the IDs in an array of LONG <- may change depending on whether
' we save each the device handle for each mouse or the index
' If no mouse found, the ID will just be 0 <- or whatever value we decide as default/none
' *****************************************************************************
' TODO: GET THIS FROM RawInput API
' For now, hardcoded arrRawMouseID(1) to 1, and the rest 0, until we figure out how to do this.
' *****************************************************************************
'Sub GetRawMouseIDs (arrRawMouseID( 8) As Integer)
Sub GetRawMouseIDs ()
Dim iLoop As Integer
' CLEAR OUT IDs
For iLoop = 1 To 8
''arrRawMouseID(iLoop) = 0
'arrMouse(iLoop).ID = 0
arrMouse(iLoop).ID = ""
Next iLoop
' GET IDs
'TODO: get this from RawInput API
''arrRawMouseID(1) = 1 ' for now just fudge it!
'arrMouse(0).ID = 1 ' for now just fudge it!
End Sub ' GetRawMouseIDs
' /////////////////////////////////////////////////////////////////////////////
' Read mouse using RawInput API
' Gets input from mouse, MouseID% = which mouse
' NOTE: click events (mouse up/mouse down) are handled by the calling sub,
' this routine just sends back
' TRUE if the given button is currently down or FALSE if it is up.
' Parameters (input only):
' MouseID% = which mouse to return input for
' wheelMin% = minimum value to allow wheelValue% to be decremented to
' wheelMax% = maximum value to allow wheelValue% to be incremened to
' Parameters (values returned):
' x% = mouse x position
' y% = mouse y position
' leftButton% = current state of left mouse button (up or down)
' middleButton% = current state of middle mouse button / scroll wheel button (up or down)
' rightButton% = current state of right mouse button (up or down)
' wheelValue% = value of mouse scroll wheel (passed in and incremented/decremented by 1 if wheel move detected)
Sub ReadRawMouse (MouseID%, x%, y%, leftButton%, middleButton%, rightButton%, wheelValue%, wheelMin%, wheelMax%)
Dim scrollAmount%
Dim dx%
Dim dy%
' =============================================================================
' BEGIN READ MOUSE THE NEW RawInput WAY:
' read scroll wheel
'TODO: get this from RawInput API
' determine mouse x position
'TODO: get this from RawInput API
dx% = 0 ' = getMouseDx(MouseID%)
x% = x% + dx% ' adjust mouse value by dx
' determine mouse y position
'TODO: get this from RawInput API
dy% = 0 ' = getMouseDy(MouseID%)
y% = y% + dy% ' adjust mouse value by dx
' read mouse buttons
'TODO: get this from RawInput API
leftButton% = FALSE
middleButton% = FALSE
rightButton% = FALSE
' END READ MOUSE THE NEW RawInput WAY:
' =============================================================================
' =============================================================================
' BEGIN READ MOUSE THE OLD QB64 WAY:
'
'' read scroll wheel
'WHILE _MOUSEINPUT ' get latest mouse information
' scrollAmount% = _MOUSEWHEEL ' (Returns -1 when scrolling up and 1 when scrolling down with 0 indicating no movement since last read.)
' IF (scrollAmount% = -1) AND (wheelValue% > wheelMin%) THEN
' wheelValue% = wheelValue% + scrollAmount%
' ELSEIF (scrollAmount% = 1) AND (wheelValue% < wheelMax%) THEN
' wheelValue% = wheelValue% + scrollAmount%
' END IF
'WEND
'
'' determine mouse x position
'x% = _MOUSEX
'
'' determine mouse y position
'y% = _dy
'
'' read mouse buttons
'leftButton% = _MOUSEBUTTON(1)
'middleButton% = _MOUSEBUTTON(3)
'rightButton% = _MOUSEBUTTON(2)
'
' END READ MOUSE THE OLD QB64 WAY:
' =============================================================================
End Sub ' ReadRawMouse
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END MOUSE FUNCTIONS TO COME
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN ERROR HANDLING HELPER FUNCTIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Sub ErrorClear
m_sError = ""
m_sIncludeError = ""
End Sub ' ErrorClear
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END ERROR HANDLING HELPER FUNCTIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN FILE FUNCTIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' /////////////////////////////////////////////////////////////////////////////
' QB64 Phoenix Edition › QB64 Rising › Code and Stuff › Help Me!
' Using shell to delete a file
' https://qb64phoenix.com/forum/showthread.php?tid=2618&pid=24683#pid24683
' a740g
' #5
' 04-24-2024, 06:05 AM
'
' There are no commands to directly make copies or backup of files.
' But you could write one with a few lines of code like:
'
' Copies src to dst
' Set overwite to true if dst should be overwritten if present
Sub CopyFile (src As String, dst As String, overwrite As _Byte)
If _FileExists(src) Then
If Not _FileExists(dst) Or (_FileExists(dst) And overwrite) Then
_WriteFile dst, _ReadFile$(src)
End If
End If
End Sub ' CopyFile
' /////////////////////////////////////////////////////////////////////////////
' Convert a value to string and trim it (because normal Str$ adds spaces)
Function cstr$ (myValue)
'cstr$ = LTRIM$(RTRIM$(STR$(myValue)))
cstr$ = _Trim$(Str$(myValue))
End Function ' cstr$
' /////////////////////////////////////////////////////////////////////////////
' QB64 Phoenix Edition › QB64 Rising › Code and Stuff › Help Me!
' Using shell to delete a file
' https://qb64phoenix.com/forum/showthread.php?tid=2618
Sub DeleteFile (sFile As String)
If _FileExists(sFile) Then
'Shell "DELETE " + sFile
'Shell "del " + sFile
Kill sFile
End If
End Sub ' DeleteFile
' /////////////////////////////////////////////////////////////////////////////
Function FileExt$ (sFile As String)
Dim iPos As Integer
iPos = _InStrRev(sFile, ".")
If iPos > 0 Then
If Len(sFile) > 1 Then
If iPos > 1 Then
FileExt$ = Right$(sFile, Len(sFile) - iPos)
Else
' dot is first character, return everything after it
FileExt$ = Right$(sFile, Len(sFile) - 1)
End If
Else
' file only has one character, the dot, the file extension is blank
FileExt$ = ""
End If
Else
' no dot found, the file extension is blank
FileExt$ = ""
End If
End Function ' FileExt$
' /////////////////////////////////////////////////////////////////////////////
Function NameOnly$ (sFile As String, sSlash As String)
Dim iPos As Integer
'sFile = Replace$(sFile, "/", "\")
iPos = _InStrRev(sFile, sSlash)
If iPos > 0 Then
If Len(sFile) > 1 Then
If iPos > 1 Then
NameOnly$ = Right$(sFile, Len(sFile) - iPos)
Else
' slash is first character, return everything after it
NameOnly$ = Right$(sFile, Len(sFile) - 1)
End If
Else
' file only has one character, the slash, name is blank
NameOnly$ = ""
End If
Else
' slash not found, return the entire thing
NameOnly$ = sFile
End If
End Function ' NameOnly$
' /////////////////////////////////////////////////////////////////////////////
Function NoExt$ (sFile As String)
Dim iPos As Integer
iPos = _InStrRev(sFile, ".")
If iPos > 0 Then
If Len(sFile) > 1 Then
If iPos > 1 Then
NoExt$ = Left$(sFile, iPos - 1)
Else
' dot is first character, removing it returns blank!
' our version will just return the name unchanged
' but you can return blank if you prefer
NoExt$ = sFile
End If
Else
' file only has one character, the dot, removing it returns blank!
' our version will just return the name unchanged
' but you can return blank if you prefer
NoExt$ = sFile
End If
Else
' no dot found
' return the name unchanged
NoExt$ = sFile
End If
End Function ' NoExt$
' /////////////////////////////////////////////////////////////////////////////
Function PathOnly$ (sFile As String, sSlash As String)
Dim iPos As Integer
'sFile = Replace$(sFile, "/", "\")
iPos = _InStrRev(sFile, sSlash)
If iPos > 0 Then
If Len(sFile) > 1 Then
If iPos > 1 Then
PathOnly$ = Left$(sFile, iPos)
Else
' slash is first character, so not much of a path, return blank
PathOnly$ = ""
End If
Else
' file only has one character, the slash, name is blank
PathOnly$ = ""
End If
Else
' slash not found, so not a path, return blank
PathOnly$ = ""
End If
End Function ' PathOnly$
' /////////////////////////////////////////////////////////////////////////////
' Writes sText to file sFileName.
' If bAppend=TRUE appends to file, else overwrites it.
' Returns blank if successful else returns error message.
' Example:
' ProgramPath$ = Left$(Command$(0), _InStrRev(Command$(0), "\"))
' ProgramName$: m_ProgramName$ = Mid$(Command$(0), _InStrRev(Command$(0), "\") + 1)
' sFileName = ProgramPath$ + ProgramName$ + ".OUT.txt"
' sText = "This is a test." + chr$(13) + "Here is line 2." + chr$(13) + "End."
' sError = PrintFile$(sFileName, sText, FALSE)
Function PrintFile$ (sFileName As String, sText As String, bAppend As Integer)
Dim sError As String: sError = ""
If (bAppend = TRUE) Then
If _FileExists(sFileName) Then
Open sFileName For Append As #1 ' opens an existing file for appending
Else
sError = "Error in PrintFile$ : File not found. Cannot append."
End If
Else
Open sFileName For Output As #1 ' opens and clears an existing file or creates new empty file
End If
If Len(sError) = 0 Then
' NOTE: WRITE places text in quotes in the file
'WRITE #1, x, y, z$
'WRITE #1, sText
' PRINT does not put text inside quotes
Print #1, sText
Close #1
End If
PrintFile$ = sError
End Function ' PrintFile$
' /////////////////////////////////////////////////////////////////////////////
' Fastest way is always to just read the whole life at once and then parse it.
Function ReadTextFile$ (sFileName As String, sDefault As String)
Dim x$
If _FileExists(sFileName) Then
Open sFileName For Binary As #1
x$ = Space$(LOF(1))
Get #1, 1, x$
Close #1
ReadTextFile$ = x$
Else
ReadTextFile$ = sDefault
End If
End Function ' ReadTextFile$
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END FILE FUNCTIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN GENERAL PURPOSE FUNCTIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' /////////////////////////////////////////////////////////////////////////////
' FOR BITWISE OPERATIONS
Function HasBit% (iByte As Integer, iBit As Integer)
''TODO: precalculate
'dim shared m_arrBitValue(1 To 8) As Integer
'dim iLoop as Integer
'For iLoop = 0 To 7
' m_arrBitValue(iLoop + 1) = 2 ^ iLoop
'Next iLoop
'HasBit% = ((iByte And m_arrBitValue(iBit)) = m_arrBitValue(iBit))
Dim iBitValue As Integer
iBitValue = 2 ^ (iBit - 1)
HasBit% = ((iByte And iBitValue) = iBitValue)
End Function ' HasBit%
' /////////////////////////////////////////////////////////////////////////////
' Returns TRUE if value OriginalString$ is numeric.
' Re: Does a Is Number function exist in QB64?
' https://www.qb64.org/forum/index.php?topic=896.15
' Version 2 by madscijr
' Returns TRUE (-1) if string is an integer, FALSE (0) if not
' Version 1 by MWheatley
' Reply #18 on: January 01, 2019, 11:24:30 AM
' returns 1 if string is an integer, 0 if not
Function IsNumber% (OriginalString$)
Dim bResult%: bResult% = FALSE
Dim iLoop%
Dim TestString$
'Dim bNegative%
Dim iDecimalCount%
Dim sNextChar$
'THEY SHOULD TRIM OUTSIDE THE FUNCTION!
'TestString$ = _TRIM$(OriginalString$)
If Len(OriginalString$) > 0 Then
TestString$ = ""
If Left$(OriginalString$, 1) = "+" Then
TestString$ = Right$(OriginalString$, Len(OriginalString$) - 1)
'bNegative% = FALSE
ElseIf Left$(OriginalString$, 1) = "-" Then
TestString$ = Right$(OriginalString$, Len(OriginalString$) - 1)
'bNegative% = TRUE
Else
TestString$ = OriginalString$
'bNegative% = FALSE
End If
If Len(TestString$) > 0 Then
bResult% = TRUE
iDecimalCount% = 0
For iLoop% = 1 To Len(TestString$)
sNextChar$ = Mid$(TestString$, iLoop%, 1)
If sNextChar$ = "." Then
iDecimalCount% = iDecimalCount% + 1
If iDecimalCount% > 1 Then
' TOO MANY DECIMAL POINTS, INVALID!
bResult% = FALSE
Exit For
End If
ElseIf Asc(sNextChar$) < 48 Or Asc(sNextChar$) > 57 Then
' NOT A NUMERAL OR A DECIMAL, INVALID!
bResult% = FALSE
Exit For
End If
Next iLoop%
End If
End If
IsNumber% = bResult%
End Function ' IsNumber%
' /////////////////////////////////////////////////////////////////////////////
' Split and join strings
' https://www.qb64.org/forum/index.php?topic=1073.0
'Combine all elements of in$() into a single string with delimiter$ separating the elements.
Function join$ (in$(), delimiter$)
Dim result$
Dim iLoop%
result$ = in$(LBound(in$))
For iLoop% = LBound(in$) + 1 To UBound(in$)
result$ = result$ + delimiter$ + in$(iLoop%)
Next iLoop%
join$ = result$
End Function ' join$
' /////////////////////////////////////////////////////////////////////////////
' Split and join strings
' https://www.qb64.org/forum/index.php?topic=1073.0
'
' FROM luke, QB64 Developer
' Date: February 15, 2019, 04:11:07 AM
'
' Given a string of words separated by spaces (or any other character),
' splits it into an array of the words. I've no doubt many people have
' written a version of this over the years and no doubt there's a million
' ways to do it, but I thought I'd put mine here so we have at least one
' version. There's also a join function that does the opposite
' array -> single string.
'
' Code is hopefully reasonably self explanatory with comments and a little demo.
' Note, this is akin to Python/JavaScript split/join, PHP explode/implode.
'Split in$ into pieces, chopping at every occurrence of delimiter$. Multiple consecutive occurrences
'of delimiter$ are treated as a single instance. The chopped pieces are stored in result$().
'
'delimiter$ must be one character long.
'result$() must have been REDIMmed previously.
' Modified to handle multi-character delimiters
Sub split (in$, delimiter$, result$())
Dim start As Integer
Dim finish As Integer
Dim iDelimLen As Integer
ReDim result$(-1)
iDelimLen = Len(delimiter$)
start = 1
Do
'While Mid$(in$, start, 1) = delimiter$
While Mid$(in$, start, iDelimLen) = delimiter$
'start = start + 1
start = start + iDelimLen
If start > Len(in$) Then
Exit Sub
End If
Wend
finish = InStr(start, in$, delimiter$)
If finish = 0 Then
finish = Len(in$) + 1
End If
ReDim _Preserve result$(0 To UBound(result$) + 1)
result$(UBound(result$)) = Mid$(in$, start, finish - start)
start = finish + 1
Loop While start <= Len(in$)
End Sub ' split
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END GENERAL PURPOSE FUNCTIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ################################################################################################################################################################
' #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"readmicesub34c.bas" compiles OK:
Code: (Select All)
' ################################################################################################################################################################
' Multimouse sub-program "ReadMiceSub.bas"
' ################################################################################################################################################################
' -------------------------------------------------------------------------------
' ABOUT
' -------------------------------------------------------------------------------
' (Subprogram for READMICEMAIN.BAS, see that for more info.)
Option Explicit
_Title "readmice"
$NoPrefix
'$Console:Only
'Console Off
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN CONSTANTS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Const cProgName = "ReadMiceSub"
Const FALSE = 0
Const TRUE = Not FALSE
Const cInvisible = 0
Const cTransparent = 160
Const cVisible = 255
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' FOR CONTROLLING WINDOW ON TOP, ETC.
Const SWP_NOSIZE = &H0001 'ignores cx and cy size parameters
'Const SWP_NOMOVE = &H0002 'ignores x and y position parameters
'Const SWP_NOZORDER = &H0004 'keeps z order and ignores hWndInsertAfter parameter
'Const SWP_NOREDRAW = &H0008 'does not redraw window changes
Const SWP_NOACTIVATE = &H0010 'does not activate window
'Const SWP_FRAMECHANGED = &H0020
'Const SWP_SHOWWINDOW = &H0040
'Const SWP_HIDEWINDOW = &H0080
'Const SWP_NOCOPYBITS = &H0100
'Const SWP_NOOWNERZORDER = &H0200
'Const SWP_NOSENDCHANGING = &H0400
'Const SWP_DRAWFRAME = SWP_FRAMECHANGED
'Const SWP_NOREPOSITION = SWP_NOOWNERZORDER
'Const SWP_DEFERERASE = &H2000
'Const SWP_ASYNCWINDOWPOS = &H4000
Const HWND_TOP = 0 'window at top of z order no focus
Const HWND_BOTTOM = 1 'window at bottom of z order no focus
Const HWND_TOPMOST = -1 'window above all others no focus unless active
Const HWND_NOTOPMOST = -2 'window below active no focus
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' FOR RAW INPUT API
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 ' Raw input comes from the mouse.
Const RIM_TYPEKEYBOARD = 1 ' Raw input comes from the keyboard.
Const RIM_TYPEHID = 2 ' Raw input comes from some device that is not a keyboard or a mouse.
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 = 1
Const cMaxX = 80
Const cMinY = 1
Const cMaxY = 30 ' 24
Const cMinWheel = 0
Const cMaxWheel = 255
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' CONSTANT FOR 2ND DIMENSION OF arrFile ARRAY
Const cFileName = 0
Const cFileData = 1
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END CONSTANTS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN UDTs
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Type RAWINPUTDEVICE
As Unsigned Integer usUsagePage, usUsage
As Unsigned Long dwFlags
As Offset hwndTarget ' <- WHAT IS Offset VS _Offset ?
End Type
Type RAWINPUTDEVICELIST
As Offset hDevice
As Unsigned Long dwType
$If 64BIT Then
As String * 4 alignment
$End If
End Type
Type POINT
As Long x, y
End Type
Type MSG
As Offset hwnd
As Unsigned Long message
As Unsigned Offset wParam
As Offset lParam
As Long time
As POINT pt
As Long lPrivate
End Type
Type WNDCLASSEX
As Unsigned Long cbSize, style
As Offset lpfnWndProc
As Long cbClsExtra, cbWndExtra
As Offset hInstance, hIcon, hCursor, hbrBackground, lpszMenuName, lpszClassName, hIconSm
End Type
Type RECT
As Long left, top, right, bottom
End Type
Type PAINTSTRUCT
As Offset hdc
As Long fErase
$If 64BIT Then
As String * 4 alignment
$End If
As RECT rcPaint
As Long fRestore, fIncUpdate
As String * 32 rgbReserved
End Type
Type RAWINPUTHEADER
As Unsigned Long dwType, dwSize
As Offset hDevice
As Unsigned Offset wParam
End Type
Type RAWMOUSE
As Unsigned Integer usFlags
$If 64BIT Then
As String * 2 alignment
$End If
'As Unsigned Long ulButtons 'commented out because I'm creating this value using MAKELONG
As Unsigned Integer usButtonFlags, usButtonData
As Unsigned Long ulRawButtons
As Long lLastX, lLastY
As Unsigned Long ulExtraInformation
End Type
Type RAWINPUT
As RAWINPUTHEADER header
As RAWMOUSE mouse
End Type
' UDT TO HOLD THE INFO FOR EACH MOUSE
Type MouseInfoType
UpdateCount As Integer ' if this value changes we know a value changed
ID As String ' mouse device ID
c As String ' cursor character
x As Integer ' screen x position
y As Integer ' screen y position
dx As Integer ' mouse x movement -1=left, 1=right, 0=none
dy As Integer ' mouse y movement -1=up , 1=down , 0=none
wheel As Integer ' mouse wheel value
LeftDown As Integer ' tracks left mouse button state, TRUE=down
MiddleDown As Integer ' tracks middle mouse button state, TRUE=down
RightDown As Integer ' tracks right mouse button state, TRUE=down
LeftCount As Integer ' counts left clicks
MiddleCount As Integer ' counts middle clicks
RightCount As Integer ' counts right clicks
End Type ' MouseInfoType
' UDT TO HOLD THE INFO FOR EACH KEYBOARD
Type KeyboardInfoType
UpdateCount As Integer ' if this value changes we know a value changed
ID As String ' keyboard device ID
'TBD
End Type ' KeyboardInfoType
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END UDTs
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN API DECLARATIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' FOR RAW INPUT API
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
Declare CustomType Library
Function GetRawInputDeviceList~& (ByVal pRawInputDeviceList As Offset, Byval puiNumDevices As Offset, Byval cbSize As Unsigned Long)
Sub GetRawInputDeviceList (ByVal pRawInputDeviceList As Offset, Byval puiNumDevices As Offset, Byval cbSize As Unsigned Long)
Function RegisterRawInputDevices& (ByVal pRawInputDevices As Offset, Byval uiNumDevices As Unsigned Long, Byval cbSize As Unsigned Long)
Function GetModuleHandle%& (ByVal lpModulename As Offset)
Function LoadIcon%& (ByVal hInstance As Offset, Byval lpIconName As Offset)
Function LoadCursor%& (ByVal hInstance As Offset, Byval lpCursorName As Offset)
Function RegisterClassEx~% (ByVal wndclassex As Offset)
Function CreateWindowEx%& (ByVal dwExStyle As Unsigned Long, Byval lpClassName As Offset, Byval lpWindowName As Offset, Byval dwStyle As Unsigned Long, Byval x As Long, Byval y As Long, Byval nWidth As Long, Byval nHeight As Long, Byval hWndParent As Offset, Byval hMenu As Offset, Byval hInstance As Offset, Byval lpParam As Offset)
Sub ShowWindow (ByVal hWnd As Offset, Byval nCmdShow As Long)
Sub UpdateWindow (ByVal hWnd As Offset)
Function GetMessage& (ByVal lpMsg As Offset, Byval hWnd As Offset, Byval wMsgFilterMin As Unsigned Long, Byval wMsgFilterMax As Unsigned Long)
Sub TranslateMessage (ByVal lpMsg As Offset)
Sub DispatchMessage (ByVal lpMsg As Offset)
Sub PostQuitMessage (ByVal nExitCode As Long)
Function DefWindowProc%& (ByVal hWnd As Offset, Byval Msg As Unsigned Long, Byval wParam As Unsigned Offset, Byval lParam As Offset)
Sub GetRawInputData (ByVal hRawInput As Offset, Byval uiCommand As Unsigned Long, Byval pData As Offset, Byval pcbSize As Offset, Byval cbSizeHeader As Unsigned Long)
Function GetRawInputData~& (ByVal hRawInput As Offset, Byval uiCommand As Unsigned Long, Byval pData As Offset, Byval pcbSize As Offset, Byval cbSizeHeader As Unsigned Long)
Sub InvalidateRect (ByVal hWnd As Offset, Byval lpRect As Offset, Byval bErase As Long)
Sub SendMessage (ByVal hWnd As Offset, Byval Msg As Unsigned Long, Byval wParam As Unsigned Offset, Byval lParam As Offset)
Function BeginPaint%& (ByVal hWnd As Offset, Byval lpPaint As Offset)
Sub GetClientRect (ByVal hWnd As Offset, Byval lpRect As Offset)
Sub DrawText (ByVal hdc As Offset, Byval lpchText As Offset, Byval cchText As Long, Byval lprc As Offset, Byval format As Unsigned Long)
Sub OffsetRect (ByVal lprc As Offset, Byval dx As Long, Byval dy As Long)
Sub EndPaint (ByVal hWnd As Offset, Byval lpPaint As Offset)
End Declare
' Header file "makeint.h" must be in same folder as this program.
Declare CustomType Library ".\makeint"
Function MAKEINTRESOURCE%& Alias "MAKEINTRSC" (ByVal i As _Offset)
End Declare
Declare Library
Function MAKELPARAM%& (ByVal l As Integer, Byval h As Integer)
Function MAKELONG~& (ByVal l As Unsigned Integer, Byval h As Unsigned Integer)
End Declare
$If 64BIT Then
Declare Library ".\internal\c\c_compiler\x86_64-w64-mingw32\include\windowsx"
$Else
Declare Library ".\internal\c\c_compiler\i686-w64-mingw32\include\windowsx"
$End If
Function GET_Y_LPARAM& (ByVal lp As Offset)
Function GET_X_LPARAM& (ByVal lp As Offset)
End Declare
' Header file "winproc.h" must be in same folder as this program.
Declare Library ".\winproc"
Function WindowProc%& ()
End Declare
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' To keep focus on window
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
'Declare Dynamic Library "user32"
' Sub ShowWindow (ByVal hWnd As _Offset, Byval nCmdShow As Long)
'End Declare
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' To make window invisible
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
Declare Dynamic Library "user32"
Function SetLayeredWindowAttributes& (ByVal hwnd As _Offset, Byval crKey As Long, Byval bAlpha As _Unsigned _Byte, Byval dwFlags As Long)
Function GetWindowLong& Alias "GetWindowLongA" (ByVal hwnd As _Offset, Byval nIndex As Long)
Function SetWindowLong& Alias "SetWindowLongA" (ByVal hwnd As _Offset, Byval nIndex As Long, Byval dwNewLong As Long)
End Declare
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' Needed for acquiring the hWnd of the window
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
Declare Library
Function FindWindow& (ByVal ClassName As _Offset, WindowName$) ' To get hWnd handle
End Declare
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END API DECLARATIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN GLOBAL VARIABLES
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BASIC PROGRAM METADATA
Dim Shared m_ProgramPath$: m_ProgramPath$ = Left$(Command$(0), _InStrRev(Command$(0), "\"))
Dim Shared m_ProgramName$: m_ProgramName$ = Mid$(Command$(0), _InStrRev(Command$(0), "\") + 1)
Dim Shared m_sTriggerFile As String: m_sTriggerFile = m_ProgramPath$ + "ReadMiceSub.DELETE-TO-CLOSE"
' GLOBAL VARIABLES TO TRACK ERROR STATE
Dim Shared m_sError As String: m_sError = ""
Dim Shared m_sIncludeError As String: m_sIncludeError = ""
' RAW INPUT VARIABLES
Dim Shared mousemessage As String
Dim Shared rawinputdevices As String
' MOUSE VARIABLES
Dim Shared arrMouse(0 To 8) As MouseInfoType ' STORES INFO FOR EACH MOUSE
'Dim Shared arrRawMouseID(8) As Long ' device IDs for mice connected to system (guessing this would be a string, dunno)
Dim Shared iMouseCount As Integer ' # OF MICE ATTACHED
' KEYBOARD VARIABLES
Dim Shared arrKeyboard(0 To 8) As KeyboardInfoType ' STORES INFO FOR EACH KEYBOARD
Dim Shared iKeyboardCount As Integer ' # OF KEYBOARDS ATTACHED
Dim Shared arrKeyState(0 To 8, 1 To 512) As Integer ' arrKeyState({device#}, {keyCode}) = TRUE if key {keyCode} on keyboard {device#} is currently held down.
Dim Shared arrScreen(1 To 80, 1 To 25) As String ' STORES TEXT FOR SCREEN
Dim Shared iMinX As Long
Dim Shared iMaxX As Long
Dim Shared iMinY As Long
Dim Shared iMaxY As Long
' RAW FILE NAMES
Dim Shared arrFile(0 To 31, 0 To 1) As String
' NETWORK VARIABLES
Dim Shared uintPort As _Unsigned Integer ' port
Dim Shared lngConn As Long ' c&
Dim Shared iData As Integer ' i
Dim Shared sOutput As String ' s$
' HANDLE FOR THE PROGRAM WINDOW
Dim Shared MyHwnd As _Offset ' _Integer64 hwnd%&
'Dim As Offset hwndMain
Dim Shared hwndMain As _Offset
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END GLOBAL VARIABLES
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' EXECUTION STARTS HERE!
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' =============================================================================
' START THE MAIN ROUTINE
main
' =============================================================================
' FINISH
'Print m_ProgramName$ + " finished."
'End
System ' return control to the operating system
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN GLOBAL ERROR HANDLER
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
ErrorHandler:
m_sError = "Error #" + _Trim$(Str$(Err)) + " at line " + _Trim$(Str$(_ErrorLine)) + "."
m_sIncludeError = "File " + Chr$(34) + _InclErrorFile$ + Chr$(34) + " at line " + _Trim$(Str$(_InclErrorLine)) + "."
Resume Next
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END GLOBAL ERROR HANDLER
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN DATA STATEMENTS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' MOUSE CURSORS (JUST SOME LETTERS)
CData:
Data A,b,C,D,E,f,G,H
' DEFAULT/INTIAL X COORDINATE OF EACH CURSOR ON SCREEN
XData:
Data 5,15,25,35,45,55,65,75
' DEFAULT/INTIAL Y COORDINATE OF EACH CURSOR ON SCREEN
YData:
Data 17,17,19,19,21,21,23,23
' DEFAULT/INITIAL VALUE OF EACH SCROLL WHEEL
WData:
Data 224,192,160,128,96,64,32,0
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END DATA STATEMENTS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN MAIN ROUTINES
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' /////////////////////////////////////////////////////////////////////////////
Sub main
Dim sPort As String
Dim iLoop As Integer
Dim in$
' MAKE SURE WE HAVE INPUT
sPort = Command$(1)
If Len(sPort) > 0 Then
If IsNumber%(sPort) = TRUE Then
' OPEN CONNECTION
uintPort = Val(sPort)
lngConn = _OpenClient("tcp/ip:" + _Trim$(Str$(uintPort)) + ":localhost")
Print lngConn
' ****************************************************************************************************************************************************************
' ****************************************************************************************************************************************************************
' RETHINK DATA STRUCTURE
' ****************************************************************************************************************************************************************
' ****************************************************************************************************************************************************************
' INITIALIZE
For iLoop = LBound(arrFile) To UBound(arrFile)
arrFile(iLoop, cFileName) = m_ProgramPath$ + "mouse" + _Trim$(Str$(iLoop)) + ".txt"
arrFile(iLoop, cFileData) = ""
Next iLoop
' INITIALIZE
iMinX = 0
iMaxX = 3583
iMinY = 0
iMaxY = 8202
' ****************************************************************************************************************************************************************
' ****************************************************************************************************************************************************************
' SET UP WINDOW TO BE SAME SIZE AS, AND OVERLAPPED WITH HOST WINDOW
' ****************************************************************************************************************************************************************
' ****************************************************************************************************************************************************************
' SET UP WINDOW
'Screen _NewImage(1024, 768, 32)
Screen 12 ' SCREEN 12 can use 16 color attributes with a black background. 256K possible RGB color hues. Background colors can be used with QB64.
' window needs to be lined up directly under the main program, so the mouse coordinates align with the display
_ScreenMove 0, 0 ' <<< NOT WORKING, HOW DO WE DO THIS IN THE EVENT MODEL?
' CREATE TRIGGER FILE
Open m_sTriggerFile For Output As #1
Print #1, "Deleting this file will cause program " + m_ProgramName$ + " to stop running."
Close #1
' GET HANDLE TO THE PROGRAM WINDOW
Do
MyHwnd = _WindowHandle
Loop Until MyHwnd
' GIVE CONTROL TO THE EVENT-ORIENTED CODE
System Val(Str$(WinMain))
Else
Print "Invalid non-numeric input " + Chr$(34) + sPort + Chr$(34) + ". Exiting."
End If
Else
Print "No input. Exiting."
End If
End Sub ' main
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END MAIN ROUTINES
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN RAW INPUT FUNCTIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' /////////////////////////////////////////////////////////////////////////////
' Runs first
Function WinMain~%& ()
'Dim As Offset hwndMain
Dim As Offset hInst
Dim As Offset hWndTop
Dim As MSG msg
Dim As WNDCLASSEX wndclass
Dim As String szMainWndClass
Dim As String szWinTitle
Dim As Unsigned Integer reg
Dim sData As String
'DEBUG: TRY FULL SCREEN <- PROGRAM CRASHES!
'_FullScreen _SquarePixels
hInst = GetModuleHandle(0)
szMainWndClass = "WinTestWin" + Chr$(0)
'szWinTitle = "Hello" + Chr$(0)
szWinTitle = cProgName + Chr$(0)
wndclass.lpszClassName = Offset(szMainWndClass)
wndclass.cbSize = Len(wndclass)
wndclass.style = CS_HREDRAW Or CS_VREDRAW
wndclass.lpfnWndProc = WindowProc
wndclass.hInstance = hInst 'GetModuleHandle(0) will return the hInstance of this EXE
wndclass.hIcon = LoadIcon(0, MAKEINTRESOURCE(IDI_APPLICATION))
wndclass.hIconSm = LoadIcon(0, MAKEINTRESOURCE(IDI_APPLICATION))
wndclass.hCursor = LoadCursor(0, MAKEINTRESOURCE(IDC_ARROW))
wndclass.hbrBackground = COLOR_WINDOW + 1
reg = RegisterClassEx(Offset(wndclass)) 'I prefer to use the output of RegisterClassEx rather than the window name
'DEBUG: SUBSTITUTE _WindowHandle
'Function CreateWindowEx%& (
' ByVal dwExStyle As Unsigned Long = 0
' Byval lpClassName As Offset = MAKELPARAM(reg, 0)
' Byval lpWindowName As Offset = Offset(szWinTitle)
' Byval dwStyle As Unsigned Long = WS_OVERLAPPEDWINDOW
' Byval x As Long = CW_USEDEFAULT
' Byval y As Long = CW_USEDEFAULT
' Byval nWidth As Long = CW_USEDEFAULT
' Byval nHeight As Long = CW_USEDEFAULT
' Byval hWndParent As Offset = 0
' Byval hMenu As Offset = 0
' Byval hInstance As Offset = hInst
' Byval lpParam As Offset = 0
' hwndMain = CreateWindowEx( _
' 0, _
' MAKELPARAM(reg, 0), _
' Offset(szWinTitle), _
' WS_OVERLAPPEDWINDOW, _
' CW_USEDEFAULT, _
' CW_USEDEFAULT, _
' CW_USEDEFAULT, _
' CW_USEDEFAULT, _
' 0, _
' 0, _
' hInst, _
' 0)
hwndMain = CreateWindowEx( _
0, _
MAKELPARAM(reg, 0), _
Offset(szWinTitle), _
WS_OVERLAPPEDWINDOW, _
0, _
0, _
1024, _
768, _
0, _
0, _
hInst, _
0)
'hwndMain = _WindowHandle
ShowWindow hwndMain, SW_SHOW
' TURN SUB WINDOW INVISIBLE
''SetWindowOpacity MyHwnd, cInvisible
'SetWindowOpacity hwndMain, cInvisible
' KEEP WINDOW VISIBLE
UpdateWindow hwndMain
'DEBUG: SUBSTITUTE _WindowHandle
'UpdateWindow _WindowHandle
'' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
'' SEND SUB WINDOW HANDLE BACK TO MAIN
'sData = _Trim$(Str$(hwndMain))
'Put #lngConn, , sData
'' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' START THE INPUT ROUTINES
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
InitRawInput
InitMouseTest 'TODO: SAVE_MOUSE_INFO
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' MAIN LOOP
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
While GetMessage(Offset(msg), 0, 0, 0)
TranslateMessage Offset(msg)
DispatchMessage Offset(msg)
' QUIT IF TRIGGER FILE IS GONE
If _FileExists(m_sTriggerFile) = FALSE Then
System
End If
' SEE IF WE CAN DETECT KEYPRESSES
' IF USER PRESSES A THEN SHOW WINDOW
If _KeyDown(65) Or _KeyDown(97) Then
Beep
'SetWindowOpacity MyHwnd, cVisible
End If
' IF USER PRESSES B THEN MAKE WINDOW TRANSPARENT
If _KeyDown(66) Or _KeyDown(98) Then
Beep
Beep
'SetWindowOpacity MyHwnd, cTransparent
End If
' IF USER PRESSES C THEN HIDE WINDOW
If _KeyDown(67) Or _KeyDown(99) Then
Beep
Beep
Beep
'SetWindowOpacity MyHwnd, cInvisible
End If
' IF USER PRESSES ESCAPE THEN EXIT
If _KeyDown(27) Then
DeleteFile m_sTriggerFile
'System
End If
' KEEP WINDOW ON TOP
If _WindowHasFocus = 0 Then
_ScreenIcon
''ShowWindow MyHwnd, 1
'ShowWindow hwndMain, 1
ShowWindow hwndMain, SW_SHOW
End If
Wend
WinMain = msg.wParam
End Function ' WinMain
' /////////////////////////////////////////////////////////////////////////////
' Handles main window events
Function MainWndProc%& (hwnd As Offset, nMsg As Unsigned Long, wParam As Unsigned Offset, lParam As Offset)
Static As Offset hwndButton
Static As Long cx, cy
Dim As Offset hdc
Dim As PAINTSTRUCT ps
Dim As RECT rc
Dim As MEM lpb
Dim As Unsigned Long dwSize
Dim As RAWINPUT raw
Dim As Long tmpx, tmpy
Static As Long maxx
Dim As RAWINPUTHEADER rih
' TEMP VARIABLES FOR DISPLAYING FORMATTED VALUES TO SCREEN
Dim strNextID As String
Dim iIndex As Integer
Dim iRowOffset As Integer
Dim iLen As Integer
Dim sCount As String
Dim sX As String
Dim sY As String
Dim sWheel As String
Dim sLeftDown As String
Dim sMiddleDown As String
Dim sRightDown As String
Dim sLeftCount As String
Dim sMiddleCount As String
Dim sRightCount As String
Dim sNext As String
Dim iNewX As Integer
Dim iNewY As Integer
Dim iDX As Integer
Dim iDY As Integer
' MORE TEMP VARIABLES
Dim iMouseNum As Integer
' HANDLE EVENTS
Select Case nMsg
Case WM_DESTROY
PostQuitMessage 0
MainWndProc = 0
Exit Function
Case WM_INPUT
GetRawInputData lParam, RID_INPUT, 0, Offset(dwSize), Len(rih)
lpb = MemNew(dwSize)
If lpb.SIZE = 0 Then
MainWndProc = 0
Exit Function
End If
If GetRawInputData(lParam, RID_INPUT, lpb.OFFSET, Offset(dwSize), Len(rih)) <> dwSize Then
'Print "GetRawInputData doesn't return correct size!"
mousemessage = "GetRawInputData doesn't return correct size!"
End If
MemGet lpb, lpb.OFFSET, raw
If raw.header.dwType = RIM_TYPEMOUSE Then
tmpx = raw.mouse.lLastX
tmpy = raw.mouse.lLastY
maxx = tmpx
' GET MOUSE INFO
' NOTES:
' ulButtons and usButtonFlags both return the same thing (buttons)
' usButtonData changes value when scroll wheel moved (just stays at one value)
'mousemessage = ""
'mousemessage = mousemessage + "Mouse:hDevice" + Str$(raw.header.hDevice)
'mousemessage = mousemessage + "usFlags=" + Hex$(raw.mouse.usFlags)
'mousemessage = mousemessage + "ulButtons=" + Hex$(MAKELONG(raw.mouse.usButtonFlags, raw.mouse.usFlags))
'mousemessage = mousemessage + "usButtonFlags=" + Hex$(raw.mouse.usButtonFlags)
'mousemessage = mousemessage + "usButtonData=" + Hex$(raw.mouse.usButtonData)
'mousemessage = mousemessage + "ulRawButtons=" + Hex$(raw.mouse.ulRawButtons)
'mousemessage = mousemessage + "lLastX=" + Str$(raw.mouse.lLastX)
'mousemessage = mousemessage + "lLastY=" + Str$(raw.mouse.lLastY)
'mousemessage = mousemessage + "ulExtraInformation=" + Hex$(raw.mouse.ulExtraInformation) + Chr$(13)
' UPDATE RANGE OF MOUSE COORDINATES
If GET_X_LPARAM(lParam) < iMinX Then iMinX = GET_X_LPARAM(lParam)
If GET_X_LPARAM(lParam) > iMaxX Then iMaxX = GET_X_LPARAM(lParam)
If GET_Y_LPARAM(lParam) < iMinY Then iMinY = GET_Y_LPARAM(lParam)
If GET_Y_LPARAM(lParam) > iMaxY Then iMaxY = GET_Y_LPARAM(lParam)
' IDENTIFY WHICH MOUSE IT IS
strNextID = _Trim$(Str$(raw.header.hDevice))
iIndex = GetMouseIndex%(strNextID)
If iIndex >= LBound(arrMouse) Then
If iIndex <= UBound(arrMouse) Then
' =============================================================================
' READ MOUSE MOVEMENT
' DOESN'T WORK, MOVES ALL OVER THE PLACE:
'' METHOD #1: SCALE MOUSE POSITION TO 80X25 POSITION
'iNewX = ( (GET_X_LPARAM(lParam) + 1) * 80) \ (iMaxX+1)
'iNewY = ( (GET_Y_LPARAM(lParam) + 1) * 25) \ (iMaxY+1)
'arrMouse(iIndex).x = iNewX
'arrMouse(iIndex).y = iNewY
' WORKS BUT NOT THAT ACCURATE:
' METHOD #2: INCREMENT/DECREMENT DELTA
If raw.mouse.lLastX < 0 Then
arrMouse(iIndex).dx = -1
ElseIf raw.mouse.lLastX > 0 Then
arrMouse(iIndex).dx = 1
Else
arrMouse(iIndex).dx = 0
End If
If raw.mouse.lLastY < 0 Then
arrMouse(iIndex).dy = -1
ElseIf raw.mouse.lLastY > 0 Then
arrMouse(iIndex).dy = 1
Else
arrMouse(iIndex).dy = 0
End If
' =============================================================================
'TODO: SAVE SCROLL WHEEL + BUTTONS
'Hex$(raw.mouse.usButtonFlags)
' left button = 1 when down, 2 when released
If ((raw.mouse.usButtonFlags And 1) = 1) Then
arrMouse(iIndex).LeftDown = TRUE
ElseIf ((raw.mouse.usButtonFlags And 2) = 2) Then
arrMouse(iIndex).LeftDown = FALSE
End If
' middle button = 16 when down, 32 when released
If ((raw.mouse.usButtonFlags And 16) = 16) Then
arrMouse(iIndex).MiddleDown = TRUE
ElseIf ((raw.mouse.usButtonFlags And 32) = 32) Then
arrMouse(iIndex).MiddleDown = FALSE
End If
' right button = 4 when down, 8 when released
If ((raw.mouse.usButtonFlags And 4) = 4) Then
arrMouse(iIndex).RightDown = TRUE
ElseIf ((raw.mouse.usButtonFlags And 8) = 8) Then
arrMouse(iIndex).RightDown = FALSE
End If
' scroll wheel = ???
'arrMouse(iIndex).wheel = ???
' DID VALUE CHANGE?
If arrMouse(iIndex).UpdateCount = 32767 Then
arrMouse(iIndex).UpdateCount = 1
Else
arrMouse(iIndex).UpdateCount = arrMouse(iIndex).UpdateCount + 1
End If
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' COLLECT VALUES FOR THIS MOUSE TO SEND
' IN THE FOLOWING TAB-DELIMITED FORMAT:
' {mouse #}\t{count}\t{dx}\t{dy}\t{wheel}\t{leftDown}\t{middleDown}\t{rightDown}\n
sOutput = ""
sOutput = sOutput + _Trim$(Str$(iIndex)) + Chr$(9)
sOutput = sOutput + _Trim$(Str$(arrMouse(iIndex).UpdateCount)) + Chr$(9)
sOutput = sOutput + _Trim$(Str$(arrMouse(iIndex).dx)) + Chr$(9)
sOutput = sOutput + _Trim$(Str$(arrMouse(iIndex).dy)) + Chr$(9)
sOutput = sOutput + _Trim$(Str$(arrMouse(iIndex).wheel)) + Chr$(9)
sOutput = sOutput + _Trim$(Str$(arrMouse(iIndex).LeftDown)) + Chr$(9)
sOutput = sOutput + _Trim$(Str$(arrMouse(iIndex).MiddleDown)) + Chr$(9)
sOutput = sOutput + _Trim$(Str$(arrMouse(iIndex).RightDown)) + Chr$(13)
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' SEND VALUES FOR THIS MOUSE TO HOST
Put #lngConn, , sOutput
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' CLEAR MOVEMENT
arrMouse(iIndex).dx = 0
arrMouse(iIndex).dy = 0
End If
End If
' UPDATE mousemessage WITH PLAYING FIELD
mousemessage = ScreenToString$
' ================================================================================================================================================================
' END WRITE OUTPUT FILE
' ================================================================================================================================================================
InvalidateRect hwnd, 0, -1
SendMessage hwnd, WM_PAINT, 0, 0
MainWndProc = 0
ElseIf raw.header.dwType = RIM_TYPEKEYBOARD Then
' TODO: READ KEYBOARD INPUT
' SEE:
' https://www.codeproject.com/Articles/17123/Using-Raw-Input-from-C-to-handle-multiple-keyboard
' https://forum.powerbasic.com/forum/user-to-user-discussions/powerbasic-for-windows/55985-raw-keyboard-hid-input-discussion
' https://hackaday.io/project/5364-cheap-windows-jogkeyboard-controller-for-cncs/log/16843-looking-at-rawinput-for-more-detail
' WinAPI Raw Input confusion - For Beginners - GameDev.net
' https://www.gamedev.net/forums/topic/700010-winapi-raw-input-confusion/
'iKeyboardCount = iKeyboardCount + 1 ' # KEYBOARDS ATTACHED
'strNextID = _Trim$(Str$(rawdevs(x).hDevice))
'arrKeyboard(iKeyboardCount - 1).ID = strNextID
' TODO: READ KEYBOARD AND STORE KEYBOARD STATE
'arrKeyState(0 To 8, 1 To 512) As Integer ' arrKeyState({device#}, {keyCode}) = TRUE if key {keyCode} on keyboard {device#} is currently held down.
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)
arrMouse(iIndex).dx = -1
ElseIf GET_X_LPARAM(lParam) > iMaxX Then
iMaxX = GET_X_LPARAM(lParam)
arrMouse(iIndex).dx = 1
Else
arrMouse(iIndex).dx = 0
End If
If GET_Y_LPARAM(lParam) < iMinY Then
iMinY = GET_Y_LPARAM(lParam)
arrMouse(iIndex).dy = -1
ElseIf GET_Y_LPARAM(lParam) > iMaxY Then
iMaxY = GET_Y_LPARAM(lParam)
arrMouse(iIndex).dy = 1
Else
arrMouse(iIndex).dy = 0
End If
' IDENTIFY WHICH MOUSE IT IS
strNextID = _Trim$(Str$(raw.header.hDevice))
iIndex = GetMouseIndex%(strNextID)
If iIndex >= LBound(arrMouse) Then
If iIndex <= UBound(arrMouse) Then
' =============================================================================
' UPDATE ABSOLUTE POSITION
' 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)
'arrMouse(iIndex).x = iNewX
'arrMouse(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?)
'arrMouse(iIndex).wheel =
'arrMouse(iIndex).LeftDown =
'arrMouse(iIndex).MiddleDown =
'arrMouse(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
If _KeyDown(27) Then End
End Function ' MainWndProc
' /////////////////////////////////////////////////////////////////////////////
' Initializes raw input stuff
Sub InitRawInput ()
Dim As RAWINPUTDEVICE Rid(0 To 49)
Dim As Unsigned Long nDevices
Dim As RAWINPUTDEVICELIST RawInputDeviceList
Dim As MEM pRawInputDeviceList
ReDim As RAWINPUTDEVICELIST rawdevs(-1)
Dim As Unsigned Long x
Dim strNextID As String
'dim lngNextID as long
If GetRawInputDeviceList(0, Offset(nDevices), Len(RawInputDeviceList)) <> 0 Then
Exit Sub
End If
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 / KEYBOARD INFO
iMouseCount = 0
iKeyboardCount = 0
rawinputdevices = "Number of raw input devices:" + Str$(nDevices) + Chr$(13)
For x = 0 To UBound(rawdevs)
rawinputdevices = rawinputdevices + Str$(rawdevs(x).hDevice) + ":" + Str$(rawdevs(x).dwType) + Chr$(13)
' RAWINPUTHEADER (winuser.h) - Win32 apps | Microsoft Learn
' https://learn.microsoft.com/en-us/windows/win32/api/winuser/ns-winuser-rawinputheader
' dwType
' Type: DWORD
' The type of raw input. It can be one of the following values:
' Constant Value Meaning
' RIM_TYPEMOUSE 0 Raw input comes from the mouse.
' RIM_TYPEKEYBOARD 1 Raw input comes from the keyboard.
' RIM_TYPEHID 2 Raw input comes from some device that is not a keyboard or a mouse.
' WHAT TYPE OF DEVICE IS IT?
'If rawdevs(x).dwType = 0 Then
If rawdevs(x).dwType = RIM_TYPEMOUSE Then
iMouseCount = iMouseCount + 1
strNextID = _Trim$(Str$(rawdevs(x).hDevice))
'lngNextID = Val(strNextID)
'arrMouse(iMouseCount-1).ID = lngNextID
arrMouse(iMouseCount - 1).ID = strNextID
arrMouse(iMouseCount - 1).UpdateCount = 0
'TODO: SAVE_MOUSE_INFO
ElseIf rawdevs(x).dwType = RIM_TYPEKEYBOARD Then
iKeyboardCount = iKeyboardCount + 1 ' # KEYBOARDS ATTACHED
strNextID = _Trim$(Str$(rawdevs(x).hDevice))
arrKeyboard(iKeyboardCount - 1).ID = strNextID
arrKeyboard(iKeyboardCount - 1).UpdateCount = 0
' TODO: READ KEYBOARD AND STORE KEYBOARD STATE
'arrKeyState(0 To 8, 1 To 512) As Integer ' arrKeyState({device#}, {keyCode}) = TRUE if key {keyCode} on keyboard {device#} is currently held down.
End If
Next x
rawinputdevices = rawinputdevices + Chr$(0)
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 WINDOW FUNCTIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' /////////////////////////////////////////////////////////////////////////////
' hWnd = handle to window to set opacity for
' Level = 0 TO 255, 0=totally invisible, 128=transparent, 255=100% solid
Sub SetWindowOpacity (hWnd As _Offset, Level As _Unsigned _Byte)
Const cIndex = -20
Const LWA_ALPHA = &H2
Const WS_EX_LAYERED = &H80000
Dim lngMsg As Long
Dim lngValue As Long
'Function GetWindowLong& Alias "GetWindowLongA" (ByVal hwnd As _Offset, Byval nIndex As Long)
lngMsg = GetWindowLong(hWnd, cIndex)
lngMsg = lngMsg Or WS_EX_LAYERED
'Function SetWindowLong& Alias "SetWindowLongA" (ByVal hwnd As _Offset, Byval nIndex As Long, Byval dwNewLong As Long)
lngValue = SetWindowLong(hWnd, cIndex, lngMsg)
'Function SetLayeredWindowAttributes& (ByVal hwnd As _Offset, Byval crKey As Long, Byval bAlpha As _Unsigned _Byte, Byval dwFlags As Long)
lngValue = SetLayeredWindowAttributes(hWnd, 0, Level, LWA_ALPHA)
End Sub ' SetWindowOpacity
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END WINDOW FUNCTIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN 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(arrMouse) - 1
For iLoop = 1 To iMouseCount
iIndex = iIndex + 1
Read arrMouse(iIndex).c
' INITIALIZED BELOW: arrMouse(iIndex).x = 0
' INITIALIZED BELOW: arrMouse(iIndex).y = 0
' INITIALIZED BELOW: arrMouse(iIndex).wheel = 127
arrMouse(iIndex).LeftDown = FALSE
arrMouse(iIndex).MiddleDown = FALSE
arrMouse(iIndex).RightDown = FALSE
arrMouse(iIndex).LeftCount = 0
arrMouse(iIndex).MiddleCount = 0
arrMouse(iIndex).RightCount = 0
arrMouse(iIndex).UpdateCount = 1
Next iLoop
' INITIALIZE X COORDINATES
Restore XData
iIndex = LBound(arrMouse) - 1
For iLoop = 1 To iMouseCount
iIndex = iIndex + 1
Read arrMouse(iIndex).x
Next iLoop
' INITIALIZE Y COORDINATES
Restore YData
iIndex = LBound(arrMouse) - 1
For iLoop = 1 To iMouseCount
iIndex = iIndex + 1
Read arrMouse(iIndex).y
Next iLoop
' INITIALIZE SCROLL WHEEL
Restore WData
iIndex = LBound(arrMouse) - 1
For iLoop = 1 To iMouseCount
iIndex = iIndex + 1
Read arrMouse(iIndex).wheel
Next iLoop
End Sub ' InitMouseTest
' /////////////////////////////////////////////////////////////////////////////
' Finds position in array arrMouse where .ID = MouseID
Function GetMouseIndex% (MouseID As String)
Dim iLoop As Integer
Dim iIndex%
iIndex% = LBound(arrMouse) - 1
For iLoop = LBound(arrMouse) To UBound(arrMouse)
If arrMouse(iLoop).ID = MouseID Then
iIndex% = iLoop
Exit For
Else
' not it
End If
Next iLoop
GetMouseIndex% = iIndex%
End Function ' GetMouseIndex%
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END MOUSE TEST FUNCTIONS #1
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN TEST OUTPUT FUNCTIONS FOR API CONTROLLED UI
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' /////////////////////////////////////////////////////////////////////////////
' Clears global array arrScreen
Sub ClearText
Dim iColNum As Integer
Dim iRowNum As Integer
For iColNum = LBound(arrScreen, 1) To UBound(arrScreen, 1)
For iRowNum = LBound(arrScreen, 2) To UBound(arrScreen, 2)
arrScreen(iColNum, iRowNum) = " "
Next iRowNum
Next iColNum
End Sub ' ClearText
' /////////////////////////////////////////////////////////////////////////////
' Plots string MyString to position (iX, iY) in global array arrScreen.
Sub WriteText (iRow As Integer, iColumn As Integer, MyString As String)
Dim iPos As Integer
Dim iLoop As Integer
If iColumn > 0 And iColumn < 81 Then
If iRow > 0 And iRow < 26 Then
For iLoop = 1 To Len(MyString)
iPos = iColumn + (iLoop - 1)
If iPos < 81 Then
arrScreen(iPos, iRow) = Mid$(MyString, iLoop, 1)
Else
Exit For
End If
Next iLoop
End If
End If
End Sub ' WriteText
' /////////////////////////////////////////////////////////////////////////////
' Converts global array arrScreen to a string.
Function ScreenToString$
Dim sResult As String
Dim iColNum As Integer
Dim iRowNum As Integer
sResult = ""
For iRowNum = LBound(arrScreen, 2) To UBound(arrScreen, 2)
For iColNum = LBound(arrScreen, 1) To UBound(arrScreen, 1)
sResult = sResult + arrScreen(iColNum, iRowNum)
Next iColNum
sResult = sResult + Chr$(13)
Next iRowNum
ScreenToString$ = sResult
End Function ' ScreenToString$
' /////////////////////////////////////////////////////////////////////////////
' based on code from:
' Qbasic Programs - Download free bas source code
' http://www.thedubber.altervista.org/qbsrc.htm
Sub DrawTextLine (y%, x%, y2%, x2%, c$)
Dim i%
Dim steep%
Dim e%
Dim sx%
Dim dx%
Dim sy%
Dim dy%
i% = 0: steep% = 0: e% = 0
If (x2% - x%) > 0 Then sx% = 1: Else sx% = -1
dx% = Abs(x2% - x%)
If (y2% - y%) > 0 Then sy% = 1: Else sy% = -1
dy% = Abs(y2% - y%)
If (dy% > dx%) Then
steep% = 1
Swap x%, y%
Swap dx%, dy%
Swap sx%, sy%
End If
e% = 2 * dy% - dx%
For i% = 0 To dx% - 1
If steep% = 1 Then
''PSET (y%, x%), c%:
'Locate y%, x% : Print c$;
WriteText y%, x%, c$
Else
''PSET (x%, y%), c%
'Locate x%, y% : Print c$;
WriteText x%, y%, c$
End If
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 FOR API CONTROLLED UI
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN MOUSE FUNCTIONS TO COME
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' /////////////////////////////////////////////////////////////////////////////
' Returns a count of # of RawInput mouse devices connected to the system
' *****************************************************************************
' TODO: GET COUNT FROM RawInput API
' For now, hardcoded to 1 until we figure out how to do this.
' *****************************************************************************
Function GetRawMouseCount% ()
GetRawMouseCount% = 1
End Function ' GetRawMouseCount%
' /////////////////////////////////////////////////////////////////////////////
' Gets ID of each RawInput mouse device connected to the system (for now upto 8)
' Returns the IDs in an array of LONG <- may change depending on whether
' we save each the device handle for each mouse or the index
' If no mouse found, the ID will just be 0 <- or whatever value we decide as default/none
' *****************************************************************************
' TODO: GET THIS FROM RawInput API
' For now, hardcoded arrRawMouseID(1) to 1, and the rest 0, until we figure out how to do this.
' *****************************************************************************
'Sub GetRawMouseIDs (arrRawMouseID( 8) As Integer)
Sub GetRawMouseIDs ()
Dim iLoop As Integer
' CLEAR OUT IDs
For iLoop = 1 To 8
''arrRawMouseID(iLoop) = 0
'arrMouse(iLoop).ID = 0
arrMouse(iLoop).ID = ""
Next iLoop
' GET IDs
'TODO: get this from RawInput API
''arrRawMouseID(1) = 1 ' for now just fudge it!
'arrMouse(0).ID = 1 ' for now just fudge it!
End Sub ' GetRawMouseIDs
' /////////////////////////////////////////////////////////////////////////////
' Read mouse using RawInput API
' Gets input from mouse, MouseID% = which mouse
' NOTE: click events (mouse up/mouse down) are handled by the calling sub,
' this routine just sends back
' TRUE if the given button is currently down or FALSE if it is up.
' Parameters (input only):
' MouseID% = which mouse to return input for
' wheelMin% = minimum value to allow wheelValue% to be decremented to
' wheelMax% = maximum value to allow wheelValue% to be incremened to
' Parameters (values returned):
' x% = mouse x position
' y% = mouse y position
' leftButton% = current state of left mouse button (up or down)
' middleButton% = current state of middle mouse button / scroll wheel button (up or down)
' rightButton% = current state of right mouse button (up or down)
' wheelValue% = value of mouse scroll wheel (passed in and incremented/decremented by 1 if wheel move detected)
Sub ReadRawMouse (MouseID%, x%, y%, leftButton%, middleButton%, rightButton%, wheelValue%, wheelMin%, wheelMax%)
Dim scrollAmount%
Dim dx%
Dim dy%
' =============================================================================
' BEGIN READ MOUSE THE NEW RawInput WAY:
' read scroll wheel
'TODO: get this from RawInput API
' determine mouse x position
'TODO: get this from RawInput API
dx% = 0 ' = getMouseDx(MouseID%)
x% = x% + dx% ' adjust mouse value by dx
' determine mouse y position
'TODO: get this from RawInput API
dy% = 0 ' = getMouseDy(MouseID%)
y% = y% + dy% ' adjust mouse value by dx
' read mouse buttons
'TODO: get this from RawInput API
leftButton% = FALSE
middleButton% = FALSE
rightButton% = FALSE
' END READ MOUSE THE NEW RawInput WAY:
' =============================================================================
' =============================================================================
' BEGIN READ MOUSE THE OLD QB64 WAY:
'
'' read scroll wheel
'WHILE _MOUSEINPUT ' get latest mouse information
' scrollAmount% = _MOUSEWHEEL ' (Returns -1 when scrolling up and 1 when scrolling down with 0 indicating no movement since last read.)
' IF (scrollAmount% = -1) AND (wheelValue% > wheelMin%) THEN
' wheelValue% = wheelValue% + scrollAmount%
' ELSEIF (scrollAmount% = 1) AND (wheelValue% < wheelMax%) THEN
' wheelValue% = wheelValue% + scrollAmount%
' END IF
'WEND
'
'' determine mouse x position
'x% = _MOUSEX
'
'' determine mouse y position
'y% = _dy
'
'' read mouse buttons
'leftButton% = _MOUSEBUTTON(1)
'middleButton% = _MOUSEBUTTON(3)
'rightButton% = _MOUSEBUTTON(2)
'
' END READ MOUSE THE OLD QB64 WAY:
' =============================================================================
End Sub ' ReadRawMouse
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END MOUSE FUNCTIONS TO COME
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN ERROR HANDLING HELPER FUNCTIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Sub ErrorClear
m_sError = ""
m_sIncludeError = ""
End Sub ' ErrorClear
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END ERROR HANDLING HELPER FUNCTIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN FILE FUNCTIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' /////////////////////////////////////////////////////////////////////////////
' QB64 Phoenix Edition › QB64 Rising › Code and Stuff › Help Me!
' Using shell to delete a file
' https://qb64phoenix.com/forum/showthread.php?tid=2618&pid=24683#pid24683
' a740g
' #5
' 04-24-2024, 06:05 AM
'
' There are no commands to directly make copies or backup of files.
' But you could write one with a few lines of code like:
'
' Copies src to dst
' Set overwite to true if dst should be overwritten if present
Sub CopyFile (src As String, dst As String, overwrite As _Byte)
If _FileExists(src) Then
If Not _FileExists(dst) Or (_FileExists(dst) And overwrite) Then
_WriteFile dst, _ReadFile$(src)
End If
End If
End Sub ' CopyFile
' /////////////////////////////////////////////////////////////////////////////
' Convert a value to string and trim it (because normal Str$ adds spaces)
Function cstr$ (myValue)
'cstr$ = LTRIM$(RTRIM$(STR$(myValue)))
cstr$ = _Trim$(Str$(myValue))
End Function ' cstr$
' /////////////////////////////////////////////////////////////////////////////
' QB64 Phoenix Edition › QB64 Rising › Code and Stuff › Help Me!
' Using shell to delete a file
' https://qb64phoenix.com/forum/showthread.php?tid=2618
Sub DeleteFile (sFile As String)
If _FileExists(sFile) Then
'Shell "DELETE " + sFile
'Shell "del " + sFile
Kill sFile
End If
End Sub ' DeleteFile
' /////////////////////////////////////////////////////////////////////////////
Function FileExt$ (sFile As String)
Dim iPos As Integer
iPos = _InStrRev(sFile, ".")
If iPos > 0 Then
If Len(sFile) > 1 Then
If iPos > 1 Then
FileExt$ = Right$(sFile, Len(sFile) - iPos)
Else
' dot is first character, return everything after it
FileExt$ = Right$(sFile, Len(sFile) - 1)
End If
Else
' file only has one character, the dot, the file extension is blank
FileExt$ = ""
End If
Else
' no dot found, the file extension is blank
FileExt$ = ""
End If
End Function ' FileExt$
' /////////////////////////////////////////////////////////////////////////////
Function NameOnly$ (sFile As String, sSlash As String)
Dim iPos As Integer
'sFile = Replace$(sFile, "/", "\")
iPos = _InStrRev(sFile, sSlash)
If iPos > 0 Then
If Len(sFile) > 1 Then
If iPos > 1 Then
NameOnly$ = Right$(sFile, Len(sFile) - iPos)
Else
' slash is first character, return everything after it
NameOnly$ = Right$(sFile, Len(sFile) - 1)
End If
Else
' file only has one character, the slash, name is blank
NameOnly$ = ""
End If
Else
' slash not found, return the entire thing
NameOnly$ = sFile
End If
End Function ' NameOnly$
' /////////////////////////////////////////////////////////////////////////////
Function NoExt$ (sFile As String)
Dim iPos As Integer
iPos = _InStrRev(sFile, ".")
If iPos > 0 Then
If Len(sFile) > 1 Then
If iPos > 1 Then
NoExt$ = Left$(sFile, iPos - 1)
Else
' dot is first character, removing it returns blank!
' our version will just return the name unchanged
' but you can return blank if you prefer
NoExt$ = sFile
End If
Else
' file only has one character, the dot, removing it returns blank!
' our version will just return the name unchanged
' but you can return blank if you prefer
NoExt$ = sFile
End If
Else
' no dot found
' return the name unchanged
NoExt$ = sFile
End If
End Function ' NoExt$
' /////////////////////////////////////////////////////////////////////////////
Function PathOnly$ (sFile As String, sSlash As String)
Dim iPos As Integer
'sFile = Replace$(sFile, "/", "\")
iPos = _InStrRev(sFile, sSlash)
If iPos > 0 Then
If Len(sFile) > 1 Then
If iPos > 1 Then
PathOnly$ = Left$(sFile, iPos)
Else
' slash is first character, so not much of a path, return blank
PathOnly$ = ""
End If
Else
' file only has one character, the slash, name is blank
PathOnly$ = ""
End If
Else
' slash not found, so not a path, return blank
PathOnly$ = ""
End If
End Function ' PathOnly$
' /////////////////////////////////////////////////////////////////////////////
' Writes sText to file sFileName.
' If bAppend=TRUE appends to file, else overwrites it.
' Returns blank if successful else returns error message.
' Example:
' ProgramPath$ = Left$(Command$(0), _InStrRev(Command$(0), "\"))
' ProgramName$: m_ProgramName$ = Mid$(Command$(0), _InStrRev(Command$(0), "\") + 1)
' sFileName = ProgramPath$ + ProgramName$ + ".OUT.txt"
' sText = "This is a test." + chr$(13) + "Here is line 2." + chr$(13) + "End."
' sError = PrintFile$(sFileName, sText, FALSE)
Function PrintFile$ (sFileName As String, sText As String, bAppend As Integer)
Dim sError As String: sError = ""
If (bAppend = TRUE) Then
If _FileExists(sFileName) Then
Open sFileName For Append As #1 ' opens an existing file for appending
Else
sError = "Error in PrintFile$ : File not found. Cannot append."
End If
Else
Open sFileName For Output As #1 ' opens and clears an existing file or creates new empty file
End If
If Len(sError) = 0 Then
' NOTE: WRITE places text in quotes in the file
'WRITE #1, x, y, z$
'WRITE #1, sText
' PRINT does not put text inside quotes
Print #1, sText
Close #1
End If
PrintFile$ = sError
End Function ' PrintFile$
' /////////////////////////////////////////////////////////////////////////////
' Fastest way is always to just read the whole life at once and then parse it.
Function ReadTextFile$ (sFileName As String, sDefault As String)
Dim x$
If _FileExists(sFileName) Then
Open sFileName For Binary As #1
x$ = Space$(LOF(1))
Get #1, 1, x$
Close #1
ReadTextFile$ = x$
Else
ReadTextFile$ = sDefault
End If
End Function ' ReadTextFile$
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END FILE FUNCTIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN GENERAL PURPOSE FUNCTIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' /////////////////////////////////////////////////////////////////////////////
' FOR BITWISE OPERATIONS
Function HasBit% (iByte As Integer, iBit As Integer)
''TODO: precalculate
'dim shared m_arrBitValue(1 To 8) As Integer
'dim iLoop as Integer
'For iLoop = 0 To 7
' m_arrBitValue(iLoop + 1) = 2 ^ iLoop
'Next iLoop
'HasBit% = ((iByte And m_arrBitValue(iBit)) = m_arrBitValue(iBit))
Dim iBitValue As Integer
iBitValue = 2 ^ (iBit - 1)
HasBit% = ((iByte And iBitValue) = iBitValue)
End Function ' HasBit%
' /////////////////////////////////////////////////////////////////////////////
' Returns TRUE if value OriginalString$ is numeric.
' Re: Does a Is Number function exist in QB64?
' https://www.qb64.org/forum/index.php?topic=896.15
' Version 2 by madscijr
' Returns TRUE (-1) if string is an integer, FALSE (0) if not
' Version 1 by MWheatley
' Reply #18 on: January 01, 2019, 11:24:30 AM
' returns 1 if string is an integer, 0 if not
Function IsNumber% (OriginalString$)
Dim bResult%: bResult% = FALSE
Dim iLoop%
Dim TestString$
'Dim bNegative%
Dim iDecimalCount%
Dim sNextChar$
'THEY SHOULD TRIM OUTSIDE THE FUNCTION!
'TestString$ = _TRIM$(OriginalString$)
If Len(OriginalString$) > 0 Then
TestString$ = ""
If Left$(OriginalString$, 1) = "+" Then
TestString$ = Right$(OriginalString$, Len(OriginalString$) - 1)
'bNegative% = FALSE
ElseIf Left$(OriginalString$, 1) = "-" Then
TestString$ = Right$(OriginalString$, Len(OriginalString$) - 1)
'bNegative% = TRUE
Else
TestString$ = OriginalString$
'bNegative% = FALSE
End If
If Len(TestString$) > 0 Then
bResult% = TRUE
iDecimalCount% = 0
For iLoop% = 1 To Len(TestString$)
sNextChar$ = Mid$(TestString$, iLoop%, 1)
If sNextChar$ = "." Then
iDecimalCount% = iDecimalCount% + 1
If iDecimalCount% > 1 Then
' TOO MANY DECIMAL POINTS, INVALID!
bResult% = FALSE
Exit For
End If
ElseIf Asc(sNextChar$) < 48 Or Asc(sNextChar$) > 57 Then
' NOT A NUMERAL OR A DECIMAL, INVALID!
bResult% = FALSE
Exit For
End If
Next iLoop%
End If
End If
IsNumber% = bResult%
End Function ' IsNumber%
' /////////////////////////////////////////////////////////////////////////////
' Split and join strings
' https://www.qb64.org/forum/index.php?topic=1073.0
'Combine all elements of in$() into a single string with delimiter$ separating the elements.
Function join$ (in$(), delimiter$)
Dim result$
Dim iLoop%
result$ = in$(LBound(in$))
For iLoop% = LBound(in$) + 1 To UBound(in$)
result$ = result$ + delimiter$ + in$(iLoop%)
Next iLoop%
join$ = result$
End Function ' join$
' /////////////////////////////////////////////////////////////////////////////
' Split and join strings
' https://www.qb64.org/forum/index.php?topic=1073.0
'
' FROM luke, QB64 Developer
' Date: February 15, 2019, 04:11:07 AM
'
' Given a string of words separated by spaces (or any other character),
' splits it into an array of the words. I've no doubt many people have
' written a version of this over the years and no doubt there's a million
' ways to do it, but I thought I'd put mine here so we have at least one
' version. There's also a join function that does the opposite
' array -> single string.
'
' Code is hopefully reasonably self explanatory with comments and a little demo.
' Note, this is akin to Python/JavaScript split/join, PHP explode/implode.
'Split in$ into pieces, chopping at every occurrence of delimiter$. Multiple consecutive occurrences
'of delimiter$ are treated as a single instance. The chopped pieces are stored in result$().
'
'delimiter$ must be one character long.
'result$() must have been REDIMmed previously.
' Modified to handle multi-character delimiters
Sub split (in$, delimiter$, result$())
Dim start As Integer
Dim finish As Integer
Dim iDelimLen As Integer
ReDim result$(-1)
iDelimLen = Len(delimiter$)
start = 1
Do
'While Mid$(in$, start, 1) = delimiter$
While Mid$(in$, start, iDelimLen) = delimiter$
'start = start + 1
start = start + iDelimLen
If start > Len(in$) Then
Exit Sub
End If
Wend
finish = InStr(start, in$, delimiter$)
If finish = 0 Then
finish = Len(in$) + 1
End If
ReDim _Preserve result$(0 To UBound(result$) + 1)
result$(UBound(result$)) = Mid$(in$, start, finish - start)
start = finish + 1
Loop While start <= Len(in$)
End Sub ' split
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END GENERAL PURPOSE FUNCTIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ################################################################################################################################################################
' #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%
' @ENDRE: why are these API declarations causing compilation to fail? - DSMan195276 - 05-24-2024
Based on the error, I believe it's because you have multiple `Declare Dynamic Library "user32"` sections in the code. Realistically speaking that should be allowed (or give a proper QB64 error), but combining the sections should solve that problem for the moment.
RE: why are these API declarations causing compilation to fail? - madscijr - 05-24-2024
(05-24-2024, 10:44 PM)DSMan195276 Wrote: Based on the error, I believe it's because you have multiple `Declare Dynamic Library "user32"` sections in the code. Realistically speaking that should be allowed (or give a proper QB64 error), but combining the sections should solve that problem for the moment.No kidding!
Yup... that did it!
Who knew it could be something so simple??
THANK YOU!