fcoutlookbar.pas

一套及时通讯的原码

unit fcOutlookBar;
{
//
// Components : TfcOutlookBar
//
// Copyright (c) 1999 by Woll2Woll Software
//
// 5/12/99 - RSW - Repaint current selection if its a non-rectangular button
// 11/1/2001 - PYW - Publish ShowDownAsUp property.
// 11/14/2001 - Added name for form inheritance issues.

}

interface

uses Messages, Windows, Graphics, Classes, Forms, Controls, SysUtils, fcCommon, fcButtonGroup,
  ExtCtrls, fcCollection, Dialogs, fcClearPanel, ComCtrls, fcOutlookList, fcImgBtn, fcButton,
  fcImager, fcChangeLink, fcShapeBtn;

{$i fcIfDef.pas}

type
  TfcOutlookPage = class;

  TfcCustomOutlookBar = class;

  TfcAnimation = class(TPersistent)
  private
    FEnabled: Boolean;
    FInterval: Integer;
    FSteps: Integer;
  public
    constructor Create;
  published
    property Enabled: Boolean read FEnabled write FEnabled;
    property Interval: Integer read FInterval write FInterval;
    property Steps: Integer read FSteps write FSteps;
  end;

  TfcOutlookPage = class(TfcButtonGroupItem)
  private
    FPanel: TfcOutlookPanel;
    FOutlookList: TfcOutlookList;
  protected
    function GetOutlookBar: TfcCustomOutlookBar; virtual;
    procedure SetIndex(Value: Integer); override;
    procedure Loaded; override;
  public
    constructor Create(Collection: TCollection); override;
    destructor Destroy; override;

    procedure CreateOutlookList; virtual;
    procedure GotSelected; override;

    property OutlookBar: TfcCustomOutlookBar read GetOutlookBar;
    property OutlookList: TfcOutlookList read FOutlookList;
    property Panel: TfcOutlookPanel read FPanel write FPanel;
  end;

  TfcOutlookPages = class(TfcButtonGroupItems)
  protected
    function GetOutlookBar: TfcCustomOutlookBar; virtual;
    function GetItems(Index: Integer): TfcOutlookPage;
    procedure AnimateSetBounds(Control: TWinControl; Rect: TRect); virtual;
  public
    constructor Create(AButtonGroup: TfcCustomButtonGroup; ACollectionItemClass: TfcButtonGroupItemClass); override;
    procedure ArrangeControls; override;
    function Add: TfcOutlookPage;
    function AddItem: TfcCollectionItem; override;

    property OutlookBar: TfcCustomOutlookBar read GetOutlookBar;
    property Items[Index: Integer]: TfcOutlookPage read GetItems; default;
  end;

  TfcCustomOutlookBarOption = (cboAutoCreateOutlookList, cboTransparentPanels);
  TfcCustomOutlookBarOptions = set of TfcCustomOutlookBarOption;

  TfcPanelAlignment = (paDynamic, paTop, paBottom);

  TfcCustomOutlookBar = class(TfcCustomButtonGroup)
  private
    // Property Storage Variables
    FAnimation: TfcAnimation;
    FAnimatingControls: Boolean;
    FAnimationLock: Integer;
    FButtonSize: Integer;
    FImager: TfcCustomImager;
    FOptions: TfcCustomOutlookBarOptions;
    FPanelAlignment: TfcPanelAlignment;
    FShowButtons: Boolean;

    FChangeLink: TfcChangeLink;

    // Property Access Methods
    function GetActivePage: TfcCustomBitBtn;
    function GetItems: TfcOutlookPages;
    procedure SetActivePage(Value: TfcCustomBitBtn);
    procedure SetAnimatingControls(Value: Boolean);
    procedure SetButtonSize(Value: Integer);
    procedure SetImager(Value: TfcCustomImager);
    procedure SetItems(Value: TfcOutlookPages);
    procedure SetOptions(Value: TfcCustomOutlookBarOptions); virtual;
    procedure SetPanelAlignment(Value: TfcPanelAlignment); virtual;
    procedure SetShowButtons(Value: Boolean);
    procedure CMControlListChange(var Message: TCMControlListChange); message CM_CONTROLLISTCHANGE;
    procedure CMControlChange(var Message: TCMControlChange); message CM_CONTROLCHANGE;
    procedure WMEraseBkgnd(var Message: TWMEraseBkGnd); message WM_ERASEBKGND; { 3/12/99 RSW - Need to prevent flicker }
    procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
    procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
  protected
    function GetCollectionClass: TfcButtonGroupItemsClass; override;
    procedure WndProc(var Message: TMessage); override;

    // Overridden methods
    function ResizeToControl(Control: TControl; DoResize: Boolean): TSize; override;
    procedure ButtonPressed(Sender: TObject); override;
    procedure CreateWnd; override;
    procedure GetChildren(Proc: TGetChildProc; Root: TComponent); override;
    procedure ImagerChange(Sender: TObject);
    procedure Loaded; override;
    procedure Notification(AComponent: TComponent; AOperation: TOperation); override;
    procedure Paint; override;

    // Overridden property access methods
    procedure SetName(const NewName: TComponentName); override;
    function IsNonRectangularButton(Control: TControl): boolean; virtual;
  public
    Patch: Variant;
//    InPaste: boolean;
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;

    function InAnimation: Boolean; virtual; { Button presses so begin animation, include 1 step }
    procedure EnableAnimation;
    procedure DisableAnimation;

    property ActivePage: TfcCustomBitBtn read GetActivePage write SetActivePage;
    property Animation: TfcAnimation read FAnimation write FAnimation;
    property AnimatingControls: Boolean read FAnimatingControls write SetAnimatingControls;
    property ButtonSize: Integer read FButtonSize write SetButtonSize;
    property Canvas;
    property Color;
    property Imager: TfcCustomImager read FImager write SetImager;
    property OutlookItems: TfcOutlookPages read GetItems write SetItems stored False;
    property Options: TfcCustomOutlookBarOptions read FOptions write SetOptions;
    property PanelAlignment: TfcPanelAlignment read FPanelAlignment write SetPanelAlignment;
    property ShowButtons: Boolean read FShowButtons write SetShowButtons;
  end;

  TfcOutlookBar = class(TfcCustomOutlookBar)
  published
    {$ifdef fcDelphi4Up}
    property Anchors;
    property Constraints;
    {$endif}

    property ActivePage;
    property Align;
    property Animation;
    property AutoBold;
    property BevelInner;
    property BevelOuter;
    property BorderStyle nodefault;
    property ButtonSize;
    property ButtonClassName;
    property Color;
    property Font;
    property ParentFont;
    property Imager;
    property OutlookItems;
    property Layout;
    property Options;
    property PanelAlignment;
    property ShowButtons;
    property ShowDownAsUp default False;
    property TabOrder;
    property TabStop default True;  //7/30/99 - Support TabStop = False
    property Visible;
//    property Transparent; { 3/13/99 - RSW - Not supported}

    property OnChange;
    property OnChanging;
    property OnEnter;
    property OnExit;
    property OnResize;
    property OnKeyDown;
    property OnKeyUp;
    property OnKeyPress;
  end;

implementation

constructor TfcAnimation.Create;
begin
  inherited;
  FEnabled := True;
  FInterval := 1;
  FSteps := 7;
end;

constructor TfcOutlookPage.Create(Collection: TCollection);
  function UniqueObjectName(oOwner: TWinControl; sPrefix: String): string;
  var
    iIndex: integer;
    sName: String;
  begin
    iIndex:= 1;
    sName:= sPrefix+inttostr(iIndex);
    while oOwner.FindComponent(sName) <> nil do begin
       inc(iIndex);
       sName:= sPrefix+inttostr(iIndex);
    end;
    result:= sName;
  end;
begin
  inherited;
  if not (csLoading in ButtonGroup.ComponentState) then
  begin
    ButtonGroup.ButtonItems.ArrangingControls := True;
    FPanel := TfcOutlookPanel.Create(ButtonGroup);
//    FPanel.Name := fcGenerateName(FPanel.Owner, ButtonGroup.Name + 'Panel');
    //11/14/2001 - Added name for form inheritance issues.
    FPanel.Name := UniqueObjectName(ButtonGroup,'OutlookPanel');
    FPanel.Parent := ButtonGroup;
    FPanel.Visible := False;
    FPanel.SendToBack;
    FPanel.Top := -FPanel.Height - 10;
    FPanel.OutlookPage := self;
//    FPanel.BevelOuter := bvNone;
    if cboAutoCreateOutlookList in OutlookBar.Options then
      CreateOutlookList;
    ButtonGroup.ButtonItems.ArrangingControls := False;
  end;
end;

destructor TfcOutlookPage.Destroy;
begin
  OutlookBar.FItems.DeletingControl := True;
  FPanel.Free;
  OutlookBar.FItems.DeletingControl := False;
  inherited;
end;

procedure TfcOutlookPage.SetIndex(Value: Integer);
begin
  inherited;
  if not (csLoading in ButtonGroup.ComponentState) then OutlookBar.SetChildOrder(Panel, Value);
end;

function TfcOutlookPage.GetOutlookBar: TfcCustomOutlookBar;
begin
  result := TfcCustomOutlookBar(ButtonGroup);
end;

procedure TfcOutlookPage.Loaded;
begin
  Panel.Owner.RemoveComponent(Panel);
  ButtonGroup.InsertComponent(Panel);
  Panel.OutlookPage := self;
  if FOutlookList <> nil then FOutlookList.OutlookPage := self;
end;

procedure TfcOutlookPage.CreateOutlookList;
var component:TWinControl;
begin
  if FOutlookList <> nil then Exit;
//  FOutlookList := TfcOutlookList.Create(GetParentForm(OutlookBar));
  component := OutlookBar.Parent;
  while (Component <> Nil) do
  begin
    if (Component is TCustomFrame) or (Component is TCustomForm) then begin
       FOutlookList := TfcOutlookList.Create(Component);
       break;
    end;
    Component := Component.Parent;
  end;

  with FOutlookList do
  begin
    Parent := FPanel;
    Align := alClient;
    BorderStyle := bsNone;
    if Component <> nil then
       Name := fcGenerateName(Component, self.OutlookBar.Name + 'OutlookList');
//    Name := fcGenerateName(GetParentForm(self.OutlookBar), self.OutlookBar.Name + 'OutlookList');
    OutlookPage := self;
  end;
end;

procedure TfcOutlookPage.GotSelected;
begin
  Selected := True;
  TfcButtonGroupItems(Collection).ArrangeControls;
end;

constructor TfcOutlookPages.Create(AButtonGroup: TfcCustomButtonGroup; ACollectionItemClass: TfcButtonGroupItemClass);
begin
  inherited Create(AButtonGroup, TfcOutlookPage);
end;

function TfcOutlookPages.GetOutlookBar: TfcCustomOutlookBar;
begin
  result := TfcCustomOutlookBar(ButtonGroup);
end;

function TfcOutlookPages.GetItems(Index: Integer): TfcOutlookPage;
begin
  result := TfcOutlookPage(inherited Items[Index]);
end;

procedure TfcOutlookPages.AnimateSetBounds(Control: TWinControl; Rect: TRect);
begin
  if Control is TfcOutlookPanel then
  begin
    if Control is TfcOutlookPanel then TfcOutlookPanel(Control).FPreventUpdate := True;
    Control.BoundsRect := Rect;
    if Control is TfcOutlookPanel then TfcOutlookPanel(Control).FPreventUpdate := False;
  end else begin
    with Rect do SetWindowPos(Control.Handle, 0, Left, Top, Right - Left, Bottom - Top, SWP_NOZORDER or SWP_NOREDRAW);
    InvalidateRect(Control.Handle, nil, False);
  end;
end;

type TfcOutlookButton = class(TfcCustomBitBtn);

procedure TfcOutlookPages.ArrangeControls;
var i: Integer;
    ControlTop: Integer;
    List: TList;
    Item: TfcGroupAnimateItem;
    CurItem: TfcOutlookPage;
    PanelHeight: Integer;
    OldPanel: TfcOutlookPanel;
    OldPanelIndex: integer;
    ASteps, AInterval: Integer;