ShowModal por formulario en VCL

Antes de continuar, en muchos en los que se realiza un desarrollo multi-área, como MDI, nos surge la necesidad de hacer diálogos modales por área o formulario. Aunque a partir de la versión de XE5 (si no recuerdo mal) hay una solución para FireMonkey, para VCL no existe esta posibilidad y hay que implementarla.
Seguramente muchos ya lo habréis solucionado de una manera u otra, la forma que lo he visto en muchos casaos es crear el dialogo sobre el formulario y en vez de mostrarlo con en modo modal mostrarlo sin modo modal y esperar en un bucle con Application.ProcessMessages la finalización de diálogo, algo como:

...
    FrmDialogo.Create(Self);
    FrmDialogo.Parent := Self;
    FrmDialogo.Show;
    while FrmDialogo.ModalResult <> mrNone do
      Application.ProcessMessages;
    case FrmDialogo.ModalResult of
      mrOK: begin
        ...
      end;
      mrCancel: begin
        ...
      end;
    end;
... 

Con esto (...bueno sí faltan cosas...) se permite poder cambiar de área y dejar el diálogo en el formulario desde el que se lanzo, pero creerme que a la larga el funcionamiento no es el esperado y a veces puede llevar a errores difíciles de encontrar.
El problema es que sólo tenemos un hilo de ejecución y con la VCL sólo se nos permite uno para la parte visual y no podemos mostrar más de una ventana modal. Para poder hacerlo tenemos que simularlo, para ello vamos a usar las primeras versiones que he usado en mi framework. Lo mejor es no usar el Application.ProcessMessages, y dejar el funcionamiento al sistema de eventos y mensajes. En una primera aproximación los diálogos modales paran el proceso del formulario emisor y al finalizarse se continúa. Además no vamos a entrar en el multiproceso, eso es otro tema.
Vamos a ver las bases del formulario usados en el framework y los diálogos (no por completo).

unit uJwd.VCL.Form;

interface

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

type
  TjwdForm = class(TForm)
    ...
    procedure OnDeactivateForModalDlg; virtual; abstract;
    procedure OnActivateForModalDlg; virtual; abstract;
    ...
    constructor Create(AOwner: TComponent); override;
  end;

implementation

{$R *.dfm}

{ TjwdForm }

constructor TjwdForm.Create(AOwner: TComponent);
begin
  if AOwner = nil then
    AOwner := Application.MainForm;
  inherited Create(AOwner);
  if AOwner is TjwdForm then
    Parent := TjwdForm(AOwner);
end;
...
end.

Lo que nos interesa de aquí es los métodos abstractos se utilizarán para habilitar y deshabilitar el formulario cuando se muestre el diálogo, ya que lo que haremos, como veremos, es deshabiltar sus controles para que n se pueda hacer hada sobre él y que el control lo tenga el nuevo diálogo. Otra cosa a tener en cuenta es que el Create ya poner como Parent propio Owner lo que nos evita hacerlo posteriormente. Esto es práctico en los diálogos, que heredan de éste.

unit uJwd.VCL.Dialog;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, uJwd.VCL.Form;

type
  EjwdFormModalException = class(Exception);

  TjwdDialog = class(TjwdForm)
    ...
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
  strict private
    function ShowModal: Integer; overload; override;
  public type
    TjwdDialogPosition = (jwdpCenter, jwdpTopCenter, jwdpBottomCenter, jwdpCenterLeft, jwdpCenterRigth, jwdpNone);
  private type
    TjwdModalProc = procedure (const AModalResult: TModalResult) of object;
  private
    ...
    procedure SetModalResult(Value: TModalResult);
    ...
  protected
    ...
    procedure SetJwdDialogPosition(var ATop, ALeft: Integer); virtual;
    procedure ShowModal(const AParent: TjwdForm;
      const ResultProc: TjwdModalProc;
      const UseRootFormHiddingDialog: boolean = True); reintroduce; overload;
    procedure ShowModal(const AParent: TjwdForm;
      const ResultProc: TProc;
      const UseRootFormHiddingDialog: boolean = True); reintroduce; overload;
  public
    procedure ShowModal(const ResultProc: TjwdModalProc;
      const UseRootFormHiddingDialog: boolean = True); reintroduce; overload;
    procedure ShowModal(const ResultProc: TProc;
      const UseRootFormHiddingDialog: boolean = True); reintroduce; overload;

    property ModalResult: TModalResult
      read FModalResult
      write SetModalResult;

    constructor Create(AOwner: TjwdForm; APosition: TjwdDialogPosition = jwdpTopCenter);
  published
    property DialogPosition: TjwdDialogPosition
      read FDialogPosition
      write FDialogPosition
      stored jwdpTopCenter;
  end;

implementation

{$R *.dfm}

constructor TjwdDialog.Create(AOwner: TjwdForm; APosition: TjwdDialogPosition);
begin
  inherited Create(AOwner);

  FDialogPosition := APosition;
end;
...
procedure TjwdDialog.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  Action := caFree;
end;
...
procedure TjwdDialog.SetJwdDialogPosition(var ATop, ALeft: Integer);
begin
  // You can change dialog position in this moment
  //   ATop and ALeft has been already calculated from DialogPosition
end;

procedure TjwdDialog.SetModalResult(Value: TModalResult);
begin
  FModalResult := Value;
  try
    Hide;
    if Assigned(FParentDialog) then
      FParentDialog.Show
    else
      TjwdForm(Parent).OnActivateForModalDlg;
    DoResultProc(FModalResult);
  finally
    FResultProc := nil;
    FResultProc2 := nil;
    Close;
  end;
end;

function TjwdDialog.ShowModal: Integer;
var
  ATop, ALeft: Integer;
begin
  Result := 0;
  try
    Position := poDesigned;
    if Assigned(FParentDialog) then
      FParentDialog.Hide
    else
      TjwdForm(Parent).OnDeactivateForModalDlg;
    case DialogPosition of
      jwdpCenter: begin
        ATop := (Parent.Height - Height) div 2;
        ALeft := (Parent.Width - Width) div 2;
      end;
      jwdpTopCenter: begin
        ATop := 0;
        ALeft := (Parent.Width - Width) div 2;
      end;
      jwdpBottomCenter: begin
        ATop := (Parent.Height - Height);
        ALeft := (Parent.Width - Width) div 2;
      end;
      jwdpCenterLeft: begin
        ATop := (Parent.Height - Height) div 2;
        ALeft := 0;
      end;
      jwdpCenterRigth: begin
        ATop := (Parent.Height - Height) div 2;
        ALeft := (Parent.Width - Width);
      end;
      else
        ATop := 0;
        ALeft := 0;
    end;
    SetJwdDialogPosition(ATop, ALeft);
    Top := ATop;
    Left := ALeft;
  finally
    Show;
  end;
end;

procedure TjwdDialog.ShowModal(const AParent: TjwdForm;
  const ResultProc: TjwdModalProc;
  const UseRootFormHiddingDialog: boolean);
begin
  if UseRootFormHiddingDialog and (Parent is TjwdDialog) then
    FParentDialog := TjwdDialog(Parent)
  else
    FParentDialog := nil;
  Parent := AParent;
  FResultProc := nil;
  FResultProc2 := ResultProc;
  ShowModal;
end;
...
procedure TjwdDialog.ShowModal(const ResultProc: TjwdModalProc;
  const UseRootFormHiddingDialog: boolean);
var
  frm: TjwdForm;
  AError: string;
begin
  frm := GetParentJwdForm(UseRootFormHiddingDialog, AError);
  if Assigned(frm) then
    ShowModal(frm, ResultProc, UseRootFormHiddingDialog)
  else
    raise EjwdFormModalException.Create(AError);
end;

end.

Se ha omitido código por brevedad y sí tenéis razón, se utiliza la misma forma que se hace en FireMonkey, pero se ha añadido para ampliar la que ya existía con el método de objeto.

• DialogPosition; posición dónde situar el diálogo sobre el padre
• SetJwdDialogPosition: sobrescribiendo este método se puede modificar la posición del diálogo
• El Close pone el ActionClose a caFree para que, por defecto, automáticamente se libere el diálogo, sobreescribiendo este método se puede cambiar esta opción
• El Create incluye la posición APosition
• El ShowModal tiene dós parámetros:
• ResultProc:  el método de respuesta , tanto en método de objeto como en en método anónimo - al igual que FireMonkey
• UseRootFormHiddingDialog, si se llama un diálogo desde otro diálogo se puede ocultar el diálogo padre y mostrar el nuevo diálogo sobre el formualrio original, nos permite anidar dialogos y no perder la traza

A grandes rasgos el ShowModal hace lo siguiente: Comprueba si el padre es correctamente un TjwdForm, si es así en función del parámetro UseRootFormHiddingDialog, pondremos como padre al mismo diálogo o al formulario raiz (ocultado el diálogo padre si es necesario); una vez gestionado, bloquea el padre usando su método OnDeactivateForModalDlg , posiciona el nuevo diálogo y después lo muestra. Una vez finalizado el diálogo (se ha asignado ModalResult)  se devuelve el control al padre, no si antes llamar a su método OnActivarForModalDlg.

unit SampleDialog;
...
type
  TSampleDLG = class(TjwdDialog)
    ...
  end;
...
procedure TSampleDLG.Button1Click(Sender: TObject);
begin
  ModalResult := mrOK;
end;

procedure TSampleDLG.Button2Click(Sender: TObject);
begin
  ModalResult := mrCancel;
end;
...

Como ejemplo, para llamar a un diálogo de ejemplo desde un formulario de ejemplo

unit SampleForm;
...
type
  TSampleFrm = class(TjwdForm)
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
  private
    procedre ResultProc(const AModalResult: TModalResult);
  public
    procedure OnDeactivateForModalDlg; override;
    procedure OnActivateForModalDlg; override;
  end;
...
procedure TSampleFrm.Button1Click(Sender: TObject);
begin
  TjwdSampleDLG.Create(Self, jwdpTopCenter).ShowModal(ResultProc, True);
end;

procedre TSampleFrm.ResultProc(const AModalResult: TModalResult);
begin
  if AModalResult = mrOK then
    ShowMessage('Correcto')
  else
    ShowMessage('Cancelado');  
end;

procedure TSampleFrm.OnDeactivateForModalDlg; 
begin
  Button1.Enabled := False;
end;

procedure TSampleFrm.OnActivateForModalDlg; 
begin
  Button1.Enabled := True;
end;

...