Firemonkey TTabControl: adding tab items

Question

I've added a TTabItemwith this simple code but it does not compile:

unit Unit1;

interface

uses
  System.SysUtils, System.Types, System.UITypes, System.Classes, System.Variants,
  FMX.Types, FMX.Controls, FMX.Forms, FMX.Graphics, FMX.Dialogs,
  FMX.Controls.Presentation, FMX.StdCtrls, FMX.TabControl;

type
  TTabItem = class(FMX.TabControl.TTabItem)
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Single); override;
  end;

  TTabControl = class(FMX.TabControl.TTabControl)
    function GetTabIndex : integer;
    public
    procedure SetTabIndexv2(const Value: Integer);
    property TabIndex: Integer read GetTabIndex write SetTabIndexv2 default -1;
  end;

type
  TForm1 = class(TForm)
    tbc1: TTabControl;
    TabItem1: TTabItem;
    TabItem2: TTabItem;
    Button1: TButton;
    Button2: TButton;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.fmx}

{ TTabItem }

procedure TTabItem.MouseDown(Button: TMouseButton; Shift: TShiftState; X,
  Y: Single);
begin
  if (self.TabControl.ActiveTab <> self) and
     ((Button = TMouseButton.mbLeft) or (ssDouble in Shift)) then begin
    MessageDlg('[Tab Item] do you want to do this?', System.UITypes.TMsgDlgType.mtInformation,
      [System.UITypes.TMsgDlgBtn.mbYes, System.UITypes.TMsgDlgBtn.mbNo], 0, procedure (const AResult: TModalResult)
    begin
      begin
        case AResult of
          mrYes: self.TabControl.ActiveTab := self;
          mrNo:;
        end;
      end;
    end);
  end else begin
    inherited;
  end;
end;

{ TTabControl }

function TTabControl.GetTabIndex: integer;
begin
 result := FMX.TabControl.TTabControl(Self).TabIndex;
end;

procedure TTabControl.SetTabIndexv2(const Value: Integer);
begin
  if self.TabIndex <> value then begin
    MessageDlg('[tabcontrol] do you want to do this?', System.UITypes.TMsgDlgType.mtInformation,
      [System.UITypes.TMsgDlgBtn.mbYes, System.UITypes.TMsgDlgBtn.mbNo], 0, procedure (const AResult: TModalResult)
    begin
      begin
        case AResult of
        mrYes: begin
                 FMX.TabControl.TTabControl(Self).TabIndex := value;
               end;
        mrNo :  ;
        end;
      end;
    end);
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  if tbc1.TabIndex = 0 then
    tbc1.TabIndex := 1
  else
    tbc1.TabIndex := 0;
end;

procedure TForm1.Button2Click(Sender: TObject);
var
  tbitem: TTabItem;
begin
  tbitem := tbc1.Add( ); //Here Error !!!
end;

end.

[dcc32 Error] Unit1.pas(106): E2010 Incompatible types: 'Unit1.TTabItem' and 'FMX.TabControl.TTabItem'

Can Firemonkey TTabControl replicate VCL TPageControl.OnChanging event?

Answer 1

You are nearly there.

procedure TForm15.ButtonRandomSeedClick(Sender: TObject);
var
  tbitem: TTabItem;
begin
  tbitem := TabControl1.Add( TTabItem ) as TTabItem; //<<<<< Change 1
  tbItem.Text := 'Tab ' + IntToStr( TabControl1.TabCount );
end;

procedure TForm15.TabItem1MouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Single);
var
  tbitem: TTabItem;
begin
  tbitem := (Sender as TTabItem);  // <<<<<<this change for testing only  
  if (tbItem <> TabControl1.ActiveTab) and
     ((Button = TMouseButton.mbLeft) or (ssDouble in Shift)) then begin
    MessageDlg('[Tab Item] do you want to do this?', System.UITypes.TMsgDlgType.mtInformation,
      [System.UITypes.TMsgDlgBtn.mbYes, System.UITypes.TMsgDlgBtn.mbNo], 0, procedure (const AResult: TModalResult)
    begin
      begin
        case AResult of
          mrYes: TabControl1.ActiveTab := (Sender as TTabItem);
          mrNo:;
        end;
      end;
    end);
  end else begin
    inherited;
  end;

end;

works as you want. (My names are different to yours)