How to create custom error dialog

// 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;