keyboardhook.pas

用DLL文件的形式挂载键盘与鼠标钩子的例子

{

 MouseHook DLL Load & TMouseHook Class Unit

 2004-09-08

 Copyright ? Thomas Yao

 // OnKeyUp does't work

}

unit KeyboardHook;

interface

uses
  Windows, Messages, Classes;

const
  DEFDLLNAME = 'keyboardhook.dll';
  MappingFileName = '57D6A971_KeyboardHookDLL_442C0DB1';
  MSGKEYDOWN: PChar = 'MSGKEYDOWN57D6A971-049B-45AF-A8CD-37E0B706E036';
  MSGKEYUP: PChar = 'MSGKEYUP442C0DB1-3198-4C2B-A718-143F6E2D1760';

type
  TMappingMem = record
    Handle: DWORD;
    MsgID: DWORD;
    KeyCode: DWORD;
  end;
  PMappingMem = ^TMappingMem;

  TEnableKeyboardHook = function(hWindow: HWND): BOOL; stdcall;

  TDisableKeyboardHook = function: BOOL; stdcall;

  TKeyDownNotify = procedure(const KeyCode: Integer) of object;

  TKeyUpNotify = procedure(const KeyCode: Integer) of object;

  TKeyboardHookBase = class
  private
    FDLLName: string;
    FDLLLoaded: BOOL;
    FListenerHandle: HWND;
    FActive: BOOL;
    hMappingFile: THandle;
    pMapMem: PMappingMem;
    procedure WndProc(var Message: TMessage);
    procedure SetDLLName(const Value: string);
  protected
    MSG_KEYDOWN: UINT;
    MSG_KEYUP: UINT;
    procedure ProcessMessage(var Message: TMessage); virtual; abstract;
  public
    constructor Create; virtual;
    destructor Destroy; override;
    function Start: BOOL; virtual;
    procedure Stop; virtual;
    property DLLLoaded: BOOL read FDLLLoaded;
    property Active: BOOL read FActive;
  published
    property DLLName: string read FDLLName write SetDLLName;
  end;

  TKeyboardHook = class(TKeyboardHookBase)
  private
    FOnKeyDown: TKeyDownNotify;
    FOnKeyUp: TKeyUpNotify;
    procedure DoKeyDown(const KeyCode: Integer);
    procedure DoKeyUp(const KeyCode: Integer);
  protected
    procedure ProcessMessage(var Message: TMessage); override;
  public

  published
    property DLLName;
    property OnKeyDown: TKeyDownNotify read FOnKeyDown write FOnKeyDown;
    property OnKeyUp: TKeyUpNotify read FOnKeyUp write FOnKeyUp;
  end;

var
  DLLLoaded: BOOL = False;

  StartKeyboardHook: TEnableKeyboardHook;
  StopKeyboardHook: TDisableKeyboardHook;

implementation

var
  DLLHandle: HMODULE;

procedure UnloadDLL;
begin
  DLLLoaded := False;

  if DLLHandle <> 0 then
  begin
    FreeLibrary(DLLHandle);
    DLLHandle := 0;
    @StartKeyboardHook := nil;
    @StopKeyboardHook := nil;
  end;
end;

function LoadDLL(const FileName: string): Integer;
begin
  Result := 0;

  if DLLLoaded then
    Exit;

  DLLHandle := LoadLibraryEx(PChar(FileName), 0, 0);
  if DLLHandle <> 0 then
  begin
    DLLLoaded := True;

    @StartKeyboardHook := GetProcAddress(DLLHandle, 'EnableKeyboardHook');
    @StopKeyboardHook := GetProcAddress(DLLHandle, 'DisableKeyboardHook');

    if (@StartKeyboardHook = nil) or (@StopKeyboardHook = nil) then
    begin
      Result := 0;
      UnloadDLL;
      Exit;
    end;

    Result := 1;
  end
  else
    MessageBox(0, PChar(DEFDLLNAME + ' library could not be loaded !'),
      'Error', MB_ICONERROR);
end;

{ TInputHook }

constructor TKeyboardHookBase.Create;
begin
  pMapMem := nil;
  hMappingFile := 0;
  FDLLName := DEFDLLNAME;
  MSG_KEYDOWN := RegisterWindowMessage(MSGKEYDOWN);
  MSG_KEYUP := RegisterWindowMessage(MSGKEYUP);
end;

destructor TKeyboardHookBase.Destroy;
begin
  Stop;
  inherited;
end;

procedure TKeyboardHookBase.WndProc(var Message: TMessage);
begin
  if pMapMem = nil then
  begin
    hMappingFile := OpenFileMapping(FILE_MAP_WRITE, False, MappingFileName);
    if hMappingFile = 0 then
      MessageBox(0, 'cannot create share memory!', 'Error', MB_OK or MB_ICONERROR);
    pMapMem := MapViewOfFile(hMappingFile, FILE_MAP_WRITE or FILE_MAP_READ, 0, 0, 0);
    if pMapMem = nil then
    begin
      CloseHandle(hMappingFile);
      MessageBox(0, 'cannot map share memory!', 'Error', MB_OK or MB_ICONERROR);
    end;
  end;
  if pMapMem = nil then
    Exit;

  if (Message.Msg = MSG_KEYDOWN) or (Message.Msg = MSG_KEYUP) then
  begin
    Message.WParam := pMapMem.KeyCode;
    ProcessMessage(Message);
  end
  else
    Message.Result := DefWindowProc(FListenerHandle, Message.Msg, Message.wParam,
      Message.lParam);
end;

function TKeyboardHookBase.Start: BOOL;
var
  hookRes: Integer;
begin
  Result := False;
  if (not FActive) and (not FDLLLoaded) then
  begin
    if FDLLName = '' then
    begin
      Result := False;
      Exit;
    end
    else
    begin
      hookRes := LoadDLL(FDLLName);
      if hookRes = 0 then
      begin
        Result := False;
        Exit;
      end
      else
      begin
        FListenerHandle := AllocateHWnd(WndProc);
        if FListenerHandle = 0 then
        begin
          Result := False;
          Exit;
        end
        else
        begin
          if StartKeyboardHook(FListenerHandle) then
          begin
            Result := True;
            FDLLLoaded := True;
            FActive := True;
          end
          else
          begin
            Result := False;
            Exit;
          end;
        end;
      end;
    end;
  end;
end;

procedure TKeyboardHookBase.Stop;
begin
  if FActive then
  begin
    if FListenerHandle <> 0 then
    begin
      pMapMem := nil;
      if hMappingFile <> 0 then
      begin
        CloseHandle(hMappingFile);
        hMappingFile := 0;
      end;
      DeallocateHWnd(FListenerHandle);
      StopKeyboardHook;
      FListenerHandle := 0;
    end;
    UnloadDLL;
    FActive := False;
    FDLLLoaded := False;
  end;
end;

procedure TKeyboardHookBase.SetDLLName(const Value: string);
begin
  if FActive then
    MessageBox(0, 'Cannot activate hook because DLL name is not set.',
      'Info', MB_OK + MB_ICONERROR)
  else
    FDLLName := Value;
end;

{ TKeyboardHook }

procedure TKeyboardHook.DoKeyDown(const KeyCode: Integer);
begin
  if Assigned(FOnKeyDown) then
    FOnKeyDown(KeyCode);
end;

procedure TKeyboardHook.DoKeyUp(const KeyCode: Integer);
begin
  if Assigned(FOnKeyUp) then
    FOnKeyUp(KeyCode);
end;

procedure TKeyboardHook.ProcessMessage(var Message: TMessage);
begin
  if Message.Msg = MSG_KEYDOWN then
  begin
    DoKeyDown(Message.WParam);
  end
  else if Message.Msg = MSG_KEYUP then
  begin
    DoKeyUp(Message.WParam);
  end;
end;

end.