{ ******************************************************************************** * BGRAExpandPanels Version 1.0 * * * * * * (c) Massimo Magnano, Alexander Roth * * * * * ******************************************************************************** See BcExpandPanels.txt for changelog and to-do } unit BCExpandPanels; {$mode objfpc}{$H+} // for debugging purposes //{$DEFINE DEBUG_PAINT} interface uses Controls, Classes, ExtCtrls, Graphics, Math, LResources, Dialogs, SysUtils, Buttons, Themes, Types, Menus, BCPanel; type TBCExpandPanelsBehaviour = (EPHotMouse, EPMultipanel, EPSinglePanel); // TBoundEvent=procedure(sender:TObject; ALeft, ATop, AWidth, AHeight: integer) of object; TAnimationEvent = procedure(Sender: TObject; deltaLeft, deltaTop, deltaWidth, deltaHeight: integer) of object; TNormalProcedure = procedure of object; { TBCBoundButton } TGlyphLayout = ( glLeft, glRight, glNone ); TGlyphKind = ( gkArrows, gkClose, gkMinMax ); TTextLayout = ( tlLeft, tlRight, tlCenter, tlNone ); TBCBoundButtonStyle = (bbsButton, bbsTab, bbsLine, bbsLineDouble, bbsLineTop, bbsLineBottom, bbsLineDoubleTop, bbsLineDoubleBottom); TBCBoundButton = class(TCustomSpeedButton) private rColorExpanded: TColor; rColorHighlight: TColor; rColorShadow: TColor; rGlyphKind: TGlyphKind; rGlyphLayout: TGlyphLayout; rStyle: TBCBoundButtonStyle; rTabWidth: Integer; rTextLayout: TTextLayout; procedure setColorExpanded(AValue: TColor); procedure SetColorHighlight(AValue: TColor); procedure SetColorShadow(AValue: TColor); procedure SetGlyphKind(AValue: TGlyphKind); procedure SetGlyphLayout(AValue: TGlyphLayout); procedure SetStyle(AValue: TBCBoundButtonStyle); procedure SetTabWidth(AValue: Integer); procedure SetTextLayout(AValue: TTextLayout); protected rGlyph :TButtonGlyph; rUserGlyphExpanded, rUserGlyphCollapsed, rGlyphExpanded, rGlyphCollapsed :TBitmap; procedure SetGlyphCollapsed(AValue: TBitmap); procedure SetGlyphExpanded(AValue: TBitmap); procedure LoadGlyph(GlyphDST :TBitmap; ResName :String); procedure BuildGlyphs; procedure Paint; override; procedure Loaded; override; (* property AllowAllUp; property Down; property Glyph; property GroupIndex; property Height; //Don't Decrease visibility :-O property HelpContext; property HelpKeyword; property HelpType; property Layout; property Left; property Margin; property Name; property NumGlyphs; property Spacing; property ShowCaption; property Tag; property Top; property Width; property Transparent; *) public constructor Create(AOwner: TComponent); override; destructor Destroy; override; published property Caption; property Color nodefault; property ColorExpanded: TColor read rColorExpanded write setColorExpanded; property ColorHighlight: TColor read rColorHighlight write SetColorHighlight default clDefault; property ColorShadow: TColor read rColorShadow write SetColorShadow default clDefault; property Font; property Flat; property GlyphExpanded: TBitmap read rUserGlyphExpanded write SetGlyphExpanded; property GlyphCollapsed: TBitmap read rUserGlyphCollapsed write SetGlyphCollapsed; property GlyphLayout: TGlyphLayout read rGlyphLayout write SetGlyphLayout default glNone; property GlyphKind: TGlyphKind read rGlyphKind write SetGlyphKind default gkArrows; property ShowAccelChar; property TextLayout: TTextLayout read rTextLayout write SetTextLayout default tlLeft; property Style: TBCBoundButtonStyle read rStyle write SetStyle default bbsButton; //Negative Values is the % of Total Width, Positive is a Fixed Width property TabWidth: Integer read rTabWidth write SetTabWidth default -50; end; { TBCExpandPanel } TBCExpandPanel = class(TBCPanel) private FEPManagesCollapsing: TNotifyEvent; FButton: TBCBoundButton; FButtonSize: integer; FCollapseKind: TAnchorKind; FCollapsed: boolean; FAnimated: boolean; FOnExpand: TNotifyEvent; FOnPreExpand: TNotifyEvent; FOnAnimate: TAnimationEvent; FOnCollapse: TNotifyEvent; FOnPreCollapse: TNotifyEvent; FOnButtonClick: TNotifyEvent; FInternalOnAnimate: TAnimationEvent; FButtonPosition: TAnchorKind; FExpandedButtonColor: TColor; FCollapsedButtonColor: TColor; FExpandedSize: integer; FAnimationSpeed: real; FTextAlignment: TAlignment; rBevelColorHighlight: TColor; rBevelColorShadow: TColor; rBevelRounded: Boolean; StopCircleActions: boolean; FAnimating: boolean; FVisibleTotal: boolean; TargetAnimationSize: integer; EndProcedureOfAnimation: TNormalProcedure; Timer: TTimer; function GetEnabled: Boolean; procedure SetBevelColorHighlight(AValue: TColor); procedure SetBevelColorShadow(AValue: TColor); procedure SetBevelRounded(AValue: Boolean); procedure SetEnabled(AValue: Boolean); procedure setExpandedSize(Value: integer); procedure setButtonSize(Value: integer); procedure setButtonPosition(Value: TAnchorKind); procedure setCollapseKind(Value: TAnchorKind); procedure setAnimationSpeed(Value: real); procedure setCollapsed(Value: boolean); procedure PositionButton; procedure SetRelevantSize(comp: TControl; AKind: TAnchorKind; ASize: Integer); function RelevantSize(comp: TControl; akind: TAnchorKind): integer; function RelevantOrthogonalSize(comp: TControl; akind: TAnchorKind): integer; function DeltaCoordinates(deltaMove, deltaSize: integer): TRect; // the outpot (left,top right, bottom) has all the information: left and top encode the movement. rigth and bottom the size changes procedure Animate(aTargetSize: integer); procedure SetTextAlignment(AValue: TAlignment); procedure TimerAnimateSize(Sender: TObject); procedure EndTimerCollapse; procedure EndTimerExpand; procedure UpdateAll; procedure ButtonClick(Sender: TObject); procedure DoCollapse; procedure DoExpand; procedure AdjustClientRect(var ARect: TRect); override; property InternalOnAnimate: TAnimationEvent read FInternalOnAnimate write FInternalOnAnimate; property EPManagesCollapsing: TNotifyEvent read FEPManagesCollapsing write FEPManagesCollapsing; protected procedure Loaded; override; procedure CreateWnd; override; procedure Paint; override; public property Animating: boolean read FAnimating; constructor Create(TheOwner: TComponent); override; destructor Destroy; override; procedure SetBounds(ALeft, ATop, AWidth, AHeight: integer); override; published property TextAlignment: TAlignment read FTextAlignment write SetTextAlignment; property Enabled: Boolean read GetEnabled write SetEnabled; property CollapseKind: TAnchorKind read FCollapseKind write setCollapseKind; //To where should it collapse? property ExpandedSize: integer read FExpandedSize write setExpandedSize; property ButtonPosition: TAnchorKind read FButtonPosition write setButtonPosition; property ButtonSize: integer read FButtonSize write setButtonSize; property Button: TBCBoundButton read FButton; property AnimationSpeed: real read FAnimationSpeed write setAnimationSpeed; property Animated: boolean read FAnimated write FAnimated default True; property Collapsed: boolean read FCollapsed write setCollapsed default False; property BevelColorHighlight: TColor read rBevelColorHighlight write SetBevelColorHighlight default clBtnHighlight; property BevelColorShadow: TColor read rBevelColorShadow write SetBevelColorShadow default clBtnShadow; property BevelRounded: Boolean read rBevelRounded write SetBevelRounded default True; property OnAnimate: TAnimationEvent read FOnAnimate write FOnAnimate; property OnButtonClick: TNotifyEvent read FOnButtonClick write FOnButtonClick; property OnPreExpand: TNotifyEvent read FOnPreExpand write FOnPreExpand; property OnExpand: TNotifyEvent read FOnExpand write FOnExpand; property OnCollapse: TNotifyEvent read FOnCollapse write FOnCollapse; property OnPreCollapse: TNotifyEvent read FOnPreCollapse write FOnPreCollapse; end; {============================================================================== Class: TBCExpandPanels Description: ==============================================================================} { TBCExpandPanels } TBCExpandPanels = class(TComponent) private { Private-Deklarationen } PanelArray: TList; // Properties FArrangeKind: TAnchorKind; FButtonPosition, FCollapseKind: TAnchorKind; FButtonGlyphKind: TGlyphKind; FButtonGlyphLayout: TGlyphLayout; FButtonStyle: TBCBoundButtonStyle; FButtonTabWidth: Integer; FButtonTextLayout: TTextLayout; FOrthogonalAbove: integer; FAbove: integer; FOrthogonalSize: integer; FBehaviour: TBCExpandPanelsBehaviour; FOnArrangePanels: TNotifyEvent; FFixedSize: integer; FUseFixedSize: boolean; FAutoCollapseIfTooHigh: boolean; FUseClientSize: boolean; function RelevantAbove(comp: TControl): integer; function RelevantOrthogonalAbove(comp: TControl): integer; function RelevantSize(comp: TControl): integer; function RelevantOrthogonalSize(comp: TControl): integer; procedure setButtonGlyphKind(AValue: TGlyphKind); procedure setButtonGlyphLayout(AValue: TGlyphLayout); procedure setButtonStyle(AValue: TBCBoundButtonStyle); procedure SetButtonTabWidth(AValue: Integer); procedure setButtonTextLayout(AValue: TTextLayout); procedure WriteRelevantAbove(comp: TBCExpandPanel; above: integer); procedure WriteRelevantSize(comp: TBCExpandPanel; size: integer); procedure WriteRelevantOrthogonalSize(comp: TBCExpandPanel; size: integer); procedure WriteRelevantOrthogonalAbove(comp: TBCExpandPanel; size: integer); procedure setArrangeKind(Value: TAnchorKind); procedure setButtonPosition(Value: TAnchorKind); procedure setCollapseKind(Value: TAnchorKind); procedure setUseClientSize(Value: boolean); procedure setUseFixedSize(Value: boolean); procedure setAutoCollapseIfTooHigh(Value: boolean); procedure setFixedSize(Value: integer); procedure setOrthogonalAbove(Value: integer); procedure setAbove(Value: integer); procedure setOrthogonalSize(Value: integer); procedure setBehaviour(Value: TBCExpandPanelsBehaviour); procedure MakeCorrectButtonClickPointers; procedure RollOutOnAnimate(Sender: TObject; deltaLeft, deltaTop, deltaWidth, deltaHeight: integer); procedure RollOutClick(Sender: TObject); procedure HotTrackSetActivePanel(Value: integer); procedure DelLastPanel; procedure RollOut1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: integer); protected { Protected-Deklarationen } public { Public-Deklarationen } property OrthogonalAbove: integer read FOrthogonalAbove write setOrthogonalAbove; property Above: integer read FAbove write setAbove; property OrthogonalSize: integer read FOrthogonalSize write setOrthogonalSize; function IdxOfPanel(aname: string): integer; overload; procedure CollapseIfTooHigh; // procedure SetCorrectSize; procedure AddPanel(rollout: TBCExpandPanel); procedure InsertPanel(idx: integer; rollout: TBCExpandPanel); function DeltePanel(aname: string): boolean; overload; function DeltePanel(idx: integer): boolean; overload; procedure DelteLastPanel; procedure ArrangePanels; function Count: integer; function Panel(idx: integer): TBCExpandPanel; property CollapseKind: TAnchorKind read FCollapseKind write setCollapseKind; property ButtonPosition: TAnchorKind read FButtonPosition write setButtonPosition; property ButtonGlyphLayout: TGlyphLayout read FButtonGlyphLayout write setButtonGlyphLayout; property ButtonGlyphKind: TGlyphKind read FButtonGlyphKind write setButtonGlyphKind; property ButtonStyle: TBCBoundButtonStyle read FButtonStyle write setButtonStyle; property ButtonTabWidth: Integer read FButtonTabWidth write SetButtonTabWidth; property ButtonTextLayout: TTextLayout read FButtonTextLayout write setButtonTextLayout; constructor Create(AOwner: TComponent); override; destructor Destroy; override; published { Published-Deklarationen } // property FixedHeight:integer read FFixedHeight write setFixedSize; // property UseFixedHeight:boolean read FUseFixedHeight write setUseFixedSize; // property UseClientHeight:boolean read FUseClientHeight write setUseClientSize; // property AutoCollapseIfTooHigh:boolean read FAutoCollapseIfTooHigh write setAutoCollapseIfTooHigh; property ArrangeKind: TAnchorKind read FArrangeKind write setArrangeKind; property OnArrangePanels: TNotifyEvent read FOnArrangePanels write FOnArrangePanels; property Behaviour: TBCExpandPanelsBehaviour read FBehaviour write setBehaviour; end; procedure Register; implementation uses GraphType, LCLProc; const //GrayScale a Color : Taken from BGRABitmap package redWeightShl10 = 306; // = 0.299 greenWeightShl10 = 601; // = 0.587 blueWeightShl10 = 117; // = 0.114 procedure korrigiere(var w: real; min, max: real); var temp: real; begin if max < min then begin temp := min; min := max; max := temp; end; if w < min then w := min; if w > max then w := max; end; //Function copied from BGRABitmap package may work ;-) function Grayscale(AColor :TColor):TColor; Var rColor, gray :Integer; begin rColor :=ColorToRGB(AColor); gray := (Red(rColor) * redWeightShl10 + Green(rColor) * greenWeightShl10 + Blue(rColor) * blueWeightShl10 + 512) shr 10; Result :=RGBToColor(gray, gray, gray); end; function GetHighlightColor(BaseColor: TColor; Value:Integer): TColor; Var rColor :Integer; begin rColor :=ColorToRGB(BaseColor); Result := RGBToColor( Min(Red(rColor) + Value, $FF), Min(Green(rColor) + Value, $FF), Min(Blue(rColor) + Value, $FF)); end; function GetShadowColor(BaseColor: TColor; Value:Integer): TColor; Var rColor :Integer; begin rColor :=ColorToRGB(BaseColor); Result := RGBToColor( Max(Red(rColor) - Value, $22), Max(Green(rColor) - Value, $22), Max(Blue(rColor) - Value, $22)); end; //Canvas Draw Functions procedure Frame3d_Rounded(Canvas: TCanvas; var ARect: TRect; const FrameWidth : integer; RX, RY:Integer; const Style : TGraphicsBevelCut; ShadowColor, HighlightColor, InternalColor: TColor); var DRect: TRect; procedure drawUP; begin inc(DRect.Left,1); inc(DRect.Top,1); //is outside the Rect but in this way we don't have a hole of 1 px inc(DRect.Right,1); inc(DRect.Bottom,1); Canvas.Brush.Color :=ShadowColor; Canvas.Brush.Style :=bsSolid; Canvas.Pen.Color := clNone; Canvas.Pen.Width := 1; //The Shadow is always 1 Pixel Canvas.Pen.Style := psClear; Canvas.RoundRect(DRect, RX,RY); dec(DRect.Left,1); dec(DRect.Top,1); dec(DRect.Right,2); dec(DRect.Bottom,2); Canvas.Brush.Color :=InternalColor; if (InternalColor = clNone) then Canvas.Brush.Style :=bsClear else Canvas.Brush.Style :=bsSolid; Canvas.Pen.Color :=HighlightColor; Canvas.Pen.Width := FrameWidth; Canvas.Pen.Style := psSolid; Canvas.RoundRect(DRect, RX,RY); Inc(ARect.Top, FrameWidth); Inc(ARect.Left, FrameWidth); Dec(ARect.Right, FrameWidth+1); //+The Shadow (1 Pixel) +1? Dec(ARect.Bottom, FrameWidth+1); end; procedure drawFLAT; begin Canvas.Brush.Color := InternalColor; if (InternalColor = clNone) then Canvas.Brush.Style :=bsClear else Canvas.Brush.Style :=bsSolid; Canvas.Pen.Color := clNone; Canvas.Pen.Width := FrameWidth; Canvas.Pen.Style := psClear; Canvas.RoundRect(DRect, RX,RY); end; procedure drawDOWN; begin Canvas.Brush.Color :=ShadowColor; Canvas.Brush.Style :=bsSolid; Canvas.Pen.Color := clNone; Canvas.Pen.Width := 1; Canvas.Pen.Style := psClear; Canvas.RoundRect(DRect, RX,RY); inc(DRect.Left,1); inc(DRect.Top,1); Canvas.Brush.Color :=InternalColor; if (InternalColor = clNone) then Canvas.Brush.Style :=bsClear else Canvas.Brush.Style :=bsSolid; Canvas.Pen.Color :=HighlightColor; Canvas.Pen.Width := FrameWidth; Canvas.Pen.Style := psSolid; Canvas.RoundRect(DRect, RX,RY); Inc(ARect.Top, FrameWidth+1); //+The Shadow (1 Pixel) Inc(ARect.Left, FrameWidth+1); Dec(ARect.Right, FrameWidth); Dec(ARect.Bottom, FrameWidth); end; begin DRect :=ARect; Case Style of bvNone: drawFLAT; bvSpace: begin drawFLAT; InflateRect(ARect, -FrameWidth, -FrameWidth); end; bvRaised: drawUP; bvLowered: drawDOWN; end; end; procedure TBCBoundButton.SetColorHighlight(AValue: TColor); begin if (rColorHighlight <> AValue) then begin rColorHighlight := AValue; if not(csLoading in ComponentState) then Invalidate; end; end; procedure TBCBoundButton.setColorExpanded(AValue: TColor); begin if (rColorExpanded <> AValue) then begin rColorExpanded := AValue; if not(csLoading in ComponentState) then Invalidate; end; end; procedure TBCBoundButton.SetColorShadow(AValue: TColor); begin if (rColorShadow <> AValue) then begin rColorShadow := AValue; if not(csLoading in ComponentState) then Invalidate; end; end; procedure TBCBoundButton.SetGlyphKind(AValue: TGlyphKind); begin if (rGlyphKind <> AValue) then begin rGlyphKind:=AValue; if not(csLoading in ComponentState) then begin BuildGlyphs; Invalidate; end; end; end; procedure TBCBoundButton.SetGlyphLayout(AValue: TGlyphLayout); begin if (rGlyphLayout <> AValue) then begin rGlyphLayout := AValue; if not(csLoading in ComponentState) then begin BuildGlyphs; Invalidate; end; end; end; procedure TBCBoundButton.SetStyle(AValue: TBCBoundButtonStyle); begin if (rStyle <> AValue) then begin rStyle:=AValue; if not(csLoading in ComponentState) then Invalidate; end; end; procedure TBCBoundButton.SetTabWidth(AValue: Integer); begin if (rTabWidth <> AValue) then begin rTabWidth:=AValue; if not(csLoading in ComponentState) and (rStyle = bbsTab) then Invalidate; end; end; procedure TBCBoundButton.SetTextLayout(AValue: TTextLayout); begin if (rTextLayout <> AValue) then begin rTextLayout := AValue; if not(csLoading in ComponentState) then Invalidate; end; end; procedure TBCBoundButton.SetGlyphCollapsed(AValue: TBitmap); begin rUserGlyphCollapsed.Assign(AValue); if not(csLoading in ComponentState) then begin BuildGlyphs; Invalidate; end; end; procedure TBCBoundButton.SetGlyphExpanded(AValue: TBitmap); begin rUserGlyphExpanded.Assign(AValue); if not(csLoading in ComponentState) then begin BuildGlyphs; Invalidate; end; end; procedure TBCBoundButton.LoadGlyph(GlyphDST: TBitmap; ResName: String); Var rGlyphO: TPortableNetworkGraphic; begin rGlyphO :=TPortableNetworkGraphic.Create; rGlyphO.LoadFromLazarusResource(ResName); GlyphDST.Assign(rGlyphO); FreeAndNil(rGlyphO); end; procedure TBCBoundButton.BuildGlyphs; begin if (rGlyphLayout <> glNone) then begin if (rUserGlyphCollapsed.Empty) then Case rGlyphKind of gkArrows: case TBCExpandPanel(Owner).CollapseKind of akTop: LoadGlyph(rGlyphCollapsed, 'BCEXP_PANEL_BOTTOM'); akLeft: LoadGlyph(rGlyphCollapsed, 'BCEXP_PANEL_RIGHT'); akRight: LoadGlyph(rGlyphCollapsed, 'BCEXP_PANEL_LEFT'); akBottom: LoadGlyph(rGlyphCollapsed, 'BCEXP_PANEL_TOP'); end; gkClose: LoadGlyph(rGlyphCollapsed, 'BCEXP_PANEL_CLOSE'); gkMinMax: if (TBCExpandPanel(Owner).CollapseKind in [akTop, akBottom]) then LoadGlyph(rGlyphCollapsed, 'BCEXP_PANEL_MAX_H') else LoadGlyph(rGlyphCollapsed, 'BCEXP_PANEL_MAX_V'); end else rGlyphCollapsed.Assign(rUserGlyphCollapsed); if (rUserGlyphExpanded.Empty) then Case rGlyphKind of gkArrows: case TBCExpandPanel(Owner).CollapseKind of akTop: LoadGlyph(rGlyphExpanded, 'BCEXP_PANEL_TOP'); akLeft: LoadGlyph(rGlyphExpanded, 'BCEXP_PANEL_LEFT'); akRight: LoadGlyph(rGlyphExpanded, 'BCEXP_PANEL_RIGHT'); akBottom: LoadGlyph(rGlyphExpanded, 'BCEXP_PANEL_BOTTOM'); end; gkClose: LoadGlyph(rGlyphExpanded, 'BCEXP_PANEL_CLOSE'); gkMinMax: if (TBCExpandPanel(Owner).CollapseKind in [akTop, akBottom]) then LoadGlyph(rGlyphExpanded, 'BCEXP_PANEL_MIN_H') else LoadGlyph(rGlyphExpanded, 'BCEXP_PANEL_MIN_V'); end else rGlyphExpanded.Assign(rUserGlyphExpanded); end; end; procedure TBCBoundButton.Paint; var paintRect, fRect :TRect; xColor, xHColor, xSColor :TColor; middleX, middleY, txtWidth, txtLeft, txtTop, glyphLeft, glyphTop :Integer; xCaption :String; FButtonPosition :TAnchorKind; FCollapsed, Rounded :Boolean; procedure drawGlyph(var ATop, ALeft :Integer); var AWidth, AHeight :Integer; begin AWidth :=paintRect.Right-paintRect.Left-2; AHeight :=paintRect.Bottom-paintRect.Top-2; if FCollapsed then rGlyph.Glyph.Assign(rGlyphCollapsed) else rGlyph.Glyph.Assign(rGlyphExpanded); //We must Calculate the Real Position of the Glyph Case FButtonPosition of akTop, akBottom : begin if (rGlyphLayout = glLeft) then begin ALeft :=2; ATop :=middleY-(rGlyph.Glyph.Height div 2); end else begin ALeft :=AWidth-rGlyph.Glyph.Width; ATop :=middleY-(rGlyph.Glyph.Height div 2); end; end; akLeft :begin if (rGlyphLayout = glLeft) then begin //Really on Bottom of paintRect ALeft :=middleX-(rGlyph.Glyph.Width div 2); ATop :=AHeight-rGlyph.Glyph.Height; end else begin //Really on Top of paintRect ALeft :=middleX-(rGlyph.Glyph.Width div 2); ATop :=2; end; end; akRight :begin if (rGlyphLayout = glLeft) then begin //Really on Top of paintRect ALeft :=middleX-(rGlyph.Glyph.Width div 2); ATop :=2; end else begin //Really on Bottom of paintRect ALeft :=middleX-(rGlyph.Glyph.Width div 2); ATop :=AHeight-rGlyph.Glyph.Height; end; end; end; rGlyph.Draw(Canvas, paintRect, point(ALeft, ATop), FState, true, 0); end; procedure drawBtn(const ABorderStyle : TGraphicsBevelCut); var xTabWidth, tY, tX: Integer; begin Case rStyle of bbsButton: Frame3d_Rounded(Canvas, paintRect, 1, 5, 5, ABorderStyle, xSColor, xHColor, xColor); bbsTab: begin fRect :=paintRect; Case FButtonPosition of akTop : begin //If rTabWidth is Negative Calculate the Tab Width if (rTabWidth < 0) then xTabWidth :=(fRect.Right-fRect.Left)*-rTabWidth div 100 else xTabWidth :=rTabWidth; inc(paintRect.Left, middleX-(xTabWidth div 2)); paintRect.Right:=paintRect.Left+xTabWidth; Frame3d_Rounded(Canvas, paintRect, 1, 5, 5, ABorderStyle, xSColor, xHColor, xColor); tY :=fRect.Bottom-2; Canvas.Pen.Style:=psSolid; Canvas.Pen.Width:=1; Canvas.Pen.Color :=xHColor; if Rounded then Canvas.MoveTo(2, tY) else Canvas.MoveTo(0, tY); Canvas.LineTo(paintRect.Left-3, tY); Canvas.LineTo(paintRect.Left, tY-3); if Rounded then Canvas.MoveTo(fRect.Right-4, tY) else Canvas.MoveTo(fRect.Right, tY); Canvas.LineTo(paintRect.Right+2, tY); Canvas.LineTo(paintRect.Right-1, tY-3); Canvas.Pen.Color :=xColor; Canvas.MoveTo(paintRect.Left-2, tY); Canvas.LineTo(paintRect.Right+2, tY); dec(tY); Canvas.MoveTo(paintRect.Left-1, tY); Canvas.LineTo(paintRect.Right+1, tY); tY :=fRect.Bottom-1; if FCollapsed then Canvas.Pen.Color :=xSColor; if Rounded then begin Canvas.MoveTo(fRect.Left+2, tY); Canvas.LineTo(fRect.Right-3, tY); end else begin Canvas.MoveTo(fRect.Left, tY); Canvas.LineTo(fRect.Right, tY); end; end; akBottom : begin if (rTabWidth < 0) then xTabWidth :=(fRect.Right-fRect.Left)*-rTabWidth div 100 else xTabWidth :=rTabWidth; inc(paintRect.Left, middleX-(xTabWidth div 2)); paintRect.Right:=paintRect.Left+xTabWidth; dec(paintRect.Top); Frame3d_Rounded(Canvas, paintRect, 1, 5, 5, ABorderStyle, xSColor, xHColor, xColor); Canvas.Pen.Style:=psSolid; Canvas.Pen.Width:=1; Canvas.Pen.Color :=xHColor; if Rounded then Canvas.MoveTo(2, 1) else Canvas.MoveTo(0, 1); Canvas.LineTo(paintRect.Left-3, 1); Canvas.LineTo(paintRect.Left, 4); if Rounded then Canvas.MoveTo(fRect.Right-4, 1) else Canvas.MoveTo(fRect.Right, 1); Canvas.LineTo(paintRect.Right+2, 1); Canvas.LineTo(paintRect.Right-1, 4); Canvas.Pen.Color :=xColor; Canvas.MoveTo(paintRect.Left-2, 1); Canvas.LineTo(paintRect.Right+2, 1); Canvas.MoveTo(paintRect.Left-1, 2); Canvas.LineTo(paintRect.Right+1, 2); if FCollapsed then Canvas.Pen.Color :=xSColor; if Rounded then begin Canvas.MoveTo(fRect.Left+2, 0); Canvas.LineTo(fRect.Right-3, 0); end else begin Canvas.MoveTo(fRect.Left, 0); Canvas.LineTo(fRect.Right, 0); end; end; akLeft : begin if (rTabWidth < 0) then xTabWidth :=(fRect.Bottom-fRect.Top)*-rTabWidth div 100 else xTabWidth :=rTabWidth; inc(paintRect.Top, middleY-(xTabWidth div 2)); paintRect.Bottom:=paintRect.Top+xTabWidth; Frame3d_Rounded(Canvas, paintRect, 1, 5, 5, ABorderStyle, xSColor, xHColor, xColor); tX :=fRect.Right-2; Canvas.Pen.Style:=psSolid; Canvas.Pen.Width:=1; Canvas.Pen.Color :=xHColor; if Rounded then Canvas.MoveTo(tX, 2) else Canvas.MoveTo(tX, 0); Canvas.LineTo(tX, paintRect.Top-3); Canvas.LineTo(tX-3, paintRect.Top); if Rounded then Canvas.MoveTo(tX, fRect.Bottom-4) else Canvas.MoveTo(tX, fRect.Bottom); Canvas.LineTo(tX, paintRect.Bottom+2); Canvas.LineTo(tX-3, paintRect.Bottom-1); Canvas.Pen.Color :=xColor; Canvas.MoveTo(tX, paintRect.Top-2); Canvas.LineTo(tX, paintRect.Bottom+2); dec(tX); Canvas.MoveTo(tX, paintRect.Top-1); Canvas.LineTo(tX, paintRect.Bottom+1); tX :=fRect.Right-1; if FCollapsed then Canvas.Pen.Color :=xSColor; if Rounded then begin Canvas.MoveTo(tX, fRect.Top+2); Canvas.LineTo(tX, fRect.Bottom-3); end else begin Canvas.MoveTo(tX, fRect.Top); Canvas.LineTo(tX, fRect.Bottom); end; end; akRight : begin if (rTabWidth < 0) then xTabWidth :=(fRect.Bottom-fRect.Top)*-rTabWidth div 100 else xTabWidth :=rTabWidth; inc(paintRect.Top, middleY-(xTabWidth div 2)); paintRect.Bottom:=paintRect.Top+xTabWidth; dec(paintRect.Left); Frame3d_Rounded(Canvas, paintRect, 1, 5, 5, ABorderStyle, xSColor, xHColor, xColor); Canvas.Pen.Style:=psSolid; Canvas.Pen.Width:=1; Canvas.Pen.Color :=xHColor; if Rounded then Canvas.MoveTo(1, 2) else Canvas.MoveTo(1, 0); Canvas.LineTo(1, paintRect.Top-3); Canvas.LineTo(4, paintRect.Top); if Rounded then Canvas.MoveTo(1, fRect.Bottom-4) else Canvas.MoveTo(1, fRect.Bottom); Canvas.LineTo(1, paintRect.Bottom+2); Canvas.LineTo(4, paintRect.Bottom-1); Canvas.Pen.Color :=xColor; Canvas.MoveTo(1, paintRect.Top-2); Canvas.LineTo(1, paintRect.Bottom+2); Canvas.MoveTo(2, paintRect.Top-1); Canvas.LineTo(2, paintRect.Bottom+1); if FCollapsed then Canvas.Pen.Color :=xSColor; if Rounded then begin Canvas.MoveTo(0, fRect.Top+2); Canvas.LineTo(0, fRect.Bottom-3); end else begin Canvas.MoveTo(0, fRect.Top); Canvas.LineTo(0, fRect.Bottom); end; end; end; end; end; end; procedure drawText; Var DTop, DLeft, AWidth, AHeight, txtH :Integer; procedure CalcCuttedCaption(MaxWidth :Integer); Var txtMaxChars :Integer; begin txtWidth :=0; if (MaxWidth < Canvas.TextWidth('...')) then xCaption :='' else begin txtMaxChars :=Canvas.TextFitInfo(xCaption, MaxWidth); txtWidth :=Canvas.TextWidth(xCaption); while (txtWidth > MaxWidth) do begin dec(txtMaxChars, 3); //-1 Chars fit better, -3 Chars for more speed xCaption :=Copy(xCaption, 0, txtMaxChars)+'...'; txtWidth :=Canvas.TextWidth(xCaption); end; end; (* Original Code, Test Speed if (txtW > AWidth) then begin txtMaxChars :=Canvas.TextFitInfo(xCaption, AWidth); xCaption :=Copy(xCaption, 0, txtMaxChars-3)+'...'; txtW :=Canvas.TextWidth(xCaption); if (txtW > AWidth) then xCaption :=''; end; *) end; begin txtH :=Canvas.TextHeight(xCaption); AWidth :=paintRect.Right-paintRect.Left-2; AHeight :=paintRect.Bottom-paintRect.Top-2; Case FButtonPosition of akTop, akBottom : begin Canvas.Font.Orientation := 0; txtTop :=middleY-(txtH div 2); if (rGlyphLayout <> glNone) then begin if (rTextLayout = tlCenter) then dec(AWidth, rGlyph.Glyph.Width*2+4) else dec(AWidth, rGlyph.Glyph.Width+2) end; CalcCuttedCaption(AWidth); Case rTextLayout of tlLeft :begin txtLeft :=paintRect.Left+4; if (rGlyphLayout = glLeft) then inc(txtLeft, rGlyph.Glyph.Width+2); end; tlRight:begin txtLeft :=paintRect.Left+AWidth-txtWidth; if (rGlyphLayout = glLeft) then inc(txtLeft, rGlyph.Glyph.Width+2); end; tlCenter:begin txtLeft :=middleX-(txtWidth div 2); end; end; //Disabled Position DTop :=txtTop+1; DLeft :=txtLeft+1; end; akLeft : begin //Vertically from Bottom to Top Canvas.Font.Orientation := 900; txtLeft:=middleX-(txtH div 2); if (rGlyphLayout <> glNone) then begin if (rTextLayout = tlCenter) then dec(AHeight, rGlyph.Glyph.Height*2+4) else dec(AHeight, rGlyph.Glyph.Height+2) end; //Vertically the Max Width is Height CalcCuttedCaption(AHeight); Case rTextLayout of tlLeft :begin //To Bottom of the ClientRect txtTop :=paintRect.Top+AHeight-2; if (rGlyphLayout = glRight) then inc(txtTop, rGlyph.Glyph.Height+2); end; tlRight:begin //To Top of the ClientRect txtTop :=paintRect.Top+txtWidth+2; if (rGlyphLayout = glRight) then inc(txtTop, rGlyph.Glyph.Height+2); end; tlCenter:begin txtTop :=middleY+(txtWidth div 2); end; end; //Disabled Position DTop :=txtTop-1; DLeft :=txtLeft+1; end; akRight : begin //Vertically from Top to Bottom Canvas.Font.Orientation := -900; txtLeft:=middleX+(txtH div 2)+1; //+1 because is better centered if (rGlyphLayout <> glNone) then begin if (rTextLayout = tlCenter) then dec(AHeight, rGlyph.Glyph.Height*2+4) else dec(AHeight, rGlyph.Glyph.Height+2) end; CalcCuttedCaption(AHeight); Case rTextLayout of tlLeft :begin //To Top of the ClientRect txtTop :=paintRect.Top+4; if (rGlyphLayout = glLeft) then inc(txtTop, rGlyph.Glyph.Height+2); end; tlRight:begin //To Bottom of the ClientRect txtTop :=paintRect.Top+AHeight-txtWidth; if (rGlyphLayout = glLeft) then inc(txtTop, rGlyph.Glyph.Height+2); end; tlCenter:begin txtTop :=middleY-(txtWidth div 2); end; end; //Disabled Position DTop :=txtTop+1; DLeft :=txtLeft-1; end; end; //Re Test here because we may not have space to draw the text, so now can be empty if (xCaption <> '') then begin if (FState = bsDisabled) then begin Canvas.Font.Color := clBtnHighlight; Canvas.TextOut(DLeft, DTop, xCaption); Canvas.Font.Color := clBtnShadow; end else Canvas.Font.Color := Font.Color; Canvas.Brush.Style:=bsClear; Canvas.TextOut(txtLeft, txtTop, xCaption); end else txtWidth:=0; end; procedure DrawLines; var d1, d2, d3, d4, dx :Integer; isVertical :Boolean; procedure calc_d(txtL, txtR, glyphL, glyphR :Integer); begin if (txtWidth > 0) then Case rTextLayout of tlLeft: begin d1 :=txtR; if (rGlyphLayout = glRight) then d2 :=glyphL; end; tlCenter:begin d2 :=txtL; d3 :=txtR; if (rGlyphLayout = glLeft) then d1 :=glyphR else if (rGlyphLayout = glRight) then d4 :=glyphL; end; tlRight:begin d2 :=txtL; if (rGlyphLayout = glLeft) then d1 :=glyphR; end; end else if (rGlyphLayout = glLeft) then d1 :=glyphR else if (rGlyphLayout = glRight) then d2 :=glyphL; end; procedure DrawALine(pCenterX, pCenterY :Integer); begin inc(d2); inc(d4); //LineTo don't paint the last Pixel if isVertical then begin //Avoid go outside the Box pCenterX :=EnsureRange(pCenterX, 0, paintRect.Right-2); Canvas.Pen.Color := {$ifdef DEBUG_PAINT} clLime {$else} xHColor {$endif}; Canvas.MoveTo(pCenterX, d1); Canvas.LineTo(pCenterX, d2); if (d3 > -1) then begin Canvas.MoveTo(pCenterX, d3); Canvas.LineTo(pCenterX, d4); end; Canvas.Pen.Color := {$ifdef DEBUG_PAINT} clGreen {$else} xSColor {$endif}; Canvas.MoveTo(pCenterX+1, d1+1); Canvas.LineTo(pCenterX+1, d2); if (d3 > -1) then begin Canvas.MoveTo(pCenterX+1, d3+1); Canvas.LineTo(pCenterX+1, d4); end; end else begin pCenterY :=EnsureRange(pCenterY, 0, paintRect.Bottom-2); Canvas.Pen.Color :={$ifdef DEBUG_PAINT} clLime {$else} xHColor {$endif}; Canvas.MoveTo(d1, pCenterY); Canvas.LineTo(d2, pCenterY); if (d3 > -1) then begin Canvas.MoveTo(d3, pCenterY); Canvas.LineTo(d4, pCenterY); end; Canvas.Pen.Color :={$ifdef DEBUG_PAINT} clGreen {$else} xSColor {$endif}; Canvas.MoveTo(d1+1, pCenterY+1); Canvas.LineTo(d2, pCenterY+1); if (d3 > -1) then begin Canvas.MoveTo(d3+1, pCenterY+1); Canvas.LineTo(d4, pCenterY+1); end; end; dec(d2); dec(d4); //return to the real Pixels end; begin d3 :=-1; isVertical :=(FButtonPosition in [akLeft, akRight]); //Assign to (d1-d2) Line All the space if isVertical then begin d1 :=paintRect.Top; d2 :=paintRect.Bottom-1; end else begin d1 :=paintRect.Left; d2 :=paintRect.Right-1; end; //Calculate the (d1-d2) (d3-d4) Lines between the Glyph and the Text elements if (rStyle in [bbsLine, bbsLineDouble]) then begin d4 :=d2; if isVertical then begin if (FButtonPosition = akRight) then calc_d(txtTop-3, txtTop+txtWidth+2, glyphTop-3, glyphTop+rGlyph.Glyph.Height+2) else begin //Only in this case (akLeft) the point coordinate is from bottom to top d1 :=paintRect.Bottom-1; d2 :=paintRect.Top; d4 :=d2; calc_d(txtTop+2, txtTop-txtWidth-3, glyphTop+rGlyph.Glyph.Height+2, glyphTop-3); //Exchange the values for Shadow coerence dx :=d1; d1 :=d2; d2 :=dx; if (d3 > -1) then begin dx :=d3; d3 :=d4; d4 :=dx; end; end; end else calc_d(txtLeft-3, txtLeft+txtWidth+2, glyphLeft-3, glyphLeft+rGlyph.Glyph.Width+2); end; //Draw the Lines Canvas.Pen.Style:=psSolid; Canvas.Pen.Width:=1; Case rStyle of bbsLine: DrawALine(middleX, middleY); bbsLineDouble: begin DrawALine(middleX-2, middleY-2); DrawALine(middleX+2, middleY+2); end; bbsLineTop: DrawALine(paintRect.Left, paintRect.Top); bbsLineBottom: DrawALine(paintRect.Right-2, paintRect.Bottom-2); bbsLineDoubleTop: begin DrawALine(paintRect.Left, paintRect.Top); DrawALine(paintRect.Left+3, paintRect.Top+3); end; bbsLineDoubleBottom: begin DrawALine(paintRect.Right-5, paintRect.Bottom-5); DrawALine(paintRect.Right-2, paintRect.Bottom-2); end; end; end; begin paintRect :=GetClientRect; {$ifdef DEBUG_PAINT} Canvas.Brush.Color:=clYellow; Canvas.Brush.Style:=bsSolid; Canvas.FillRect(paintRect); {$endif} middleY :=paintRect.Top+((paintRect.Bottom-paintRect.Top) div 2); middleX :=paintRect.Left+((paintRect.Right-paintRect.Left) div 2); FButtonPosition :=TBCExpandPanel(Owner).FButtonPosition; FCollapsed :=TBCExpandPanel(Owner).FCollapsed; Rounded :=not(FCollapsed) and TBCExpandPanel(Owner).rBevelRounded; if FCollapsed then xColor :=Self.Color else xColor :=rColorExpanded; xCaption :=Caption; Case FState of Buttons.bsHot:begin if (rColorHighlight = clDefault) then xHColor :=GetHighlightColor(xColor, 120) else xHColor :=rColorHighlight; if (rColorShadow = clDefault) then xSColor :=GetShadowColor(xColor, 40) else xSColor :=rColorShadow; xColor :=GetHighlightColor(xColor, 20); drawBtn(bvRaised); end; Buttons.bsDown:begin if (rColorHighlight = clDefault) then xHColor :=GetHighlightColor(xColor, 60) else xHColor :=rColorHighlight; if (rColorShadow = clDefault) then xSColor :=GetShadowColor(xColor, 60) else xSColor :=rColorShadow; xColor :=GetHighlightColor(xColor, 20); drawBtn(bvLowered); end; else begin if (FState = bsDisabled) then xColor :=GrayScale(xColor); if Flat then xHColor :=xColor else if (rColorHighlight = clDefault) then xHColor :=GetHighlightColor(xColor, 60) else xHColor :=rColorHighlight; if (rColorShadow = clDefault) then xSColor :=GetShadowColor(xColor, 60) else xSColor :=rColorShadow; if Flat then drawBtn(bvSpace) else drawBtn(bvRaised); end; end; if (rGlyphLayout <> glNone) then drawGlyph(glyphTop, glyphLeft) else begin glyphTop :=0; glyphLeft:=0; end; if (rTextLayout <> tlNone) and (xCaption <> '') then drawText else txtWidth:=0; if (rStyle in [bbsLine..bbsLineDoubleBottom]) then DrawLines; end; procedure TBCBoundButton.Loaded; begin inherited Loaded; if not(csDesigning in ComponentState) then begin //IF Used Outside TBCExpandPanel if not(Owner is TBCExpandPanel) then BuildGlyphs; end; end; constructor TBCBoundButton.Create(AOwner: TComponent); begin inherited Create(AOwner); Color :=clSkyBlue; rColorExpanded := RGBToColor(23, 136, 248); rColorHighlight :=clDefault; rColorShadow :=clDefault; rGlyphLayout :=glNone; rGlyphKind :=gkArrows; rTextLayout :=tlLeft; Flat :=False; rStyle :=bbsButton; rTabWidth :=-50; //Why FGlyph is Private in ancestor????? rGlyph := TButtonGlyph.Create; rGlyph.IsDesigning := csDesigning in ComponentState; rGlyph.ShowMode := gsmAlways; rGlyphExpanded :=TBitmap.Create; rGlyphExpanded.Transparent := True; rGlyphCollapsed :=TBitmap.Create; rGlyphCollapsed.Transparent := True; rUserGlyphExpanded :=TBitmap.Create; rUserGlyphExpanded.Transparent := True; rUserGlyphCollapsed :=TBitmap.Create; rUserGlyphCollapsed.Transparent := True; SetSubComponent((Owner is TBCExpandPanel)); // ControlStyle := ControlStyle + [csNoFocus, csNoDesignSelectable]; end; destructor TBCBoundButton.Destroy; begin FreeAndNil(rGlyphExpanded); FreeAndNil(rGlyphCollapsed); FreeAndNil(rUserGlyphExpanded); FreeAndNil(rUserGlyphCollapsed); FreeAndNil(rGlyph); inherited Destroy; end; {TBCExpandPanels} constructor TBCExpandPanels.Create(AOwner: TComponent); begin inherited Create(AOwner); PanelArray := TList.Create; FCollapseKind := akTop; FButtonPosition := akTop; FButtonGlyphKind :=gkArrows; FButtonGlyphLayout :=glNone; FButtonStyle :=bbsButton; FButtonTabWidth :=-50; FButtonTextLayout :=tlLeft; FArrangeKind := akTop; FUseFixedSize := False; FUseClientSize := False; FFixedSize := 400; FAutoCollapseIfTooHigh := False; FAbove := 10; FOrthogonalAbove := 10; FOrthogonalSize := 200; end; destructor TBCExpandPanels.Destroy; var i: integer; begin for I := PanelArray.Count - 1 downto 0 do PanelArray.Delete(i); PanelArray.Free; PanelArray := nil; inherited Destroy; end; procedure TBCExpandPanels.AddPanel(rollout: TBCExpandPanel); begin InsertPanel(PanelArray.Count, rollout); end; procedure TBCExpandPanels.InsertPanel(idx: integer; rollout: TBCExpandPanel); begin if Count <= 0 then begin FAbove := RelevantAbove(rollout); FOrthogonalAbove := RelevantOrthogonalAbove(rollout); FOrthogonalSize := RelevantOrthogonalSize(rollout); end else begin WriteRelevantAbove(rollout, FAbove); WriteRelevantOrthogonalAbove(rollout, FOrthogonalAbove); WriteRelevantOrthogonalSize(rollout, FOrthogonalSize); end; with rollout do begin Tag := Idx; FButton.Tag := Idx; FButton.OnMouseMove := @RollOut1MouseMove; InternalOnAnimate := @RollOutOnAnimate; end; PanelArray.Insert(idx, rollout); if FBehaviour <> EPMultipanel then HotTrackSetActivePanel(0); //damit das erste ausgeklappt ist ArrangePanels; MakeCorrectButtonClickPointers; end; function TBCExpandPanels.DeltePanel(aname: string): boolean; var i: integer; begin Result := False; for i := 0 to PanelArray.Count - 1 do if TBCExpandPanel(PanelArray[i]).Name = aname then begin PanelArray.Delete(i); Result := True; break; end; ArrangePanels; end; function TBCExpandPanels.DeltePanel(idx: integer): boolean; begin Result := False; if (idx >= 0) and (idx <= PanelArray.Count - 1) then begin PanelArray.Delete(idx); Result := True; end; ArrangePanels; end; procedure TBCExpandPanels.DelteLastPanel; begin if (PanelArray.Count >= 1) then PanelArray.Delete(PanelArray.Count - 1); ArrangePanels; end; procedure TBCExpandPanels.DelLastPanel; begin PanelArray.Delete(PanelArray.Count - 1); end; function TBCExpandPanels.RelevantAbove(comp: TControl): integer; begin case FArrangeKind of akLeft: Result := comp.Left; akTop: Result := comp.Top; end; end; function TBCExpandPanels.RelevantOrthogonalAbove(comp: TControl): integer; begin case FArrangeKind of akTop: Result := comp.Left; akLeft: Result := comp.Top; end; end; function TBCExpandPanels.RelevantSize(comp: TControl): integer; begin case FArrangeKind of akLeft: Result := comp.Width; akTop: Result := comp.Height; end; end; function TBCExpandPanels.RelevantOrthogonalSize(comp: TControl): integer; begin case FArrangeKind of akLeft: Result := comp.Height; akTop: Result := comp.Width; end; end; procedure TBCExpandPanels.setButtonGlyphKind(AValue: TGlyphKind); var i: Integer; begin if (FButtonGlyphKind <> AValue) then begin FButtonGlyphKind:=AValue; for i := 0 to PanelArray.Count - 1 do Panel(i).Button.GlyphKind := AValue; end; end; procedure TBCExpandPanels.setButtonGlyphLayout(AValue: TGlyphLayout); var i: Integer; begin if (FButtonGlyphLayout <> AValue) then begin FButtonGlyphLayout:=AValue; for i := 0 to PanelArray.Count - 1 do Panel(i).Button.GlyphLayout := AValue; end; end; procedure TBCExpandPanels.setButtonStyle(AValue: TBCBoundButtonStyle); var i: Integer; begin if (FButtonStyle <> AValue) then begin FButtonStyle:=AValue; for i := 0 to PanelArray.Count - 1 do Panel(i).Button.Style := AValue; end; end; procedure TBCExpandPanels.SetButtonTabWidth(AValue: Integer); var i: Integer; begin if (FButtonTabWidth <> AValue) then begin FButtonTabWidth:=AValue; for i := 0 to PanelArray.Count - 1 do Panel(i).Button.TabWidth := AValue; end; end; procedure TBCExpandPanels.setButtonTextLayout(AValue: TTextLayout); var i: Integer; begin if (FButtonTextLayout <> AValue) then begin FButtonTextLayout:=AValue; for i := 0 to PanelArray.Count - 1 do Panel(i).Button.TextLayout := AValue; end; end; procedure TBCExpandPanels.WriteRelevantAbove(comp: TBCExpandPanel; above: integer); begin case FArrangeKind of akLeft: comp.Left := above; akTop: comp.Top := above; end; end; procedure TBCExpandPanels.WriteRelevantSize(comp: TBCExpandPanel; size: integer); begin case FArrangeKind of akLeft: comp.Width := size; akTop: comp.Height := size; end; end; procedure TBCExpandPanels.WriteRelevantOrthogonalSize(comp: TBCExpandPanel; size: integer); begin case FArrangeKind of akLeft: comp.Height := size; akTop: comp.Width := size; end; end; procedure TBCExpandPanels.WriteRelevantOrthogonalAbove(comp: TBCExpandPanel; size: integer); begin case FArrangeKind of akLeft: comp.Top := size; akTop: comp.Left := size; end; end; procedure TBCExpandPanels.setArrangeKind(Value: TAnchorKind); begin case Value of //that is mean, but I haven't implemented the bottom and right yet.... akRight: Value := akLeft; akBottom: Value := akTop; end; if FArrangeKind = Value then exit; FArrangeKind := Value; ArrangePanels; end; procedure TBCExpandPanels.setButtonPosition(Value: TAnchorKind); var i: integer; begin if FButtonPosition = Value then exit; FButtonPosition := Value; for i := 0 to PanelArray.Count - 1 do Panel(i).ButtonPosition := Value; end; procedure TBCExpandPanels.setCollapseKind(Value: TAnchorKind); var i: integer; begin if FCollapseKind = Value then exit; FCollapseKind := Value; for i := 0 to PanelArray.Count - 1 do Panel(i).CollapseKind := Value; end; procedure TBCExpandPanels.setUseClientSize(Value: boolean); begin FUseClientSize := Value; ArrangePanels; end; procedure TBCExpandPanels.setUseFixedSize(Value: boolean); begin if FUseFixedSize = Value then exit; FUseFixedSize := Value; ArrangePanels; end; procedure TBCExpandPanels.setAutoCollapseIfTooHigh(Value: boolean); begin if FAutoCollapseIfTooHigh = Value then exit; FAutoCollapseIfTooHigh := Value; if FAutoCollapseIfTooHigh then CollapseIfTooHigh; end; procedure TBCExpandPanels.setFixedSize(Value: integer); var r: real; begin if FFixedSize = Value then exit; r := Value; korrigiere(r, 20, 10000); FFixedSize := round(r); ArrangePanels; end; procedure TBCExpandPanels.setOrthogonalAbove(Value: integer); begin if FOrthogonalAbove = Value then exit; FOrthogonalAbove := Value; ArrangePanels; end; procedure TBCExpandPanels.setAbove(Value: integer); begin if FAbove = Value then exit; FAbove := Value; ArrangePanels; end; procedure TBCExpandPanels.setOrthogonalSize(Value: integer); var i: integer; begin FOrthogonalSize := Value; for I := 0 to PanelArray.Count - 1 do WriteRelevantOrthogonalSize(TBCExpandPanel(PanelArray[i]), FOrthogonalSize); end; procedure TBCExpandPanels.setBehaviour(Value: TBCExpandPanelsBehaviour); var i: integer; isAlreadyOneExpand: boolean; begin isAlreadyOneExpand := False; FBehaviour := Value; MakeCorrectButtonClickPointers; // look if more then one is open for I := 0 to PanelArray.Count - 1 do with TBCExpandPanel(PanelArray[i]) do if (Behaviour <> EPMultipanel) and not Collapsed then //leave only the first open, if it is not MultiPanel if not isAlreadyOneExpand then isAlreadyOneExpand := True else Collapsed := True; end; procedure TBCExpandPanels.MakeCorrectButtonClickPointers; var i: integer; begin // set correct pointers for I := 0 to PanelArray.Count - 1 do with TBCExpandPanel(PanelArray[i]) do if FBehaviour <> EPMultipanel then EPManagesCollapsing := @RollOutClick else EPManagesCollapsing := nil; end; procedure TBCExpandPanels.CollapseIfTooHigh; var i, h, max: integer; tempanimated: boolean; begin if Count <= 1 then exit; h := RelevantAbove(Panel(0)); max := RelevantSize(Panel(0).Parent); for i := 0 to Count - 1 do if h + RelevantSize(Panel(i)) > max then with Panel(i) do begin tempanimated := Animated; Animated := False; Collapsed := True; Animated := tempanimated; h := h + TBCExpandPanel(Panel(i)).ButtonSize; end else h := h + RelevantSize(Panel(i)); end; procedure TBCExpandPanels.RollOutOnAnimate(Sender: TObject; deltaLeft, deltaTop, deltaWidth, deltaHeight: integer); var idx, i, size: integer; begin idx := PanelArray.IndexOf(Sender); for i := idx + 1 to PanelArray.Count - 1 do begin size := RelevantAbove(TBCExpandPanel(PanelArray[i])); case FArrangeKind of akTop: size := size + deltaTop + deltaHeight; akLeft: size := size + deltaLeft + deltaWidth; end; WriteRelevantAbove(TBCExpandPanel(PanelArray[i]), size); end; end; //procedure TBCExpandPanels.SetCorrectSize; //const plus=1; //extra Anstand //var // i, exSize, // countexpanded, // SumSize, closedSize:Integer; //begin // if PanelArray.Count<=0 then // exit; // SumSize:=FFixedSize; // if FUseClientSize then // SumSize:=TBCExpandPanel(PanelArray[0]).Parent.Height; // countexpanded:=0; // closedSize:=0; // for I := 0 to PanelArray.count-1 do // with TBCExpandPanel(PanelArray[i]) do // begin // if not Collapsed and not Animating //error producer!!! animating does not neccessairily mean that it is expanding // or Collapsed and Animating then // inc(countexpanded) // else // closedSize:=closedSize+Height; // end; // exSize:=SumSize- FTop- closedSize; // case Behaviour of // EPMultipanel: // if countexpanded>0 then // exSize:=trunc(exSize/countexpanded) // else // exSize:=400; // end; // for I := 0 to PanelArray.count-1 do // with TBCExpandPanel(PanelArray[i]) do // begin // if not FUseFixedSize and not FUseClientSize then // ExpandedSize:=200 // else // ExpandedSize:=exSize; // end; //end; {============================================================================== Procedure: ArrangePanels Belongs to: TBCExpandPanels Result: None Parameters: Description: ==============================================================================} procedure TBCExpandPanels.ArrangePanels; const plus = 1; //extra Anstand var i, t: integer; begin if Count <= 0 then exit; //left setzen!!! // SetCorrectSize; t := FAbove + plus; for I := 0 to PanelArray.Count - 1 do begin if not TBCExpandPanel(PanelArray[i]).Visible then continue; WriteRelevantAbove(TBCExpandPanel(PanelArray[i]), t); WriteRelevantOrthogonalAbove(TBCExpandPanel(PanelArray[i]), OrthogonalAbove); t := t + plus + self.RelevantSize(TBCExpandPanel(PanelArray[i])); end; if FAutoCollapseIfTooHigh then CollapseIfTooHigh; if Assigned(FOnArrangePanels) then FOnArrangePanels(Self); end; function TBCExpandPanels.Count: integer; begin Result := PanelArray.Count; end; function TBCExpandPanels.Panel(idx: integer): TBCExpandPanel; begin if idx < Count then Result := TBCExpandPanel(PanelArray.Items[idx]) else Result := nil; end; {============================================================================== Procedure: RollOutClick Belongs to: TBCExpandPanels Result: None Parameters: Sender : TObject = Description: ==============================================================================} procedure TBCExpandPanels.RollOutClick(Sender: TObject); begin if (Behaviour <> EPMultipanel) then HotTrackSetActivePanel(TBCBoundButton(Sender).Tag); end; procedure TBCExpandPanels.HotTrackSetActivePanel(Value: integer); var i: integer; begin for I := PanelArray.Count - 1 downto 0 do TBCExpandPanel(PanelArray[i]).Collapsed := Value <> i; end; procedure TBCExpandPanels.RollOut1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: integer); begin if (Behaviour = EPHotMouse) and (TBCExpandPanel(PanelArray[TBCBoundButton(Sender).Tag]).Collapsed) then HotTrackSetActivePanel(TBCBoundButton(Sender).Tag); end; function TBCExpandPanels.IdxOfPanel(aname: string): integer; var i: integer; begin Result := -1; // is not here for i := 0 to PanelArray.Count - 1 do if TBCExpandPanel(PanelArray[i]).Name = aname then begin Result := i; break; end; end; { TBCExpandPanel } procedure TBCExpandPanel.setCollapsed(Value: boolean); begin {$ifopt D+} debugln('TBCExpandPanel.setCollapsed '+BoolToStr(Collapsed, True)); {$endif} if FCollapsed = Value then exit; FCollapsed := Value; if not(csLoading in ComponentState) then if Value then DoCollapse else DoExpand; end; procedure TBCExpandPanel.SetRelevantSize(comp: TControl; AKind: TAnchorKind; ASize: Integer); begin case AKind of akTop, akBottom: comp.Height :=ASize; akLeft, akRight: comp.Width :=ASize; end; end; function TBCExpandPanel.RelevantSize(comp: TControl; akind: TAnchorKind): integer; begin case akind of akTop, akBottom: Result := comp.Height; akLeft, akRight: Result := comp.Width; end; end; function TBCExpandPanel.RelevantOrthogonalSize(comp: TControl; akind: TAnchorKind): integer; begin case akind of akTop, akBottom: Result := comp.Width; akLeft, akRight: Result := comp.Height; end; end; function TBCExpandPanel.DeltaCoordinates(deltaMove, deltaSize: integer): TRect; begin Result := Rect(0, 0, 0, 0); case FCollapseKind of akTop: Result := Rect(0, 0, 0, deltaSize); akLeft: Result := Rect(0, 0, deltaSize, 0); akBottom: Result := Rect(0, deltaMove, 0, deltaSize); akRight: Result := Rect(deltaMove, 0, deltaSize, 0); end; end; procedure TBCExpandPanel.TimerAnimateSize(Sender: TObject); var step: real; originalsize, size: integer; deltaMove, deltaSize: integer; delta: TRect; vorzeichen: integer; begin deltaMove := 0; deltaSize := 0; StopCircleActions := False; FAnimating := True; step := FAnimationSpeed; Size := RelevantSize(Self, FCollapseKind); vorzeichen := Sign(TargetAnimationSize - RelevantSize(self, FCollapseKind)); // muss ich delta addieren oder muss ich delta abziehen originalsize := ExpandedSize; //One huge step if not animated if not FAnimated or not (ComponentState * [csLoading, csDesigning] = []) then step := abs(Size - TargetAnimationSize); //small steps if animated if FAnimated and (ComponentState * [csLoading, csDesigning] = []) then begin step := step * originalsize / 200; if step < 3 then step := 3; end; //now actually do something if Abs(Size - TargetAnimationSize) > 0 then begin if Abs(Size - TargetAnimationSize) < abs(step) then // if there is just a little bit left to go, set delta so it can go directly to the end size deltaSize := TargetAnimationSize - Size else deltaSize := vorzeichen * round(step); if (CollapseKind = akBottom) or (CollapseKind = akRight) then deltaMove := -deltaSize; delta := DeltaCoordinates(deltaMove, deltaSize); SetBounds(Left + delta.Left, Top + delta.Top, Width + delta.Right, Height + delta.Bottom); if assigned(FInternalOnAnimate) then FInternalOnAnimate(self, delta.Left, delta.Top, delta.Right, delta.Bottom); if assigned(FOnAnimate) then FOnAnimate(self, delta.Left, delta.Top, delta.Right, delta.Bottom); end; if Abs(Size - TargetAnimationSize) = 0 then //it's finished ( executes it NEXT time the timer activates!) begin Timer.Enabled := False; FAnimating := False; StopCircleActions := False; if assigned(EndProcedureOfAnimation) then EndProcedureOfAnimation; end; end; procedure TBCExpandPanel.EndTimerCollapse; begin if assigned(OnCollapse) then OnCollapse(self); UpdateAll; end; procedure TBCExpandPanel.EndTimerExpand; begin if assigned(OnExpand) then OnExpand(self); UpdateAll; end; procedure TBCExpandPanel.UpdateAll; begin Update; //FButton.Update; end; procedure TBCExpandPanel.setExpandedSize(Value: integer); begin {$ifopt D+} debugln('TBCExpandPanel.setExpandedSize'); debugln(IntToStr(Value)); {$endif} if (FExpandedSize = Value) then exit; FExpandedSize := Value; if not(csLoading in ComponentState) and not(FCollapsed) then Animate(FExpandedSize); end; function TBCExpandPanel.GetEnabled: Boolean; begin Result :=inherited Enabled; if (FButton.Enabled <> Result) //Paranoic Think then FButton.Enabled :=Result; end; procedure TBCExpandPanel.SetBevelColorHighlight(AValue: TColor); begin if (rBevelColorHighlight <> AValue) then begin rBevelColorHighlight := AValue; if not(csLoading in ComponentState) then Invalidate; end; end; procedure TBCExpandPanel.SetBevelColorShadow(AValue: TColor); begin if (rBevelColorShadow <> AValue) then begin rBevelColorShadow := AValue; if not(csLoading in ComponentState) then Invalidate; end; end; procedure TBCExpandPanel.SetBevelRounded(AValue: Boolean); begin if (rBevelRounded <> AValue) then begin rBevelRounded := AValue; if not(csLoading in ComponentState) then Invalidate; end; end; procedure TBCExpandPanel.SetEnabled(AValue: Boolean); begin inherited Enabled :=AValue; FButton.Enabled :=AValue; end; procedure TBCExpandPanel.setButtonSize(Value: integer); begin if FButtonSize = Value then exit; FButtonSize := Value; PositionButton; end; procedure TBCExpandPanel.SetBounds(ALeft, ATop, AWidth, AHeight: integer); begin inherited SetBounds(ALeft, ATop, AWidth, AHeight); if not Collapsed and not Animating and (ComponentState * [csLoading] = []) then FExpandedSize := RelevantSize(self, FCollapseKind); end; procedure TBCExpandPanel.setButtonPosition(Value: TAnchorKind); var wasanimated, wascollpased: boolean; begin if FButtonPosition = Value then exit; wasanimated := Animated; wascollpased := Collapsed; Animated := False; if Collapsed then Collapsed := False; FButtonPosition := Value; PositionButton; Collapsed := wascollpased; Animated := wasanimated; Invalidate; end; procedure TBCExpandPanel.setCollapseKind(Value: TAnchorKind); var wasanimated, wascollpased: boolean; begin if FCollapseKind = Value then exit; wasanimated := Animated; wascollpased := Collapsed; Animated := False; if Collapsed then Collapsed := False; FCollapseKind := Value; //switsch sizes case FCollapseKind of akLeft, akRight: FExpandedSize := Width; akTop, akBottom: FExpandedSize := Height; end; if not(csLoading in ComponentState) then begin FButton.BuildGlyphs; FButton.Invalidate; end; Collapsed := wascollpased; Animated := wasanimated; end; procedure TBCExpandPanel.setAnimationSpeed(Value: real); begin korrigiere(Value, 3, 1000); FAnimationSpeed := Value; end; procedure TBCExpandPanel.PositionButton; function ButtonRect: TRect; begin case FButtonPosition of akBottom, akTop: Result := Rect(0, 0, RelevantOrthogonalSize(self, FButtonPosition), FButtonSize); akLeft, akRight: Result := Rect(0, 0, FButtonSize, RelevantOrthogonalSize(self, FButtonPosition)); end; //this must come after the thing above!!! // this moves the button to the bottom, or the right case FButtonPosition of akBottom: Result.Top := Result.Top + RelevantSize(self, FButtonPosition) - FButtonSize; akRight: Result.Left := Result.Left + RelevantSize(self, FButtonPosition) - FButtonSize; end; end; var new: TRect; begin if StopCircleActions or not(Assigned(FButton)) or (csLoading in ComponentState) then exit; StopCircleActions := True; new := ButtonRect; FButton.SetBounds(new.Left, new.Top, new.Right, new.Bottom); //set anchors case FButtonPosition of akBottom: FButton.Anchors := [akTop, akLeft, akBottom, akRight] - [akTop]; akLeft: FButton.Anchors := [akTop, akLeft, akBottom, akRight] - [akRight]; akTop: FButton.Anchors := [akTop, akLeft, akBottom, akRight] - [akBottom]; akRight: FButton.Anchors := [akTop, akLeft, akBottom, akRight] - [akLeft]; end; Invalidate; StopCircleActions := False; end; procedure TBCExpandPanel.ButtonClick(Sender: TObject); begin if Assigned(FEPManagesCollapsing) then FEPManagesCollapsing(self) else Collapsed := not Collapsed; if Assigned(OnButtonClick) then OnButtonClick(self); end; procedure TBCExpandPanel.Animate(aTargetSize: integer); var storAnimated: boolean; begin if (FAnimating) then begin // FinishLastAnimationFast storAnimated := FAnimated; FAnimated := False; TimerAnimateSize(self); FAnimated := storAnimated; end; // Now do animation TargetAnimationSize := aTargetSize; if (ComponentState * [csLoading, csDesigning] = []) and FAnimated then begin Timer.Enabled := True; Timer.OnTimer := @TimerAnimateSize; //EndProcedureOfAnimation := nil; //On Collapse then EndTimerCollapse never Executed end else begin TimerAnimateSize(self); TimerAnimateSize(self); end; end; procedure TBCExpandPanel.SetTextAlignment(AValue: TAlignment); begin if FTextAlignment=AValue then Exit; FTextAlignment:=AValue; Invalidate; end; procedure TBCExpandPanel.DoCollapse; var i :Integer; curControl: TControl; begin (* may work but is irrilevant because TSpeedButton is always on Bottom ????why? i :=0; while (i < ControlCount) do begin curControl :=Controls[i]; if not(curControl is TBCBoundButton) then begin Self.SetChildZPosition(curControl, 0); end; inc(i) end;*) if assigned(OnPreCollapse) then OnPreCollapse(self); //FButton.Color := FCollapsedButtonColor; EndProcedureOfAnimation := @EndTimerCollapse; Animate(FButtonSize); {$ifopt D+} debugln('TBCExpandPanel.DoCollapse'); debugln('FButtonSize ' + IntToStr(FButtonSize)); {$endif} end; procedure TBCExpandPanel.DoExpand; begin if assigned(OnPreExpand) then OnPreExpand(self); // FButton.ControlStyle := FButton.ControlStyle + [csNoFocus, csNoDesignSelectable]; // FButton.Parent:=self; //FButton.Color := FExpandedButtonColor; EndProcedureOfAnimation := @EndTimerExpand; Animate(FExpandedSize); {$ifopt D+} debugln('TBCExpandPanel.DoExpand'); debugln('FExpandedSize ' + IntToStr(FExpandedSize)); {$endif} end; procedure TBCExpandPanel.AdjustClientRect(var ARect: TRect); begin inherited AdjustClientRect(ARect); if Assigned(FButton) then case ButtonPosition of akTop: ARect.Top := ARect.Top + fButton.Height; akBottom: ARect.Bottom := ARect.Bottom - fButton.Height; akLeft: ARect.Left := ARect.Left + fButton.Width; akRight: ARect.Right := ARect.Right - fButton.Width; end; end; procedure TBCExpandPanel.Loaded; begin inherited Loaded; end; procedure TBCExpandPanel.CreateWnd; begin inherited CreateWnd; FButton.BuildGlyphs; //Button Loaded is called Before Self.Loaded and cannot Build Glyphs (* if (FCollapsed) then SetRelevantSize(Self, FButtonPosition, FButtonSize) else SetRelevantSize(Self, FButtonPosition, FExpandedSize); *) PositionButton; end; procedure TBCExpandPanel.Paint; var ARect: TRect; TS: TTextStyle; begin if not(FCollapsed) then begin ARect := GetClientRect; Case FButtonPosition of akTop: inc(ARect.Top, FButtonSize); akBottom: dec(ARect.Bottom, FButtonSize); akLeft: inc(ARect.Left, FButtonSize); akRight: dec(ARect.Right, FButtonSize); end; {$ifdef DEBUG_PAINT} Canvas.Brush.Color:=clRed; Canvas.Brush.Style:=bsSolid; Canvas.FillRect(ARect); {$endif} // if BevelOuter is set then draw a frame with BevelWidth if (BevelOuter <> bvNone) then if rBevelRounded then Frame3d_Rounded(Self.Canvas, ARect, BevelWidth, 5, 5, BevelOuter, rBevelColorShadow, rBevelColorHighlight, Color) else Self.Canvas.Frame3d(ARect, BevelWidth, BevelOuter); InflateRect(ARect, -BorderWidth, -BorderWidth); // if BevelInner is set then skip the BorderWidth and draw a frame with BevelWidth if (BevelInner <> bvNone) then if rBevelRounded then Frame3d_Rounded(Self.Canvas, ARect, BevelWidth, 5, 5, BevelInner, rBevelColorShadow, rBevelColorHighlight, Color) else Self.Canvas.Frame3d(ARect, BevelWidth, BevelInner); if (Self.Caption <> '') then begin TS := Canvas.TextStyle; TS.Alignment := BidiFlipAlignment(Self.TextAlignment, UseRightToLeftAlignment); if (BiDiMode <> bdLeftToRight) then TS.RightToLeft:= True; TS.Layout:= Graphics.tlCenter; TS.Opaque:= false; TS.Clipping:= false; TS.SystemFont:=Canvas.Font.IsDefault; if not(Enabled) then begin Canvas.Font.Color := clBtnHighlight; Types.OffsetRect(ARect, 1, 1); Self.Canvas.TextRect(ARect, ARect.Left, ARect.Top, Self.Caption, TS); Self.Canvas.Font.Color := clBtnShadow; Types.OffsetRect(ARect, -1, -1); end else Self.Canvas.Font.Color := Font.Color; Self.Canvas.TextRect(ARect,ARect.Left,ARect.Top, Self.Caption, TS); end; end; end; constructor TBCExpandPanel.Create(TheOwner: TComponent); begin StopCircleActions := True; inherited; FButtonSize := 27; FAnimated := True; FCollapseKind := akTop; FVisibleTotal := True; FCollapsed := False; FButtonPosition := akTop; FCollapsedButtonColor := clSkyBlue; FExpandedButtonColor := RGBToColor(23, 136, 248); rBevelColorHighlight:=clBtnHighlight; rBevelColorShadow:=clBtnShadow; rBevelRounded:=True; FExpandedSize := 200; Height := FExpandedSize; Width := 200; FAnimationSpeed := 20; Caption := ''; Timer := TTimer.Create(self); Timer.Enabled := False; Timer.Name := 'Animationtimer'; Timer.Interval := 20; FButton := TBCBoundButton.Create(self); with FButton do begin Parent := self; Name := 'Button'; Caption := 'Caption'; ControlStyle := ControlStyle + [csNoFocus, csNoDesignSelectable]; FButton.OnClick := @self.ButtonClick; end; StopCircleActions := False; //may be only in CreateWnd but the button is greater by some pixels PositionButton; end; destructor TBCExpandPanel.Destroy; begin timer.Enabled := False; Timer.Free; if (ComponentState * [csLoading, csDesigning] = []) then FButton.Free; // bringt einen Fehler in der Designtime wenn ich das hier mache // FButton.Free; // bringt einen Fehler in der Designtime wenn ich das hier mache inherited Destroy; end; {$IFDEF FPC} procedure Register; begin RegisterComponents('BGRA Controls', [TBCExpandPanel, TBCExpandPanels]); end; {$ENDIF} initialization {$i BCExpandPanels.lrs} end.