Модератор: Модераторы
unit Unit1;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, FileUtil, LResources, Forms, Controls, Graphics, Dialogs,
ExtCtrls, StdCtrls, Windows;
type
{ TForm1 }
TForm1 = class(TForm)
CheckBox1: TCheckBox;
CheckBox2: TCheckBox;
CheckBox3: TCheckBox;
CheckBox4: TCheckBox;
Timer1: TTimer;
procedure Timer1Timer(Sender: TObject);
private
{ private declarations }
public
{ public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.lfm}
{ TForm1 }
procedure TForm1.Timer1Timer(Sender: TObject);
begin
//-------------------- левый шифт ----------------------
if ((Word(GetKeyState(VK_LSHIFT)) and $8000)<>0) then
CheckBox1.Checked:=True
else
CheckBox1.Checked:=False;
//-------------------- правый шифт ----------------------
if ((Word(GetKeyState(VK_RSHIFT)) and $8000)<>0) then
CheckBox2.Checked:=True
else
CheckBox2.Checked:=False;
//-------------------- любой контрл ----------------------
if ((Word(GetKeyState(VK_RCONTROL)) and $8000)<>0) or
((Word(GetKeyState(VK_LCONTROL)) and $8000)<>0) then
CheckBox3.Checked:=True
else
CheckBox3.Checked:=False;
//-------------------- ну скажем клавиша B ----------------------
if ((Word(GetKeyState(VK_B)) and $8000)<>0) then
CheckBox4.Checked:=True
else
CheckBox4.Checked:=False;
//Чтобы получить информацию о состоянии всех виртуальных клавиш,
//используйте функцию GetKeyboardState.
end;
end.
Andreich писал(а):Краткая предыстория,... с целью немного развеяться пытаюсь написать простенькую игрушку в которой реализуется управление с клавиатуры. Перемещение и перерисовка объектов осуществляется по таймеру. Нужно каким-то образом в обработчике события таймера определить нажата ли (т.е. продолжает удерживаться) некоторая кнопка. Как подобное можно реализовать?
Andreich писал(а):Краткая предыстория,... с целью немного развеяться пытаюсь написать простенькую игрушку в которой реализуется управление с клавиатуры. Перемещение и перерисовка объектов осуществляется по таймеру. Нужно каким-то образом в обработчике события таймера определить нажата ли (т.е. продолжает удерживаться) некоторая кнопка. Как подобное можно реализовать?
//
// This unit is part of the GLScene Project, http://glscene.org
//
{: GLKeyboard<p>
Provides on demand state of any key on the keyboard as well as a set of
utility functions for working with virtual keycodes.<p>
Note that windows maps the mouse buttons to virtual key codes too, and you
can use the functions/classes in this unit to check mouse buttons too.<br>
See "Virtual-Key Codes" in the Win32 programmers rйferences for a list of
key code constants (VK_* constants are declared in the "Windows" unit).<p>
<b>Historique : </b><font size=-1><ul>
<li>07/11/09 - DaStr - Improved FPC compatibility and moved to the /Source/Platform/
directory (BugtrackerID = 2893580) (thanks Predator)
<li>28/03/07 - DaStr - Renamed from Keyboard.pas (BugTracker ID = 1678646)
<li>17/03/07 - DaStr - Dropped Kylix support in favor of FPC (BugTrackerID=1681585)
<li>19/12/06 - DaS - Added additional string constants and made all
existing 'Mixed Case', not 'UPPERCASE'
KeyNameToVirtualKeyCode optimized,
Fixed comments to KeyNameToVirtualKeyCode() function
<li>17/11/03 - Egg - Fixed IsKeyDown (VK) (A. P. Mohrenweiser)
<li>09/10/00 - Egg - Fixed VirtualKeyCodeToKeyName
<li>03/08/00 - Egg - Creation, partly based Silicon Commander code
</ul></font>
}
unit GLKeyboard;
interface
{$I GLScene.inc}
uses
{$IFDEF MSWINDOWS}
Windows;
{$ELSE}
{$IFDEF FPC}
// Non-windows platforms are supported only via FPC.
lcltype, lclintf;
{$ENDIF}
{$ENDIF}
type
TVirtualKeyCode = Integer;
const
// pseudo wheel keys (we squat F23/F24), see KeyboardNotifyWheelMoved
VK_MOUSEWHEELUP = VK_F23;
VK_MOUSEWHEELDOWN = VK_F24;
{: Check if the key corresponding to the given Char is down.<p>
The character is mapped to the <i>main keyboard</i> only, and not to the
numeric keypad.<br>
The Shift/Ctrl/Alt state combinations that may be required to type the
character are ignored (ie. 'a' is equivalent to 'A', and on my french
keyboard, '5' = '(' = '[' since they all share the same physical key). }
function IsKeyDown(c : Char) : Boolean; overload;
{: Check if the given virtual key is down.<p>
This function is just a wrapper for GetAsyncKeyState. }
function IsKeyDown(vk : TVirtualKeyCode) : Boolean; overload;
{: Returns the first pressed key whose virtual key code is >= to minVkCode.<p>
If no key is pressed, the return value is -1, this function does NOT
wait for user input.<br>
If you don't care about multiple key presses, just don't use the parameter. }
function KeyPressed(minVkCode : TVirtualKeyCode = 0) : TVirtualKeyCode;
{: Converts a virtual key code to its name.<p>
The name is expressed using the locale windows options. }
function VirtualKeyCodeToKeyName(vk : TVirtualKeyCode) : String;
{: Converts a key name to its virtual key code.<p>
The comparison is **NOT** case-sensitive, if no match is found, returns -1.<p>
The name is expressed using the locale windows options, except for mouse
buttons which are translated to 'LBUTTON', 'MBUTTON' and 'RBUTTON'. }
function KeyNameToVirtualKeyCode(const keyName : String) : TVirtualKeyCode;
{: Returns the virtual keycode corresponding to the given char.<p>
The returned code is untranslated, f.i. 'a' and 'A' will give the same
result. A return value of -1 means that the characted cannot be entered
using the keyboard. }
function CharToVirtualKeyCode(c : Char) : TVirtualKeyCode;
{: Use this procedure to notify a wheel movement and have it resurfaced as key stroke.<p>
Honoured by IsKeyDown and KeyPressed }
procedure KeyboardNotifyWheelMoved(wheelDelta : Integer);
var
vLastWheelDelta : Integer;
// ---------------------------------------------------------------------
// ---------------------------------------------------------------------
// ---------------------------------------------------------------------
implementation
// ---------------------------------------------------------------------
// ---------------------------------------------------------------------
// ---------------------------------------------------------------------
uses SysUtils;
const
cLBUTTON = 'Left Mouse Button';
cMBUTTON = 'Middle Mouse Button';
cRBUTTON = 'Right Mouse Button';
cUP = 'Up';
cDOWN = 'Down';
cRIGHT = 'Right';
cLEFT = 'Left';
cPAGEUP = 'Page up';
cPAGEDOWN = 'Page down';
cHOME = 'Home';
cEND = 'End';
cMOUSEWHEELUP = 'Mouse Wheel Up';
cMOUSEWHEELDOWN = 'Mouse Wheel Down';
cPAUSE = 'Pause';
cSNAPSHOT = 'Print Screen';
cNUMLOCK = 'Num Lock';
cINSERT = 'Insert';
cDELETE = 'Delete';
cDIVIDE = 'Num /';
cLWIN = 'Left Win';
cRWIN = 'Right Win';
cAPPS = 'Application Key';
c0 = '~';
c1 = '[';
c2 = ']';
c3 = ';';
c4 = '''';
c5 = '<';
c6 = '>';
c7 = '/';
c8 = '\';
// IsKeyDown
//
function IsKeyDown(c : Char) : Boolean;
{$IFDEF MSWINDOWS}
var
vk : Integer;
begin
// '$FF' filters out translators like Shift, Ctrl, Alt
vk:=VkKeyScan(c) and $FF;
if vk<>$FF then
Result:=(GetAsyncKeyState(vk)<0)
else Result:=False;
end;
{$ELSE}
{$IFDEF FPC}
begin
c := UpperCase(c)[1];
Result := GetKeyState(Ord(c)) < 0;
end;
{$ELSE}
begin
raise Exception.Create('GLKeyboard.IsKeyDown(c : Char) not yet implemented for your platform!');
end;
{$ENDIF}
{$ENDIF}
// IsKeyDown
//
function IsKeyDown(vk : TVirtualKeyCode) : Boolean;
begin
case vk of
VK_MOUSEWHEELUP:
begin
Result := vLastWheelDelta > 0;
if Result then
vLastWheelDelta := 0;
end;
VK_MOUSEWHEELDOWN:
begin
Result := vLastWheelDelta < 0;
if Result then
vLastWheelDelta := 0;
end;
else
{$IFDEF MSWINDOWS}
Result := (GetAsyncKeyState(vk) < 0);
{$ELSE}
{$IFDEF FPC}
Result := GetKeyState(vk) < 0;
{$ELSE}
raise Exception.Create('GLKeyboard.IsKeyDown(vk : TVirtualKeyCode) not fully yet implemented for your platform!');
{$ENDIF}
{$ENDIF}
end;
end;
// KeyPressed
//
function KeyPressed(minVkCode : TVirtualKeyCode = 0) : TVirtualKeyCode;
{$IFDEF MSWINDOWS}
var
i : Integer;
buf : TKeyboardState;
begin
Assert(minVkCode>=0);
Result:=-1;
if GetKeyboardState(buf) then begin
for i:=minVkCode to High(buf) do begin
if (buf[i] and $80)<>0 then begin
Result:=i;
Exit;
end;
end;
end;
if vLastWheelDelta<>0 then begin
if vLastWheelDelta>0 then
Result:=VK_MOUSEWHEELUP
else Result:=VK_MOUSEWHEELDOWN;
vLastWheelDelta:=0;
end;
end;
{$ELSE}
begin
raise Exception.Create('GLKeyboard.KeyPressed not yet implemented for your platform!');
end;
{$ENDIF}
// VirtualKeyCodeToKeyName
//
function VirtualKeyCodeToKeyName(vk : TVirtualKeyCode) : String;
{$IFDEF MSWINDOWS}
var
nSize : Integer;
{$ENDIF}
begin
// Win32 API can't translate mouse button virtual keys to string
case vk of
VK_LBUTTON : Result:=cLBUTTON;
VK_MBUTTON : Result:=cMBUTTON;
VK_RBUTTON : Result:=cRBUTTON;
VK_UP : Result:=cUP;
VK_DOWN : Result:=cDOWN;
VK_LEFT : Result:=cLEFT;
VK_RIGHT : Result:=cRIGHT;
VK_PRIOR : Result:=cPAGEUP;
VK_NEXT : Result:=cPAGEDOWN;
VK_HOME : Result:=cHOME;
VK_END : Result:=cEND;
VK_MOUSEWHEELUP : Result:=cMOUSEWHEELUP;
VK_MOUSEWHEELDOWN : Result:=cMOUSEWHEELDOWN;
VK_PAUSE : Result := cPAUSE;
VK_SNAPSHOT : Result := cSNAPSHOT;
VK_NUMLOCK : Result := cNUMLOCK;
VK_INSERT : Result := cINSERT;
VK_DELETE : Result := cDELETE;
VK_DIVIDE : Result := cDIVIDE;
VK_LWIN : Result := cLWIN;
VK_RWIN : Result := cRWIN;
VK_APPS : Result := cAPPS;
192 : Result := c0;
219 : Result := c1;
221 : Result := c2;
186 : Result := c3;
222 : Result := c4;
188 : Result := c5;
190 : Result := c6;
191 : Result := c7;
220 : Result := c8;
else
{$IFDEF MSWINDOWS}
nSize:=32; // should be enough
SetLength(Result, nSize);
vk:=MapVirtualKey(vk, 0);
nSize:=GetKeyNameText((vk and $FF) shl 16, PChar(Result), nSize);
SetLength(Result, nSize);
{$ELSE}
raise Exception.Create('GLKeyboard.VirtualKeyCodeToKeyName not yet fully implemented for your platform!');
{$ENDIF}
end;
end;
// KeyNameToVirtualKeyCode
//
function KeyNameToVirtualKeyCode(const keyName : String) : TVirtualKeyCode;
{$IFDEF MSWINDOWS}
var
i : Integer;
begin
// ok, I admit this is plain ugly. 8)
Result:=-1;
for i:=0 to 255 do
begin
if SameText(VirtualKeyCodeToKeyName(i), keyName) then
begin
Result:=i;
Break;
end;
end;
end;
{$ELSE}
var
i : Integer;
lExceptionWasRaised: Boolean;
begin
// ok, I admit this is plain ugly. 8)
Result := -1;
lExceptionWasRaised := False;
for i:=0 to 255 do
try
if SameText(VirtualKeyCodeToKeyName(i), keyName) then
begin
Result:=i;
Exit;
end;
finally
lExceptionWasRaised := True;
// DaStr: Since VirtualKeyCodeToKeyName is not fully implemented in non-Unix
// systems, this function can thow exceptions, which we need to catch here.
end;
if (Result = -1) and lExceptionWasRaised then
raise Exception.Create('GLKeyboard.KeyNameToVirtualKeyCode not yet fully implemented for your platform or keyName wasn''t found!');
end;
{$ENDIF}
// CharToVirtualKeyCode
//
function CharToVirtualKeyCode(c : Char) : TVirtualKeyCode;
begin
{$IFDEF MSWINDOWS}
Result:=VkKeyScan(c) and $FF;
if Result=$FF then Result:=-1;
{$ELSE}
{$IFDEF FPC}
c := UpperCase(c)[1];
Result := Ord(c);
{$ELSE}
raise Exception.Create('GLKeyboard.CharToVirtualKeyCode not yet implemented for your platform!');
{$ENDIF}
{$ENDIF}
end;
// KeyboardNotifyWheelMoved
//
procedure KeyboardNotifyWheelMoved(wheelDelta : Integer);
begin
vLastWheelDelta:=wheelDelta;
end;
end.
Tango писал(а):И не работает по Linux там стоят просто заглушки для функций GetKeyState, она всегда возвращает 0.
Сейчас этот форум просматривают: нет зарегистрированных пользователей и гости: 243