771 lines
22 KiB
ObjectPascal

unit spkt_Tab;
{$mode delphi}
{.$Define EnhancedRecordSupport}
(*******************************************************************************
* *
* File: spkt_Tab.pas *
* Description: Toolbar component tab *
* Copyright: (c) 2009 by Spook. *
* License: Modified LGPL (with linking exception, like Lazarus LCL) *
' See "license.txt" in this installation *
* *
*******************************************************************************)
interface
uses
Graphics, Controls, Classes, SysUtils,
SpkMath,
spkt_Appearance, spkt_Const, spkt_Dispatch, spkt_Exceptions,
spkt_Pane, spkt_Types;
type
TSpkTab = class;
TSpkMouseTabElementType = (etNone, etTabArea, etPane);
TSpkMouseTabElement = record
ElementType: TSpkMouseTabElementType;
ElementIndex: integer;
end;
TSpkTabAppearanceDispatch = class(TSpkBaseAppearanceDispatch)
private
FTab: TSpkTab;
public
// *** Constructor ***
constructor Create(ATab: TSpkTab);
// *** Implementation of methods inherited from TSpkBaseTabDispatch ***
procedure NotifyAppearanceChanged; override;
end;
TSpkTab = class(TSpkComponent)
private
FAppearanceDispatch: TSpkTabAppearanceDispatch;
FAppearance: TSpkToolbarAppearance;
FMouseHoverElement: TSpkMouseTabElement;
FMouseActiveElement: TSpkMouseTabElement;
FOnClick: TNotifyEvent;
protected
FToolbarDispatch: TSpkBaseToolbarDispatch;
FCaption: string;
FVisible: boolean;
FOverrideAppearance: boolean;
FCustomAppearance: TSpkToolbarAppearance;
FPanes: TSpkPanes;
FRect: T2DIntRect;
FImages: TImageList;
FDisabledImages: TImageList;
FLargeImages: TImageList;
FDisabledLargeImages: TImageList;
FImagesWidth: Integer;
FLargeImagesWidth: Integer;
// *** Sets the appropriate appearance tiles ***
procedure SetPaneAppearance; inline;
// *** Sheet search ***
function FindPaneAt(x, y: integer): integer;
// *** Designtime and LFM support ***
procedure GetChildren(Proc: TGetChildProc; Root: TComponent); override;
procedure DefineProperties(Filer: TFiler); override;
procedure Loaded; override;
// *** Getters and setters ***
procedure SetCaption(const Value: string);
procedure SetCustomAppearance(const Value: TSpkToolbarAppearance);
procedure SetOverrideAppearance(const Value: boolean);
procedure SetVisible(const Value: boolean);
procedure SetAppearance(const Value: TSpkToolbarAppearance);
procedure SetImages(const Value: TImageList);
procedure SetDisabledImages(const Value: TImageList);
procedure SetLargeImages(const Value: TImageList);
procedure SetDisabledLargeImages(const Value: TImageList);
procedure SetImagesWidth(const Value: Integer);
procedure SetLargeImagesWidth(const Value: Integer);
procedure SetRect(ARect: T2DIntRect);
procedure SetToolbarDispatch(const Value: TSpkBaseToolbarDispatch);
public
// *** Constructor, destructor ***
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
// *** Geometry, sheet service, drawing ***
function AtLeastOnePaneVisible: boolean;
procedure Draw(ABuffer: TBitmap; AClipRect: T2DIntRect);
// *** Mouse support ***
procedure MouseLeave;
procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
procedure MouseMove(Shift: TShiftState; X, Y: Integer);
procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
// *** Dispatcher event handling ***
procedure NotifyAppearanceChanged;
// *** Support for elements ***
procedure FreeingPane(APane: TSpkPane);
procedure ExecOnClick;
property ToolbarDispatch: TSpkBaseToolbarDispatch read FToolbarDispatch write SetToolbarDispatch;
property Appearance: TSpkToolbarAppearance read FAppearance write SetAppearance;
property Panes: TSpkPanes read FPanes;
property Rect: T2DIntRect read FRect write SetRect;
property Images: TImageList read FImages write SetImages;
property DisabledImages: TImageList read FDisabledImages write SetDisabledImages;
property LargeImages: TImageList read FLargeImages write SetLargeImages;
property DisabledLargeImages: TImageList read FDisabledLargeImages write SetDisabledLargeImages;
property ImagesWidth: Integer read FImagesWidth write SetImagesWidth;
property LargeImagesWidth: Integer read FLargeImagesWidth write SetLargeImagesWidth;
published
property CustomAppearance: TSpkToolbarAppearance read FCustomAppearance write SetCustomAppearance;
property Caption: string read FCaption write SetCaption;
property OverrideAppearance: boolean read FOverrideAppearance write SetOverrideAppearance default false;
property Visible: boolean read FVisible write SetVisible default true;
property OnClick: TNotifyEvent read FOnClick write FOnClick;
end;
TSpkTabs = class(TSpkCollection)
protected
FToolbarDispatch: TSpkBaseToolbarDispatch;
FAppearance: TSpkToolbarAppearance;
FImages: TImageList;
FDisabledImages: TImageList;
FLargeImages: TImageList;
FDisabledLargeImages: TImageList;
FImagesWidth: Integer;
FLargeImagesWidth: Integer;
procedure SetToolbarDispatch(const Value: TSpkBaseToolbarDispatch);
function GetItems(AIndex: integer): TSpkTab; reintroduce;
procedure SetAppearance(const Value: TSpkToolbarAppearance);
procedure SetImages(const Value: TImageList);
procedure SetDisabledImages(const Value: TImageList);
procedure SetLargeImages(const Value: TImageList);
procedure SetDisabledLargeImages(const Value: TImageList);
procedure SetImagesWidth(const Value: Integer);
procedure SetLargeImagesWidth(const Value: Integer);
public
function Add: TSpkTab;
function Insert(AIndex: integer): TSpkTab;
procedure Notify(Item: TComponent; Operation: TOperation); override;
procedure Update; override;
property Items[index: integer]: TSpkTab read GetItems; default;
property ToolbarDispatch: TSpkBaseToolbarDispatch read FToolbarDispatch write SetToolbarDispatch;
property Appearance: TSpkToolbarAppearance read FAppearance write SetAppearance;
property Images: TImageList read FImages write SetImages;
property DisabledImages: TImageList read FDisabledImages write SetDisabledImages;
property LargeImages: TImageList read FLargeImages write SetLargeImages;
property DisabledLargeImages: TImageList read FDisabledLargeImages write SetDisabledLargeImages;
property ImagesWidth: Integer read FImagesWidth write SetImagesWidth;
property LargeImagesWidth: Integer read FLargeImagesWidth write SetLargeImagesWidth;
end;
implementation
{ TSpkTabDispatch }
constructor TSpkTabAppearanceDispatch.Create(ATab: TSpkTab);
begin
inherited Create;
FTab := ATab;
end;
procedure TSpkTabAppearanceDispatch.NotifyAppearanceChanged;
begin
if Assigned(FTab) then
FTab.NotifyAppearanceChanged;
end;
{ TSpkTab }
constructor TSpkTab.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FAppearanceDispatch := TSpkTabAppearanceDispatch.Create(self);
FMouseHoverElement.ElementType := etNone;
FMouseHoverElement.ElementIndex := -1;
FMouseActiveElement.ElementType := etNone;
FMouseActiveElement.ElementIndex := -1;
FCaption := 'Tab';
FVisible := true;
FCustomAppearance := TSpkToolbarAppearance.Create(FAppearanceDispatch);
FPanes := TSpkPanes.Create(self);
FPanes.ToolbarDispatch := FToolbarDispatch;
FPanes.ImagesWidth := FImagesWidth;
FPanes.LargeImagesWidth := FLargeImagesWidth;
{$IFDEF EnhancedRecordSupport}
FRect := T2DIntRect.Create(0,0,0,0);
{$ELSE}
FRect.Create(0,0,0,0);
{$ENDIF}
SetPaneAppearance;
end;
destructor TSpkTab.Destroy;
begin
FPanes.Free;
FCustomAppearance.Free;
FAppearanceDispatch.Free;
inherited Destroy;
end;
function TSpkTab.AtLeastOnePaneVisible: boolean;
var
i: integer;
PaneVisible: boolean;
begin
Result := (FPanes.Count > 0);
if Result then
begin
PaneVisible := false;
i := FPanes.Count - 1;
while (i >= 0) and not PaneVisible do
begin
PaneVisible := FPanes[i].Visible;
dec(i);
end;
Result := Result and PaneVisible;
end;
end;
procedure TSpkTab.SetRect(ARect: T2DIntRect);
var
x, i: integer;
tw: integer;
tmpRect: T2DIntRect;
begin
FRect := ARect;
if AtLeastOnePaneVisible then
begin
x := ARect.left;
for i := 0 to FPanes.Count - 1 do
if FPanes[i].Visible then
begin
tw := FPanes[i].GetWidth;
tmpRect.Left := x;
tmpRect.Top := ARect.Top;
tmpRect.Right := x + tw - 1;
tmpRect.Bottom := ARect.bottom;
FPanes[i].Rect := tmpRect;
x := x + tw + TabPaneHSpacing;
end
else
begin
{$IFDEF EnhancedRecordSupport}
FPanes[i].Rect := T2DIntRect.Create(-1,-1,-1,-1);
{$ELSE}
FPanes[i].Rect.Create(-1,-1,-1,-1);
{$ENDIF}
end;
end;
end;
procedure TSpkTab.SetToolbarDispatch(const Value: TSpkBaseToolbarDispatch);
begin
FToolbarDispatch := Value;
FPanes.ToolbarDispatch := FToolbarDispatch;
end;
procedure TSpkTab.DefineProperties(Filer: TFiler);
begin
inherited DefineProperties(Filer);
Filer.DefineProperty('Panes', FPanes.ReadNames, FPanes.WriteNames, true);
end;
procedure TSpkTab.Draw(ABuffer: TBitmap; AClipRect: T2DIntRect);
var
LocalClipRect: T2DIntRect;
i: integer;
begin
if AtLeastOnePaneVisible then
for i := 0 to FPanes.Count - 1 do
if FPanes[i].visible then
begin
if AClipRect.IntersectsWith(FPanes[i].Rect, LocalClipRect) then
FPanes[i].Draw(ABuffer, LocalClipRect);
end;
end;
procedure TSpkTab.ExecOnClick;
begin
if Assigned(FOnClick) then
FOnClick(self);
end;
function TSpkTab.FindPaneAt(x, y: integer): integer;
var
i: integer;
begin
Result := -1;
i := FPanes.Count - 1;
while (i >= 0) and (Result = -1) do
begin
if FPanes[i].Visible then
begin
{$IFDEF EnhancedRecordSupport}
if FPanes[i].Rect.Contains(T2DIntVector.Create(x,y)) then
{$ELSE}
if FPanes[i].Rect.Contains(x,y) then
{$ENDIF}
Result := i;
end;
dec(i);
end;
end;
procedure TSpkTab.FreeingPane(APane: TSpkPane);
begin
FPanes.RemoveReference(APane);
end;
procedure TSpkTab.GetChildren(Proc: TGetChildProc; Root: TComponent);
var
i: Integer;
begin
inherited;
for i := 0 to FPanes.Count - 1 do
Proc(FPanes.Items[i]);
end;
procedure TSpkTab.Loaded;
begin
inherited;
if FPanes.ListState = lsNeedsProcessing then
FPanes.ProcessNames(self.Owner);
end;
procedure TSpkTab.MouseDown(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer);
begin
if FMouseActiveElement.ElementType = etPane then
begin
if FMouseActiveElement.ElementIndex <> -1 then
FPanes[FMouseActiveElement.ElementIndex].MouseDown(Button, Shift, X, Y);
end else
if FMouseActiveElement.ElementType = etTabArea then
begin
// Placeholder, if there is a need to handle this event.
end else
if FMouseActiveElement.ElementType = etNone then
begin
if FMouseHoverElement.ElementType = etPane then
begin
if FMouseHoverElement.ElementIndex <> -1 then
begin
FMouseActiveElement.ElementType := etPane;
FMouseActiveElement.ElementIndex := FMouseHoverElement.ElementIndex;
FPanes[FMouseHoverElement.ElementIndex].MouseDown(Button, Shift, X, Y);
end
else
begin
FMouseActiveElement.ElementType := etTabArea;
FMouseActiveElement.ElementIndex := -1;
end;
end else
if FMouseHoverElement.ElementType = etTabArea then
begin
FMouseActiveElement.ElementType := etTabArea;
FMouseActiveElement.ElementIndex := -1;
// Placeholder, if there is a need to handle this event.
end;
end;
end;
procedure TSpkTab.MouseLeave;
begin
if FMouseActiveElement.ElementType = etNone then
begin
if FMouseHoverElement.ElementType = etPane then
begin
if FMouseHoverElement.ElementIndex <> -1 then
FPanes[FMouseHoverElement.ElementIndex].MouseLeave;
end else
if FMouseHoverElement.ElementType = etTabArea then
begin
// Placeholder, if there is a need to handle this event.
end;
end;
FMouseHoverElement.ElementType := etNone;
FMouseHoverElement.ElementIndex := -1;
end;
procedure TSpkTab.MouseMove(Shift: TShiftState; X, Y: Integer);
var
i: integer;
NewMouseHoverElement: TSpkMouseTabElement;
begin
// We're looking for an object under the mouse
i := FindPaneAt(X, Y);
if i <> -1 then
begin
NewMouseHoverElement.ElementType := etPane;
NewMouseHoverElement.ElementIndex := i;
end else
if (X >= FRect.left) and (Y >= FRect.top) and
(X <= FRect.right) and (Y <= FRect.bottom) then
begin
NewMouseHoverElement.ElementType := etTabArea;
NewMouseHoverElement.ElementIndex := -1;
end else
begin
NewMouseHoverElement.ElementType := etNone;
NewMouseHoverElement.ElementIndex := -1;
end;
if FMouseActiveElement.ElementType = etPane then
begin
if FMouseActiveElement.ElementIndex <> -1 then
begin
FPanes[FMouseActiveElement.ElementIndex].MouseMove(Shift, X, Y);
end;
end else
if FMouseActiveElement.ElementType = etTabArea then
begin
// Placeholder, if there is a need to handle this event
end else
if FMouseActiveElement.ElementType = etNone then
begin
// If the item under the mouse changes, we inform the previous element
// that the mouse leaves its area
if (NewMouseHoverElement.ElementType <> FMouseHoverElement.ElementType) or
(NewMouseHoverElement.ElementIndex <> FMouseHoverElement.ElementIndex) then
begin
if FMouseHoverElement.ElementType = etPane then
begin
if FMouseHoverElement.ElementIndex <> -1 then
FPanes[FMouseHoverElement.ElementIndex].MouseLeave;
end else
if FMouseHoverElement.ElementType = etTabArea then
begin
// Placeholder, if there is a need to handle this event
end;
end;
if NewMouseHoverElement.ElementType = etPane then
begin
if NewMouseHoverElement.ElementIndex <> -1 then
FPanes[NewMouseHoverElement.ElementIndex].MouseMove(Shift, X, Y);
end else
if NewMouseHoverElement.ElementType = etTabArea then
begin
// Placeholder, if there is a need to handle this event
end;
end;
FMouseHoverElement := NewMouseHoverElement;
end;
procedure TSpkTab.MouseUp(Button: TMouseButton; Shift: TShiftState; X,
Y: Integer);
var
ClearActive: boolean;
begin
ClearActive := not (ssLeft in Shift) and not (ssMiddle in Shift) and not (ssRight in Shift);
if FMouseActiveElement.ElementType = etPane then
begin
if FMouseActiveElement.ElementIndex <> -1 then
FPanes[FMouseActiveElement.ElementIndex].MouseUp(Button, Shift, X, Y);
end else
if FMouseActiveElement.ElementType = etTabArea then
begin
// Placeholder, if there is a need to handle this event.
end;
if ClearActive and
(FMouseActiveElement.ElementType <> FMouseHoverElement.ElementType) or
(FMouseActiveElement.ElementIndex <> FMouseHoverElement.ElementIndex) then
begin
if FMouseActiveElement.ElementType = etPane then
begin
if FMouseActiveElement.ElementIndex <> -1 then
FPanes[FMouseActiveElement.ElementIndex].MouseLeave;
end else
if FMouseActiveElement.ElementType = etTabArea then
begin
// Placeholder, if there is a need to handle this event.
end;
if FMouseHoverElement.ElementType = etPane then
begin
if FMouseHoverElement.ElementIndex <> -1 then
FPanes[FMouseHoverElement.ElementIndex].MouseMove(Shift, X, Y);
end else
if FMouseHoverElement.ElementType = etTabArea then
begin
// Placeholder, if there is a need to handle this event.
end;
end;
if ClearActive then
begin
FMouseActiveElement.ElementType := etNone;
FMouseActiveElement.ElementIndex := -1;
end;
end;
procedure TSpkTab.NotifyAppearanceChanged;
begin
if Assigned(FToolbarDispatch) then
FToolbarDispatch.NotifyAppearanceChanged;
end;
procedure TSpkTab.SetCustomAppearance(const Value: TSpkToolbarAppearance);
begin
FCustomAppearance.Assign(Value);
end;
procedure TSpkTab.SetDisabledImages(const Value: TImageList);
begin
FDisabledImages := Value;
FPanes.DisabledImages := Value;
end;
procedure TSpkTab.SetDisabledLargeImages(const Value: TImageList);
begin
FDisabledLargeImages := Value;
FPanes.DisabledLargeImages := Value;
end;
procedure TSpkTab.SetImages(const Value: TImageList);
begin
FImages := Value;
FPanes.Images := Value;
end;
procedure TSpkTab.SetImagesWidth(const Value: Integer);
begin
FImagesWidth := Value;
FPanes.ImagesWidth := Value;
end;
procedure TSpkTab.SetLargeImages(const Value: TImageList);
begin
FLargeImages := Value;
FPanes.LargeImages := Value;
end;
procedure TSpkTab.SetLargeImagesWidth(const Value: Integer);
begin
FLargeImagesWidth := Value;
FPanes.LargeImagesWidth := Value;
end;
procedure TSpkTab.SetAppearance(const Value: TSpkToolbarAppearance);
begin
FAppearance := Value;
SetPaneAppearance;
if FToolbarDispatch <> nil then
FToolbarDispatch.NotifyMetricsChanged;
end;
procedure TSpkTab.SetCaption(const Value: string);
begin
FCaption := Value;
if Assigned(FToolbarDispatch) then
FToolbarDispatch.NotifyMetricsChanged;
end;
procedure TSpkTab.SetOverrideAppearance(const Value: boolean);
begin
FOverrideAppearance := Value;
SetPaneAppearance;
if FToolbarDispatch <> nil then
FToolbarDispatch.NotifyMetricsChanged;
end;
procedure TSpkTab.SetPaneAppearance;
begin
if FOverrideAppearance then
FPanes.Appearance := FCustomAppearance
else
FPanes.Appearance := FAppearance;
// The method plays the role of a macro - therefore it does not
// notify the dispatcher about the change.
end;
procedure TSpkTab.SetVisible(const Value: boolean);
begin
FVisible := Value;
if FToolbarDispatch <> nil then
FToolbarDispatch.NotifyItemsChanged;
end;
{ TSpkTabs }
function TSpkTabs.Add: TSpkTab;
begin
Result := TSpkTab.create(FRootComponent);
Result.Parent := FRootComponent;
AddItem(Result);
end;
function TSpkTabs.GetItems(AIndex: integer): TSpkTab;
begin
Result := TSpkTab(inherited Items[AIndex]);
end;
function TSpkTabs.Insert(AIndex: integer): TSpkTab;
var
lOwner, lParent: TComponent;
i: Integer;
begin
if (AIndex < 0) or (AIndex >= self.Count) then
raise InternalException.Create('TSpkTabs.Insert: Invalid index!');
if FRootComponent<>nil then
begin
lOwner := FRootComponent.Owner;
lParent := FRootComponent;
end
else
begin
lOwner := nil;
lParent := nil;
end;
Result := TSpkTab.Create(lOwner);
Result.Parent := lParent;
if FRootComponent<>nil then
begin
i := 0;
while FRootComponent.Owner.FindComponent('SpkTab'+IntToStr(i)) <> nil do
inc(i);
Result.Name := 'SpkTab' + IntToStr(i);
end;
InsertItem(AIndex, Result);
end;
procedure TSpkTabs.Notify(Item: TComponent; Operation: TOperation);
begin
inherited Notify(Item, Operation);
case Operation of
opInsert:
begin
// Setting the dispatcher to nil will cause that during the
// ownership assignment, the Notify method will not be called
TSpkTab(Item).ToolbarDispatch := nil;
TSpkTab(Item).Appearance := self.FAppearance;
TSpkTab(Item).Images := self.FImages;
TSpkTab(Item).DisabledImages := self.FDisabledImages;
TSpkTab(Item).LargeImages := self.FLargeImages;
TSpkTab(Item).DisabledLargeImages := self.FDisabledLargeImages;
TSpkTab(Item).ImagesWidth := self.FImagesWidth;
TSpkTab(Item).LargeImagesWidth := self.FLargeImagesWidth;
TSpkTab(Item).ToolbarDispatch := self.FToolbarDispatch;
end;
opRemove:
if not(csDestroying in Item.ComponentState) then
begin
TSpkTab(Item).ToolbarDispatch := nil;
TSpkTab(Item).Appearance := nil;
TSpkTab(Item).Images := nil;
TSpkTab(Item).DisabledImages := nil;
TSpkTab(Item).LargeImages := nil;
TSpkTab(Item).DisabledLargeImages := nil;
// TSpkTab(Item).ImagesWidth := 0;
// TSpkTab(Item).LargeImagesWidth := 0;
end;
end;
end;
procedure TSpkTabs.SetAppearance(const Value: TSpkToolbarAppearance);
var
i: Integer;
begin
FAppearance := Value;
for i := 0 to self.Count - 1 do
self.Items[i].Appearance := FAppearance;
end;
procedure TSpkTabs.SetDisabledImages(const Value: TImageList);
var
i: Integer;
begin
FDisabledImages := Value;
for i := 0 to self.Count - 1 do
Items[i].DisabledImages := Value;
end;
procedure TSpkTabs.SetDisabledLargeImages(const Value: TImageList);
var
i: Integer;
begin
FDisabledLargeImages := Value;
for i := 0 to self.count - 1 do
Items[i].DisabledLargeImages := Value;
end;
procedure TSpkTabs.SetImages(const Value: TImageList);
var
i: Integer;
begin
FImages := Value;
for i := 0 to self.Count - 1 do
Items[i].Images := Value;
end;
procedure TSpkTabs.SetImagesWidth(const Value: Integer);
var
i: Integer;
begin
FImagesWidth := Value;
for i := 0 to Count - 1 do
Items[i].ImagesWidth := Value;
end;
procedure TSpkTabs.SetLargeImages(const Value: TImageList);
var
i: Integer;
begin
FLargeImages := Value;
for i := 0 to self.Count - 1 do
Items[i].LargeImages := Value;
end;
procedure TSpkTabs.SetLargeImagesWidth(const Value: Integer);
var
i: Integer;
begin
FLargeImagesWidth := Value;
for i := 0 to Count - 1 do
Items[i].LargeImagesWidth := Value;
end;
procedure TSpkTabs.SetToolbarDispatch(const Value: TSpkBaseToolbarDispatch);
var
i: integer;
begin
FToolbarDispatch := Value;
for i := 0 to self.Count - 1 do
self.Items[i].ToolbarDispatch := FToolbarDispatch;
end;
procedure TSpkTabs.Update;
begin
inherited Update;
if Assigned(FToolbarDispatch) then
FToolbarDispatch.NotifyItemsChanged;
end;
end.