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

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

program

Project1; uses

Forms, Unit1 in

'..Hooks1Unit1.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

.

Другое по теме:

Категории

Статьи

Советы

Copyright © 2022 - All Rights Reserved - www.delphirus.com