Sources
Delphi Russian Knowledge Base
DRKB - это самая большая и удобная в использовании база знаний по Дельфи в рунете, составленная Виталием Невзоровым

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

01.01.2007
Автор: Bogachev

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.

https://delphiworld.narod.ru/

DelphiWorld 6.0