本程序来自EurekaLog for Delphi中的EHook.pas,
经过修改后可以单独运行.
本单元实现了两种API Hook技术.
一是采用了更改各个模块中函数入口指针,实现各模块调用API时被 Hook.优点是可以选择性的对某个模块(OCX,DLL..)访问
某个API时被hook.
二是采用了所有模块都被Hook,通过修改API函数第一条指令为跳转到用户API,备份原API内容.用户可以在自己定义的API上调用原来的API.
本单元还实现了UnHook.
是一个较完整的API Hook 库程序
有兴趣的朋友可以将这个API Hook Lib扩展到对其他进程的API Hook.
本文末尾将介绍两种Hook技术的使用方法.


EHookLib.pas:

代码:

{************************************************}
{                                                }
{               EurekaLog v 6.x                  }
{              Hook Unit - EHook                 }
{                                                }
{  Copyright (c) 2001 - 2007 by Fabio Dell'Aria  }
{                                                }
{************************************************}

unit EHookLIB;

//{$I Exceptions.inc}

interface

uses Windows; 

type
  THandle = Cardinal;
  PPointer = ^Pointer;
  PShortInt = ^ShortInt;

function HookProcedureEx(ProcAddr, NewProc: Pointer; ProcName: string): Pointer;
function UnhookProcedure(ProcAddr: Pointer): Boolean;

function HookDllProcedureEx(ImportModule, ExportModule, ProcName: string;
  NewProc: Pointer): Pointer;
function TryHookDllProcedureEx(ImportModules: array of string;
  ExportModule, ProcName: string; NewProc: Pointer;
  var CallProc: Pointer; CanFail: Boolean): Boolean;
function TryHookProcedureEx(ExportModule, ProcName: string; NewProc: Pointer;
  var CallProc: Pointer): Boolean;

function HookVirtualMethod(AClass: TClass; Index: Integer; Method: Pointer): Pointer;
function UnhookVirtualMethod(AClass: TClass; Index: Integer): Boolean;

procedure JumpToMem(Addr, Jump: Pointer);

function GetFunctionSize(Addr, MaxSize: DWord): DWord;
function GetAsmSize(Start: Pointer; var Size: Byte): Boolean;

var
  CriticalError: procedure (const Section: string) = nil;

implementation

uses Classes, SysUtils;

const
  EProcNullStr = 'Cannot hook a null procedure ("%s").';
  ESharedAreaStr = 'Cannot hook the module "%s" located into the shared-area.';
  EHookingErrorStr = 'Cannot hook the procedure "%s".';

  SharedMem = $7FFFFFFF; // Don't use major value because Delphi3 don't support it.

  ModRmMod = $C0; // XX??????
  ModRmRM = $07; //  ?????XXX

  OperSizeOver = $66; // Change the operand size from 32 to 16/8 bits.
  AddrSizeOver = $67; // Change the address size from 32 to 16/8 bits.

  OpCodePrefixes: set of Byte =
    [$F0, $F2, $F3, $2E, $36, $3E, $26, $64, $65, OperSizeOver, AddrSizeOver];

  OpCodeShortJump: set of Byte = [$70..$7F, $E0..$E3, $EB]; // 1 OpCode byte

  OpCodeReturn: set of Byte = [$C2, $C3..$CA, $CB]; // "Return" first byte OpCodes

  OpCodeLongJump1Byte: set of Byte = [$E8..$E9]; // 1 OpCode byte

  OpCodeLongJump2Bytes: set of Byte = [$80..$8F]; // 2 OpCode bytes, 1th = $0F

  AsmConst: array [0..255] of Byte = ($EE, $EE, $EE, $EE, $F1, $0B, $00, $00,
    $0E, $0E, $FE, $FE, $F1, $EB, $00, $FF, $EE, $EE, $EE, $EE, $E1, $EB, $E0,
    $E0, $EE, $FE, $FE, $FE, $F1, $FB, $F0, $F0, $EE, $EE, $EE, $EE, $F1, $FB,
    $FF, $F0, $EE, $EE, $EE, $EE, $E1, $EB, $EF, $E0, $0E, $0E, $0E, $0E, $01,
    $0B, $FF, $F0, $FE, $FE, $FE, $FE, $F1, $FB, $FF, $F0, $E0, $E0, $E0, $E0,
    $E0, $E0, $E0, $E0, $E0, $E0, $E0, $E0, $E0, $E0, $E0, $E0, $E0, $E0, $E0,
    $E0, $E0, $E0, $E0, $E0, $E0, $E0, $E0, $E0, $E0, $E0, $E0, $E0, $E0, $E0,
    $EE, $EE, $EF, $EF, $EF, $EF, $EB, $EE, $E1, $EE, $F0, $F0, $E0, $E0, $E1,
    $E1, $E1, $E1, $E1, $E1, $E1, $01, $F1, $F1, $F1, $F1, $F1, $F1, $E1, $E1,
    $BE, $BE, $BE, $BE, $BE, $BE, $BE, $BE, $BE, $BE, $BE, $BE, $BE, $BE, $BE,
    $BE, $E0, $E0, $E0, $E0, $E0, $E0, $E0, $E0, $E0, $E0, $ED, $E0, $E0, $E0,
    $E0, $E0, $04, $04, $04, $E4, $E0, $E0, $E0, $E0, $01, $0B, $00, $E0, $E0,
    $E0, $E0, $E0, $E1, $E1, $E1, $E1, $E1, $E1, $E1, $E1, $FB, $FB, $EB, $EB,
    $EB, $EB, $EB, $EB, $EE, $EE, $E2, $E0, $EE, $EE, $EE, $EE, $03, $00, $02,
    $00, $00, $01, $00, $00, $FE, $EE, $EE, $EE, $E1, $E1, $F0, $E0, $EE, $EE,
    $EE, $EE, $EE, $EE, $EE, $EE, $E1, $E1, $E1, $E1, $E1, $E1, $F1, $E1, $EB,
    $EB, $ED, $E1, $E0, $E0, $E0, $E0, $FF, $E0, $EF, $EF, $E0, $E0, $EE, $EE,
    $E0, $E0, $E0, $E0, $E0, $E0, $EE, $FE);

type
  EHookError = class(Exception);
  EProcNull = class(EHookError);
  EHookingError = class(EHookError);
  ESharedArea = class(EHookError);

  EIgnoreException = class(Exception);
  TProc = procedure;

  TRedirectOpCodes = packed record
    JMPOpCode: Byte;
    JMPDistance: DWord;
  end;

  TPrefixes = set of Byte;

  THookedProcedure = record
    OriginalProc, HookedBlockPt: Pointer;
    HookedBlockSize: DWord;
    POriginalAsmPt: Pointer;
    POriginalAsmSize: DWord;
  end;
  PHookedProcedure = ^ THookedProcedure;

  PSaveDLLProc = ^TSaveDLLProc;
  TSaveDLLProc = packed record
    HookModule: THandle;
    ExportModule: string;
    OldProc, NewProc: Pointer;
  end;

  THookedData = packed record
    ClassType: TClass;
    OriginalMethod: Pointer;
    Index: Integer;
  end;
  PHookedData = ^THookedData;

  PWin9xDebugThunk = ^TWin9xDebugThunk;
  TWin9xDebugThunk = packed record
    PUSH: Byte;    // PUSH instruction opcode ($68)
    Addr: Pointer; // The actual address of the DLL routine
    JMP: Byte;     // JMP instruction opcode ($E9)
    Rel: Integer;  // Relative displacement (a Kernel32 address)
  end;

  IMAGE_IMPORT_DESCRIPTOR = packed record
    UnUsed: array [0..11] of Byte;
    Name: DWord;
    FirstThunk: DWord;  // RVA to IAT
  end;
  PImageImportDescriptor = ^IMAGE_IMPORT_DESCRIPTOR;

  IMAGE_THUNK_DATA = packed record
    Function_: DWord; // PDWord
  end;
  PImageThunkData = ^IMAGE_THUNK_DATA;

  PImageDosHeader = ^TImageDosHeader;
  TImageDosHeader = packed record    // DOS .EXE header
      e_magic: Word;                 // Magic number
      UnUsed: array [0..57] of Byte;
      _lfanew: LongInt;              // File address of new exe header
  end;

  THookedMethodsList = class(TList)
  private
    FLock: TRTLCriticalSection;
    function GetItem(Index: Integer): PHookedData;
  protected
  public
    constructor Create;
    destructor Destroy; override;
    procedure Lock;
    procedure Unlock;
    procedure Delete(Index: Integer);
    property Items[Index: Integer]: PHookedData read GetItem; default;
  end;

const
  TRedirectOpCodesSize = SizeOf(TRedirectOpCodes);

var
  HookedProcedures, DllList: TList;
  HookedMethodsList: THookedMethodsList;

//------------------------------------------------------------------------------

{ THookedMethods }

constructor THookedMethodsList.Create;
begin
  inherited;
  InitializeCriticalSection(FLock);
end;

function THookedMethodsList.GetItem(Index: Integer): PHookedData;
begin
  Result := PHookedData(TList(Self).Items[Index]);
end;

procedure THookedMethodsList.Lock;
begin
  EnterCriticalSection(FLock);
end;

procedure THookedMethodsList.Unlock;
begin
  LeaveCriticalSection(FLock);
end;

procedure THookedMethodsList.Delete(Index: Integer);
var
  Data: PHookedData;
  Ptr: Pointer;
begin
  Ptr := Items[Index];
  Data := PHookedData(Ptr);
  Dispose(Data);
  inherited;
end;

destructor THookedMethodsList.Destroy;
var
  I: Integer;
begin
  Lock;
  try
    for I := 0 to HookedMethodsList.Count - 1 do
      UnhookVirtualMethod(HookedMethodsList[0]^.ClassType, HookedMethodsList[0]^.Index);
  finally
    Unlock;
  end;
  DeleteCriticalSection(FLock);
  inherited;
end;

//------------------------------------------------------------------------------

function GetReadableSize(Address, Size: DWord): DWord;
const
  ReadAttributes = [PAGE_READONLY, PAGE_READWRITE, PAGE_WRITECOPY, PAGE_EXECUTE,
    PAGE_EXECUTE_READ, PAGE_EXECUTE_READWRITE, PAGE_EXECUTE_WRITECOPY];
var
  MemInfo: TMemoryBasicInformation;
  Tmp: DWord;
begin
  Result := 0;
  if (VirtualQuery(Pointer(Address), MemInfo, SizeOf(MemInfo)) = SizeOf(MemInfo)) and
    (MemInfo.State = MEM_COMMIT) and (MemInfo.Protect in ReadAttributes) then
  begin
    Result := (MemInfo.RegionSize - (Address - DWord(MemInfo.BaseAddress)));
    if (Result < Size) then
    begin
      repeat
        Tmp := GetReadableSize((DWord(MemInfo.BaseAddress) + MemInfo.RegionSize), (Size - Result));
        if (Tmp > 0) then Inc(Result, Tmp)
        else Result := 0;
      until (Result >= Size) or (Tmp = 0);
    end;
  end;
end;

function IsValidBlockAddr(Address, Size: DWord): Boolean;
begin
  Result := (GetReadableSize(Address, Size) >= Size);
end;

function ConvertAddress(Addr: DWord): DWord;
type
  TJMPCode = packed record
    JMPOpCode: Word;
    JMPPtr: PDWord;
    MOVOpCode: Word;
  end;
  PJMPCode = ^TJMPCode;
var
  JMP: PJMPCode;
begin
  Result := Addr;
  if (IsValidBlockAddr(Addr, 8)) then
  begin
    JMP := PJMPCode(Addr);
    if (JMP^.JMPOpCode = $25FF) and (IsValidBlockAddr(DWord(JMP^.JMPPtr), 4)) then
      Result := JMP^.JMPPtr^;
  end;
end;

//------------------------------------------------------------------------------

function GetVirtualMethod(AClass: TClass; const Index: Integer): Pointer;
begin
  Result := PPointer(Integer(AClass) + (Index * 4))^
end;

procedure SetVirtualMethod(AClass: TClass; Index: Integer; Method: Pointer);
var
  PatchAddress: PPointer;
  OldProtectionCode: DWord;
begin
  PatchAddress := PPointer(Integer(AClass) + (Index * 4));
  if (FindHInstance(PatchAddress) = 0) then Exit; // Check for unloaded module...
  VirtualProtect(PatchAddress, 4, PAGE_EXECUTE_READWRITE, @OldProtectionCode);
  PatchAddress^ := Method;
  VirtualProtect(PatchAddress, 4, OldProtectionCode, @OldProtectionCode);
  FlushInstructionCache(GetCurrentProcess, PatchAddress, 4);
end;

function HookVirtualMethod(AClass: TClass; Index: Integer; Method: Pointer): Pointer;
var
  HData: PHookedData;
  n: Integer;
begin
  Result := nil;
  if (Assigned(HookedMethodsList)) then
  begin
    HookedMethodsList.Lock;
    try
      Result := GetVirtualMethod(AClass, Index);
      if (Result = Method) then
      begin // Just hooked...
        for n := 0 to (HookedMethodsList.Count - 1) do
        begin
          if ((HookedMethodsList[n]^.ClassType = AClass) and
          (HookedMethodsList[n]^.Index = Index)) then
          begin
            Result := HookedMethodsList[n]^.OriginalMethod;
            Break;
          end;
        end;
      end
      else
      begin // First hook...
        SetVirtualMethod(AClass, Index, Method);
        New(HData);
        HData^.ClassType := AClass;
        HData^.OriginalMethod := Result;
        HData^.Index := Index;
        HookedMethodsList.Add(HData);
      end;
    finally
      HookedMethodsList.Unlock;
    end;
  end;
end;

function UnhookVirtualMethod(AClass: TClass; Index: Integer): Boolean;
var
  n: Integer;
begin
  Result := False;
  if (Assigned(HookedMethodsList)) then
  begin
    HookedMethodsList.Lock;
    try
      for n := 0 to (HookedMethodsList.Count - 1) do
      begin
        if ((HookedMethodsList[n]^.ClassType = AClass) and
        (HookedMethodsList[n]^.Index = Index)) then
        begin
          SetVirtualMethod(AClass, Index, HookedMethodsList[n]^.OriginalMethod);
          HookedMethodsList.Delete(n);
          Result := True;
          Break;
        end;
      end;
    finally
      HookedMethodsList.Unlock;
    end;
  end;
end;

//------------------------------------------------------------------------------

procedure WriteMem(Addr: Pointer; const Data; Size: DWord);
var
  OldProtectionCode: DWord;
begin
  VirtualProtect(Addr, Size, PAGE_EXECUTE_READWRITE, @OldProtectionCode);
  Move(Data, Addr^, Size);
  VirtualProtect(Addr, Size, oldProtectionCode, @OldProtectionCode);
  FlushInstructionCache(GetCurrentProcess, Addr, Size);
end;

procedure JumpToMem(Addr, Jump: Pointer);
var
  JumpOpCode: TRedirectOpCodes;
begin
  JumpOpCode.JMPOpCode := $E9; // JMP OpCode
  JumpOpCode.JMPDistance := (DWord(Jump) - DWord(Addr) - 5); // JMP Distance
  WriteMem(Addr, JumpOpCode, TRedirectOpCodesSize);
end;

function ModuleFileName(HModule: THandle): string;
var
  Buff: array[0..MAX_PATH - 1] of Char;
begin
  GetModuleFileName(HModule, Buff, SizeOf(Buff));
  Result := Buff;
end;

function ModRMByte(Prefixes: TPrefixes; OpCodeSize, OpCode, ModRM, SID: Byte): Byte;
var
  RmMod, RmRM: Byte;

  function AddrSize: Byte;
  begin
    Result := 4;
    if (OperSizeOver in Prefixes) then Dec(Result, 2);
  end;

  function SIDSize: Byte;
  begin
    Result := 1;
    if (SID and $07 = $05) then Inc(Result, 4);
  end;

begin
  Result := 0;
  RmMod := (ModRM and ModRmMod) shr 6;
  RmRM := (ModRM and ModRmRM);
  if (not (AddrSizeOver in Prefixes)) then
    case rmMod of // 32 bit mode...
      0: begin
          Result := 0;
          if (RmRM = 4) then Inc(Result, SIDSize)
          else
            if (RmRM = 5) then Inc(Result, 4);
        end;
      1: begin
          Result := 1;
          if (RmRM = 4) then Inc(Result);
        end;
      2: begin
          Result := 4;
          if (RmRM = 4) then Inc(Result);
        end;
      3: Result := 0;
    end
  else
    case rmMod of // 16 bit mode...
      0: begin
          Result := 0;
          if (RmRM = 6) then Inc(Result, 2);
        end;
      1: Result := 1;
      2: Result := 2;
      3: Result := 0;
    end;

  if (opCodeSize = 1) then // OpCode extensions...
  begin
    if (OpCode in [$6B, $80, $82, $83, $C0, $C1, $C6]) then Inc(Result)
    else
      if (OpCode in [$69, $81, $C7]) then Inc(Result, AddrSize)
      else
        if (OpCode = $F6) and (ModRM and $38 = 0) then Inc(Result)
        else
          if (OpCode = $F7) and (ModRM and $38 = 0) then Inc(Result, AddrSize);
  end
  else
    if (OpCode in [$70, $71, $72, $73, $A4, $AC, $BA, $C2, $C4, $C5, $C6]) then Inc(Result);
end;

function GetAsmSize(Start: Pointer; var Size: Byte): Boolean;
var
  OpCode, OpCodeSize, OpCodeType, Mask, Shift, ModRM, PrefixesSize: Byte;
  Ptr: PByte;
  Prefixes: TPrefixes;
begin
  Size := 1;
  Prefixes := [];
  Ptr := Start;
  repeat
    OpCode := Ptr^;
    if (OpCode in [AddrSizeOver, OperSizeOver]) then Prefixes := Prefixes + [OpCode];
    Inc(Ptr);
  until (not (OpCode in OpCodePrefixes));
  PrefixesSize := (DWord(Ptr) - DWord(Start) - 1);
  if (OpCode = $0F) then
  begin
    OpCodeSize := 2;
    OpCode := Ptr^;
    Inc(Ptr);
    Mask := $F0;
    Shift := 4;
  end
  else
  begin
    OpCodeSize := 1;
    Mask := $0F;
    Shift := 0;
  end;
  OpCodeType := ((AsmConst[OpCode] and Mask) shr Shift);
  Result := (OpCodeType <> $0F);
  if (Result) then
  begin
    if (OpCodeType < $0E) then
    begin
      Size := (OpCodeType + OpCodeSize);
      if (Size > OpCodeSize + 6) then
      begin
        Dec(Size, 7);
        if (OperSizeOver in Prefixes) then Dec(Size, 2);
      end;
    end
    else
    begin
      ModRM := Ptr^;
      Inc(Ptr);
      Size := (ModRMByte(Prefixes, OpCodeSize, OpCode, ModRM, Ptr^) + OpCodeSize + 1);
    end;
    Inc(Size, PrefixesSize);
  end;
end;

function GetFunctionSize(Addr, MaxSize: DWord): DWord;
var
  AsmSize: DWord;
  OpSize, OpCode: Byte;
  Pt, PtEnd: PChar;
begin
  Result := 1;

  if (MaxSize = 0) then
  begin
    Result := 0;
    Exit;
  end;

  try
    Pt := PChar(Addr);
    PtEnd := PChar(Pt + MaxSize - 1);
    AsmSize := 0;
    while (Pt <= PtEnd) do
    begin
      if (GetAsmSize(Pt, OpSize)) then
      begin
        // Skip the prefixes OpCodes...
        while ((PByte(Pt)^ in OpCodePrefixes) and (Pt <= PtEnd)) do Inc(Pt);

        OpCode := PByte(Pt)^;
        if (OpCode in OpCodeReturn) then
        begin
          Result := (AsmSize + OpSize);
          Exit;
        end;
      end
      else OpSize := 1;
      Inc(AsmSize, OpSize);
      Inc(Pt, OpSize);
    end;
  except
    Result := 0;
  end;
end;

function CalculateRelocatedAsmSize(Addr: Pointer; Size: Word): DWord;
var
  AsmSize: DWord;
  OpSize, OpCode: Byte;
  Pt, PtStart, PtEnd, JmpTo: PChar;
  Delta: Integer;
begin
  Pt := PChar(Addr);
  PtStart := Pt;
  PtEnd := PChar(Pt + Size - 1);
  Result := Size;
  AsmSize := 0;
  while (AsmSize < Size) do
  begin
    if (GetAsmSize(Pt, OpSize)) then
    begin
      // Skip the prefixes OpCodes...
      while ((PByte(Pt)^ in OpCodePrefixes) and (Pt <= PtEnd)) do Inc(Pt);

      OpCode := PByte(Pt)^;
      if (OpCode in OpCodeShortJump) then
      begin
        Delta := PShortInt(Pt + 1)^;
        JmpTo := (Pt + 2 + Delta);
        if ((JmpTo < PtStart) or (JmpTo > PtEnd + 1)) then Inc(Result, 5);
      end;
    end
    else OpSize := 1;
    Inc(AsmSize, OpSize);
    Inc(Pt, OpSize);
  end;
end;

procedure RelocateMemory(NewAddr, OldAddr: Pointer; Size: DWord);
var
  AsmSize: DWord;
  OpSize, OpCode, OpBytes: Byte;
  OldPt, Pt, PtStart, PtEnd, JmpTo, ShortJumpsPt: PChar;
  NewDistance, Distance, Delta: Integer;
begin
  OldPt := OldAddr;
  Pt := PChar(NewAddr);
  PtStart := Pt;
  PtEnd := PChar(Pt + Size - 1);
  ShortJumpsPt := (Pt + Size + SizeOf(TRedirectOpCodes));
  AsmSize := 0;
  while (AsmSize < Size) do
  begin
    if (GetAsmSize(Pt, OpSize)) then
    begin
      // Skip the prefixes OpCodes...
      while ((PByte(Pt)^ in OpCodePrefixes) and (Pt <= PtEnd)) do Inc(Pt);

      // Check for 2 bytes OpCode instructions...
      OpCode := PByte(Pt)^;
      if (OpCode = $0F) then // 2 bytes OpCode size
      begin
        Inc(Pt);
        OpCode := PByte(Pt)^;
        Dec(OpSize);
        OpBytes := 2;
      end
      else OpBytes := 1;

      // Search for relative Jump/Call instructions...
      if ((OpBytes = 1) and (OpCode in OpCodeShortJump)) then
      begin
        Distance := PShortInt(Pt + 1)^;
        JmpTo := (Pt + 2 + Distance);

        // Check if need relocation...
        if (JmpTo < PtStart) or (JmpTo > (PtEnd + 1)) then
        begin
          JmpTo := (OldPt + Integer(AsmSize) + OpSize + Distance);
          JumpToMem(ShortJumpsPt, JmpTo);
          Distance := (ShortJumpsPt - (Pt + 2));
          WriteMem((Pt + 1), Distance, 1);
          Inc(ShortJumpsPt, SizeOf(TRedirectOpCodes));
        end;
      end
      else
        if ((OpBytes = 1) and (OpCode in OpCodeLongJump1Byte)) or
          ((OpBytes = 2) and (OpCode in OpCodeLongJump2Bytes)) then
        begin
          Distance := PInteger(Pt + 1)^;
          JmpTo := (Pt + 5 + Distance);

          // Check if need relocation...
          if (JmpTo < PtStart) or (JmpTo > (PtEnd + 1)) then
          begin
            Delta := (OldPt + Integer(AsmSize) - Pt + (OpBytes - 1));
            NewDistance := (Distance + Delta);
            WriteMem(Pt + 1, NewDistance, 4);
          end;
        end;
    end
    else OpSize := 1;
    Inc(AsmSize, OpSize);
    Inc(Pt, OpSize);
  end;
end;

function HookProcedure(ProcAddr, NewProc: Pointer): Pointer;
var
  PProc, Pt, PAsm: PChar;
  AsmSize, FullAsmSize, OldProtectionCode: DWord;
  OpSize: Byte;
  n: Integer;
  PHookedBlock: PHookedProcedure;
begin
  for n := 0 to HookedProcedures.Count - 1 do
  begin
    PHookedBlock := PHookedProcedure(HookedProcedures[n]);
    if (ProcAddr = PHookedBlock^.OriginalProc) then
    begin
      Result := PHookedBlock^.HookedBlockPt;
      Exit;
    end;
  end;

  PProc := ProcAddr;
  Pt := PProc;
  AsmSize := 0;
  repeat
    if (not (GetAsmSize(Pt, OpSize))) then OpSize := 1;
    Inc(AsmSize, OpSize);
    Inc(Pt, OpSize);
  until (AsmSize >= 5);
  FullAsmSize := (CalculateRelocatedAsmSize(PProc, AsmSize) + SizeOf(TRedirectOpCodes));
  GetMem(PAsm, FullAsmSize);

  // Save hooked data...
  New(PHookedBlock);
  PHookedBlock^.OriginalProc := ProcAddr;
  PHookedBlock^.HookedBlockPt := PAsm;
  PHookedBlock^.HookedBlockSize := FullAsmSize;
  PHookedBlock^.POriginalAsmSize := AsmSize;
  GetMem(PHookedBlock^.POriginalAsmPt, AsmSize);
  Move(PProc^, PHookedBlock^.POriginalAsmPt^, AsmSize);
  HookedProcedures.Add(PHookedBlock);

  // Transform this data-block into executable code-block.
  VirtualProtect(PAsm, FullAsmSize, PAGE_EXECUTE_READWRITE, @OldProtectionCode);

  // Copy first ASM instructions from Procedure to Hook block...
  Move(PProc^, PAsm^, AsmSize);

  RelocateMemory(PAsm, PProc, AsmSize);

  JumpToMem((PAsm + AsmSize), (PProc + AsmSize)); // JMP from Hook block to Procedure...
  JumpToMem(PProc, NewProc); // JMP from Procedure to Hook block...

  Result := PAsm;
end;

function HookProcedureEx(ProcAddr, NewProc: Pointer; ProcName: string): Pointer;
begin
  ProcAddr := Pointer(ConvertAddress(DWord(ProcAddr)));
  NewProc := Pointer(ConvertAddress(DWord(NewProc)));

  if (ProcAddr = nil) then
    raise EProcNull.CreateFmt(EProcNullStr, [ProcName])
  else
    if (DWord(ProcAddr) > SharedMem) and // Shared Area...
      (Win32Platform <> VER_PLATFORM_WIN32_NT) then // Win9X/ME ...
      raise ESharedArea.CreateFmt(ESharedAreaStr,
        [ModuleFileName(FindHInstance(ProcAddr))]);

  try
    Result := HookProcedure(ProcAddr, NewProc);
  except
    raise EHookingError.CreateFmt(EHookingErrorStr, [ProcName]);
  end;
end;

function UnhookProcedure(ProcAddr: Pointer): Boolean;
var
  n: Integer;
  PHookedBlock: PHookedProcedure;
begin
  Result := False;
  n := 0;
  while (n <= HookedProcedures.Count - 1) do
  begin
    PHookedBlock := PHookedProcedure(HookedProcedures[n]);
    if (ProcAddr = PHookedBlock^.OriginalProc) then
    begin
      WriteMem(PHookedBlock^.OriginalProc, PHookedBlock^.POriginalAsmPt^, PHookedBlock^.POriginalAsmSize);
      FreeMem(PHookedBlock^.POriginalAsmPt, PHookedBlock^.POriginalAsmSize);
      FreeMem(PHookedBlock^.HookedBlockPt, PHookedBlock^.HookedBlockSize);
      FreeMem(PHookedBlock, SizeOf(THookedProcedure));
      HookedProcedures.Delete(n);
      Result := True;
    end;
    Inc(n);
  end;
end;

function HookDllProcedure(ImportModule: THandle; ExportModule: string; OldProc, NewProc: Pointer;
  ProcName: string; CanFail, Unhook: Boolean): Pointer;
var
  FromProcDebugThunk, ImportThunk: PWin9xDebugThunk;
  IsThunked, FoundProc: Boolean;
  NtHeader: PImageNtHeaders;
  ImportDir: TImageDataDirectory;
  ImportDesc: PImageImportDescriptor;
  CurrName: PChar;
  ImportEntry: PImageThunkData;
  Base: Pointer;
  SaveDLLProc: PSaveDLLProc;

  function IsWin9xDebugThunk(P: Pointer): Boolean;
  begin
    with PWin9xDebugThunk(P)^ do
      Result := (PUSH = $68) and (JMP = $E9);
  end;

  // Mapped or loaded image related functions
  function PeMapImgNtHeaders(const BaseAddress: Pointer): PImageNtHeaders;
  begin
    Result := nil;
    if (not IsValidBlockAddr(DWord(BaseAddress), SizeOf(TImageDosHeader))) then Exit;

    if (PImageDosHeader(BaseAddress)^.e_magic <> IMAGE_DOS_SIGNATURE) or
      (PImageDosHeader(BaseAddress)^._lfanew = 0) then Exit;

    Result := PImageNtHeaders(DWORD(BaseAddress) + DWORD(PImageDosHeader(BaseAddress)^._lfanew));
    if (not IsValidBlockAddr(DWord(Result), SizeOf(TImageNtHeaders))) or
      (Result^.Signature <> IMAGE_NT_SIGNATURE) then Result := nil
  end;

  procedure CheckFail;
  begin
    if (not CanFail) then
      raise EHookingError.CreateFmt(EHookingErrorStr, [ProcName]);
  end;

begin
  Result := nil;

  if (OldProc = nil) then
    raise EProcNull.CreateFmt(EProcNullStr, [ProcName]);

  if (ImportModule > SharedMem) and // Shared Area...
    (Win32Platform <> VER_PLATFORM_WIN32_NT) then // Win9X/ME ...
    raise ESharedArea.CreateFmt(ESharedAreaStr, [ModuleFileName(ImportModule)]);

  Base := Pointer(ImportModule);
  FromProcDebugThunk := PWin9xDebugThunk(OldProc);
  IsThunked := (Win32Platform <> VER_PLATFORM_WIN32_NT) and IsWin9xDebugThunk(FromProcDebugThunk);
  NtHeader := PeMapImgNtHeaders(Base);
  if (NtHeader = nil) then
  begin
    CheckFail;
    Exit;
  end;

  ImportDir := NtHeader.OptionalHeader.DataDirectory[IMAGE_DIRECTORY_ENTRY_IMPORT];
  if (ImportDir.VirtualAddress = 0) then
  begin
    CheckFail;
    Exit;
  end;

  ImportDesc := PImageImportDescriptor(DWORD(Base) + ImportDir.VirtualAddress);
  while (ImportDesc^.Name <> 0) do
  begin
    CurrName := (PChar(Base) + ImportDesc^.Name);
    if (StrIComp(CurrName, PChar(ExportModule)) = 0) then
    begin
      ImportEntry := PImageThunkData(DWORD(Base) + ImportDesc^.FirstThunk);
      while (ImportEntry^.Function_ <> 0) do
      begin
        if IsThunked then
        begin
          ImportThunk := PWin9xDebugThunk(ImportEntry^.Function_);
          FoundProc := IsWin9xDebugThunk(ImportThunk) and
            (ImportThunk^.Addr = FromProcDebugThunk^.Addr);
        end
        else
          FoundProc := Pointer(ImportEntry^.Function_) = OldProc;
        if FoundProc then
        begin
          WriteMem(@ImportEntry^.Function_, NewProc, 4);
          if (not Unhook) then
          begin
            New(SaveDLLProc);
            SaveDLLProc^.OldProc := OldProc;
            SaveDLLProc^.NewProc := NewProc;
            SaveDLLProc^.HookModule := ImportModule;
            SaveDLLProc^.ExportModule := ExportModule;
            DllList.Add(SaveDLLProc);
          end;
          Result := OldProc;
        end;
        Inc(ImportEntry);
      end;
    end;
    Inc(ImportDesc);
  end;

  if (not CanFail) and (Result = nil) then
    raise EHookingError.CreateFmt(EHookingErrorStr, [ProcName]);
end;

function TryHookDllProcedureEx(ImportModules: array of string;
  ExportModule, ProcName: string; NewProc: Pointer;
  var CallProc: Pointer; CanFail: Boolean): Boolean;
var
  TmpProc, OldProc: Pointer;
  HModule: THandle;
  n: integer;
begin
  Result := False;
  OldProc := GetProcAddress(GetModuleHandle(PChar(ExportModule)), PChar(ProcName));

  for n := low(ImportModules) to high(ImportModules) do
  begin
    HModule := GetModuleHandle(PChar(ImportModules[n]));
    if (HModule <> 0) then
    begin
      TmpProc := HookDllProcedure(HModule, ExportModule, OldProc, NewProc,
        ExportModule + '.' + ProcName, CanFail, False);
      Result := (Result) or (TmpProc <> nil);
    end;
  end;

  CallProc := OldProc; // WARNING don't move to HERE!!!
end;

function TryHookProcedureEx(ExportModule, ProcName: string; NewProc: Pointer;
  var CallProc: Pointer): Boolean;
var
  TmpProc, OldProc: Pointer;
begin
  Result := False;
  OldProc := GetProcAddress(GetModuleHandle(PChar(ExportModule)), PChar(ProcName));

  TmpProc := nil;
  if Assigned(OldProc) then TmpProc := HookProcedureEx(OldProc, NewProc, ProcName);

  Result := (Result) or (TmpProc <> nil);
  CallProc := TmpProc; // WARNING don't move to HERE!!!
end;

function HookDllProcedureEx(ImportModule, ExportModule, ProcName: string;
  NewProc: Pointer): Pointer;
var
  OldProc: Pointer;
begin
  OldProc := GetProcAddress(GetModuleHandle(PChar(ExportModule)), PChar(ProcName));

  Result := HookDllProcedure(GetModuleHandle(PChar(ImportModule)), ExportModule,
    OldProc, NewProc, ExportModule + '.' + ProcName, False, False);
end;

//------------------------------------------------------------------------------

procedure Init;
begin
  DllList := TList.Create;
  HookedMethodsList := THookedMethodsList.Create;
  HookedProcedures := TList.Create;
end;

procedure Done;
var
  n: Integer;
  P: PSaveDLLProc;
  PHookedBlock: PHookedProcedure;
begin
  for n := 0 to DllList.Count - 1 do
  begin
    P := PSaveDLLProc(DllList[n]);
    HookDLLProcedure(P^.HookModule, P^.ExportModule, P^.NewProc, P^.OldProc, '', True, True);
    Dispose(P);
  end;
  DllList.Free;
  DllList := nil;
  HookedMethodsList.Free;
  HookedMethodsList := nil;
  for n := HookedProcedures.Count - 1 downto 0 do
  begin
    PHookedBlock := HookedProcedures[n];
    UnhookProcedure(PHookedBlock^.OriginalProc);
  end;
  HookedProcedures.Free;
  HookedProcedures := nil;
end;

//------------------------------------------------------------------------------
procedure SafeExec(Proc: TProc; Section: string);
var
  Error: string;
begin
  try
    Proc;
  except
    on Err: TObject do
    begin
      if (Err is EIgnoreException) then raise;

      if (@CriticalError <> nil) then
      begin
        CriticalError(Format('%s (Address: %s)', [Section, IntToHex(DWord(@Proc), 8)]));
        Abort;
      end
      else
      begin
        if (ExceptObject is Exception) then Error := Exception(ExceptObject).Message
        else Error := 'General internal error.';
        raise Exception.CreateFmt('Critical error at: "%s"'#13#10'Error: "%s".', [Section, Error]);
      end;
    end;
  end;
end;

//------------------------------------------------------------------------------
initialization
  SafeExec(Init, 'EHook.Init');

finalization
  SafeExec(Done, 'EHook.Done');

end.

下面是示例程序:
代码:

type
  //保存原API函数地址
  Kernel_WriteFile: function(hFile: Integer; const Buffer; nNumberOfBytesToWrite: Cardinal;
    var lpNumberOfBytesWritten: Cardinal; lpOverlapped: Pointer): Integer; stdcall;
  //自定义api函数
function MyWriteFile(hFile: THandle; Buffer:PPChar; nNumberOfBytesToWrite: DWORD;
  var lpNumberOfBytesWritten: DWORD; lpOverlapped: POverlapped): BOOL; stdcall;
var
  i:DWORD;
begin
   //将所有写入的数据取反
    for i:=LongWord(Buffer) to LongWord(Buffer)+nNumberOfBytesToWrite-1 do
    begin
      A:=PByte(i)^;
      A:=not A;
      PByte(i)^:=A;
    end;
  //调用原来的系统文件
  Result:=Kernel_WriteFile(hFile, Buffer, nNumberOfBytesToWrite, lpNumberOfBytesWritten, lpOverlapped);
end;

上面准备好了用户自定义API,和保存系统API函数指针.
下面介绍用法:
1.对单独模块进行API Hook
例如,假设我们的程序中包括了Mapx5.ocx, lin.dll和其他一些dll模块,
我们只想Hook程序的MapX5.OCX和 Lin.dll两个模块的WriteFile这个API函数,
调用函数TryHookDllProcedureEx:
代码:

   S:=ExtractFilePath(Application.ExeName);//获取路径
    // Hooked "WriteFile" Windows API...
    TryHookDllProcedureEx(
      [S+'MapX5.OCX', S+'Lin.dll'], //仅改变Mapx5.ocx, lin.dll两个模块的WriteFile功能
      kernel32, 'WriteFile',
      @HookedWriteFile, @Kernel_WriteFile, True);

2.对所有模块进行API Hook
更简单,调用函数TryHookProcedureEx
代码:

  TryHookProcedureEx(
    kernel32, 'CreateFileA',
    @MyCreateFileA, @Kernel_CreateFileA);

Unhook某个函数:
更更简单,调用  UnHookProcedure:
代码:

  UnHookProcedure(@Kernel_WriteFile);