unit KbdStats;
interface
uses
Windows;
//////////////////////////////////////////////////////////////////////////////
// stuff
type
PKbdLlHookStruct = ^TKbdLlHookStruct;
TKbdLlHookStruct =
record
vkCode : DWORD;
scanCode : DWORD;
flags : DWORD;
time : DWORD;
dwExtraInfo: Cardinal;
// ULONG_PTR
end;
TFNLowLevelKeyboardProc =
function(nCode: Integer; wParam: WPARAM;
lParam: PKbdLlHookStruct): LRESULT
stdcall;
TFNLowLevelKeyboardMethod =
function(nCode: Integer; wParam: WPARAM;
lParam: PKbdLlHookStruct): LRESULT
stdcall of object;
//////////////////////////////////////////////////////////////////////////////
// TKeyboardStatistics
type
TKeyboardStatistics =
class
private
FHook: HHOOK;
FActive: Boolean;
FCounter: Integer;
FLowLevelKeyboardProc: TFNLowLevelKeyboardProc;
FLowLevelKeyboardMethod: TFNLowLevelKeyboardMethod;
function LowLevelKeyboardMethod(nCode: Integer; wParam: WPARAM;
lParam: PKbdLlHookStruct): LRESULT;
stdcall;
procedure SetActive(Active: Boolean);
public
constructor Create(Active: Boolean = True);
destructor Destroy;
override;
published
property Active: Boolean
read FActive
write SetActive;
property Counter: Integer
read FCounter
write FCounter;
end;
implementation
//////////////////////////////////////////////////////////////////////////////
// stuff
function MakeStdcallCallback(
const Method: TMethod): Pointer;
type
PCallbackCode = ^TCallbackCode;
TCallbackCode =
packed record
Ops1:
array [0..2]
of Longword;
Val1: Pointer;
Ops2:
array [0..1]
of Longword;
Val2: Pointer;
end;
begin
Result := VirtualAlloc(
nil, SizeOf(TCallbackCode), MEM_COMMIT,
PAGE_EXECUTE_READWRITE);
if Assigned(Result)
then
try
with PCallbackCode(Result)^
do
begin
Ops1[0] := $448B5050;
Ops1[1] := $44890824;
Ops1[2] := $058B0424;
Val1 := Addr(Method.Data);
Ops2[0] := $08244489;
Ops2[1] := $25FF9058;
Val2 := Addr(Method.Code);
end;
except
VirtualFree(Result, 0, MEM_RELEASE);
Result :=
nil;
end;
end;
procedure FreeCallback(Callback: Pointer);
begin
if Assigned(Callback)
then
VirtualFree(Callback, 0, MEM_RELEASE);
end;
//////////////////////////////////////////////////////////////////////////////
// TKeyboardStatistics
constructor TKeyboardStatistics.Create(Active: Boolean);
begin
inherited Create;
FHook := 0;
FActive := False;
FCounter := 0;
FLowLevelKeyboardMethod := LowLevelKeyboardMethod;
FLowLevelKeyboardProc := TFNLowLevelKeyboardProc(
MakeStdcallCallback(TMethod(FLowLevelKeyboardMethod)));
if not Assigned(FLowLevelKeyboardProc)
then
Fail;
SetActive(Active);
end;
destructor TKeyboardStatistics.Destroy;
begin
SetActive(False);
FCounter := 0;
if Assigned(FLowLevelKeyboardProc)
then
begin
FreeCallback(Addr(FLowLevelKeyboardProc));
FLowLevelKeyboardProc :=
nil;
end;
inherited;
end;
procedure TKeyboardStatistics.SetActive(Active: Boolean);
const
WH_KEYBOARD_LL = 13;
begin
if FActive = Active
then
Exit;
if FHook <> 0
then
if UnhookWindowsHookEx(FHook)
then
FHook := 0;
if Active
then
FHook := SetWindowsHookEx(WH_KEYBOARD_LL,
TFNHookProc(FLowLevelKeyboardProc), HInstance, 0);
FActive := FHook <> 0;
end;
function TKeyboardStatistics.LowLevelKeyboardMethod(nCode: Integer;
wParam: WPARAM; lParam: PKbdLlHookStruct): LRESULT;
const
LLKHF_EXTENDED = KF_EXTENDED
shr 8;
LLKHF_INJECTED = $00000010;
LLKHF_ALTDOWN = KF_ALTDOWN
shr 8;
LLKHF_UP = KF_UP
shr 8;
begin
if HC_ACTION = nCode
then
if Assigned(lParam)
then
if LLKHF_UP = (lParam.flags
and LLKHF_UP)
then
Inc(FCounter);
Result := CallNextHookEx(FHook, nCode, wParam, Windows.LPARAM(lParam));
end;
end.