program Project1;
uses
Forms,
Unit1 in '..\Hooks1\Unit1.pas' {Form1};
{$R *.RES}
begin
Application.Initialize;
Application.CreateForm(TForm1, Form1);
Application.Run;
end.
// *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* //
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.
// *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* //
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
// *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* //
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.
|
Перехват (Hook) клавиатуры (программа Sendkeys)