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

Материал из DRKB

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

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.


Author: Bogachev
Source: http://delphiworld.narod.ru/
ID: 02227