Установка ловушки для клавиатуры

Code:

// 1. Library Code for a Key Hook DLL

library HookLib;

uses

  madExcept,

  Windows,

  Messages,

  SysUtils;

type

  PHookRec = ^THookRec;

  THookRec = record

    AppHnd: Integer;

    MemoHnd: Integer;

  end;

var

  Hooked: Boolean;

  hKeyHook, hMemo, hMemFile, hApp: HWND;

  PHookRec1: PHookRec;

function KeyHookFunc(Code, VirtualKey, KeyStroke: Integer): LRESULT; stdcall;

var

  KeyState1: TKeyBoardState;

  AryChar: array[0..1] of Char;

  Count: Integer;

begin

  Result := 0;

  if Code = HC_NOREMOVE then Exit;

  Result := CallNextHookEx(hKeyHook, Code, VirtualKey, KeyStroke);

  {I moved the CallNextHookEx up here but if you want to block

  or change any keys then move it back down}

  if Code < 0 then

    Exit;

  if Code = HC_ACTION then

  begin

    if ((KeyStroke and (1 shl 30)) <> 0) then

      if not IsWindow(hMemo) then

      begin

       {I moved the OpenFileMapping up here so it would not be opened

       unless the app the DLL is attatched to gets some Key messages}

        hMemFile  := OpenFileMapping(FILE_MAP_WRITE, False, 'Global7v9k');

        PHookRec1 := MapViewOfFile(hMemFile, FILE_MAP_WRITE, 0, 0, 0);

        if PHookRec1 <> nil then

        begin

          hMemo := PHookRec1.MemoHnd;

          hApp  := PHookRec1.AppHnd;

        end;

      end;

    if ((KeyStroke and (1 shl 30)) <> 0) then

    begin

      GetKeyboardState(KeyState1);

      Count := ToAscii(VirtualKey, KeyStroke, KeyState1, AryChar, 0);

      if Count = 1 then

      begin

        SendMessage(hMemo, WM_CHAR, Ord(AryChar[0]), 0);

        {I included 2 ways to get the Charaters, a Memo Hnadle and

        a WM_USER+1678 message to the program}

        PostMessage(hApp, WM_USER + 1678, Ord(AryChar[0]), 0);

      end;

    end;

  end;

end;

function StartHook(MemoHandle, AppHandle: HWND): Byte; export;

begin

  Result := 0;

  if Hooked then

  begin

    Result := 1;

    Exit;

  end;

  if not IsWindow(MemoHandle) then

  begin

    Result := 4;

    Exit;

  end;

  hKeyHook := SetWindowsHookEx(WH_KEYBOARD, KeyHookFunc, hInstance, 0);

  if hKeyHook > 0 then

  begin

    {you need to use a mapped file because this DLL attatches to every app

    that gets windows messages when it's hooked, and you can't get info except

    through a Globally avaiable Mapped file}

    hMemFile := CreateFileMapping($FFFFFFFF, // $FFFFFFFF gets a page memory file

     nil,                // no security attributes

     PAGE_READWRITE,     // read/write access

     0,                  // size: high 32-bits

     SizeOf(THookRec),   // size: low 32-bits

     //SizeOf(Integer),

     'Global7v9k');    // name of map object

   PHookRec1 := MapViewOfFile(hMemFile, FILE_MAP_WRITE, 0, 0, 0);

    hMemo := MemoHandle;

    PHookRec1.MemoHnd := MemoHandle;

    hApp := AppHandle;

    PHookRec1.AppHnd := AppHandle;

    {set the Memo and App handles to the mapped file}

    Hooked := True;

  end

  else

    Result := 2;

end;

function StopHook: Boolean; export;

begin

  if PHookRec1 <> nil then

  begin

    UnmapViewOfFile(PHookRec1);

    CloseHandle(hMemFile);

    PHookRec1 := nil;

  end;

  if Hooked then

    Result := UnhookWindowsHookEx(hKeyHook)

  else

    Result := True;

  Hooked := False;

end;

procedure EntryProc(dwReason: DWORD);

begin

  if (dwReason = Dll_Process_Detach) then

  begin

    if PHookRec1 <> nil then

    begin

      UnmapViewOfFile(PHookRec1);

      CloseHandle(hMemFile);

    end;

    UnhookWindowsHookEx(hKeyHook);

  end;

end;

exports

  StartHook,

  StopHook;

begin

  PHookRec1 := nil;

  Hooked := False;

  hKeyHook := 0;

  hMemo := 0;

  DLLProc := @EntryProc;

  EntryProc(Dll_Process_Attach);

end.

Code:

unit Unit1;

interface

uses

  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,

  Dialogs, StdCtrls;

type

  TForm1 = class(TForm)

    but_StartHook: TButton;

    but_StopHook: TButton;

    label1: TLabel;

    Memo1: TMemo;

    procedure but_StartHookClick(Sender: TObject);

    procedure but_StopHookClick(Sender: TObject);

  private

    { Private declarations }

    hLib2: THandle;

    DllStr1: string;

    procedure DllMessage(var Msg: TMessage); message WM_USER + 1678;

  public

    { Public declarations }

  end;

var

  Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.DllMessage(var Msg: TMessage);

begin

  if (Msg.wParam = 8) or (Msg.wParam = 13) then Exit;

  {the 8 is the Backspace and the 13 if the Enter key, You'll need to

do some special handleing for a string}

  DllStr1 := DllStr1 + Chr(Msg.wParam);

  label1.Caption := DllStr1;

end;

procedure TForm1.but_StartHookClick(Sender: TObject);

type

  TStartHook = function(MemoHandle, AppHandle: HWND): Byte;

var

  StartHook1: TStartHook;

  SHresult: Byte;

begin

  hLib2 := LoadLibrary('HookLib.dll');

  @StartHook1 := GetProcAddress(hLib2, 'StartHook');

  if @StartHook1 = nil then Exit;

  SHresult := StartHook1(Memo1.Handle, Handle);

  if SHresult = 0 then ShowMessage('the Key Hook was Started, good');

  if SHresult = 1 then ShowMessage('the Key Hook was already Started');

  if SHresult = 2 then ShowMessage('the Key Hook can NOT be Started, bad');

  if SHresult = 4 then ShowMessage('MemoHandle is incorrect');

end;

procedure TForm1.but_StopHookClick(Sender: TObject);

type

  TStopHook = function: Boolean;

var

  StopHook1: TStopHook;

  hLib21: THandle;

begin

  @StopHook1 := GetProcAddress(hLib2, 'StopHook');

  if @StopHook1 = nil then

  begin

    ShowMessage('Stop Hook DLL Mem Addy not found');

    Exit;

  end;

  if StopHook1 then

    ShowMessage('Hook was stoped');

  FreeLibrary(hLib2);

  {for some reason in Win XP you need to call FreeLibrary twice

maybe because you get 2 functions from the DLL? ?}

  FreeLibrary(hLib2);

end;

end.