actnman.pas

多数代码可以直接在Delphi6和Delphi7环境下运行。部分涉及.NET技术内容的代码

{*******************************************************}
{                                                       }
{       Borland Delphi Visual Component Library         }
{                                                       }
{  Copyright (c) 1995-2002 Borland Software Corporation }
{                                                       }
{*******************************************************}

unit ActnMan;

interface

uses Windows, Messages, SysUtils, Forms, Classes, Menus, ActnList, Graphics,
  ToolWin, ImgList, Controls, Buttons;

const
  CM_ITEMSELECTED  = CM_BASE + $0402;
  CM_ITEMCLICKED   = CM_BASE + $0403;
  CM_ITEMKEYED     = CM_BASE + $0404;
  CM_SCROLLCLICKED = CM_BASE + $0406;
  CM_RESETBAR      = CM_BASE + $0409;
  CM_ENTERMENULOOP = CM_BASE + $0410;
  CM_ITEMDROPPOINT = CM_BASE + $0411;

type

  TActionBars = class;
  TActionListCollection = class;
  TActionClientsCollection = class;
  TActionClientItem = class;
  TActionClientItemClass = class of TActionClientItem;
  TCustomActionBar = class;
  TActionClient = class;
  TActionClients = class;
  TActionClientsClass = class of TActionClients;
  TActionBarsClass = class of TActionBars;
  TActionBarItemClass = class of TActionBarItem;
  TCustomActionManager = class;
  TGetBarsClassEvent = procedure(Sender: TCustomActionManager;
    BarsClass: TActionBarsClass) of object;
  TGetBarItemClassEvent = procedure(Sender: TCustomActionManager;
    var BarItemClass: TActionBarItemClass) of object;
  TGetClientsClassEvent = procedure(Sender: TCustomActionManager;
    var ClientsClass: TActionClientsClass) of object;
  TGetClientItemClassEvent = procedure(Sender: TCustomActionManager;
    var ClientItemClass: TActionClientItemClass) of object;
  TStyleChanged = procedure(Sender: TCustomActionManager) of object;    
  TActionProc = procedure(AClient: TActionClient) of object;

{ TActionBarStyle }

  TCustomActionControlClass = class of TCustomActionControl;
  TCustomColorMapClass = class of TCustomActionBarColorMap;

{ The following class requires the $M directive units which register
  descendants of this class to be added to the uses clause by the IDE. }

{$M+}

  TActionBarStyle = class
  public
    function GetControlClass(ActionBar: TCustomActionBar;
      AnItem: TActionClientItem): TCustomActionControlClass; virtual; abstract;
    function GetColorMapClass(ActionBar: TCustomActionBar): TCustomColorMapClass; virtual; abstract;
    function GetStyleName: string; virtual; abstract;
  end;

{$M-}

{ TCustomActionManager }

  TCustomActionManager = class(TCustomActionList)
  private
    FAction: TCustomAction;
    FActionBars: TActionBars;
    FCompareCaption: string;
    FCompareProc: TActionProc;
    FFoundClient: TActionClientItem;
    FLinkedActionLists: TActionListCollection;
    FDefaultActionBars: TActionBars;
    FFileName: TFileName;
    FLoading: Boolean;
    FPrioritySchedule: TStringList;
    FSaved: Boolean;
    FOnGetBarItemClass: TGetBarItemClassEvent;
    FOnGetBarsClass: TGetBarsClassEvent;
    FOnGetClientItemClass: TGetClientItemClassEvent;
    FOnGetClientsClass: TGetClientsClassEvent;
    FOnStyleChanged: TStyleChanged;
    FStyle: TActionBarStyle;
    procedure CompareCaption(AClient: TActionClient);
    procedure CompareAction(AClient: TActionClient);
    function FindItem: TActionClientItem;
    procedure SetActionBars(const Value: TActionBars);
    procedure SetPrioritySchedule(const Value: TStringList);
    function IsPriorityScheduleStored: Boolean;
    procedure SetLinkedActionLists(const Value: TActionListCollection);
    function IsLinkedActionListsStored: Boolean;
    function IsActionBarsStored: Boolean;
    function GetLinkedActionLists: TActionListCollection;
    procedure ReadStyleProp(Reader: TReader);
    procedure WriteStyleProp(Writer: TWriter);
    procedure SetStyle(const Value: TActionBarStyle);
    procedure ResetClientUsageData(AClient: TActionClient);
  protected
    procedure Change; override;
    function CreateActionBars: TActionBars;
    procedure DefineProperties(Filer: TFiler); override;
    function FindActionClient(AnAction: TContainedAction;
      Clients: TActionClientsCollection = nil): TActionClientItem;
    function FindActionBar(ActionBar: TCustomActionBar;
      Clients: TActionClientsCollection = nil): TActionClient;
    procedure FindClient(AClient: TActionClient);
    function GetActionBarsClass: TActionBarsClass; dynamic;
    function GetActionBarItemClass: TActionBarItemClass; dynamic;
    function GetActionClientsClass: TActionClientsClass; dynamic;
    function GetActionClientItemClass: TActionClientItemClass; dynamic;
    function GetUsage(AnItem: TActionClientItem): Boolean; virtual;
    function HasLinkedActionLists: Boolean;
    procedure Loaded; override;
    procedure LoadMenu(Clients: TActionClients; AMenu: TMenuItem);
    procedure Notification(AComponent: TComponent; Operation: TOperation);
      override;
    procedure SetupActionBars(ActionBars: TActionClientsCollection);
    procedure SetImages(Value: TCustomImageList); override;
    property Loading: Boolean read FLoading;
    property OnGetBarItemClass: TGetBarItemClassEvent read FOnGetBarItemClass
      write FOnGetBarItemClass;
    property OnGetBarsClass: TGetBarsClassEvent read FOnGetBarsClass
      write FOnGetBarsClass;
    property OnGetClientsClass: TGetClientsClassEvent read FOnGetClientsClass
      write FOnGetClientsClass;
    property OnGetClientItemClass: TGetClientItemClassEvent read FOnGetClientItemClass
      write FOnGetClientItemClass;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    function AddAction(AnAction: TCustomAction; AClient: TActionClient;
      After: Boolean = True): TActionClientItem;
    function AddCategory(ACategory: string; AClient: TActionClient;
      After: Boolean = True): TActionClientItem;
    function AddSeparator(AnItem: TActionClientItem; After: Boolean = True): TActionClientItem;
    procedure AfterConstruction; override;    
    procedure Assign(Source: TPersistent); override;
    procedure DeleteActionItems(Actions: array of TCustomAction);
    procedure DeleteItem(Caption: string);
    function FindItemByCaption(ACaption: string): TActionClientItem;
    function FindItemByAction(Action: TCustomAction): TActionClientItem;
    procedure LoadFromFile(const Filename: string);
    procedure LoadFromStream(S: TStream);
    procedure ResetActionBar(Index: Integer);
    procedure ResetUsageData;
    procedure SaveToFile(const Filename: string);
    procedure SaveToStream(S: TStream);
    property ActionBars: TActionBars read FActionBars write SetActionBars
      stored IsActionBarsStored;
    property DefaultActionBars: TActionBars read FDefaultActionBars;
    property LinkedActionLists: TActionListCollection read GetLinkedActionLists
      write SetLinkedActionLists stored IsLinkedActionListsStored;
    property FileName: TFileName read FFileName write FFileName;
    property Images;
    property PrioritySchedule: TStringList read FPrioritySchedule
      write SetPrioritySchedule stored IsPriorityScheduleStored;
    property Style: TActionBarStyle read FStyle write SetStyle;
    property OnStyleChanged: TStyleChanged read FOnStyleChanged write FOnStyleChanged;
  end;

{ TActionManager }

  TActionManager = class(TCustomActionManager)
  published
    // FileName must be streamed before ActionBars
    property FileName;
    property ActionBars;
    property LinkedActionLists;
    property Images;
    property PrioritySchedule;
    property State;
    property Style;
    property OnChange;
    property OnExecute;
    property OnGetBarItemClass;
    property OnGetBarsClass;
    property OnGetClientsClass;
    property OnGetClientItemClass;
    property OnUpdate;
    property OnStateChange;
    property OnStyleChanged;
  end;

{ TActionListItem }

  TActionListItem = class(TCollectionItem)
  private
    FActionList: TCustomActionList;
    FCaption: string;
    procedure SetActionList(const Value: TCustomActionList);
    function GetCaption: string;
  protected
    function GetDisplayName: string; override;
    function Owner: TActionListCollection;
  public
    procedure Assign(Source: TPersistent); override;
  published
    property ActionList: TCustomActionList read FActionList write SetActionList;
    property Caption: string read GetCaption write FCaption;
  end;

{ TActionListCollection }

  TActionListCollection = class(TOwnedCollection)
  private
    function GetActionManager: TCustomActionManager;
    function GetListItem(Index: Integer): TActionListItem;
    procedure SetListItem(Index: Integer;
      const Value: TActionListItem);
  public
    property ActionManager: TCustomActionManager read GetActionManager;
    property ListItems[Index: Integer]: TActionListItem read GetListItem
      write SetListItem; default;
  end;

{ TActionClientsCollection }

  TActionClientsCollection = class(TOwnedCollection)
  private
    FAutoHotKeys: Boolean;
    FParentItem: TActionClient;
    FCustomizable: Boolean;
    function GetActionClient(const Index: Integer): TActionClient;
    procedure SetActionClient(const Index: Integer;
      const Value: TActionClient);
    procedure SetAutoHotKeys(const Value: Boolean);
  protected
    function GetActionManager: TCustomActionManager;
    function InternalRethinkHotkeys(ForceRethink: Boolean): Boolean;
    property ActionClients[const Index: Integer]: TActionClient
      read GetActionClient write SetActionClient; default;
    property ParentItem: TActionClient read FParentItem write FParentItem;
  public
    procedure AfterConstruction; override;
    procedure IterateClients(Clients: TActionClientsCollection; ActionProc: TActionProc);
    property ActionManager: TCustomActionManager read GetActionManager;
    property AutoHotKeys: Boolean read FAutoHotKeys write SetAutoHotKeys;
    property Customizable: Boolean read FCustomizable write FCustomizable default True;
  end;

{ TActionClient }

  TBackgroundLayout = (blNormal, blStretch, blTile, blLeftBanner, blRightBanner);
  TChangesAllowed = (caModify, caMove, caDelete);
  TChangesAllowedSet = set of TChangesAllowed;

  TActionClient = class(TCollectionItem)
  private
    FActionBar: TCustomActionBar;
    FBackground: TPicture;
    FBackgroundLayout: TBackgroundLayout;
    FChildActionBar: TCustomActionBar;
    FContextItems: TActionClients;
    FCaption: string;
    FColor: TColor;
    FSmallIcons: Boolean;
    FItems: TActionClients;
    FVisible: Boolean;
    FChangesAllowed: TChangesAllowedSet;
    FTag: Integer;
    function GetContextItems: TActionClients;
    procedure SetActionBar(const Value: TCustomActionBar);
    procedure SetItems(const Value: TActionClients);
    procedure SetBackground(const Value: TPicture);
    procedure SetBackgroundLayout(const Value: TBackgroundLayout);
    procedure SetContextItems(const Value: TActionClients);
    function IsBackgroundStored: Boolean;
    function AreContextItemsStored: Boolean;
    function GetBackground: TPicture;
    function GetItems: TActionClients;
    function IsItemsStored: Boolean;
    function GetHasItems: Boolean;
    function GetOwningCollection: TActionClientsCollection;
  protected
    procedure ClearActionBar;
    procedure ColorChanged; virtual;
    procedure FreeChildren;
    function HasVisibleItems: Boolean;
    function IsChildItem(AClient: TActionClient): Boolean;
    procedure SetChangesAllowed(const Value: TChangesAllowedSet); virtual;
    procedure SetColor(const Value: TColor); virtual;
    procedure SetVisible(const Value: Boolean); virtual;
  public
    constructor Create(Collection: TCollection); override;
    destructor Destroy; override;
    procedure Assign(Source: TPersistent); override;
    function HasBackground: Boolean;
    procedure Refresh; virtual;
    property ActionBar: TCustomActionBar read FActionBar write SetActionBar;
    property ChildActionBar: TCustomActionBar read FChildActionBar
      write FChildActionBar;
    property HasItems: Boolean read GetHasItems;
    property OwningCollection: TActionClientsCollection read GetOwningCollection;    
  published
    property ChangesAllowed: TChangesAllowedSet read FChangesAllowed
      write SetChangesAllowed default [caModify, caMove, caDelete];
    property Color: TColor read FColor write SetColor default clDefault;
    property ContextItems: TActionClients read GetContextItems write SetContextItems
      stored AreContextItemsStored;
    property Background: TPicture read GetBackground write SetBackground
      stored IsBackgroundStored;
    property BackgroundLayout: TBackgroundLayout read FBackgroundLayout
      write SetBackgroundLayout default blNormal;
    property Items: TActionClients read GetItems write SetItems
      stored IsItemsStored;
    property Tag: Integer read FTag write FTag default 0;
    property Visible: Boolean read FVisible write SetVisible default True;
  end;

{ TActionBarItem }

  TActionBarItem = class(TActionClient)
  private
    FAutoSize: Boolean;
    FGlyphLayout: TButtonLayout;
    function GetActionBars: TActionBars;
    procedure SetAutoSize(const Value: Boolean);
    procedure SetGlyphLayout(const Value: TButtonLayout);
  protected
    procedure ColorChanged; override;
    function GetDisplayName: string; override;
    procedure SetVisible(const Value: Boolean); override;
    property ActionBars: TActionBars read GetActionBars;
  public
    constructor Create(Collection: TCollection); override;
    procedure Refresh; override;
  published
    property ActionBar;
    property AutoSize: Boolean read FAutoSize write SetAutoSize default True;
    property GlyphLayout: TButtonLayout read FGlyphLayout write SetGlyphLayout default blGlyphLeft;
  end;

{ TActionBars }

  TActionBars = class(TActionClientsCollection)
  private
    FSessionCount: Integer;
    FShowHint: Boolean;
    function GetActionBar(const Index: Integer): TActionBarItem;
    procedure SetShowHints(const Value: Boolean);
    procedure SetHintShortCuts(const Value: Boolean);
    function GetHintShortCuts: Boolean;
  protected
    procedure DoShowHint(AClient: TActionClient);
    procedure Notify(Item: TCollectionItem;
      Action: TCollectionNotification); override;
  public
    constructor Create(AOwner: TPersistent; ItemClass: TCollectionItemClass);
    function Add: TActionBarItem;