Delphi实现全局顶层窗口创建通知后关闭程序致Win32进程崩溃

我需要全局监听新顶层窗口的创建事件，目前用32位DLL+宿主程序实现了WH_SHELL钩子，能正常捕获窗口创建，但关闭宿主程序后，后台Win32进程会崩溃。以下是实现代码：

HookDLL代码 #

library HookDLL;

uses
  System.SysUtils,
  Winapi.Windows,
  CodeSiteLogging;

var
  hHook: Winapi.Windows.HHOOK;

function ShellProc(nCode: Integer; wParam: WPARAM; lParam: LPARAM): LRESULT; stdcall;
var
  WindowTitle: array[0..255] of Char;
begin
  if nCode = HSHELL_WINDOWCREATED then
  begin
    GetWindowText(wParam, WindowTitle, 256);
    CodeSite.Send('New window created', Format('HWND: %d, Title: %s', [wParam, WindowTitle]));
  end;
  Result := CallNextHookEx(hHook, nCode, wParam, lParam);
end;

procedure InstallHook; stdcall;
begin
  if hHook = 0 then
  begin
    hHook := SetWindowsHookEx(WH_SHELL, @ShellProc, HInstance, 0);
    if hHook <> 0 then
      CodeSite.Send('Hook set successfully')
    else
      CodeSite.Send('Failed to set hook');
  end;
end;

procedure UninstallHook; stdcall;
begin
  if hHook <> 0 then
  begin
    if UnhookWindowsHookEx(hHook) then
    begin
      CodeSite.Send('Hook removed');
      hHook := 0;
    end
    else
      CodeSite.Send('Failed to remove hook');
  end;
end;

exports
  InstallHook,
  UninstallHook;

begin
  hHook := 0;  // Initialize here
end.

宿主程序代码 #

unit MainForm;

interface

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

type
  TForm1 = class(TForm)
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
  private
    FHook: HHOOK;
    DLLHandle: THandle;
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.FormCreate(Sender: TObject);
var
  InstallHookProc: procedure; stdcall;
begin
  CodeSite.Send('TForm1.FormCreate: 1');

  // Load the DLL once and store the handle in a field for later use
  DLLHandle := LoadLibrary('HookDLL.dll');  

  if DLLHandle <> 0 then
  begin
    CodeSite.Send('TForm1.FormCreate: 2');

    @InstallHookProc := GetProcAddress(DLLHandle, 'InstallHook');
    if Assigned(InstallHookProc) then
    begin
      try
        CodeSite.Send('TForm1.FormCreate: ');
        InstallHookProc;
      except
        on E: Exception do
        begin
          CodeSite.Send('Exception in InstallHookProc', E.Message);
        end;
      end;

      // Check for errors
      if GetLastError <> 0 then
      begin
        CodeSite.Send('GetLastError after SetHook', SysErrorMessage(GetLastError));
      end;
    end
    else
    begin
      CodeSite.Send('TForm1.FormCreate: Failed to get InstallHook procedure address');
    end;
  end
  else
  begin
    CodeSite.Send('TForm1.FormCreate: Failed to load DLL');
  end;
end;

procedure TForm1.FormDestroy(Sender: TObject);
var
  UninstallHookProc: procedure; stdcall;
begin
  if DLLHandle <> 0 then  // Assume DLLHandle is a private field of TForm1
  begin
    @UninstallHookProc := GetProcAddress(DLLHandle, 'UninstallHook');
    if Assigned(UninstallHookProc) then
    begin
      try
        UninstallHookProc;
      except
        on E: Exception do
        begin
          CodeSite.Send('Exception in UninstallHookProc', E.Message);
        end;
      end;
    end
    else
    begin
      CodeSite.Send('Failed to get UninstallHook procedure address');
    end;

    // Check for errors
    if GetLastError <> 0 then
    begin
      CodeSite.Send('GetLastError after Unhook', SysErrorMessage(GetLastError));
    end;

    // Free the library
    try
      FreeLibrary(DLLHandle);
    except
      on E: Exception do
      begin
        CodeSite.Send('Exception in FreeLibrary', E.Message);
      end;
    end;

    // Check for errors
    if GetLastError <> 0 then
    begin
      CodeSite.Send('GetLastError after FreeLibrary', SysErrorMessage(GetLastError));
    end;
  end
  else
  begin
    CodeSite.Send('DLL was not loaded');
  end;
end;

end.

问题原因及修复方案 #

核心问题 #

全局WH_SHELL钩子会注入到所有32位进程中，当宿主程序卸载钩子并释放DLL后，部分进程可能仍在调用钩子函数，此时DLL已被卸载，导致访问违规崩溃。另外当前代码存在以下隐患：

• 钩子卸载后未确保所有进程已完成钩子回调调用
• GetLastError使用时机错误：try...except块会覆盖错误码，导致信息不准确
• 钩子回调中使用CodeSite.Send存在跨进程操作风险

修复步骤 #

1. 确保钩子完全卸载后再释放DLL
   卸载钩子后发送全局消息，让所有进程刷新钩子状态，并短暂等待回调完成：

   procedure UninstallHook; stdcall;
   begin
     if hHook <> 0 then
     begin
       if UnhookWindowsHookEx(hHook) then
       begin
         CodeSite.Send('Hook removed');
         hHook := 0;
         // 广播空消息触发进程钩子处理逻辑
         SendMessage(HWND_BROADCAST, WM_NULL, 0, 0);
         // 等待所有进程完成回调
         Sleep(100);
       end
       else
         CodeSite.Send('Failed to remove hook');
     end;
   end;
   

2. 修正GetLastError使用逻辑
   在API调用后立即获取错误码，避免被try...except覆盖：

   // 宿主程序安装钩子部分修正
   if Assigned(InstallHookProc) then
   begin
     CodeSite.Send('TForm1.FormCreate: Installing hook');
     InstallHookProc;
     // 立即获取错误码
     var LastErr := GetLastError;
     if LastErr <> 0 then
     begin
       CodeSite.Send('GetLastError after SetHook', SysErrorMessage(LastErr));
     end;
   end;
   

3. 替换跨进程日志操作
   钩子回调中避免直接调用外部日志库，改为通过消息传递给宿主程序：

   function ShellProc(nCode: Integer; wParam: WPARAM; lParam: LPARAM): LRESULT; stdcall;
   var
     WindowTitle: array[0..255] of Char;
     HostWnd: HWND;
     MsgText: string;
   begin
     if nCode = HSHELL_WINDOWCREATED then
     begin
       GetWindowText(wParam, WindowTitle, 256);
       // 查找宿主窗口（替换为实际宿主窗口标题）
       HostWnd := FindWindow(nil, 'Form1');
       if HostWnd <> 0 then
       begin
         MsgText := Format('HWND: %d, Title: %s', [wParam, WindowTitle]);
         // 发送自定义消息传递数据
         SendMessage(HostWnd, WM_USER + 1, 0, LPARAM(PChar(MsgText)));
       end;
     end;
     Result := CallNextHookEx(hHook, nCode, wParam, lParam);
   end;
   

4. 确保DLL路径可被所有进程访问
   将DLL放置在系统目录（如C:\Windows\System32），或确保宿主程序与DLL在同一目录，避免其他进程加载失败。

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