Allow multiple MDI Parent Forms on same Application

Question

I'm trying follow what was suggested in this answer, changing this part of Vcl.Forms.pas:

procedure TCustomForm.CreateWindowHandle(const Params: TCreateParams);
var
  CreateStruct: TMDICreateStruct;
  NewParams: TCreateParams;
begin
  if (FormStyle = fsMDIChild) and not (csDesigning in ComponentState) then
  begin
    {if (Application.MainForm = nil) or
      (Application.MainForm.ClientHandle = 0) then
      raise EInvalidOperation.Create(SNoMDIForm);}
    with CreateStruct do
    begin
      szClass := Params.WinClassName;
      szTitle := Params.Caption;
      hOwner := THandle(HInstance);
      X := Params.X;
      Y := Params.Y;
      cX := Params.Width;
      cY := Params.Height;
      style := Params.Style;
      lParam := THandle(Params.Param);
    end;
    WindowHandle := SendStructMessage(Application.MainForm.ClientHandle,
      WM_MDICREATE, 0, CreateStruct);
    Include(FFormState, fsCreatedMDIChild);
  end
  else

  //...

but still comes the error saying that "no MDI Form is active"

What more is need be made to this suggestion works? Thanks in advance.

Code of test with Forms:

procedure TForm1.Button1Click(Sender: TObject);
begin
  Form2 := TForm2.Create(Self); // MDIForm
  Form2.Show;
  Form3 := TForm3.Create(Form2); // MDIChild
  Form3.Show;
end;

Answer 1

After the help of comments above (mainly of @Remy Lebeau) follows this code working. I hope that can help someone ahead :-).

// MainForm
type
  TForm1 = class(TForm)
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

uses
  Unit2;

{$R *.dfm}

procedure TForm1.Button1Click(Sender: TObject);
begin
  Form2 := TForm2.Create(Application);
  Form2.Show;
end;

---

// MDIForm
type
  TForm2 = class(TForm)
    MainMenu1: TMainMenu;
    O1: TMenuItem;
    procedure O1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form2: TForm2;

implementation

uses
  Unit3;

{$R *.dfm}

procedure TForm2.O1Click(Sender: TObject);
begin
  Form3 := TForm3.Create(Self);
  Form3.Show;
end;

---

// MDIChild
type
  TForm3 = class(TForm)
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
  private
    { Private declarations }
    procedure CreateWindowHandle(const Params: TCreateParams); override;
    procedure DestroyWindowHandle; override;
  protected
    FMDIClientHandle: HWND;
  public
    { Public declarations }
  end;

var
  Form3: TForm3;

implementation

uses
  Unit1;

{$R *.dfm}

procedure TForm3.CreateWindowHandle(const Params: TCreateParams);
var
  CreateStruct: TMDICreateStruct;

  function GetMDIClientHandle: HWND;
  begin
    Result := 0;
    if (Owner is TForm) then
      Result := TForm(Owner).ClientHandle;
    if (Result = 0) and (Application.MainForm <> nil) then
      Result := Application.MainForm.ClientHandle;
    if Result = 0 then
      raise EInvalidOperation.Create('No Parent MDI Form');
  end;

begin
  if (FormStyle = fsMDIChild) and not (csDesigning in ComponentState) then
  begin
    FMDIClientHandle := GetMDIClientHandle;
    with CreateStruct do
    begin
      szClass := Params.WinClassName;
      szTitle := Params.Caption;
      hOwner := HInstance;
      X := Params.X;
      Y := Params.Y;
      cX := Params.Width;
      cY := Params.Height;
      style := Params.Style;
      lParam := Longint(Params.Param);
    end;
    WindowHandle := SendMessage(FMDIClientHandle, WM_MDICREATE, 0, LongInt(@CreateStruct));
    Include(FFormState, fsCreatedMDIChild);
  end
  else
  begin
    FMDIClientHandle := 0;
    inherited CreateWindowHandle(Params);
    Exclude(FFormState, fsCreatedMDIChild);
  end;
end;

procedure TForm3.DestroyWindowHandle;
begin
  if fsCreatedMDIChild in FFormState then
    SendMessage(FMDIClientHandle, WM_MDIDESTROY, Handle, 0)
  else
    inherited DestroyWindowHandle;
  FMDIClientHandle := 0;
end;

procedure TForm3.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  Action := CaFree;
end;