Советы по Delphi

         

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


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

library Sendkey;

{Данный код написан по мотивам книги "Delphi Developer's Guide"
авторов Xavier Pacheco и Steve Teixeira.}
usesSysUtils, 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)publicdestructor Destroy; override;end;
destructor TMessageList.Destroy;
var
i: longint;begin
{ освобождаем все записи сообщений перед тем как разрушить список }for i := 0 to Count - 1 doDispose(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 thenUnhookWindowsHookEx(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 thenStopPlaybackelse{ копируем очередное сообщение из списка в буфер }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 thenraise ESetHookError.Create('Не могу повесить hook')elsePlaying := True;end;

procedure MakeMessage(vKey: byte; M: word);
{ процедура создает запись TEventMsg, эмулирующую нажатие клавиши и }
{ добавляет это к списку сообщений }
var
E: PEventMsg;begin
New(E); { выделяем память под запись сообщения }with E^ do beginMessage := 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) thenMakeMessage(vKey, wm_SysKeyDown)elseMakeMessage(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')]) thenMakeMessage(vKey, wm_SysKeyUp)elseMakeMessage(vKey, wm_KeyUp);end;

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

procedure ProcessKey(S: String);
{ Данная функция выполняет разбор каждого символа в строке для создания списка сообщений }
var
KeyCode: word;Key: byte;index: integer;Token: TKeyString;begin
index := 1;repeatcase 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) thenraise EInvalidToken.Create('Незакрытая скобка');end;{ ищем признак в массиве, в случае удачи }{ параметр Key будет содержать код vk }if not FindKeyInArray(Token, Key) thenraise 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 beginMessageList.Free;if E is ESetHookError thenResult := sk_FailSetHookelse if E is EInvalidToken thenResult := sk_InvalidToken;endelse{ Перехват дескрипторов всех объектов исключений гарантирует, }{ что исключение не попадет в стек приложения }Result := sk_UnknownError;end;end;

exports
SendKeys index 1;
begin end
[000140]


Вот она! Работающая! С комментариями! Полная версия! Привожу код полностью. Автор . Большое человеческое ему спасибо. Старую версию на всякий случай оставляю, авось пригодится.

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 ofVK_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<>0then beginUnhookWindowsHookEx(HookHandle);ExitProc := SaveExitProc;end;end;

exports Key_Hook;

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


/p> Unit1.dfm

object Form1: TForm1
Left = 200Top = 104Width = 544Height = 375Caption = 'XXX'Font.Charset = DEFAULT_CHARSETFont.Color = clWindowTextFont.Height = -11Font.Name = 'MS Sans Serif'Font.Style = []PixelsPerInch = 96TextHeight = 13object Label1: TLabelLeft = 128Top = 68Width = 32Height = 13Caption = 'Label1'endend
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]


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