Delphi在全局异常中的屏幕截图

我正在开发一个组件，使用德尔福2006，该组件检索系统信息并写入文件。 要求是我必须在组件中合并一个全局异常处理程序，因此当异常发生时它将被捕获并向用户显示我的自定义消息。

  procedure Tmy.GlobalExceptionHandlerThis(Sender : TObject; E : Exception );
  begin
    //catch the exception and show the message
      TakeScreenShotAndSaveInapplicationFolder;
      MessageDlg('Exception has Occured  , Detail  '+E.Message,mtError,[mbOK],0);
  end;

这工作正常，但根据要求，我必须捕获错误屏幕截图（这是为了直观地找到弹出异常的表单）

所以我这样做了，并从以下位置获取屏幕截图代码delphigeist.com http://www.delphigeist.com/2009/09/take-screenshot.html:

procedure TakeScreenShotAndSaveInapplicationFolder;
var
  thisBitmap: TBitmap;
  sDate : string;
begin
  DateSeparator :='_';
  TimeSeparator:='_';
  sDate :=DateTimeToStr(now);
  thisBitmap := TBitmap.Create;
  ScreenshotArea(thisBitmap, Screen.DesktopRect, True);
  thisBitmap.SaveToFile(ExtractFilePath(Application.ExeName)+sDate+'.jpg');
  FreeAndNil(thisBitmap);
end;

Problem:

当异常发生时，我也想截取消息的屏幕截图，但使用我的代码会发生这种情况

谁能告诉我怎样才能得到这样的屏幕截图？ 这是沿着表格获取消息

MessageDlg('Exception has Occured, Detail ' + E.Message,mtError,[mbOK],0);是模态的，所以在消息之后我无法拍摄屏幕截图。在我也不能之前， 那么什么时候可以在出现异常信息时截屏呢？

procedure Tmy.GlobalExceptionHandlerThis(Sender : TObject; E : Exception );
begin
  //catch the exception and show the message
  TakeScreenShotAndSaveInapplicationFolder;
  MessageDlg('Exception has Occured  , Detail  '+E.Message,mtError,[mbOK],0);
  TakeScreenShotAndSaveInapplicationFolder;
end;

Modify 这个消息框 https://stackoverflow.com/a/9642293/757830（一个包装器Windows.MessageBox）， 如下：

{ TAwMessageBox }

type
  TAwMessageBox = class(TObject)
  private
    FCaption: String;
    FFlags: Cardinal;
    FHookProc: TFarProc;
    FText: String;
    FWndHook: HHOOK;
    function Execute: Integer;
    procedure HookProc(var Message: THookMessage);
  end;

function TAwMessageBox.Execute: Integer;
begin
  try
    try
      FHookProc := MakeHookInstance(HookProc);
      FWndHook := SetWindowsHookEx(WH_CALLWNDPROCRET, FHookProc, 0,
        GetCurrentThreadID);
      Result := Application.MessageBox(PChar(FText), PChar(FCaption), FFlags);
    finally
      if FWndHook <> 0 then
        UnhookWindowsHookEx(FWndHook);
      if FHookProc <> nil then
        FreeHookInstance(FHookProc);
    end;
  except
    Result := 0;
  end;
end;

procedure TAwMessageBox.HookProc(var Message: THookMessage);
var
  Data: PCWPRetStruct;
  Title: array[0..255] of Char;
begin
  with Message do
    if nCode < 0 then
      Result := CallNextHookEx(FWndHook, nCode, wParam, lParam)
    else
      Result := 0;
  if Message.nCode = HC_ACTION then
  begin
    Data := PCWPRetStruct(Message.lParam);
    if (Data.message = WM_ACTIVATE) and (LoWord(Data.wParam) = WA_INACTIVE) then
    begin
      ZeroMemory(@Title, SizeOf(Title));
      GetWindowText(Data.hwnd, @Title, SizeOf(Title));
      if String(Title) = FCaption then
      begin
        TakeScreenShotAndSaveInapplicationFolder;
        UnhookWindowsHookEx(FWndHook);
        FWndHook := 0;
        FreeHookInstance(FHookProc);
        FHookProc := nil;
      end;
    end;
  end;
end;

function MsgBox(const Text: String; Flags: Cardinal;
  const Caption: String): Integer;
begin
  with TAwMessageBox.Create do
  try
    FCaption := Caption;
    FFlags := Flags;
    FText := Text;
    Result := Execute;
  finally
    Free;
  end;
end;

测试代码及截图：

procedure TForm1.ApplicationEvents1Exception(Sender: TObject; E: Exception);
begin
  MsgBox('Exception has occured. Details:'#13#10#13#10 + E.Message,
    MB_OK or MB_ICONERROR, 'Error');
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  raise Exception.Create('Test exception');
end;