Советы по 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 tryResult := 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 |
Вот она! Работающая! С комментариями! Полная версия! Привожу код полностью. Автор . Большое человеческое ему спасибо. Старую версию на всякий случай оставляю, авось пригодится.
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 |
| 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. |
