actnman.pas

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

    property ActionBars[const Index: Integer]: TActionBarItem
      read GetActionBar; default;
  published
    property Customizable;
    property HintShortCuts: Boolean read GetHintShortCuts
      write SetHintShortCuts default True;
    property SessionCount: Integer read FSessionCount write FSessionCount default 0;
    property ShowHints: Boolean read FShowHint write SetShowHints default True;
  end;

{ TActionClients }

  TActionClientClass = class of TActionClient;
  TCaptionOptions = (coNone, coSelective, coAll);

  TActionClients = class(TActionClientsCollection)
  private
    FCaptionOptions: TCaptionOptions;
    FSmallIcons: Boolean;
    FHideUnused: Boolean;
    function GetActionClient(const Index: Integer): TActionClientItem;
    procedure SetActionClient(const Index: Integer;
      const Value: TActionClientItem);
    procedure SetCaptionOptions(const Value: TCaptionOptions);
    procedure SetSmallIcons(const Value: Boolean);
    procedure SetHideUnused(const Value: Boolean);
  protected
    procedure DoHideUnused(AClient: TActionClient);
    procedure DoShowCaptions(AClient: TActionClient);
    procedure ToggleSmallIcons(Clients: TActionClients; Small: Boolean);
    procedure Notify(Item: TCollectionItem;
      Action: TCollectionNotification); override;
  public
    constructor Create(AOwner: TPersistent; ItemClass: TCollectionItemClass);
    function Add: TActionClientItem;
    procedure Assign(Source: TPersistent); override;
    function VisibleCount: Integer;
    property ActionClients[const Index: Integer]: TActionClientItem
      read GetActionClient write SetActionClient; default;
    property ActionManager: TCustomActionManager read GetActionManager;
  published
    property AutoHotKeys default True;
    property Customizable;
    property HideUnused: Boolean read FHideUnused write SetHideUnused default True;
    property CaptionOptions: TCaptionOptions read FCaptionOptions
      write SetCaptionOptions default coSelective;
    property SmallIcons: Boolean read FSmallIcons write SetSmallIcons default True;
  end;

{ TActionClientLink }

  TActionClientLinkClass = class of TActionClientLink;

  TActionClientLink = class(TActionLink)
  protected
    FClient: TActionClientItem;
    procedure AssignClient(AClient: TObject); override;
    function IsCaptionLinked: Boolean; override;
    function IsEnabledLinked: Boolean; override;
    function IsHelpContextLinked: Boolean; override;
    function IsHintLinked: Boolean; override;
    function IsImageIndexLinked: Boolean; override;
    function IsOnExecuteLinked: Boolean; override;
    function IsShortCutLinked: Boolean; override;
    function IsVisibleLinked: Boolean; override;
    function DoShowHint(var HintStr: string): Boolean; virtual;
    procedure SetCaption(const Value: string); override;
    procedure SetChecked(Value: Boolean); override;
    procedure SetEnabled(Value: Boolean); override;
    procedure SetHelpContext(Value: THelpContext); override;
    procedure SetHint(const Value: string); override;
    procedure SetImageIndex(Value: Integer); override;
    procedure SetOnExecute(Value: TNotifyEvent); override;
    procedure SetShortCut(Value: TShortCut); override;
    procedure SetVisible(Value: Boolean); override;
  end;

{ TActionClientItem }

  TMergeRange = 0..High(Integer);
  TCustomActionControl = class;

  TActionClientItem = class(TActionClient)
  private
    FActionLink: TActionClientLink;
    FCheckUnused: Boolean;
    FControl: TCustomActionControl;
    FUsageCount: Integer;
    FShortCut: TShortCut;
    FMergeIndex: TMergeRange;
    FSeparator: Boolean;
    FShowCaption: Boolean;
    FShowShortCut: Boolean;
    FShortCutText: string;
    FImageIndex: TImageIndex;
    FLastSession: Integer;
    FUnused: Boolean;
    FShowGlyph: Boolean;
    FHelpContext: THelpContext;
    procedure DoActionChange(Sender: TObject);
    procedure SetAction(const Value: TContainedAction);
    procedure SetUsageCount(const Value: Integer);
    function GetActionClients: TActionClients;
    procedure SetShortCut(const Value: TShortCut);
    procedure SetControl(const Value: TCustomActionControl);
    procedure SetMergeIndex(const Value: TMergeRange);
    procedure SetShowShortCut(const Value: Boolean);
    procedure SetImageIndex(const Value: TImageIndex);
    procedure SetCaption(const Value: string);
    procedure SetShowCaption(const Value: Boolean);
    function GetCaption: string;
    function GetAction: TContainedAction;
    procedure SetShowGlyph(const Value: Boolean);
    function IsCaptionStored: Boolean;
    function GetParentItem: TActionClient;
    procedure SetLastSession(const Value: Integer);
    function IsHelpContextStored: Boolean;
  protected
    procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); dynamic;
    procedure ColorChanged; override;
    function GetActionLinkClass: TActionClientLinkClass; dynamic;
    function GetDisplayName: string; override;
    procedure ResetUsageData;
    procedure SetChangesAllowed(const Value: TChangesAllowedSet); override;
    procedure SetCollection(Value: TCollection); override;
    procedure SetIndex(Value: Integer); override;
    procedure SetVisible(const Value: Boolean); override;
  public
    constructor Create(Collection: TCollection); override;
    destructor Destroy; override;
    procedure Assign(Source: TPersistent); override;
    function HasGlyph: Boolean;
    procedure InitiateAction; virtual;
    procedure Refresh; override;
    function Unused: Boolean;
    property ActionClients: TActionClients read GetActionClients;
    property ActionLink: TActionClientLink read FActionLink write FActionLink;
    property CheckUnused: Boolean read FCheckUnused write FCheckUnused;
    property Control: TCustomActionControl read FControl write SetControl;
    property ParentItem: TActionClient read GetParentItem;
    property Separator: Boolean read FSeparator;
    property ShortCutText: string read FShortCutText;
  published
    property Action: TContainedAction read GetAction write SetAction;
    property Caption: string read GetCaption write SetCaption stored IsCaptionStored;
    property HelpContext: THelpContext read FHelpContext write FHelpContext stored IsHelpContextStored default 0;
    property ImageIndex: TImageIndex read FImageIndex write SetImageIndex default -1;
    property MergeIndex: TMergeRange read FMergeIndex write SetMergeIndex default 0;
    property LastSession: Integer read FLastSession write SetLastSession default 0;
    property ShowCaption: Boolean read FShowCaption write SetShowCaption default True;
    property ShowGlyph: Boolean read FShowGlyph write SetShowGlyph default True;
    property ShowShortCut: Boolean read FShowShortCut write SetShowShortCut default True;
    property ShortCut: TShortCut read FShortCut write SetShortCut default 0;
    property UsageCount: Integer read FUsageCount write SetUsageCount default 0;
  end;

{ TActionDragBaseClass }

  TActionDragBaseClass = class(TDragObjectEx)
  private
    FActionManager: TCustomActionManager;
  public
    property ActionManager: TCustomActionManager read FActionManager
      write FActionManager;
  end;  

{ TActionDragObject }

  TCustomActionClass = class(TCustomAction);

  TActionDragObject = class(TActionDragBaseClass)
  private
    FActions: TList;
    function GetAction(Index: Integer): TContainedAction;
    function GetActionCount: Integer;
  protected
    FActionClasses: Boolean;
  public
    constructor Create;
    destructor Destroy; override;
    procedure AddAction(AnAction: TContainedAction);
    procedure AddActionClass(AnActionClass: TCustomActionClass);
    property ActionCount: Integer read GetActionCount;
    property Actions[Index: Integer]: TContainedAction read GetAction;
  end;

{ TCategoryDragObject }

  TCategoryDragObject = class(TActionDragObject)
  private
    FCategory: string;
  public
    constructor Create(ACategory: string);
    property Category: string read FCategory;
  end;

{ TActionItemDragObject }

  TActionItemDragObject = class(TActionDragBaseClass)
  private
    FClientItem: TActionClientItem;
  protected
    procedure Finished(Target: TObject; X: Integer; Y: Integer;
      Accepted: Boolean); override;
  public
    property ClientItem: TActionClientItem read FClientItem write FClientItem;
  end;

{ TCustomActionBarColorMap }

  TCustomActionBarColorMap = class;

  TColorMapUpdateProc = procedure(ActionBar: TCustomActionBar;
    Colors: TCustomActionBarColorMap);

  TCustomActionBarColorMap = class(TComponent)
  private
    FActionBars: TList;
    FBtnSelectedColor: TColor;
    FBtnFrameColor: TColor;
    FBtnSelectedFont: TColor;
    FColor: TColor;
    FDisabledColor: TColor;
    FDisabledFontColor: TColor;
    FDisabledFontShadow: TColor;
    FFontColor: TColor;
    FHotColor: TColor;
    FShadowColor: TColor;
    FHotFontColor: TColor;
    FUnusedColor: TColor;
    FSelectedFontColor: TColor;
    FSelectedColor: TColor;
    FHighlightColor: TColor;
    FDesignFocus: TColor;
    FMenuColor: TColor;
    FFrameTopLeftInner: TColor;
    FFrameTopLeftOuter: TColor;
    FFrameBottomRightInner: TColor;
    FFrameBottomRightOuter: TColor;
    FOnColorChange: TNotifyEvent;
    function GetDisabledColor: TColor;
    function GetUnusedColor: TColor;
  protected
    procedure Add(ActionBar: TCustomActionBar);
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
    procedure Remove(ActionBar: TCustomActionBar);
    procedure SetColor(const Value: TColor); virtual;
    procedure SetFontColor(const Value: TColor); virtual;
    procedure UpdateActionBars(UpdateProc: TColorMapUpdateProc; Color: TColor);
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Assign(Source: TPersistent); override;
    procedure UpdateColors; virtual;
    property BtnFrameColor: TColor read FBtnFrameColor write FBtnFrameColor;
    property BtnSelectedColor: TColor read FBtnSelectedColor write FBtnSelectedColor;
    property BtnSelectedFont: TColor read FBtnSelectedFont write FBtnSelectedFont;
    property Color: TColor read FColor write SetColor;
    property DesignFocus: TColor read FDesignFocus write FDesignFocus;
    property DisabledColor: TColor read GetDisabledColor write FDisabledColor;
    property DisabledFontColor: TColor read FDisabledFontColor write FDisabledFontColor;
    property DisabledFontShadow: TColor read FDisabledFontShadow write FDisabledFontShadow;
    property FontColor: TColor read FFontColor write SetFontColor;
    property FrameTopLeftInner: TColor read FFrameTopLeftInner write FFrameTopLeftInner;
    property FrameTopLeftOuter: TColor read FFrameTopLeftOuter write FFrameTopLeftOuter;
    property FrameBottomRightInner: TColor read FFrameBottomRightInner write FFrameBottomRightInner;
    property FrameBottomRightOuter: TColor read FFrameBottomRightOuter write FFrameBottomRightOuter;
    property HighlightColor: TColor read FHighlightColor write FHighlightColor;
    property HotColor: TColor read FHotColor write FHotColor;
    property HotFontColor: TColor read FHotFontColor write FHotFontColor;
    property MenuColor: TColor read FMenuColor write FMenuColor;
    property SelectedColor: TColor read FSelectedColor write FSelectedColor;
    property SelectedFontColor: TColor read FSelectedFontColor write FSelectedFontColor;
    property ShadowColor: TColor read FShadowColor write FShadowColor;
    property UnusedColor: TColor read GetUnusedColor write FUnusedColor;
    property OnColorChange: TNotifyEvent read FOnColorChange write FOnColorChange;
  end;

{ TCustomActionBar }

  TCustomActionBarClass = class of TCustomActionBar;
  TBarOrientation = (boLeftToRight, boRightToLeft, boTopToBottom, boBottomToTop);
  TControlCreatedEvent = procedure(Sender: TObject;
    var Control: TCustomActionControl) of object;
  TGetControlClassEvent = procedure(Sender: TCustomActionBar; AnItem: TActionClient;
    var ControlClass: TCustomActionControlClass) of object;
  TBarEdge = (beLeft, beRight, beEither);

  TCustomActionBar = class(TToolWindow)
  private
    FActionClient: TActionClient;
    FActionManager: TCustomActionManager;
    FAllowHiding: Boolean;
    FCanvas: TCanvas;
    FColorMap: TCustomActionBarColorMap;
    FDesignable: Boolean;     
    FDesignMode: Boolean;
    FEnabledState: Boolean;
    FOrientation: TBarOrientation;
    FSpacing: Integer;
    FOnControlCreated: TControlCreatedEvent;
    FOnGetControlClass: TGetControlClassEvent;
    FOnPaint: TNotifyEvent;
    FPersistentHotKeys: Boolean;
    FHRowCount: Integer;
    FVRowCount: Integer;
    FVertMargin: Integer;
    FHorzMargin: Integer;
    FHorzSeparator: Boolean;
    FSavedSize: TPoint;
    FVertSeparator: Boolean;
    FTallest: Integer;
    FWidest: Integer;
    FContextBar: Boolean;
    procedure SetActionManager(const Value: TCustomActionManager);
    procedure SetHorzMargin(const Value: Integer);
    procedure SetHorzSeparator(const Value: Boolean);
    procedure SetVertMargin(const Value: Integer);
    procedure SetVertSeparator(const Value: Boolean);
    procedure CMEnabledchanged(var Message: TMessage);
      message CM_ENABLEDCHANGED;
    procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE;
    procedure CMResetBar(var Message: TMessage); message CM_RESETBAR;
    procedure CMWinINIChange(var Message: TMessage);
      message CM_WININICHANGE;
    function GetItems: TActionClients;
    procedure WMContextMenu(var Message: TWMContextMenu);
      message WM_CONTEXTMENU;
    procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
    function GetAutoSizing: Boolean;
    function GetColorMap: TCustomActionBarColorMap;
  protected
    FDefaultColorMap: TCustomActionBarColorMap;
    FSavedWrapState: Boolean;
    procedure AlignControls(AControl: TControl; var Rect: TRect); override;
    procedure AutoSizingChanged; virtual;
    function BackgroundSize: TPoint;
    procedure Clear; virtual;
    function CalcInsertPosition(Control: TCustomActionControl; X, Y: Integer): Integer;
    function CreateControl(AnItem: TActionClientItem): TCustomActionControl; virtual;
    procedure CreateControls; virtual;
    function CustomAlignInsertBefore(C1: TControl; C2: TControl): Boolean; override;
    procedure CustomAlignPosition(Control: TControl; var NewLeft: Integer;
      var NewTop: Integer; var NewWidth: Integer; var NewHeight: Integer;
      var AlignRect: TRect; AlignInfo: TAlignInfo); override;
    function DesignWndProc(var Message: TMessage): Boolean; override;
    function DoGetControlClass(AnItem: TActionClientItem): TCustomActionControlClass; dynamic;
    procedure DoControlCreated(Control: TCustomActionControl); virtual;
    procedure DoDropCategory(Source: TCategoryDragObject; const X, Y: Integer); virtual;
    procedure DoDropActions(Source: TActionDragObject; const X, Y: Integer); virtual;
    procedure DoDropItem(Source: TActionItemDragObject; const X,Y: Integer); virtual;
    procedure DragOver(Source: TObject; X: Integer; Y: Integer;
      State: TDragState; var Accept: Boolean); override;
    function FindLast: TActionClientItem; virtual;
    function FindAccelItem(const Accel: Word): TActionClientItem;
    function FindItemAt(const P: TPoint): TCustomActionControl;
    function FindItemCaption(const ACaption: string): TCustomActionControl;