unit TestTabPanelA;

{$mode objfpc}{$H+}

interface

uses
  //Classes, SysUtils, Types, LResources, Forms, Controls, Graphics, Dialogs, LCLType;
SysUtils, Types, Classes, LCLStrConsts, LCLType, LCLProc, LResources, Controls,
Forms, StdCtrls, lMessages, GraphType, Graphics, LCLIntf, CustomTimer, Themes,
LCLClasses, Menus, PopupNotifier, ImgList, contnrs, FGL;


type


  TTestTabPanelATab = class;

  TBeforeShowPageEvent = procedure (ASender: TObject; ANewPage: TTestTabPanelATab; ANewIndex: Integer) of object;

  TTestTabPanelATab = class(TCustomControl)
  private
    FOnBeforeShow: TBeforeShowPageEvent;
  protected
    procedure SetParent(AParent: TWinControl); override;
  public
    constructor Create(TheOwner: TComponent); override;
    destructor Destroy; override;
  published
    // Lazarus-specific TTestTabPanelATab events
    // OnBeforeShow occurs before a page is displayed, so that
    // preparations can be executed in it's user interface, for example
    property OnBeforeShow: TBeforeShowPageEvent read FOnBeforeShow write FOnBeforeShow;
    // Other events and properties
    property BiDiMode;
    property ChildSizing;
    property Color;
    property Left stored False;
    property Top stored False;
    property Width stored False;
    property Height stored False;
    property OnContextPopup;
    property OnEnter;
    property OnExit;
    property OnMouseDown;
    property OnMouseEnter;
    property OnMouseLeave;
    property OnMouseMove;
    property OnMouseUp;
    property OnMouseWheel;
    property OnMouseWheelDown;
    property OnMouseWheelUp;
    property OnResize;
    property ParentBiDiMode;
    property ParentShowHint;
    property PopupMenu;
    property TabOrder stored False;
    property Visible stored False;
  end;

  { TUNBPages }



  TTestTabPanelA = class;

  TTestTabPanelATabs = class(TStrings)
  private
    FPageList: TListWithEvent;
    FNotebook: TTestTabPanelA;
    procedure PageListChange(Ptr: Pointer; AnAction: TListNotification);
  protected
    function Get(Index: Integer): String; override;
    function GetCount: Integer; override;
    function GetObject(Index: Integer): TObject; override;
    procedure Put(Index: Integer; const S: String); override;
  public
    constructor Create(thePageList: TListWithEvent; theNotebook: TTestTabPanelA);
    procedure Clear; override;
    procedure Delete(Index: Integer); override;
    procedure Insert(Index: Integer; const S: String); override;
//    procedure Move(CurIndex, NewIndex: Integer); override;
  end;






  TTestTabPanelA = class(TCustomControl)
  private
    FPages: TStrings; // TTestTabPanelATabs
    FPageIndex: Integer;
    FPageList: TListWithEvent;
    function GetActivePage: String;
    function GetActivePageComponent: TTestTabPanelATab;
    function GetPage(AIndex: Integer): TTestTabPanelATab;
    function GetPageCount : integer;
    function GetPageIndex: Integer;
{    function FindVisiblePage(Index: Integer): Integer;}
    procedure InsertPage(APage: TTestTabPanelATab; Index: Integer);
{    procedure MovePage(APage: TCustomPage; NewIndex: Integer);
    procedure RemovePage(Index: Integer);
    procedure SetActivePage(const Value: String);}
    procedure SetPageIndex(AValue: Integer);
  public
    constructor Create(TheOwner: TComponent); override;
    destructor Destroy; override;
    procedure ShowControl(AControl: TControl); override;
{    function TabIndexAtClientPos(ClientPos: TPoint): integer;
    function TabRect(AIndex: Integer): TRect;
    function GetImageIndex(ThePageIndex: Integer): Integer; virtual;
    function IndexOf(APage: TCustomPage): integer;
    function CustomPage(Index: integer): TCustomPage;}
  public
    property ActivePage: String read GetActivePage;// write SetActivePage; // should not be published because the read can raise an exception
    property ActivePageComponent: TTestTabPanelATab read GetActivePageComponent;// write SetActivePage; // should not be published because the read can raise an exception
    property Page[Index: Integer]: TTestTabPanelATab read GetPage;
    property PageCount: integer read GetPageCount;
//    property PageList: TList read FPageList;
  published
    // LCL TTestTabPanelA specific properties
    property PageIndex: Integer read GetPageIndex write SetPageIndex default -1;
    property Pages: TStrings read FPages;
    // Generic properties
    property Align;
    property AutoSize;
    property Anchors;
    property BiDiMode;
    property BorderSpacing;
    property Color;
    property Constraints;
    property DragCursor;
    property DragMode;
    property Enabled;
//    property OnChange;
    property OnChangeBounds;
//    property OnChanging;
    property OnContextPopup;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDrag;
    property OnEnter;
    property OnExit;
    property OnMouseDown;
    property OnMouseEnter;
    property OnMouseLeave;
    property OnMouseMove;
    property OnMouseUp;
    property OnMouseWheel;
    property OnMouseWheelDown;
    property OnMouseWheelUp;
    property OnResize;
    property OnStartDrag;
//    property Options;
//    property PageIndex;
    property ParentBiDiMode;
    property PopupMenu;
    property TabOrder;
    property TabStop;
  end;



procedure Register;

implementation




constructor TTestTabPanelATab.Create(TheOwner: TComponent);
begin
  inherited Create(TheOwner);

  ControlStyle := ControlStyle + [csAcceptsControls, csDesignFixedBounds, csNoDesignVisible, csNoFocus];

  // height and width depends on parent, align to client rect
  Align := alClient;
  Caption := '';
  Visible := False;
end;

destructor TTestTabPanelATab.Destroy;
begin

  if (Parent <> nil) and (Parent is TTestTabPanelA) then begin
    TTestTabPanelA(Parent).FPageList.Remove(Self);
  end;

  inherited Destroy;
end;

procedure TTestTabPanelATab.SetParent(AParent: TWinControl);
var
  OldParent: TWinControl;
  ParentNotebook: TTestTabPanelA;
  i: integer;
begin
  if (AParent = Parent) {or (pfInserting in FFlags)} then Exit;

  OldParent := Parent;
  if (OldParent <> AParent) and (OldParent <> nil) and (OldParent is TTestTabPanelA) {and (not (pfRemoving in FFlags))} then begin
    // remove from old pagelist
    ParentNotebook := TTestTabPanelA(OldParent);
    i := ParentNotebook.FPageList.IndexOf(Self);
    ParentNotebook.Pages.Delete(i);
  end;

  inherited SetParent(AParent);

  if (Parent <> nil) and (Parent is TTestTabPanelA) then begin
    // add to new pagelist
    ParentNotebook := TTestTabPanelA(Parent);
    i := ParentNotebook.FPageList.IndexOf(Self);
    if i < 0 then  ParentNotebook.InsertPage(Self, ParentNotebook.Pages.Count);
  end;
end;








{------------------------------------------------------------------------------
  TTestTabPanelATabs Constructor
 ------------------------------------------------------------------------------}
constructor TTestTabPanelATabs.Create(thePageList: TListWithEvent; theNotebook: TTestTabPanelA);
begin
  inherited Create;
  fPageList := thePageList;
  fPageList.OnChange:=@PageListChange;
  fNotebook := theNotebook;
end;

{------------------------------------------------------------------------------
  procedure TTestTabPanelATabs.PageListChange(Ptr: Pointer; AnAction: TListNotification);
 ------------------------------------------------------------------------------}
procedure TTestTabPanelATabs.PageListChange(Ptr: Pointer; AnAction: TListNotification);
{var
  APage: TUNBPage;}
begin
{  if (AnAction=lnAdded) then
  begin
    APage:=TObject(Ptr) as TUNBPage;
    if not (pfInserting in APage.FFlags) then
      APage.Parent:=fNotebook;
  end;}
end;


function TTestTabPanelATabs.Get(Index: Integer): string;
begin
  if (Index<0) or (Index>=fPageList.Count) then exit;
  Result := TTestTabPanelATab(fPageList[Index]).Caption;
end;


function TTestTabPanelATabs.GetCount: Integer;
begin
  Result := fPageList.Count;
end;


function TTestTabPanelATabs.GetObject(Index: Integer): TObject;
begin
  if (Index<0) or (Index>=fPageList.Count) then     exit;
  Result := TTestTabPanelATab(fPageList[Index]);
end;

procedure TTestTabPanelATabs.Put(Index: Integer; const S: String);
begin
  if (Index<0) or (Index>=fPageList.Count) then  exit;
  //debugln(['TTestTabPanelATabs.Put ',DbgSName(FNotebook),' ',Index,' S="',S,'"']);
  TTestTabPanelATab(fPageList[Index]).Caption := S;
end;

procedure TTestTabPanelATabs.Clear;
begin
  while fPageList.Count>0 do Delete(fPageList.Count-1);
end;

procedure TTestTabPanelATabs.Delete(Index: Integer);
var
  APage: TTestTabPanelATab;
begin
  // Make sure Index is in the range of valid pages to delete
  if (Index < 0) or (Index >= fPageList.Count) then Exit;

  APage := TTestTabPanelATab(fPageList[Index]);
  // delete handle
  APage.Parent := nil;
  // free the page
  Application.ReleaseComponent(APage);
end;

procedure TTestTabPanelATabs.Insert(Index: Integer; const S: String);
var
  NewPage: TTestTabPanelATab;
  NewOwner: TComponent;
begin
  NewOwner := FNotebook.Owner;
  if NewOwner = nil then
    NewOwner := FNotebook;
  NewPage := TTestTabPanelATab.Create(NewOwner);
  NewPage.Caption := S;

  FNoteBook.InsertPage(NewPage,Index);
end;








constructor TTestTabPanelA.Create(TheOwner: TComponent);
var
  lSize: TSize;
begin
  inherited Create(TheOwner);

  FPageList := TListWithEvent.Create;
  FPageIndex := -1;
  FPages := TTestTabPanelATabs.Create(FPageList, Self);

  ControlStyle := []; // do not add csAcceptsControls
  TabStop := true;

  // Initial size
  lSize := GetControlClassDefaultSize();
  SetInitialBounds(0, 0, lSize.CX, lSize.CY);
end;

destructor TTestTabPanelA.Destroy;
begin
  FreeAndNil(FPageList);
  FreeAndNil(FPages);

  inherited Destroy;
end;

procedure TTestTabPanelA.ShowControl(AControl: TControl);
var
  i: Integer;
begin
  if AControl = ActivePageComponent then exit;
  i := FPageList.IndexOf(Pointer(aControl));
  if i >= 0 then  PageIndex := i;
  inherited ShowControl(AControl);
end;



function TTestTabPanelA.GetActivePage: String;
begin
  Result := Page[GetPageIndex].Caption;
end;

function TTestTabPanelA.GetActivePageComponent: TTestTabPanelATab;
begin
  Result := Page[GetPageIndex];
end;

function TTestTabPanelA.GetPage(AIndex: Integer): TTestTabPanelATab;
begin
  if (AIndex < 0) or (AIndex >= FPageList.Count) then result := nil;
  Result := TTestTabPanelATab(FPageList.Items[AIndex]);
end;

function TTestTabPanelA.GetPageCount: Integer;
begin
  Result := FPages.Count;
end;

function TTestTabPanelA.GetPageIndex: Integer;
begin
  Result := FPageIndex;
end;

procedure TTestTabPanelA.InsertPage(APage: TTestTabPanelATab; Index: Integer);
begin
  if FPageList.IndexOf(APage) >= 0 then Exit;

  FPageList.Insert(Index, APage);

  APage.Parent := Self;
  APage.Align := alClient;
  APage.Visible := False;
  APage.ControlStyle := APage.ControlStyle + [csNoDesignVisible];

  if PageIndex = -1 then SetPageIndex(Index);
end;

procedure TTestTabPanelA.SetPageIndex(AValue: Integer);
var
  pg: TTestTabPanelATab;
begin
  if (AValue < -1) or (AValue >= Pages.Count) then Exit;
  if FPageIndex = AValue then exit;

  // Hide the previously shown page
  if (FPageIndex >= 0) and (FPageIndex < Pages.Count) then begin
    pg := Page[FPageIndex];
    pg.ControlStyle := pg.ControlStyle + [csNoDesignVisible];
    pg.Visible := False;
  end;

  // Update the property
  FPageIndex := AValue;
  if (FPageIndex = -1) then exit;

  // And show the new one
  pg := Page[FPageIndex];
  if Assigned(pg.FOnBeforeShow) then pg.FOnBeforeShow(Self, pg, FPageIndex); // OnBeforeShow event

  pg.Visible := True;
  pg.ControlStyle := pg.ControlStyle - [csNoDesignVisible];
  pg.Align := alClient;
end;




procedure Register;
begin
  RegisterComponents('TestControls',[TTestTabPanelA]);
  RegisterNoIcon([TTestTabPanelATab]);

  //RegisterComponents('Additional',[TNotebook]);
  //RegisterNoIcon([TPage]);

end;

end.