Перехват (Hook) клавиатуры (программа Sendkeys) - Полная версия
Вот она! Работающая! С комментариями! Полная версия! Привожу код полностью. Автор Bogachev. Большое человеческое ему спасибо. Старую версию на всякий случай оставляю, авось пригодится.
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. |
[000503]