actnman.pas

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

    function FindNearestControl(const Point: TPoint): TCustomActionControl;
    function FindNextVisibleItem(AClient: TActionClientItem): TActionClientItem;
    function FindPreviousVisibleItem(AClient: TActionClientItem): TActionClientItem;
    function FindLeastUsedItem(const Visible: Boolean = True): TActionClientItem;
    function FindNext(AClient: TActionClientItem;
      const Wrap: Boolean = True): TActionClientItem; virtual;
     function FindPrevious(AClient: TActionClientItem;
      const Wrap: Boolean = True): TActionClientItem; virtual;
    function GetBannerWidth(BarEdge:  TBarEdge): Integer; virtual;
    function GetBarHeight: Integer; virtual;
    function GetBarWidth: Integer; virtual;
    function GetDesignMode: Boolean; virtual;
    function GetActionControl(const Index: Integer): TCustomActionControl; virtual;
    function GetDefaultColorMapClass: TCustomColorMapClass; virtual;
    function GetControlClass(AnItem: TActionClientItem): TCustomActionControlClass; virtual;
    function GetPopupMenuClass: TCustomActionBarClass;
    function HasItems: Boolean;
    function ItemCount: Integer; virtual;
    procedure Loaded; override;
    procedure NCPaint(DC: HDC); override;
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
    procedure DrawBackground; virtual;
    procedure Paint; virtual;
    procedure PaintWindow(DC: HDC); override;
    procedure Reset; virtual;
    procedure SetActionClient(const Value: TActionClient); virtual;
    procedure SetAutoSizing(const Value: Boolean); virtual;
    procedure SetColorMap(const Value: TCustomActionBarColorMap); virtual;
    procedure SetDesignMode(const Value: Boolean); virtual;
    procedure SetOrientation(const Value: TBarOrientation); virtual;
    procedure SetPersistentHotKeys(const Value: Boolean); virtual;
    procedure SetSpacing(Value: Integer); virtual;
    procedure SetBiDiMode(Value: TBiDiMode); override;
    function SetupDefaultColorMap: TCustomActionBarColorMap;
    procedure VisibleChanging; override;
    property HRowCount: Integer read FHRowCount;
    property Items: TActionClients read GetItems;
    property VRowCount: Integer read FVRowCount;
    property Widest: Integer read FWidest;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure DragDrop(Source: TObject; X: Integer; Y: Integer); override;
    function FindFirst: TActionClientItem; virtual;
    function FindFirstVisibleItem: TActionClientItem;
    function FindLastVisibleItem: TActionClientItem;
    procedure RecreateControls; virtual;
    procedure SetBounds(ALeft: Integer; ATop: Integer; AWidth: Integer;
      AHeight: Integer); override;
    function Style: TActionBarStyle; virtual;      
    property ActionManager: TCustomActionManager read FActionManager
      write SetActionManager;
    property ActionClient: TActionClient read FActionClient write SetActionClient;
    property AllowHiding: Boolean read FAllowHiding write FAllowHiding;
    property AutoSizing: Boolean read GetAutoSizing write SetAutoSizing;
    property Caption;
    property Canvas: TCanvas read FCanvas;
    property Color;
    property ColorMap: TCustomActionBarColorMap read GetColorMap write SetColorMap;
    property ContextBar: Boolean read FContextBar write FContextBar;
    property Designable: Boolean read FDesignable write FDesignable;
    property Font;
    property DesignMode: Boolean read GetDesignMode write SetDesignMode;
    property HorzMargin: Integer read FHorzMargin write SetHorzMargin default 1;
    property HorzSeparator: Boolean read FHorzSeparator write SetHorzSeparator;
    property Orientation: TBarOrientation read FOrientation write SetOrientation;
    property PersistentHotKeys: Boolean read FPersistentHotKeys write SetPersistentHotKeys;
    property ActionControls[const Index: Integer]: TCustomActionControl read GetActionControl;
    property Spacing: Integer read FSpacing write SetSpacing;
    property VertMargin: Integer read FVertMargin write SetVertMargin default 1;
    property VertSeparator: Boolean read FVertSeparator write SetVertSeparator;
    property OnControlCreated: TControlCreatedEvent read FOnControlCreated
      write FOnControlCreated;
    property OnGetControlClass: TGetControlClassEvent read FOnGetControlClass
      write FOnGetControlClass;
    property OnPaint: TNotifyEvent read FOnPaint write FOnPaint;
  end;

{ TCustomActionControl }

  TCMItemMsg = record
    Msg: Cardinal;
    Unused: Integer;
    Sender: TCustomActionControl;
    Result: Longint;
  end;

  TCustomActionControl = class(TGraphicControl)
  private
    FActionBar: TCustomActionBar;
    FActionClient: TActionClientItem;
    FDropPoint: Boolean;
    FGlyphLayout: TButtonLayout;
    FGlyphPos: TPoint;
    FMargins: TRect;
    FSelected: Boolean;
    FSmallIcon: Boolean;
    FSpacing: Integer;
    FTextBounds: TRect;
    FTransparent: Boolean;
    function CaptionLength: Integer;
    function CaptionHeight: Integer;
    function ActualSpacing(ImageSize: TPoint): Integer;
    procedure CMTextChanged(var Message: TMessage); message CM_TEXTCHANGED;
    function GetActionBar: TCustomActionBar;
    procedure SetMargins(Value: TRect);
    procedure SetTransparent(const Value: Boolean);
    procedure SetSmallIcon(const Value: Boolean);
    procedure SetSpacing(const Value: Integer);
    procedure CMHintShow(var Message: TCMHintShow); message CM_HINTSHOW;
    procedure WMContextMenu(var Message: TWMContextMenu);
      message WM_CONTEXTMENU;
  protected
    procedure BeginAutoDrag; override;
    procedure CalcLayout; virtual;
    function DesignWndProc(var Message: TMessage): Boolean; override;
    procedure DoDragDrop(DragObject: TObject; X, Y: Integer); virtual;
    procedure DragOver(Source: TObject; X: Integer; Y: Integer;
      State: TDragState; var Accept: Boolean); override;
    function GetAction: TBasicAction; override;
    function GetShowCaption: Boolean; virtual;
    function GetShowShortCut: Boolean; virtual;
    procedure CMDesignHitTest(var Message: TCMDesignHitTest);
      message CM_DESIGNHITTEST;
    procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
    procedure CMItemSelected(var Message: TCMItemMsg); message CM_ITEMSELECTED;
    procedure CMItemDropPoint(var Message: TCMItemMsg); message CM_ITEMDROPPOINT;
    procedure DoStartDrag(var DragObject: TDragObject); override;
    procedure DrawDesignFocus(var PaintRect: TRect); virtual;
    procedure DrawDragDropPoint;
    procedure DrawGlyph(const Location: TPoint); virtual;
    procedure DrawLargeGlyph(Location: TPoint); virtual;
    procedure DrawBackground(var PaintRect: TRect); virtual;
    procedure DrawText(var ARect: TRect; var Flags: Cardinal; Text: string); virtual;
    procedure DrawShadowedText(Rect: TRect; Flags: Cardinal; Text: string;
      TextColor, ShadowColor: TColor); virtual;
    procedure DrawSeparator(const Offset: Integer); virtual;
    function GetImageSize: TPoint; virtual;
    function HasGlyph: Boolean;
    function IsChecked: Boolean; virtual;
    function IsGrouped: Boolean; virtual;
    function GetSeparator: Boolean; virtual;
    procedure Paint; override;
    procedure PositionChanged; virtual;
    procedure ResetUsageData;
    procedure SetActionClient(Value: TActionClientItem); virtual;
    procedure SetGlyphLayout(const Value: TButtonLayout); virtual;
    procedure SetSelected(Value: Boolean); virtual;
    procedure SetDropPoint(Value: Boolean);
    procedure UpdateSelection;
    procedure UpdateTextBounds;
    procedure WMSetText(var Message: TWMSetText); message WM_SETTEXT;
    property GlyphPos: TPoint read FGlyphPos write FGlyphPos;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure CalcBounds; virtual;
    procedure Click; override;
    procedure DragDrop(Source: TObject; X: Integer; Y: Integer); override;
    procedure InitiateAction; override;
    procedure Keyed; virtual;
    property ActionBar: TCustomActionBar read GetActionBar;
    property ActionClient: TActionClientItem read FActionClient write SetActionClient;
    property Caption;
    property DropPoint: Boolean read FDropPoint write SetDropPoint;
    property GlyphLayout: TButtonLayout read FGlyphLayout write SetGlyphLayout;
    property Margins: TRect read FMargins write SetMargins;
    property Selected: Boolean read FSelected write SetSelected;
    property Separator: Boolean read GetSeparator;
    property ShowCaption: Boolean read GetShowCaption;
    property ShowShortCut: Boolean read GetShowShortCut;
    property SmallIcon: Boolean read FSmallIcon write SetSmallIcon;
    property Spacing: Integer read FSpacing write SetSpacing default 4;
    property TextBounds: TRect read FTextBounds write FTextBounds;
    property Transparent: Boolean read FTransparent write SetTransparent;
    property OnClick;
  end;

{ IActionBarDesigner }

  IActionBarDesigner = interface
  ['{7CFC301B-1C59-11D4-8184-00C04F6BB89F}']
    function CreateAction(AnActionClass: TContainedActionClass): TContainedAction;
    procedure EditAction(Action: TContainedAction);
    procedure Modified(ActionBar: TCustomActionBar);
    procedure SetActiveMenu(Menu: TCustomActionBar);
    procedure SetItemSelection(const Items: array of TActionClient);
    procedure SetSelection(APersistent: TPersistent);
  end;

{ TXToolDockForm }

  TXToolDockForm = class(TToolDockForm)
  private
    procedure CMDialogChar(var Message: TMessage); message CM_DIALOGCHAR;
  end;

procedure NotifyDesigner(ActionBar: TCustomActionBar);

const
  caAllChanges = [caModify, caMove, caDelete];
  ControlDragMode: array[Boolean] of TDragMode = (dmManual, dmAutomatic);
  cDefaultSchedule: string = '0=3'#13#10'1=3'#13#10'2=6'#13#10'3=9'#13#10 +
                             '4=12'#13#10'5=12'#13#10'6=17'#13#10'7=17'#13#10 +
                             '8=17'#13#10'9=23'#13#10'10=23'#13#10'11=23'#13#10 +
                             '12=23'#13#10'13=23'#13#10'14=31'#13#10'15=31'#13#10 +
                             '16=31'#13#10'17=31'#13#10'18=31'#13#10'19=31'#13#10 +
                             '20=31'#13#10'21=31'#13#10'22=31'#13#10'23=31'#13#10 +
                             '24=31'#13#10'25=31'#13#10;
type
  TActionBarStyleList = class(TStringList)
  private
    function GetStyle(Index: Integer): TActionBarStyle;
  public
    property Style[Index: Integer]: TActionBarStyle read GetStyle;
  end;
var
  ActionBarDesigner: IActionBarDesigner = nil;
  ActionBarStyles: TActionBarStyleList;
  DefaultActnBarStyle: string;

implementation

uses Consts, Dialogs, CommCtrl, GraphUtil, Math, ActnMenus, ActnColorMaps,
  Themes;

{ TXToolDockForm }

procedure TXToolDockForm.CMDialogChar(var Message: TMessage);
begin
  { Make sure pickletters are found in the main form first }
  if Application.MainForm <> nil then
    Application.MainForm.Dispatch(Message);
  if Message.Result = 0 then inherited;
end;

procedure NotifyDesigner(ActionBar: TCustomActionBar);
begin
  if Assigned(ActionBarDesigner) and ((ActionBar = nil) or
     (Assigned(ActionBar) and ActionBar.Designable)) then
    ActionBarDesigner.Modified(ActionBar);
end;

{ TCustomActionManager }

constructor TCustomActionManager.Create(AOwner: TComponent);
var
  I: Integer;
begin
  inherited Create(AOwner);
  Exclude(FComponentStyle, csInheritable);
  FActionBars := CreateActionBars;
  FPrioritySchedule := TStringList.Create;
  FPrioritySchedule.Text := cDefaultSchedule;
  for I := 0 to FPrioritySchedule.Count - 1 do
    with FPrioritySchedule do
      Objects[I] := Pointer(StrToInt(Values[Names[I]]));
end;

destructor TCustomActionManager.Destroy;
begin
  FPrioritySchedule.Free;
  FActionBars.Free;
  FDefaultActionBars.Free;
  if Assigned(FLinkedActionLists) then
    FLinkedActionLists.Free;
  inherited Destroy;
end;

function TCustomActionManager.AddAction(AnAction: TCustomAction;
  AClient: TActionClient; After: Boolean): TActionClientItem;
begin
  Result := nil;
  if (AClient = nil) or (AClient.Collection = nil) then exit;
  Result := TActionClientItem(AClient.Collection.Add);
  Result.Index := AClient.Index + Integer(After);
  Result.Action := AnAction;
end;

type
  TActionManagerClass = class(TCustomActionManager);
  TActionArray = array of TContainedAction;

function AddActions(var Actions: TActionArray;
  ActionList: TCustomActionList; ACategory: string): Integer;
var
  I: Integer;
begin
  Result := Length(Actions);
  if ActionList = nil then exit;
  SetLength(Actions, Result + ActionList.ActionCount);
  for I := 0 to ActionList.ActionCount - 1 do
    if AnsiCompareText(ActionList[I].Category, ACategory) = 0 then
    begin
      Actions[Result] := ActionList[I];
      Inc(Result);
    end;
  SetLength(Actions, Result);
end;

function TCustomActionManager.AddCategory(ACategory: string;
  AClient: TActionClient; After: Boolean): TActionClientItem;
var
  I: Integer;
  Actions: TActionArray;
begin
  Result := nil;
  if (AClient = nil) then exit;
  AddActions(Actions, Self, ACategory);
  for I := 0 to LinkedActionLists.Count - 1 do
    AddActions(Actions, LinkedActionLists[I].ActionList, ACategory);
  with AClient as TActionClient do
  begin
    Result := GetActionClientItemClass.Create(nil);
    Result.Caption := ACategory;
    Result.Collection := AClient.Collection;
    Result.Index := AClient.Index + Integer(After);
    for I := 0 to Length(Actions) - 1 do
      Result.Items.Add.Action := Actions[I];
    Result.Control.Enabled := True;
  end;
end;

function TCustomActionManager.AddSeparator(AnItem: TActionClientItem;
  After: Boolean): TActionClientItem;
begin
  Result := nil;
  if (AnItem = nil) or (AnItem.ActionClients = nil) then exit;
  Result := AnItem.ActionClients.Add;
  Result.Caption := '|';
  Result.Index := AnItem.Index + Integer(After);
end;

procedure TCustomActionManager.Assign(Source: TPersistent);
begin
  inherited Assign(Source);
  if Source is TCustomActionManager then
  begin
    ActionBars.Assign(TCustomActionManager(Source).ActionBars);
    FileName := TCustomActionManager(Source).FileName;
    if Assigned(Images) then
      Images.Assign(TCustomActionManager(Source).Images);
    PrioritySchedule.Assign(TCustomActionManager(Source).PrioritySchedule);
    if Assigned(TCustomActionManager(Source).FLinkedActionLists) then
      LinkedActionLists.Assign(TCustomActionManager(Source).LinkedActionLists);
  end;
end;

procedure TCustomActionManager.CompareAction(AClient: TActionClient);
begin
  if AClient is TActionClientItem then
    with AClient as TActionClientItem do
      if Action = FAction then
        FFoundClient := TActionClientItem(AClient);
end;

procedure TCustomActionManager.CompareCaption(AClient: TActionClient);