Fechar Form dentro de TabSheet

unit SFormTabSet;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ExtCtrls, Tabs, ComCtrls, Contnrs;

type

  TSFormTabSet = class;

  TFormInfo = class
  private
    FForm: TForm;
    FFormTabSet: TSFormTabSet;
    FTabIndex: Integer;
    FFormClose: TCloseEvent;
    procedure setForm(AForm: TForm);
    procedure setFormTabSet(AFormTabSet: TSFormTabSet);
  protected
    procedure formClose(Sender: TObject; var Action: TCloseAction);
  public
    constructor Create(var AForm: TForm; AFormTabSet: TSFormTabSet);
    procedure createTab;
    function getForm: TForm;
    function getFormTabSet: TSFormTabSet;
    function getTabIndex: Integer;
    procedure setTabIndex(const Value: Integer);
  end;

  TBackgroundImage = class(TImage)
  public
    constructor Create(AOwner: TComponent); override;
  end;

  TSFormTabSet = class(TCustomPanel)
  private
    FTabSet: TTabSet;
    FDockPanel: TPanel;
    FBackgroundImage: TBackgroundImage;
    FForms: TObjectList;
    FBackgroundColor: TColor;
    FImageList: TImageList;
    FFormIndex: Integer;


    procedure setBackgroundColor(const Value: TColor);
    procedure setBackgroundImage(const Value: TBackgroundImage);
    procedure createDockPanel;
    procedure createFormList;
    procedure createImage(Owner: TComponent);
    procedure createTabSet;
    function getFormIndex(var AForm: TForm): Integer; overload;

    procedure tabSetChange(Sender: TObject; NewTab: Integer;
      var AllowChange: Boolean);
  protected
    procedure DoAddDockClient(Client: TControl; const ARect: TRect); override;
    function getTabSet: TTabSet;
    function getDockPanel: TPanel;
    function getBackgroundImage: TBackgroundImage;
    function getForms: TObjectList;
    function getBackgroundColor: TColor;
    function getImageList: TImageList;
    function getFormIndex: Integer; overload;
    procedure setFormIndex(Index: Integer);
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    function addForm(AForm: TForm): Integer;
    function getForm(Index: Integer): TForm;
    procedure removeForm(Index: Integer); overload;
    procedure removeForm(AForm: TForm); overload;
    property DockManager;
  published
    property BackgroundImage: TBackgroundImage read FBackgroundImage write setBackgroundImage;
    property Align;
    property Alignment;
    property Anchors;
    property BiDiMode;
    property BackgroundColor: TColor read FBackgroundColor
      write setBackgroundColor;
    property Constraints;
    property Ctl3D;
    property Enabled;
    property ParentBiDiMode;
    property ParentBackground;
    property ParentColor;
    property ParentCtl3D;
    property ParentFont;
    property ParentShowHint;
    property PopupMenu;
    property ShowHint;
    property TabOrder;
    property TabStop;
    property Visible;
    property OnCanResize;
    property OnClick;
    property OnConstrainedResize;
    property OnContextPopup;
    property OnDockDrop;
    property OnDockOver;
    property OnDblClick;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDock;
    property OnEndDrag;
    property OnEnter;
    property OnExit;
    property OnGetSiteInfo;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property OnResize;
    property OnStartDock;
    property OnStartDrag;
    property OnUnDock;
  end;

implementation

{ TSFormTabSet }

function TSFormTabSet.addForm(AForm: TForm): Integer;
var
  FormInfo: TFormInfo;
  formIndex: Integer;
begin
  Result := -1;
  if getFormIndex >= 0 then
    TFormInfo(getForms[getFormIndex]).getForm.Hide;
  formIndex := getFormIndex(AForm);
  if formIndex >= 0 then
  begin
    getTabSet.TabIndex := TFormInfo(getForms[formIndex]).getTabIndex;
    AForm.Show;
    Abort;
  end  
  else
  begin
    if Align <> alClient then
      Align := alClient;
    FormInfo := TFormInfo.Create(AForm, Self);
    FormInfo.createTab;
    FormInfo.getForm.Position := poDesigned;
    FormInfo.getForm.Top := 0;
    FormInfo.getForm.Left := 0;
    FormInfo.getForm.Show;
    Result := getForms.Add(FormInfo);
    setFormIndex(Result);
  end;
end;


constructor TSFormTabSet.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  createTabSet;
  createDockPanel;
  createImage(getDockPanel);
  createFormList;

  BevelOuter := bvNone;
  Height := getTabSet.Height + 1;
  setBackgroundColor(clWhite);
  setFormIndex(-1);

end;

procedure TSFormTabSet.createDockPanel;
begin
  FDockPanel := TPanel.Create(Self);
  FDockPanel.Parent := Self;
  FDockPanel.Color := clWhite;
  FDockPanel.BevelOuter := bvNone;
  FDockPanel.Height := 0;
  FDockPanel.AutoSize := True;
  FDockPanel.Align := alClient;
end;

procedure TSFormTabSet.createFormList;
begin
  FForms := TObjectList.Create;
end;

procedure TSFormTabSet.createImage(Owner: TComponent);
begin
  FBackgroundImage := TBackgroundImage.Create(Owner);
  FBackgroundImage.Parent := TWinControl(Owner);
  FBackgroundImage.Align := alClient;
end;

procedure TSFormTabSet.createTabSet;
begin
  FTabSet := TTabSet.Create(Self);
  FTabSet.Parent :=  Self;
  FTabSet.Align := alTop;
  FTabSet.DitherBackground := False;
  FTabSet.SelectedColor := getBackgroundColor;
  FTabSet.Font.Name := ´Tahoma´;
  FTabSet.Height := FTabSet.TabHeight + 2;
  FTabSet.OnChange := tabSetChange;
end;

destructor TSFormTabSet.Destroy;
begin
  if Assigned(FForms) then
  begin
    FForms.Clear;
    FForms.Free;
  end;
  inherited;
end;

procedure TSFormTabSet.DoAddDockClient(Client: TControl; const ARect: TRect);
begin
  Abort;
end;

function TSFormTabSet.getBackgroundColor: TColor;
begin
  Result := FBackgroundColor;
end;

function TSFormTabSet.getBackgroundImage: TBackgroundImage;
begin
 Result := FBackgroundImage;
end;

function TSFormTabSet.getDockPanel: TPanel;
begin
  Result := FDockPanel;
end;

function TSFormTabSet.getForm(Index: Integer): TForm;
begin
  Result := TFormInfo(getForms[Index]).getForm;
end;

function TSFormTabSet.getFormIndex: Integer;
begin
  Result := FFormIndex;
end;

function TSFormTabSet.getForms: TObjectList;
begin
  Result := FForms;
end;

function TSFormTabSet.getImageList: TImageList;
begin
  Result := FImageList;
end;

function TSFormTabSet.getTabSet: TTabSet;
begin
  Result := FTabSet;
end;

function TSFormTabSet.getFormIndex(var AForm: TForm): Integer;
var
  i: Integer;
  FormInfo: TFormInfo;
begin
  Result := -1;
  for i := 0 to (getForms.Count - 1) do
  begin
    FormInfo := TFormInfo(getForms[i]);
    if (FormInfo.getForm = AForm) then
    begin
      Result := i;
      Break;
    end;  
  end;
end;

procedure TSFormTabSet.removeForm(Index: Integer);
var
  itemIndex, i: Integer;
begin
  itemIndex := TFormInfo(getForms[Index]).getTabIndex;
  getForms.Delete(Index);
  getTabSet.Tabs.Delete(itemIndex);
  for i := 0 to (getForms.Count - 1) do
  begin
    if TFormInfo(getForms[i]).getTabIndex > itemIndex then
      TFormInfo(getForms[i]).setTabIndex(
        TFormInfo(getForms[i]).getTabIndex - 1);
  end;

  if (itemIndex = 0) and (getTabSet.Tabs.Count > 0) then
    getTabSet.TabIndex := itemIndex
  else
    getTabSet.TabIndex := Pred(itemIndex);

  if (Index = 0) and (getForms.Count > 0)  then
    setFormIndex(Index)
  else
    setFormIndex(Pred(Index));

  if getFormIndex >= 0 then
    TFormInfo(getForms[getFormIndex]).getForm.Show;
end;

procedure TSFormTabSet.removeForm(AForm: TForm);
var
  i: Integer;
begin
  for i := 0 to (getForms.Count - 1) do
  begin
    if TFormInfo(getForms[i]).getForm = AForm then
    begin
      removeForm(i);
      Break;
    end;  
  end;
end;

procedure TSFormTabSet.setBackgroundColor(const Value: TColor);
begin
  if FBackgroundColor <> Value then
  begin
    FBackgroundColor := Value;
    getDockPanel.Color := getBackgroundColor;
    getTabSet.SelectedColor := getBackgroundColor;
  end;
end;

procedure TSFormTabSet.setBackgroundImage(const Value: TBackgroundImage);
begin
  FBackgroundImage.Assign(Value);
end;

procedure TSFormTabSet.setFormIndex(Index: Integer);
begin
  FFormIndex := Index;
end;

procedure TSFormTabSet.tabSetChange(Sender: TObject; NewTab: Integer;
  var AllowChange: Boolean);
var
  i: Integer;
  FormInfo: TFormInfo;
begin
  for i := 0 to (getForms.Count - 1) do
  begin
    FormInfo := TFormInfo(getForms[i]);
    if FormInfo.getTabIndex = NewTab then
    begin
      TFormInfo(getForms[getFormIndex]).getForm.Hide;
      FormInfo.getForm.Show;
      setFormIndex(i);
    end;
  end;
end;

{ TFormInfo }

constructor TFormInfo.Create(var AForm: TForm;  AFormTabSet: TSFormTabSet);
begin
  setForm(AForm);
  FFormClose := AForm.OnClose;
  AForm.OnClose := formClose;
  setFormTabSet(AFormTabSet);
  setTabIndex(-1);
end;

procedure TFormInfo.createTab;
begin
  if getTabIndex = -1 then
  begin
    setTabIndex(getFormTabSet.getTabSet.Tabs.Add(FForm.Caption));
    getFormTabSet.getTabSet.TabIndex := getTabIndex;
  end;
  getForm.ManualDock(FFormTabSet.getDockPanel);
end;

procedure TFormInfo.formClose(Sender: TObject; var Action: TCloseAction);
begin
  if Assigned(FFormClose) then
    FFormClose(Sender, Action);
  if Action <> caNone then
  begin
    if Sender is TForm then
    begin
      getFormTabSet.removeForm(TForm(Sender));
      TForm(Sender).OnClose := FFormClose;
    end;
  end;
end;

function TFormInfo.getForm: TForm;
begin
  Result := FForm;
end;

function TFormInfo.getFormTabSet: TSFormTabSet;
begin
  Result := FFormTabSet;
end;

function TFormInfo.getTabIndex: Integer;
begin
  Result := FTabIndex;
end;

procedure TFormInfo.setForm(AForm: TForm);
begin
  FForm := AForm;
end;

procedure TFormInfo.setFormTabSet(AFormTabSet: TSFormTabSet);
begin
  FFormTabSet := AFormTabSet;
end;

procedure TFormInfo.setTabIndex(const Value: Integer);
begin
  FTabIndex := Value;
end;

{ TBackgroundImage }

constructor TBackgroundImage.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  SetSubComponent(True);
end;

end.