unit ugradtabcontrol; {------------------------------------------------------------------------------- @name GradTabControl @author Eugen Bolz @lastchange 07.10.2008 @version 0.1 @comments TGradTabControl is based on TNotebook/TPageControl/TTabControl @license http://creativecommons.org/licenses/LGPL/2.1/ @todo: - If a Button isnt visible but focused the bar should move to the button - working - Close Button at Tabs - Drawer needed or first style wishes - Button Events accessable from Page-Events - TabBar Events accessable from TGradTabControl - Maybe rename TGradTabControl to TCustomPageControl and of these TGradTabControl and TGradPageControl ------------------------------------------------------------------------------} {$mode objfpc}{$H+} {.$DEFINE DEBUGTAB} interface uses Classes,LResources, SysUtils, Menus, LCLType, LCLProc, ExtCtrls, Graphics, ugradbtn, Controls, uRotateBitmap, Buttons, Forms, ImgList; type TGradTabControl = class; { TGradTabPageButton } TGradTabPageButton = class( TGradButton ) private FCloseButton : TGradButton; FShowCloseButton : Boolean; procedure AlignCloseButton; procedure SetShowCloseButton(AValue: Boolean); protected procedure SetRotateDirection(const Value: TRotateDirection); override; procedure RealSetText(const Value: TCaption); override; procedure SetAutoHeightBorderSpacing(const AValue: Integer); override; procedure SetAutoWidthBorderSpacing(const AValue: Integer); override; procedure SetShowGlyph(const Value: Boolean); override; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; procedure Resize; override; procedure SetBounds(aLeft, aTop, aWidth, aHeight: integer); override; property ShowCloseButton : Boolean read FShowCloseButton write SetShowCloseButton default false; published property OnStartDock; property OnStartDrag; property OnDockDrop; property OnDockOver; property OnDragDrop; property OnDragOver; property OnEndDock; property OnEndDrag; property OnMouseDown; property OnMouseUp; property OnMouseMove; property OnMouseWheel; property OnMouseWheelUp; property OnMouseWheelDown; end; TGradTabPageButtonClickEvent = procedure(GradTabControl : TGradTabControl;AIndex : Integer) of object; TGradTabPageButtonMouseDownUpEvent = procedure(GradTabControl : TGradTabControl;Button: TMouseButton; Shift: TShiftState; X, Y, AIndex: Integer) of object; TGradTabPageButtonMouseMoveEvent = procedure(GradTabControl : TGradTabControl; Shift: TShiftState; X, Y, AIndex: Integer) of object; //Properties of the Tab should be accessable from here TGradTabPage = class(TCustomControl) private FActiveTabColor: TColor; FButton : TGradTabPageButton; FCaption: TCaption; FGradTabControl : TGradTabControl; FFlags: TPageFlags; FImageIndex: Integer; FNormalTabColor: TColor; FOwnerTabColor: Boolean; FTabVisible,FCurrentlyDestroying,FShowCloseButton : Boolean; function GetTabButtonLayout: TButtonLayout; function GetTabColor: TColor; function GetTabGlyph: TBitmap; function GetTabShowGlyph: Boolean; function GetTabTextAlignment: TTextAlignment; function GetTabPopupMenu : TPopupMenu; function GetText : TCaption; procedure SetImageIndex(const AValue: Integer); procedure SetTabButtonLayout(const AValue: TButtonLayout); procedure SetTabColor(const AValue: TColor); procedure SetTabGlyph(const AValue: TBitmap); procedure SetTabPopupMenu(Value : TPopupMenu); procedure SetTabShowGlyph(const AValue: Boolean); procedure SetTabTextAlignment(const AValue: TTextAlignment); procedure SetText(const Value: TCaption); procedure SetEnabled(Value: Boolean); override; protected function GetPageIndex: integer; procedure SetPageIndex(AValue: Integer); procedure SetParent(NewParent: TWinControl); override; procedure SetShowCloseButton(Value: Boolean); procedure SetTabVisible(Value: Boolean); public constructor Create(AOwner: TComponent); override; destructor Destroy; override; procedure DestroyHandle; override; procedure Paint; override; property TabButton : TGradTabPageButton read FButton; function VisibleIndex: integer; procedure UpdateImage; published property TabVisible : Boolean read FTabVisible write SetTabVisible default true; property PageIndex : Integer read GetPageIndex write SetPageIndex; property Caption : TCaption read GetText write SetText; property ShowCloseButton : Boolean read FShowCloseButton write SetShowCloseButton default false; property TabPopupMenu : TPopupMenu read GetTabPopupMenu write SetTabPopupMenu; property Color; property TabColor : TColor read GetTabColor write SetTabColor; property TabTextAlignment : TTextAlignment read GetTabTextAlignment write SetTabTextAlignment default taCenter; property TabGlyph : TBitmap read GetTabGlyph write SetTabGlyph; property TabShowGlyph : Boolean read GetTabShowGlyph write SetTabShowGlyph; property TabButtonLayout : TButtonLayout read GetTabButtonLayout write SetTabButtonLayout; property ImageIndex : Integer read FImageIndex write SetImageIndex default 0; property Enabled; property PopupMenu; property OnStartDock; property OnStartDrag; property OnDockDrop; property OnDockOver; property OnDragDrop; property OnDragOver; property OnEndDock; property OnEndDrag; property OnMouseDown; property OnMouseUp; property OnMouseMove; property OnMouseWheel; property OnMouseWheelUp; property OnMouseWheelDown; property ActiveTabColor : TColor read FActiveTabColor write FActiveTabColor default clGreen; property NormalTabColor : TColor read FNormalTabColor write FNormalTabColor default clBlue; property OwnerTabColor : Boolean read FOwnerTabColor write FOwnerTabColor default false; end; { TFormPage } TFormPage = class(TGradTabPage) private FDestroyPageAtDestroy: Boolean; FOldForm : TCustomForm; FShowPageAtDestroy: Boolean; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; procedure FormToPage(TheForm : TCustomForm); procedure PageToForm(AShow : Boolean); published property TheForm : TCustomForm read FOldForm; property ShowPageAtDestroy : Boolean read FShowPageAtDestroy write FShowPageAtDestroy default false; property DestroyPageAtDestroy : Boolean read FDestroyPageAtDestroy write FDestroyPageAtDestroy default false; end; { TGradTabPagesBar } TTabs = Array of Integer; { @name TGradTabPagesBar @comments Shows and Order the TabButtons } TGradTabPagesBar = class(TCustomControl) private FActiveTabColor: TColor; FNormalTabColor: TColor; FPageList : TListWithEvent; FTabControl : TGradTabControl; FShowFromButton, FMovedTo : Integer; FTabPosition : TTabPosition; FTabHeight,FLongWidth : Integer; FActiveIndex: Integer; protected procedure InsertButton(AButton: TGradTabPageButton; Index: Integer); procedure OrderButtons; procedure UnFocusButton(Index: Integer); procedure FocusButton(Index: Integer); procedure SetTabPosition(Value: TTabPosition); function IsVisible(Index: Integer) : Boolean; procedure ChangeLeftTop(LastTabPosition : TTabPosition); function GetViewedTabs : TTabs; function GetViewableTabs(FromIndex : Integer) : TTabs; function GetTabsOfSide(FromIndex : Integer; FromLeftSide : Boolean) : TTabs; procedure ScrollToTab(PIndex : Integer); public constructor Create(AOwner: TComponent; var thePageList: TListWithEvent; TheTabControl : TGradTabControl); procedure Paint; override; procedure Resize; override; procedure MoveToNext; procedure MoveToPrior; procedure MoveTo(Num: Integer); procedure MoveToNorm; property TabPosition : TTabPosition read FTabPosition write SetTabPosition; published property OnStartDock; property OnStartDrag; property OnDockDrop; property OnDockOver; property OnDragDrop; property OnDragOver; property OnEndDock; property OnEndDrag; property OnMouseDown; property OnMouseUp; property OnMouseMove; property OnMouseWheel; property OnMouseWheelUp; property OnMouseWheelDown; property ActiveTabColor : TColor read FActiveTabColor write FActiveTabColor default clGreen; property NormalTabColor : TColor read FNormalTabColor write FNormalTabColor default clBlue; end; // Is parent of the Next/Prev Buttons { @name TGradTabBar @description } TGradTabBar = class(TCustomControl) public constructor Create(AOwner: TComponent); override; destructor Destroy; override; procedure Paint; override; end; TGradTabPages = class(TStrings) private FPageList: TListWithEvent; FGradTabControl : TGradTabControl; 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(var thePageList: TListWithEvent; theGradTabControl: TGradTabControl); procedure Clear; override; procedure Delete(Index: Integer); override; procedure Insert(Index: Integer; const S: String); override; procedure Move(CurIndex, NewIndex: Integer); override; end; { TGradTabControl } TGradTabControl = class(TCustomControl) private FAutoShowScrollButton: Boolean; FImages: TImageList; FMoveIncrement: Integer; FLeftButton, FRightButton : TGradButton; FOnPageChanged: TNotifyEvent; FShowLeftTopScrollButton: Boolean; FShowRightBottomScrollButton: Boolean; FTabStrings : TStrings; //TGradTabPages FPageList: TList; //Is Managed by TGradTabPages FOnTabButtonClick : TGradTabPageButtonClickEvent; FOnTabButtonMouseDown, FOnTabButtonMouseUp : TGradTabPageButtonMouseDownUpEvent; FOnTabButtonMouseMove : TGradTabPageButtonMouseMoveEvent; FPageIndex, fPageIndexOnLastChange, fPageIndexOnLastShow, FTabHeight, FLongWidth : Integer; FBar : TGradTabBar; FImageChangeLink : TChangeLink; FPagesBar: TGradTabPagesBar; FPagesPopup : TPopupMenu; FTabPosition : TTabPosition; FLongTabs : Boolean; procedure AssignEvents(TheControl : TCustomControl); procedure AlignPage(APage : TGradTabPage; ARect : TRect); procedure AlignPages; function GetActiveTabColor: TColor; function GetNormalTabColor: TColor; procedure ImageListChange(Sender: TObject); procedure SetActiveTabColor(const AValue: TColor); procedure SetNormalTabColor(const AValue: TColor); procedure UpdateTabImages; function GetCurrentPage : TGradTabPage; function GetPage(AIndex: Integer) : TGradTabPage; function GetCount : Integer; function GetPagesBarDragOver: TDragOverEvent; procedure MoveTab(Sender: TObject; NewIndex: Integer); function FindVisiblePage(Index: Integer): Integer; procedure PageButtonMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); procedure PageButtonMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); procedure PageButtonMouseClick(Sender: TObject); procedure PopupMouseClick(Sender: TObject); procedure PageButtonMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); procedure SetAutoShowScrollButtons(const AValue: Boolean); procedure SetImages(const AValue: TImageList); procedure SetLongWidth(const AValue: Integer); procedure SetShowLeftTopScrollButton(const AValue: Boolean); procedure SetShowRightBottomScrollButton(const AValue: Boolean); //SubControl Events procedure SubMouseWheel(Sender: TObject; Shift: TShiftState; WheelDelta: Integer; MousePos: TPoint; var Handled: Boolean); procedure SubMouseWheelUp(Sender: TObject; Shift: TShiftState; MousePos: TPoint; var Handled: Boolean); procedure SubMouseWheelDown(Sender: TObject; Shift: TShiftState; MousePos: TPoint; var Handled: Boolean); procedure SubMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); procedure SubMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); procedure SubMouseClick(Sender: TObject); procedure SubMouseDblClick(Sender: TObject); procedure SubMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); procedure SubDragOver(Sender, Source: TObject; X,Y: Integer; State: TDragState; var Accept: Boolean); procedure SubDragDrop(Sender, Source: TObject; X,Y: Integer); //End procedure PopupTabs(Sender: TObject); procedure MoveLeftTopClick(Sender: TObject); procedure MoveRightBottomClick(Sender: TObject); procedure PageRemoved(Index: Integer); procedure SetCurrentPage(Value : TGradTabPage); procedure SetCurrentPageNum(Value: Integer); procedure SetPagesBarDragOver(const AValue: TDragOverEvent); procedure ShowPage(Index: Integer); procedure ShowCurrentPage; procedure UnShowPage(Index: Integer); protected function ChildClassAllowed(ChildClass: TClass): boolean; override; procedure InsertPage(APage: TGradTabPage; Index: Integer); procedure AddRemovePageHandle(APage: TGradTabPage); procedure RemovePage(Index: Integer); procedure InvPaint; procedure SetTabHeight(Value: Integer); procedure SetTabs(Value: TStrings); procedure SetTabPosition(Value : TTabPosition); procedure SetLongTabs(Value : Boolean); procedure Change; procedure UpdateTabProperties; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; function GetTabRect(AIndex : Integer) : TRect; function AddPage(AName: String) : Integer; function AddPage(APage: TGradTabPage) : Integer; function GetTabBarSize(TabPos : TTabPosition) : Integer; function GetClientRect: TRect; override; procedure Paint; override; procedure Resize; override; procedure UpdateAllDesignerFlags; procedure UpdateDesignerFlags(APageIndex: integer); property Page[Index: Integer] : TGradTabPage read GetPage; property Bar : TGradTabBar read FBar; property PagesBar : TGradTabPagesBar read FPagesBar; property PageList: TList read FPageList; property Tabs : TStrings read FTabStrings write SetTabs; property PageCount : Integer read GetCount; published property Align; property ControlState; property ControlStyle; property ActivePage : TGradTabPage read GetCurrentPage write SetCurrentPage; property OnTabButtonClick : TGradTabPageButtonClickEvent read FOnTabButtonClick write FOnTabButtonClick; property OnTabButtonMouseDown : TGradTabPageButtonMouseDownUpEvent read FOnTabButtonMouseDown write FOnTabButtonMouseDown; property OnTabButtonMouseUp : TGradTabPageButtonMouseDownUpEvent read FOnTabButtonMouseUp write FOnTabButtonMouseUp; property OnTabButtonMouseMove : TGradTabPageButtonMouseMoveEvent read FOnTabButtonMouseMove write FOnTabButtonMouseMove; property OnStartDock; property OnStartDrag; property OnDockDrop; property OnDockOver; property OnDragDrop; property OnDragOver; property OnEndDock; property OnEndDrag; property OnMouseDown; property OnMouseUp; property OnMouseMove; property OnMouseWheel; property OnMouseWheelUp; property OnMouseWheelDown; property OnClick; property OnDblClick; property PageIndex : Integer read FPageIndex write SetCurrentPageNum; property TabHeight : Integer read FTabHeight write SetTabHeight; property TabPosition : TTabPosition read FTabPosition write SetTabPosition default tpTop; property LongTabs : Boolean read FLongTabs write SetLongTabs; property LongWidth: Integer read FLongWidth write SetLongWidth; property MoveIncrement : Integer read FMoveIncrement write FMoveIncrement; property OnPageChanged: TNotifyEvent read FOnPageChanged write FOnPageChanged; property AutoShowScrollButtons : Boolean read FAutoShowScrollButton write SetAutoShowScrollButtons default true; property ShowLeftTopScrollButton : Boolean read FShowLeftTopScrollButton write SetShowLeftTopScrollButton; property ShowRightBottomScrollButton : Boolean read FShowRightBottomScrollButton write SetShowRightBottomScrollButton; property Images : TImageList read FImages write SetImages; property NormalTabColor: TColor read GetNormalTabColor write SetNormalTabColor default clBlue; property ActiveTabColor: TColor read GetActiveTabColor write SetActiveTabColor default clGreen; //property ShowTabs : Boolean; { TODO } end; procedure Register; function IsAssigned(var Obj : TObject) : String; function BoolStr(BV : Boolean) : String; function IncAr(var Ar : TTabs) : Integer; function Form2Page(theTabControl : TGradTabControl; theForm : TCustomForm) : TFormPage; implementation uses gradtabcontroleditor, ComponentEditors, math; const FPageCount : Integer = 0; {------------------------------------------------------------------------------- Register ------------------------------------------------------------------------------} procedure Register; begin RegisterComponents('Misc',[TGradTabControl]); RegisterComponentEditor(TGradTabControl,TGradTabControlComponentEditor); RegisterComponentEditor(TGradTabPage,TGradTabPageComponentEditor); RegisterNoIcon([TGradTabPage]); end; function IsAssigned(var Obj: TObject): String; begin Result := 'Assigned: '+BoolToStr(Assigned(Obj),true); end; function BoolStr(BV: Boolean): String; begin Result := BoolToStr(BV,true); end; function ValueInArray(Needle : Integer; Stack : TTabs) : Boolean; var i : Integer; begin Result := false; {$IFDEF DEBUGTAB} DebugLn('ValueInArray: Needle=%d Low=%d High=%d',[Needle, Low(Stack), High(Stack)]); {$ENDIF} for i := Low(Stack) to High(Stack) do if Needle =Stack[i] then begin Result := true; Exit; end; end; function IncAr(var Ar : TTabs) : Integer; begin SetLength(Ar, Length(Ar)+1); Result := Length(Ar)-1; end; function Form2Page(theTabControl: TGradTabControl; theForm: TCustomForm ): TFormPage; begin Result := TFormPage.Create(theTabControl); Result.FormToPage(theForm); Result.ShowPageAtDestroy:=false; Result.Parent := theTabControl; end; {------------------------------------------------------------------------------- TGradTabPageButton Create(AOwner: TComponent ------------------------------------------------------------------------------} constructor TGradTabPageButton.Create(AOwner: TComponent); var tempPic : TPicture; begin inherited Create(AOwner); ControlStyle := ControlStyle+[csNoDesignSelectable,csDesignInteractive]-[csCaptureMouse]; FCloseButton := TGradButton.Create(Self); FCloseButton.Width:=12; FCloseButton.Height:=12; TextAlignment:=taCenter; FCloseButton.Left:=1; FCloseButton.Top:=1; FCloseButton.Caption:=''; FCloseButton.ShowGlyph:=true; try tempPic := TPicture.Create; tempPic.LoadFromLazarusResource('close_btn'); FCloseButton.Glyph.Assign(tempPic.Graphic); finally tempPic.Free; end; FCloseButton.BorderSides:=[]; FCloseButton.Color:=clRed; FShowCloseButton:=false; SetSubComponent(true); end; destructor TGradTabPageButton.Destroy; begin FCloseButton.Free; inherited Destroy; end; {------------------------------------------------------------------------------- TGradTabPageButton AlignCloseButton ------------------------------------------------------------------------------} procedure TGradTabPageButton.AlignCloseButton; var TheRect : TRect; DisplayWidth, DisplayHeight: Integer; NewTop,NewLeft : Integer; begin if not HasParent then Exit; GetBackgroundRect(TheRect); DisplayWidth:= TheRect.Right-TheRect.Left; DisplayHeight:=TheRect.Bottom-TheRect.Top; case RotateDirection of rdNormal: begin NewTop:=(DisplayHeight div 2)-(FCloseButton.Height div 2)-1; NewLeft:=DisplayWidth-(FCloseButton.Width)+1; end; rdRight: begin NewTop:=DisplayHeight-(FCloseButton.Height)+1; NewLeft:=(DisplayWidth div 2)-(FCloseButton.Width div 2); end; rdLeft: begin NewTop:=1; NewLeft:=(DisplayWidth div 2)-(FCloseButton.Width div 2); end; end; FCloseButton.Top:=NewTop+TheRect.Top; FCloseButton.Left:=NewLeft+TheRect.Left; end; {------------------------------------------------------------------------------- TGradTabPageButton SetShowCloseButton(AValue: Boolean) ------------------------------------------------------------------------------} procedure TGradTabPageButton.SetShowCloseButton(AValue: Boolean); begin if AValue = FShowCloseButton then Exit; FShowCloseButton:=AValue; if AValue then begin AlignCloseButton; FCloseButton.Parent:=Self; end else begin FCloseButton.Parent:=nil; end; end; {------------------------------------------------------------------------------- TGradTabPageButton Resize ------------------------------------------------------------------------------} procedure TGradTabPageButton.Resize; begin inherited Resize; AlignCloseButton; end; procedure TGradTabPageButton.SetBounds(aLeft, aTop, aWidth, aHeight: integer); var ParentControl : TGradTabControl; begin {if Parent = nil then Exit; ParentControl := TGradTabPagesBar(Parent).FTabControl; if ParentControl.TabPosition in [tpLeft, tpRight] then begin if ParentControl.LongTabs then begin if ParentControl.LongWidth <> aWidth then if ParentControl.LongWidth < aWidth then begin ParentControl.LongWidth:=aWidth; end; end; end;} inherited SetBounds(aLeft, aTop, aWidth, aHeight); end; {------------------------------------------------------------------------------- TGradTabPageButton SetRotateDirection(const Value: TRotateDirection) ------------------------------------------------------------------------------} procedure TGradTabPageButton.SetRotateDirection(const Value: TRotateDirection); begin inherited; FCloseButton.RotateDirection:=Value; if FShowCloseButton then AlignCloseButton; end; {------------------------------------------------------------------------------- TGradTabPageButton.SetText(const Value: TCaption) ------------------------------------------------------------------------------} procedure TGradTabPageButton.RealSetText(const Value: TCaption); var NewCaption : TCaption; begin NewCaption:=Value; inherited RealSetText(NewCaption); AlignCloseButton; {$IFDEF DEBUGTAB} DebugLn('TGradTabPageButton RealSetText ',BoolToStr(Assigned(Parent),true), BoolToStr((Parent is TGradTabPagesBar),true) ); {$ENDIF} if Assigned(Parent) AND (Parent is TGradTabPagesBar) then (Parent as TGradTabPagesBar).OrderButtons; end; procedure TGradTabPageButton.SetAutoHeightBorderSpacing(const AValue: Integer); begin inherited SetAutoHeightBorderSpacing(AValue); if Parent <> nil then (Parent AS TGradTabPagesBar).OrderButtons; end; procedure TGradTabPageButton.SetAutoWidthBorderSpacing(const AValue: Integer); begin inherited SetAutoWidthBorderSpacing(AValue); if Parent <> nil then (Parent AS TGradTabPagesBar).OrderButtons; end; procedure TGradTabPageButton.SetShowGlyph(const Value: Boolean); begin inherited SetShowGlyph(Value); if Parent <> nil then (Parent AS TGradTabPagesBar).OrderButtons; end; {------------------------------------------------------------------------------- TGradTabPage Create(AOwner: TGradTabPageButton) ------------------------------------------------------------------------------} constructor TGradTabPage.Create(AOwner: TComponent); begin inherited Create(AOwner); FCurrentlyDestroying := false; fCompStyle := csPage; ControlStyle := ControlStyle + [csAcceptsControls,csDesignFixedBounds,csNoDesignVisible]; Align := alClient; FButton := TGradTabPageButton.Create(Self); FTabVisible:=true; FShowCloseButton:=false; FImageIndex:=0; FActiveTabColor:=clGreen; FNormalTabColor:=clBlue; FOwnerTabColor:=false; end; {------------------------------------------------------------------------------- TGradTabPage Destroy ------------------------------------------------------------------------------} destructor TGradTabPage.Destroy; begin FCurrentlyDestroying := true; Parent := nil; FButton.Parent := nil; FButton.Free; inherited; end; {------------------------------------------------------------------------------- TGradTabPage DestroyHandle ------------------------------------------------------------------------------} procedure TGradTabPage.DestroyHandle; begin inherited DestroyHandle; Exclude(FFlags,pfAdded); end; {------------------------------------------------------------------------------- TGradTabPage GetPageIndex: integer ------------------------------------------------------------------------------} function TGradTabPage.GetPageIndex: integer; begin if (Parent<>nil) and (Parent is TGradTabControl) then Result:=TGradTabControl(Parent).PageList.IndexOf(Self) else Result := -1; end; {------------------------------------------------------------------------------- TGradTabPage SetPageIndex(AValue: Integer) ------------------------------------------------------------------------------} procedure TGradTabPage.SetPageIndex(AValue: Integer); begin if (Parent<>nil) and (Parent is TGradTabControl) then begin TGradTabControl(Parent).MoveTab(Self,AValue); end; end; {------------------------------------------------------------------------------- TGradTabPage SetParent(NewParent: TWinControl) ------------------------------------------------------------------------------} procedure TGradTabPage.SetParent(NewParent: TWinControl); var OldParent: TWinControl; ParentTabControl: TGradTabControl; i: integer; begin {$IFDEF DEBUGTAB} DebugLn('TGradTabPage.SetParent'); {$ENDIF} if (NewParent=Parent) or (pfInserting in FFlags) then Exit; //if ((Parent<>nil)) AND (NewParent=Parent) then exit; CheckNewParent(NewParent); OldParent:=Parent; {$IFDEF DEBUGTAB} DebugLn('OldParent: %s NewParent: %s',[DbgSName(OldParent),DbgSName(NewParent)]); {$ENDIF} if (OldParent<>NewParent) and (OldParent<>nil) and (OldParent is TGradTabControl) and (not (pfRemoving in FFlags)) then begin // remove from old pagelist ParentTabControl := TGradTabControl(OldParent); i := PageIndex; if i >= 0 then ParentTabControl.RemovePage(i); {$IFDEF DEBUGTAB} DebugLn('Page removed from old TabControl'); {$ENDIF} end; inherited SetParent(NewParent); {$IFDEF DEBUGTAB} DebugLn('New Parent set'); {$ENDIF} if (OldParent<>NewParent) and (Parent<>nil) and (Parent is TGradTabControl) then begin // add to new pagelist ParentTabControl:=TGradTabControl(Parent); i:=ParentTabControl.PageList.IndexOf(Self); if i<0 then ParentTabControl.InsertPage(Self,ParentTabControl.PageCount); {$IFDEF DEBUGTAB} DebugLn('Insert Page in new Parent'); {$ENDIF} end; FGradTabControl := TGradTabControl(NewParent); {$IFDEF DEBUGTAB} DebugLn('TGradTabPage.SetParent end'); {$ENDIF} end; {------------------------------------------------------------------------------- TGradTabPage SetShowCloseButton(Value: Boolean) ------------------------------------------------------------------------------} procedure TGradTabPage.SetShowCloseButton(Value: Boolean); begin if FShowCloseButton=Value then Exit; FShowCloseButton:=Value; FButton.ShowCloseButton:=Value; if not Value then FButton.Caption:=FCaption else SetText(FCaption); end; {------------------------------------------------------------------------------- TGradTabPage SetTabVisible(Value: Boolean) ------------------------------------------------------------------------------} procedure TGradTabPage.SetTabVisible(Value: Boolean); begin if Value = FTabVisible then exit; FTabVisible := Value; if csDesigning in ComponentState then Exit; if Parent.HandleAllocated then begin TGradTabControl(Parent).AddRemovePageHandle(Self); if FTabVisible then begin // check if there was no visible tab if TGradTabControl(Parent).PageIndex = -1 then TGradTabControl(Parent).PageIndex:=PageIndex; end else // Check if the page is active and set a new pageindex TGradTabControl(Parent).PageRemoved(PageIndex); end; FButton.Visible:=FTabVisible; if FTabVisible then TGradTabControl(Parent).PagesBar.OrderButtons else begin FButton.Left:=-FButton.Width; FButton.Top:=-FButton.Height; end; //DoTabVisible; { TODO } end; {------------------------------------------------------------------------------- TGradTabPage GetTabPopupMenu : TPopupMenu ------------------------------------------------------------------------------} function TGradTabPage.GetTabPopupMenu : TPopupMenu; begin Result := FButton.PopupMenu; end; procedure TGradTabPage.SetTabTextAlignment(const AValue: TTextAlignment); begin if FButton.TextAlignment = AValue then Exit; FButton.TextAlignment:= AValue; end; {------------------------------------------------------------------------------- TGradTabPage SetTabPopupMenu(Value: TPopupMenu) ------------------------------------------------------------------------------} procedure TGradTabPage.SetTabPopupMenu(Value : TPopupMenu); begin if not Assigned(FButton) then Exit; if not Assigned(Value) then Exit; FButton.PopupMenu:=Value; end; procedure TGradTabPage.SetTabShowGlyph(const AValue: Boolean); begin FButton.ShowGlyph:= AValue; end; function TGradTabPage.GetTabColor: TColor; begin Result := FButton.Color end; function TGradTabPage.GetTabButtonLayout: TButtonLayout; begin Result := FButton.ButtonLayout; end; function TGradTabPage.GetTabGlyph: TBitmap; begin Result := FButton.Glyph; end; function TGradTabPage.GetTabShowGlyph: Boolean; begin Result := FButton.ShowGlyph; end; function TGradTabPage.GetTabTextAlignment: TTextAlignment; begin Result := FButton.TextAlignment; end; procedure TGradTabPage.SetImageIndex(const AValue: Integer); begin if FGradTabControl=nil then Exit; if FImageIndex=AValue then exit; FImageIndex:=AValue; if (FGradTabControl.Images <> nil) AND (FImageIndex<>-1) then begin UpdateImage; end; end; procedure TGradTabPage.SetTabButtonLayout(const AValue: TButtonLayout); begin FButton.ButtonLayout:=AValue; end; procedure TGradTabPage.SetTabColor(const AValue: TColor); begin if FButton.Color = AValue then Exit; FButton.Color:=AValue; end; procedure TGradTabPage.SetTabGlyph(const AValue: TBitmap); begin if FButton.Glyph = AValue then Exit; FButton.Glyph.Assign(AValue); end; {------------------------------------------------------------------------------- TGradTabPage SetText(Value: TCaption) ------------------------------------------------------------------------------} procedure TGradTabPage.SetText(const Value: TCaption); begin FCaption := Value; if FShowCloseButton then FButton.Caption:=FCaption+' ' else FButton.Caption:={IntToStr(PageIndex)+': '+}FCaption; end; {------------------------------------------------------------------------------- TGradTabPage GetText : TCaption ------------------------------------------------------------------------------} function TGradTabPage.GetText : TCaption; begin Result := FCaption; end; procedure TGradTabPage.SetEnabled(Value: Boolean); begin inherited SetEnabled(Value); FButton.Enabled:=Value; end; {------------------------------------------------------------------------------- TGradTabPage Paint ------------------------------------------------------------------------------} procedure TGradTabPage.Paint; var i : Integer; begin {for i := 0 to Height do begin Canvas.Pen.Color:=ColorBetween(Color,Parent.Color,i / (Height )); Canvas.Line(0,i,Width,i); //Canvas.FillRect(-1,-1,Width,Height); end; Canvas.TextOut(Width-Canvas.TextWidth(DbgSName(Self)),0,DbgSName(Self)); } inherited; end; {------------------------------------------------------------------------------- TGradTabPage VisibleIndex ------------------------------------------------------------------------------} function TGradTabPage.VisibleIndex: integer; var List: TList; i: Integer; begin if (Parent<>nil) and (Parent is TGradTabControl) then begin Result:=0; List:=TGradTabControl(Parent).PageList; i:=0; repeat if i=List.Count then exit(-1); if (TObject(List[i])=Self) then exit; if TGradTabPage(List[i]).TabVisible or (csDesigning in ComponentState) then inc(Result); inc(i); until false; end else Result := -1; end; procedure TGradTabPage.UpdateImage; begin if FGradTabControl = nil then Exit; FButton.Glyph.Clear; if Assigned(FGradTabControl.Images) AND (FGradTabControl.Images.Count<>0) AND (ImageIndex < FGradTabControl.Images.Count) AND (ImageIndex<>-1) then begin FGradTabControl.Images.GetBitmap(ImageIndex,FButton.Glyph); FButton.ShowGlyph:=true; end; end; {------------------------------------------------------------------------------- TGradTabPagesBar Create(AOwner: TComponent; var theTabList: TListWithEvent; TheTabControl : TGradTabControl) ------------------------------------------------------------------------------} constructor TGradTabPagesBar.Create(AOwner: TComponent; var thePageList: TListWithEvent; TheTabControl : TGradTabControl); begin inherited Create(AOwner); FPageList := thePageList; FShowFromButton:=-1; ControlStyle := ControlStyle+[csNoDesignSelectable]; FTabPosition:=tpTop; FMovedTo:=1; FTabControl := TheTabControl; SetSubComponent(true); FTabControl.FLeftButton.Visible:=false; FTabControl.FRightButton.Visible:=false; FActiveTabColor:=clGreen; FNormalTabColor:=clBlue; end; {------------------------------------------------------------------------------- TGradTabPagesBar Paint ------------------------------------------------------------------------------} procedure TGradTabPagesBar.Paint; begin {Canvas.Brush.Color:=clBlue; Canvas.FillRect(0,0,Width,Height); } //WriteLn(Left, ' ' ,Top, ' ' ,Width, ' ' ,Height); inherited; end; procedure TGradTabPagesBar.Resize; begin inherited Resize; OrderButtons; end; procedure TGradTabPagesBar.MoveToNext; var TheTabs : TTabs; VIA, L : Boolean; FLastShowFrom : Integer; begin {$IFDEF DEBUGTAB}DebugLn('MoveToNext Begin');{$ENDIF} //DebugLn(GetStackTrace(true)); TheTabs:= GetViewedTabs; VIA := ValueInArray(FPageList.Count-1,TheTabs); L := (Length(TheTabs)>1); {$IFDEF DEBUGTAB} DebugLn('ValueInArray=%s Length=%s',[BoolToStr(VIA,true),BoolToStr(L,true)]); {$ENDIF} FLastShowFrom:= FShowFromButton; if VIA AND L then FShowFromButton := TheTabs[0] else Inc(FShowFromButton); if FShowFromButton>=FPageList.Count then FShowFromButton:= FPageList.Count-1; {if not FTabControl.Page[FShowFromButton].Enabled then FShowFromButton := FLastShowFrom;} {$IFDEF DEBUGTAB}DebugLn('New FShowFromButton: %d',[FShowFromButton]);{$ENDIF} OrderButtons; {$IFDEF DEBUGTAB}DebugLn('MoveToNext End');{$ENDIF} //GetViewedTabs; end; procedure TGradTabPagesBar.MoveToPrior; var FLastShowFrom : Integer; begin FLastShowFrom:= FShowFromButton; Dec(FShowFromButton); if FShowFromButton<0 then FShowFromButton := 0; {$IFDEF DEBUGTAB}DebugLn('New FShowFromButton: %d',[FShowFromButton]);{$ENDIF} OrderButtons; //GetViewedTabs; end; {------------------------------------------------------------------------------- TGradTabPagesBar InsertButton(AButton: TGradTabPageButton; Index: Integer) ------------------------------------------------------------------------------} procedure TGradTabPagesBar.InsertButton(AButton: TGradTabPageButton; Index: Integer); var LastLeft : Integer; begin LastLeft := 0; if (Index >= 1) AND (FPageList.Count>=1) then LastLeft := TGradTabPage(FPageList.Items[Index-1]).TabButton.Left; FTabControl.AssignEvents(AButton); with AButton do begin Left:=-123; Parent := Self; ShowFocusBorder:=false; TextAlignment:=taCenter; BorderSides:=[bsTopLine,bsRightLine,bsLeftLine]; OnMouseDown:=@FTabControl.PageButtonMouseDown; OnMouseUp:=@FTabControl.PageButtonMouseUp; OnClick:=@FTabControl.PageButtonMouseClick; OnMouseMove:=@FTabControl.PageButtonMouseMove; end; if (Index >= 1) AND (FPageList.Count>=1) then UnFocusButton(Index-1); FocusButton(Index); OrderButtons; {$IFDEF DEBUGTAB}WriteLn('TGradTabPagesBar.InsertButton');{$ENDIF} end; procedure TGradTabPagesBar.MoveTo(Num: Integer); function GetLast : Integer; var Btn : TGradButton; i,l : Integer; begin Result := 1; if FPageList.Count = 0 then Exit; l := 1; for i := 0 to FPageList.Count-2 do begin Btn := TGradTabPage(FPageList.Items[i]).TabButton; L := L + 1; if TabPosition in [tpTop, tpBottom] then begin L := L + Btn.Width; //if Result > Width then Result := Result - Width; end else begin L := L + Btn.Height; //if Result > Height then Result := Result - Height; end; end; Result := l; //Result := end; var i : Integer; begin {$IFDEF DEBUGTAB}DebugLn('MoveTo Max: %d, Current: %d',[GetLast+1,FMovedTo]);{$ENDIF} if FMovedTo > 1 then FMovedTo := 1; if FMovedTo < -GetLast then FMovedTo := -GetLast+2; //OrderButtons; end; procedure TGradTabPagesBar.MoveToNorm; begin FMovedTo:=1; OrderButtons; end; {------------------------------------------------------------------------------- TGradTabPagesBar OrderButtons ------------------------------------------------------------------------------} procedure TGradTabPagesBar.OrderButtons; var LastLeft, LastTop, i, BarWidth, BarHeight: Integer; NewDirection: TRotateDirection; NewBorderSides: TBorderSides; NewGradientType: TGradientType; B : TGradButton; begin if csDestroying in FTabControl.ComponentState then Exit; {$IFDEF DEBUGTAB}DebugLn('OrderButton Start');{$ENDIF} FMovedTo:=0; if FPageList.Count=0 then Exit; for i := FShowFromButton-1 downto 0 do begin if i >= FPageList.Count then Continue; B := TGradTabPage(FPageList.Items[i]).TabButton; if FTabPosition in [tpRight, tpLeft] then Dec(FMovedTo,B.Height+1); if FTabPosition in [tpTop, tpBottom] then Dec(FMovedTo,B.Width+1); end; Inc(FMovedTo); LastLeft:= FMovedTo; LastTop := FMovedTo; { if FTabPosition in [tpTop, tpBottom] then begin BarWidth:= Width; BarHeight:= 0; end else begin } BarWidth := Width; BarHeight:= Height; //end; case FTabPosition of tpTop: begin NewBorderSides := [bsTopLine, bsRightLine, bsLeftLine]; NewGradientType := gtHorizontal; NewDirection := rdNormal; end; tpBottom: begin NewBorderSides := [bsBottomLine, bsRightLine, bsLeftLine]; NewGradientType := gtHorizontal; NewDirection := rdNormal; end; tpLeft: begin NewBorderSides := [bsTopLine, bsBottomLine, bsLeftLine]; if FTabControl.LongTabs then begin NewGradientType := gtHorizontal; NewDirection := rdNormal; end else begin NewGradientType := gtVertical; NewDirection := rdLeft; end; end; tpRight: begin NewBorderSides := [bsTopLine, bsBottomLine, bsRightLine]; if FTabControl.LongTabs then begin NewGradientType := gtHorizontal; NewDirection := rdNormal; end else begin NewGradientType := gtVertical; NewDirection := rdRight; end; end; end; FActiveIndex:=FTabControl.PageIndex; for i := 0 to FPageList.Count - 1 do begin B := TGradTabPage(FPageList.Items[i]).TabButton; if B.Visible then begin B.RotateDirection := NewDirection; B.BorderSides := NewBorderSides; B.GradientType := NewGradientType; {$IFDEF DEBUGTAB} DebugLn('Begin I: %d W: %d H: %d L: %d T: %d, BW: %d, BH: %d',[i,B.Width,B.Height,B.Left,B.Top,BarWidth,BarHeight]); {$ENDIF} case FTabPosition of tpTop: begin //if B.Width < B.GetAutoWidth then B.Width := B.GetAutoWidth; B.Left := LastLeft; LastLeft := LastLeft + B.Width + 1; if FActiveIndex = i then begin B.Top := 0; B.Height:= BarHeight; end else begin B.Top := 3; B.Height:= BarHeight-3; end; end; tpBottom: begin //if B.Width < B.GetAutoWidth then B.Width := B.GetAutoWidth; B.Left := LastLeft; LastLeft := LastLeft + B.Width + 1; B.Top := 0; if FActiveIndex = i then B.Height := BarHeight else B.Height := BarHeight-3; end; tpLeft: begin if FTabControl.LongTabs then begin if (B.GetAutoWidth > FTabControl.LongWidth) then begin FTabControl.LongWidth:=B.GetAutoWidth; Exit; end; end; B.Height:= B.GetAutoHeight; B.Top := LastTop; LastTop := LastTop + B.Height + 1; if FActiveIndex = i then begin B.Left := 0; B.Width:= FTabControl.GetTabBarSize(tpLeft); end else begin B.Left := 3; B.Width:= FTabControl.GetTabBarSize(tpLeft)-3; end; end; tpRight: begin if FTabControl.LongTabs then begin if (B.GetAutoWidth > FTabControl.LongWidth) then begin FTabControl.LongWidth:=B.GetAutoWidth; Exit; end; end; B.Height:= B.GetAutoHeight; B.Top := LastTop; LastTop := LastTop + B.Height + 1; B.Left := 0; if FActiveIndex = i then B.Width := FTabControl.GetTabBarSize(tpRight) else begin B.Width := FTabControl.GetTabBarSize(tpRight)-3; end; {$IFDEF DEBUGTAB} DebugLn('B.Width=%d TabBarSize(tpRight)=%d FActive=%d',[B.Width, FTabControl.GetTabBarSize(tpRight), FActiveIndex]); {$ENDIF} end; end; {$IFDEF DEBUGTAB} DebugLn('End I: %d W: %d H: %d L: %d T: %d, BW: %d, BH: %d',[i,B.Width,B.Height,B.Left,B.Top,BarWidth,BarHeight]); {$ENDIF} end; end; {$IFDEF DEBUGTAB} DebugLn('BarWidth=%d LastLeft=%d FMovedTo=%d BarHeight=%d LastTop=%d',[BarWidth, LastLeft, FMovedTo, BarHeight, LastTop]); DebugLn('BarWidth < LastLeft-FMovedTo = %s BarHeight < LastTop-FMovedTo=%s',[ BoolStr(BarWidth < (LastLeft-FMovedTo)), BoolStr(BarHeight < (LastTop-FMovedTo))]); {$ENDIF} if not FTabControl.AutoShowScrollButtons then Exit; if ((BarWidth < (LastLeft-FMovedTo)) OR (BarHeight < (LastTop-FMovedTo)) OR (FMovedTo <> 1)) AND ((BarHeight<>0) AND (BarWidth<>0)) then begin FTabControl.FLeftButton.Visible:=true; FTabControl.FRightButton.Visible:=true; end else begin FTabControl.FLeftButton.Visible:=false; FTabControl.FRightButton.Visible:=false; end; {$IFDEF DEBUGTAB} DebugLn('FR=%s FL=%s',[BoolStr(FTabControl.FRightButton.Visible),BoolStr(FTabControl.FLeftButton.Visible)]); DebugLn('OrderButton End'); {$ENDIF} end; {------------------------------------------------------------------------------- TGradTabPagesBar UnFocusButton(Index: Integer) ------------------------------------------------------------------------------} procedure TGradTabPagesBar.UnFocusButton(Index: Integer); begin if (Index < 0) or (Index >= FPageList.Count) then Exit; {$IFDEF DEBUGTAB} DebugLn('TGradTabPagesBar.UnFocusButton Index: %d Assigned %s', [Index,BoolToStr(Assigned(TGradTabPage(FPageList.Items[Index]).TabButton),true)]); {$ENDIF} with TGradTabPage(FPageList.Items[Index]).TabButton do begin case FTabPosition of tpTop : begin Top:=3; Height:=Self.Height-3; end; tpBottom: begin Top:=0; Height:=Self.Height-3; end; tpRight: begin Left := 0; Width:= Self.Width-3; end; tpLeft: begin Left := 3; Width:=Self.Width-3; end; end; if TGradTabPage(FPageList.Items[Index]).OwnerTabColor then Color := TGradTabPage(FPageList.Items[Index]).NormalTabColor else Color := NormalTabColor; UpdatePositions; end; end; {------------------------------------------------------------------------------- TGradTabPagesBar FocusButton(Index: Integer) ------------------------------------------------------------------------------} procedure TGradTabPagesBar.FocusButton(Index: Integer); var CurTabs : TTabs; DoNext : Boolean; c : Integer; begin if csDestroying in FTabControl.ComponentState then Exit; if (Index < 0) or (Index >= FPageList.Count) then Exit; {$IFDEF DEBUGTAB} DebugLn('TGradTabPagesBar.FocusButton Index: %d Assigned %s', [Index,BoolToStr(Assigned(TGradTabPage(FPageList.Items[Index]).TabButton),true)]); {$ENDIF} with TGradTabPage(FPageList.Items[Index]).TabButton do begin case FTabPosition of tpTop, tpBottom : begin Top:=0; Height:=Self.Height; DoNext := ((Left+Width)>= Self.Width); end; tpRight, tpLeft: begin Left := 0; Width:= Self.Width; if FTabControl.LongTabs then Height := FTabControl.TabHeight; DoNext := ((Top+Height)>= Self.Height); end; end; if TGradTabPage(FPageList.Items[Index]).OwnerTabColor then Color := TGradTabPage(FPageList.Items[Index]).ActiveTabColor else Color := ActiveTabColor; end; {$IFDEF DEBUGTAB} DebugLn('FR=%s FL=%s',[BoolStr(FTabControl.FRightButton.Visible),BoolStr(FTabControl.FLeftButton.Visible)]); {$ENDIF} if not (FTabControl.FRightButton.Visible AND FTabControl.FLeftButton.Visible) then Exit; C := 0; {$IFDEF DEBUGTAB} DebugLn('Left=%d Width=%d Width=%d',[TGradTabPage(FPageList.Items[Index]).TabButton.Left, TGradTabPage(FPageList.Items[Index]).TabButton.Width, Width]); DebugLn('FocusButton Before ScrollToTab'); {$ENDIF} ScrollToTab(Index); {$IFDEF DEBUGTAB} DebugLn('FocusButton After ScrollToTab'); {$ENDIF} end; {------------------------------------------------------------------------------- TGradTabPagesBar SetTabPosition(Value: TTabPosition) ------------------------------------------------------------------------------} procedure TGradTabPagesBar.SetTabPosition(Value: TTabPosition); function DbgsTabPosition(V : TTabPosition) : String; begin case V of tpTop : Result := 'tpTop'; tpBottom: Result := 'tpBottom'; tpRight: Result := 'tpRight'; tpLeft: Result := 'tpLeft'; end; end; begin if FTabPosition = Value then Exit; {$IFDEF DEBUGTAB} DebugLn('Change TabPosition from %s to %s',[DbgsTabPosition(FTabPosition),DbgsTabPosition(Value)]); {$ENDIF} FTabPosition:=Value; OrderButtons; end; function TGradTabPagesBar.IsVisible(Index: Integer): Boolean; var TheButton : TGradTabPageButton; begin if (Index < 0) or (Index >= FPageList.Count) then Exit; TheButton := TGradTabPage(FPageList.Items[Index]).TabButton; if TabPosition in [tpTop, tpBottom] then Result := TheButton.Visible AND (TheButton.Left >= 0) AND (TheButton.Left+TheButton.Width <= Width+5) else Result := TheButton.Visible AND (TheButton.Top >= 0) AND (TheButton.Top+TheButton.Height <= Height+5); end; procedure TGradTabPagesBar.ChangeLeftTop(LastTabPosition: TTabPosition); begin end; function TGradTabPagesBar.GetViewedTabs: TTabs; var i,l : Integer; begin {$IFDEF DEBUGTAB} DebugLn('GetViewedTabs'); DebugLn('Width=%d Height=%d',[Width,Height]); {$ENDIF} for i := 0 to FPageList.Count-1 do begin with TGradTabPage(FPageList.Items[i]).TabButton do begin if ((TabPosition in [tpTop, tpBottom]) AND (Left >= 0) {AND (Left <=(Self.Width-10))} AND (Left+Width < Self.Width)) OR ((TabPosition in [tpLeft, tpRight]) AND (Top >= 0) {AND (Top <=(Self.Height-10))} AND (Top+Height < Self.Height)) then begin l := IncAr(Result); {$IFDEF DEBUGTAB} DebugLn('L=%d T=%d W=%d H=%d Caption=%s',[Left, Top, Width, Height, Caption]); DebugLn('%d. Value: %d',[l,i]); {$ENDIF} Result[l] := i; end; end; end; {$IFDEF DEBUGTAB} DebugLn('GetViewedTabs End'); {$ENDIF} end; function TGradTabPagesBar.GetViewableTabs(FromIndex: Integer): TTabs; var i,l, Last : Integer; begin Last := 1; for i := FromIndex to FPageList.Count-1 do begin with TGradTabPage(FPageList.Items[i]).TabButton do begin case TabPosition of tpTop,tpBottom : begin if Last + Width < Self.Width then begin l := IncAr(Result); Result[l] := i; Inc(Last, Width+1); end; end; tpLeft,tpRight : begin if Last + Height < Self.Height then begin l := IncAr(Result); Result[l] := i; Inc(Last, Height+1); end; end; end; end; end; end; function TGradTabPagesBar.GetTabsOfSide(FromIndex: Integer; FromLeftSide: Boolean ): TTabs; var i,l,fstart,fend : Integer; begin if FromLeftSide then begin fstart := 0; fend:= FromIndex-1; end else begin fstart:= FromIndex+1; fend:= FPageList.Count-1; end; for i := fstart to fend do begin l := IncAr(Result); Result[l] := i; end; end; procedure TGradTabPagesBar.ScrollToTab(PIndex: Integer); var CurTabs, TabsLeft, TabsRight : TTabs; C : Integer; DoNext : Boolean; IsInLeft, IsInRight : Boolean; begin C := 0; if (FPageList.Count=0) OR (PIndex>=FPageList.Count) then Exit; if IsVisible(PIndex) then Exit; CurTabs := GetViewedTabs; TabsLeft:= GetTabsOfSide(CurTabs[0],true); TabsRight:= GetTabsOfSide(CurTabs[High(CurTabs)],false); IsInLeft:= ValueInArray(PIndex,TabsLeft); IsInRight:= ValueInArray(PIndex,TabsRight); {$IFDEF DEBUGTAB} DebugLn('ScrollToTab TabInLeft=%s TabInRight=%s',[BoolStr(IsInLeft),BoolStr(IsInRight)]); {$ENDIF} if IsInLeft then begin FShowFromButton := TabsLeft[0]; OrderButtons; if IsVisible(PIndex) then Exit; end; {$IFDEF DEBUGTAB} DebugLn('ScrollToTab=%d',[PIndex]); {$ENDIF} repeat {$IFDEF DEBUGTAB} DebugLn('Run=%d',[C]); {$ENDIF} with TGradTabPage(FPageList.Items[PIndex]).TabButton do case FTabPosition of tpTop, tpBottom : DoNext := ((Left+Width)>= Self.Width); tpRight, tpLeft: DoNext := ((Top+Height)>= Self.Height); end; if DoNext then MoveToNext else MoveToPrior; Inc(C); //{$IFDEF DEBUGTAB} DebugLn('ValInAr=%s',[BoolStr(ValueInArray(PIndex,CurTabs))]); {$ENDIF} {$IFDEF DEBUGTAB} DebugLn('IsVisible(%d)=%s',[PIndex, BoolStr(IsVisible(PIndex))]); {$ENDIF} until({ValueInArray(PIndex,CurTabs)} IsVisible(PIndex) {OR (C=10)}); //if DoNext then MoveToNext else MoveToPrior; {$IFDEF DEBUGTAB} DebugLn('ScrollToTab End'); {$ENDIF} end; {------------------------------------------------------------------------------- TGradTabPagesBar Create(AOwner: TComponent) ------------------------------------------------------------------------------} constructor TGradTabBar.Create(AOwner: TComponent); begin inherited Create(AOwner); ControlStyle := ControlStyle+[csNoDesignSelectable]; SetSubComponent(true); end; {------------------------------------------------------------------------------- TGradTabPagesBar Destroy ------------------------------------------------------------------------------} destructor TGradTabBar.Destroy; begin inherited; end; {------------------------------------------------------------------------------- TGradTabPagesBar Paint ------------------------------------------------------------------------------} procedure TGradTabBar.Paint; begin {Canvas.Brush.Color:=clFuchsia; Canvas.FillRect(0,0,Width,Height); } {$IFDEF DEBUGTAB} //WriteLn(Left, ' ' ,Top, ' ' ,Width, ' ' ,Height); {$ENDIF} inherited; end; {------------------------------------------------------------------------------ TGradTabPages Constructor ------------------------------------------------------------------------------} constructor TGradTabPages.Create(var thePageList: TListWithEvent; theGradTabControl: TGradTabControl); begin inherited Create; fPageList := thePageList; fPageList.OnChange:=@PageListChange; fGradTabControl:= theGradTabControl; end; {------------------------------------------------------------------------------ procedure TGradTabPages.PageListChange(Ptr: Pointer; AnAction: TListNotification); ------------------------------------------------------------------------------} procedure TGradTabPages.PageListChange(Ptr: Pointer; AnAction: TListNotification); var APage: TGradTabPage; begin if (AnAction=lnAdded) then begin APage:=TObject(Ptr) as TGradTabPage; if not (pfInserting in APage.FFlags) then APage.Parent:=fGradTabControl; end; end; {------------------------------------------------------------------------------ TGradTabPages Get ------------------------------------------------------------------------------} function TGradTabPages.Get(Index: Integer): String; begin {$IFDEF DEBUGTAB}DebugLn('TGradTabPages.Get Index=',Index);{$ENDIF} if (Index<0) or (Index>=fPageList.Count) then RaiseGDBException('TGradTabPages.Get Index out of bounds'); Result := TGradTabPage(fPageList[Index]).Caption; end; {------------------------------------------------------------------------------ TGradTabPages GetCount ------------------------------------------------------------------------------} function TGradTabPages.GetCount: Integer; begin Result := fPageList.Count; end; {------------------------------------------------------------------------------ TGradTabPages GetObject ------------------------------------------------------------------------------} function TGradTabPages.GetObject(Index: Integer): TObject; begin if (Index<0) or (Index>=fPageList.Count) then RaiseGDBException('TGradTabPages.GetObject Index out of bounds'); Result := TGradTabPage(fPageList[Index]); end; {------------------------------------------------------------------------------ TGradTabPages Put ------------------------------------------------------------------------------} procedure TGradTabPages.Put(Index: Integer; const S: String); begin if (Index<0) or (Index>=fPageList.Count) then RaiseGDBException('TGradTabPages.Put Index out of bounds'); TGradTabPage(fPageList[Index]).Caption := S; end; {------------------------------------------------------------------------------ TGradTabPages Clear ------------------------------------------------------------------------------} procedure TGradTabPages.Clear; begin {$IFDEF DEBUGTAB}DebugLn('TGradTabPages.Clear Begin');{$ENDIF} while fPageList.Count>0 do Delete(fPageList.Count-1); {$IFDEF DEBUGTAB}DebugLn('TGradTabPages.Clear End');{$ENDIF} end; {------------------------------------------------------------------------------ TGradTabPages Delete(Index: Integer) ------------------------------------------------------------------------------} procedure TGradTabPages.Delete(Index: Integer); var APage: TGradTabPage; AButton : TGradTabPageButton; CurrentPageNum,i : Integer; begin // Make sure Index is in the range of valid pages to delete {$IFDEF DEBUGTAB} DebugLn(['TGradTabPages.Delete B ',FGradTabControl.Name,' Index=',Index,' fPageList.Count=',fPageList.Count,' fNoteBook.PageIndex=',FGradTabControl.PageIndex]); {$ENDIF} if (Index >= 0) and (Index < fPageList.Count) then begin APage:=TGradTabPage(fPageList[Index]); {$IFDEF DEBUGTAB} DebugLn('B Parent = nil'); {$ENDIF} // delete handle APage.Parent:=nil; {$IFDEF DEBUGTAB} DebugLn('B APage.Free'); {$ENDIF} // free the page APage.Free; end; {$IFDEF DEBUGTAB} DebugLn(['TGradTabPages.Delete END ',FGradTabControl.Name,' Index=',Index,' fPageList.Count=',fPageList.Count,' fNoteBook.PageIndex=',FGradTabControl.PageIndex]); {$ENDIF} end; {------------------------------------------------------------------------------ TGradTabPages Insert(Inder: Integer; const S: String) ------------------------------------------------------------------------------} procedure TGradTabPages.Insert(Index: Integer; const S: String); var NewPage: TGradTabPage; NewButton: TGradTabPageButton; NewOwner: TComponent; begin {$IFDEF DEBUGTAB} DebugLn(['TGradTabPages.Insert A ',FGradTabControl.Name,' Index=',Index,' S="',S,'"']); {$ENDIF} NewOwner:=FGradTabControl.Owner; if NewOwner=nil then NewOwner:=FGradTabControl; NewPage := TGradTabPage.Create(NewOwner); with NewPage do begin Caption := S; end; {$IFDEF DEBUGTAB} DebugLn(['TGradTabPages.Insert B ',FGradTabControl.Name,' Index=',Index,' S="',S,'"']); {$ENDIF} {TODO} FGradTabControl.InsertPage(NewPage,Index); {$IFDEF DEBUGTAB} DebugLn(['TGradTabPages.Insert END ',FGradTabControl.Name,' Index=',Index,' S="',S,'"']); {$ENDIF} end; {------------------------------------------------------------------------------ TGradTabPages Move ------------------------------------------------------------------------------} procedure TGradTabPages.Move(CurIndex, NewIndex: Integer); var APage: TGradTabPage; NewControlIndex, NewPageIndex: integer; begin if CurIndex=NewIndex then exit; NewPageIndex:=NewIndex; APage:=TGradTabPage(fPageList[CurIndex]); // calculate new control index (i.e. ZOrderPosition) if NewIndex>=fPageList.Count-1 then NewControlIndex:=FGradTabControl.ControlCount-1 else NewControlIndex:=FGradTabControl.GetControlIndex(TGradTabPage(fPageList[NewIndex])); // calculate new PageIndex {TODO} if FGradTabControl.PageIndex=CurIndex then NewPageIndex:=NewIndex else if FGradTabControl.PageIndex>CurIndex then begin if FGradTabControl.PageIndex<=NewIndex then NewPageIndex:=FGradTabControl.PageIndex-1; end else begin if FGradTabControl.PageIndex>=NewIndex then NewPageIndex:=FGradTabControl.PageIndex+1; end; // move Page in fPageList fPageList.Move(CurIndex, NewIndex); // move in wincontrol list FGradTabControl.SetControlIndex(APage,NewControlIndex); // update PageIndex FGradTabControl.PageIndex:=NewPageIndex; end; {------------------------------------------------------------------------------ TGradTabControl Create(AOwner: TComponent) ------------------------------------------------------------------------------} constructor TGradTabControl.Create(AOwner: TComponent); begin inherited; FImageChangeLink := TChangeLink.Create; FImageChangeLink.OnChange:=@ImageListChange; FTabPosition:=tpTop; FAutoShowScrollButton:=true; fCompStyle := csNoteBook; ControlStyle := [{csAcceptsControls, }csDesignInteractive]; TabStop:=true; FPageList := TListWithEvent.Create; FTabStrings := TGradTabPages.Create(TListWithEvent(FPageList), Self); FPageIndex:=-1; FTabHeight:=20; FPagesPopup := TPopupMenu.Create(Self); FPagesPopup.OnPopup:=@PopupTabs; FBar := TGradTabBar.Create(Self); FBar.Height:=FTabHeight; FBar.Top:=0; FBar.Left:=0; FBar.Width:=Width; FBar.Parent := Self; //FBar.Align:=alTop; FMoveIncrement:=1; FLeftButton := TGradButton.Create(Self); FLeftButton.Parent := FBar; FLeftButton.Align:= alLeft; FLeftButton.Caption:='<'; FLeftButton.AutoWidth:=true; FLeftButton.Visible := false; FLeftButton.SetSubComponent(true); FRightButton := TGradButton.Create(Self); FRightButton.Parent := FBar; FRightButton.Align:= alRight; FRightButton.Caption:='>'; FRightButton.AutoWidth:=true; FRightButton.Visible:= false; FRightButton.SetSubComponent(true); FPagesBar := TGradTabPagesBar.Create(Self,TListWithEvent(FPageList), Self); FPagesBar.Parent:=FBar; FPagesBar.Align:=alClient; FPagesBar.Left:=0; FPagesBar.Top:=0; FPagesBar.Width:=FBar.Width; FPagesBar.Height:=FBar.Height; AssignEvents(FBar); AssignEvents(FPagesBar); //AssignEvents(FRightButton); //AssignEvents(FLeftButton); FLeftButton.OnClick:=@MoveLeftTopClick; FRightButton.OnClick:=@MoveRightBottomClick; with FRightButton, FLeftButton do begin OnMouseUp:=nil; OnMouseDown:=nil; PopupMenu:=FPagesPopup; end; FRightButton.PopupMenu:=FPagesPopup; Height:=200; Width:=200; end; {------------------------------------------------------------------------------ TGradTabControl Destroy ------------------------------------------------------------------------------} destructor TGradTabControl.Destroy; begin {$IFDEF DEBUGTAB} DebugLn('TGradTabControl.Destroy Start'); DebugLn('B Tabs.Clear'); {$ENDIF} Tabs.Clear; {$IFDEF DEBUGTAB} DebugLn('A Tabs.Clear'); DebugLn('B FreeAndNil(FTabStrings)'); {$ENDIF} FreeAndNil(FTabStrings); {$IFDEF DEBUGTAB} DebugLn('A FreeAndNil(FTabStrings)'); DebugLn('B FreeAndNil(FPageList)'); {$ENDIF} FreeAndNil(FPageList); {$IFDEF DEBUGTAB} DebugLn('A FreeAndNil(FPageList)'); {$ENDIF} //FLeftButton.Free; //FRightButton.Free; {$IFDEF DEBUGTAB} DebugLn('TGradTabControl.Destroy End'); {$ENDIF} FImageChangeLink.Destroy; inherited; end; function TGradTabControl.GetTabRect(AIndex: Integer): TRect; begin if (AIndex >= FPageList.Count) or (AIndex < 0) then Exit; with TGradTabPage(FPageList[AIndex]).TabButton do begin Result.Left:=Left; Result.Top:=Top; Result.Bottom:=Top+Height; Result.Right:=Left+Width; end; end; procedure TGradTabControl.AssignEvents(TheControl: TCustomControl); begin if TheControl = nil then Exit; with TheControl do begin OnMouseWheel:=@SubMouseWheel; OnMouseWheelUp:=@SubMouseWheelUp; OnMouseWheelDown:=@SubMouseWheelDown; OnClick:=@SubMouseClick; OnDblClick:=@SubMouseDblClick; OnMouseMove:=@SubMouseMove; OnMouseDown:=@SubMouseDown; OnMouseUp:=@SubMouseUp; OnDragOver:=@SubDragOver; OnDragDrop:=@SubDragDrop; end; end; {------------------------------------------------------------------------------ TGradTabControl AlignPage(APage : TGradTabPage; ARect : TRect) ------------------------------------------------------------------------------} procedure TGradTabControl.AlignPage(APage : TGradTabPage; ARect : TRect); begin if APage <> nil then with APage do begin Left:=ARect.Left; Top :=ARect.Top; Width := ARect.Right; Height:= ARect.Bottom; end; end; procedure TGradTabControl.AlignPages; var i : Integer; begin for i := 0 to FPageList.Count-1 do AlignPage(TGradTabPage(FPageList.Items[i]),GetClientRect); UpdateAllDesignerFlags; end; function TGradTabControl.GetActiveTabColor: TColor; begin Result := FPagesBar.ActiveTabColor; end; function TGradTabControl.GetNormalTabColor: TColor; begin Result := FPagesBar.NormalTabColor; end; procedure TGradTabControl.ImageListChange(Sender: TObject); begin UpdateTabImages; end; procedure TGradTabControl.SetActiveTabColor(const AValue: TColor); begin FPagesBar.ActiveTabColor:= AValue; end; procedure TGradTabControl.SetNormalTabColor(const AValue: TColor); begin FPagesBar.NormalTabColor:=AValue; end; procedure TGradTabControl.UpdateTabImages; var i : Integer; begin if FImages = nil then Exit; {$IFDEF DEBUGTAB}DebugLn('TGradTabControl.UpdateTabImages Images.Count: %d',[Images.Count]);{$ENDIF} for i := 0 to PageCount-1 do TGradTabPage(FPageList.Items[i]).UpdateImage; end; {------------------------------------------------------------------------------ TGradTabControl GetCurrentPage : TGradTabPage ------------------------------------------------------------------------------} function TGradTabControl.GetCurrentPage : TGradTabPage; begin Result := nil; if FPageIndex <> -1 then Result := TGradTabPage(FPageList.Items[FPageIndex]); end; {------------------------------------------------------------------------------ TGradTabControl GetPage(AIndex: Integer) : TGradTabPage ------------------------------------------------------------------------------} function TGradTabControl.GetPage(AIndex: Integer) : TGradTabPage; var LastTabPage : TGradTabPage; LastTab : Integer; begin Result := nil; if (AIndex >= 0) AND (AIndex < FPageList.Count) then Result := TGradTabPage(FPageList.Items[AIndex]); end; {------------------------------------------------------------------------------ TGradTabControl GetCount : Integer ------------------------------------------------------------------------------} function TGradTabControl.GetCount : Integer; begin Result := FPageList.Count; end; function TGradTabControl.GetPagesBarDragOver: TDragOverEvent; begin Result := FPagesBar.OnDragOver; end; {------------------------------------------------------------------------------ TGradTabControl MoveTab(Sender: TObject; NewIndex: Integer) ------------------------------------------------------------------------------} procedure TGradTabControl.MoveTab(Sender: TObject; NewIndex: Integer); begin if (Sender <> nil) and (NewIndex < PageCount) then begin TGradTabPages(FTabStrings).Move(TGradTabPage(Sender).PageIndex,NewIndex); end else ; //raise exception? Change; end; {------------------------------------------------------------------------------ TGradTabControl FindVisiblePage(Index: Integer): Integer ------------------------------------------------------------------------------} function TGradTabControl.FindVisiblePage(Index: Integer): Integer; begin for Result := Index to FPageList.Count - 1 do if TGradTabPage(FPageList[Result]).TabVisible then exit; // if arrived here no visible forward page was found, search backwards for Result := Index - 1 downto 0 do if TGradTabPage(FPageList[Result]).TabVisible then exit; Result := -1; end; {------------------------------------------------------------------------------ TGradTabControl PageButtonMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer) ------------------------------------------------------------------------------} procedure TGradTabControl.PageButtonMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); var AButton : TGradTabPageButton; begin AButton := TGradTabPageButton(Sender); if Assigned(FOnTabButtonMouseDown) then FOnTabButtonMouseDown(Self, Button, Shift, X,Y, FPageList.IndexOf(AButton.Owner)); end; {------------------------------------------------------------------------------ TGradTabControl PageButtonMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer) ------------------------------------------------------------------------------} procedure TGradTabControl.PageButtonMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); var AButton : TGradTabPageButton; begin AButton := TGradTabPageButton(Sender); if Assigned(FOnTabButtonMouseUp) then FOnTabButtonMouseUp(Self, Button, Shift, X,Y, FPageList.IndexOf(AButton.Owner)); end; {------------------------------------------------------------------------------ TGradTabControl.PageButtonMouseClick(Sender: TObject) ------------------------------------------------------------------------------} procedure TGradTabControl.PageButtonMouseClick(Sender: TObject); var AButton : TGradTabPageButton; begin AButton := TGradTabPageButton(Sender); PageIndex:=FPageList.IndexOf(AButton.Owner); if Assigned(FOnTabButtonClick) then FOnTabButtonClick(Self, FPageList.IndexOf(AButton.Owner)); end; procedure TGradTabControl.PopupMouseClick(Sender: TObject); var AButton : TGradTabPageButton; begin AButton := Page[(Sender as TMenuItem).Tag].TabButton; PageButtonMouseClick(AButton); end; procedure TGradTabControl.PageButtonMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); var AButton : TGradTabPageButton; begin AButton := TGradTabPageButton(Sender); if Assigned(FOnTabButtonMouseMove) then FOnTabButtonMouseMove(Self, Shift, X,Y, FPageList.IndexOf(AButton.Owner)); end; procedure TGradTabControl.SetAutoShowScrollButtons(const AValue: Boolean); begin if FAutoShowScrollButton=AValue then exit; FAutoShowScrollButton:=AValue; FPagesBar.OrderButtons; end; procedure TGradTabControl.SetImages(const AValue: TImageList); begin {$IFDEF DEBUGTAB}DebugLn('TGradTabControl.SetImages FImages: ', IsAssigned(FImages));{$ENDIF} if FImages=AValue then exit; if (AValue = nil) AND (FImages<>nil) then FImages.UnRegisterChanges(FImageChangeLink); FImages:=AValue; if FImages <> nil then FImages.RegisterChanges(FImageChangeLink); UpdateTabImages; end; procedure TGradTabControl.SetLongWidth(const AValue: Integer); begin {$IFDEF DEBUGTAB} DebugLn('SetLongWidth Old=%d New=%d',[FLongWidth, AValue]); {$ENDIF} if FLongWidth = AValue then Exit; {$IFDEF DEBUGTAB} DebugLn('NewLongWidth set'); {$ENDIF} FLongWidth:=AValue; SetTabPosition(TabPosition); end; procedure TGradTabControl.SetShowLeftTopScrollButton(const AValue: Boolean); begin if FShowLeftTopScrollButton=AValue then exit; FShowLeftTopScrollButton:=AValue; FLeftButton.Visible:=AValue; end; procedure TGradTabControl.SetShowRightBottomScrollButton(const AValue: Boolean ); begin if FShowRightBottomScrollButton=AValue then exit; FShowRightBottomScrollButton:=AValue; FRightButton.Visible:=AValue; end; procedure TGradTabControl.SubMouseWheel(Sender: TObject; Shift: TShiftState; WheelDelta: Integer; MousePos: TPoint; var Handled: Boolean); begin if Assigned(OnMouseWheel) then OnMouseWheel(Sender, Shift, WheelDelta, MousePos, Handled); end; procedure TGradTabControl.SubMouseWheelUp(Sender: TObject; Shift: TShiftState; MousePos: TPoint; var Handled: Boolean); begin if Assigned(OnMouseWheelUp) then OnMouseWheelUp(Sender, Shift, MousePos, Handled); end; procedure TGradTabControl.SubMouseWheelDown(Sender: TObject; Shift: TShiftState; MousePos: TPoint; var Handled: Boolean); begin if Assigned(OnMouseWheelDown) then OnMouseWheelDown(Sender, Shift, MousePos, Handled); end; procedure TGradTabControl.SubMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin if Assigned(OnMouseDown) then OnMouseDown(Sender, Button, Shift, X, Y); end; procedure TGradTabControl.SubMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin if Assigned(OnMouseUp) then OnMouseUp(Sender, Button, Shift, X, Y); end; procedure TGradTabControl.SubMouseClick(Sender: TObject); begin if Assigned(OnClick) then OnClick(Sender); end; procedure TGradTabControl.SubMouseDblClick(Sender: TObject); begin if Assigned(OnDblClick) then OnDblClick(Sender); end; procedure TGradTabControl.SubMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); begin if Assigned(OnMouseMove) then OnMouseMove(Sender, Shift, X, Y); end; procedure TGradTabControl.SubDragOver(Sender, Source: TObject; X, Y: Integer; State: TDragState; var Accept: Boolean); begin if Assigned(OnDragOver) then OnDragOver(Sender, Source, X, Y, State, Accept); end; procedure TGradTabControl.SubDragDrop(Sender, Source: TObject; X, Y: Integer); begin if Assigned(OnDragDrop) then OnDragDrop(Sender, Source, X, Y); end; procedure TGradTabControl.PopupTabs(Sender: TObject); var tempMenu : TMenuItem; i : Integer; begin with FPagesPopup.Items do begin Clear; for i := 0 to PageCount-1 do begin tempMenu := TMenuItem.Create(FPagesPopup); tempMenu.Caption:=Page[i].Caption; tempMenu.OnClick:=@PopupMouseClick; tempMenu.Tag:=i; //DebugLn('I=%d OnClick-Assigned=%s',[i,BoolStr(Assigned(Page[i].TabButton.OnClick))]); Add(tempMenu); end; end; end; procedure TGradTabControl.MoveLeftTopClick(Sender: TObject); begin PagesBar.MoveToPrior; end; procedure TGradTabControl.MoveRightBottomClick(Sender: TObject); begin PagesBar.MoveToNext; end; {------------------------------------------------------------------------------ TGradTabControl PageRemoved(Index: Integer) ------------------------------------------------------------------------------} procedure TGradTabControl.PageRemoved(Index: Integer); var NewPageIndex: Integer; begin if not (csLoading in ComponentState) then begin // if this page is showing, then show the next page before deleting it if Index = FPageIndex then begin NewPageIndex := FindVisiblePage(Index); {$IFDEF DEBUGTAB} DebugLn('TGradTabControl.PageRemoved Index: %d NewPageIndex: %d',[Index, NewPageIndex]); {$ENDIF} if NewPageIndex >= 0 then PageIndex := NewPageIndex else FPageIndex := NewPageIndex; end; FPagesBar.OrderButtons; end; end; {------------------------------------------------------------------------------ TGradTabControl SetCurrentPage(Value : TGradTabPage) ------------------------------------------------------------------------------} procedure TGradTabControl.SetCurrentPage(Value : TGradTabPage); begin if FPageList.IndexOf(Value) = -1 then Exit; SetCurrentPageNum(FPageList.IndexOf(Value)); end; {------------------------------------------------------------------------------ TGradTabControl SetCurrentPageNum(Value: Integer) ------------------------------------------------------------------------------} procedure TGradTabControl.SetCurrentPageNum(Value: Integer); begin if (Value<0) or (Value>=fPageList.Count) then Exit; if FPageIndex=Value then Exit; if not Page[Value].Enabled then Exit; if not Page[Value].TabVisible then Exit; if FPageIndex <> -1 then UnShowPage(FPageIndex); ShowPage(Value); FPagesBar.FocusButton(Value); FPageIndex := Value; UpdateAllDesignerFlags; FPagesBar.OrderButtons; if ([csDesigning, csLoading, csDestroying] * ComponentState = []) and Assigned(OnPageChanged) then OnPageChanged(Self); end; procedure TGradTabControl.SetPagesBarDragOver(const AValue: TDragOverEvent); begin FPagesBar.OnDragOver:=AValue; end; {------------------------------------------------------------------------------ TGradTabControl ShowPage(Index: Integer) ------------------------------------------------------------------------------} procedure TGradTabControl.ShowPage(Index: Integer); begin // Focus the TabButton FPagesBar.FocusButton(Index); // Enable Page with TGradTabPage(FPageList.Items[Index]) do begin Visible:=true; BringToFront; end; UpdateDesignerFlags(Index); AlignPage(TGradTabPage(FPageList.Items[Index]), GetClientRect); end; {------------------------------------------------------------------------------ TGradTabControl UnShowPage(Index: Integer) ------------------------------------------------------------------------------} procedure TGradTabControl.UnShowPage(Index: Integer); begin // Disable Page if (Index<0) or (Index>=fPageList.Count) then Exit; // Focus the TabButton FPagesBar.UnFocusButton(Index); UpdateDesignerFlags(Index); with TGradTabPage(FPageList.Items[Index]) do Visible:=false; end; {------------------------------------------------------------------------------ TGradTabControl function ChildClassAllowed(ChildClass: TClass): boolean; ------------------------------------------------------------------------------} function TGradTabControl.ChildClassAllowed(ChildClass: TClass): boolean; begin {$IFDEF DEBUGTAB} DebugLn('TGradTabControl.ChildClassAllowed ',ChildClass.ClassName); {$ENDIF} Result := (ChildClass<>nil); Result := ChildClass.InheritsFrom(TGradTabPage) AND Result; if Result then Exit; if GetCurrentPage=nil then begin Result := ChildClass.InheritsFrom(TGradTabBar); end else begin if (ChildClass.InheritsFrom(TControl)) AND (NOT ChildClass.InheritsFrom(TGradTabPage)) then begin TControl(ChildClass.ClassParent).Parent := GetCurrentPage; Result := true; end; end; end; {------------------------------------------------------------------------------ TGradTabControl InsertPage(APage: TGradTabPage; Index: Integer) ------------------------------------------------------------------------------} procedure TGradTabControl.InsertPage(APage: TGradTabPage; Index: Integer); var NewZPosition: integer; cRect : TRect; tempName : String; begin if FPageList.IndexOf(APage)>=0 then exit; {$IFDEF DEBUGTAB} DebugLn(['TGradTabControl.InsertPage A ',dbgsName(Self),' Index=',Index,' Name=', APage.Name,' Caption=',APage.Caption]); {$ENDIF} APage.DisableAlign; try if Index=0 then SetControlIndex(APage,NewZPosition); if PageIndex = -1 then FPageIndex := Index; {$IFDEF DEBUGTAB}DebugLn('APage.Name empty: %s',[BoolToStr(APage.Name='',true)]);{$ENDIF} if HandleAllocated and (not (csLoading in ComponentState)) then begin AddRemovePageHandle(APage); if PageIndex = Index then ShowCurrentPage; end; finally APage.EnableAlign; AlignPage(APage, GetClientRect); SetCurrentPageNum(Index); end; {$IFDEF DEBUGTAB} DebugLn(['TGradTabControl.InsertPage END ',dbgsName(Self),' Index=', Index,' Name=',APage.Name,' Caption=',APage.Caption]); {$ENDIF} end; {------------------------------------------------------------------------------ TGradTabControl RemovePage(Index: Integer) ------------------------------------------------------------------------------} procedure TGradTabControl.AddRemovePageHandle(APage: TGradTabPage); begin if (not (csDestroying in APage.ComponentState)) and (APage.TabVisible or (csDesigning in ComponentState)) then begin {$IFDEF NOTEBOOK_DEBUG} DebugLn(['TGradTabControl.AddRemovePageHandle ADD ',DbgSName(APage),' pfAdded=',pfAdded in APage.FFlags]); {$ENDIF} if (pfAdded in APage.FFlags) then exit; Include(APage.FFlags,pfAdding); APage.FFlags:=APage.FFlags+[pfAdded]-[pfAdding]; APage.ResizeDelayedAutoSizeChildren end else begin {$IFDEF NOTEBOOK_DEBUG} DebugLn(['TGradTabControl.AddRemovePageHandle REMOVE ',DbgSName(APage),' pfAdded=',pfAdded in APage.FFlags]); {$ENDIF} if not (pfAdded in APage.FFlags) or (pfRemoving in APage.FFlags) then exit; APage.FFlags := APage.FFlags - [pfAdded] + [pfRemoving]; if APage.HandleAllocated then APage.DestroyHandle; Exclude(APage.FFlags, pfRemoving); end; end; {------------------------------------------------------------------------------ TGradTabControl RemovePage(Index: Integer) ------------------------------------------------------------------------------} procedure TGradTabControl.RemovePage(Index: Integer); var APage: TGradTabPage; begin if (Index >= 0) and (Index < FPageList.Count) then begin APage:=TGradTabPage(fPageList[Index]); APage.FTabVisible:=false; { TODO } if HandleAllocated then AddRemovePageHandle(APage); { TODO?} PageRemoved(Index); FPageList.Delete(Index); APage.Parent:=nil; if FPageIndex >= Index then Dec(FPageIndex); FPagesBar.OrderButtons; end; end; {------------------------------------------------------------------------------ TGradTabControl InvPaint ------------------------------------------------------------------------------} procedure TGradTabControl.InvPaint; begin if csDesigning in ComponentState then Invalidate else Paint; end; {------------------------------------------------------------------------------ TGradTabControl SetTabHeight(Value: Integer) ------------------------------------------------------------------------------} procedure TGradTabControl.SetTabHeight(Value: Integer); begin if FTabHeight = Value then Exit; FTabHeight:=Value; SetTabPosition(TabPosition); end; {------------------------------------------------------------------------------ TGradTabControl SetTabs(Value: TStrings) ------------------------------------------------------------------------------} procedure TGradTabControl.SetTabs(Value: TStrings); begin FTabStrings.Assign(Value); end; {------------------------------------------------------------------------------ TGradTabControl SetTabPosition(Value : TTabPosition) ------------------------------------------------------------------------------} procedure TGradTabControl.SetTabPosition(Value : TTabPosition); var tempSize : Integer; begin FTabPosition:=Value; tempSize:=FTabHeight; {$IFDEF DEBUGTAB} DebugLn('TGradTabControl.SetTabPosition Before'); DebugLn('FBar Left %d Top %d Height %d Width %d',[ FBar.Left, Fbar.Top, FBar.Height, FBar.Width]); DebugLn('FPagesBar Left %d Top %d Height %d Width %d',[ FPagesBar.Left, FPagesbar.Top, FPagesBar.Height, FPagesBar.Width]); DebugLn('Control Left %d Top %d Height %d Width %d',[ Left, Top, Height, Width]); {$ENDIF} FPagesBar.TabPosition:=Value; case Value of tpTop: begin FBar.Height:=FTabHeight; FBar.Top:=0; FBar.Left:=0; FBar.Width:=Width; //FBar.Align:=alTop; end; tpLeft:begin FBar.Height:=Height; FBar.Top:=0; FBar.Left:=0; FBar.Width:=GetTabBarSize(tpLeft); //FBar.Align:=alLeft; end; tpBottom:begin FBar.Height:=tempSize; FBar.Top:=Height-tempSize; FBar.Left:=0; FBar.Width:=Width; //FBar.Align := alBottom; end; tpRight:begin FBar.Left:=Width-GetTabBarSize(tpRight); FBar.Top:=0; FBar.Height:=Height; FBar.Width:=GetTabBarSize(tpRight); //FBar.Align:=alRight; end; end; //FPagesBar.Align:=alClient; case Value of tpTop: begin FLeftButton.Align:=alLeft; FLeftButton.RotateDirection:=rdNormal; FLeftButton.AutoWidth:=true; FLeftButton.AutoHeight:=false; FRightButton.Align:=alRight; FRightButton.RotateDirection:=rdNormal; FRightButton.AutoWidth:=true; FRightButton.AutoHeight:=false; //FBar.Align:=alTop; end; tpLeft:begin FLeftButton.Align:=alTop; FLeftButton.RotateDirection:=rdRight; FLeftButton.AutoWidth:=false; FLeftButton.AutoHeight:=true; FRightButton.Align:=alBottom; FRightButton.RotateDirection:=rdRight; FRightButton.AutoWidth:=false; FRightButton.AutoHeight:=true; //FBar.Align:=alLeft; end; tpBottom:begin FLeftButton.Align:=alLeft; FLeftButton.RotateDirection:=rdNormal; FLeftButton.AutoWidth:=true; FLeftButton.AutoHeight:=false; FRightButton.Align:=alRight; FRightButton.RotateDirection:=rdNormal; FRightButton.AutoWidth:=true; FRightButton.AutoHeight:=false; //FBar.Align := alBottom; end; tpRight:begin FLeftButton.Align:=alTop; FLeftButton.RotateDirection:=rdRight; FLeftButton.AutoWidth:=false; FLeftButton.AutoHeight:=true; FRightButton.Align:=alBottom; FRightButton.RotateDirection:=rdRight; FRightButton.AutoWidth:=false; FRightButton.AutoHeight:=true; //FBar.Align:=alRight; end; end; if not FPagesBar.IsVisible(FPageIndex) then FPagesBar.FocusButton(FPageIndex); {$IFDEF DEBUGTAB} DebugLn('TGradTabControl.SetTabPosition After'); DebugLn('FBar Left %d Top %d Height %d Width %d',[ FBar.Left, Fbar.Top, FBar.Height, FBar.Width]); DebugLn('FPagesBar Left %d Top %d Height %d Width %d',[ FPagesBar.Left, FPagesbar.Top, FPagesBar.Height, FPagesBar.Width]); DebugLn('Control Left %d Top %d Height %d Width %d',[ Left, Top, Height, Width]); {$ENDIF} AlignPages; InvPaint; end; {------------------------------------------------------------------------------ TGradTabControl SetLongTabs(Value : Boolean) ------------------------------------------------------------------------------} procedure TGradTabControl.SetLongTabs(Value : Boolean); begin if FLongTabs=Value then Exit; FLongTabs:=Value; SetTabPosition(TabPosition); end; {------------------------------------------------------------------------------ TGradTabControl Update ------------------------------------------------------------------------------} procedure TGradTabControl.Change; begin ShowCurrentPage; fPageIndexOnLastChange := fPageIndex; if ([csLoading,csDestroying]*ComponentState=[]) then begin if Assigned(fOnPageChanged) then fOnPageChanged(Self); end; end; procedure TGradTabControl.UpdateTabProperties; begin end; {------------------------------------------------------------------------------ TGradTabControl AddPage(AName: String) : Integer ------------------------------------------------------------------------------} function TGradTabControl.AddPage(AName: String) : Integer; begin Result := FTabStrings.Add(AName); end; {------------------------------------------------------------------------------ TGradTabControl AddPage(APage: TGradTabPage) : Integer ------------------------------------------------------------------------------} function TGradTabControl.AddPage(APage: TGradTabPage) : Integer; begin Result := FPageList.Count; FPageList.Insert(Result, APage); end; function TGradTabControl.GetTabBarSize(TabPos: TTabPosition): Integer; begin if TabPos in [tpTop,tpBottom] then Result := TabHeight else if LongTabs then Result := LongWidth else Result := TabHeight; end; {------------------------------------------------------------------------------ TGradTabControl GetClientRect: TRect ------------------------------------------------------------------------------} function TGradTabControl.GetClientRect: TRect; var tempR : TRect; begin tempR := Inherited; case FTabPosition of tpTop: begin tempR.Top:=FTabHeight+2; tempR.Left:=2; tempR.Right:=Width-2; tempR.Bottom:=Height-2; end; tpBottom: begin tempR.Top:=2; tempR.Left:=2; tempR.Right:=Width-2; tempR.Bottom:=Height-FTabHeight-2; end; tpRight: begin tempR.Top:=2; tempR.Left:=2; tempR.Right:=Width-GetTabBarSize(tpRight)-2; tempR.Bottom:=Height-2; end; tpLeft: begin tempR.Top:=2; tempR.Left:=GetTabBarSize(tpLeft)+2; tempR.Right:=Width-2; tempR.Bottom:=Height-2; end; end; Result := tempR; end; {------------------------------------------------------------------------------ TGradTabControl Paint ------------------------------------------------------------------------------} procedure TGradTabControl.Paint; var i,j : Integer; AClientRect : TRect; begin Canvas.Brush.Color:=Color; Canvas.FillRect(0,0,Width,Height); Canvas.Pen.Color:=clBlack; {case FTabPosition of tpTop: begin Canvas.Line(0,FTabHeight,0,Height); Canvas.Line(0,FTabHeight,Width,FTabHeight); Canvas.Line(Width-1,FTabHeight,Width-1,Height); Canvas.Line(0,Height-1,Width,Height-1); end; tpBottom: begin Canvas.Line(0,0,0,Height-FTabHeight); Canvas.Line(0,0,Width,0); //Top Canvas.Line(Width-1,0,Width-1,Height-FTabHeight); Canvas.Line(0,Height-FTabHeight-1,Width,Height-FTabHeight-1); end; tpRight: begin Canvas.Line(0,0,0,Height); //Left Canvas.Line(0,0,Width-GetTabBarSize(tpRight),0); //Top Canvas.Line(Width-1-GetTabBarSize(tpRight),0,Width-1-GetTabBarSize(tpRight),Height); //Right Canvas.Line(0,Height-1,Width-GetTabBarSize(tpRight),Height-1);//Bottom end; tpLeft: begin Canvas.Line(GetTabBarSize(tpLeft),0,GetTabBarSize(tpLeft),Height); //Left Canvas.Line(GetTabBarSize(tpLeft),0,Width,0); //Top Canvas.Line(Width-1,0,Width-1,Height); //Right Canvas.Line(GetTabBarSize(tpLeft),Height-1,Width,Height-1);//Bottom end; end;} AClientRect := GetClientRect; Canvas.Rectangle(AClientRect.Left-2, AClientRect.Top-2, AClientRect.Right+2, AClientRect.Bottom+2); end; {------------------------------------------------------------------------------ TGradTabControl Resize ------------------------------------------------------------------------------} procedure TGradTabControl.Resize; begin inherited; {$IFDEF DEBUGTAB} DebugLn('TGradTabControl.Resize HasParent %s FPageList.Count %d',[BoolToStr(HasParent,true), FPageList.Count]); {$ENDIF} if HasParent and (FPageList.Count<>0) then AlignPage(GetCurrentPage, GetClientRect); case FTabPosition of tpTop: begin FBar.Width:=Width; FBar.Top:=0; end; tpBottom: begin FBar.Width:=Width; FBar.Top:=Height-FTabHeight; end; tpLeft: begin FBar.Height:=Height; FBar.Left:=0; FBar.Top:=0; end; tpRight: begin FBar.Height:=Height; FBar.Left:=Width-GetTabBarSize(tpRight); FBar.Top:=0; end; end; end; {------------------------------------------------------------------------------ procedure TGradTabControl.UpdateAllDesignerFlags; ------------------------------------------------------------------------------} procedure TGradTabControl.UpdateAllDesignerFlags; var i: integer; begin for i:=0 to PageCount-1 do UpdateDesignerFlags(i); end; {------------------------------------------------------------------------------ TGradTabControl UpdateDesignerFlags(APageIndex: integer) ------------------------------------------------------------------------------} procedure TGradTabControl.UpdateDesignerFlags(APageIndex: integer); begin {$IFDEF DEBUGTAB} DebugLn('TGradTabControl.UpdateDesignerFlags: Index: %d Current: %d Assigned: %s',[APageIndex, FPageIndex,BoolToStr(Assigned(Page[APageIndex]),true)]); {$ENDIF} if APageIndex<>FPageIndex then Page[APageIndex].ControlStyle:= Page[APageIndex].ControlStyle+[csNoDesignVisible{,csNoDesignSelectable}] else Page[APageIndex].ControlStyle:= Page[APageIndex].ControlStyle-[csNoDesignVisible{,csNoDesignSelectable}]; {$IFDEF DEBUGTAB} DebugLn('TGradTabControl.UpdateDesignerFlags End'); {$ENDIF} end; {------------------------------------------------------------------------------ TGradTabControl.ShowCurrentPage ------------------------------------------------------------------------------} procedure TGradTabControl.ShowCurrentPage; var CurPage: TGradTabPage; begin if (FPageIndex >= 0) and (FPageIndex < FPageList.Count) then begin CurPage:=Page[FPageIndex]; // first make the new page visible {$IFDEF DEBUGTAB}DebugLn(['TGradTabControl.ShowCurrentPage ',DbgSName(CurPage),' CurPage.Visible=',CurPage.Visible]);{$ENDIF} if CurPage.Visible then begin if FPageIndexOnLastShow<>fPageIndex then begin // some widgetsets like win32/64 do not send WM_SIZE messages for // hidden pages. Force resizing page (it is alClient). {$IFDEF DEBUGTAB} DebugLn(['TGradTabControl.ShowCurrentPage ',dbgsName(Self),' ',DbgSName(CurPage),' CurPage.Visible=',CurPage.Visible,' BoundsRect=',dbgs(BoundsRect),' ClientRect=',dbgs(ClientRect),' CurPage.BoundsRect=',dbgs(CurPage.BoundsRect),' CurPage.ClientRect=',dbgs(CurPage.ClientRect)]); {$ENDIF} ReAlign; // TCustomPage.IsControlVisible is overriden // therefore AutoSizing of childs was skipped => do it now CurPage.ReAlign; end; end else begin CurPage.Visible := true; end; end; end; { TFormPage } constructor TFormPage.Create(AOwner: TComponent); begin inherited Create(AOwner); FShowPageAtDestroy:=false; FDestroyPageAtDestroy:=false; end; destructor TFormPage.Destroy; var FOld : TCustomForm; begin if FDestroyPageAtDestroy AND (FOldForm <> nil) then begin FOld := FOldForm; PageToForm(false); FOld.Free; FOld := nil; end else PageToForm(FShowPageAtDestroy); inherited Destroy; end; procedure TFormPage.FormToPage(TheForm: TCustomForm); var i : Integer; begin if FOldForm = TheForm then Exit; FOldForm := TheForm; for i := TheForm.ControlCount-1 downto 0 do begin TheForm.Controls[i].Parent := Self; end; Caption:=TheForm.Caption; if TheForm.Visible then TheForm.Close; end; procedure TFormPage.PageToForm(AShow : Boolean); var i : Integer; begin for i := ControlCount-1 downto 0 do begin Controls[i].Parent := FOldForm; end; if AShow then FOldForm.Show; FOldForm := nil; end; initialization {$I ugradtabcontrol.lrs} end.