Delphi 10.2如何Hook TBitmap.Create并获取调用函数名？

问题说明 #

需在Delphi 10.2中Hook TBitmap.Create构造函数，记录调用该构造函数的函数/过程名称，依赖madExcept和DDetours工具实现，此前AI生成的代码存在编译失败或运行崩溃问题。

原代码问题分析 #

1. 构造函数类型定义错误：原代码将TBitmap.Create定义为function，但Delphi构造函数本质是procedure，错误类型会导致调用栈混乱、程序崩溃。
2. Hook时机不当：在initialization段直接执行Hook，此时Vcl.Graphics单元的类初始化可能未完成，易引发访问错误。
3. 递归调用风险：在构造函数Hook内直接调用StackTrace，可能触发递归（如StackTrace内部需创建TBitmap），导致栈溢出。

可行实现方案 #

方案一：安全Hook TBitmap.Create构造函数 #

修正构造函数类型定义，调整Hook时机并添加递归防护。

unit Main;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes,
  Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, DDetours;

type
  TForm2 = class(TForm)
    CreateBitmapBtn: TButton;
    RemoveHookBtn: TButton;
    Memo1: TMemo;
    procedure FormCreate(Sender: TObject);
    procedure CreateBitmapBtnClick(Sender: TObject);
    procedure RemoveHookBtnClick(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form2: TForm2;

procedure InstallTBitmapCreateHook;
procedure RemoveTBitmapCreateHook;

implementation

{$R *.dfm}

uses madStackTrace;

// 正确匹配TBitmap.Create的参数与调用约定
type
  TBitmapCreateProc = procedure(Self: TBitmap; DoAlloc: Boolean); stdcall;

var
  Original_TBitmap_Create: TBitmapCreateProc = nil;

procedure Hook_TBitmap_Create(Self: TBitmap; DoAlloc: Boolean);
var
  CallerInfo: string;
  // 标记Hook状态，防止递归调用
  class var IsHookActive: Boolean;
begin
  if IsHookActive then
  begin
    Original_TBitmap_Create(Self, DoAlloc);
    Exit;
  end;

  IsHookActive := True;
  try
    // 截取调用栈，跳过当前Hook函数，取上一层调用方
    CallerInfo := StackTrace(1, 2);
    if Assigned(Form2) and Assigned(Form2.Memo1) then
      Form2.Memo1.Lines.Add(Format('TBitmap.Create被调用，调用方：%s', [CallerInfo]))
    else
      OutputDebugString(PChar(Format('TBitmap.Create被调用，调用方：%s', [CallerInfo])));

    // 调用原始构造函数
    Original_TBitmap_Create(Self, DoAlloc);
  finally
    IsHookActive := False;
  end;
end;

procedure TForm2.FormCreate(Sender: TObject);
begin
  // 延迟到窗体创建时Hook，确保Vcl.Graphics初始化完成
  InstallTBitmapCreateHook;
end;

procedure TForm2.CreateBitmapBtnClick(Sender: TObject);
var
  bMap: TBitmap;
begin
  bMap := TBitmap.Create;
  try
    bMap.Width := 100;
    bMap.Height := 100;
  finally
    bMap.Free;
  end;
end;

procedure InstallTBitmapCreateHook;
begin
  if not Assigned(Original_TBitmap_Create) then
  begin
    Original_TBitmap_Create := InterceptCreate(@Vcl.Graphics.TBitmap.Create, @Hook_TBitmap_Create) as TBitmapCreateProc;
  end;
end;

procedure RemoveTBitmapCreateHook;
begin
  if Assigned(Original_TBitmap_Create) then
  begin
    InterceptRemove(@Original_TBitmap_Create);
    Original_TBitmap_Create := nil;
  end;
end;

procedure TForm2.RemoveHookBtnClick(Sender: TObject);
begin
  RemoveTBitmapCreateHook;
end;

finalization
  RemoveTBitmapCreateHook;

end.

方案二：Hook TBitmap.AfterConstruction（更稳定） #

构造函数Hook易受RTT和初始化顺序影响，Hook AfterConstruction是更稳妥的选择，对象构造完成后触发，避免构造过程中的异常。

unit Main2;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes,
  Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, DDetours;

type
  TForm3 = class(TForm)
    CreateBitmapBtn: TButton;
    RemoveHookBtn: TButton;
    Memo1: TMemo;
    procedure FormCreate(Sender: TObject);
    procedure CreateBitmapBtnClick(Sender: TObject);
    procedure RemoveHookBtnClick(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form3: TForm3;

implementation

{$R *.dfm}

uses madStackTrace;

type
  TAfterConstructionProc = procedure(Self: TObject); stdcall;

var
  Original_TBitmap_AfterConstruction: TAfterConstructionProc = nil;

procedure Hook_TBitmap_AfterConstruction(Self: TObject);
var
  CallerInfo: string;
  class var IsHookActive: Boolean;
begin
  if IsHookActive then
  begin
    Original_TBitmap_AfterConstruction(Self);
    Exit;
  end;

  IsHookActive := True;
  try
    // 仅处理TBitmap实例
    if Self is TBitmap then
    begin
      // 截取调用栈，跳过当前Hook和AfterConstruction本身
      CallerInfo := StackTrace(2, 3);
      if Assigned(Form3) and Assigned(Form3.Memo1) then
        Form3.Memo1.Lines.Add(Format('TBitmap实例创建完成，调用方：%s', [CallerInfo]))
      else
        OutputDebugString(PChar(Format('TBitmap实例创建完成，调用方：%s', [CallerInfo])));
    end;

    Original_TBitmap_AfterConstruction(Self);
  finally
    IsHookActive := False;
  end;
end;

procedure TForm3.FormCreate(Sender: TObject);
begin
  InstallBitmapHook;
end;

procedure InstallBitmapHook;
begin
  if not Assigned(Original_TBitmap_AfterConstruction) then
  begin
    Original_TBitmap_AfterConstruction := InterceptCreate(@TBitmap.AfterConstruction, @Hook_TBitmap_AfterConstruction) as TAfterConstructionProc;
  end;
end;

procedure RemoveBitmapHook;
begin
  if Assigned(Original_TBitmap_AfterConstruction) then
  begin
    InterceptRemove(@Original_TBitmap_AfterConstruction);
    Original_TBitmap_AfterConstruction := nil;
  end;
end;

procedure TForm3.CreateBitmapBtnClick(Sender: TObject);
var
  bMap: TBitmap;
begin
  bMap := TBitmap.Create;
  try
    bMap.Width := 100;
    bMap.Height := 100;
  finally
    bMap.Free;
  end;
end;

procedure TForm3.RemoveHookBtnClick(Sender: TObject);
begin
  RemoveBitmapHook;
end;

finalization
  RemoveBitmapHook;

end.

关键注意事项 #

• 类型严格匹配：必须确保Hook函数与原函数的参数、调用约定完全一致，这里统一用stdcall避免调用栈错误。
• 递归防护：添加IsHookActive标记，防止StackTrace内部调用TBitmap触发递归Hook。
• 延迟Hook时机：将Hook操作延迟到窗体创建阶段，确保Vcl.Graphics单元初始化完成，避免访问未初始化内存。
• 精准截取栈帧：使用StackTrace(N, M)指定栈帧范围，跳过Hook函数本身，直接获取真正的调用方信息。

内容的提问来源于stack exchange，提问作者Mark