syshook.pas

一套功能非常丰富的图书管理系统

{******************************************************************************}
{                                                                              }
{ 这是一个截获全局消息的组件                                                   }
{                                                                              }
{ This is a component for capturing global message                             }
{                                                                              }
{******************************************************************************}


{************************************************}
{                                                }
{ 它可以截获键盘与鼠标事件，并可以得到触发事件   }
{ 的来源句柄、来源所在的进程...以及其他一些信息  }
{                                                }
{ It can capture keyboard event and mouse event, }
{ and can capture source handle from causeing    }
{ event , process of  source...and  other        }
{ information                                    }
{                                                }
{************************************************}
unit SysHook;

interface

uses
  Windows, Messages, SysUtils, Classes,TlHelp32;

type
  {截获消息的结构 the structure of message}
  TEventMsg = ^_EventMsg;
  _EventMsg = packed record
    Message : UINT;
    ParamL : UINT;
    ParamH : UINT;
    Time : DWORD;
    Hwnd : HWND;
  end;

  TMouseButton = (mbLeft, mbRight, mbMiddle);

  TGetMessageEvent =
        procedure (Msg : TEventMsg) of object;

  TGetKeyDownMessage =
        procedure (Key : Word;Winhandle :HWND) of object;

  TGetKeyUpMessage =
        procedure (Key : Word;Winhandle :HWND) of object;

  TGetMouseDownMessage =
        procedure (Button : TMouseButton;
                   WinHandle :HWND;X, Y : integer) of object;

  TGetMouseUpMessage =
        procedure (Button : TMouseButton;
                   WinHandle :HWND;X, Y : integer) of object;

  TGetMouseMoveMessage =
        procedure (X, Y : integer) of object;

  TSysHook = class(TComponent)
  private
    FHooking: boolean;
    Handle : HHOOK;
    FOnGetMessage : TGetMessageEvent;
    FOnKeyDown: TGetKeyDownMessage;
    FOnKeyUp: TGetKeyUpMessage;
    FOnMouseDown: TGetMouseDownMessage;
    FOnMouseUp: TGetMouseupMessage;
    FOnMouseMove: TGetMouseMoveMessage;
    procedure SetHooking(const Value: boolean);
  protected
    procedure DoKeyDown(Msg : TEventMsg);dynamic;
    procedure DoKeyUp(Msg : TEventMsg);dynamic;
    procedure DoMouseDown(Msg : TEventMsg);dynamic;
    procedure DoMouseUp(Msg : TEventMsg);dynamic;
    procedure DoMouseMove(Msg : TEventMsg);dynamic;
  public
    constructor Create(AOwner : TComponent);override;
    destructor Destroy;override;
    function GetProcessInfo(AProcessID : DWORD):PProcessEntry32;
    function GetWinClassName(WinHandle : HWND):string;
    function GetProcess(WinHandle : HWND):DWORD;
    function GetInstance(WinHandle : HWND):DWORD;
  published
    property Enabled : boolean
               read FHooking write SetHooking;
    property OnGetMessage : TGetMessageEvent
               read FOnGetMessage write FOnGetMessage;
    property OnKeyDown : TGetKeyDownMessage
               read FOnKeyDown write FOnKeyDown;
    property OnKeyUp : TGetKeyUpMessage
               read FOnKeyUp write FOnKeyUp;
    property OnMouseDown : TGetMouseDownMessage
               read FOnMouseDown write FOnMouseDown;
    property OnMouseUp : TGetMouseupMessage
               read FOnMouseUp write FOnMouseUp;
    property OnMouseMove : TGetMouseMoveMessage
               read FOnMouseMove write FOnMouseMove;
  end;

procedure Register;

implementation

function Play(Code : integer;wParam, lParam : Longint):Longint;stdcall;forward;

var
  _Hook : TSysHook;

procedure Register;
begin
  RegisterComponents('Samples', [TSysHook]);
end;
{ TSysHook }

constructor TSysHook.Create(AOwner : TComponent);
begin
  inherited Create(AOwner);
  _Hook := Self;
end;

destructor TSysHook.Destroy;
begin
  Enabled := False;
  _Hook := nil;
  inherited;
end;

function Play(Code, wParam, lParam: Longint): Longint;
begin
  Result := 0;
  if (Code = HC_ACTION) or (Code =HC_SYSMODALON)or(Code=HC_SYSMODALOFF)then
  begin
    if Assigned(_Hook.FOnGetMessage) then
      _Hook.FOnGetMessage(TEventMsg(lParam));

    if TEventMsg(lParam).Message = WM_KEYDOWN then
      _Hook.DoKeyDown(TEventMsg(lParam));

    if TEventMsg(lParam).Message = WM_KEYUP then
      _Hook.DoKeyUp(TEventMsg(lParam));

    if (TEventMsg(lParam).Message = WM_LBUTTONDOWN) or
       (TEventMsg(lParam).Message = WM_RBUTTONDOWN) or
       (TEventMsg(lParam).Message = WM_MBUTTONDOWN) then
       _Hook.DoMouseDown(TEventMsg(lParam));

    if (TEventMsg(lParam).Message = WM_LBUTTONUP) or
       (TEventMsg(lParam).Message = WM_RBUTTONUP) or
       (TEventMsg(lParam).Message = WM_MBUTTONUP) then
       _Hook.DoMouseUp(TEventMsg(lParam));

    if TEventMsg(lParam).Message = WM_MOUSEMOVE then
      _Hook.DoMouseMove(TEventMsg(lParam));
  end;
 if Code < 0 then
    Result := CallNextHookEx(_Hook.Handle,Code,wParam,lParam);
end;

procedure TSysHook.DoKeyDown(Msg: TEventMsg);
var
  AKey : array [0..1] of Char;
  AState : TKeyboardState;
begin
  try
    GetKeyboardState(AState);
    ToAscii(Msg.ParamL,Msg.ParamH,AState,AKey,0);
    if Assigned(FOnKeyDown) then
      FOnKeyDown(Ord(AKey[0]),GetFocus);
  except
  end;
end;

procedure TSysHook.DoKeyUp(Msg: TEventMsg);
var
  AKey : array [0..1] of Char;
  AState : TKeyboardState;
begin
  try
    GetKeyboardState(AState);
    ToAscii(Msg.ParamL,Msg.ParamH,AState,AKey,0);
    if Assigned(FOnKeyUp) then
      FOnKeyUp(Ord(AKey[0]),GetFocus);
  except
  end;
end;

procedure TSysHook.DoMouseDown(Msg: TEventMsg);
var
  Button : TMouseButton;
begin
  Button := mbLeft;
  case Msg.Message of
    WM_LBUTTONDOWN : button := mbLeft;
    WM_RBUTTONDOWN : Button := mbRight;
    WM_MBUTTONDOWN : Button := mbMiddle;
  end;
  if Assigned(FOnMouseDown) then
    FOnMouseDown(Button,Msg.Hwnd,Msg.ParamL,Msg.ParamH);
end;

procedure TSysHook.DoMouseMove(Msg: TEventMsg);
begin
  if Assigned(FOnMouseMove) then
    FOnMouseMove(Msg.ParamL,Msg.ParamH);
end;

procedure TSysHook.DoMouseUp(Msg: TEventMsg);
var
  Button : TMouseButton;
begin
  Button := mbLeft;
  case Msg.Message of
    WM_LBUTTONUP : button := mbLeft;
    WM_RBUTTONUP : Button := mbRight;
    WM_MBUTTONUP : Button := mbMiddle;
  end;
  if Assigned(FOnMouseUp) then
    FOnMouseUp(Button,Msg.Hwnd,Msg.ParamL,Msg.ParamH);
end;

function TSysHook.GetInstance(WinHandle: HWND): DWORD;
begin
  Result := GetWindowLong(WinHandle,GWL_HINSTANCE);
end;

function TSysHook.GetProcess(WinHandle: HWND): DWORD;
var
  p : DWORD;
begin
  GetWindowThreadProcessId(WinHandle,@p);
  Result := P;
end;

function TSysHook.GetProcessInfo(AProcessID: DWORD): PProcessEntry32;
var
  Snap : THandle;
  PE : TProcessEntry32;
  PPE : PProcessEntry32;
  Found : boolean;
begin
  Snap := CreateToolHelp32SnapShot(TH32CS_SNAPPROCESS,0);
  PE.dwSize := SizeOf(PE);
  PPE := nil;
  Found := False;
  if Process32First(Snap,PE) then
  repeat
    if (PE.th32ProcessID =  AProcessID) then
      Found := True;
  until (Found = true) or (not Process32Next(Snap,PE));
  if Found then
  begin
    new(PPE);
    PPE^ := PE;
  end;
  Result := PPE;
end;

function TSysHook.GetWinClassName(WinHandle: HWND): string;
var
  ClassName : pChar;
begin
  GetMem(ClassName,256);
  GetClassName(WinHandle,ClassName,256);
  Result := string(ClassName);
end;

procedure TSysHook.SetHooking(const Value: boolean);
begin
  FHooking := Value;
  if Value then
      Handle := SetWindowsHookEx(WH_JOURNALRECORD,Play,hInstance,0)
  else
    UnHookWindowsHookEx(Handle);
end;

end.