Перехват (Hook) клавиатуры (программа Sendkeys)

Written on . Posted in [Delphi] Система. Клавиатура

SendKey - DLL-ка
Project1 - Управляющая программа

Project1.dpr

program Project1;

uses

Forms,
Unit1 in '..\Hooks1\Unit1.pas' {Form1};

{$R *.RES}

begin
Application.Initialize;
Application.CreateForm(TForm1, Form1);
Application.Run;
end.

SendKey.dpr

library SendKey;

uses

SysUtils, Classes, Windows, Messages;

const
{пользовательские сообщения}
wm_LeftShow_Event = wm_User + 133;
wm_RightShow_Event = wm_User + 134;
wm_UpShow_Event = wm_User + 135;
wm_DownShow_Event = wm_User + 136;

{handle для ловушки}
HookHandle: hHook = 0;

var
SaveExitProc : Pointer;

{собственно ловушка}
function Key_Hook(Code: integer; wParam: word; lParam: Longint): Longint;stdcall; export;
var H: HWND;
begin
{если Code>=0, то ловушка может обработать событие}
if (Code >= 0) and (lParam and $40000000 = 0)
then begin
{ищем окно по имени класса и по заголовку
(Caption формы управляющей программы должен быть равен 'XXX' !!!!)}
H := FindWindow('TForm1', 'XXX');

{это те клавиши?}
Case wParam of
VK_Left: SendMessage(H, wm_LeftShow_Event, 0, 0);
VK_Right: SendMessage(H, wm_RightShow_Event, 0, 0);
VK_Up: SendMessage(H, wm_UpShow_Event, 0, 0);
VK_Down: SendMessage(H, wm_DownShow_Event, 0, 0);
end;
{если 0, то система должна дальше обработать это событие}
{если 1 - нет}
Result:=0;
end

else if Code<0 {если Code<0, то нужно вызвать следующую ловушку}
then Result := CallNextHookEx(HookHandle,Code, wParam, lParam);
end;


{при выгрузке DLL надо снять ловушку}
procedure LocalExitProc; far;
begin
if HookHandle<>0
then begin
UnhookWindowsHookEx(HookHandle);
ExitProc := SaveExitProc;
end;
end;



exports Key_Hook;


{инициализация DLL при загрузке ее в память}
begin
{устанавливаем ловушку}
HookHandle := SetWindowsHookEx(wh_Keyboard, @Key_Hook,
hInstance, 0);
if HookHandle = 0
then MessageBox(0, 'Unable to set hook!', 'Error', mb_Ok)
else begin
SaveExitProc := ExitProc;
ExitProc := @LocalExitProc;
end;
end.

Unit1.dfm

object Form1: TForm1

Left = 200
Top = 104
Width = 544
Height = 375
Caption = 'XXX'
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = []
PixelsPerInch = 96
TextHeight = 13
object Label1: TLabel
Left = 128
Top = 68
Width = 32
Height = 13
Caption = 'Label1'
end
end

Unit1.pas

unit Unit1;

interface

uses

SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls;

{пользовательские сообщения}

const

wm_LeftShow_Event = wm_User + 133;
wm_RightShow_Event = wm_User + 134;
wm_UpShow_Event = wm_User + 135;
wm_DownShow_Event = wm_User + 136;

type
TForm1 = class(TForm)
Label1: TLabel;

procedure FormCreate(Sender: TObject);

private //Обработчики сообщений
procedure WM_LeftMSG (Var M : TMessage);
message wm_LeftShow_Event;

procedure WM_RightMSG (Var M : TMessage);
message wm_RightShow_Event;

procedure WM_UpMSG (Var M : TMessage);
message wm_UpShow_Event;

procedure WM_DownMSG (Var M : TMessage);
message wm_DownShow_Event;
end;

var
Form1: TForm1;
P : Pointer;

implementation

{$R *.DFM}

//Загрузка DLL
function Key_Hook(Code: integer; wParam: word; lParam: Longint) : Longint; stdcall; external 'SendKey' name 'Key_Hook';

procedure TForm1.WM_LefttMSG (Var M : TMessage);
begin
Label1.Caption:='Left';
end;

procedure TForm1.WM_RightMSG (Var M : TMessage);
begin
Label1.Caption:='Right';
end;

procedure TForm1.WM_UptMSG (Var M : TMessage);
begin
Label1.Caption:='Up';
end;

procedure TForm1.WM_DownMSG (Var M : TMessage);
begin
Label1.Caption:='Down';
end;


procedure TForm1.FormCreate(Sender: TObject);
begin
{если не использовать вызов процедуры из DLL в программе,
то компилятор удалит загрузку DLL из программы}
P:=@Key_Hook;
end;

end.

кондиционеры форум