Pasted

// See also: https://pastebin.com/fs1CwVfZ - "how to use VCL form as exception dialog"
// See also: https://pastebin.com/BFhcdsnh - "how to replace dialog icon"
// See also: https://pastebin.com/S5h3VB3J - "how to subclass without changing class name"
 
// You may be not satisfied by standard EurekaLog dialogs, so you may want to use your own dialog.
// Here is what you need to do: create class inheriting from abstract TBaseDialog class (EDialog unit), register it, and set ExceptionDialogType option. 
// The following sample shows 4 new dialog. 
//
// As you can see, the central method here is ShowModalInternal. It does all the work. 
// It's abstract and must be overwritten in child classes. 
// We use this method to show MessageBox, but you can do something else. 
// Like creating and showing VCL or FMX form.
//
// All other methods of TBaseDialog are virtual, but not abstract. They contain default behavior. 
// You can override them to alter behavior, but you don't have to. 
// Base dialog class contains large number of helpers (methods and properties). 
// All that dialog needs to do is to invoke these methods in right order. 
// Therefore any child class can use powerful tools to quickly build new dialog.
// Note: there is another abstract dialog class - TWinAPIDialog from EDialogWinAPI unit. 
// It's useful if you want to create new dialog based on direct WinAPI calls, 
// rather than using ready functions or frameworks (VCL/CLX/FMX).
// 
// Important note: dialog class is responsible for almost whole exception processing. 
// That's because "dialog" don't have to be visual. 
// Think about Win32 service, system log, WER (Windows Error Reporting), etc. 
// So, this is not always possible to distinguish between "error dialog" and "exception processing". 
// That's why these concepts are both controlled by single "dialog" class. 
// As we saw above, a major method for visual dialog is ShowModalInternal method. 
// But real entry point is Execute method. 
// You can see its default implementation in TBaseDialog.Execute.
 
uses
  EDialog, EClasses, ETypes;
 
type
  // "Empty" dialog that does nothing at all
  TNullDialog = class(TBaseDialog)
  protected
    procedure Beep; override;
    function ShowModalInternal: TResponse; override;
  public
    class function ThreadSafe: Boolean; override;
  end;
 
  // MessageBox dialog
  TMessageBoxDialog = class(TBaseDialog)
  protected
    function ShowModalInternal: TResponse; override;
    procedure Beep; override;
  public
    class function ThreadSafe: Boolean; override;
  end;
 
  // A variant of MessageBox with more detailed message (with call stack)
  TMessageBoxDetailedDialog = class(TMessageBoxDialog)
  protected
    function ExceptionMessage: String; override;
  end;
 
  // "Default" dialog - dialog that invokes standard dialog (non-EurekaLog)
  TRTLHandlerDialog = class(TBaseDialog)
  protected
    procedure Beep; override;
    function GetCallRTLExceptionEvent: Boolean; override;
    function ShowModalInternal: TResponse; override;
  end;
 
{ TNullDialog }
 
procedure TNullDialog.Beep;
begin
  // does nothing - no beep needed
end;
 
// Main method: do nothing, return success
function TNullDialog.ShowModalInternal: TResponse;
begin
  SetReproduceText(ReproduceText);
 
  Result.SendResult := srSent;
  Result.ErrorCode := ERROR_SUCCESS;
  Result.ErrorMessage := '';
end;
 
// Indicate that we can be called from any thread 
// (this should be False for VCL/CLX/FMX dialogs)
class function TNullDialog.ThreadSafe: Boolean;
begin
  Result := True;
end;
 
{ TMessageBoxDialog }
 
procedure TMessageBoxDialog.Beep;
begin
  // does nothing - beep is invoked by Windows.MessageBox in 
  // TMessageBoxDialog.ShowModalInternal
end;
 
// Main method 
function TMessageBoxDialog.ShowModalInternal: TResponse;
var
  Flags: Cardinal;
  Msg: String;
begin
  // Set default result
  Result.ErrorCode := ERROR_SUCCESS;
  Result.ErrorMessage := '';
  if SendErrorReportChecked then
    Result.SendResult := srSent
  else
    Result.SendResult := srCancelled;
 
  // Prepare message to show
  Msg := ExceptionMessage;
  if ShowSendErrorControl then
  begin
    Msg := Format(Options.CustomizedExpandedTexts[mtSend_AskSend], [Msg]);
    Flags := MB_YESNO;
  end
  else
    Flags := MB_OK;
  Flags := Flags or MB_ICONERROR or MB_TASKMODAL;
  if SendErrorReportChecked or (not ShowSendErrorControl) then
    Flags := Flags or MB_DEFBUTTON1
  else
    Flags := Flags or MB_DEFBUTTON2;
 
  // Call actual MessageBox and set result
  case MessageBox(Msg,
                  Options.CustomizedExpandedTexts[mtDialog_Caption],
                  Flags) of
    0: Result.ErrorCode := GetLastError;
    IDYes:
       Result.SendResult := srSent;
    IDNo:
       Result.SendResult := srCancelled;
  end;
 
  // Save error code/error message for failures
  if Result.ErrorCode <> ERROR_SUCCESS then
  begin
    Result.SendResult := srUnknownError;
    Result.ErrorMessage := SysErrorMessage(Result.ErrorCode);
  end
  else
    SetReproduceText(ReproduceText);
end;
 
// Can be called from any thread
class function TMessageBoxDialog.ThreadSafe: Boolean;
begin
  Result := True;
end;
 
{ TRTLHandlerDialog }
 
// Indicate desire to invoke RTL handler
function TRTLHandlerDialog.GetCallRTLExceptionEvent: Boolean;
begin
  Result := True;
end;
 
function TRTLHandlerDialog.ShowModalInternal: TResponse;
begin
  SetReproduceText(ReproduceText);
 
  Result.SendResult := srRestart;  // means "call RTL handler"
  Result.ErrorCode := ERROR_SUCCESS;
  Result.ErrorMessage := '';
end;
 
procedure TRTLHandlerDialog.Beep;
begin
  // Does nothing - transfer work to RTL handler
end;
 
{ TMessageBoxDetailedDialog }
 
// This one is a bit more complex - we want to add call stack to error message.
// However, default form is not very readable with variable-width fonts.
// That's why first we need a way to format call stack in another way.
 
type
  // Our new formatter
  TMessageBoxDetailedFormatter = class(TEurekaBaseStackFormatter)
  protected
    function GetItemText(const AIndex: Integer): String; override;
    function GetStrings: TStrings; override;
  end;
 
// Forms one line of call stack
function TMessageBoxDetailedFormatter.GetItemText(const AIndex: Integer): String;
var
  Cache: TEurekaDebugInfo;
  Info: PEurekaDebugInfo;
  ModuleName, UnitName, RoutineName, LineInfo: String;
begin
  Info := CallStack.GetItem(AIndex, Cache);
 
  ModuleName := ExtractFileName(Info^.Location.ModuleName);
  UnitName := Info^.Location.UnitName;
 
  if UnitName = ChangeFileExt(ModuleName, '') then
    UnitName := ''
  else
    UnitName := '.' + UnitName;
 
  RoutineName := CallStack.ComposeName
    (Info^.Location.ClassName, Info^.Location.ProcedureName);
  if RoutineName <> '' then
    RoutineName := '.' + RoutineName;
 
  if Info^.Location.LineNumber > 0 then
    LineInfo := Format(',%d[%d]', 
      [Info^.Location.LineNumber, Info^.Location.ProcOffsetLine]) 
  else
    LineInfo := '';
 
  Result := ModuleName + UnitName + RoutineName + LineInfo;
end;
 
// Formats entire call stack
function TMessageBoxDetailedFormatter.GetStrings: TStrings;
var
  ThreadID: Cardinal;
  I: Integer;
  Line: String;
  Stack: TEurekaBaseStackList;
begin
  if not Assigned(FStr) then
  begin
    FStr := TStringList.Create;
    FModified := True;
  end;
  if FModified then
  begin
    Stack := CallStack;
    CalculateLengths;
    FStr.BeginUpdate;
    try
      FStr.Clear;
      FStr.Capacity := Stack.Count;
 
      if Stack.Count > 0 then
      begin
        ThreadID := Stack.Items[0].ThreadID;
        for I := 0 to Stack.Count - 1 do
        begin
          if (Stack.Items[I].Location.Module <> 0) and
             (Stack.Items[I].Location.DebugDetail in [ddUnit..ddSourceCode]) and
             (Stack.Items[I].ThreadID = ThreadID) then
          begin
            Line := GetItemText(I);
            if (FStr.Count <= 0) or (FStr[FStr.Count - 1] <> Line) then
              FStr.Add(Line);
          end;
        end;
      end;
    finally
      FStr.EndUpdate;
    end;
    FModified := False;
  end;
  Result := FStr;
end;
 
// Append call stack to error message
function TMessageBoxDetailedDialog.ExceptionMessage: String;
const
  MaxLines = 15;
var
  Formatter: TMessageBoxDetailedFormatter;
  Stack: TEurekaBaseStackList;
begin
  {$WARNINGS OFF}
  // Abstract methods are intended here. 
  // It is like assert: they should not be called.
  Formatter := TMessageBoxDetailedFormatter.Create;
  {$WARNINGS ON}
  try
 
    if Assigned(CallStack) then
      Formatter.Assign(CallStack.Formatter);
    Formatter.CaptionHeader := '';
 
    Stack := nil;
    try
      if CallStack <> nil then
      begin
        Stack := TEurekaStackList.Create;
        Stack.Assign(CallStack);
        while Stack.Count > MaxLines do
          Stack.Delete(Stack.Count - 1);
      end;
      Result := inherited ExceptionMessage + sLineBreak + sLineBreak +
                CallStackToString(Stack, '', Formatter);
    finally
      FreeAndNil(Stack);
    end;
  finally
    FreeAndNil(Formatter);
  end;
end;
 
...
 
initialization
 
  RegisterDialogClass(TNullDialog);
  RegisterDialogClass(TMessageBoxDialog);
  RegisterDialogClass(TMessageBoxDetailedDialog);
  RegisterDialogClass(TRTLHandlerDialog);
 
end.
 
// Usage:
CurrentEurekaModuleOptions.ExceptionDialogType := TMessageBoxDetailedDialog.ClassName;