{*******************************************************} { } { TabedMdiChild } { } { Component derived from TPageControl implementing } { "TabedBrowsing" for } { MDI-Children. } { } { Copyright (c) 2006 Christian Rehn aka R2C2 } { } { Diese Klasse ist für alle gedacht, die meinen } { sie nützlich finden zu müssen ;-) } { This class is intended for everybody thinking } { it is useful ;-) } { } {*******************************************************} //TODO: CloseButton //TODO: Colored unit TMdiTabs_class; interface uses Classes, Forms, ComCtrls, Contnrs, Menus, Controls; type TTabedMdiChild = class(TForm) type TNameChangeEvent = procedure (AChild: TTabedMdiChild; const AOldName: string; var ANewName: string) of object; TMdiChildEvent = procedure (AChild: TTabedMdiChild) of object; strict private FTabName:string; FOnTabNameChange: TNameChangeEvent; FOnHintChange: TNameChangeEvent; FOnClose2: TMdiChildEvent; FOnActivate2: TMdiChildEvent; strict protected procedure SetTabName(Value: string); virtual; procedure SetHint(AHint: string); virtual; public destructor Destroy; override; property OnTabNameChange: TNameChangeEvent read FOnTabNameChange write FOnTabNameChange; property OnHintChange: TNameChangeEvent read FOnHintChange write FOnHintChange; property OnClose2: TMdiChildEvent read FOnClose2 write FOnClose2; property OnActivate2: TMdichildEvent read FOnActivate2 write FOnActivate2; procedure Activate; override; published property TabName: string read FTabName write SetTabName; property Hint write SetHint; end; TMdiTab = class; TMdiTabs = class(TPageControl) strict private FUseChildHints: Boolean; FTabMoving: Boolean; FPopup: TPopupMenu; function GetPage(AIndex: Integer): TMdiTab; procedure SetActivePage(const Value: TMdiTab); function GetActivePage: TMdiTab; function GetTabByChild(AChild: TTabedMdiChild): TMdiTab; virtual; procedure ChildTabNameChanged(AChild: TTabedMdiChild; const AOldName: string; var ANewName: string); virtual; procedure ChildClosed(AChild: TTabedMdiChild); virtual; procedure ChildActivated(AChild: TTabedMdiChild); virtual; procedure ChildHintChanged(AChild: TTabedMdiChild; const AOldName: string; var ANewName: string); virtual; procedure PopupClose(Sender: TObject); virtual; procedure PopupMoveLeft(Sender: TObject); virtual; procedure PopupMoveRight(Sender: TObject); virtual; public constructor Create(AOwner: TComponent); override; property Pages[AIndex: Integer]: TMdiTab read GetPage; property ActivePage: TMdiTab read GetActivePage write SetActivePage; procedure Change; override; procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; procedure MouseMove(Shift: TShiftState; X, Y: Integer); override; procedure DragOver(Source: TObject; X, Y: Integer; State: TDragState; var Accept: Boolean); override; procedure DragDrop(Source: TObject; X, Y: Integer); override; procedure AddChild(AChild: TTabedMdiChild); virtual; published property Color; property ParentColor; property UseChildHints: Boolean read FUseChildHints write FUseChildHints; property TabMoving: Boolean read FTabMoving write FTabMoving; end; TMdiTab = class(TTabsheet) strict private FMdiChild:TTabedMdiChild; public constructor Create(AOwner: TComponent; AMdiChild: TTabedMdiChild); reintroduce; property MdiChild : TTabedMdiChild read FMdiChild; end; procedure Register; implementation uses SysUtils, Math, Graphics; procedure Register; begin RegisterComponents('R2C2', [TMdiTabs]); end; {$REGION 'TTabedMdiChild'} destructor TTabedMdiChild.Destroy; begin if Assigned(FOnClose2) then FOnClose2(self); inherited; end; procedure TTabedMdiChild.SetHint(AHint: string); begin if Assigned(FOnHintChange) then FOnHintChange(Self, Hint, AHint); inherited Hint := AHint; end; procedure TTabedMdiChild.SetTabName(Value: string); begin if Assigned(FOnTabNameChange) then FOnTabNameChange(Self, FTabName, Value); FTabName := Value; end; procedure TTabedMdiChild.activate; begin inherited; if Assigned(FOnActivate2) then FOnActivate2(Self); end; {$ENDREGION} {$REGION 'TMdiTabs'} constructor TMdiTabs.Create(AOwner: TComponent); var item: TMenuItem; begin inherited Create(AOwner); Align := alTop; HotTrack := True; Height := 25; Constraints.MaxHeight := 25; Constraints.MinHeight := 25; FUseChildHints := True; FTabMoving := True; FPopup := TPopupMenu.Create(Self); item := TMenuItem.Create(FPopup); item.Caption := 'Seite schließen'; item.OnClick := PopupClose; FPopup.Items.Add(item); item := TMenuItem.Create(FPopup); item.Caption := '-'; FPopup.Items.Add(item); item := TMenuItem.Create(FPopup); item.Caption := 'nach links verschieben'; item.OnClick := PopupMoveLeft; FPopup.Items.Add(item); item := TMenuItem.Create(FPopup); item.Caption := 'nach rechts verschieben'; item.OnClick := PopupMoveRight; FPopup.Items.Add(item); PopupMenu := FPopup; end; function TMdiTabs.GetTabByChild(AChild: TTabedMdiChild): TMdiTab; var i: Integer; begin Result := nil; for i := PageCount -1 downto 0 do begin if Pages[i].MdiChild = AChild then begin Result := Pages[i]; end; end; end; procedure TMdiTabs.Change; begin inherited; ActivePage.MdiChild.Show; end; {$REGION 'Popup'} procedure TMdiTabs.PopupClose(Sender: TObject); begin ActivePage.MdiChild.Close; end; procedure TMdiTabs.PopupMoveLeft(Sender: TObject); begin if ActivePage.PageIndex > 0 then ActivePage.PageIndex := ActivePage.PageIndex -1; end; procedure TMdiTabs.PopupMoveRight(Sender: TObject); begin if ActivePage.PageIndex < (PageCount -1) then ActivePage.PageIndex := ActivePage.PageIndex +1; end; {$ENDREGION} {$REGION 'Drag & Drop'} procedure TMdiTabs.DragDrop(Source: TObject; X, Y: Integer); begin inherited; ActivePage.PageIndex := IndexOfTabAt(X, Y); end; procedure TMdiTabs.DragOver(Source: TObject; X, Y: Integer; State: TDragState; var Accept: Boolean); begin inherited; if IndexOfTabAt(X, Y) <> -1 then Accept := True; end; {$ENDREGION} procedure TMdiTabs.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin inherited MouseDown(Button, Shift, X, Y); if Button = mbRight then begin // right mouse-button changes tabs(just like the left one) ActivePageIndex := IndexOfTabAt(X, Y); Change; end else if (Button = mbLeft) and (FTabMoving) then begin BeginDrag(False, 10); end; end; procedure TMdiTabs.MouseMove(Shift: TShiftState; X, Y: Integer); begin if FUseChildHints then Hint := Pages[IndexOfTabAt(X, Y)].MdiChild.Hint; end; {$REGION 'Getter & setter'} function TMdiTabs.GetActivePage: TMdiTab; begin Result := TMdiTab(inherited ActivePage); end; procedure TMdiTabs.SetActivePage(const Value: TMdiTab); begin inherited ActivePage := Value; end; function TMdiTabs.GetPage(AIndex: Integer): TMdiTab; begin Result := TMdiTab(inherited Pages[AIndex]); end; {$ENDREGION} procedure TMdiTabs.AddChild(AChild: TTabedMdiChild); var Tab: TMdiTab; begin if GetTabByChild(AChild) = nil then begin Tab := TMdiTab.Create(Self, AChild); Tab.PageControl := Self; Tab.Caption := AChild.TabName; Tab.Hint := AChild.Hint; AChild.OnTabNameChange := ChildTabNameChanged; AChild.OnClose2 := ChildClosed; AChild.OnHintChange := ChildHintChanged; AChild.OnActivate2 := ChildActivated; AChild.Activate; end else begin raise Exception.Create('Tab already existent.'); end; end; {$REGION 'event handlers for children'} procedure TMdiTabs.ChildActivated(AChild: TTabedMdiChild); var Tab: TMdiTab; begin Tab := GetTabByChild(AChild); Tab.PageControl.ActivePage := Tab; end; procedure TMdiTabs.ChildClosed(AChild: TTabedMdiChild); var Tab: TMdiTab; begin Tab := GetTabByChild(AChild); Tab.Free; end; procedure TMdiTabs.ChildTabNameChanged(AChild: TTabedMdiChild; const AOldName: string; var ANewName: string); var Tab: TMdiTab; begin Tab := GetTabByChild(AChild); if Tab <> nil then Tab.Caption := ANewName; end; procedure TMdiTabs.ChildHintChanged(AChild: TTabedMdiChild; const AOldName: string; var ANewName: string); var Tab: TMdiTab; begin Tab := GetTabByChild(AChild); Tab.Hint := ANewName; end; {$ENDREGION} {$ENDREGION} {$REGION 'TMdiTab'} constructor TMdiTab.Create(AOwner: TComponent; AMdiChild: TTabedMdiChild); begin inherited Create(AOwner); FMdiChild := AMdiChild; end; {$ENDREGION} end.