Советы по Delphi
phonexa.com          

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


Я уже видел несколько сообщений в новостных группах, касающиеся данного вопроса. Вот код, который, по моему мнению, наиболее полно раскрывает данную тему. Совет имеет один существенный недостаток. В том виде, в каком я нашел его, отсутствует программа, осуществляющая управление данной DLL, то есть приводится реализации самого перехвата, а часть, позволяющая управлять им, к сожалению, отсутствует. Если у читателей имеется реализация программы или другой аналогичный код, поделитесь со мной, а я в свою очередь попытаюсь найти полную реализацию данного проекта. Тем не менее данный материал раскрывает технологию осуществления перехвата и может использоваться в качестве отправной точки для дальнейшего экспериментирования.

    library Sendkey;

{Данный код написан по мотивам книги "Delphi Developer's Guide"
авторов Xavier Pacheco и Steve Teixeira.}
uses SysUtils, WinTypes, WinProcs, Messages, Classes, KeyDefs;
type
{ Коды ошибок }

TSendKeyError = (sk_None, sk_FailSetHook, sk_InvalidToken, sk_UnknownError);
{ исключения } ESendKeyError = class(Exception); ESetHookError = class(ESendKeyError); EInvalidToken = class(ESendKeyError);
{ потомок TList, который знает как избавляться от своего содержания } TMessageList = class(TList) public destructor Destroy; override; end;
destructor TMessageList.Destroy;
var
i: longint; begin
{ освобождаем все записи сообщений перед тем как разрушить список } for i := 0 to Count - 1 do Dispose(PEventMsg(Items[i])); inherited Destroy; end;

var
{ глобальные переменные для DLL } MsgCount: word; MessageBuffer: TEventMsg; HookHandle: hHook; Playing: Boolean; MessageList: TMessageList; AltPressed, ControlPressed, ShiftPressed: Boolean; NextSpecialKey: TKeyString;
function MakeWord(L, H: Byte): Word;
{ макрос создает число из самого большого и самого маленького байтов }
inline(
$5A/            { pop dx } $58/            { pop ax } $8A/$E2);       { mov ah, dl }
procedure StopPlayback;
{ Снимаем перехват и наводим порядок }
begin
{ если перехват к настоящему времени активен, отключаем его } if Playing then UnhookWindowsHookEx(HookHandle); MessageList.Free; Playing := False; end;

function Play(Code: integer; wParam: word; lParam: Longint): Longint; export;
{ Это функция-оболочка возвращает JournalPlayback. Вызывается системой во время }
{ опроса аппаратных событий. Параметр Code указывает что нужно делать. }
begin
case Code of
hc_Skip: begin { hc_Skip пропускает очередное сообщение из нашего списка. Если мы } { в конце списка, это хорошо, снимаем захват JournalPlayback } { в данном месте кода. } { увеличиваем счетчик сообщений } inc(MsgCount); { проверка воспроизведения всех сообщений } if MsgCount >= MessageList.Count then StopPlayback else { копируем очередное сообщение из списка в буфер } MessageBuffer := TEventMsg(MessageList.Items[MsgCount]^); Result := 0; end;
hc_GetNext: begin { hc_GetNext нужен для заполнения wParam и lParam соответствующими } { значениями, необходимыми для воспроизведения сообщения. НЕ СНИМАЙТЕ } { захват в этом участке кода. Возвращаемая величина указывает время, } { в течение которого Windows должна воспроизвести сообщение. Мы } { возвращаем 0 для того, чтобы это было обработано немедленно. } { перемещаем сообщение в буфер для очереди сообщений } PEventMsg(lParam)^ := MessageBuffer; Result := 0 { немедленная обработка } end
else { если Code не hc_Skip или hc_GetNext, то вызываем следующий hook в цепочке } Result := CallNextHookEx(HookHandle, Code, wParam, lParam); end; end;

procedure StartPlayback;
{ Инициализируем глобальные и вешаем hook }
begin
{ захватываем из списка первое сообщение и помещаем } { в буфер, если hc_GetNext получено перед hc_Skip } MessageBuffer := TEventMsg(MessageList.Items[0]^); { инициализируем счетчик сообщений } MsgCount := 0; { инициализируем флаги клавиш Alt, Control и Shift } AltPressed := False; ControlPressed := False; ShiftPressed := False; { вешаем hook! } HookHandle := SetWindowsHookEx(wh_JournalPlayback, Play, hInstance, 0); if HookHandle = 0 then raise ESetHookError.Create('Не могу повесить hook') else Playing := True; end;

procedure MakeMessage(vKey: byte; M: word);
{ процедура создает запись TEventMsg, эмулирующую нажатие клавиши и }
{ добавляет это к списку сообщений }
var
E: PEventMsg; begin
New(E);                                 { выделяем память под запись сообщения } with E^ do begin Message := M;                         { устанавливаем поле сообщения } { больший байт ParamL является кодом vk, меньший - кодом сканирования } ParamL := MakeWord(vKey, MapVirtualKey(vKey, 0)); ParamH := 1;                          { счетчик повторов равен 1 } Time := GetTickCount;                 { устанавливаем время } end; MessageList.Add(E); end;

procedure KeyDown(vKey: byte);
{ Генерируем KeyDownMessage }
begin
{ не генерим клавишу "sys" (F10), если нажата клавиша Ctrl (одна из причуд Windows) } if (AltPressed and (not ControlPressed) and (vKey in [Ord('A')..Ord('Z')])) or (vKey = vk_Menu) then MakeMessage(vKey, wm_SysKeyDown) else MakeMessage(vKey, wm_KeyDown); end;

procedure KeyUp(vKey: byte);
{ Генерируем сообщение KeyUp }
begin
{ не генерим клавишу "sys" (F10), если нажата клавиша Ctrl (одна из причуд Windows) } if AltPressed and (not ControlPressed) and (vKey in [Ord('A')..Ord('Z')]) then MakeMessage(vKey, wm_SysKeyUp) else MakeMessage(vKey, wm_KeyUp); end;

procedure SimKeyPresses(VKeyCode: Word);
{ Данная функция имитирует нажатие клавиши, передаваемой ей в качестве параметра, }
{ учитывая текущий статус клавиш Alt, Control и Shift }
begin
{ нажимаем клавишу Alt, если выставлен соответствующий флаг } if AltPressed then KeyDown(vk_Menu); { нажимаем клавишу Control, если выставлен соответствующий флаг } if ControlPressed then KeyDown(vk_Control); { если shift не нажат, или не нажаты клавиши shif и control... } if (((Hi(VKeyCode) and 1) <> 0) and (not ControlPressed)) or ShiftPressed then KeyDown(vk_Shift);    { ...нажимаем shift } KeyDown(Lo(VKeyCode));  { нажимаем клавишу down } KeyUp(Lo(VKeyCode));    { отпускаем клавишу } { если shift нажат, или не нажаты клавиши shif и control... } if (((Hi(VKeyCode) and 1) <> 0) and (not ControlPressed)) or ShiftPressed then KeyUp(vk_Shift);      { ...отпускаем shift } { если флаг shift установлен, сбрасываем его } if ShiftPressed then begin ShiftPressed := False; end; { Отпускаем клавишу Control, и если флаг клавиши был установлен, сбрасываем его } if ControlPressed then begin KeyUp(vk_Control); ControlPressed := False; end; { Отпускаем клавишу Alt, и если флаг клавиши был установлен, сбрасываем его } if AltPressed then begin KeyUp(vk_Menu); AltPressed := False; end; end;

procedure ProcessKey(S: String);
{ Данная функция выполняет разбор каждого символа в строке для создания списка сообщений }
var
KeyCode: word; Key: byte; index: integer; Token: TKeyString; begin
index := 1; repeat case S[index] of
KeyGroupOpen : begin { Это начало специального признака! } Token := ''; inc(index); while S[index] <> KeyGroupClose do begin { добавляем к признаку до тех пор, пока не столкнемся с символом окончания признака } Token := Token + S[index]; inc(index); { убеждаемся, что признак не слишком длинный } if (Length(Token) = 7) and (S[index] <> KeyGroupClose) then raise EInvalidToken.Create('Незакрытая скобка'); end; { ищем признак в массиве, в случае удачи } { параметр Key будет содержать код vk } if not FindKeyInArray(Token, Key) then raise EInvalidToken.Create('Неверный признак'); { эмулируем последовательность нажатия клавиш } SimKeyPresses(MakeWord(Key, 0)); end;
AltKey : begin { устанавливаем флаг клавиши Alt } AltPressed := True; end;
ControlKey : begin { устанавливаем флаг клавиши Control } ControlPressed := True; end;
ShiftKey : begin { устанавливаем флаг клавиши Shift } ShiftPressed := True; end;
else begin { Была нажата клавиша с нормальным символом } { конвертируем символ в число типа word, содержащее наибольший байт } { статуса shift и наименьший байт кода vk } KeyCode := vkKeyScan(MakeWord(Byte(S[index]), 0)); { эмулируем последовательность нажатия клавиш } SimKeyPresses(KeyCode); end; end; inc(index); until index > Length(S); end;

function SendKeys(S: String): TSendKeyError; export;
{ Это первая точка входа. Базируясь на входном параметре - строке  }
{ S, данная функция создает список keyup/keydown-сообщений, вешает }
{ hook на JournalPlayback, и повторяет сообщения нажатий клавиш.   }
var
i: byte; begin
try Result := sk_None;                   { успешный прием } MessageList := TMessageList.Create;  { создаем список сообщений } ProcessKey(S);                       { создаем сообщения из строки } StartPlayback;                       { вешаем хук и воспроизводим сообщения } except { при возникновении исключения возвращаем код ошибки и наводим порядок } on E:ESendKeyError do begin MessageList.Free; if E is ESetHookError then Result := sk_FailSetHook else if E is EInvalidToken then Result := sk_InvalidToken; end else { Перехват дескрипторов всех объектов исключений гарантирует, } { что исключение не попадет в стек приложения } Result := sk_UnknownError; end; end;

exports
SendKeys index 1;
begin end
[000140]


Вот она! Работающая! С комментариями! Полная версия! Привожу код полностью. Автор 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]



Содержание раздела