actnctrls.pas

这是不可多得的源代码

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

unit ActnCtrls;

interface

uses Windows, Messages, Classes, Controls, Graphics, ToolWin, ActnMan,
  Buttons, StdCtrls, ComCtrls, Contnrs, GraphUtil, ExtCtrls;

type

{ TCustomButtonControl }

  TCustomButtonControl = class(TCustomActionControl)
  private
    FAllowAllUp: Boolean;
    FDown: Boolean;
    FDragging: Boolean;
    FMouseInControl: Boolean;
    FTrackButton: TMouseButton;
    procedure SetDown(Value: Boolean);
    procedure SetAllowAllUp(Value: Boolean);
    procedure UpdateTracking;
    procedure SetFlat(const Value: Boolean);
    procedure SetState(const Value: TButtonState);
  protected
    FFlat: Boolean;
    FState: TButtonState;
    procedure DrawBackground(var PaintRect: TRect); override;
    procedure DrawFrame(ARect: TRect; Down: Boolean); virtual;
    function GetShowShortCut: Boolean; override;
    procedure Loaded; override;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
      X, Y: Integer); override;
    procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState;
      X, Y: Integer); override;
    procedure Paint; override;
    procedure SetActionClient(Value: TActionClientItem); override;
    procedure SetGlyphLayout(const Value: TButtonLayout); override;
    procedure SetSelected(Value: Boolean); override;
    procedure WMLButtonDblClk(var Message: TWMLButtonDown); message WM_LBUTTONDBLCLK;
    procedure CMDialogChar(var Message: TCMDialogChar); message CM_DIALOGCHAR;
    procedure CMEnabledChanged(var Message: TMessage); message CM_ENABLEDCHANGED;
    procedure CMTextChanged(var Message: TMessage); message CM_TEXTCHANGED;
    procedure CMMouseEnter(var Message: TMessage); message CM_MOUSEENTER;
    procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE;
    procedure DrawLargeGlyph(Location: TPoint); override;
    property MouseInControl: Boolean read FMouseInControl;
  public
    constructor Create(AOwner: TComponent); override;
    procedure CalcBounds; override;
    procedure Click; override;
    procedure SetBounds(ALeft: Integer; ATop: Integer; AWidth: Integer;
      AHeight: Integer); override;
    property AllowAllUp: Boolean read FAllowAllUp write SetAllowAllUp;
    property Caption;
    property Down: Boolean read FDown write SetDown;
    property Flat: Boolean read FFlat write SetFlat;
    property ShowCaption;
    property ShowShortCut;
    property State: TButtonState read FState write SetState;
    property TrackButton: TMouseButton read FTrackButton write FTrackButton;
  end;

{ TCustomUtilityButton }

  TCustomUtilityButton = class(TCustomButtonControl)
  private
    FArrowSize: Integer;
    FDirection: TScrollDirection;
    FScrollTimer: TTimer;
    FOnClick: TNotifyEvent;
    FRepeatRate: Integer;
    FAutoScroll: Boolean;
    FArrowType: TArrowType;
    procedure SetArrowSize(const Value: Integer);
    procedure SetArrowType(const Value: TArrowType);
    procedure SetDirection(const Value: TScrollDirection);
  protected
    procedure DrawArrows; virtual;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
      X: Integer; Y: Integer); override;
    procedure OnDelay(Sender: TObject);
    procedure CMMouseEnter(var Message: TMessage); message CM_MOUSEENTER;
    procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE;
    procedure Paint; override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Click; override;
    property AutoScroll: Boolean read FAutoScroll write FAutoScroll;
    property ArrowSize: Integer read FArrowSize write SetArrowSize;
    property ArrowType: TArrowType read FArrowType write SetArrowType;
    property Color;
    property Direction: TScrollDirection read FDirection write SetDirection;
    property RepeatRate: Integer read FRepeatRate write FRepeatRate;
    property OnClick: TNotifyEvent read FOnClick write FOnClick;
  end;

{ TCustomToolScrollBtn }

  TCustomToolScrollBtn = class(TCustomUtilityButton)
  protected
    procedure DrawArrows; override;
  public
    constructor Create(AOwner: TComponent); override;
  end;

{ TCustomDropDownButton }

  TCustomActionBarClass = class of TCustomActionBar;
  
  TCustomDropDownButton = class(TCustomButtonControl)
  private
    FDroppedDown: Boolean;
    procedure CMMouseleave(var Message: TMessage); message CM_MOUSELEAVE;
  protected
    procedure DrawFrame(ARect: TRect; Down: Boolean); override;
    function GetPopupClass: TCustomActionBarClass; virtual;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
      X, Y: Integer); override;
    function MouseOverDropDown: Boolean;
    procedure Paint; override;
    property DroppedDown: Boolean read FDroppedDown;
  public
    procedure CalcBounds; override;
    procedure Click; override;
    procedure DropDownClick; virtual;
  end;

  TCustomComboControl = class;

  TCustomActionCombo = class(TCustomComboBoxEx)
  private
    FComboControl: TCustomComboControl;
  protected
    procedure BeginAutoDrag; override;
    function DesignWndProc(var Message: TMessage): Boolean; override;
    procedure DragOver(Source: TObject; X: Integer; Y: Integer;
      State: TDragState; var Accept: Boolean); override;
    procedure ComboWndProc(var Message: TMessage; ComboWnd: HWND;
      ComboProc: Pointer); override;
  public
    procedure DragDrop(Source: TObject; X: Integer; Y: Integer); override;
  end;

  TCustomComboControl = class(TCustomActionControl)
  private
    FComboBox: TCustomActionCombo;
  protected
    procedure ComboClick(Sender: TObject);
    procedure SetParent(AParent: TWinControl); override;
    procedure SetActionClient(Value: TActionClientItem); override;
    procedure SetDragMode(Value: TDragMode); override;
    procedure VisibleChanging; override;
    procedure CMVisiblechanged(var Message: TMessage);
      message CM_VISIBLECHANGED;
    procedure Paint; override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure CalcBounds; override;
    procedure Click; override;
    procedure SetBounds(ALeft: Integer; ATop: Integer; AWidth: Integer;
      AHeight: Integer); override;
    property ComboBox: TCustomActionCombo read FComboBox;
  end;

{ TCustomActionDockBar }

  TCustomActionDockBar = class(TCustomActionBar)
  private
    FDragObject: TDragDockObject;
  protected
    procedure DoEndDock(Target: TObject; X: Integer; Y: Integer); override;
    procedure DoStartDock(var DragObject: TDragObject); override;
    function GetFloatingDockSiteClass: TWinControlClass; override;
    procedure GetSiteInfo(Client: TControl; var InfluenceRect: TRect;
      MousePos: TPoint; var CanDock: Boolean); override;
    procedure Loaded; override;
  public
    constructor Create(AOwner: TComponent); override;
    procedure Dock(NewDockSite: TWinControl; ARect: TRect); override;
  end;

{ TCustomActionToolBar }

  TCustomToolScrollBtnClass = class of TCustomToolScrollBtn;

  TCustomActionToolBar = class(TCustomActionDockBar)
  private
    FHiddenItems: TStack;
    FHideLevel: Integer;
    FPopupBar: TCustomActionBar;
    FScrollBtn: TCustomToolScrollBtn;
    FShadowClr: TColor;
    FHighlightClr: TColor;
    function GetHiddenCount: Integer;
  protected
    procedure AutoSizingChanged; override;
    function CalcButtonWidth: Integer;
    function CreateControl(AnItem: TActionClientItem): TCustomActionControl; override;
    procedure DisableHiding;
    procedure DoDropCategory(Source: TCategoryDragObject; const X, Y: Integer); override;
    procedure DrawBackground; override;
    procedure DrawSeparator(const Pos, Offset: Integer); virtual;
    procedure EnableHiding;
    function GetControlClass(AnItem: TActionClientItem): TCustomActionControlClass; override;
    function GetScrollBtnClass: TCustomToolScrollBtnClass;
    function GetPopupClass: TCustomActionBarClass; virtual;
    procedure HideUnusedItems;
    procedure Reset; override;
    procedure ScrollBtnClick(Sender: TObject);
    procedure SetOrientation(const Value: TBarOrientation); override;
    procedure SetupDropDownBtn;
    procedure CMColorchanged(var Message: TMessage);
      message CM_COLORCHANGED;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure DragDrop(Source: TObject; X: Integer; Y: Integer); override;
    procedure SetBounds(ALeft: Integer; ATop: Integer; AWidth: Integer;
      AHeight: Integer); override;
    property HiddenCount: Integer read GetHiddenCount;
  end;

{ TActionToolBar }

  TActionToolBar = class(TCustomActionToolBar)
  public
    property Canvas;
  published
    property ActionManager;
    property Align default alTop;
    property AllowHiding default True;
    property Anchors;
    property BiDiMode;
    property Caption;
    property Color default clBtnFace;
    property ColorMap;
    property Constraints;
    property Cursor;
    property DragCursor;
    property DragKind default dkDock;
    property DragMode;
    property EdgeBorders default [];
    property EdgeInner;
    property EdgeOuter default esNone;
    property Enabled;
    property Font;
    property HorzMargin;
    property HorzSeparator default True;
    property Orientation default boLeftToRight;
    property ParentBiDiMode;
    property ParentBackground default False;
    property ParentColor default False;
    property ParentFont;
    property ParentShowHint;
    property PersistentHotKeys default False;
    property PopupMenu;
    property ShowHint;
    property Spacing;
    property VertMargin;
    property Visible;
    property OnControlCreated;
    property OnCanResize;
    property OnClick;
    property OnConstrainedResize;
    property OnContextPopup;
    property OnDockDrop;
    property OnDockOver;
    property OnDblClick;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDock;
    property OnEndDrag;
    property OnEnter;
    property OnExit;
    property OnGetControlClass;
    property OnGetSiteInfo;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property OnPaint;
    property OnResize;
    property OnStartDock;
    property OnStartDrag;
    property OnUnDock;
  end;

implementation

uses SysUtils, Forms, Consts, ActnList, ExtActns, ActnMenus,
  ListActns, ActnColorMaps;

{ TCustomButtonControl }

constructor TCustomButtonControl.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  ControlStyle := [csDoubleClicks];
  FFlat := True;
  FState := bsUp;
end;

procedure TCustomButtonControl.CalcBounds;
begin
  inherited CalcBounds;
  Width := Width + 1;
end;

procedure TCustomButtonControl.Click;
begin
  SetSelected(True);
  inherited Click;
end;

procedure TCustomButtonControl.CMEnabledChanged(var Message: TMessage);
begin
  UpdateTracking;
  inherited;
end;

procedure TCustomButtonControl.CMTextChanged(var Message: TMessage);
begin
  if Separator then
  begin
    if Assigned(ActionBar) and
       (ActionBar.Orientation in [boLeftToRight, boRightToLeft]) then
      Width := 8
    else
      Height := 6;
  end
  else
    inherited;
end;

procedure TCustomButtonControl.CMMouseEnter(var Message: TMessage);
begin
  inherited;
  if FFlat and not FMouseInControl and Enabled and (GetCapture = 0) then
  begin
    FMouseInControl := True;
    Repaint;
  end;
end;

procedure TCustomButtonControl.CMMouseLeave(var Message: TMessage);
begin
  inherited;
  if FFlat and FMouseInControl and Enabled then
  begin
    FMouseInControl := False;
    if not IsChecked then
      FState := bsUp;
    FDragging := False;
    Invalidate;
  end;
end;

procedure TCustomButtonControl.DrawBackground(var PaintRect: TRect);
const
  BrushStyle: array[Boolean] of TBrushStyle = (bsSolid, bsClear);
begin
  if IsChecked and not MouseInControl then
    Canvas.Brush.Bitmap := AllocPatternBitmap(Canvas.Brush.Color,
      GetHighLightColor(Canvas.Brush.Color));
  inherited;
end;

procedure TCustomButtonControl.DrawFrame(ARect: TRect; Down: Boolean);
begin
end;

function TCustomButtonControl.GetShowShortCut: Boolean;
begin
  Result := False;
end;

procedure TCustomButtonControl.Loaded;
begin
  inherited Loaded;
  if Action <> nil then ActionChange(Action, True);
end;

procedure TCustomButtonControl.MouseDown(Button: TMouseButton; Shift: TShiftState;
  X, Y: Integer);
begin
  inherited MouseDown(Button, Shift, X, Y);
  if (Button = mbLeft) and Enabled then
  begin
    if not FDown then
    begin
      State := bsDown;
      Invalidate;
    end;
    FDragging := True;
  end;
end;

procedure TCustomButtonControl.MouseMove(Shift: TShiftState; X, Y: Integer);
var
  NewState: TButtonState;
begin
  inherited MouseMove(Shift, X, Y);
  if FDragging then
  begin
    if not FDown then NewState := bsUp
    else NewState := bsExclusive;
    if (X >= 0) and (X < ClientWidth) and (Y >= 0) and (Y <= ClientHeight) then
      if FDown then
        NewState := bsExclusive
      else
        NewState := bsDown;
    if NewState <> FState then
      State := NewState;
  end
  else if not MouseInControl then
    UpdateTracking;
end;

procedure TCustomButtonControl.MouseUp(Button: TMouseButton; Shift: TShiftState;
  X, Y: Integer);
var
  DoClick: Boolean;
begin
  inherited MouseUp(Button, Shift, X, Y);
  if FDragging then
  begin
    FDragging := False;
    DoClick := (X >= 0) and (X < ClientWidth) and (Y >= 0) and (Y <= ClientHeight);
    if Assigned(ActionClient) and (ActionClient.Action is TCustomAction) and
       ((TCustomAction(ActionClient.Action).GroupIndex = 0) or
       (TCustomAction(ActionClient.Action).AutoCheck and
       TCustomAction(ActionClient.Action).Checked)) then
    begin
      { Redraw face in-case mouse is captured }
      FState := bsUp;
      FMouseInControl := False;
      if DoClick and not (FState in [bsExclusive, bsDown]) then
        Invalidate;
    end
    else
      if DoClick then
      begin
        SetDown(not FDown);
        if FDown then Repaint;
      end
      else
      begin
        if FDown then FState := bsExclusive;
        Repaint;
      end;
    if DoClick then Click;
    UpdateTracking;
  end;
end;

procedure TCustomButtonControl.Paint;
begin
  inherited Paint;
  if not Separator then
  begin
    Canvas.Pen.Width := 1;
    DrawFrame(ClientRect, IsChecked or (FState = bsDown))
  end;
end;

procedure TCustomButtonControl.SetActionClient(Value: TActionClientItem);
begin
  inherited SetActionClient(Value);
  Enabled := Enabled and Assigned(Value) and not Separator;
end;

procedure TCustomButtonControl.SetAllowAllUp(Value: Boolean);
begin
  if FAllowAllUp <> Value then
    FAllowAllUp := Value;