tb2item.pas

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

    procedure Popup(X, Y: Integer); override;
    function PopupEx(X, Y: Integer; ReturnClickedItemOnly: Boolean = False): TTBCustomItem;
  published
    property Images: TCustomImageList read GetImages write SetImages;
    property Items: TTBRootItem read FItem;
    property LinkSubitems: TTBCustomItem read GetLinkSubitems write SetLinkSubitems;
    property Options: TTBItemOptions read GetOptions write SetOptions default [];
  end;

  TTBCustomImageList = class(TImageList)
  private
    FCheckedImages: TCustomImageList;
    FCheckedImagesChangeLink: TChangeLink;
    FDisabledImages: TCustomImageList;
    FDisabledImagesChangeLink: TChangeLink;
    FHotImages: TCustomImageList;
    FHotImagesChangeLink: TChangeLink;
    FImagesBitmap: TBitmap;
    FImagesBitmapMaskColor: TColor;
    procedure ChangeImages(var AImageList: TCustomImageList;
      Value: TCustomImageList; AChangeLink: TChangeLink);
    procedure ImageListChanged(Sender: TObject);
    procedure ImagesBitmapChanged(Sender: TObject);
    procedure SetCheckedImages(Value: TCustomImageList);
    procedure SetDisabledImages(Value: TCustomImageList);
    procedure SetHotImages(Value: TCustomImageList);
    procedure SetImagesBitmap(Value: TBitmap);
    procedure SetImagesBitmapMaskColor(Value: TColor);
    {$IFDEF CLR}
    procedure WriteLeft(Writer: TWriter);
    procedure WriteTop(Writer: TWriter);
    {$ENDIF}
  protected
    procedure DefineProperties(Filer: TFiler); override;
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
    property CheckedImages: TCustomImageList read FCheckedImages write SetCheckedImages;
    property DisabledImages: TCustomImageList read FDisabledImages write SetDisabledImages;
    property HotImages: TCustomImageList read FHotImages write SetHotImages;
    property ImagesBitmap: TBitmap read FImagesBitmap write SetImagesBitmap;
    property ImagesBitmapMaskColor: TColor read FImagesBitmapMaskColor
      write SetImagesBitmapMaskColor default clFuchsia;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure DrawState(Canvas: TCanvas; X, Y, Index: Integer;
      Enabled, Selected, Checked: Boolean); virtual;
  end;

  TTBImageList = class(TTBCustomImageList)
  published
    property CheckedImages;
    property DisabledImages;
    property HotImages;
    property ImagesBitmap;
    property ImagesBitmapMaskColor;
  end;

const
  {$IFNDEF TB2K_USE_STRICT_O2K_MENU_STYLE}
  tbMenuBkColor = clMenu;
  tbMenuTextColor = clMenuText;
  {$ELSE}
  tbMenuBkColor = clBtnFace;
  tbMenuTextColor = clBtnText;
  {$ENDIF}

  tbMenuVerticalMargin = 4;
  tbMenuImageTextSpace = 1;
  tbMenuLeftTextMargin = 2;
  tbMenuRightTextMargin = 3;

  tbMenuSeparatorOffset = 12;

  tbMenuScrollArrowHeight = 19;

  tbDropdownArrowWidth = 8;
  tbDropdownArrowMargin = 3;
  tbDropdownComboArrowWidth = 11;
  tbDropdownComboMargin = 2;

  tbLineSpacing = 6;
  tbLineSepOffset = 1;
  tbDockedLineSepOffset = 4;

  WM_TB2K_CLICKITEM = WM_USER + $100;

function TBGetItems(const AObject: TObject): TTBCustomItem;
procedure TBInitToolbarSystemFont;

var
  ToolbarFont: TFont;


implementation

uses
  {$IFDEF CLR} System.Threading, Types, WinUtils, {$ENDIF}
  MMSYSTEM, TB2Consts, TB2Common, IMM, TB2Acc;

{$UNDEF ALLOCHWND_CLASSES}
{$IFNDEF CLR}
  {$IFDEF JR_D6}
    {$DEFINE ALLOCHWND_CLASSES}
  {$ENDIF}
{$ENDIF}

var
  LastPos: TPoint;

threadvar
  ClickWndRefCount: Integer;
  ClickWnd: HWND;
  ClickList: TList;

type
  TTBModalHandler = class
  private
    FCreatedWnd: Boolean;
    FInited: Boolean;
    FWnd: HWND;
    FRootPopup: TTBPopupWindow;
    procedure WndProc(var Msg: TMessage);
  public
    constructor Create(AExistingWnd: HWND);
    destructor Destroy; override;
    procedure Loop(const RootView: TTBView; const AMouseDown, AExecuteSelected,
      AFromMSAA, TrackRightButton: Boolean);
    property RootPopup: TTBPopupWindow read FRootPopup write FRootPopup;
    property Wnd: HWND read FWnd;
  end;

  TItemChangedNotificationData = class
  private
    Proc: TTBItemChangedProc;
    RefCount: Integer;
  end;

  {$IFNDEF CLR}
  TComponentAccess = class(TComponent);
  TControlAccess = class(TControl);
  {$ENDIF}

const
  ViewTimerBaseID = 9000;
  MaxGroupLevel = 10;


{ Misc. }

function TBGetItems(const AObject: TObject): TTBCustomItem;
{ If AObject is an item, returns AObject, otherwise finds the root item
  associated with AObject. If AObject is not a TTBCustomItem and does not
  implement the ITBItems interface, nil is returned. }
var
  Intf: ITBItems;
begin
  if AObject is TTBCustomItem then
    Result := TTBCustomItem(AObject)
  else begin
    {$IFNDEF CLR}
    if AObject.GetInterface(ITBItems, Intf) then
    {$ELSE}
    Intf := ITBItems(AObject);
    if Assigned(Intf) then
    {$ENDIF}
      Result := Intf.GetItems
    else
      Result := nil;
  end;
end;

procedure DestroyClickWnd;
begin
  if ClickWnd <> 0 then begin
    {$IFDEF ALLOCHWND_CLASSES}Classes.{$ENDIF} DeallocateHWnd(ClickWnd);
    ClickWnd := 0;
  end;
  FreeAndNil(ClickList);
end;

procedure ReferenceClickWnd;
begin
  Inc(ClickWndRefCount);
end;

procedure ReleaseClickWnd;
begin
  Dec(ClickWndRefCount);
  if ClickWndRefCount = 0 then
    DestroyClickWnd;
end;

procedure QueueClick(const AItem: TObject; const AArg: Integer);
{ Adds an item to ClickList and posts a message to handle it. AItem must be
  either a TTBCustomItem or TTBItemViewer. }
var
  I: Integer;
begin
  if ClickWnd = 0 then
    ClickWnd := {$IFDEF ALLOCHWND_CLASSES}Classes.{$ENDIF} AllocateHWnd(TTBCustomItem.ClickWndProc);
  if ClickList = nil then
    ClickList := TList.Create;

  { Add a new item to ClickList or replace an empty one }
  I := ClickList.IndexOf(nil);
  if I = -1 then
    I := ClickList.Add(AItem)
  else
    ClickList[I] := AItem;

  PostMessage(ClickWnd, WM_TB2K_CLICKITEM, AArg, I);
end;

procedure RemoveFromClickList(const AItem: TObject);
{ Any class that potentially calls QueueClick needs to call RemoveFromClickList
  before an instance is destroyed to ensure that any references to the
  instance still in ClickList are removed. }
var
  I: Integer;
begin
  if Assigned(ClickList) and Assigned(AItem) then
    for I := 0 to ClickList.Count-1 do
      if ClickList[I] = AItem then
        ClickList[I] := ClickList;
        { ^ The special value of ClickList is assigned to the item instead of
          of nil because we want the index to stay reserved until the
          WM_TB2K_CLICKITEM message for the index is processed. We don't want
          the WM_TB2K_CLICKITEM message that's still in the queue to later
          refer to a different item; this would result in queued clicks being
          processed in the wrong order in a case like this:
            A.PostClick; B.PostClick; A.Free; C.PostClick;
          C's click would end up being processed before A's, because C would
          get A's index. }
end;

function ProcessDoneAction(const DoneActionData: TTBDoneActionData;
  const ReturnClickedItemOnly: Boolean): TTBCustomItem;
begin
  Result := nil;
  case DoneActionData.DoneAction of
    tbdaNone: ;
    tbdaClickItem: begin
        if DoneActionData.Sound and NeedToPlaySound('MenuCommand') then
          PlaySound('MenuCommand', 0, SND_ALIAS or SND_ASYNC or SND_NODEFAULT or SND_NOSTOP);
        Result := DoneActionData.ClickItem;
        if not ReturnClickedItemOnly then
          Result.PostClick;
      end;
    tbdaOpenSystemMenu: begin
        SendMessage(DoneActionData.Wnd, WM_SYSCOMMAND, SC_KEYMENU, DoneActionData.Key);
      end;
    tbdaHelpContext: begin
        { Based on code in TPopupList.WndProc: }
        if Assigned(Screen.ActiveForm) and
           (biHelp in Screen.ActiveForm.BorderIcons) then
          Application.HelpCommand(HELP_CONTEXTPOPUP, DoneActionData.ContextID)
        else
          Application.HelpContext(DoneActionData.ContextID);
      end;
  end;
end;


{ TTBCustomItemActionLink }

procedure TTBCustomItemActionLink.AssignClient(AClient: TObject);
begin
  FClient := AClient as TTBCustomItem;
end;

{$IFDEF JR_D6}
function TTBCustomItemActionLink.IsAutoCheckLinked: Boolean;
begin
  Result := (FClient.AutoCheck = (Action as TCustomAction).AutoCheck);
end;
{$ENDIF}

function TTBCustomItemActionLink.IsCaptionLinked: Boolean;
begin
  Result := inherited IsCaptionLinked and
    (FClient.Caption = (Action as TCustomAction).Caption);
end;

function TTBCustomItemActionLink.IsCheckedLinked: Boolean;
begin
  Result := inherited IsCheckedLinked and
    (FClient.Checked = (Action as TCustomAction).Checked);
end;

function TTBCustomItemActionLink.IsEnabledLinked: Boolean;
begin
  Result := inherited IsEnabledLinked and
    (FClient.Enabled = (Action as TCustomAction).Enabled);
end;

function TTBCustomItemActionLink.IsHelpContextLinked: Boolean;
begin
  Result := inherited IsHelpContextLinked and
    (FClient.HelpContext = (Action as TCustomAction).HelpContext);
end;

function TTBCustomItemActionLink.IsHintLinked: Boolean;
begin
  Result := inherited IsHintLinked and
    (FClient.Hint = (Action as TCustomAction).Hint);
end;

function TTBCustomItemActionLink.IsImageIndexLinked: Boolean;
begin
  Result := inherited IsImageIndexLinked and
    (FClient.ImageIndex = (Action as TCustomAction).ImageIndex);
end;

function TTBCustomItemActionLink.IsShortCutLinked: Boolean;
begin
  Result := inherited IsShortCutLinked and
    (FClient.ShortCut = (Action as TCustomAction).ShortCut);
end;

function TTBCustomItemActionLink.IsVisibleLinked: Boolean;
begin
  Result := inherited IsVisibleLinked and
    (FClient.Visible = (Action as TCustomAction).Visible);
end;

function TTBCustomItemActionLink.IsOnExecuteLinked: Boolean;
begin
  Result := inherited IsOnExecuteLinked and
    {$IFNDEF CLR}
    MethodsEqual(TMethod(FClient.OnClick), TMethod(Action.OnExecute));
    {$ELSE}
    (@FClient.OnClick = @Action.OnExecute);
    {$ENDIF}
end;

{$IFDEF JR_D6}
procedure TTBCustomItemActionLink.SetAutoCheck(Value: Boolean);
begin
  if IsAutoCheckLinked then FClient.AutoCheck := Value;
end;
{$ENDIF}

procedure TTBCustomItemActionLink.SetCaption(const Value: string);
begin
  if IsCaptionLinked then FClient.Caption := Value;
end;

procedure TTBCustomItemActionLink.SetChecked(Value: Boolean);
begin
  if IsCheckedLinked then FClient.Checked := Value;
end;

procedure TTBCustomItemActionLink.SetEnabled(Value: Boolean);
begin
  if IsEnabledLinked then FClient.Enabled := Value;
end;

procedure TTBCustomItemActionLink.SetHelpContext(Value: THelpContext);
begin
  if IsHelpContextLinked then FClient.HelpContext := Value;
end;

procedure TTBCustomItemActionLink.SetHint(const Value: string);
begin
  if IsHintLinked then FClient.Hint := Value;
end;

procedure TTBCustomItemActionLink.SetImageIndex(Value: Integer);
begin
  if IsImageIndexLinked then FClient.ImageIndex := Value;
end;

procedure TTBCustomItemActionLink.SetShortCut(Value: TShortCut);