delphi下支持64位的钩子实现

从delphi.about.com上找了一个钩子的实现代码，写得很不错，可惜不支持64位，后来有一个帖子里说参考classes单元改改，就自己改了一下，现在分享给大家

修改部分如下

const
{$IF Defined(CPUX86)}
  CodeBytes = 2;
{$ELSEIF Defined(CPUX64)}
  CodeBytes = 8;
{$IFEND}


type
  pObjectInstance = ^TObjectInstance;
  TObjectInstance = packed record
    Code: Byte;
    Offset: Integer;
    case Integer of
      0: (Next: pObjectInstance);
      1: (Method: THookMethod);
  end;
const
//  InstanceCount = 313; // set so that sizeof (TInstanceBlock) < PageSize
  InstanceCount = (4096 - SizeOf(Pointer) * 2 - CodeBytes) div SizeOf(TObjectInstance) - 1;
type
  pInstanceBlock = ^TInstanceBlock;
  TInstanceBlock = packed record
    Next: pInstanceBlock;
    Code: array[1..CodeBytes] of Byte;
    WndProcPtr: Pointer;
    Instances: array[0..InstanceCount] of TObjectInstance;
  end;

var
  InstBlockList: pInstanceBlock = nil;
  InstFreeList: pObjectInstance = nil;


function StdHookProc(Code: UINT; WParam: WPARAM; LParam: WPARAM): LResult; stdcall;
{$IF Defined(CPUX86)}
{ In    ECX = Address of method pointer }
{ Out   EAX = Result }
asm
        XOR     EAX,EAX
        PUSH    EAX
        PUSH    LParam
        PUSH    WParam
        PUSH    Code
        MOV     EDX,ESP
        MOV     EAX,[ECX].Longint[4]
        CALL    [ECX].Pointer
        ADD     ESP,12
        POP     EAX
end;
{$ELSEIF Defined(CPUX64)}
{ In    R11 = Address of method pointer }
{ Out   RAX = Result }
var
  HookMsg: THookMsg;
asm
        .PARAMS 2
        MOV     HookMsg.Code,Code
        MOV     HookMsg.WParam,WParam
        MOV     HookMsg.LParam,LParam
        MOV     HookMsg.Result,0
        LEA     RDX,HookMsg
        MOV     RCX,[R11].TMethod.Data
        CALL    [R11].TMethod.Code
        MOV     RAX,HookMsg.Result
end;
{$IFEND}

{ Allocate a hook method instance }

function CalcJmpOffset(Src, Dest: Pointer): Longint;
begin
  Result := IntPtr(Dest) - (IntPtr(Src) + 5);
end;

function MakeHookInstance(Method: THookMethod): Pointer;
const
  BlockCode: array[1..CodeBytes] of Byte = (
{$IF Defined(CPUX86)}
    $59,                       { POP ECX }
    $E9);                      { JMP StdWndProc }
{$ELSEIF Defined(CPUX64)}
    $41,$5b,                   { POP R11 }
    $FF,$25,$00,$00,$00,$00);  { JMP [RIP+0] }
{$IFEND}
  PageSize = 4096;
var
  Block: PInstanceBlock;
  Instance: PObjectInstance;
begin
  if InstFreeList = nil then
  begin
    Block := VirtualAlloc(nil, PageSize, MEM_COMMIT, PAGE_EXECUTE_READWRITE);
    Block^.Next := InstBlockList;
    Move(BlockCode, Block^.Code, SizeOf(BlockCode));
{$IF Defined(CPUX86)}
    Block^.WndProcPtr := Pointer(CalcJmpOffset(@Block^.Code[2], @StdHookProc));
{$ELSEIF Defined(CPUX64)}
    Block^.WndProcPtr := @StdHookProc;
{$IFEND}
    Instance := @Block^.Instances;
    repeat
      Instance^.Code := $E8;  { CALL NEAR PTR Offset }
      Instance^.Offset := CalcJmpOffset(Instance, @Block^.Code);
      Instance^.Next := InstFreeList;
      InstFreeList := Instance;
      Inc(PByte(Instance), SizeOf(TObjectInstance));
    until IntPtr(Instance) - IntPtr(Block) >= SizeOf(TInstanceBlock);
    InstBlockList := Block;
  end;
  Result := InstFreeList;
  Instance := InstFreeList;
  InstFreeList := Instance^.Next;
  Instance^.Method := Method;
end;

{ Free a hook method instance }

procedure FreeHookInstance(ObjectInstance: Pointer);
begin
  if ObjectInstance = nil then
    Exit;

  pObjectInstance(ObjectInstance)^.Next := InstFreeList;
  InstFreeList := ObjectInstance
end;

使用代码示例，这个工具支持多种钩子，我用的是键盘钩子：

procedure THookManager.CreateHook(hookMethod: THookNotify);
begin
  KeyboardHook := TKeyboardHook.Create;
  KeyboardHook.OnPreExecute := KeyboardHookPreEx;
  KeyboardHook.Active := True;
end;

procedure THookManager.KeyboardHookPreExecute(Hook: THook; var Hookmsg: THookMsg);
var
  Key: Word;
  Handled: Boolean;
begin
  Handled := false;
  Key := Hookmsg.WPARAM;
  if Hookmsg.Code = HC_ACTION then
  begin
    if (key=ord('1')) and InHotKeyState then
    begin
      //在KeyDown时发送消息，不使用keyup是因为alt等键一般被松开了
      if KeyboardHook.KeyState = ksKeyDown then
      begin
        handled := HandleNumberKey(key);
        if not handled then
          HandleKey(key); //自己的处理逻辑
      end;
      //Keyup、KeyDown都不给其他程序处理，否则可能会造成两个程序同时相应按键
      Handled := True;
    end;
  end;
  Hookmsg.Result := IfThen(Handled, 1, 0); //math单元
end;

function IsKeyPress( KeyState: TKeyBoardState; key: Byte ): Boolean;
begin
  Result := KeyState[key] shr 7 = 1;
end;

function THookManager.InHotKeyState(): Boolean;
var
  KeyState: TKeyBoardState;
  bAlt, bShift, bCtrl: Boolean;
begin
  GetKeyboardState(KeyState);
  bAlt := IsKeyPress(KeyState, VK_MENU);
  bCtrl := IsKeyPress(KeyState, VK_Control);
  bShift := IsKeyPress(KeyState, VK_Shift);
  Result := bAlt and not bCtrl and not bShift;
end;

完整代码去我的资源里下载吧，我用的是Delphi XE2(第一个支持64位的版本)

http://download.csdn.net/detail/youthon/8442961