sframebar.pas

Alpha Controls 5.40,delphi上的alpha开发源码控件包。没有密码。5.40版的最新版。

unit sFrameBar;
{$I sDefs.inc}

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ExtCtrls, sSpeedButton, sScrollBox, ImgList, Menus;

type
{$IFNDEF NOTFORHELP}
  TsTitleItem = class;
  TsTitles = class;
  TsTitleState = (stClosed, stOpened, stClosing, stOpening);
{$ENDIF} // NOTFORHELP

  TsFrameBar = class(TsScrollBox)
{$IFNDEF NOTFORHELP}
  private
    FItems: TsTitles;
    FTitleHeight: integer;
    FAnimation: boolean;
    FImages: TCustomImageList;
    FSpacing: integer;
    FAllowAllClose: boolean;
    FAllowAllOpen: boolean;
    FAutoFrameSize: boolean;
    FBorderWidth: integer;
    procedure SetItems(const Value: TsTitles);
    procedure SetTitleHeight(const Value: integer);
    procedure SetImages(const Value: TCustomImageList);
    function Offset : integer;
    procedure UpdateWidths;
    procedure SetSpacing(const Value: integer);
    function CalcClientRect : TRect;
    function CreateDefaultFrame : TFrame;
    function UpdateFrame(i, y, h, w : integer) : boolean;
    procedure SetAutoFrameSize(const Value: boolean);
    procedure SetAllowAllOpen(const Value: boolean);
    procedure SetBorderWidth(const Value: integer);
  public
    Arranging : boolean;
    Sizing : boolean;
    constructor Create(AOwner : TComponent); override;
    destructor Destroy; override;
    procedure Loaded; override;
    procedure WndProc (var Message: TMessage); override;
{$ENDIF} // NOTFORHELP
    procedure ArrangeTitles;
    procedure ChangeSize(Index : integer; AllowAnimation : boolean; Height:integer);
    procedure OpenItem(Index : integer; AllowAnimation : boolean);
    procedure CloseItem(Index : integer; AllowAnimation : boolean);
    procedure ExpandAll(AllowAnimation : boolean);
    procedure CollapseAll(AllowAnimation : boolean);
    procedure Rearrange;
  published
{$IFNDEF NOTFORHELP}
    property Align default alLeft;
    property BorderStyle;
    property BorderWidth : integer read FBorderWidth write SetBorderWidth default 2;
{$ENDIF} // NOTFORHELP
    property AllowAllClose : boolean read FAllowAllClose write FAllowAllClose default False;
    property AllowAllOpen : boolean read FAllowAllOpen write SetAllowAllOpen default False;
    property Animation : boolean read FAnimation write FAnimation default True;
    property AutoFrameSize : boolean read FAutoFrameSize write SetAutoFrameSize;
    property Images : TCustomImageList read FImages write SetImages;
    property Items : TsTitles read FItems write SetItems;
    property TitleHeight : integer read FTitleHeight write SetTitleHeight default 28;
    property Spacing : integer read FSpacing write SetSpacing default 2;
  end;

{$IFNDEF NOTFORHELP}
  TsTitles = class(TCollection)
  private
    FOwner: TsFrameBar;
  protected
    function GetItem(Index: Integer): TsTitleItem;
    procedure SetItem(Index: Integer; Value: TsTitleItem);
    function GetOwner: TPersistent; override;
  public
    constructor Create(AOwner : TsFrameBar);
    destructor Destroy; override;
    property Items[Index: Integer]: TsTitleItem read GetItem write SetItem; default;
  end;

  TsTitleButton = class(TsSpeedButton)
  protected
    Active : boolean;
    constructor InternalCreate(AOwner : TsFrameBar; Index : integer);
  public
    TitleItem : TsTitleItem; // v4.65
    function CurrentState : integer; override;
    property OnClick;
  end;
{$ENDIF} // NOTFORHELP

  TCreateFrameEvent = procedure (Sender: TObject; var Frame: TCustomFrame) of object;
  TFrameDestroyEvent = procedure (Sender: TObject; var Frame: TCustomFrame; var CanDestroy: boolean) of object;

  TsTitleItem = class(TCollectionItem)
{$IFNDEF NOTFORHELP}
  private
    FOwner: TsTitles;
    FCaption: string;
    FVisible: boolean;
    FOnCreateFrame: TCreateFrameEvent;
    FImageIndex: integer;
    FOnFrameDestroy: TFrameDestroyEvent;
    FOnClick: TNotifyEvent;
    procedure SetCaption(const Value: string);
    procedure SetVisible(const Value: boolean);
    procedure TitleButtonClick(Sender: TObject);
    function GetSkinSection: string;
    procedure SetSkinSection(const Value: string);
    procedure SetImageIndex(const Value: integer);
    function GetMargin: integer;
    function GetSpacing: integer;
    procedure SetMargin(const Value: integer);
    procedure SetSpacing(const Value: integer);
    function GetPopupMenu: TPopupMenu;
    procedure SetPopupMenu(const Value: TPopupMenu);
  public
{$ENDIF} // NOTFORHELP
    TitleButton : TsTitleButton;
    Frame : TCustomFrame;
    State : TsTitleState;
{$IFNDEF NOTFORHELP}
    FrameSize : integer;
    Closing : boolean;
    destructor Destroy; override;
    constructor Create(Collection: TCollection); override;
{$ENDIF} // NOTFORHELP
  published
    property Caption : string read FCaption write SetCaption;
    property ImageIndex : integer read FImageIndex write SetImageIndex default -1;
    property SkinSection : string read GetSkinSection write SetSkinSection;
    property Margin : integer read GetMargin write SetMargin default 5;
    property Spacing : integer read GetSpacing write SetSpacing default 8;
    property Visible : boolean read FVisible write SetVisible default True;
    property PopupMenu : TPopupMenu read GetPopupMenu write SetPopupMenu;
    property OnCreateFrame: TCreateFrameEvent read FOnCreateFrame write FOnCreateFrame;
    property OnClick: TNotifyEvent read FOnClick write FOnClick;
    property OnFrameDestroy: TFrameDestroyEvent read FOnFrameDestroy write FOnFrameDestroy;
  end;

implementation

uses sConst, sMessages, sSkinProps, sVCLUtils, sFrameAdapter, sLabel, stdctrls, acntUtils, acSBUtils;

{ TsTitles }
var
  DontAnim : boolean;

constructor TsTitles.Create(AOwner: TsFrameBar);
begin
  inherited Create(TsTitleItem);
  FOwner := AOwner;
end;

destructor TsTitles.Destroy;
begin
  inherited Destroy;
  FOwner := nil;
end;

function TsTitles.GetItem(Index: Integer): TsTitleItem;
begin
  Result := TsTitleItem(inherited GetItem(Index));
end;

function TsTitles.GetOwner: TPersistent;
begin
  Result := FOwner;
end;

procedure TsTitles.SetItem(Index: Integer; Value: TsTitleItem);
begin
  inherited SetItem(Index, Value);
end;

{ TsFrameBar }
procedure TsFrameBar.ArrangeTitles;
const
  StepsCount = 3;
  DelayValue = 10;
var
  i, ii, sHeight, cWidth, AutoHeight : integer;
  cRect : TRect;
  Steps, sDiv : integer;
  CanDestroy : boolean;
  procedure SetActive(Index : integer; Active : boolean);
  begin
    if (Items[Index].TitleButton.Active <> Active) and (Items[Index].State in [stClosed, stOpened]) then begin
      Items[Index].TitleButton.Active := Active;
      Items[Index].TitleButton.SkinData.Invalidate;
    end;
  end;
begin
  if not visible or Arranging or (csReading in ComponentState) or (Items.Count = 0) then Exit;
  if not DontAnim and not (csDesigning in ComponentState) and FAnimation and Visible and not (csLoading in ComponentState) then Steps := StepsCount else Steps := 0;

  cRect := CalcClientRect;
  Arranging := True;
  sHeight := 0;
  AutoHeight := -1;
  if not ShowHintStored then begin
    AppShowHint := Application.ShowHint;
    Application.ShowHint := False;
    ShowHintStored := True;
  end;
  FadingForbidden := True;
  MouseForbidden := True;
  if AutoFrameSize then begin
    AutoScroll := False;
    sHeight := cRect.Top;
    for i := 0 to Items.Count - 1 do if Items[i].TitleButton.Visible and Items[i].Visible then begin
      inc(sHeight, FTitleHeight);
      if (Items[i].State in [stOpened, stOpening]) then inc(sHeight, BorderWidth);
      inc(sHeight, BorderWidth);
    end;
    AutoHeight := HeightOf(cRect) - sHeight;
  end;
  for ii := 0 to Steps do begin
    SkinData.BeginUpdate;
    Perform(WM_SETREDRAW, 0, 0);
    sHeight := cRect.Top;
    cWidth := WidthOf(cRect);
    for i := 0 to Items.Count - 1 do if Items[i].TitleButton.Visible and Items[i].Visible then begin
      Items[i].TitleButton.SetBounds(cRect.Left, sHeight - Offset, cWidth, FTitleHeight);
      if Items[i].TitleButton.Parent <> Self then Items[i].TitleButton.Parent := Self;
      inc(sHeight, FTitleHeight);
      sDiv := Items[i].FrameSize;
      if (sDiv = 0) and (Items[i].State = stOpening) and not Animation then Items[i].State := stOpened;
      case Items[i].State of
        stOpening : begin
          inc(sHeight, FSpacing);
          if (ii = Steps) and (AutoHeight <> -1) then begin
            sDiv := AutoHeight;
            Items[i].FrameSize := AutoHeight;
            if Items[i].Frame <> nil then Items[i].Frame.Height := AutoHeight
          end;
          if Steps <> 0 then sDiv := Round((sDiv / Steps) * ii);
//!!!          for j := 0 to Steps - ii - 2 do sDiv := sDiv div 2; // Current height
          if UpdateFrame(i, sHeight - Offset, sDiv, cWidth) then begin
            if (ii = Steps) then begin
              Items[i].State := stOpened;
            end;
            if Steps > 0 then Sleep(DelayValue);
          end;
        end;
        stClosing : begin
        try
          if Steps = 0 then sDiv := 0 else sDiv := Round((sDiv / Steps) * (Steps - ii));
//!!!          for j := 0 to ii - 2 do sDiv := sDiv div 2; // Current height
          if (ii = Steps) then begin
            Items[i].Closing := False;
            CanDestroy := True;

            if Assigned(Items[i].FOnFrameDestroy) then Items[i].FOnFrameDestroy(Self, Items[i].Frame, CanDestroy);
            if CanDestroy then FreeAndNil(Items[i].Frame);
//            end;
            Items[i].FrameSize := 0;
            sDiv := 0;

            inc(sHeight, BorderWidth);
            Items[i].State := stClosed;
            SetActive(i, False);
            if Items[i].Frame <> nil then UpdateFrame(i, sHeight - Offset, sDiv, cWidth);
            Continue;
          end;
          UpdateFrame(i, sHeight - Offset, sDiv, cWidth);
          if Steps > 0 then Sleep(DelayValue);
        except
        end;
        end;
        stOpened : begin
          if AutoHeight <> -1 then begin
            sDiv := AutoHeight;
            Items[i].FrameSize := AutoHeight;
            if Items[i].Frame <> nil then Items[i].Frame.Height := AutoHeight
          end;
          UpdateFrame(i, sHeight - Offset, -1, cWidth);
          if (sDiv = 0) and (Items[i].Frame <> nil) then begin // v4.81
            sDiv := Items[i].Frame.Height
          end;
//          SetWindowRgn(Items[i].Frame.Handle, 0, False); // v5.03
        end;
        stClosed : begin
          if Items[i].Frame <> nil then begin
            CanDestroy := True;
            if Assigned(Items[i].FOnFrameDestroy) then Items[i].FOnFrameDestroy(Self, Items[i].Frame, CanDestroy);
            if CanDestroy then FreeAndNil(Items[i].Frame);
            Items[i].FrameSize := 0;
            sDiv := 0;
            if Items[i].Frame <> nil then UpdateFrame(i, sHeight - Offset, sDiv, cWidth);
            Items[i].FrameSize := 0;
          end
        end;
      end;
      if (Items[i].Frame <> nil) and (Items[i].State in [stOpened, stOpening, stClosing]) then begin
        if Items[i].Frame.Parent = nil then Items[i].Frame.Parent := Self;
        inc(sHeight, sDiv + BorderWidth);
      end;
      if (Items[i].Frame <> nil) and (Items[i].State = stOpened) then begin
        SetWindowRgn(Items[i].Frame.Handle, 0, False); // v5.03
      end;
      inc(sHeight, BorderWidth);
      SetActive(i, Items[i].State in [stOpened, stOpening]);
    end;
    Perform(WM_SETREDRAW, 1, 0);
    SkinData.EndUpdate;
    Repaint;
    if Parent <> nil then begin
      RedrawWindow(Handle, nil, 0, RDW_UPDATENOW or RDW_ALLCHILDREN or RDW_INVALIDATE or RDW_ERASE);
      SetParentUpdated(Self);
    end;
    if Assigned(acMagnForm) then SendMessage(acMagnForm.Handle, SM_ALPHACMD, MakeWParam(0, AC_REFRESH), 0);
    Application.ProcessMessages;
  end;
  FadingForbidden := False;
  inc(sHeight, BorderWidth + 2 * integer(BorderStyle = bsSingle));
  if VertScrollBar.Range <> sHeight then VertScrollBar.Range := sHeight;
  Arranging := False;
  UpdateWidths;
  if Parent <> nil then SendMessage(Handle, WM_NCPAINT, 0, 0);
  if Assigned(acMagnForm) then SendMessage(acMagnForm.Handle, SM_ALPHACMD, MakeWParam(0, AC_REFRESH), 0);
  MouseForbidden := False;
  Application.ShowHint := AppShowHint;
  ShowHintStored := False;
end;

function TsFrameBar.CalcClientRect: TRect;
begin
  Result := Rect(0, 0, Width - 4 * integer(BorderStyle = bsSingle), Height);
  InflateRect(Result,  - BorderWidth - 2 * integer(BorderStyle = bsSingle), - BorderWidth - 2 * integer(BorderStyle = bsSingle));
  if Parent = nil then Exit;
  if GetWindowLong(Handle, GWL_STYLE) and WS_VSCROLL = WS_VSCROLL then dec(Result.Right, GetSystemMetrics(SM_CXVSCROLL));
end;

procedure TsFrameBar.ChangeSize(Index: integer; AllowAnimation: boolean; Height: integer);
begin

  if Assigned(Items[Index].Frame) then begin
    Items[Index].FrameSize := Height;
    Items[Index].Frame.Height := Height;
  end;
  Items[Index].FrameSize := Height;

  if AllowAnimation then Items[Index].State := stOpening else Items[Index].State := stOpened;

  DontAnim := not AllowAnimation;
  ArrangeTitles;
  DontAnim := False;
end;

procedure TsFrameBar.CloseItem(Index: integer; AllowAnimation: boolean);
begin

  if AllowAnimation then Items[Index].State := stClosing else Items[Index].State := stClosed;
  DontAnim := not AllowAnimation;
  ArrangeTitles;
  DontAnim := False;
end;

procedure TsFrameBar.CollapseAll(AllowAnimation : boolean);
var
  i : integer;
begin

  for i := 0 to Items.Count - 1 do if AllowAnimation then Items[i].State := stClosing else Items[i].State := stClosed;
  ArrangeTitles;
end;

constructor TsFrameBar.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  SkinData.COC := COC_TsFrameBar;
  FItems := TsTitles.Create(Self);

  Caption := ' ';
  Align := alLeft;
  BevelOuter := bvLowered;