tb2item.pas

对于单个控件,COMPONET-->INSTALL COMPONENT..-->PAS或DCU文件-->INSTALL。 2.对于带*.DPK文件的控件包,FILE-->OP

unit TB2Item;

// vclskin patch for toolbar2000 2.2
{
  Toolbar2000
  Copyright (C) 1998-2006 by Jordan Russell
  All rights reserved.

  The contents of this file are subject to the "Toolbar2000 License"; you may
  not use or distribute this file except in compliance with the
  "Toolbar2000 License". A copy of the "Toolbar2000 License" may be found in
  TB2k-LICENSE.txt or at:
    http://www.jrsoftware.org/files/tb2k/TB2k-LICENSE.txt

  Alternatively, the contents of this file may be used under the terms of the
  GNU General Public License (the "GPL"), in which case the provisions of the
  GPL are applicable instead of those in the "Toolbar2000 License". A copy of
  the GPL may be found in GPL-LICENSE.txt or at:
    http://www.jrsoftware.org/files/tb2k/GPL-LICENSE.txt
  If you wish to allow use of your version of this file only under the terms of
  the GPL and not to allow others to use your version of this file under the
  "Toolbar2000 License", indicate your decision by deleting the provisions
  above and replace them with the notice and other provisions required by the
  GPL. If you do not delete the provisions above, a recipient may use your
  version of this file under either the "Toolbar2000 License" or the GPL.

  $jrsoftware: tb2k/Source/TB2Item.pas,v 1.284 2006/04/05 19:34:05 jr Exp $
}

interface

{$I TB2Ver.inc}
{x$DEFINE TB2K_NO_ANIMATION}
  { Enabling the above define disables all menu animation. For debugging
    purpose only. }
{x$DEFINE TB2K_USE_STRICT_O2K_MENU_STYLE}
  { Enabling the above define forces it to use clBtnFace for the menu color
    instead of clMenu, and disables the use of flat menu borders on Windows
    XP with themes enabled. }

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  {$IFDEF CLR} TB2OleMarshal, {$ENDIF}
  StdCtrls, CommCtrl, Menus, ActnList, ImgList, TB2Anim,
  Winskindata,Winskindlg,winskinform;

type
  TTBCustomItem = class;
  TTBCustomItemClass = class of TTBCustomItem;
  TTBCustomItemActionLink = class;
  TTBCustomItemActionLinkClass = class of TTBCustomItemActionLink;
  TTBItemViewer = class;
  TTBItemViewerClass = class of TTBItemViewer;
  TTBPopupWindow = class;
  TTBPopupWindowClass = class of TTBPopupWindow;
  TTBView = class;

  TTBDoneAction = (tbdaNone, tbdaCancel, tbdaClickItem, tbdaOpenSystemMenu,
    tbdaHelpContext);
  TTBDoneActionData = record
    DoneAction: TTBDoneAction;
    { tbdaClickItem-specific fields: }
    ClickItem: TTBCustomItem;
    Sound: Boolean;
    { tbdaOpenSystemMenu-specific fields: }
    Wnd: HWND;
    Key: Cardinal;
    { tbdaHelpContext-specific fields: }
    ContextID: Integer;
  end;
  TTBInsertItemProc = procedure(AParent: TComponent; AItem: TTBCustomItem) of object;
  TTBItemChangedAction = (tbicInserted, tbicDeleting, tbicSubitemsChanged,
    tbicSubitemsBeginUpdate, tbicSubitemsEndUpdate, tbicInvalidate,
    tbicInvalidateAndResize, tbicRecreateItemViewers, tbicNameChanged,
    tbicSubMenuImagesChanged);
  TTBItemChangedProc = procedure(Sender: TTBCustomItem; Relayed: Boolean;
    Action: TTBItemChangedAction; Index: Integer; Item: TTBCustomItem) of object;
  TTBItemDisplayMode = (nbdmDefault, nbdmTextOnly, nbdmTextOnlyInMenus, nbdmImageAndText);
  TTBItemOption = (tboDefault, tboDropdownArrow, tboImageAboveCaption,
    tboLongHintInMenuOnly, tboNoAutoHint, tboNoRotation, tboSameWidth,
    tboShowHint, tboToolbarStyle, tboToolbarSize);
  TTBItemOptions = set of TTBItemOption;
  TTBItemStyle = set of (tbisSubmenu, tbisSelectable, tbisSeparator,
    tbisEmbeddedGroup, tbisClicksTransparent, tbisCombo, tbisNoAutoOpen,
    tbisSubitemsEditable, tbisNoLineBreak, tbisRightAlign, tbisDontSelectFirst,
    tbisRedrawOnSelChange, tbisRedrawOnMouseOverChange);
  TTBPopupAlignment = (tbpaLeft, tbpaRight, tbpaCenter);
  TTBPopupEvent = procedure(Sender: TTBCustomItem; FromLink: Boolean) of object;
  TTBSelectEvent = procedure(Sender: TTBCustomItem; Viewer: TTBItemViewer;
    Selecting: Boolean) of object;

  ETBItemError = class(Exception);

  TTBImageChangeLink = class(TChangeLink)
  private
    FLastWidth, FLastHeight: Integer;
  end;
  {$IFNDEF JR_D5}
  TImageIndex = type Integer;
  {$ENDIF}

  TTBCustomItem = class(TComponent)
  private
    FActionLink: TTBCustomItemActionLink;
    FAutoCheck: Boolean;
    FCaption: String;
    FChecked: Boolean;
    FDisplayMode: TTBItemDisplayMode;
    FEnabled: Boolean;
    FEffectiveOptions: TTBItemOptions;
    FGroupIndex: Integer;
    FHelpContext: THelpContext;
    FHint: String;
    FImageIndex: TImageIndex;
    FImages: TCustomImageList;
    FImagesChangeLink: TTBImageChangeLink;
    FItems: TList;
    FItemStyle: TTBItemStyle;
    FLinkParents: TList;
    FMaskOptions: TTBItemOptions;
    FOptions: TTBItemOptions;
    FInheritOptions: Boolean;
    FNotifyList: TList;
    FOnClick: TNotifyEvent;
    FOnPopup: TTBPopupEvent;
    FOnSelect: TTBSelectEvent;
    FParent: TTBCustomItem;
    FParentComponent: TComponent;
    FRadioItem: Boolean;
    FShortCut: TShortCut;
    FSubMenuImages: TCustomImageList;
    FSubMenuImagesChangeLink: TTBImageChangeLink;
    FLinkSubitems: TTBCustomItem;
    FVisible: Boolean;

    procedure DoActionChange(Sender: TObject);
    function ChangeImages(var AImages: TCustomImageList;
      const Value: TCustomImageList; var AChangeLink: TTBImageChangeLink): Boolean;
    class procedure ClickWndProc(var Message: TMessage); {$IFDEF CLR} static; {$ENDIF}
    function FindItemWithShortCut(AShortCut: TShortCut;
      var ATopmostParent: TTBCustomItem): TTBCustomItem;
    function FixOptions(const AOptions: TTBItemOptions): TTBItemOptions;
    function GetAction: TBasicAction;
    function GetCount: Integer;
    function GetItem(Index: Integer): TTBCustomItem;
    procedure ImageListChangeHandler(Sender: TObject);
    procedure InternalNotify(Ancestor: TTBCustomItem; NestingLevel: Integer;
      Action: TTBItemChangedAction; Index: Integer; Item: TTBCustomItem);
    {$IFDEF JR_D6}
    function IsAutoCheckStored: Boolean;
    {$ENDIF}
    function IsCaptionStored: Boolean;
    function IsCheckedStored: Boolean;
    function IsEnabledStored: Boolean;
    function IsHelpContextStored: Boolean;
    function IsHintStored: Boolean;
    function IsImageIndexStored: Boolean;
    function IsOnClickStored: Boolean;
    function IsShortCutStored: Boolean;
    function IsVisibleStored: Boolean;
    procedure Notify(Action: TTBItemChangedAction; Index: Integer; Item: TTBCustomItem);
    procedure RefreshOptions;
    procedure SetAction(Value: TBasicAction);
    procedure SetCaption(Value: String);
    procedure SetChecked(Value: Boolean);
    procedure SetDisplayMode(Value: TTBItemDisplayMode);
    procedure SetEnabled(Value: Boolean);
    procedure SetGroupIndex(Value: Integer);
    procedure SetImageIndex(Value: TImageIndex);
    procedure SetImages(Value: TCustomImageList);
    procedure SetInheritOptions(Value: Boolean);
    procedure SetLinkSubitems(Value: TTBCustomItem);
    procedure SetMaskOptions(Value: TTBItemOptions);
    procedure SetOptions(Value: TTBItemOptions);
    procedure SetRadioItem(Value: Boolean);
    procedure SetSubMenuImages(Value: TCustomImageList);
    procedure SetVisible(Value: Boolean);
    procedure SubMenuImagesChanged;
    procedure TurnSiblingsOff;
  protected
    procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); dynamic;
    procedure Change(NeedResize: Boolean); virtual;
    function CreatePopup(const ParentView: TTBView; const ParentViewer: TTBItemViewer;
      const PositionAsSubmenu, SelectFirstItem, Customizing: Boolean;
      const APopupPoint: TPoint; const Alignment: TTBPopupAlignment): TTBPopupWindow; virtual;
    procedure DoPopup(Sender: TTBCustomItem; FromLink: Boolean); virtual;
    procedure EnabledChanged; virtual;
    function GetActionLinkClass: TTBCustomItemActionLinkClass; dynamic;
    function GetChevronParentView: TTBView; virtual;
    procedure GetChildren(Proc: TGetChildProc; Root: TComponent); override;
    function GetItemViewerClass(AView: TTBView): TTBItemViewerClass; virtual;
    function GetPopupWindowClass: TTBPopupWindowClass; virtual;
    class procedure IndexError;
    procedure Loaded; override;
    function NeedToRecreateViewer(AViewer: TTBItemViewer): Boolean; virtual;
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
    function OpenPopup(const SelectFirstItem, TrackRightButton: Boolean;
      const PopupPoint: TPoint; const Alignment: TTBPopupAlignment;
      const ReturnClickedItemOnly: Boolean): TTBCustomItem;
    procedure RecreateItemViewers;
    procedure SetChildOrder(Child: TComponent; Order: Integer); override;
    procedure SetName(const NewName: TComponentName); override;
    {$IFNDEF CLR}
    procedure SetParentComponent(Value: TComponent); override;
    {$ENDIF}

    property ActionLink: TTBCustomItemActionLink read FActionLink write FActionLink;
    property ItemStyle: TTBItemStyle read FItemStyle write FItemStyle;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    function HasParent: Boolean; override;
    function GetParentComponent: TComponent; override;

    procedure Add(AItem: TTBCustomItem);
    procedure Clear;
    procedure Click; virtual;
    function ContainsItem(AItem: TTBCustomItem): Boolean;
    procedure Delete(Index: Integer);
    function GetItemStyle: TTBItemStyle;
    function GetShortCutText: String;
    function IndexOf(AItem: TTBCustomItem): Integer;
    procedure InitiateAction; virtual;
    procedure Insert(NewIndex: Integer; AItem: TTBCustomItem);
    function IsShortCut(var Message: TWMKey): Boolean;
    procedure Move(CurIndex, NewIndex: Integer);
    function Popup(X, Y: Integer; TrackRightButton: Boolean;
      Alignment: TTBPopupAlignment = tbpaLeft;
      ReturnClickedItemOnly: Boolean = False): TTBCustomItem;
    procedure PostClick;
    procedure RegisterNotification(ANotify: TTBItemChangedProc);
    procedure Remove(Item: TTBCustomItem);
    {$IFDEF CLR}
    procedure SetParentComponent(Value: TComponent); override;
    {$ENDIF}
    procedure UnregisterNotification(ANotify: TTBItemChangedProc);
    procedure ViewBeginUpdate;
    procedure ViewEndUpdate;

    property Action: TBasicAction read GetAction write SetAction;
    property AutoCheck: Boolean read FAutoCheck write FAutoCheck {$IFDEF JR_D6} stored IsAutoCheckStored {$ENDIF} default False;
    property Caption: String read FCaption write SetCaption stored IsCaptionStored;
    property Count: Integer read GetCount;
    property Checked: Boolean read FChecked write SetChecked stored IsCheckedStored default False;
    property DisplayMode: TTBItemDisplayMode read FDisplayMode write SetDisplayMode default nbdmDefault;
    property EffectiveOptions: TTBItemOptions read FEffectiveOptions;
    property Enabled: Boolean read FEnabled write SetEnabled stored IsEnabledStored default True;
    property GroupIndex: Integer read FGroupIndex write SetGroupIndex default 0;
    property HelpContext: THelpContext read FHelpContext write FHelpContext stored IsHelpContextStored default 0;
    property Hint: String read FHint write FHint stored IsHintStored;
    property ImageIndex: TImageIndex read FImageIndex write SetImageIndex stored IsImageIndexStored default -1;
    property Images: TCustomImageList read FImages write SetImages;
    property InheritOptions: Boolean read FInheritOptions write SetInheritOptions default True;
    property Items[Index: Integer]: TTBCustomItem read GetItem; default;
    property LinkSubitems: TTBCustomItem read FLinkSubitems write SetLinkSubitems;
    property MaskOptions: TTBItemOptions read FMaskOptions write SetMaskOptions default [];
    property Options: TTBItemOptions read FOptions write SetOptions default [];
    property Parent: TTBCustomItem read FParent;
    property ParentComponent: TComponent read FParentComponent write FParentComponent;
    property RadioItem: Boolean read FRadioItem write SetRadioItem default False;
    property ShortCut: TShortCut read FShortCut write FShortCut stored IsShortCutStored default 0;
    property SubMenuImages: TCustomImageList read FSubMenuImages write SetSubMenuImages;
    property Visible: Boolean read FVisible write SetVisible stored IsVisibleStored default True;
    property OnClick: TNotifyEvent read FOnClick write FOnClick stored IsOnClickStored;
    property OnPopup: TTBPopupEvent read FOnPopup write FOnPopup;
    property OnSelect: TTBSelectEvent read FOnSelect write FOnSelect;
  end;

  TTBCustomItemActionLink = class(TActionLink)
  protected
    FClient: TTBCustomItem;
    procedure AssignClient(AClient: TObject); override;
    {$IFDEF JR_D6}
    function IsAutoCheckLinked: Boolean; virtual;
    {$ENDIF}
    function IsCaptionLinked: Boolean; override;
    function IsCheckedLinked: Boolean; override;
    function IsEnabledLinked: Boolean; override;
    function IsHelpContextLinked: Boolean; override;
    function IsHintLinked: Boolean; override;
    function IsImageIndexLinked: Boolean; override;
    function IsShortCutLinked: Boolean; override;
    function IsVisibleLinked: Boolean; override;
    function IsOnExecuteLinked: Boolean; override;
    {$IFDEF JR_D6}
    procedure SetAutoCheck(Value: Boolean); override;
    {$ENDIF}
    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 SetShortCut(Value: TShortCut); override;
    procedure SetVisible(Value: Boolean); override;
    procedure SetOnExecute(Value: TNotifyEvent); override;
  end;

  {$IFNDEF CLR}
  TTBBaseAccObject = class(TInterfacedObject, IDispatch)
  {$ELSE}
  TTBBaseAccObject = class(TTBStandardOleMarshalObject)
  {$ENDIF}
  public
    procedure ClientIsDestroying; virtual; abstract;
    {$IFNDEF CLR}
    { IDispatch }
    function GetTypeInfoCount(out Count: Integer): HResult; stdcall;
    function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult; stdcall;
    function GetIDsOfNames(const IID: TGUID; Names: Pointer;
      NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; stdcall;
    function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
      Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; stdcall;
    {$ENDIF}
  end;

  TTBItemViewer = class
  private
    FBoundsRect: TRect;
    FClipped: Boolean;
    FGroupLevel: Integer;
    FItem: TTBCustomItem;
    FOffEdge: Boolean;
    FShow: Boolean;
    FView: TTBView;
    procedure AccSelect(const AExecute: Boolean);
    function GetIndex: Integer;
  protected
    FAccObjectInstance: TTBBaseAccObject;
    procedure CalcSize(const Canvas: TCanvas; var AWidth, AHeight: Integer);
      virtual;
    function CaptionShown: Boolean; dynamic;
    function DoExecute: Boolean; virtual;
    procedure DrawItemCaption(const Canvas: TCanvas; ARect: TRect;
      const ACaption: String; ADrawDisabledShadow: Boolean; AFormat: UINT); virtual;
    procedure Entering; virtual;
    function GetAccRole: Integer; virtual;
    function GetAccValue(var Value: WideString): Boolean; virtual;
    function GetCaptionText: String; virtual;
    procedure GetCursor(const Pt: TPoint; var ACursor: HCURSOR); virtual;
    function GetImageList: TCustomImageList;
    function ImageShown: Boolean;
    function IsRotated: Boolean;
    function IsToolbarSize: Boolean;
    function IsPtInButtonPart(X, Y: Integer): Boolean; virtual;
    procedure KeyDown(var Key: Word; Shift: TShiftState); virtual;
    procedure Leaving; virtual;
    procedure LosingCapture; virtual;
    procedure MouseDown(Shift: TShiftState; X, Y: Integer;
      var MouseDownOnMenu: Boolean); virtual;
    procedure MouseMove(X, Y: Integer); virtual;
    procedure MouseUp(X, Y: Integer; MouseWasDownOnMenu: Boolean); virtual;
    procedure MouseWheel(WheelDelta: Integer; X, Y: Integer); virtual;
    procedure Paint(const Canvas: TCanvas; const ClientAreaRect: TRect;
      IsSelected, IsPushed, UseDisabledShadow: Boolean); virtual;
    procedure PostAccSelect(const AExecute: Boolean);
    function UsesSameWidth: Boolean; virtual;
  public
    State: set of (tbisInvalidated, tbisLineSep);
    property BoundsRect: TRect read FBoundsRect;
    property Clipped: Boolean read FClipped;
    property Index: Integer read GetIndex;
    property Item: TTBCustomItem read FItem;
    property OffEdge: Boolean read FOffEdge;
    property Show: Boolean read FShow;
    property View: TTBView read FView;
    constructor Create(AView: TTBView; AItem: TTBCustomItem; AGroupLevel: Integer); virtual;
    destructor Destroy; override;
    procedure Execute(AGivePriority: Boolean);
    function GetAccObject: TTBBaseAccObject;
    function GetHintText: String;
    function IsAccessible: Boolean;
    function IsToolbarStyle: Boolean;