| Welcome, Guest |
You have to register before you can post on our site.
|
| Forum Statistics |
» Members: 483
» Latest member: aplus
» Forum threads: 2,803
» Forum posts: 26,423
Full Statistics
|
|
|
| read 2 or more USB mice on one PC - fully working with keyboard input |
|
Posted by: madscijr - 06-15-2024, 07:50 PM - Forum: Works in Progress
- Replies (2)
|
 |
This totally works for reading mouse input, give it a try.
It also detects keyup / keydown events.
Currently it just reads the one keyboard but that's good enough for most applications.
(To read keyboards with Raw Input, need to figure out how to define the RawInput type which has unions.)
Code: (Select All) ' *****************************************************************************
' NOTE: The following header files must be in same folder as this program:
' "makeint.h"
' "winproc.h"
' *****************************************************************************
' NOTE: THIS DETECTS A COUPLE "PHANTOM MICE" WHICH DON'T SEEM TO WORK
' I THINK THESE MIGHT BE MY LAPTOP'S TOUCHPAD AND TOUCHSCREEN?
' IS THERE SOME WAY TO IDENTIFY AND IGNORE THESE?
Option Explicit
_Title "multimouse"
$NoPrefix
$Console:Only
Console Off
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN CONSTANTS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Const FALSE = 0
Const TRUE = Not FALSE
Const cDebugEnabled = TRUE
' MIN/MAX VALUES FOR MOUSE TEST
Const cMinX = 1
Const cMaxX = 354 ' 160 ' 79
Const cMinY = 1 ' 16
Const cMaxY = 45 ' 24
Const cMinWheel = 0
Const cMaxWheel = 255
Const cMinPX = 1
Const cMaxPX = 1024
Const cMinPY = 1
Const cMaxPY = 768
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END CONSTANTS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ================================================================================================================================================================
' BEGIN API CONSTANTS
' ================================================================================================================================================================
Const COLOR_WINDOW = 5
Const CS_HREDRAW = &H0002
Const CS_VREDRAW = &H0001
Const CW_USEDEFAULT = &H80000000
Const DT_CENTER = &H00000001
Const DT_LEFT = &H00000000
Const DT_RIGHT = &H00000002
Const DT_VCENTER = &H00000004
Const DT_WORDBREAK = &H00000010
Const DT_SINGLELINE = &H00000020
Const Edit = 101
Const EM_GETSEL = &H00B0
Const EM_SETSEL = &H00B1
Const EN_CHANGE = &H0300
Const EN_KILLFOCUS = &H0200
Const EN_SETFOCUS = &H0100
Const GCL_HICON = -14
Const GCL_HICONSM = -34
Const Hid_Bottom = 66
Const Hid_Left = 33
Const Hid_Right = 34
Const HWND_DESKTOP = 0
Const ICON_BIG = 1
Const ICON_SMALL = 0
Const IDC_ARROW = 32512
Const IDI_APPLICATION = 32512
Const KEYEVENTF_KEYUP = &H0002
Const KL_NAMELENGTH = 9
Const LabelInfo = 201
Const MOUSE_ATTRIBUTES_CHANGED = &H04
Const MOUSE_MOVE_ABSOLUTE = &H01
Const MOUSE_MOVE_NOCOALESCE = &H08
Const MOUSE_MOVE_RELATIVE = &H00
Const MOUSE_VIRTUAL_DESKTOP = &H02
Const NULL = 0
Const RI_KEY_BREAK = 1
Const RI_KEY_E0 = 2
Const RI_KEY_E1 = 4
Const RI_KEY_MAKE = 0
Const RI_KEY_TERMSRV_SET_LED = 8
Const RI_KEY_TERMSRV_SHADOW = &H10
Const RID_INPUT = &H10000003
Const RIDEV_EXINPUTSINK = &H00001000
Const RIDI_DEVICEINFO = &H2000000B
Const RIM_TYPEMOUSE = 0
Const RIM_TYPEKEYBOARD = 1
Const RIM_TYPEHID = 2
Const RIM_TYPEUNKNOWN = -1 ' just a made up value to indicate type unknown
Const SIZE_MINIMIZED = 1
Const SW_SHOW = 5
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' BEGIN Virtual-Key Codes
' https://learn.microsoft.com/en-us/windows/win32/inputdev/virtual-key-codes
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' NOTE: raw.data.Keyboard.vKey may require set extended bit
Const VK_LBUTTON = &H01 ' dec = 1, Left mouse button
Const VK_RBUTTON = &H02 ' dec = 2, Right mouse button
Const VK_CANCEL = &H03 ' dec = 3, Control-break processing
Const VK_MBUTTON = &H04 ' dec = 4, Middle mouse button
Const VK_XBUTTON1 = &H05 ' dec = 5, X1 mouse button
Const VK_XBUTTON2 = &H06 ' dec = 6, X2 mouse button
'??? = &H07 ' dec = 7, Reserved
Const VK_BACK = &H08 ' dec = 8, BACKSPACE key
Const VK_TAB = &H09 ' dec = 9, TAB key
'??? = &H0A-0B ' dec = 10-11, Reserved
Const VK_CLEAR = &H0C ' dec = 12, CLEAR key
Const VK_RETURN = &H0D ' dec = 13, ENTER key
'??? = &H0E-0F ' dec = 14-15, Unassigned
Const VK_SHIFT = &H10 ' dec = 16, SHIFT key
Const VK_CONTROL = &H11 ' dec = 17, CTRL key
Const VK_MENU = &H12 ' dec = 18, ALT key
Const VK_PAUSE = &H13 ' dec = 19, PAUSE key
Const VK_CAPITAL = &H14 ' dec = 20, CAPS LOCK key
Const VK_KANA = &H15 ' dec = 21, IME Kana mode
Const VK_HANGUL = &H15 ' dec = 21, IME Hangul mode
Const VK_IME_ON = &H16 ' dec = 22, IME On
Const VK_JUNJA = &H17 ' dec = 23, IME Junja mode
Const VK_FINAL = &H18 ' dec = 24, IME final mode
Const VK_HANJA = &H19 ' dec = 25, IME Hanja mode
Const VK_KANJI = &H19 ' dec = 25, IME Kanji mode
Const VK_IME_OFF = &H1A ' dec = 26, IME Off
Const VK_ESCAPE = &H1B ' dec = 27, ESC key
Const VK_CONVERT = &H1C ' dec = 28, IME convert
Const VK_NONCONVERT = &H1D ' dec = 29, IME nonconvert
Const VK_ACCEPT = &H1E ' dec = 30, IME accept
Const VK_MODECHANGE = &H1F ' dec = 31, IME mode change request
Const VK_SPACE = &H20 ' dec = 32, SPACEBAR
Const VK_PRIOR = &H21 ' dec = 33, PAGE UP key
Const VK_NEXT = &H22 ' dec = 34, PAGE DOWN key
Const VK_END = &H23 ' dec = 35, END key
Const VK_HOME = &H24 ' dec = 36, HOME key
Const VK_LEFT = &H25 ' dec = 37, LEFT ARROW key
Const VK_UP = &H26 ' dec = 38, UP ARROW key
Const VK_RIGHT = &H27 ' dec = 39, RIGHT ARROW key
Const VK_DOWN = &H28 ' dec = 40, DOWN ARROW key
Const VK_SELECT = &H29 ' dec = 41, SELECT key
Const VK_PRINT = &H2A ' dec = 42, PRINT key
Const VK_EXECUTE = &H2B ' dec = 43, EXECUTE key
Const VK_SNAPSHOT = &H2C ' dec = 44, PRINT SCREEN key
Const VK_INSERT = &H2D ' dec = 45, INS key
Const VK_DELETE = &H2E ' dec = 46, DEL key
Const VK_HELP = &H2F ' dec = 47, HELP key
' MADE OUR OWN CONSTANTS FOR THESE:
Const VK_0 = &H30 ' dec = 48, 0 key
Const VK_1 = &H31 ' dec = 49, 1 key
Const VK_2 = &H32 ' dec = 50, 2 key
Const VK_3 = &H33 ' dec = 51, 3 key
Const VK_4 = &H34 ' dec = 52, 4 key
Const VK_5 = &H35 ' dec = 53, 5 key
Const VK_6 = &H36 ' dec = 54, 6 key
Const VK_7 = &H37 ' dec = 55, 7 key
Const VK_8 = &H38 ' dec = 56, 8 key
Const VK_9 = &H39 ' dec = 57, 9 key
'??? = &H3A-40 ' dec = 58-64, Undefined
Const VK_A = &H41 ' dec = 65, A key
Const VK_B = &H42 ' dec = 66, B key
Const VK_C = &H43 ' dec = 67, C key
Const VK_D = &H44 ' dec = 68, D key
Const VK_E = &H45 ' dec = 69, E key
Const VK_F = &H46 ' dec = 70, F key
Const VK_G = &H47 ' dec = 71, G key
Const VK_H = &H48 ' dec = 72, H key
Const VK_I = &H49 ' dec = 73, I key
Const VK_J = &H4A ' dec = 74, J key
Const VK_K = &H4B ' dec = 75, K key
Const VK_L = &H4C ' dec = 76, L key
Const VK_M = &H4D ' dec = 77, M key
Const VK_N = &H4E ' dec = 78, N key
Const VK_O = &H4F ' dec = 79, O key
Const VK_P = &H50 ' dec = 80, P key
Const VK_Q = &H51 ' dec = 81, Q key
Const VK_R = &H52 ' dec = 82, R key
Const VK_S = &H53 ' dec = 83, S key
Const VK_T = &H54 ' dec = 84, T key
Const VK_U = &H55 ' dec = 85, U key
Const VK_V = &H56 ' dec = 86, V key
Const VK_W = &H57 ' dec = 87, W key
Const VK_X = &H58 ' dec = 88, X key
Const VK_Y = &H59 ' dec = 89, Y key
Const VK_Z = &H5A ' dec = 90, Z key
' Microsoft's Virtual-Key Codes constants (continued):
Const VK_LWIN = &H5B ' dec = 91, Left Windows key
Const VK_RWIN = &H5C ' dec = 92, Right Windows key
Const VK_APPS = &H5D ' dec = 93, Applications key
'??? = &H5E ' dec = 94, Reserved
Const VK_SLEEP = &H5F ' dec = 95, Computer Sleep key
Const VK_NUMPAD0 = &H60 ' dec = 96, Numeric keypad 0 key
Const VK_NUMPAD1 = &H61 ' dec = 97, Numeric keypad 1 key
Const VK_NUMPAD2 = &H62 ' dec = 98, Numeric keypad 2 key
Const VK_NUMPAD3 = &H63 ' dec = 99, Numeric keypad 3 key
Const VK_NUMPAD4 = &H64 ' dec = 100, Numeric keypad 4 key
Const VK_NUMPAD5 = &H65 ' dec = 101, Numeric keypad 5 key
Const VK_NUMPAD6 = &H66 ' dec = 102, Numeric keypad 6 key
Const VK_NUMPAD7 = &H67 ' dec = 103, Numeric keypad 7 key
Const VK_NUMPAD8 = &H68 ' dec = 104, Numeric keypad 8 key
Const VK_NUMPAD9 = &H69 ' dec = 105, Numeric keypad 9 key
Const VK_MULTIPLY = &H6A ' dec = 106, Multiply key
Const VK_ADD = &H6B ' dec = 107, Add key
Const VK_SEPARATOR = &H6C ' dec = 108, Separator key
Const VK_SUBTRACT = &H6D ' dec = 109, Subtract key
Const VK_DECIMAL = &H6E ' dec = 110, Decimal key
Const VK_DIVIDE = &H6F ' dec = 111, Divide key
Const VK_F1 = &H70 ' dec = 112, F1 key
Const VK_F2 = &H71 ' dec = 113, F2 key
Const VK_F3 = &H72 ' dec = 114, F3 key
Const VK_F4 = &H73 ' dec = 115, F4 key
Const VK_F5 = &H74 ' dec = 116, F5 key
Const VK_F6 = &H75 ' dec = 117, F6 key
Const VK_F7 = &H76 ' dec = 118, F7 key
Const VK_F8 = &H77 ' dec = 119, F8 key
Const VK_F9 = &H78 ' dec = 120, F9 key
Const VK_F10 = &H79 ' dec = 121, F10 key
Const VK_F11 = &H7A ' dec = 122, F11 key
Const VK_F12 = &H7B ' dec = 123, F12 key
Const VK_F13 = &H7C ' dec = 124, F13 key
Const VK_F14 = &H7D ' dec = 125, F14 key
Const VK_F15 = &H7E ' dec = 126, F15 key
Const VK_F16 = &H7F ' dec = 127, F16 key
Const VK_F17 = &H80 ' dec = 128, F17 key
Const VK_F18 = &H81 ' dec = 129, F18 key
Const VK_F19 = &H82 ' dec = 130, F19 key
Const VK_F20 = &H83 ' dec = 131, F20 key
Const VK_F21 = &H84 ' dec = 132, F21 key
Const VK_F22 = &H85 ' dec = 133, F22 key
Const VK_F23 = &H86 ' dec = 134, F23 key
Const VK_F24 = &H87 ' dec = 135, F24 key
'??? = &H88-8F ' dec = 136-143, Reserved
Const VK_NUMLOCK = &H90 ' dec = 144, NUM LOCK key
Const VK_SCROLL = &H91 ' dec = 145, SCROLL LOCK key
'??? = &H92-96 ' dec = 146-150, OEM specific
'??? = &H97-9F ' dec = 151-159, Unassigned
Const VK_LSHIFT = &HA0 ' dec = 160, Left SHIFT key
Const VK_RSHIFT = &HA1 ' dec = 161, Right SHIFT key
Const VK_LCONTROL = &HA2 ' dec = 162, Left CONTROL key
Const VK_RCONTROL = &HA3 ' dec = 163, Right CONTROL key
Const VK_LMENU = &HA4 ' dec = 164, Left ALT key
Const VK_RMENU = &HA5 ' dec = 165, Right ALT key
Const VK_BROWSER_BACK = &HA6 ' dec = 166, Browser Back key
Const VK_BROWSER_FORWARD = &HA7 ' dec = 167, Browser Forward key
Const VK_BROWSER_REFRESH = &HA8 ' dec = 168, Browser Refresh key
Const VK_BROWSER_STOP = &HA9 ' dec = 169, Browser Stop key
Const VK_BROWSER_SEARCH = &HAA ' dec = 170, Browser Search key
Const VK_BROWSER_FAVORITES = &HAB ' dec = 171, Browser Favorites key
Const VK_BROWSER_HOME = &HAC ' dec = 172, Browser Start and Home key
Const VK_VOLUME_MUTE = &HAD ' dec = 173, Volume Mute key
Const VK_VOLUME_DOWN = &HAE ' dec = 174, Volume Down key
Const VK_VOLUME_UP = &HAF ' dec = 175, Volume Up key
Const VK_MEDIA_NEXT_TRACK = &HB0 ' dec = 176, Next Track key
Const VK_MEDIA_PREV_TRACK = &HB1 ' dec = 177, Previous Track key
Const VK_MEDIA_STOP = &HB2 ' dec = 178, Stop Media key
Const VK_MEDIA_PLAY_PAUSE = &HB3 ' dec = 179, Play/Pause Media key
Const VK_LAUNCH_MAIL = &HB4 ' dec = 180, Start Mail key
Const VK_LAUNCH_MEDIA_SELECT = &HB5 ' dec = 181, Select Media key
Const VK_LAUNCH_APP1 = &HB6 ' dec = 182, Start Application 1 key
Const VK_LAUNCH_APP2 = &HB7 ' dec = 183, Start Application 2 key
'??? = &HB8-B9 ' dec = 184-137, Reserved
Const VK_OEM_1 = &HBA ' dec = 186, Used for miscellaneous characters; it can vary by keyboard. For the US standard keyboard, the ;: key
Const VK_OEM_PLUS = &HBB ' dec = 187, For any country/region, the + key
Const VK_OEM_COMMA = &HBC ' dec = 188, For any country/region, the , key
Const VK_OEM_MINUS = &HBD ' dec = 189, For any country/region, the - key
Const VK_OEM_PERIOD = &HBE ' dec = 190, For any country/region, the . key
Const VK_OEM_2 = &HBF ' dec = 191, Used for miscellaneous characters; it can vary by keyboard. For the US standard keyboard, the /? key
Const VK_OEM_3 = &HC0 ' dec = 192, Used for miscellaneous characters; it can vary by keyboard. For the US standard keyboard, the `~ key
'??? = &HC1-DA ' dec = 193-218, Reserved
Const VK_OEM_4 = &HDB ' dec = 219, Used for miscellaneous characters; it can vary by keyboard. For the US standard keyboard, the [{ key
Const VK_OEM_5 = &HDC ' dec = 220, Used for miscellaneous characters; it can vary by keyboard. For the US standard keyboard, the \\| key
Const VK_OEM_6 = &HDD ' dec = 221, Used for miscellaneous characters; it can vary by keyboard. For the US standard keyboard, the ]} key
Const VK_OEM_7 = &HDE ' dec = 222, Used for miscellaneous characters; it can vary by keyboard. For the US standard keyboard, the '" key
Const VK_OEM_8 = &HDF ' dec = 223, Used for miscellaneous characters; it can vary by keyboard.
'??? = &HE0 ' dec = 224, Reserved
'??? = &HE1 ' dec = 225, OEM specific
Const VK_OEM_102 = &HE2 ' dec = 226, The <> keys on the US standard keyboard, or the \\| key on the non-US 102-key keyboard
'??? = &HE3-E4 ' dec = 227-228, OEM specific
Const VK_PROCESSKEY = &HE5 ' dec = 229, IME PROCESS key
'??? = &HE6 ' dec = 230, OEM specific
Const VK_PACKET = &HE7 ' dec = 231, Used to pass Unicode characters as if they were keystrokes. The VK_PACKET key is the low word of a 32-bit Virtual Key value used for non-keyboard input methods. For more information, see Remark in KEYBDINPUT, SendInput, WM_KEYDOWN, and WM_KEYUP
'??? = &HE8 ' dec = 232, Unassigned
'??? = &HE9-F5 ' dec = 233-245, OEM specific
Const VK_ATTN = &HF6 ' dec = 246, Attn key
Const VK_CRSEL = &HF7 ' dec = 247, CrSel key
Const VK_EXSEL = &HF8 ' dec = 248, ExSel key
Const VK_EREOF = &HF9 ' dec = 249, Erase EOF key
Const VK_PLAY = &HFA ' dec = 250, Play key
Const VK_ZOOM = &HFB ' dec = 251, Zoom key
Const VK_NONAME = &HFC ' dec = 252, Reserved
Const VK_PA1 = &HFD ' dec = 253, PA1 key
Const VK_OEM_CLEAR = &HFE ' dec = 254, Clear key
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' END Virtual-Key Codes
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' Messages a window receives through or sends from its WindowProc function:
' DefWindowProcA function (winuser.h)
' https://learn.microsoft.com/en-us/windows/win32/api/winuser/nf-winuser-defwindowproca
Const WM_APP = &H08000 ' dec=32768
Const WM_APPCOMMAND = &H0319 ' dec=793
Const WM_CHAR = &H0102 ' dec=258
Const WM_COMMAND = &H0111 ' dec=273
Const WM_DEADCHAR = &H0103 ' dec=259
Const WM_DESTROY = &H0002 ' dec=2
Const WM_INITDIALOG = &H0110 ' dec=272
Const WM_INPUT = &H00FF ' dec=255
Const WM_KEYDOWN = &H0100 ' dec=256
Const WM_KEYUP = &H0101 ' dec=257
Const WM_MOUSEMOVE = &H0200 ' dec=512
Const WM_NCACTIVATE = &H0086 ' dec=134
Const WM_NEXTDLGCTL = &H28 ' dec=40
Const WM_PAINT = &H000F ' dec=15
Const WM_SETICON = &H0080 ' dec=128
Const WM_SIZE = &H0005 ' dec=5
Const WM_SYSCHAR = &H0106 ' dec=262
Const WM_SYSDEADCHAR = &H0107 ' dec=263
Const WM_SYSKEYDOWN = &H0104 ' dec=260
Const WM_SYSKEYUP = &H0105 ' dec=261
Const WM_UNICHAR = &H0109 ' dec=265
' CONSTANTS USED FOR WINDOWS STYLES & FEATURES, SEE:
' Window Styles
' https://learn.microsoft.com/en-us/windows/win32/winmsg/window-styles
' Window Features
' https://learn.microsoft.com/en-us/windows/win32/winmsg/window-features
Const WS_CAPTION = &H00C00000 ' dec=12582912
Const WS_CHILD = &H40000000 ' dec=1073741824
Const WS_MAXIMIZEBOX = &H00010000 ' dec=65536
Const WS_MINIMIZEBOX = &H00020000 ' dec=131072
Const WS_OVERLAPPED = &H00000000 ' dec=0
Const WS_SYSMENU = &H00080000 ' dec=524288
Const WS_THICKFRAME = &H00040000 ' dec=262144
Const WS_VISIBLE = &H10000000 ' dec=268435456
Const WS_OVERLAPPEDWINDOW = WS_OVERLAPPED Or WS_CAPTION Or WS_SYSMENU Or WS_THICKFRAME Or WS_MINIMIZEBOX Or WS_MAXIMIZEBOX
' CONSTANTS USED BY MapVirtualKey FOR PARAMETER uMapType
' https://learn.microsoft.com/en-us/windows/win32/api/winuser/nf-winuser-mapvirtualkeya
Const MAPVK_VK_TO_VSC = 0 ' The uCode parameter is a virtual-key code and is translated into a scan code. If it is a virtual-key code that does not distinguish between left- and right-hand keys, the left-hand scan code is returned. If there is no translation, the function returns 0.
Const MAPVK_VSC_TO_VK = 1 ' The uCode parameter is a scan code and is translated into a virtual-key code that does not distinguish between left- and right-hand keys. If there is no translation, the function returns 0. Windows Vista and later: the high byte of the uCode value can contain either 0xe0 or 0xe1 to specify the extended scan code.
Const MAPVK_VK_TO_CHAR = 2 ' The uCode parameter is a virtual-key code and is translated into an unshifted character value in the low order word of the return value. Dead keys (diacritics) are indicated by setting the top bit of the return value. If there is no translation, the function returns 0. See Remarks.
Const MAPVK_VSC_TO_VK_EX = 3 ' The uCode parameter is a scan code and is translated into a virtual-key code that distinguishes between left- and right-hand keys. If there is no translation, the function returns 0. Windows Vista and later: the high byte of the uCode value can contain either 0xe0 or 0xe1 to specify the extended scan code.
Const MAPVK_VK_TO_VSC_EX = 4 ' Windows Vista and later: The uCode parameter is a virtual-key code and is translated into a scan code. If it is a virtual-key code that does not distinguish between left- and right-hand keys, the left-hand scan code is returned. If the scan code is an extended scan code, the high byte of the returned value will contain either 0xe0 or 0xe1 to specify the extended scan code. If there is no translation, the function returns 0.
' ================================================================================================================================================================
' END API CONSTANTS
' ================================================================================================================================================================
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN RAW INPUT TYPES
' FOR TYPE CONVERSION SEE: "QB64PE C Libraries" at:
' https://qb64phoenix.com/qb64wiki/index.php/C_Libraries
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
'RAWINPUTDEVICE structure (winuser.h)
'https://learn.microsoft.com/en-us/windows/win32/api/winuser/ns-winuser-rawinputdevice
'typedef struct tagRAWINPUTDEVICE {
' USHORT usUsagePage;
' USHORT usUsage;
' DWORD dwFlags;
' HWND hwndTarget;
'} RAWINPUTDEVICE, *PRAWINPUTDEVICE, *LPRAWINPUTDEVICE;
' Spriggsy's version:
Type RAWINPUTDEVICE
As Unsigned Integer usUsagePage, usUsage
As Unsigned Long dwFlags
As Offset hwndTarget
End Type
' ^^^ Should "Unsigned Integer" be "_UNSIGNED INTEGER"
' and "Unsigned Long" be "_UNSIGNED LONG"
' and "Offset" be "_OFFSET" like this?:
'
'TYPE RAWINPUTDEVICE
' usUsagePage AS _UNSIGNED INTEGER ' WORD
' usUsage AS _UNSIGNED INTEGER ' WORD
' dwFlags AS _UNSIGNED LONG ' DWORD
' hwndTarget AS _OFFSET ' DWORD
'END TYPE
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
'RAWINPUTDEVICELIST structure (winuser.h)
'https://learn.microsoft.com/en-us/windows/win32/api/winuser/ns-winuser-rawinputdevicelist
'typedef struct tagRAWINPUTDEVICELIST {
' HANDLE hDevice;
' DWORD dwType;
'} RAWINPUTDEVICELIST, *PRAWINPUTDEVICELIST;
' Spriggsy's version:
Type RAWINPUTDEVICELIST
As Offset hDevice
As Unsigned Long dwType
$If 64BIT Then
As String * 4 alignment
$End If
End Type
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
'POINT structure (windef.h)
'https://learn.microsoft.com/en-us/windows/win32/api/windef/ns-windef-point
'typedef struct tagPOINT {
' LONG x;
' LONG y;
'} POINT, *PPOINT, *NPPOINT, *LPPOINT;
Type POINT
As Long x, y
End Type
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
'MSG structure (winuser.h)
'https://learn.microsoft.com/en-us/windows/win32/api/winuser/ns-winuser-msg
'typedef struct tagMSG {
' HWND hwnd;
' UINT message;
' WPARAM wParam;
' LPARAM lParam;
' DWORD time;
' POINT pt;
' DWORD lPrivate;
'} MSG, *PMSG, *NPMSG, *LPMSG;
Type MSG
As Offset hwnd
As Unsigned Long message
As Unsigned Offset wParam
As Offset lParam
As Long time
As POINT pt
As Long lPrivate
End Type
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
'WNDCLASSEXA structure (winuser.h)
'https://learn.microsoft.com/en-us/windows/win32/api/winuser/ns-winuser-wndclassexa
'typedef struct WNDCLASSEXA {
' UINT cbSize;
' UINT style;
' WNDPROC lpfnWndProc;
' int cbClsExtra;
' int cbWndExtra;
' HINSTANCE hInstance;
' HICON hIcon;
' HCURSOR hCursor;
' HBRUSH hbrBackground;
' LPCSTR lpszMenuName;
' LPCSTR lpszClassName;
' HICON hIconSm;
'} WNDCLASSEXA, *PWNDCLASSEXA, *NPWNDCLASSEXA, *LPWNDCLASSEXA;
Type WNDCLASSEX
As Unsigned Long cbSize, style
As Offset lpfnWndProc
As Long cbClsExtra, cbWndExtra
As Offset hInstance, hIcon, hCursor, hbrBackground, lpszMenuName, lpszClassName, hIconSm
End Type
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
'RECT structure (windef.h)
'https://learn.microsoft.com/en-us/windows/win32/api/windef/ns-windef-rect
'typedef struct tagRECT {
' LONG left; Specifies the x-coordinate of the upper-left corner of the rectangle.
' LONG top; Specifies the y-coordinate of the upper-left corner of the rectangle.
' LONG right; Specifies the x-coordinate of the lower-right corner of the rectangle.
' LONG bottom; Specifies the y-coordinate of the lower-right corner of the rectangle.
'} RECT, *PRECT, *NPRECT, *LPRECT;
Type RECT
As Long left, top, right, bottom
End Type
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
'PAINTSTRUCT structure (winuser.h)
'https://learn.microsoft.com/en-us/windows/win32/api/winuser/ns-winuser-paintstruct
'typedef struct tagPAINTSTRUCT {
' HDC hdc;
' BOOL fErase;
' RECT rcPaint;
' BOOL fRestore;
' BOOL fIncUpdate;
' BYTE rgbReserved[32];
'} PAINTSTRUCT, *PPAINTSTRUCT, *NPPAINTSTRUCT, *LPPAINTSTRUCT;
Type PAINTSTRUCT
As Offset hdc
As Long fErase
$If 64BIT Then
As String * 4 alignment
$End If
As RECT rcPaint
As Long fRestore, fIncUpdate
As String * 32 rgbReserved
End Type
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
'RAWINPUTHEADER structure (winuser.h)
'https://learn.microsoft.com/en-us/windows/win32/api/winuser/ns-winuser-rawinputheader
'typedef struct tagRAWINPUTHEADER {
' DWORD dwType;
' DWORD dwSize;
' HANDLE hDevice;
' WPARAM wParam;
'} RAWINPUTHEADER, *PRAWINPUTHEADER, *LPRAWINPUTHEADER;
' Spriggsy's version:
Type RAWINPUTHEADER
As Unsigned Long dwType, dwSize
As Offset hDevice
As Unsigned Offset wParam
End Type
' ^^^ Doesn't match the types I expected, should it be these?:
'TYPE RAWINPUTHEADER
' dwType AS _UNSIGNED LONG ' DWORD
' dwSize AS _UNSIGNED LONG ' DWORD
' hDevice AS _UNSIGNED LONG ' DWORD <- should this be _OFFSET ?
' wParam AS LONG
'END TYPE
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
'RAWMOUSE structure (winuser.h)
'https://learn.microsoft.com/en-us/windows/win32/api/winuser/ns-winuser-rawmouse
'typedef struct tagRAWMOUSE {
' USHORT usFlags;
' union {
' ULONG ulButtons;
' struct {
' USHORT usButtonFlags;
' USHORT usButtonData;
' } DUMMYSTRUCTNAME;
' } DUMMYUNIONNAME2;
' ULONG ulRawButtons;
' LONG lLastX;
' LONG lLastY;
' ULONG ulExtraInformation;
'} RAWMOUSE, *PRAWMOUSE, *LPRAWMOUSE;
' Spriggsy's simplified version:
Type RAWMOUSE
As Unsigned Integer usFlags
$If 64BIT Then
As String * 2 alignment
$End If
'As Unsigned Long ulButtons 'commented out because I'm creating this value using MAKELONG
As Unsigned Integer usButtonFlags, usButtonData
As Unsigned Long ulRawButtons
As Long lLastX, lLastY
As Unsigned Long ulExtraInformation
End Type
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
'RAWKEYBOARD structure (winuser.h)
'https://learn.microsoft.com/en-us/windows/win32/api/winuser/ns-winuser-rawkeyboard
'typedef struct tagRAWKEYBOARD {
' USHORT MakeCode;
' USHORT Flags;
' USHORT Reserved;
' USHORT VKey;
' UINT Message;
' ULONG ExtraInformation;
'} RAWKEYBOARD, *PRAWKEYBOARD, *LPRAWKEYBOARD;
Type RAWKEYBOARD
MakeCode As _Unsigned Integer ' USHORT
Flags As _Unsigned Integer ' USHORT
Reserved As _Unsigned Integer ' USHORT
VKey As _Unsigned Integer ' USHORT
Message As _Unsigned Long ' UINT
ExtraInformation As _Unsigned _Offset ' ULONG
End Type
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
'RAWINPUT structure (winuser.h)
'https://learn.microsoft.com/en-us/windows/win32/api/winuser/ns-winuser-rawinput
'typedef struct tagRAWINPUT {
' RAWINPUTHEADER header;
' union {
' RAWMOUSE mouse;
' RAWKEYBOARD keyboard;
' RAWHID hid;
' } data;
'} RAWINPUT, *PRAWINPUT, *LPRAWINPUT;
' Spriggsy's simplified version:
Type RAWINPUT
As RAWINPUTHEADER header
As RAWMOUSE mouse
'As RAWKEYBOARD keyboard <- ADDING THIS CAUSES THE PROGRAM TO CRASH ON MOUSE INPUT
End Type
' Simplified copy for keyboard:
Type RAWINPUT_K
As RAWINPUTHEADER header
As RAWKEYBOARD keyboard
End Type
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
'RID_DEVICE_INFO_MOUSE structure (winuser.h)
'https://learn.microsoft.com/en-us/windows/win32/api/winuser/ns-winuser-rid_device_info_mouse
'typedef struct tagRID_DEVICE_INFO_MOUSE {
' DWORD dwId;
' DWORD dwNumberOfButtons;
' DWORD dwSampleRate;
' BOOL fHasHorizontalWheel;
'} RID_DEVICE_INFO_MOUSE, *PRID_DEVICE_INFO_MOUSE;
Type RID_DEVICE_INFO_MOUSE
dwId As _Unsigned Long
dwNumberOfButtons As _Unsigned Long
dwSampleRate As _Unsigned Long
fHasHorizontalWheel As Integer
End Type
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
'RID_DEVICE_INFO_KEYBOARD structure (winuser.h)
'https://learn.microsoft.com/en-us/windows/win32/api/winuser/ns-winuser-rid_device_info_keyboard
'typedef struct tagRID_DEVICE_INFO_KEYBOARD {
' DWORD dwType;
' DWORD dwSubType;
' DWORD dwKeyboardMode;
' DWORD dwNumberOfFunctionKeys;
' DWORD dwNumberOfIndicators;
' DWORD dwNumberOfKeysTotal;
'} RID_DEVICE_INFO_KEYBOARD, *PRID_DEVICE_INFO_KEYBOARD;
Type RID_DEVICE_INFO_KEYBOARD
dwType As _Unsigned Long ' DWORD
dwSubType As _Unsigned Long ' DWORD
dwKeyboardMode As _Unsigned Long ' DWORD
dwNumberOfFunctionKeys As _Unsigned Long ' DWORD
dwNumberOfIndicators As _Unsigned Long ' DWORD
dwNumberOfKeysTotal As _Unsigned Long ' DWORD
End Type
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
'RID_DEVICE_INFO_HID structure (winuser.h)
'https://learn.microsoft.com/en-us/windows/win32/api/winuser/ns-winuser-rid_device_info_hid
'typedef struct tagRID_DEVICE_INFO_HID {
' DWORD dwVendorId;
' DWORD dwProductId;
' DWORD dwVersionNumber;
' USHORT usUsagePage;
' USHORT usUsage;
'} RID_DEVICE_INFO_HID, *PRID_DEVICE_INFO_HID;
Type RID_DEVICE_INFO_HID
dwVendorId As _Unsigned Long ' DWORD
dwProductId As _Unsigned Long ' DWORD
dwVersionNumber As _Unsigned Long ' DWORD
usUsagePage As _Unsigned Integer ' USHORT
usUsage As _Unsigned Integer ' USHORT
End Type
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' NEEDS FIXING:
'RID_DEVICE_INFO structure (winuser.h)
'https://learn.microsoft.com/en-us/windows/win32/api/winuser/ns-winuser-rid_device_info
'typedef struct tagRID_DEVICE_INFO {
' DWORD cbSize;
' DWORD dwType;
' union {
' RID_DEVICE_INFO_MOUSE mouse;
' RID_DEVICE_INFO_KEYBOARD keyboard;
' RID_DEVICE_INFO_HID hid;
' } DUMMYUNIONNAME1;
'} RID_DEVICE_INFO, *PRID_DEVICE_INFO, *LPRID_DEVICE_INFO;
' ^^^ NOT SURE HOW TO DEFINE THIS, SHOULD IT BE SOMETHING LIKE THIS?:
'Type DUMMYUNIONNAME1
' My_RID_DEVICE_INFO_MOUSE As _Offset ' pointer to VAR A1
' My_RID_DEVICE_INFO_KEYBOARD As _Offset ' pointer to VAR A2
' My_RID_DEVICE_INFO_HID As _Offset ' pointer to VAR A3
'End Type
'Type RID_DEVICE_INFO
' cbSize As _Unsigned Long ' DWORD
' dwType As _Unsigned Long ' DWORD
' My_DUMMYUNIONNAME1 As _Offset ' pointer to DUMMYUNIONNAME1
'End Type
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
'RAWHID structure (winuser.h)
'https://learn.microsoft.com/en-us/windows/win32/api/winuser/ns-winuser-rawhid
'typedef struct tagRAWHID {
' DWORD dwSizeHid;
' DWORD dwCount;
' BYTE bRawData[1];
'} RAWHID, *PRAWHID, *LPRAWHID;
Type RAWHID
dwSizeHid As _Unsigned Long ' DWORD
dwCount As _Unsigned Long ' DWORD
bRawData As _Unsigned _Byte ' bRawData[1] AS BYTE
End Type
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END RAW INPUT TYPES
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN CUSTOM TYPES
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' UDT TO HOLD THE INFO FOR EACH MOUSE (multimouse)
Type MouseInfoType
ID As String ' player identifier or mouse device ID
char 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
px As Long ' pointer x position (hires) for absolute position of mouse from raw input api
py As Long ' pointer y position (hires) for absolute position of mouse from raw input api
' Multimouse:
pdx As Long ' mouse x movement (hires) can be greater than just -1 or +1
pdy As Long ' mouse y movement (hires) can be greater than just -1 or +1
wheel As Integer ' mouse wheel value
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
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END CUSTOM TYPES
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN API DECLARATIONS PART 1
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Declare CustomType Library
'DECLARE FUNCTION GetRawInputDeviceList LIB "USER32.DLL" ALIAS "GetRawInputDeviceList"( _
' BYREF pRawInputDeviceList AS RAWINPUTDEVICELIST, _
' BYREF puiNumDevices AS _UNSIGNED LONG, _
' BYVAL cbSize AS _UNSIGNED LONG _
' ) AS _UNSIGNED LONG
Function GetRawInputDeviceList~& (ByVal pRawInputDeviceList As Offset, Byval puiNumDevices As Offset, Byval cbSize As Unsigned Long)
Sub GetRawInputDeviceList (ByVal pRawInputDeviceList As Offset, Byval puiNumDevices As Offset, Byval cbSize As Unsigned Long)
'DECLARE FUNCTION RegisterRawInputDevices LIB "USER32.DLL" ALIAS "RegisterRawInputDevices"( _
' BYREF pRawInputDevices AS RAWINPUTDEVICE, _
' BYVAL uiNumDevices AS _UNSIGNED LONG, _
' BYVAL cbSize AS _UNSIGNED LONG _
' ) AS LONG
Function RegisterRawInputDevices& (ByVal pRawInputDevices As Offset, Byval uiNumDevices As Unsigned Long, Byval cbSize As Unsigned Long)
Function GetModuleHandle%& (ByVal lpModulename As Offset)
Function LoadIcon%& (ByVal hInstance As Offset, Byval lpIconName As Offset)
Function LoadCursor%& (ByVal hInstance As Offset, Byval lpCursorName As Offset)
Function RegisterClassEx~% (ByVal wndclassex As Offset)
Function CreateWindowEx%& (ByVal dwExStyle As Unsigned Long, Byval lpClassName As Offset, Byval lpWindowName As Offset, Byval dwStyle As Unsigned Long, Byval x As Long, Byval y As Long, Byval nWidth As Long, Byval nHeight As Long, Byval hWndParent As Offset, Byval hMenu As Offset, Byval hInstance As Offset, Byval lpParam As Offset)
Sub ShowWindow (ByVal hWnd As Offset, Byval nCmdShow As Long)
Sub UpdateWindow (ByVal hWnd As Offset)
Function GetMessage& (ByVal lpMsg As Offset, Byval hWnd As Offset, Byval wMsgFilterMin As Unsigned Long, Byval wMsgFilterMax As Unsigned Long)
Sub TranslateMessage (ByVal lpMsg As Offset)
Sub DispatchMessage (ByVal lpMsg As Offset)
Sub PostQuitMessage (ByVal nExitCode As Long)
Function DefWindowProc%& (ByVal hWnd As Offset, Byval Msg As Unsigned Long, Byval wParam As Unsigned Offset, Byval lParam As Offset)
'DECLARE FUNCTION GetRawInputData LIB "USER32.DLL" ALIAS "GetRawInputData"( _
' BYVAL hRawInput AS _UNSIGNED LONG, _
' BYVAL uiCommand AS _UNSIGNED LONG, _
' BYREF pData AS _OFFSET, _
' BYREF pcbSize AS _UNSIGNED LONG, _
' BYVAL cbSizeHeader AS _UNSIGNED LONG _
' ) AS _UNSIGNED LONG
Sub GetRawInputData (ByVal hRawInput As Offset, Byval uiCommand As Unsigned Long, Byval pData As Offset, Byval pcbSize As Offset, Byval cbSizeHeader As Unsigned Long)
Function GetRawInputData~& (ByVal hRawInput As Offset, Byval uiCommand As Unsigned Long, Byval pData As Offset, Byval pcbSize As Offset, Byval cbSizeHeader As Unsigned Long)
Sub InvalidateRect (ByVal hWnd As Offset, Byval lpRect As Offset, Byval bErase As Long)
'DECLARE FUNCTION SendMessage LIB "USER32.DLL" ALIAS "SendMessageA"( _
' BYVAL hWnd AS _OFFSET, _
' BYVAL Msg AS _UNSIGNED LONG, _
' BYVAL wParam AS _UNSIGNED LONG, _
' BYVAL lParam AS LONG _
' ) AS LONG
Sub SendMessage (ByVal hWnd As Offset, Byval Msg As Unsigned Long, Byval wParam As Unsigned Offset, Byval lParam As Offset)
Function BeginPaint%& (ByVal hWnd As Offset, Byval lpPaint As Offset)
'Public Declare Function GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Sub GetClientRect (ByVal hWnd As Offset, Byval lpRect As Offset)
'Public Declare Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hdc As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long
Sub DrawText (ByVal hdc As Offset, Byval lpchText As Offset, Byval cchText As Long, Byval lprc As Offset, Byval format As Unsigned Long)
'Public Declare Function OffsetRect Lib "user32" (lpRect As RECT, ByVal X As Long, ByVal Y As Long) As Long
Sub OffsetRect (ByVal lprc As Offset, Byval dx As Long, Byval dy As Long)
Sub EndPaint (ByVal hWnd As Offset, Byval lpPaint As Offset)
End Declare ' CustomType Library
' Header file "makeint.h" must be in same folder as this program.
Declare CustomType Library ".\makeint"
Function MAKEINTRESOURCE%& Alias "MAKEINTRSC" (ByVal i As _Offset)
End Declare
Declare Library
Function MAKELPARAM%& (ByVal l As Integer, Byval h As Integer)
Function MAKELONG~& (ByVal l As Unsigned Integer, Byval h As Unsigned Integer)
End Declare
$If 64BIT Then
Declare Library ".\internal\c\c_compiler\x86_64-w64-mingw32\include\windowsx"
$Else
Declare Library ".\internal\c\c_compiler\i686-w64-mingw32\include\windowsx"
$End If
Function GET_Y_LPARAM& (ByVal lp As Offset)
Function GET_X_LPARAM& (ByVal lp As Offset)
End Declare
' Header file "winproc.h" must be in same folder as this program.
Declare Library ".\winproc"
Function WindowProc%& ()
End Declare
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END API DECLARATIONS PART 1
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN GLOBAL VARIABLES
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ENABLE / DISABLE DEBUG CONSOLE
Dim Shared m_bDebug As Integer: m_bDebug = FALSE
' GLOBAL VARIABLES TO TRACK ERROR STATE
Dim Shared m_sError As String: m_sError = ""
'Dim Shared m_sIncludeError As String: m_sIncludeError = ""
' BASIC PROGRAM METADATA
Dim Shared m_ProgramPath$: m_ProgramPath$ = Left$(Command$(0), _InStrRev(Command$(0), "\"))
Dim Shared m_ProgramName$: m_ProgramName$ = Mid$(Command$(0), _InStrRev(Command$(0), "\") + 1)
' RAW INPUT VARIABLES
Dim Shared rawinputdevices As String
Dim Shared hDlg As _Unsigned Long ' DWORD
' MOUSE VARIABLES
Dim Shared arrMouse(8) As MouseInfoType ' STORES INFO FOR EACH MOUSE
Dim Shared iMouseCount As Integer ' # OF MICE ATTACHED
Dim Shared iMinX As Long
Dim Shared iMaxX As Long
Dim Shared iMinY As Long
Dim Shared iMaxY As Long
' KEYBOARD VARIABLES
'Dim Shared arrKeyIndex(8) As String ' STORES KEYBOARD ID
'Dim Shared arrLastKeyDown(8) As Integer ' STORES LAST KEY PRESSED
'Dim Shared arrLastKeyUp(8) As Integer ' STORES LAST KEY RELEASED
'Dim Shared iKeyBoardCount As Integer ' # OF KEYBOARDS ATTACHED
Dim Shared iLastKeyDown As Integer
Dim Shared iLastKeyUp As Integer
' SCREEN SIZE
Dim Shared lngScreenWidth As Long
Dim Shared lngScreenHeight As Long
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END GLOBAL VARIABLES PART 3
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' EXECUTION STARTS HERE!
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ENABLE / DISABLE DEBUG CONSOLE WINDOW
If cDebugEnabled = TRUE Then
$Console
_Delay 4
_Console On
_Echo "Started " + m_ProgramName$
_Echo "Debugging on..."
End If
' INITIALIZE
iMinX = 0
iMaxX = _DesktopWidth '3583
iMinY = 0
iMaxY = _DesktopHeight ' 8202
lngScreenWidth = 1024 ' _DESKTOPWIDTH
lngScreenHeight = 768 ' _DESKTOPHEIGHT
' START THE EVENTS
System Val(Str$(WinMain))
' DEACTIVATE DEBUGGING WINDOW
If cDebugEnabled = TRUE Then
_Console Off
End If
' EXIT PROGRAM
System ' return control to the operating system
'' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'' BEGIN GLOBAL ERROR HANDLER
'' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'ErrorHandler:
'm_sError = "Error #" + _Trim$(Str$(Err)) + " at line " + _Trim$(Str$(_ErrorLine)) + "."
'm_sIncludeError = "File " + Chr$(34) + _InclErrorFile$ + Chr$(34) + " at line " + _Trim$(Str$(_InclErrorLine)) + "."
'Resume Next
'' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'' END GLOBAL ERROR HANDLER
'' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN 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
' DEFAULT/INTIAL HIRES X COORDINATE OF EACH CURSOR ON SCREEN (1024x768)
PXData:
Data 75,150,225,300,375,450,525,600
' DEFAULT/INTIAL HIRES Y COORDINATE OF EACH CURSOR ON SCREEN (1024x768)
PYData:
Data 54,108,162,216,270,324,378,432
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END DATA STATEMENTS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN RAW INPUT FUNCTIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' /////////////////////////////////////////////////////////////////////////////
' Runs first
Function WinMain~%& ()
Dim As Offset hwndMain, hInst
Dim As MSG msg
Dim As WNDCLASSEX wndclass
Dim As String szMainWndClass
Dim As String szWinTitle
Dim As Unsigned Integer reg
' SET UP WINDOW
' Q: HOW CAN WE GET THIS TO WORK FULLSCREEN?
' THIS MAKES PROGRAM CRASH: _FullScreen _SquarePixels
hInst = GetModuleHandle(0)
szMainWndClass = "WinTestWin" + Chr$(0)
szWinTitle = "Hello" + Chr$(0)
wndclass.lpszClassName = Offset(szMainWndClass)
wndclass.cbSize = Len(wndclass)
wndclass.style = CS_HREDRAW Or CS_VREDRAW
wndclass.lpfnWndProc = WindowProc
wndclass.hInstance = hInst 'GetModuleHandle(0) will return the hInstance of this EXE
wndclass.hIcon = LoadIcon(0, MAKEINTRESOURCE(IDI_APPLICATION))
wndclass.hIconSm = LoadIcon(0, MAKEINTRESOURCE(IDI_APPLICATION))
wndclass.hCursor = LoadCursor(0, MAKEINTRESOURCE(IDC_ARROW))
wndclass.hbrBackground = COLOR_WINDOW + 1
reg = RegisterClassEx(Offset(wndclass)) 'I prefer to use the output of RegisterClassEx rather than the window name
' INITIALIZE RAW INPUT
InitRawInput
If Len(m_sError) = 0 Then
' SET WINDOW SiZE + INITIALIZE WINDOW
'Q: HOW CAN WE USE THE QB64PE PROGRAM'S WINDOW HANDLE e.g. _WindowHandle ?
hwndMain = CreateWindowEx( _
0, _
MAKELPARAM(reg, 0), _
Offset(szWinTitle), _
WS_OVERLAPPEDWINDOW, _
0, _
0, _
lngScreenWidth, _
lngScreenHeight, _
0, _
0, _
hInst, _
0)
ShowWindow hwndMain, SW_SHOW
UpdateWindow hwndMain
InitInputVars
' MAIN PROGRAM LOOP
While GetMessage(Offset(msg), 0, 0, 0)
TranslateMessage Offset(msg)
DispatchMessage Offset(msg)
Wend
Else
Screen 0
Cls
Print "error"
Sleep
End If
' RETURN A VALUE
WinMain = msg.wParam
End Function ' WinMain
' /////////////////////////////////////////////////////////////////////////////
' Handles main window events
' MESSAGE TYPES FOR READING THE KEYBOARD:
' WM_CHAR
' WM_KEYDOWN
' WM_KEYUP
' WM_SYSCHAR
' WM_SYSKEYDOWN
' WM_SYSKEYUP
Function MainWndProc%& (hwnd As Offset, nMsg As Unsigned Long, wParam As Unsigned Offset, lParam As Offset)
' EVENT HANDLER VARIABLES PART 1
Static As Offset hwndButton
Static As Long cx, cy
Dim As Offset hdc
Dim As PAINTSTRUCT ps
Dim As RECT rc
Dim As RECT TargetRect
Dim As MEM lpb
Dim As Unsigned Long dwSize
Dim As RAWINPUT rawm ' MOUSE VERSION
Dim As RAWINPUT_K rawk ' KEYBOARD VERSION
Dim As Long tmpx, tmpy
Static As Long maxx
Dim As RAWINPUTHEADER rih
' TEMP VARIABLES FOR DISPLAYING FORMATTED VALUES TO SCREEN
Dim strNextID As String
Dim iIndex As Integer
Dim iRowOffset As Integer
Dim iLine As Integer
Dim iLen As Integer
Dim iCount As Integer
Dim sCount As String
Dim sText As String
Dim sX As String
Dim sY As String
Dim sPX As String
Dim sPY As String
Dim sWheel As String
Dim sLeftDown As String
Dim sMiddleDown As String
Dim sRightDown As String
Dim sLeftCount As String
Dim sMiddleCount As String
Dim sRightCount As String
Dim sNext As String
Dim iNewX As Integer
Dim iNewY As Integer
Dim iDX As Integer
Dim iDY As Integer
Dim iInputType As Integer
' EVENT HANDLER VARIABLES PART 2
Dim pRawInput As _Offset ' RAWINPUT POINTER
Dim zKeyName As String ' ASCIIZ * 50 = NULL-terminated string
Dim sRawInput As String
Dim sBuffer As String
Dim ScanCode As _Unsigned Long ' DWORD
Static hFocusBak As _Unsigned Long ' DWORD
Dim RawInputDevCount As Long
Dim KeyboardTypeCount As Long
Dim RawInputDeviceIndex As Long
Dim ByteCount As Long
Dim int_wParam As Integer
Dim vbCrLf As String: vbCrLf = Chr$(13) + Chr$(10)
Dim vbCr As String: vbCr = Chr$(13)
Dim vbLf As String: vbLf = Chr$(10)
ReDim arrText$(0)
' HANDLE EVENT MESSAGES
Select Case nMsg
Case WM_DESTROY:
DebugPrint "nMsg = WM_DESTROY"
PostQuitMessage 0
MainWndProc = 0
Exit Function
Case WM_INPUT:
DebugPrint "nMsg = WM_INPUT"
' MOUSE VERSION:
GetRawInputData lParam, RID_INPUT, 0, Offset(dwSize), Len(rih)
' KEYBOARD VERSION:
'GetRawInputData(CBLPARAM, %RID_INPUT, BYVAL %NULL, ByteCount, SIZEOF(RAWINPUTHEADER)) ' Get size of raw input buffer
lpb = MemNew(dwSize)
If lpb.SIZE = 0 Then
MainWndProc = 0
Exit Function
End If
' GET THE RAW INPUT
If GetRawInputData(lParam, RID_INPUT, lpb.OFFSET, Offset(dwSize), Len(rih)) <> dwSize Then
Print "GetRawInputData doesn't return correct size!"
DebugPrint "WRONG SIZE: GetRawInputData doesn't return correct size!"
End If
' IDENTIFY TYPE OF INPUT
Select Case dwSize
Case Len(rawm):
' MOUSE INPUT
DebugPrint "dwSize = Len(rawm) so MOUSE INPUT DETECTED"
iInputType = RIM_TYPEMOUSE
MemGet lpb, lpb.OFFSET, rawm
Case Len(rawk):
' KEYBOARD INPUT
DebugPrint "dwSize = Len(rawk) so KEYBOARD INPUT DETECTED"
iInputType = RIM_TYPEKEYBOARD
MemGet lpb, lpb.OFFSET, rawk
Case Else:
' SOME OTHER TYPE (MAYBE HID) BUT ONE WE CAN'T PROCESS
DebugPrint "dwSize = SOME OTHER TYPE (MAYBE HID)"
iInputType = RIM_TYPEUNKNOWN
End Select
If iInputType = RIM_TYPEMOUSE Then
If rawm.header.dwType = RIM_TYPEMOUSE Then
tmpx = rawm.mouse.lLastX
tmpy = rawm.mouse.lLastY
maxx = tmpx
' 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$(rawm.header.hDevice))
DebugPrint " strNextID = " + Chr$(34) + strNextID + Chr$(34)
' GET ARRAY INDEX FROM strnextID
iIndex = GetMouseIndex%(strNextID)
DebugPrint " iIndex = " + _Trim$(Str$(iIndex))
' DETECT MOVEMENT
If iIndex >= LBound(arrMouse) Then
If iIndex <= UBound(arrMouse) Then
' METHOD #2 = INACCURATE
' INCREMENT/DECREMENT FIXED DELTA
If rawm.mouse.lLastX < 0 Then
arrMouse(iIndex).dx = -1
arrMouse(iIndex).x = arrMouse(iIndex).x - 1
ElseIf rawm.mouse.lLastX > 0 Then
arrMouse(iIndex).dx = 1
arrMouse(iIndex).x = arrMouse(iIndex).x + 1
End If
If rawm.mouse.lLastY < 0 Then
arrMouse(iIndex).dy = -1
arrMouse(iIndex).y = arrMouse(iIndex).y - 1
ElseIf rawm.mouse.lLastY > 0 Then
arrMouse(iIndex).dy = 1
arrMouse(iIndex).y = arrMouse(iIndex).y + 1
End If
' METHOD #3: INCREMENT/DECREMENT TRUE DELTA
arrMouse(iIndex).pdx = rawm.mouse.lLastX
arrMouse(iIndex).pdy = rawm.mouse.lLastY
arrMouse(iIndex).px = arrMouse(iIndex).px + arrMouse(iIndex).pdx
arrMouse(iIndex).py = arrMouse(iIndex).py + arrMouse(iIndex).pdy
' =============================================================================
' left button = 1 when down, 2 when released
If ((rawm.mouse.usButtonFlags And 1) = 1) Then
arrMouse(iIndex).LeftDown = TRUE
ElseIf ((rawm.mouse.usButtonFlags And 2) = 2) Then
arrMouse(iIndex).LeftDown = FALSE
End If
' =============================================================================
' middle button = 16 when down, 32 when released
If ((rawm.mouse.usButtonFlags And 16) = 16) Then
arrMouse(iIndex).MiddleDown = TRUE
ElseIf ((rawm.mouse.usButtonFlags And 32) = 32) Then
arrMouse(iIndex).MiddleDown = FALSE
End If
' =============================================================================
' right button = 4 when down, 8 when released
If ((rawm.mouse.usButtonFlags And 4) = 4) Then
arrMouse(iIndex).RightDown = TRUE
ElseIf ((rawm.mouse.usButtonFlags And 8) = 8) Then
arrMouse(iIndex).RightDown = FALSE
End If
' =============================================================================
' scroll wheel = ???
'Hex$(rawm.mouse.usButtonFlags)
'arrMouse(iIndex).wheel = ???
End If
End If
' INVOKE PAINT
InvalidateRect hwnd, 0, -1
SendMessage hwnd, WM_PAINT, 0, 0
MainWndProc = 0
' ================================================================================================================================================================
' END DRAW SCREEN
' ================================================================================================================================================================
End If
ElseIf iInputType = RIM_TYPEKEYBOARD Then
' *** FOR NOW RAW KEYBOARD INPUT NOT WORKING
'DebugPrint "iInputType = RIM_TYPEKEYBOARD"
'If rawk.header.dwType = RIM_TYPEKEYBOARD Then
' DebugPrint "* FOUND RAW INPUT KEYBOARD *"
'
' ' HOW DO WE READ THE KEYBOARD USING RawInputAPI ???
' DebugPrint "rawk.header.dwType = RIM_TYPEKEYBOARD"
'
' ' IDENTIFY WHICH KEYBOARD IT IS
' strNextID = _Trim$(Str$(rawk.header.hDevice))
' DebugPrint " strNextID = " + Chr$(34) + strNextID + Chr$(34)
'
' '' GET ARRAY INDEX FROM strnextID
' 'iIndex = GetKeyboardIndex%(strNextID)
' 'DebugPrint " iIndex = " + _Trim$(Str$(iIndex))
'
'End If
End If
' FINISHUP WM_INPUT
MemFree lpb
MainWndProc = 0
Exit Function
Case WM_MOUSEMOVE:
DebugPrint "nMsg = WM_MOUSEMOVE"
Exit Function
Case WM_PAINT:
DebugPrint "nMsg = WM_PAINT"
hdc = BeginPaint(hwnd, Offset(ps))
GetClientRect hwnd, Offset(rc)
' -----------------------------------------------------------------------------
' DISPLAY MOUSE INFO ON SCREEN AT MOUSE POSITIONS
iCount = 0
For iIndex = LBound(arrMouse) To UBound(arrMouse)
iCount = iCount + 1
If Len(arrMouse(iIndex).ID) > 0 Then
' CHECK CURSOR BOUNDARIES
If arrMouse(iIndex).x < cMinX Then arrMouse(iIndex).x = cMinX
If arrMouse(iIndex).x > cMaxX Then arrMouse(iIndex).x = cMaxX
If arrMouse(iIndex).y < cMinY Then arrMouse(iIndex).y = cMinY
If arrMouse(iIndex).y > cMaxY Then arrMouse(iIndex).y = cMaxY
' CHECK HIRES CURSOR BOUNDARIES
If arrMouse(iIndex).px < cMinPX Then arrMouse(iIndex).px = cMinPX
If arrMouse(iIndex).px > cMaxPX Then arrMouse(iIndex).px = cMaxPX
If arrMouse(iIndex).py < cMinPY Then arrMouse(iIndex).py = cMinPY
If arrMouse(iIndex).py > cMaxPY Then arrMouse(iIndex).py = cMaxPY
' DEFINE TARGET RECT FOR WHERE TO DRAW ON SCREEN
TargetRect.left = rc.left + arrMouse(iIndex).px
TargetRect.top = rc.top + arrMouse(iIndex).py
TargetRect.right = rc.right + arrMouse(iIndex).px
TargetRect.bottom = rc.bottom + arrMouse(iIndex).py
' COLLECT VALUES FOR THIS MOUSE IN A STRING
sText = ""
sText = sText + _Trim$(Str$(iCount))
sText = sText + " ("
sText = sText + _Trim$(Str$(arrMouse(iIndex).px))
sText = sText + ","
sText = sText + _Trim$(Str$(arrMouse(iIndex).py))
sText = sText + ") "
sText = sText + IIFS$(arrMouse(iIndex).LeftDown, "1", " ")
sText = sText + IIFS$(arrMouse(iIndex).MiddleDown, "2", " ")
sText = sText + IIFS$(arrMouse(iIndex).RightDown, "3", " ")
'arrMouse(iIndex).wheel
'arrMouse(iIndex).char
'arrMouse(iIndex).y
'arrMouse(iIndex).x
' DRAW VALUES FOR THIS MOUSE TO SCREEN AT POINTER POSITION
DrawText hdc, Offset(sText), Len(sText), Offset(TargetRect), DT_LEFT
OffsetRect Offset(TargetRect), arrMouse(iIndex).px, arrMouse(iIndex).px
End If
Next iIndex
' -----------------------------------------------------------------------------
' DISPLAY INSTRUCTIONS ON SCREEN
' DEFINE TARGET RECT FOR WHERE TO DRAW ON SCREEN
TargetRect.left = rc.left + 100
TargetRect.top = rc.top + 500
TargetRect.right = rc.right + 100
TargetRect.bottom = rc.bottom + 500
' COLLECT VALUES FOR THIS KEYBOARD IN A STRING
sText = ""
sText = sText + "Raw Input API multi-mouse demo:"
sText = sText + Chr$(13)
sText = sText + Chr$(13)
sText = sText + "1. Plug in 2 or more USB mice"
sText = sText + Chr$(13)
sText = sText + "2. Move them around and click the buttons."
sText = sText + Chr$(13)
sText = sText + "3. Try pressing some keys on the keyboard."
sText = sText + Chr$(13)
sText = sText + Chr$(13)
sText = sText + "Press ESC to exit."
' DRAW VALUES FOR THIS KEYBOARD TO SCREEN AT NEXT POSITION
DrawText hdc, Offset(sText), Len(sText), Offset(TargetRect), DT_LEFT
OffsetRect Offset(TargetRect), 0, 0 ' y,x
' -----------------------------------------------------------------------------
' DISPLAY KEYBOARD INFO ON SCREEN
' DEFINE TARGET RECT FOR WHERE TO DRAW ON SCREEN
TargetRect.left = rc.left + 400
TargetRect.top = rc.top + 100
TargetRect.right = rc.right + 400
TargetRect.bottom = rc.bottom + 100
' COLLECT VALUES FOR THIS KEYBOARD IN A STRING
sText = ""
sText = sText + "Keyboard: "
sText = sText + IIFS$(iLastKeyDown > 0, VirtualKeyCodeToString$(iLastKeyDown) + " (" + _Trim$(Str$(iLastKeyDown)) + ")", "")
'sText = sText + Chr$(13)
'sText = sText + " LAST DOWN="
'sText = sText + IIFS$(iLastKeyDown > 0, VirtualKeyCodeToString$(iLastKeyDown), "")
'sText = sText + Chr$(13)
'sText = sText + " LAST UP ="
'sText = sText + IIFS$(iLastKeyUp > 0, VirtualKeyCodeToString$(iLastKeyUp), "")
' DRAW VALUES FOR THIS KEYBOARD TO SCREEN AT NEXT POSITION
DrawText hdc, Offset(sText), Len(sText), Offset(TargetRect), DT_LEFT
OffsetRect Offset(TargetRect), 0, 0 ' y,x
' -----------------------------------------------------------------------------
' FINISH PAINT
EndPaint hwnd, Offset(ps)
MainWndProc = 0
Exit Function
Case WM_CHAR:
DebugPrint "nMsg = WM_CHAR"
'' GET AN INTEGER FROM WPARAM
'If wParam < 32768 Then
' int_wParam = Val(_Trim$(Str$(wParam)))
'Else
' int_wParam = -1
'End If
'
'' WM_CHAR message
'' https://learn.microsoft.com/en-us/windows/win32/inputdev/wm-char
'' Posted to the window with the keyboard focus when a WM_KEYDOWN message is translated by the TranslateMessage function. The WM_CHAR message contains the character code of the key that was pressed.
'DebugPrint "nMsg = WM_CHAR"
'DebugPrint " Offset hwnd=" + _Trim$(Str$(hwnd)) + ", Unsigned Long nMsg=" + _Trim$(Str$(nMsg)) + ", Unsigned Offset wParam=" + _Trim$(Str$(wParam)) + ", Offset lParam=" + _Trim$(Str$(lParam))
'DebugPrint " Pressed key: " + VirtualKeyCodeToString$(int_wParam)
'
'' INVOKE PAINT
'InvalidateRect hwnd, 0, -1
'SendMessage hwnd, WM_PAINT, 0, 0
'MainWndProc = 0
Exit Function
Case WM_KEYDOWN:
DebugPrint "nMsg = WM_KEYDOWN"
' GET AN INTEGER FROM WPARAM
If wParam < 32768 Then
int_wParam = Val(_Trim$(Str$(wParam)))
Else
int_wParam = -1
End If
' REMEMBER KEY
iLastKeyDown = int_wParam
' WM_KEYDOWN message
' Posted to the window with the keyboard focus when a nonsystem key is pressed. A nonsystem key is a key that is pressed when the ALT key is not pressed.
' https://learn.microsoft.com/en-us/windows/win32/inputdev/wm-keydown
DebugPrint "nMsg = WM_KEYDOWN"
DebugPrint " strNextID =" + Chr$(34) + strNextID + Chr$(34)
DebugPrint " Offset hwnd=" + _Trim$(Str$(hwnd)) + ", Unsigned Long nMsg=" + _Trim$(Str$(nMsg)) + ", Unsigned Offset wParam=" + _Trim$(Str$(wParam)) + ", Offset lParam=" + _Trim$(Str$(lParam))
DebugPrint " Pressed key: " + VirtualKeyCodeToString$(int_wParam)
' INVOKE PAINT
InvalidateRect hwnd, 0, -1
SendMessage hwnd, WM_PAINT, 0, 0
MainWndProc = 0
Exit Function
Case WM_KEYUP:
DebugPrint "nMsg = WM_KEYUP"
' GET AN INTEGER FROM WPARAM
If wParam < 32768 Then
int_wParam = Val(_Trim$(Str$(wParam)))
Else
int_wParam = -1
End If
' REMEMBER KEY
iLastKeyUp = int_wParam
iLastKeyDown = 0
' WM_KEYUP message
' https://learn.microsoft.com/en-us/windows/win32/inputdev/wm-keyup
' Posted to the window with the keyboard focus when a nonsystem key is released. A nonsystem key is a key that is pressed when the ALT key is not pressed, or a keyboard key that is pressed when a window has the keyboard focus.
DebugPrint "nMsg = WM_KEYUP"
DebugPrint " strNextID =" + Chr$(34) + strNextID + Chr$(34)
DebugPrint " Offset hwnd=" + _Trim$(Str$(hwnd)) + ", Unsigned Long nMsg=" + _Trim$(Str$(nMsg)) + ", Unsigned Offset wParam=" + _Trim$(Str$(wParam)) + ", Offset lParam=" + _Trim$(Str$(lParam))
DebugPrint " Pressed key: " + VirtualKeyCodeToString$(int_wParam)
' INVOKE PAINT
InvalidateRect hwnd, 0, -1
SendMessage hwnd, WM_PAINT, 0, 0
MainWndProc = 0
' EXIT WHEN USER RELEASES ESCAPE KEY
If int_wParam = 27 Then System
Exit Function
Case WM_SYSCHAR:
DebugPrint "nMsg = WM_SYSCHAR"
'' GET AN INTEGER FROM WPARAM
'If wParam < 32768 Then
' int_wParam = Val(_Trim$(Str$(wParam)))
'Else
' int_wParam = -1
'End If
'
'' WM_SYSCHAR message
'' https://learn.microsoft.com/en-us/windows/win32/menurc/wm-syschar
'' Posted to the window with the keyboard focus when a WM_SYSKEYDOWN message is translated by the TranslateMessage function. It specifies the character code of a system character key that is, a character key that is pressed while the ALT key is down.
'DebugPrint "nMsg = WM_SYSCHAR"
'DebugPrint " Offset hwnd=" + _Trim$(Str$(hwnd)) + ", Unsigned Long nMsg=" + _Trim$(Str$(nMsg)) + ", Unsigned Offset wParam=" + _Trim$(Str$(wParam)) + ", Offset lParam=" + _Trim$(Str$(lParam))
'DebugPrint " Pressed key: " + VirtualKeyCodeToString$(int_wParam)
'
'' INVOKE PAINT
'InvalidateRect hwnd, 0, -1
'SendMessage hwnd, WM_PAINT, 0, 0
'MainWndProc = 0
Exit Function
Case WM_SYSKEYDOWN:
DebugPrint "nMsg = WM_SYSKEYDOWN"
' GET AN INTEGER FROM WPARAM
If wParam < 32768 Then
int_wParam = Val(_Trim$(Str$(wParam)))
Else
int_wParam = -1
End If
' REMEMBER KEY
iLastKeyDown = int_wParam
' WM_SYSKEYDOWN message
' https://learn.microsoft.com/en-us/windows/win32/inputdev/wm-syskeydown
' Posted to the window with the keyboard focus when the user presses the F10 key (which activates the menu bar) or holds down the ALT key and then presses another key. It also occurs when no window currently has the keyboard focus; in this case, the WM_SYSKEYDOWN message is sent to the active window. The window that receives the message can distinguish between these two contexts by checking the context code in the lParam parameter.
DebugPrint "nMsg = WM_SYSKEYDOWN"
DebugPrint " strNextID =" + Chr$(34) + strNextID + Chr$(34)
DebugPrint " Offset hwnd=" + _Trim$(Str$(hwnd)) + ", Unsigned Long nMsg=" + _Trim$(Str$(nMsg)) + ", Unsigned Offset wParam=" + _Trim$(Str$(wParam)) + ", Offset lParam=" + _Trim$(Str$(lParam))
DebugPrint " Pressed key: " + VirtualKeyCodeToString$(int_wParam)
' INVOKE PAINT
InvalidateRect hwnd, 0, -1
SendMessage hwnd, WM_PAINT, 0, 0
MainWndProc = 0
Exit Function
Case WM_SYSKEYUP:
DebugPrint "nMsg = WM_SYSKEYUP"
' GET AN INTEGER FROM WPARAM
If wParam < 32768 Then
int_wParam = Val(_Trim$(Str$(wParam)))
Else
int_wParam = -1
End If
' REMEMBER KEY
iLastKeyUp = int_wParam
iLastKeyDown = 0
' WM_SYSKEYUP message
' https://learn.microsoft.com/en-us/windows/win32/inputdev/wm-syskeyup
' Posted to the window with the keyboard focus when the user releases a key that was pressed while the ALT key was held down. It also occurs when no window currently has the keyboard focus; in this case, the WM_SYSKEYUP message is sent to the active window. The window that receives the message can distinguish between these two contexts by checking the context code in the lParam parameter.
' A window receives this message through its WindowProc function.
DebugPrint "nMsg = WM_SYSKEYUP"
DebugPrint " strNextID =" + Chr$(34) + strNextID + Chr$(34)
DebugPrint " Offset hwnd=" + _Trim$(Str$(hwnd)) + ", Unsigned Long nMsg=" + _Trim$(Str$(nMsg)) + ", Unsigned Offset wParam=" + _Trim$(Str$(wParam)) + ", Offset lParam=" + _Trim$(Str$(lParam))
DebugPrint " Pressed key: " + VirtualKeyCodeToString$(int_wParam)
' INVOKE PAINT
InvalidateRect hwnd, 0, -1
SendMessage hwnd, WM_PAINT, 0, 0
MainWndProc = 0
Exit Function
Case Else:
' some other message
MainWndProc = DefWindowProc(hwnd, nMsg, wParam, lParam)
End Select
End Function ' MainWndProc
' /////////////////////////////////////////////////////////////////////////////
' Initializes raw input stuff
Sub InitRawInput ()
Dim As RAWINPUTDEVICE Rid(0 To 49)
Dim As Unsigned Long nDevices
Dim As RAWINPUTDEVICELIST RawInputDeviceList
Dim As MEM pRawInputDeviceList
ReDim As RAWINPUTDEVICELIST rawdevs(-1)
Dim As Unsigned Long x
Dim iLoop2 As Integer
Dim strNextID As String
If GetRawInputDeviceList(0, Offset(nDevices), Len(RawInputDeviceList)) <> 0 Then
Exit Sub
End If
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 DEVICE 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)
' Is it a mouse or Keyboard?
If rawdevs(x).dwType = RIM_TYPEMOUSE Then
iMouseCount = iMouseCount + 1 ' INCREMENT THE MOUSE COUNT
strNextID = _Trim$(Str$(rawdevs(x).hDevice)) ' GET THE MOUSE DEVICE ID
arrMouse(iMouseCount - 1).ID = strNextID ' SAVE THE MOUSE DEVICE ID
ElseIf rawdevs(x).dwType = RIM_TYPEKEYBOARD Then
'iKeyBoardCount = iKeyBoardCount + 1 ' INCREMENT THE KEYBAORD COUNT
'strNextID = _Trim$(Str$(rawdevs(x).hDevice)) ' GET THE KEYBOARD DEVICE ID
'arrKeyIndex(iKeyBoardCount - 1) = strNextID ' SAVE THE KEYBOARD DEVICE ID
'arrLastKeyDown(iKeyBoardCount - 1) = 0
End If
Next x
' FOR NOW KEYBOARD INFO IS NOT RAW INPUT, UNTIL WE FIGURE IT OUT:
iLastKeyDown = 0
iLastKeyUp = 0
rawinputdevices = rawinputdevices + Chr$(0)
MemFree pRawInputDeviceList
Rid(0).usUsagePage = &H01
Rid(0).usUsage = &H02
Rid(0).dwFlags = 0
Rid(0).hwndTarget = 0
If RegisterRawInputDevices(Offset(Rid()), 1, Len(Rid(0))) = 0 Then
m_sError = "RawInput init failed" + Chr$(0)
End If
End Sub ' InitRawInput
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END RAW INPUT FUNCTIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN RAW INPUT VARIABLE FUNCTIONS #1
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' /////////////////////////////////////////////////////////////////////////////
' Initialize variables that store mouse + keyboard input
Sub InitInputVars
Dim iIndex As Integer
Dim iLoop As Integer
' FOR NOW ONLY SUPPORT UPTO 8 MICE
If (iMouseCount > 8) Then iMouseCount = 8
' INITIALIZE CURSORS, MOUSE STATE, ETC.
Restore CData
iIndex = LBound(arrMouse) - 1
For iLoop = 1 To iMouseCount
iIndex = iIndex + 1
Read arrMouse(iIndex).char
arrMouse(iIndex).dx = 0
arrMouse(iIndex).dy = 0
arrMouse(iIndex).pdx = 100
arrMouse(iIndex).pdy = 100
arrMouse(iIndex).LeftDown = FALSE
arrMouse(iIndex).MiddleDown = FALSE
arrMouse(iIndex).RightDown = FALSE
arrMouse(iIndex).LeftCount = 0
arrMouse(iIndex).MiddleCount = 0
arrMouse(iIndex).RightCount = 0
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 HIRES X COORDINATES
Restore PXData
iIndex = LBound(arrMouse) - 1
For iLoop = 1 To iMouseCount
iIndex = iIndex + 1
Read arrMouse(iIndex).px
Next iLoop
' INITIALIZE HIRES Y COORDINATES
Restore PYData
iIndex = LBound(arrMouse) - 1
For iLoop = 1 To iMouseCount
iIndex = iIndex + 1
Read arrMouse(iIndex).py
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
' INITIALIZE KEYBOARD STATE VARIABLES
'iKeyBoardCount = 0 ' # OF KEYBOARDS ATTACHED
'For iIndex = lbound(arrKeyIndex) to ubound(arrKeyIndex)
' arrKeyIndex(iIndex) = "" ' STORES KEYBOARD ID
' arrLastKeyDown(iIndex) = 0 ' STORES LAST KEY PRESSED FOR THIS KEYBOARD
'next iIndex
iLastKeyDown = 0
iLastKeyUp = 0
End Sub ' InitInputVars
' /////////////////////////////////////////////////////////////////////////////
' Finds position in array arrMouse where .ID = MouseID
Function GetMouseIndex% (MouseID As String)
Dim iLoop As Integer
Dim iIndex%
iIndex% = LBound(arrMouse) - 1
For iLoop = LBound(arrMouse) To UBound(arrMouse)
If arrMouse(iLoop).ID = MouseID Then
iIndex% = iLoop
Exit For
End If
Next iLoop
GetMouseIndex% = iIndex%
End Function ' GetMouseIndex%
'' /////////////////////////////////////////////////////////////////////////////
'' Finds position in array arrKeyIndex containing KeyboardID
'
'Function GetKeyboardIndex% (KeyboardID As String)
' Dim iLoop As Integer
' Dim iIndex%
' iIndex% = LBound(arrKeyIndex) - 1
' For iLoop = LBound(arrKeyIndex) To UBound(arrKeyIndex)
' If arrKeyIndex(iLoop) = KeyboardID Then
' iIndex% = iLoop
' Exit For
' End If
' Next iLoop
' GetKeyboardIndex% = iIndex%
'End Function ' GetKeyboardIndex%
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END RAW INPUT VARIABLE FUNCTIONS #1
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN CONSTANT TO STRING FUNCTIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' /////////////////////////////////////////////////////////////////////////////
Function VirtualKeyCodeToString$ (MyInteger As Integer)
Dim Mystring As String
Select Case MyInteger
Case VK_LBUTTON:
Mystring = "VK_LBUTTON"
Case VK_RBUTTON:
Mystring = "VK_RBUTTON"
Case VK_CANCEL:
Mystring = "VK_CANCEL"
Case VK_MBUTTON:
Mystring = "VK_MBUTTON"
Case VK_XBUTTON1:
Mystring = "VK_XBUTTON1"
Case VK_XBUTTON2:
Mystring = "VK_XBUTTON2"
Case VK_BACK:
Mystring = "VK_BACK"
Case VK_TAB:
Mystring = "VK_TAB"
Case VK_CLEAR:
Mystring = "VK_CLEAR"
Case VK_RETURN:
Mystring = "VK_RETURN"
Case VK_SHIFT:
Mystring = "VK_SHIFT"
Case VK_CONTROL:
Mystring = "VK_CONTROL"
Case VK_MENU:
Mystring = "VK_MENU"
Case VK_PAUSE:
Mystring = "VK_PAUSE"
Case VK_CAPITAL:
Mystring = "VK_CAPITAL"
Case VK_KANA:
Mystring = "VK_KANA"
Case VK_HANGUL:
Mystring = "VK_HANGUL"
Case VK_IME_ON:
Mystring = "VK_IME_ON"
Case VK_JUNJA:
Mystring = "VK_JUNJA"
Case VK_FINAL:
Mystring = "VK_FINAL"
Case VK_HANJA:
Mystring = "VK_HANJA"
Case VK_KANJI:
Mystring = "VK_KANJI"
Case VK_IME_OFF:
Mystring = "VK_IME_OFF"
Case VK_ESCAPE:
Mystring = "VK_ESCAPE"
Case VK_CONVERT:
Mystring = "VK_CONVERT"
Case VK_NONCONVERT:
Mystring = "VK_NONCONVERT"
Case VK_ACCEPT:
Mystring = "VK_ACCEPT"
Case VK_MODECHANGE:
Mystring = "VK_MODECHANGE"
Case VK_SPACE:
Mystring = "VK_SPACE"
Case VK_PRIOR:
Mystring = "VK_PRIOR"
Case VK_NEXT:
Mystring = "VK_NEXT"
Case VK_END:
Mystring = "VK_END"
Case VK_HOME:
Mystring = "VK_HOME"
Case VK_LEFT:
Mystring = "VK_LEFT"
Case VK_UP:
Mystring = "VK_UP"
Case VK_RIGHT:
Mystring = "VK_RIGHT"
Case VK_DOWN:
Mystring = "VK_DOWN"
Case VK_SELECT:
Mystring = "VK_SELECT"
Case VK_PRINT:
Mystring = "VK_PRINT"
Case VK_EXECUTE:
Mystring = "VK_EXECUTE"
Case VK_SNAPSHOT:
Mystring = "VK_SNAPSHOT"
Case VK_INSERT:
Mystring = "VK_INSERT"
Case VK_DELETE:
Mystring = "VK_DELETE"
Case VK_HELP:
Mystring = "VK_HELP"
Case VK_0:
Mystring = "VK_0"
Case VK_1:
Mystring = "VK_1"
Case VK_2:
Mystring = "VK_2"
Case VK_3:
Mystring = "VK_3"
Case VK_4:
Mystring = "VK_4"
Case VK_5:
Mystring = "VK_5"
Case VK_6:
Mystring = "VK_6"
Case VK_7:
Mystring = "VK_7"
Case VK_8:
Mystring = "VK_8"
Case VK_9:
Mystring = "VK_9"
Case VK_A:
Mystring = "VK_A"
Case VK_B:
Mystring = "VK_B"
Case VK_C:
Mystring = "VK_C"
Case VK_D:
Mystring = "VK_D"
Case VK_E:
Mystring = "VK_E"
Case VK_F:
Mystring = "VK_F"
Case VK_G:
Mystring = "VK_G"
Case VK_H:
Mystring = "VK_H"
Case VK_I:
Mystring = "VK_I"
Case VK_J:
Mystring = "VK_J"
Case VK_K:
Mystring = "VK_K"
Case VK_L:
Mystring = "VK_L"
Case VK_M:
Mystring = "VK_M"
Case VK_N:
Mystring = "VK_N"
Case VK_O:
Mystring = "VK_O"
Case VK_P:
Mystring = "VK_P"
Case VK_Q:
Mystring = "VK_Q"
Case VK_R:
Mystring = "VK_R"
Case VK_S:
Mystring = "VK_S"
Case VK_T:
Mystring = "VK_T"
Case VK_U:
Mystring = "VK_U"
Case VK_V:
Mystring = "VK_V"
Case VK_W:
Mystring = "VK_W"
Case VK_X:
Mystring = "VK_X"
Case VK_Y:
Mystring = "VK_Y"
Case VK_Z:
Mystring = "VK_Z"
Case VK_LWIN:
Mystring = "VK_LWIN"
Case VK_RWIN:
Mystring = "VK_RWIN"
Case VK_APPS:
Mystring = "VK_APPS"
Case VK_SLEEP:
Mystring = "VK_SLEEP"
Case VK_NUMPAD0:
Mystring = "VK_NUMPAD0"
Case VK_NUMPAD1:
Mystring = "VK_NUMPAD1"
Case VK_NUMPAD2:
Mystring = "VK_NUMPAD2"
Case VK_NUMPAD3:
Mystring = "VK_NUMPAD3"
Case VK_NUMPAD4:
Mystring = "VK_NUMPAD4"
Case VK_NUMPAD5:
Mystring = "VK_NUMPAD5"
Case VK_NUMPAD6:
Mystring = "VK_NUMPAD6"
Case VK_NUMPAD7:
Mystring = "VK_NUMPAD7"
Case VK_NUMPAD8:
Mystring = "VK_NUMPAD8"
Case VK_NUMPAD9:
Mystring = "VK_NUMPAD9"
Case VK_MULTIPLY:
Mystring = "VK_MULTIPLY"
Case VK_ADD:
Mystring = "VK_ADD"
Case VK_SEPARATOR:
Mystring = "VK_SEPARATOR"
Case VK_SUBTRACT:
Mystring = "VK_SUBTRACT"
Case VK_DECIMAL:
Mystring = "VK_DECIMAL"
Case VK_DIVIDE:
Mystring = "VK_DIVIDE"
Case VK_F1:
Mystring = "VK_F1"
Case VK_F2:
Mystring = "VK_F2"
Case VK_F3:
Mystring = "VK_F3"
Case VK_F4:
Mystring = "VK_F4"
Case VK_F5:
Mystring = "VK_F5"
Case VK_F6:
Mystring = "VK_F6"
Case VK_F7:
Mystring = "VK_F7"
Case VK_F8:
Mystring = "VK_F8"
Case VK_F9:
Mystring = "VK_F9"
Case VK_F10:
Mystring = "VK_F10"
Case VK_F11:
Mystring = "VK_F11"
Case VK_F12:
Mystring = "VK_F12"
Case VK_F13:
Mystring = "VK_F13"
Case VK_F14:
Mystring = "VK_F14"
Case VK_F15:
Mystring = "VK_F15"
Case VK_F16:
Mystring = "VK_F16"
Case VK_F17:
Mystring = "VK_F17"
Case VK_F18:
Mystring = "VK_F18"
Case VK_F19:
Mystring = "VK_F19"
Case VK_F20:
Mystring = "VK_F20"
Case VK_F21:
Mystring = "VK_F21"
Case VK_F22:
Mystring = "VK_F22"
Case VK_F23:
Mystring = "VK_F23"
Case VK_F24:
Mystring = "VK_F24"
Case VK_NUMLOCK:
Mystring = "VK_NUMLOCK"
Case VK_SCROLL:
Mystring = "VK_SCROLL"
Case VK_LSHIFT:
Mystring = "VK_LSHIFT"
Case VK_RSHIFT:
Mystring = "VK_RSHIFT"
Case VK_LCONTROL:
Mystring = "VK_LCONTROL"
Case VK_RCONTROL:
Mystring = "VK_RCONTROL"
Case VK_LMENU:
Mystring = "VK_LMENU"
Case VK_RMENU:
Mystring = "VK_RMENU"
Case VK_BROWSER_BACK:
Mystring = "VK_BROWSER_BACK"
Case VK_BROWSER_FORWARD:
Mystring = "VK_BROWSER_FORWARD"
Case VK_BROWSER_REFRESH:
Mystring = "VK_BROWSER_REFRESH"
Case VK_BROWSER_STOP:
Mystring = "VK_BROWSER_STOP"
Case VK_BROWSER_SEARCH:
Mystring = "VK_BROWSER_SEARCH"
Case VK_BROWSER_FAVORITES:
Mystring = "VK_BROWSER_FAVORITES"
Case VK_BROWSER_HOME:
Mystring = "VK_BROWSER_HOME"
Case VK_VOLUME_MUTE:
Mystring = "VK_VOLUME_MUTE"
Case VK_VOLUME_DOWN:
Mystring = "VK_VOLUME_DOWN"
Case VK_VOLUME_UP:
Mystring = "VK_VOLUME_UP"
Case VK_MEDIA_NEXT_TRACK:
Mystring = "VK_MEDIA_NEXT_TRACK"
Case VK_MEDIA_PREV_TRACK:
Mystring = "VK_MEDIA_PREV_TRACK"
Case VK_MEDIA_STOP:
Mystring = "VK_MEDIA_STOP"
Case VK_MEDIA_PLAY_PAUSE:
Mystring = "VK_MEDIA_PLAY_PAUSE"
Case VK_LAUNCH_MAIL:
Mystring = "VK_LAUNCH_MAIL"
Case VK_LAUNCH_MEDIA_SELECT:
Mystring = "VK_LAUNCH_MEDIA_SELECT"
Case VK_LAUNCH_APP1:
Mystring = "VK_LAUNCH_APP1"
Case VK_LAUNCH_APP2:
Mystring = "VK_LAUNCH_APP2"
Case VK_OEM_1:
Mystring = "VK_OEM_1"
Case VK_OEM_PLUS:
Mystring = "VK_OEM_PLUS"
Case VK_OEM_COMMA:
Mystring = "VK_OEM_COMMA"
Case VK_OEM_MINUS:
Mystring = "VK_OEM_MINUS"
Case VK_OEM_PERIOD:
Mystring = "VK_OEM_PERIOD"
Case VK_OEM_2:
Mystring = "VK_OEM_2"
Case VK_OEM_3:
Mystring = "VK_OEM_3"
Case VK_OEM_4:
Mystring = "VK_OEM_4"
Case VK_OEM_5:
Mystring = "VK_OEM_5"
Case VK_OEM_6:
Mystring = "VK_OEM_6"
Case VK_OEM_7:
Mystring = "VK_OEM_7"
Case VK_OEM_8:
Mystring = "VK_OEM_8"
Case VK_OEM_102:
Mystring = "VK_OEM_102"
Case VK_PROCESSKEY:
Mystring = "VK_PROCESSKEY"
Case VK_PACKET:
Mystring = "VK_PACKET"
Case VK_ATTN:
Mystring = "VK_ATTN"
Case VK_CRSEL:
Mystring = "VK_CRSEL"
Case VK_EXSEL:
Mystring = "VK_EXSEL"
Case VK_EREOF:
Mystring = "VK_EREOF"
Case VK_PLAY:
Mystring = "VK_PLAY"
Case VK_ZOOM:
Mystring = "VK_ZOOM"
Case VK_NONAME:
Mystring = "VK_NONAME"
Case VK_PA1:
Mystring = "VK_PA1"
Case VK_OEM_CLEAR:
Mystring = "VK_OEM_CLEAR"
Case Else:
Mystring = _Trim$(Str$(MyInteger))
End Select
VirtualKeyCodeToString$ = Mystring
End Function ' VirtualKeyCodeToString$
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END CONSTANT TO STRING FUNCTIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN GENERAL PURPOSE FUNCTIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' /////////////////////////////////////////////////////////////////////////////
' IIF function for QB for integers
Function IIF (Condition, IfTrue, IfFalse)
If Condition Then IIF = IfTrue Else IIF = IfFalse
End Function
' /////////////////////////////////////////////////////////////////////////////
' IIF function for QB for strings
Function IIFS$ (Condition, IfTrue$, IfFalse$)
If Condition Then IIFS$ = IfTrue$ Else IIFS$ = IfFalse$
End Function
' /////////////////////////////////////////////////////////////////////////////
' Split and join strings
' https://www.qb64.org/forum/index.php?topic=1073.0
'Combine all elements of in$() into a single string with delimiter$ separating the elements.
Function join$ (in$(), delimiter$)
Dim result$
Dim iLoop As Integer
result$ = in$(LBound(in$))
For iLoop = LBound(in$) + 1 To UBound(in$)
result$ = result$ + delimiter$ + in$(iLoop)
Next iLoop
join$ = result$
End Function ' join$
' /////////////////////////////////////////////////////////////////////////////
' Split and join strings
' https://www.qb64.org/forum/index.php?topic=1073.0
'
' FROM luke, QB64 Developer
' Date: February 15, 2019, 04:11:07 AM
'
' Given a string of words separated by spaces (or any other character),
' splits it into an array of the words. I've no doubt many people have
' written a version of this over the years and no doubt there's a million
' ways to do it, but I thought I'd put mine here so we have at least one
' version. There's also a join function that does the opposite
' array -> single string.
'
' Code is hopefully reasonably self explanatory with comments and a little demo.
' Note, this is akin to Python/JavaScript split/join, PHP explode/implode.
'Split in$ into pieces, chopping at every occurrence of delimiter$. Multiple consecutive occurrences
'of delimiter$ are treated as a single instance. The chopped pieces are stored in result$().
'
'delimiter$ must be one character long.
'result$() must have been REDIMmed previously.
' Modified to handle multi-character delimiters
Sub split (in$, delimiter$, result$())
Dim start As Integer
Dim finish As Integer
Dim iDelimLen As Integer
ReDim result$(-1)
iDelimLen = Len(delimiter$)
start = 1
Do
'While Mid$(in$, start, 1) = delimiter$
While Mid$(in$, start, iDelimLen) = delimiter$
'start = start + 1
start = start + iDelimLen
If start > Len(in$) Then
Exit Sub
End If
Wend
finish = InStr(start, in$, delimiter$)
If finish = 0 Then
finish = Len(in$) + 1
End If
ReDim _Preserve result$(0 To UBound(result$) + 1)
result$(UBound(result$)) = Mid$(in$, start, finish - start)
start = finish + 1
Loop While start <= Len(in$)
End Sub ' split
' /////////////////////////////////////////////////////////////////////////////
' FROM: String Manipulation
' found at abandoned, outdated and now likely malicious qb64 dot net website
' http://www.qb64.[net]/forum/index_topic_5964-0/
'
'SUMMARY:
' Purpose: A library of custom functions that transform strings.
' Author: Dustinian Camburides (dustinian@gmail.com)
' Platform: QB64 (www.qb64.org)
' Revision: 1.6
' Updated: 5/28/2012
'SUMMARY:
'[Replace$] replaces all instances of the [Find] sub-string with the [Add] sub-string within the [Text] string.
'INPUT:
'Text: The input string; the text that's being manipulated.
'Find: The specified sub-string; the string sought within the [Text] string.
'Add: The sub-string that's being added to the [Text] string.
Function Replace$ (Text1 As String, Find1 As String, Add1 As String)
' VARIABLES:
Dim Text2 As String
Dim Find2 As String
Dim Add2 As String
Dim lngLocation As Long ' The address of the [Find] substring within the [Text] string.
Dim strBefore As String ' The characters before the string to be replaced.
Dim strAfter As String ' The characters after the string to be replaced.
' INITIALIZE:
' MAKE COPIESSO THE ORIGINAL IS NOT MODIFIED (LIKE ByVal IN VBA)
Text2 = Text1
Find2 = Find1
Add2 = Add1
lngLocation = InStr(1, Text2, Find2)
' PROCESSING:
' While [Find2] appears in [Text2]...
While lngLocation
' Extract all Text2 before the [Find2] substring:
strBefore = Left$(Text2, lngLocation - 1)
' Extract all text after the [Find2] substring:
strAfter = Right$(Text2, ((Len(Text2) - (lngLocation + Len(Find2) - 1))))
' Return the substring:
Text2 = strBefore + Add2 + strAfter
' Locate the next instance of [Find2]:
lngLocation = InStr(1, Text2, Find2)
' Next instance of [Find2]...
Wend
' OUTPUT:
Replace$ = Text2
End Function ' Replace$
'' /////////////////////////////////////////////////////////////////////////////
'
'Sub SplitTest
' Dim in$
' Dim delim$
' ReDim arrText$(0)
' Dim iLoop%
'
' delim$ = Chr$(10)
' in$ = "this" + delim$ + "is" + delim$ + "a" + delim$ + "test"
' Print "in$ = " + Chr$(34) + in$ + Chr$(34)
' Print "delim$ = " + Chr$(34) + delim$ + Chr$(34)
' split in$, delim$, arrText$()
'
' For iLoop% = LBound(arrText$) To UBound(arrText$)
' Print "arrText$(" + _Trim$(Str$(iLoop%)) + ") = " + Chr$(34) + arrText$(iLoop%) + Chr$(34)
' Next iLoop%
' Print
' Print "Split test finished."
'End Sub ' SplitTest
'' /////////////////////////////////////////////////////////////////////////////
'
'Sub SplitAndReplaceTest
' Dim in$
' Dim out$
' Dim iLoop%
' ReDim arrText$(0)
'
' Print "-------------------------------------------------------------------------------"
' Print "SplitAndReplaceTest"
' Print
'
' Print "Original value"
' in$ = "This line 1 " + Chr$(13) + Chr$(10) + "and line 2" + Chr$(10) + "and line 3 " + Chr$(13) + "finally THE END."
' out$ = in$
' out$ = Replace$(out$, Chr$(13), "\r")
' out$ = Replace$(out$, Chr$(10), "\n")
' out$ = Replace$(out$, Chr$(9), "\t")
' Print "in$ = " + Chr$(34) + out$ + Chr$(34)
' Print
'
' Print "Fixing linebreaks..."
' in$ = Replace$(in$, Chr$(13) + Chr$(10), Chr$(13))
' in$ = Replace$(in$, Chr$(10), Chr$(13))
' out$ = in$
' out$ = Replace$(out$, Chr$(13), "\r")
' out$ = Replace$(out$, Chr$(10), "\n")
' out$ = Replace$(out$, Chr$(9), "\t")
' Print "in$ = " + Chr$(34) + out$ + Chr$(34)
' Print
'
' Print "Splitting up..."
' split in$, Chr$(13), arrText$()
'
' For iLoop% = LBound(arrText$) To UBound(arrText$)
' out$ = arrText$(iLoop%)
' out$ = Replace$(out$, Chr$(13), "\r")
' out$ = Replace$(out$, Chr$(10), "\n")
' out$ = Replace$(out$, Chr$(9), "\t")
' Print "arrText$(" + cstr$(iLoop%) + ") = " + Chr$(34) + out$ + Chr$(34)
' Next iLoop%
' Print
'
' Print "SplitAndReplaceTest finished."
'End Sub ' SplitAndReplaceTest
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END GENERAL PURPOSE FUNCTIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN handle MEM for any type
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' QB64 GPT Just Rewrote My Code
' https://qb64phoenix.com/forum/showthread.php?tid=2728
' And the revisions QB64 GPT made (after minor changes and me asking it to redo some syntax errors):
' It separated out a lot of processing out to separate subs.
' It is quite impressive how little input I had to give it to fix its mistakes.
' The code actually worked just as well as it did before the changes, which blows my mind.
' It actually even listened to me when I told it that it would need to cast an OFFSET type by using VAL(STR$(var)).
' To be fair, I had to tell it "ByRef" was invalid and a couple of other things.
' I also had to declare "y" each time it was used. But the last iteration only required me to declare "y".
' I think that is a decent enough result. Too bad I can't get it to be this good every time.
' 1) This is the paid version of GPT4. I am on the plus plan, so whatever that one has.
' 2) I think I deleted the session. Sorry. I only used it for as long as I needed it.
' 3) I don't know what the hard limit is. It's in "tokens", which I have no idea how those are calculated.
' I got a pretty large source code from one output and it can take a lot of input. I would just say it can handle quite a bit.
' The GPT I used was one I trained using the Wiki, sample code, etc. At the time, it used GPT4.
' Custom GPTs now use 4o. I will probably need to republish it to take advantage of 4o for it.
' I guess training is the wrong word. A custom GPT has a "knowledge base".
' You can have a maximum of 20 files.
' It can use those files to create an answer. Even a zip folder can be used.
' It will basically only use the knowledge base when specifically asked. Otherwise, it is using whatever it already had in its model.
' As for testing code and such, you can create "actions" for your GPT that allow it to do things outside of ChatGPT, including REST API.
' So if dbox ever made a REST API for QBJS, you could definitely have it write QBJS code and then ask it to run it.
Sub anyArg (args() As _MEM)
Dim As _Unsigned Integer x, y
Dim As _Unsigned _Offset z
Dim As _Unsigned Long size, elementsize
For x = LBound(args) To UBound(args)
If _MemExists(args(x)) Then
z = 0
size = Val(Str$(args(x).SIZE))
elementsize = Val(Str$(args(x).ELEMENTSIZE))
If _ReadBit(args(x).TYPE, 7) And _ReadBit(args(x).TYPE, 13) = 0 Then
HandleNumericType args(x), size, elementsize, z
ElseIf _ReadBit(args(x).TYPE, 8) Then
HandleFloatingType args(x), size, elementsize, z
ElseIf _ReadBit(args(x).TYPE, 9) Then
HandleStringType args(x), size, elementsize
ElseIf _ReadBit(args(x).TYPE, 13) And _ReadBit(args(x).TYPE, 7) Then
HandleOffsetType args(x), size, elementsize, z
ElseIf args(x).TYPE = 0 And args(x).SIZE > 0 Then
HandleSoundType args(x)
ElseIf _ReadBit(args(x).TYPE, 14) Then
Print args(x).SIZE, "MEM"
' TODO: Handle other types if necessary
End If
If _ReadBit(args(x).TYPE, 11) Then
Screen args(x).IMAGE
End If
End If
Next
End Sub ' anyArg
' Subroutines for handling specific types
Sub HandleNumericType (arg As _MEM, size As _Unsigned Long, elementsize As _Unsigned Long, z As _Unsigned _Offset)
If _ReadBit(arg.TYPE, 10) Then
If _ReadBit(arg.TYPE, 16) Then
Select Case elementsize
Case 1
Dim As _Unsigned _Byte unsignedbytearray(1 To (size / elementsize))
ProcessArray_UByte unsignedbytearray(), arg, size, elementsize, z, "UBYTE ARRAY"
Case 2
Dim As _Unsigned Integer unsignedintarray(1 To (size / elementsize))
ProcessArray_UInteger unsignedintarray(), arg, size, elementsize, z, "USHORT ARRAY"
Case 4
Dim As _Unsigned Long unsignedlongarray(1 To (size / elementsize))
ProcessArray_ULong unsignedlongarray(), arg, size, elementsize, z, "ULONG ARRAY"
Case 8
Dim As _Unsigned _Integer64 unsignedint64array(1 To (size / elementsize))
ProcessArray_UInt64 unsignedint64array(), arg, size, elementsize, z, "UINT64 ARRAY"
End Select
Else
PrintSingleValue arg, size, elementsize
End If
Else
If _ReadBit(arg.TYPE, 16) Then
Select Case elementsize
Case 1
Dim As _Byte bytearray(1 To (size / elementsize))
ProcessArray_Byte bytearray(), arg, size, elementsize, z, "BYTE ARRAY"
Case 2
Dim As Integer intarray(1 To (size / elementsize))
ProcessArray_Integer intarray(), arg, size, elementsize, z, "SHORT ARRAY"
Case 4
Dim As Long longarray(1 To (size / elementsize))
ProcessArray_Long longarray(), arg, size, elementsize, z, "LONG ARRAY"
Case 8
Dim As _Integer64 int64array(1 To (size / elementsize))
ProcessArray_Int64 int64array(), arg, size, elementsize, z, "INT64 ARRAY"
End Select
Else
PrintSingleValue arg, size, elementsize
End If
End If
End Sub ' HandleNumericType
Sub HandleFloatingType (arg As _MEM, size As _Unsigned Long, elementsize As _Unsigned Long, z As _Unsigned _Offset)
If _ReadBit(arg.TYPE, 16) Then
Select Case elementsize
Case 4
Dim As Single singlearray(1 To (size / elementsize))
ProcessArray_Single singlearray(), arg, size, elementsize, z, "SINGLE ARRAY"
Case 8
Dim As Double doublearray(1 To (size / elementsize))
ProcessArray_Double doublearray(), arg, size, elementsize, z, "DOUBLE ARRAY"
Case 32
Dim As _Float floatarray(1 To (size / elementsize))
ProcessArray_Float floatarray(), arg, size, elementsize, z, "FLOAT ARRAY"
End Select
Else
Select Case size
Case 4
Print _MemGet(arg, arg.OFFSET, Single), "SINGLE"
Case 8
Print _MemGet(arg, arg.OFFSET, Double), "DOUBLE"
Case 32
Print _MemGet(arg, arg.OFFSET, _Float), "FLOAT"
End Select
End If
End Sub ' HandleFloatingType
Sub HandleStringType (arg As _MEM, size As _Unsigned Long, elementsize As _Unsigned Long)
If _ReadBit(arg.TYPE, 16) Then
Dim As String stringarray(1 To (size / elementsize))
Dim As _Unsigned Long y
For y = LBound(stringarray) To UBound(stringarray)
stringarray(y) = Space$(elementsize)
_MemGet arg, (arg.OFFSET) + (y * elementsize - elementsize), stringarray(y)
Print stringarray(y), "STRING ARRAY"
Next
Else
Dim As String stringtest: stringtest = Space$(elementsize)
_MemGet arg, arg.OFFSET, stringtest
Print stringtest
End If
End Sub ' HandleStringType
Sub HandleOffsetType (arg As _MEM, size As _Unsigned Long, elementsize As _Unsigned Long, z As _Unsigned _Offset)
If _ReadBit(arg.TYPE, 10) Then
If _ReadBit(arg.TYPE, 16) Then
Dim As _Unsigned _Offset unsignedoffsetarray(1 To (size / elementsize))
ProcessArray_UOffset unsignedoffsetarray(), arg, size, elementsize, z, "ULONG_PTR ARRAY"
Else
Print _MemGet(arg, arg.OFFSET, _Unsigned _Offset), "ULONG_PTR"
End If
Else
If _ReadBit(arg.TYPE, 16) Then
Dim As _Offset offsetarray(1 To (size / elementsize))
ProcessArray_Offset offsetarray(), arg, size, elementsize, z, "LONG_PTR ARRAY"
Else
Print _MemGet(arg, arg.OFFSET, _Offset), "LONG_PTR"
End If
End If
End Sub ' HandleOffsetType
Sub HandleSoundType (arg As _MEM)
If Not _SndPlaying(arg.SOUND) Then
_SndPlay (arg.SOUND)
End If
Print "SOUND", arg.SIZE, arg.ELEMENTSIZE
End Sub ' HandleSoundType
' Subroutines for processing arrays
Sub ProcessArray_UByte (unsignedbytearray() As _Unsigned _Byte, arg As _MEM, size As _Unsigned Long, elementsize As _Unsigned Long, z As _Unsigned _Offset, typeName As String)
Dim As _Unsigned Long y
For y = LBound(unsignedbytearray) To UBound(unsignedbytearray)
_MemGet arg, arg.OFFSET + z, unsignedbytearray(y)
z = z + elementsize
Print unsignedbytearray(y), typeName
Next
End Sub ' ProcessArray_UByte
Sub ProcessArray_UInteger (unsignedintarray() As _Unsigned Integer, arg As _MEM, size As _Unsigned Long, elementsize As _Unsigned Long, z As _Unsigned _Offset, typeName As String)
Dim As _Unsigned Long y
For y = LBound(unsignedintarray) To UBound(unsignedintarray)
_MemGet arg, arg.OFFSET + z, unsignedintarray(y)
z = z + elementsize
Print unsignedintarray(y), typeName
Next
End Sub ' ProcessArray_UInteger
Sub ProcessArray_ULong (unsignedlongarray() As _Unsigned Long, arg As _MEM, size As _Unsigned Long, elementsize As _Unsigned Long, z As _Unsigned _Offset, typeName As String)
Dim As _Unsigned Long y
For y = LBound(unsignedlongarray) To UBound(unsignedlongarray)
_MemGet arg, arg.OFFSET + z, unsignedlongarray(y)
z = z + elementsize
Print unsignedlongarray(y), typeName
Next
End Sub ' ProcessArray_ULong
Sub ProcessArray_UInt64 (unsignedint64array() As _Unsigned _Integer64, arg As _MEM, size As _Unsigned Long, elementsize As _Unsigned Long, z As _Unsigned _Offset, typeName As String)
Dim As _Unsigned Long y
For y = LBound(unsignedint64array) To UBound(unsignedint64array)
_MemGet arg, arg.OFFSET + z, unsignedint64array(y)
z = z + elementsize
Print unsignedint64array(y), typeName
Next
End Sub ' ProcessArray_UInt64
Sub ProcessArray_Byte (bytearray() As _Byte, arg As _MEM, size As _Unsigned Long, elementsize As _Unsigned Long, z As _Unsigned _Offset, typeName As String)
Dim As _Unsigned Long y
For y = LBound(bytearray) To UBound(bytearray)
_MemGet arg, arg.OFFSET + z, bytearray(y)
z = z + elementsize
Print bytearray(y), typeName
Next
End Sub ' ProcessArray_Byte
Sub ProcessArray_Integer (intarray() As Integer, arg As _MEM, size As _Unsigned Long, elementsize As _Unsigned Long, z As _Unsigned _Offset, typeName As String)
Dim As _Unsigned Long y
For y = LBound(intarray) To UBound(intarray)
_MemGet arg, arg.OFFSET + z, intarray(y)
z = z + elementsize
Print intarray(y), typeName
Next
End Sub ' ProcessArray_Integer
Sub ProcessArray_Long (longarray() As Long, arg As _MEM, size As _Unsigned Long, elementsize As _Unsigned Long, z As _Unsigned _Offset, typeName As String)
Dim As _Unsigned Long y
For y = LBound(longarray) To UBound(longarray)
_MemGet arg, arg.OFFSET + z, longarray(y)
z = z + elementsize
Print longarray(y), typeName
Next
End Sub ' ProcessArray_Long
Sub ProcessArray_Int64 (int64array() As _Integer64, arg As _MEM, size As _Unsigned Long, elementsize As _Unsigned Long, z As _Unsigned _Offset, typeName As String)
Dim As _Unsigned Long y
For y = LBound(int64array) To UBound(int64array)
_MemGet arg, arg.OFFSET + z, int64array(y)
z = z + elementsize
Print int64array(y), typeName
Next
End Sub ' ProcessArray_Int64
Sub ProcessArray_Single (singlearray() As Single, arg As _MEM, size As _Unsigned Long, elementsize As _Unsigned Long, z As _Unsigned _Offset, typeName As String)
Dim As _Unsigned Long y
For y = LBound(singlearray) To UBound(singlearray)
_MemGet arg, arg.OFFSET + z, singlearray(y)
z = z + elementsize
Print singlearray(y), typeName
Next
End Sub ' ProcessArray_Single
Sub ProcessArray_Double (doublearray() As Double, arg As _MEM, size As _Unsigned Long, elementsize As _Unsigned Long, z As _Unsigned _Offset, typeName As String)
Dim As _Unsigned Long y
For y = LBound(doublearray) To UBound(doublearray)
_MemGet arg, arg.OFFSET + z, doublearray(y)
z = z + elementsize
Print doublearray(y), typeName
Next
End Sub ' ProcessArray_Double
Sub ProcessArray_Float (floatarray() As _Float, arg As _MEM, size As _Unsigned Long, elementsize As _Unsigned Long, z As _Unsigned _Offset, typeName As String)
Dim As _Unsigned Long y
For y = LBound(floatarray) To UBound(floatarray)
_MemGet arg, arg.OFFSET + z, floatarray(y)
z = z + elementsize / 2
Print floatarray(y), typeName
Next
End Sub ' ProcessArray_Float
Sub ProcessArray_UOffset (unsignedoffsetarray() As _Unsigned _Offset, arg As _MEM, size As _Unsigned Long, elementsize As _Unsigned Long, z As _Unsigned _Offset, typeName As String)
Dim As _Unsigned Long y
For y = LBound(unsignedoffsetarray) To UBound(unsignedoffsetarray)
_MemGet arg, arg.OFFSET + z, unsignedoffsetarray(y)
z = z + elementsize
Print unsignedoffsetarray(y), typeName
Next
End Sub ' ProcessArray_UOffset
Sub ProcessArray_Offset (offsetarray() As _Offset, arg As _MEM, size As _Unsigned Long, elementsize As _Unsigned Long, z As _Unsigned _Offset, typeName As String)
Dim As _Unsigned Long y
For y = LBound(offsetarray) To UBound(offsetarray)
_MemGet arg, arg.OFFSET + z, offsetarray(y)
z = z + elementsize
Print offsetarray(y), typeName
Next
End Sub ' ProcessArray_Offset
Sub PrintSingleValue (arg As _MEM, size As _Unsigned Long, elementsize As _Unsigned Long)
Select Case size
Case 1
Print _MemGet(arg, arg.OFFSET, _Byte), "BYTE"
Case 2
Print _MemGet(arg, arg.OFFSET, Integer), "SHORT"
Case 4
Print _MemGet(arg, arg.OFFSET, Long), "LONG"
Case 8
Print _MemGet(arg, arg.OFFSET, _Integer64), "INT64"
End Select
End Sub ' PrintSingleValue
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END handle MEM for any type
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ################################################################################################################################################################
' BEGIN DEBUGGING ROUTINES #DEBUG
' ################################################################################################################################################################
' /////////////////////////////////////////////////////////////////////////////
' Prints MyString to console with linebreaks.
' Thanks to:
' SpriggsySpriggs for how to use the QB64 debug console:
' https://www.qb64.org/forum/index.php?topic=3949.0
Sub DebugPrint (MyString As String)
If cDebugEnabled = TRUE Then
ReDim arrLines(-1) As String
Dim iLoop As Integer
split MyString, Chr$(13), arrLines()
For iLoop = LBound(arrLines) To UBound(arrLines)
_Echo arrLines(iLoop)
Next iLoop
End If
End Sub ' DebugPrint
' /////////////////////////////////////////////////////////////////////////////
' Simply prints s$ to console (no linebreaks).
Sub DebugPrint1 (s$)
If cDebugEnabled = TRUE Then
_Echo s$
End If
End Sub ' DebugPrint1
' ################################################################################################################################################################
' END DEBUGGING ROUTINES @DEBUG
' ################################################################################################################################################################
|
|
|
| _RESIZE question |
|
Posted by: TerryRitchie - 06-15-2024, 02:32 AM - Forum: Help Me!
- Replies (5)
|
 |
When exactly is _RESIZE supposed to detect that a screen has resized?
What I thought is that _RESIZE will change to -1 (TRUE) when the borders are resized manually. However, the SCREEN statement is triggering a _RESIZE as well, but it's not consistent. (see code below)
Having SCREEN trigger a resize makes some sense I suppose, but without consistency it's rather difficult to program for.
Is _RESIZE supposed to be going -1 when the SCREEN statement is used? In my opinion it would be better if it didn't.
Code: (Select All)
$RESIZE:ON
PRINT _RESIZE ' no resize event triggered for SCREEN 0
SLEEP ' REM in front of this line has no effect on SCREEN _NEWIMAGE triggering a resize event
SCREEN _NEWIMAGE(640, 480, 32)
PRINT _RESIZE ' resize event triggered
SLEEP ' REM this line and the SCREEN statement below will not trigger a _RESIZE event
SCREEN _NEWIMAGE(800, 600, 32)
PRINT _RESIZE ' resize only triggered if sleep statement above not REM'ed
|
|
|
|
| Exercise with picture and text |
|
Posted by: Kernelpanic - 06-13-2024, 04:16 PM - Forum: Programs
- Replies (10)
|
 |
At last a small, successful exercise (would a sub-form of exercises make sense?). A standard program with a picture on the side and a gimmick with color and font.
The program calculates the piston speed of an engine. According to Hütten, engines with a piston speed of over 21 meters per second are in danger of flying apart. The book is 40 years old, wether is that still true today? Maybe!
The picture: Two-Stroke Engine
Code: (Select All)
'Kolbengeschwindigkeit berechnen - 13. Juni 2024
'Uebung wie man Text und Bild einfuegt
Screen _NewImage(650, 420, 32)
$Color:32
Option _Explicit
Dim As Double kolbenhub, drehzahl, kolbenges
Dim As Long Bild, myFont
Dim As String Text
Bild = _LoadImage("..\..\Bilder\Zweitackter.gif") 'Siehe Hinweis unten um das Bild zu erhalten
_PutImage (470, 35), Bild 'Platzierung des Bildes. Haengt von der Fenstergroesse ab
Locate 2, 3
Print "Berechnung der Kolbengeschwindigkeit"
Locate 3, 3
Print "===================================="
Locate 5, 3
Input "Kolbenhub in cm : ", kolbenhub
Locate 6, 3
Input "Motordrehzahl bei hoechster Leistung: ", drehzahl
'Formel fuer die Kolbengeschwindigkeit - H. Huetten
kolbenges = (((2 * kolbenhub) * drehzahl) / (60 * 100))
If kolbenges <= 21 Then
Locate 8, 3
Print Using "Die Kolbengeschwindigkeit betraegt : ##.##"; kolbenges
Else
Locate 8, 3
Beep: Color Red, 0
Print Using "Die Kolbengeschwindigkeit liegt ueber 21 m/sec: ##.##"; kolbenges
Locate 9, 3
Color White, 0
Print "(Bei Dauerbelastung droht Gefahr fuer den Motor!)"
End If
Text = "Bild von A. Schierwagen, GNU-Lizens - Wikipedia"
myFont = _LoadFont("C:\Windows\Fonts\Dauphinn.ttf", 15, "")
_Font myFont
'Neue Farbe setzen, dunkelgelb
Color _RGB32(255, 165, 0), _RGB32(0, 0, 0)
'Spalte - Zeile (Umgekehrt wie bei Locate)
_PrintString (360, 340), Text
'Farbe und Schrift zuruecksetzen
Color _RGB32(255), _RGB32(0, 0, 0)
_Font 16
_FreeFont myFont
End
![[Image: Bild-mit-Text2024-06-13.jpg]](https://i.ibb.co/9yQmtTx/Bild-mit-Text2024-06-13.jpg)
It's an animated gif. Is there a way to get the animation? I couldn't find anything - or didn't understand it. 
|
|
|
|
| Breakout |
|
Posted by: luke - 06-13-2024, 12:28 PM - Forum: Games
- Replies (8)
|
 |
Nothing fancy going on here. Arrow keys to move.
Code: (Select All)
$COLOR:32
CONST BALL_RADIUS = 5
CONST PADDLE_SPAN = 25
CONST PADDLE_HEIGHT = 10
CONST PADDLE_VELOCITY = 5
CONST PADDLE_GRADIENT = 0.3
CONST BLOCK_WIDTH = 42
CONST BLOCK_HEIGHT = 10
CONST BLOCK_MARGIN = 10
CONST NUM_BLOCKS = 36
CONST SPEED_PER_LEVEL = 1.1
CONST FALSE = 0, TRUE = NOT FALSE
CONST KEY_LEFT = 19200
CONST KEY_RIGHT = 19712
TYPE block_t
x1 AS INTEGER
x2 AS INTEGER
y1 AS INTEGER
y2 AS INTEGER
alive AS INTEGER
colour AS _UNSIGNED LONG
END TYPE
DIM blocks(1 TO NUM_BLOCKS) AS block_t
DIM SHARED colours(1 TO 12) AS _UNSIGNED LONG
colours(1) = Peru
colours(2) = RazzleDazzleRose
colours(3) = Wheat
colours(4) = WildBlueYonder
colours(5) = Lavender
colours(6) = MountainMeadow
colours(7) = BurntOrange
colours(8) = PeachPuff
colours(9) = LawnGreen
colours(10) = Chestnut
colours(11) = IndianRed
colours(12) = LightGoldenRodYellow
SCREEN _NEWIMAGE(640, 480, 32)
RANDOMIZE TIMER
start:
level = 0
next_level:
level = level + 1
ball_vy = -(3 + SPEED_PER_LEVEL * level)
win_condition = FALSE
init_blocks blocks()
ball_x = _WIDTH / 2
ball_vx = INT(RND * 5)
ball_y = _HEIGHT * 0.9
paddle_x = _WIDTH / 2
paddle_y = _HEIGHT - PADDLE_HEIGHT - 10
CLS
centreprint "Level" + STR$(level)
_DISPLAY
_DELAY 2
DO
CLS , 0
'Paddle movement
IF _KEYDOWN(KEY_LEFT) THEN paddle_x = paddle_x - PADDLE_VELOCITY
IF paddle_x < PADDLE_SPAN THEN paddle_x = PADDLE_SPAN
IF _KEYDOWN(KEY_RIGHT) THEN paddle_x = paddle_x + PADDLE_VELOCITY
IF paddle_x > _WIDTH - PADDLE_SPAN THEN paddle_x = _WIDTH - PADDLE_SPAN
'Ball movement
ball_x = ball_x + ball_vx
ball_y = ball_y + ball_vy
'Draw paddle
LINE (paddle_x - PADDLE_SPAN, paddle_y)-(paddle_x + PADDLE_SPAN, paddle_y + PADDLE_HEIGHT), White, BF
'Draw ball
CIRCLE (ball_x, ball_y), BALL_RADIUS, White
'Draw blocks & block collision
win_condition = TRUE
FOR b = LBOUND(blocks) TO UBOUND(blocks)
IF NOT blocks(b).alive THEN _CONTINUE
top_bound = ball_y + BALL_RADIUS >= blocks(b).y1
bottom_bound = ball_y - BALL_RADIUS <= blocks(b).y2
left_bound = ball_x + BALL_RADIUS >= blocks(b).x1
right_bound = ball_x - BALL_RADIUS <= blocks(b).x2
IF top_bound AND left_bound AND right_bound AND bottom_bound THEN
ball_vy = -ball_vy
blocks(b).alive = FALSE
ELSE
LINE (blocks(b).x1, blocks(b).y1)-(blocks(b).x2, blocks(b).y2), blocks(b).colour, BF
win_condition = FALSE
END IF
NEXT b
'Win?
IF win_condition THEN GOTO next_level
'Boundary collision
IF ball_x - BALL_RADIUS + ball_vx <= 0 OR ball_x + BALL_RADIUS + ball_vx >= _WIDTH THEN ball_vx = -ball_vx
IF ball_y - BALL_RADIUS + ball_vy <= 0 THEN ball_vy = -ball_vy
'Paddle collision
IF ABS(ball_x - paddle_x) <= PADDLE_SPAN + BALL_RADIUS AND ball_y + BALL_RADIUS >= paddle_y THEN
ball_vy = -ball_vy
ball_vx = (ball_x - paddle_x) * PADDLE_GRADIENT
END IF
'Missed ball
IF ball_y - BALL_RADIUS >= _HEIGHT THEN
centreprint "Game Over"
_DELAY 2
GOTO start
END IF
_DISPLAY
_LIMIT 60
LOOP
PRINT "Game over"
SUB init_blocks (blocks() AS block_t)
x = BLOCK_MARGIN
y = BLOCK_MARGIN
FOR i = LBOUND(blocks) TO UBOUND(blocks)
blocks(i).alive = TRUE
IF x + BLOCK_WIDTH > _WIDTH THEN
x = BLOCK_MARGIN
y = y + BLOCK_HEIGHT + BLOCK_MARGIN
END IF
blocks(i).x1 = x
blocks(i).x2 = x + BLOCK_WIDTH
blocks(i).y1 = y
blocks(i).y2 = y + BLOCK_HEIGHT
blocks(i).colour = colours(INT(RND * UBOUND(colours)) + 1)
x = x + BLOCK_WIDTH + BLOCK_MARGIN
NEXT i
END SUB
SUB centreprint (s$)
_PRINTSTRING ((_WIDTH - _PRINTWIDTH(s$)) / 2, (_HEIGHT - _FONTHEIGHT) / 2), s$
_DISPLAY
END SUB
|
|
|
|
Can a function return a custom TYPE? |
|
Posted by: 12centuries - 06-12-2024, 10:38 PM - Forum: Help Me!
- Replies (3)
|
 |
Hello! Former PDS 7.1 developer here, and I recently stumbled on some of my old source code files while digging through an old hard drive. That led me to qb64 and eventually here!
So I decided to take a stab at completing a little text-based map scroller that I started a few decades ago, and I'm using some of the new conventions available with QB64PE.
It brings me my first question: Can a function return a custom TYPE? If so, how?
Consider the following code:
Code: (Select All)
' Split a "label:value" string in to two parts, stored as a custom TYPE
Type config_item_type
Label As String
Value As String
End Type
Dim config_item As config_item_type
line$ = "title: Main Entrance"
config_item = Split_Header_line(lines$)
' Expecting config_item.Label = "title" and config_item.Value = "Main Entrance"
Function Split_Header_Line (line$)
Dim result As config_item_type
i% = InStr(line$, ":")
If i% Then
result.Label = LCase$(Left$(line$, i%))
result.Value = LTrim$(Mid$(line$, i% + 1))
End If
Split_Header_Line = result
END FUNCTION
I get the following two errors:
Expected = similar user defined type on line 10
and
User defined types in expresssions are invalid on line 21
Is this telling me that I can't use TYPEd variables as return types for functions or am I missing something more obvious?
|
|
|
|
|
![[Image: QB-code-formatting.png]](https://i.ibb.co/wBKXGpQ/QB-code-formatting.png)
