unit TB2Item; {$MODE Delphi} { Toolbar2000 Copyright (C) 1998-2008 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.313 2008/09/19 16:35:48 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 LCLIntf, LCLType, LMessages, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, {$IFDEF CLR} TB2OleMarshal, {$ENDIF} StdCtrls, CommCtrl, Menus, ActnList, ImgList, TB2Anim; 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: Word; { 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; function ScreenToClient(const P: TPoint): TPoint; end; TTBViewOrientation = (tbvoHorizontal, tbvoVertical, tbvoFloating); TTBEnterToolbarLoopOptions = set of (tbetMouseDown, tbetExecuteSelected, tbetFromMSAA); TTBViewState = set of (vsModal, vsMouseInWindow, vsDrawInOrder, vsOppositePopup, vsIgnoreFirstMouseUp, vsShowAccels, vsDropDownMenus, vsNoAnimation); TTBViewStyle = set of (vsMenuBar, vsUseHiddenAccels, vsAlwaysShowHints); TTBViewTimerID = (tiOpen, tiClose, tiScrollUp, tiScrollDown); TTBViewClass = class of TTBView; TTBView = class(TComponent) private FViewers: TList; { at front to minimize code size } FActiveTimers: set of TTBViewTimerID; FBackgroundColor: TColor; FBaseSize: TPoint; FCapture: Boolean; FCaptureWnd: HWND; FChevronOffset: Integer; FChevronParentView: TTBView; FChevronSize: Integer; FCurParentItem: TTBCustomItem; FCustomizing: Boolean; FDoneActionData: TTBDoneActionData; FInternalViewersAtEnd: Integer; FInternalViewersAtFront: Integer; FIsPopup: Boolean; FIsToolbar: Boolean; FMaxHeight: Integer; FMonitorRect: TRect; FMouseOverSelected: Boolean; FNewViewersGetHighestPriority: Boolean; FOpenViewer: TTBItemViewer; FOpenViewerView: TTBView; FOpenViewerWindow: TTBPopupWindow; FParentView: TTBView; FParentItem: TTBCustomItem; FPriorityList: TList; FOrientation: TTBViewOrientation; FScrollOffset: Integer; FSelected: TTBItemViewer; FSelectedViaMouse: Boolean; FShowDownArrow: Boolean; FShowUpArrow: Boolean; FState: TTBViewState; FStyle: TTBViewStyle; FUpdating: Integer; FUsePriorityList: Boolean; FValidated: Boolean; FWindow: TWinControl; FWrapOffset: Integer; procedure DeletingViewer(Viewer: TTBItemViewer); procedure DrawItem(Viewer: TTBItemViewer; DrawTo: TCanvas; Offscreen: Boolean); procedure FreeViewers; function GetViewer(Index: Integer): TTBItemViewer; function GetViewerCount: Integer; {$IFDEF JR_D9} inline; {$ENDIF} procedure ImagesChanged; function InsertItemViewers(const NewIndex: Integer; const AItem: TTBCustomItem; const AGroupLevel: Integer; const AddToPriorityList, TopOfPriorityList: Boolean): Integer; procedure ItemNotification(Ancestor: TTBCustomItem; Relayed: Boolean; Action: TTBItemChangedAction; Index: Integer; Item: TTBCustomItem); procedure LinkNotification(Ancestor: TTBCustomItem; Relayed: Boolean; Action: TTBItemChangedAction; Index: Integer; Item: TTBCustomItem); procedure RecreateItemViewer(const I: Integer); procedure Scroll(ADown: Boolean); procedure SetCustomizing(Value: Boolean); procedure SetSelected(Value: TTBItemViewer); procedure SetUsePriorityList(Value: Boolean); procedure StartTimer(const ATimer: TTBViewTimerID; const Interval: Integer); procedure StopAllTimers; procedure StopTimer(const ATimer: TTBViewTimerID); procedure UpdateCurParentItem; protected FAccObjectInstance: TTBBaseAccObject; procedure AutoSize(AWidth, AHeight: Integer); virtual; function CalculatePositions(const CanMoveControls: Boolean; const AOrientation: TTBViewOrientation; AWrapOffset, AChevronOffset, AChevronSize: Integer; var ABaseSize, TotalSize: TPoint; var AWrappedLines: Integer): Boolean; procedure DoUpdatePositions(var ASize: TPoint); virtual; function GetChevronItem: TTBCustomItem; virtual; procedure GetMargins(AOrientation: TTBViewOrientation; var Margins: TRect); virtual; function GetMDIButtonsItem: TTBCustomItem; virtual; function GetMDISystemMenuItem: TTBCustomItem; virtual; function GetParentToolbarView: TTBView; function GetRootView: TTBView; function HandleWMGetObject(var Message: TMessage): Boolean; procedure InitiateActions; procedure KeyDown(var Key: Word; Shift: TShiftState); virtual; procedure Notification(AComponent: TComponent; Operation: TOperation); override; procedure SetAccelsVisibility(AShowAccels: Boolean); public constructor Create(AOwner: TComponent; AParentView: TTBView; AParentItem: TTBCustomItem; AWindow: TWinControl; AIsToolbar, ACustomizing, AUsePriorityList: Boolean); reintroduce; virtual; destructor Destroy; override; procedure BeginUpdate; procedure CancelCapture; procedure CancelChildPopups; procedure CancelMode; procedure CloseChildPopups; function ContainsView(AView: TTBView): Boolean; procedure DrawSubitems(ACanvas: TCanvas); procedure EndModal; procedure EndModalWithClick(AViewer: TTBItemViewer); procedure EndModalWithHelp(AContextID: Integer); procedure EndModalWithSystemMenu(AWnd: HWND; AKey: Word); procedure EndUpdate; procedure EnterToolbarLoop(Options: TTBEnterToolbarLoopOptions); procedure ExecuteSelected(AGivePriority: Boolean); function Find(Item: TTBCustomItem): TTBItemViewer; function FirstSelectable: TTBItemViewer; function GetAccObject: TTBBaseAccObject; function GetCaptureWnd: HWND; function GetFont: TFont; virtual; procedure GetOffEdgeControlList(const List: TList); procedure GivePriority(AViewer: TTBItemViewer); procedure HandleHintShowMessage(var Message: TCMHintShow); function HighestPriorityViewer: TTBItemViewer; procedure Invalidate(AViewer: TTBItemViewer); procedure InvalidatePositions; virtual; function IndexOf(AViewer: TTBItemViewer): Integer; function IsModalEnding: Boolean; function NextSelectable(CurViewer: TTBItemViewer; GoForward: Boolean): TTBItemViewer; function NextSelectableWithAccel(CurViewer: TTBItemViewer; Key: Char; RequirePrimaryAccel: Boolean; var IsOnlyItemWithAccel: Boolean): TTBItemViewer; procedure NotifyFocusEvent; function OpenChildPopup(const SelectFirstItem: Boolean): Boolean; procedure RecreateAllViewers; procedure ScrollSelectedIntoView; procedure Select(Value: TTBItemViewer; ViaMouse: Boolean); procedure SetCapture; procedure TryValidatePositions; procedure UpdateSelection(const P: TPoint; const AllowNewSelection: Boolean); function UpdatePositions: TPoint; procedure ValidatePositions; function ViewerFromPoint(const P: TPoint): TTBItemViewer; property BackgroundColor: TColor read FBackgroundColor write FBackgroundColor; property BaseSize: TPoint read FBaseSize; property Capture: Boolean read FCapture; property ChevronOffset: Integer read FChevronOffset write FChevronOffset; property ChevronSize: Integer read FChevronSize write FChevronSize; property Customizing: Boolean read FCustomizing write SetCustomizing; property IsPopup: Boolean read FIsPopup; property IsToolbar: Boolean read FIsToolbar; property MouseOverSelected: Boolean read FMouseOverSelected; property NewViewersGetHighestPriority: Boolean read FNewViewersGetHighestPriority write FNewViewersGetHighestPriority; property ParentView: TTBView read FParentView; property ParentItem: TTBCustomItem read FParentItem; property OpenViewer: TTBItemViewer read FOpenViewer; property OpenViewerView: TTBView read FOpenViewerView; property Orientation: TTBViewOrientation read FOrientation write FOrientation; property Selected: TTBItemViewer read FSelected write SetSelected; property SelectedViaMouse: Boolean read FSelectedViaMouse; property State: TTBViewState read FState; property Style: TTBViewStyle read FStyle write FStyle; property UsePriorityList: Boolean read FUsePriorityList write SetUsePriorityList; property Viewers[Index: Integer]: TTBItemViewer read GetViewer; property ViewerCount: Integer read GetViewerCount; property Window: TWinControl read FWindow; property WrapOffset: Integer read FWrapOffset write FWrapOffset; end; TTBRootItemClass = class of TTBRootItem; TTBRootItem = class(TTBCustomItem); { same as TTBCustomItem, except there's a property editor for it } TTBItem = class(TTBCustomItem) published property Action; property AutoCheck; property Caption; property Checked; property DisplayMode; property Enabled; property GroupIndex; property HelpContext; property Hint; property ImageIndex; property Images; property InheritOptions; property MaskOptions; property Options; property RadioItem; property ShortCut; property Visible; property OnClick; property OnSelect; end; TTBGroupItem = class(TTBCustomItem) public constructor Create(AOwner: TComponent); override; published property InheritOptions; property LinkSubitems; property MaskOptions; property Options; end; TTBSubmenuItem = class(TTBCustomItem) private function GetDropdownCombo: Boolean; procedure SetDropdownCombo(Value: Boolean); public constructor Create(AOwner: TComponent); override; published property Action; property AutoCheck; property Caption; property Checked; //property DisplayAsToolbar; property DisplayMode; property DropdownCombo: Boolean read GetDropdownCombo write SetDropdownCombo default False; property Enabled; property GroupIndex; property HelpContext; property Hint; property ImageIndex; property Images; property InheritOptions; property LinkSubitems; property MaskOptions; property Options; property RadioItem; property ShortCut; property SubMenuImages; property Visible; property OnClick; property OnPopup; property OnSelect; end; TTBSeparatorItem = class(TTBCustomItem) private FBlank: Boolean; procedure SetBlank(Value: Boolean); protected function GetItemViewerClass(AView: TTBView): TTBItemViewerClass; override; public constructor Create(AOwner: TComponent); override; published property Blank: Boolean read FBlank write SetBlank default False; property Hint; property Visible; end; TTBSeparatorItemViewer = class(TTBItemViewer) protected procedure CalcSize(const Canvas: TCanvas; var AWidth, AHeight: Integer); override; procedure Paint(const Canvas: TCanvas; const ClientAreaRect: TRect; IsSelected, IsPushed, UseDisabledShadow: Boolean); override; function UsesSameWidth: Boolean; override; end; TTBControlItem = class(TTBCustomItem) private FControl: TControl; FDontFreeControl: Boolean; procedure SetControl(Value: TControl); protected procedure Notification(AComponent: TComponent; Operation: TOperation); override; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; property DontFreeControl: Boolean read FDontFreeControl write FDontFreeControl; published property Control: TControl read FControl write SetControl; end; TTBPopupView = class(TTBView) protected procedure AutoSize(AWidth, AHeight: Integer); override; public function GetFont: TFont; override; end; ITBPopupWindow = interface ['{E45CBE74-1ECF-44CB-B064-6D45B1924708}'] end; TTBPopupWindow = class(TCustomControl, ITBPopupWindow) private FAccelsVisibilitySet: Boolean; FAnimationDirection: TTBAnimationDirection; FView: TTBView; procedure CMHintShow(var Message: TCMHintShow); message CM_HINTSHOW; procedure CMShowingChanged(var Message: TMessage); message CM_SHOWINGCHANGED; procedure WMClose(var Message: TWMClose); message WM_CLOSE; procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND; procedure WMGetObject(var Message: TMessage); message WM_GETOBJECT; procedure WMNCCalcSize(var Message: TWMNCCalcSize); message WM_NCCALCSIZE; procedure WMNCPaint(var Message: TMessage); message WM_NCPAINT; procedure WMPaint(var Message: TWMPaint); message WM_PAINT; procedure WMPrint(var Message: TMessage); message WM_PRINT; procedure WMPrintClient(var Message: {$IFNDEF CLR} TMessage {$ELSE} TWMPrintClient {$ENDIF}); message WM_PRINTCLIENT; protected procedure CreateParams(var Params: TCreateParams); override; procedure CreateWnd; override; procedure DestroyWindowHandle; override; function GetViewClass: TTBViewClass; dynamic; procedure Paint; override; procedure PaintScrollArrows; virtual; public constructor CreatePopupWindow(AOwner: TComponent; const AParentView: TTBView; const AItem: TTBCustomItem; const ACustomizing: Boolean); virtual; destructor Destroy; override; property View: TTBView read FView; end; ITBItems = interface ['{A5C0D7CC-3EC4-4090-A0F8-3D03271877EA}'] function GetItems: TTBCustomItem; end; TTBItemContainer = class(TComponent, ITBItems) private FItem: TTBRootItem; function GetImages: TCustomImageList; function GetItems: TTBCustomItem; procedure SetImages(Value: TCustomImageList); protected procedure GetChildren(Proc: TGetChildProc; Root: TComponent); override; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; property Items: TTBRootItem read FItem; published property Images: TCustomImageList read GetImages write SetImages; end; TTBPopupMenu = class(TPopupMenu, ITBItems) private FItem: TTBRootItem; //procedure SetItems(Value: TTBCustomItem); function GetImages: TCustomImageList; function GetItems: TTBCustomItem; function GetLinkSubitems: TTBCustomItem; function GetOptions: TTBItemOptions; procedure RootItemClick(Sender: TObject); procedure SetImages(Value: TCustomImageList); procedure SetLinkSubitems(Value: TTBCustomItem); procedure SetOptions(Value: TTBItemOptions); protected {$IFNDEF JR_D5} procedure DoPopup(Sender: TObject); {$ENDIF} function GetRootItemClass: TTBRootItemClass; dynamic; procedure SetChildOrder(Child: TComponent; Order: Integer); override; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; procedure GetChildren(Proc: TGetChildProc; Root: TComponent); override; function IsShortCut(var Message: TWMKey): Boolean; override; 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.Runtime.InteropServices, System.Text, System.Threading, Types, WinUtils, {$ENDIF} 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; FSaveFocusWnd: HWND; 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 PlaySystemSound('MenuCommand'); 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); begin if IsShortCutLinked then FClient.ShortCut := Value; end; procedure TTBCustomItemActionLink.SetVisible(Value: Boolean); begin if IsVisibleLinked then FClient.Visible := Value; end; procedure TTBCustomItemActionLink.SetOnExecute(Value: TNotifyEvent); begin if IsOnExecuteLinked then FClient.OnClick := Value; end; { TTBCustomItem } {}function ItemContainingItems(const AItem: TTBCustomItem): TTBCustomItem; begin if Assigned(AItem) and Assigned(AItem.FLinkSubitems) then Result := AItem.FLinkSubitems else Result := AItem; end; constructor TTBCustomItem.Create(AOwner: TComponent); begin inherited; FEnabled := True; FImageIndex := -1; FInheritOptions := True; FItemStyle := [tbisSelectable, tbisRedrawOnSelChange, tbisRedrawOnMouseOverChange]; FVisible := True; ReferenceClickWnd; end; destructor TTBCustomItem.Destroy; var I: Integer; begin Destroying; RemoveFromClickList(Self); { Changed in 0.33. Moved FParent.Remove call *after* the child items are deleted. } for I := Count-1 downto 0 do Items[I].Free; if Assigned(FParent) then FParent.Remove(Self); FreeAndNil(FItems); FActionLink.Free; FActionLink := nil; FreeAndNil(FSubMenuImagesChangeLink); FreeAndNil(FImagesChangeLink); inherited; if Assigned(FNotifyList) then begin for I := FNotifyList.Count-1 downto 0 do TItemChangedNotificationData(FNotifyList[I]).Free; FNotifyList.Free; end; FLinkParents.Free; ReleaseClickWnd; end; {$IFDEF JR_D6} function TTBCustomItem.IsAutoCheckStored: Boolean; begin Result := (ActionLink = nil) or not FActionLink.IsAutoCheckLinked; end; {$ENDIF} function TTBCustomItem.IsCaptionStored: Boolean; begin Result := (ActionLink = nil) or not FActionLink.IsCaptionLinked; end; function TTBCustomItem.IsCheckedStored: Boolean; begin Result := (ActionLink = nil) or not FActionLink.IsCheckedLinked; end; function TTBCustomItem.IsEnabledStored: Boolean; begin Result := (ActionLink = nil) or not FActionLink.IsEnabledLinked; end; function TTBCustomItem.IsHintStored: Boolean; begin Result := (ActionLink = nil) or not FActionLink.IsHintLinked; end; function TTBCustomItem.IsHelpContextStored: Boolean; begin Result := (ActionLink = nil) or not FActionLink.IsHelpContextLinked; end; function TTBCustomItem.IsImageIndexStored: Boolean; begin Result := (ActionLink = nil) or not FActionLink.IsImageIndexLinked; end; function TTBCustomItem.IsShortCutStored: Boolean; begin Result := (ActionLink = nil) or not FActionLink.IsShortCutLinked; end; function TTBCustomItem.IsVisibleStored: Boolean; begin Result := (ActionLink = nil) or not FActionLink.IsVisibleLinked; end; function TTBCustomItem.IsOnClickStored: Boolean; begin Result := (ActionLink = nil) or not FActionLink.IsOnExecuteLinked; end; function TTBCustomItem.GetAction: TBasicAction; begin if FActionLink <> nil then Result := FActionLink.Action else Result := nil; end; function TTBCustomItem.GetActionLinkClass: TTBCustomItemActionLinkClass; begin Result := TTBCustomItemActionLink; end; procedure TTBCustomItem.DoActionChange(Sender: TObject); begin if Sender = Action then ActionChange(Sender, False); end; procedure TTBCustomItem.ActionChange(Sender: TObject; CheckDefaults: Boolean); begin if Action is TCustomAction then with TCustomAction(Sender) do begin {$IFDEF JR_D6} if not CheckDefaults or (Self.AutoCheck = False) then Self.AutoCheck := AutoCheck; {$ENDIF} if not CheckDefaults or (Self.Caption = '') then Self.Caption := Caption; if not CheckDefaults or (Self.Checked = False) then Self.Checked := Checked; if not CheckDefaults or (Self.Enabled = True) then Self.Enabled := Enabled; if not CheckDefaults or (Self.HelpContext = 0) then Self.HelpContext := HelpContext; if not CheckDefaults or (Self.Hint = '') then Self.Hint := Hint; if not CheckDefaults or (Self.ImageIndex = -1) then Self.ImageIndex := ImageIndex; if not CheckDefaults or (Self.ShortCut = scNone) then Self.ShortCut := ShortCut; if not CheckDefaults or (Self.Visible = True) then Self.Visible := Visible; if not CheckDefaults or not Assigned(Self.OnClick) then Self.OnClick := OnExecute; end; end; procedure TTBCustomItem.SetAction(Value: TBasicAction); begin if Value = nil then begin FActionLink.Free; FActionLink := nil; end else begin if FActionLink = nil then FActionLink := GetActionLinkClass.Create(Self); FActionLink.Action := Value; FActionLink.OnChange := DoActionChange; { Note: Delphi's Controls.pas and Menus.pas merely check for "csLoading in Value.ComponentState" here. But that doesn't help when the Action property references an action on another form / data module that has already finished loading. So we check two things: 1. csLoading in Value.ComponentState 2. csLoading in ComponentState In the typical case where the item and action list reside on the same form, #1 and #2 are both true. Only #1 is true when Action references an action on another form / data module that is created *after* the item (e.g. if Form1.TBItem1.Action = Form2.Action1, and Form1 is created before Form2). Only #2 is true when Action references an action on another form / data module that is created *before* the item (e.g. if Form2.TBItem1.Action = Form1.Action1, and Form1 is created before Form2). } ActionChange(Value, (csLoading in Value.ComponentState) or (csLoading in ComponentState)); Value.FreeNotification(Self); end; end; procedure TTBCustomItem.InitiateAction; begin if FActionLink <> nil then FActionLink.Update; end; procedure TTBCustomItem.Loaded; begin inherited; if Action <> nil then ActionChange(Action, True); end; procedure TTBCustomItem.GetChildren(Proc: TGetChildProc; Root: TComponent); var I: Integer; begin for I := 0 to Count-1 do Proc(Items[I]); end; procedure TTBCustomItem.SetChildOrder(Child: TComponent; Order: Integer); var I: Integer; begin I := IndexOf(Child as TTBCustomItem); if I <> -1 then Move(I, Order); end; function TTBCustomItem.HasParent: Boolean; begin Result := True; end; function TTBCustomItem.GetParentComponent: TComponent; begin if (FParent <> nil) and (FParent.FParentComponent <> nil) then Result := FParent.FParentComponent else Result := FParent; end; procedure TTBCustomItem.SetName(const NewName: TComponentName); begin if Name <> NewName then begin inherited; if Assigned(FParent) then FParent.Notify(tbicNameChanged, -1, Self); end; end; procedure TTBCustomItem.SetParentComponent(Value: TComponent); var RootItem: TTBCustomItem; begin if FParent <> nil then FParent.Remove(Self); if Value <> nil then begin RootItem := TBGetItems(Value); if Assigned(RootItem) then RootItem.Add(Self) else raise ETBItemError.CreateFmt(STBToolbarItemParentInvalid, [Value.ClassName]); end; end; procedure TTBCustomItem.Notification(AComponent: TComponent; Operation: TOperation); begin inherited; if Operation = opRemove then begin RemoveFromList(FLinkParents, AComponent); if AComponent = Action then Action := nil; if AComponent = Images then Images := nil; if AComponent = SubMenuImages then SubMenuImages := nil; if AComponent = LinkSubitems then LinkSubitems := nil; end; end; class procedure TTBCustomItem.IndexError; begin raise ETBItemError.Create(STBToolbarIndexOutOfBounds); end; class procedure TTBCustomItem.ClickWndProc(var Message: TMessage); var List: TList; I: Integer; Item: TObject; begin if Message.Msg = WM_TB2K_CLICKITEM then begin List := ClickList; { optimization... } if Assigned(List) then begin I := ClipToLongint(Message.LParam); if (I >= 0) and (I < List.Count) then begin Item := List[I]; List[I] := nil; { If the item value is set to ClickList, then it was 'removed' from the list by RemoveFromClickList } if Item = List then Item := nil; end else Item := nil; { Remove trailing nil items from ClickList. This is not *necessary*, but it will make RemoveFromClickList faster if we clean out items that aren't used, and may never be used again. } for I := List.Count-1 downto 0 do begin if List[I] = nil then List.Delete(I) else Break; end; if Assigned(Item) then begin try if Item is TTBCustomItem then TTBCustomItem(Item).Click else if Item is TTBItemViewer then TTBItemViewer(Item).AccSelect(Message.WParam <> 0); except Application.HandleException(Item); end; end; end; end else with Message do Result := DefWindowProc(ClickWnd, Msg, wParam, lParam); end; procedure TTBCustomItem.PostClick; { Posts a message to the message queue that causes the item's Click handler to be executed when control is returned to the message loop. This should be called instead of Click when a WM_SYSCOMMAND message is (possibly) currently being handled, because TApplication.WndProc's CM_APPSYSCOMMAND handler disables the VCL's processing of focus messages until the Perform(WM_SYSCOMMAND, ...) call returns. (An OnClick handler which calls TForm.ShowModal needs focus messages to be enabled or else the form will be shown with no initial focus.) } begin QueueClick(Self, 0); end; procedure TTBCustomItem.Click; begin if Enabled then begin { Following code based on D6's TMenuItem.Click } {$IFDEF JR_D6} if (not Assigned(ActionLink) and AutoCheck) or (Assigned(ActionLink) and not ActionLink.IsAutoCheckLinked and AutoCheck) then {$ELSE} if AutoCheck then {$ENDIF} Checked := not Checked; { Following code based on D4's TControl.Click } { Call OnClick if assigned and not equal to associated action's OnExecute. If associated action's OnExecute assigned then call it, otherwise, call OnClick. } if Assigned(FOnClick) and (Action <> nil) and {$IFNDEF CLR} not MethodsEqual(TMethod(FOnClick), TMethod(Action.OnExecute)) then {$ELSE} (@FOnClick <> @Action.OnExecute) then {$ENDIF} FOnClick(Self) else if not(csDesigning in ComponentState) and (ActionLink <> nil) then ActionLink.Execute {$IFDEF JR_D6}(Self){$ENDIF} else if Assigned(FOnClick) then FOnClick(Self); end; end; function TTBCustomItem.GetCount: Integer; begin if FItems = nil then Result := 0 else Result := FItems.Count; end; function TTBCustomItem.GetItem(Index: Integer): TTBCustomItem; begin if (FItems = nil) or (Index < 0) or (Index >= FItems.Count) then begin IndexError; Result := nil; Exit; end; Result := TTBCustomItem(FItems.List[Index]); end; procedure TTBCustomItem.Add(AItem: TTBCustomItem); begin Insert(Count, AItem); end; procedure TTBCustomItem.InternalNotify(Ancestor: TTBCustomItem; NestingLevel: Integer; Action: TTBItemChangedAction; Index: Integer; Item: TTBCustomItem); { Note: Ancestor is Item's parent, or in the case of a group item relayed notification, it can also be a group item which *links* to Item's parent (i.e. ItemContainingItems(Ancestor) = Item.Parent). } procedure RelayToParentOf(const AItem: TTBCustomItem); begin if NestingLevel > MaxGroupLevel then Exit; if (tbisEmbeddedGroup in AItem.ItemStyle) and Assigned(AItem.Parent) then begin if Ancestor = Self then AItem.Parent.InternalNotify(AItem, NestingLevel + 1, Action, Index, Item) else { Don't alter Ancestor on subsequent relays; only on the first. } AItem.Parent.InternalNotify(Ancestor, NestingLevel + 1, Action, Index, Item); end; end; var I: Integer; P: TTBCustomItem; SaveProc: TTBItemChangedProc; begin { If Self is a group item, relay the notification to the parent } RelayToParentOf(Self); { If any group items are linked to Self, relay the notification to those items' parents } if Assigned(FLinkParents) then for I := 0 to FLinkParents.Count-1 do begin P := TTBCustomItem(FLinkParents[I]); if P <> Parent then RelayToParentOf(P); end; if Assigned(FNotifyList) then begin I := 0; while I < FNotifyList.Count do begin with TItemChangedNotificationData(FNotifyList[I]) do begin SaveProc := Proc; Proc(Ancestor, Ancestor <> Self, Action, Index, Item); end; { Is I now out of bounds? } if I >= FNotifyList.Count then Break; { Only proceed to the next index if the list didn't change } {$IFNDEF CLR} if MethodsEqual(TMethod(TItemChangedNotificationData(FNotifyList[I]).Proc), TMethod(SaveProc)) then {$ELSE} if @TItemChangedNotificationData(FNotifyList[I]).Proc = @SaveProc then {$ENDIF} Inc(I); end; end; end; procedure TTBCustomItem.Notify(Action: TTBItemChangedAction; Index: Integer; Item: TTBCustomItem); begin InternalNotify(Self, 0, Action, Index, Item); end; procedure TTBCustomItem.ViewBeginUpdate; begin Notify(tbicSubitemsBeginUpdate, -1, nil); end; procedure TTBCustomItem.ViewEndUpdate; begin Notify(tbicSubitemsEndUpdate, -1, nil); end; procedure TTBCustomItem.Insert(NewIndex: Integer; AItem: TTBCustomItem); begin if Assigned(AItem.FParent) then raise ETBItemError.Create(STBToolbarItemReinserted); if (NewIndex < 0) or (NewIndex > Count) then IndexError; if FItems = nil then FItems := TList.Create; FItems.Insert(NewIndex, AItem); AItem.FParent := Self; ViewBeginUpdate; try Notify(tbicInserted, NewIndex, AItem); AItem.RefreshOptions; finally ViewEndUpdate; end; end; procedure TTBCustomItem.Delete(Index: Integer); var Item: TTBCustomItem; begin Item := Items[Index]; { will raise exception if out of range } Notify(tbicDeleting, Index, Item); Item.FParent := nil; FItems.Delete(Index); end; function TTBCustomItem.IndexOf(AItem: TTBCustomItem): Integer; var I: Integer; begin for I := 0 to Count-1 do if FItems.List[I] = AItem then begin Result := I; Exit; end; Result := -1; end; procedure TTBCustomItem.Remove(Item: TTBCustomItem); var I: Integer; begin I := IndexOf(Item); //if I = -1 then raise ETBItemError.Create(STBToolbarItemNotFound); if I <> -1 then Delete(I); end; procedure TTBCustomItem.Clear; var I: Integer; begin for I := Count-1 downto 0 do Items[I].Free; end; procedure TTBCustomItem.Move(CurIndex, NewIndex: Integer); var Item: TTBCustomItem; begin if CurIndex <> NewIndex then begin if (NewIndex < 0) or (NewIndex >= Count) then IndexError; Item := Items[CurIndex]; ViewBeginUpdate; try Delete(CurIndex); Insert(NewIndex, Item); finally ViewEndUpdate; end; end; end; function TTBCustomItem.ContainsItem(AItem: TTBCustomItem): Boolean; begin while Assigned(AItem) and (AItem <> Self) do AItem := AItem.Parent; Result := Assigned(AItem); end; procedure TTBCustomItem.RegisterNotification(ANotify: TTBItemChangedProc); var I: Integer; Data: TItemChangedNotificationData; begin if FNotifyList = nil then FNotifyList := TList.Create; for I := 0 to FNotifyList.Count-1 do with TItemChangedNotificationData(FNotifyList[I]) do {$IFNDEF CLR} if MethodsEqual(TMethod(ANotify), TMethod(Proc)) then begin {$ELSE} if @ANotify = @Proc then begin {$ENDIF} Inc(RefCount); Exit; end; FNotifyList.Expand; Data := TItemChangedNotificationData.Create; Data.Proc := ANotify; Data.RefCount := 1; FNotifyList.Add(Data); end; procedure TTBCustomItem.UnregisterNotification(ANotify: TTBItemChangedProc); var I: Integer; Data: TItemChangedNotificationData; begin if Assigned(FNotifyList) then for I := 0 to FNotifyList.Count-1 do begin Data := TItemChangedNotificationData(FNotifyList[I]); {$IFNDEF CLR} if MethodsEqual(TMethod(Data.Proc), TMethod(ANotify)) then begin {$ELSE} if @Data.Proc = @ANotify then begin {$ENDIF} Dec(Data.RefCount); if Data.RefCount = 0 then begin FNotifyList.Delete(I); Data.Free; if FNotifyList.Count = 0 then FreeAndNil(FNotifyList); end; Break; end; end; end; function TTBCustomItem.GetPopupWindowClass: TTBPopupWindowClass; begin Result := TTBPopupWindow; end; procedure TTBCustomItem.DoPopup(Sender: TTBCustomItem; FromLink: Boolean); begin if Assigned(FOnPopup) then FOnPopup(Sender, FromLink); if not(tbisCombo in ItemStyle) then Click; end; var PlayedSound: Boolean = False; function TTBCustomItem.CreatePopup(const ParentView: TTBView; const ParentViewer: TTBItemViewer; const PositionAsSubmenu, SelectFirstItem, Customizing: Boolean; const APopupPoint: TPoint; const Alignment: TTBPopupAlignment): TTBPopupWindow; function CountObscured(X, Y, W, H: Integer): Integer; var I: Integer; P: TPoint; V: TTBItemViewer; begin Result := 0; if ParentView = nil then Exit; P := ParentView.FWindow.ClientToScreen(Point(0, 0)); Dec(X, P.X); Dec(Y, P.Y); Inc(W, X); Inc(H, Y); for I := 0 to ParentView.FViewers.Count-1 do begin V := ParentView.Viewers[I]; if V.Show and (V.BoundsRect.Left >= X) and (V.BoundsRect.Right <= W) and (V.BoundsRect.Top >= Y) and (V.BoundsRect.Bottom <= H) then Inc(Result); end; end; var EventItem, ParentItem: TTBCustomItem; Opposite: Boolean; ChevronParentView: TTBView; X, X2, Y, Y2, W, H: Integer; P: TPoint; RepeatCalcX: Boolean; ParentItemRect: TRect; MonitorRect: TRect; AnimDir: TTBAnimationDirection; begin EventItem := ItemContainingItems(Self); if EventItem <> Self then EventItem.DoPopup(Self, True); DoPopup(Self, False); ChevronParentView := GetChevronParentView; if ChevronParentView = nil then ParentItem := Self else ParentItem := ChevronParentView.FParentItem; Opposite := Assigned(ParentView) and (vsOppositePopup in ParentView.FState); Result := GetPopupWindowClass.CreatePopupWindow(nil, ParentView, ParentItem, Customizing); try if Assigned(ChevronParentView) then begin ChevronParentView.FreeNotification(Result.View); Result.View.FChevronParentView := ChevronParentView; Result.View.FIsToolbar := True; Result.View.Style := Result.View.Style + (ChevronParentView.Style * [vsAlwaysShowHints]); Result.Color := clBtnFace; end; { Calculate ParentItemRect, and MonitorRect (the rectangle of the monitor that the popup window will be confined to) } if Assigned(ParentView) then begin ParentView.ValidatePositions; ParentItemRect := ParentViewer.BoundsRect; P := ParentView.FWindow.ClientToScreen(Point(0, 0)); OffsetRect(ParentItemRect, P.X, P.Y); if not IsRectEmpty(ParentView.FMonitorRect) then MonitorRect := ParentView.FMonitorRect else MonitorRect := GetRectOfMonitorContainingRect(ParentItemRect, False); end else begin ParentItemRect.TopLeft := APopupPoint; ParentItemRect.BottomRight := APopupPoint; MonitorRect := GetRectOfMonitorContainingPoint(APopupPoint, False); end; Result.View.FMonitorRect := MonitorRect; { Initialize item positions and size of the popup window } if ChevronParentView = nil then Result.View.FMaxHeight := (MonitorRect.Bottom - MonitorRect.Top) - (PopupMenuWindowNCSize * 2) else Result.View.WrapOffset := (MonitorRect.Right - MonitorRect.Left) - (PopupMenuWindowNCSize * 2); if SelectFirstItem then Result.View.Selected := Result.View.FirstSelectable; Result.View.UpdatePositions; W := Result.Width; H := Result.Height; { Calculate initial X,Y position of the popup window } if Assigned(ParentView) then begin if not PositionAsSubmenu then begin if ChevronParentView = nil then begin if (ParentView = nil) or (ParentView.FOrientation <> tbvoVertical) then begin if GetSystemMetrics(SM_MENUDROPALIGNMENT) = 0 then X := ParentItemRect.Left else X := ParentItemRect.Right - W; Y := ParentItemRect.Bottom; end else begin X := ParentItemRect.Left - W; Y := ParentItemRect.Top; end; end else begin if ChevronParentView.FOrientation <> tbvoVertical then begin X := ParentItemRect.Right - W; Y := ParentItemRect.Bottom; end else begin X := ParentItemRect.Left - W; Y := ParentItemRect.Top; end; end; end else begin X := ParentItemRect.Right - PopupMenuWindowNCSize; Y := ParentItemRect.Top - PopupMenuWindowNCSize; end; end else begin X := APopupPoint.X; Y := APopupPoint.Y; case Alignment of tbpaRight: Dec(X, W); tbpaCenter: Dec(X, W div 2); end; end; { Adjust the Y position of the popup window } { If the window is going off the bottom of the monitor, try placing it above the parent item } if (Y + H > MonitorRect.Bottom) and ((ParentView = nil) or (ParentView.FOrientation <> tbvoVertical)) then begin if not PositionAsSubmenu then Y2 := ParentItemRect.Top else Y2 := ParentItemRect.Bottom + PopupMenuWindowNCSize; Dec(Y2, H); { Only place it above the parent item if it isn't going to go off the top of the monitor } if Y2 >= MonitorRect.Top then Y := Y2; end; { If it's still going off the bottom (which can be possible if a menu bar was off the screen to begin with), clip it to the bottom of the monitor } if Y + H > MonitorRect.Bottom then Y := MonitorRect.Bottom - H; if Y < MonitorRect.Top then Y := MonitorRect.Top; { Other adjustments to the position of the popup window } if not PositionAsSubmenu then begin if (ParentView = nil) and (Alignment = tbpaRight) and (X < MonitorRect.Left) then Inc(X, W); if X + W > MonitorRect.Right then begin if Assigned(ParentView) or (Alignment <> tbpaLeft) then X := MonitorRect.Right; Dec(X, W); end; if X < MonitorRect.Left then X := MonitorRect.Left; if (ParentView = nil) or (ParentView.FOrientation <> tbvoVertical) then begin Y2 := ParentItemRect.Top - H; if Y2 >= MonitorRect.Top then begin { Would the popup window obscure less items if it popped out to the top instead? } if (CountObscured(X, Y2, W, H) < CountObscured(X, Y, W, H)) or ((Y < ParentItemRect.Bottom) and (Y + H > ParentItemRect.Top) and (X < ParentItemRect.Right) and (X + W > ParentItemRect.Left)) then Y := Y2; end; { Make sure a tall popup window doesn't overlap the parent item } if (Y < ParentItemRect.Bottom) and (Y + H > ParentItemRect.Top) and (X < ParentItemRect.Right) and (X + W > ParentItemRect.Left) then begin if ParentItemRect.Right + W <= MonitorRect.Right then X := ParentItemRect.Right else X := ParentItemRect.Left - W; if X < MonitorRect.Top then X := MonitorRect.Top; end; end else begin X2 := ParentItemRect.Right; if X2 + W <= MonitorRect.Right then begin { Would the popup window obscure less items if it popped out to the right instead? } if (CountObscured(X2, Y, W, H) < CountObscured(X, Y, W, H)) or ((Y < ParentItemRect.Bottom) and (Y + H > ParentItemRect.Top) and (X < ParentItemRect.Right) and (X + W > ParentItemRect.Left)) then X := X2; end; { Make sure a wide popup window doesn't overlap the parent item } if (Y < ParentItemRect.Bottom) and (Y + H > ParentItemRect.Top) and (X < ParentItemRect.Right) and (X + W > ParentItemRect.Left) then begin if ParentItemRect.Bottom + H <= MonitorRect.Bottom then Y := ParentItemRect.Bottom else Y := ParentItemRect.Top - H; if Y < MonitorRect.Top then Y := MonitorRect.Top; end; end; end else begin { Make nested submenus go from left to right on the screen. Each it runs out of space on the screen, switch directions } repeat RepeatCalcX := False; X2 := X; if Opposite or (X2 + W > MonitorRect.Right) then begin if Assigned(ParentView) then X2 := ParentItemRect.Left + PopupMenuWindowNCSize; Dec(X2, W); if not Opposite then Include(Result.View.FState, vsOppositePopup) else begin if X2 < MonitorRect.Left then begin Opposite := False; RepeatCalcX := True; end else Include(Result.View.FState, vsOppositePopup); end; end; until not RepeatCalcX; X := X2; if X < MonitorRect.Left then X := MonitorRect.Left; end; { Determine animation direction } AnimDir := []; if not PositionAsSubmenu then begin if Y >= ParentItemRect.Bottom then Include(AnimDir, tbadDown) else if Y + H <= ParentItemRect.Top then Include(AnimDir, tbadUp); if X >= ParentItemRect.Right then Include(AnimDir, tbadRight) else if X + W <= ParentItemRect.Left then Include(AnimDir, tbadLeft); end else begin if X + W div 2 >= ParentItemRect.Left + (ParentItemRect.Right - ParentItemRect.Left) div 2 then Include(AnimDir, tbadRight) else Include(AnimDir, tbadLeft); end; Result.FAnimationDirection := AnimDir; Result.SetBounds(X, Y, W, H); if Assigned(ParentView) then begin Result.FreeNotification(ParentView); ParentView.FOpenViewerWindow := Result; ParentView.FOpenViewerView := Result.View; ParentView.FOpenViewer := ParentViewer; if ParentView.FIsToolbar then begin Include(ParentView.FState, vsDropDownMenus); ParentView.Invalidate(ParentViewer); ParentView.FWindow.Update; end; end; Include(Result.View.FState, vsDrawInOrder); if not NeedToPlaySound('MenuPopup') then begin { Don't call PlaySound if we don't have to } Result.Visible := True; end else begin if not PlayedSound then begin { Work around Windows 2000 "bug" where there's a 1/3 second delay upon the first call to PlaySound (or sndPlaySound) by painting the window completely first. This way the delay isn't very noticable. } PlayedSound := True; Result.Visible := True; Result.Update; PlaySystemSound('MenuPopup'); end else begin PlaySystemSound('MenuPopup'); Result.Visible := True; end; end; CallNotifyWinEvent(EVENT_SYSTEM_MENUPOPUPSTART, Result.View.FWindow.Handle, OBJID_CLIENT, CHILDID_SELF); { Call NotifyFocusEvent now that the window is visible } if Assigned(Result.View.Selected) then Result.View.NotifyFocusEvent; except Result.Free; raise; end; end; function TTBCustomItem.OpenPopup(const SelectFirstItem, TrackRightButton: Boolean; const PopupPoint: TPoint; const Alignment: TTBPopupAlignment; const ReturnClickedItemOnly: Boolean): TTBCustomItem; var ModalHandler: TTBModalHandler; Popup: TTBPopupWindow; DoneActionData: TTBDoneActionData; begin ModalHandler := TTBModalHandler.Create(0); try Popup := CreatePopup(nil, nil, False, SelectFirstItem, False, PopupPoint, Alignment); try Include(Popup.View.FState, vsIgnoreFirstMouseUp); ModalHandler.RootPopup := Popup; ModalHandler.Loop(Popup.View, False, False, False, TrackRightButton); DoneActionData := Popup.View.FDoneActionData; finally ModalHandler.RootPopup := nil; { Remove vsModal state from the root view before any TTBView.Destroy methods get called, so that NotifyFocusEvent becomes a no-op } Exclude(Popup.View.FState, vsModal); Popup.Free; end; finally ModalHandler.Free; end; Result := ProcessDoneAction(DoneActionData, ReturnClickedItemOnly); end; function TTBCustomItem.Popup(X, Y: Integer; TrackRightButton: Boolean; Alignment: TTBPopupAlignment = tbpaLeft; ReturnClickedItemOnly: Boolean = False): TTBCustomItem; var P: TPoint; begin P.X := X; P.Y := Y; Result := OpenPopup(False, TrackRightButton, P, Alignment, ReturnClickedItemOnly); end; function TTBCustomItem.FindItemWithShortCut(AShortCut: TShortCut; var ATopmostParent: TTBCustomItem): TTBCustomItem; function DoItem(AParentItem: TTBCustomItem; LinkDepth: Integer): TTBCustomItem; var I: Integer; NewParentItem, Item: TTBCustomItem; begin Result := nil; NewParentItem := AParentItem; if Assigned(NewParentItem.LinkSubitems) then begin NewParentItem := NewParentItem.LinkSubitems; Inc(LinkDepth); if LinkDepth > 25 then Exit; { prevent infinite link recursion } end; for I := 0 to NewParentItem.Count-1 do begin Item := NewParentItem.Items[I]; if Item.ShortCut = AShortCut then begin Result := Item; Exit; end; Result := DoItem(Item, LinkDepth); if Assigned(Result) then begin ATopmostParent := Item; Exit; end; end; end; begin ATopmostParent := nil; Result := DoItem(Self, 0); end; function TTBCustomItem.IsShortCut(var Message: TWMKey): Boolean; var ShortCut: TShortCut; ShiftState: TShiftState; ShortCutItem, TopmostItem, Item, EventItem: TTBCustomItem; I: Integer; label StartOver; begin Result := False; ShiftState := KeyDataToShiftState(ClipToLongint(Message.KeyData)); ShortCut := Menus.ShortCut(Message.CharCode, ShiftState); StartOver: ShortCutItem := FindItemWithShortCut(ShortCut, TopmostItem); if Assigned(ShortCutItem) then begin { Send OnPopup/OnClick events to ShortCutItem's parents so that they can update the Enabled state of ShortCutItem if needed } Item := Self; repeat if not Item.Enabled then Exit; EventItem := ItemContainingItems(Item); if not(csDesigning in ComponentState) then begin for I := 0 to EventItem.Count-1 do EventItem.Items[I].InitiateAction; end; if not(tbisEmbeddedGroup in Item.ItemStyle) then begin if EventItem <> Item then begin try EventItem.DoPopup(Item, True); except Application.HandleException(Self); end; end; try Item.DoPopup(Item, False); except Application.HandleException(Self); end; end; ShortCutItem := Item.FindItemWithShortCut(ShortCut, TopmostItem); if ShortCutItem = nil then { Can no longer find the shortcut inside TopmostItem. Start over because the shortcut might have moved. } goto StartOver; Item := TopmostItem; until Item = nil; if ShortCutItem.Enabled then begin try ShortCutItem.Click; except Application.HandleException(Self); end; Result := True; end; end; end; function TTBCustomItem.GetChevronParentView: TTBView; begin Result := nil; end; function TTBCustomItem.GetItemViewerClass(AView: TTBView): TTBItemViewerClass; begin Result := TTBItemViewer; end; function TTBCustomItem.NeedToRecreateViewer(AViewer: TTBItemViewer): Boolean; begin Result := False; end; function TTBCustomItem.GetItemStyle: TTBItemStyle; begin { This public method exists for TB2DsgnItemEditor. It needs access to ItemStyle but can't access a protected member across assembly boundaries. } Result := FItemStyle; end; function TTBCustomItem.GetShortCutText: String; var P: Integer; begin P := Pos(#9, Caption); if P = 0 then begin if ShortCut <> 0 then Result := ShortCutToText(ShortCut) else Result := ''; end else Result := Copy(Caption, P+1, Maxint); end; procedure TTBCustomItem.Change(NeedResize: Boolean); const ItemChangedActions: array[Boolean] of TTBItemChangedAction = (tbicInvalidate, tbicInvalidateAndResize); begin if Assigned(FParent) then FParent.Notify(ItemChangedActions[NeedResize], -1, Self); end; procedure TTBCustomItem.RecreateItemViewers; begin if Assigned(FParent) then FParent.Notify(tbicRecreateItemViewers, -1, Self); end; procedure TTBCustomItem.ImageListChangeHandler(Sender: TObject); var Resize: Boolean; begin if Sender = FSubMenuImages then begin FSubMenuImagesChangeLink.FLastWidth := FSubMenuImages.Width; FSubMenuImagesChangeLink.FLastHeight := FSubMenuImages.Height; SubMenuImagesChanged; end else begin { Sender is FImages } Resize := False; if (FImagesChangeLink.FLastWidth <> FImages.Width) or (FImagesChangeLink.FLastHeight <> FImages.Height) then begin FImagesChangeLink.FLastWidth := FImages.Width; FImagesChangeLink.FLastHeight := FImages.Height; Resize := True; end; Change(Resize); end; end; procedure TTBCustomItem.SubMenuImagesChanged; begin Notify(tbicSubMenuImagesChanged, -1, nil); end; procedure TTBCustomItem.TurnSiblingsOff; var I: Integer; Item: TTBCustomItem; begin if (GroupIndex <> 0) and Assigned(FParent) then begin for I := 0 to FParent.Count-1 do begin Item := FParent[I]; if (Item <> Self) and (Item.GroupIndex = GroupIndex) then Item.Checked := False; end; end; end; procedure TTBCustomItem.SetCaption(Value: String); begin if FCaption <> Value then begin FCaption := Value; Change(True); end; end; procedure TTBCustomItem.SetChecked(Value: Boolean); begin if FChecked <> Value then begin FChecked := Value; Change(False); if Value then TurnSiblingsOff; end; end; procedure TTBCustomItem.SetDisplayMode(Value: TTBItemDisplayMode); begin if FDisplayMode <> Value then begin FDisplayMode := Value; Change(True); end; end; procedure TTBCustomItem.EnabledChanged; begin Change(False); end; procedure TTBCustomItem.SetEnabled(Value: Boolean); begin if FEnabled <> Value then begin FEnabled := Value; EnabledChanged; end; end; procedure TTBCustomItem.SetGroupIndex(Value: Integer); begin if FGroupIndex <> Value then begin FGroupIndex := Value; if Checked then TurnSiblingsOff; end; end; procedure TTBCustomItem.SetImageIndex(Value: TImageIndex); var HadNoImage: Boolean; begin if FImageIndex <> Value then begin HadNoImage := FImageIndex = -1; FImageIndex := Value; Change(HadNoImage xor (Value = -1)); end; end; function TTBCustomItem.ChangeImages(var AImages: TCustomImageList; const Value: TCustomImageList; var AChangeLink: TTBImageChangeLink): Boolean; { Returns True if image list was resized } var LastWidth, LastHeight: Integer; begin Result := False; LastWidth := -1; LastHeight := -1; if Assigned(AImages) then begin LastWidth := AImages.Width; LastHeight := AImages.Height; AImages.UnregisterChanges(AChangeLink); if Value = nil then begin AChangeLink.Free; AChangeLink := nil; Result := True; end; end; AImages := Value; if Assigned(Value) then begin Result := (Value.Width <> LastWidth) or (Value.Height <> LastHeight); if AChangeLink = nil then begin AChangeLink := TTBImageChangeLink.Create; AChangeLink.FLastWidth := Value.Width; AChangeLink.FLastHeight := Value.Height; AChangeLink.OnChange := ImageListChangeHandler; end; Value.RegisterChanges(AChangeLink); Value.FreeNotification(Self); end; end; procedure TTBCustomItem.SetImages(Value: TCustomImageList); begin if FImages <> Value then Change(ChangeImages(FImages, Value, FImagesChangeLink)); end; procedure TTBCustomItem.SetSubMenuImages(Value: TCustomImageList); begin if FSubMenuImages <> Value then begin ChangeImages(FSubMenuImages, Value, FSubMenuImagesChangeLink); SubMenuImagesChanged; end; end; procedure TTBCustomItem.SetInheritOptions(Value: Boolean); begin if FInheritOptions <> Value then begin FInheritOptions := Value; RefreshOptions; end; end; procedure TTBCustomItem.SetLinkSubitems(Value: TTBCustomItem); begin if Value = Self then Value := nil; if FLinkSubitems <> Value then begin if Assigned(FLinkSubitems) then RemoveFromList(FLinkSubitems.FLinkParents, Self); FLinkSubitems := Value; if Assigned(Value) then begin Value.FreeNotification(Self); AddToList(Value.FLinkParents, Self); end; Notify(tbicSubitemsChanged, -1, nil); end; end; function TTBCustomItem.FixOptions(const AOptions: TTBItemOptions): TTBItemOptions; begin Result := AOptions; if not(tboToolbarStyle in Result) then Exclude(Result, tboToolbarSize); end; procedure TTBCustomItem.RefreshOptions; const NonInheritedOptions = [tboDefault]; ChangeOptions = [tboDefault, tboDropdownArrow, tboImageAboveCaption, tboNoRotation, tboSameWidth, tboToolbarStyle, tboToolbarSize]; var OldOptions, NewOptions: TTBItemOptions; I: Integer; Item: TTBCustomItem; begin OldOptions := FEffectiveOptions; if FInheritOptions and Assigned(FParent) then NewOptions := FParent.FEffectiveOptions - NonInheritedOptions else NewOptions := []; NewOptions := FixOptions(NewOptions - FMaskOptions + FOptions); if FEffectiveOptions <> NewOptions then begin FEffectiveOptions := NewOptions; if (OldOptions * ChangeOptions) <> (NewOptions * ChangeOptions) then Change(True); for I := 0 to Count-1 do begin Item := Items[I]; if Item.FInheritOptions then Item.RefreshOptions; end; end; end; procedure TTBCustomItem.SetMaskOptions(Value: TTBItemOptions); begin if FMaskOptions <> Value then begin FMaskOptions := Value; RefreshOptions; end; end; procedure TTBCustomItem.SetOptions(Value: TTBItemOptions); begin Value := FixOptions(Value); if FOptions <> Value then begin FOptions := Value; RefreshOptions; end; end; procedure TTBCustomItem.SetRadioItem(Value: Boolean); begin if FRadioItem <> Value then begin FRadioItem := Value; Change(False); end; end; procedure TTBCustomItem.SetVisible(Value: Boolean); begin if FVisible <> Value then begin FVisible := Value; Change(True); end; end; { TTBGroupItem } constructor TTBGroupItem.Create(AOwner: TComponent); begin inherited; ItemStyle := ItemStyle + [tbisEmbeddedGroup, tbisSubitemsEditable]; end; { TTBSubmenuItem } constructor TTBSubmenuItem.Create(AOwner: TComponent); begin inherited; ItemStyle := ItemStyle + [tbisSubMenu, tbisSubitemsEditable]; end; function TTBSubmenuItem.GetDropdownCombo: Boolean; begin Result := tbisCombo in ItemStyle; end; procedure TTBSubmenuItem.SetDropdownCombo(Value: Boolean); begin if (tbisCombo in ItemStyle) <> Value then begin if Value then ItemStyle := ItemStyle + [tbisCombo] else ItemStyle := ItemStyle - [tbisCombo]; Change(True); end; end; { TTBSeparatorItem } constructor TTBSeparatorItem.Create(AOwner: TComponent); begin inherited; ItemStyle := ItemStyle - [tbisSelectable, tbisRedrawOnSelChange, tbisRedrawOnMouseOverChange] + [tbisSeparator, tbisClicksTransparent]; end; function TTBSeparatorItem.GetItemViewerClass(AView: TTBView): TTBItemViewerClass; begin Result := TTBSeparatorItemViewer; end; procedure TTBSeparatorItem.SetBlank(Value: Boolean); begin if FBlank <> Value then begin FBlank := Value; Change(False); end; end; { TTBSeparatorItemViewer } procedure TTBSeparatorItemViewer.CalcSize(const Canvas: TCanvas; var AWidth, AHeight: Integer); begin if not IsToolbarStyle then { Office 2000's menu separators have a hard-coded height of 10 } AHeight := 10 else begin AWidth := 6; AHeight := 6; end; end; procedure TTBSeparatorItemViewer.Paint(const Canvas: TCanvas; const ClientAreaRect: TRect; IsSelected, IsPushed, UseDisabledShadow: Boolean); var DC: HDC; R: TRect; ToolbarStyle, Horiz, LineSep: Boolean; begin DC := Canvas.Handle; if TTBSeparatorItem(Item).FBlank then Exit; R := ClientAreaRect; ToolbarStyle := IsToolbarStyle; Horiz := not ToolbarStyle or (View.FOrientation = tbvoVertical); LineSep := tbisLineSep in State; if LineSep then Horiz := not Horiz; if Horiz then begin R.Top := R.Bottom div 2 - 1; if not ToolbarStyle then InflateRect(R, -tbMenuSeparatorOffset, 0) else if LineSep then begin if View.FOrientation = tbvoFloating then InflateRect(R, -tbLineSepOffset, 0) else InflateRect(R, -tbDockedLineSepOffset, 0); end; DrawEdge(DC, R, EDGE_ETCHED, BF_TOP); end else begin R.Left := R.Right div 2 - 1; if LineSep then InflateRect(R, 0, -tbDockedLineSepOffset); DrawEdge(DC, R, EDGE_ETCHED, BF_LEFT); end; end; function TTBSeparatorItemViewer.UsesSameWidth: Boolean; begin Result := False; end; { TTBControlItem } constructor TTBControlItem.Create(AOwner: TComponent); begin inherited; ItemStyle := ItemStyle - [tbisSelectable] + [tbisClicksTransparent]; end; destructor TTBControlItem.Destroy; begin inherited; { Free the associated control *after* the item is completely destroyed } if not FDontFreeControl and Assigned(FControl) and not(csAncestor in FControl.ComponentState) then FControl.Free; end; procedure TTBControlItem.Notification(AComponent: TComponent; Operation: TOperation); begin inherited; if (Operation = opRemove) and (AComponent = FControl) then Control := nil; end; procedure TTBControlItem.SetControl(Value: TControl); begin if FControl <> Value then begin FControl := Value; if Assigned(Value) then Value.FreeNotification(Self); Change(True); end; end; { TTBItemViewer } constructor TTBItemViewer.Create(AView: TTBView; AItem: TTBCustomItem; AGroupLevel: Integer); begin inherited Create; FItem := AItem; FView := AView; FGroupLevel := AGroupLevel; ReferenceClickWnd; end; destructor TTBItemViewer.Destroy; begin RemoveFromClickList(Self); if Assigned(FAccObjectInstance) then begin FAccObjectInstance.ClientIsDestroying; FAccObjectInstance := nil; end; inherited; ReleaseClickWnd; end; function TTBItemViewer.GetAccObject: TTBBaseAccObject; begin if FAccObjectInstance = nil then begin if not InitializeOleAcc then begin Result := nil; Exit; end; FAccObjectInstance := TTBItemViewerAccObject.Create(Self); end; Result := FAccObjectInstance; end; procedure TTBItemViewer.AccSelect(const AExecute: Boolean); { Called by ClickWndProc when an item of type TTBItemViewer is in ClickList } var Obj: {$IFNDEF CLR} IDispatch {$ELSE} TTBBaseAccObject {$ENDIF}; begin { Ensure FAccObjectInstance is created by calling GetAccObject. Store the reference as an interface so that the object will be destroyed when we exit if it's no longer used. } Obj := GetAccObject; if Assigned(Obj) then (FAccObjectInstance as TTBItemViewerAccObject).HandleAccSelect(AExecute); end; procedure TTBItemViewer.PostAccSelect(const AExecute: Boolean); { Internally called by TTBItemViewerAccObject. Don't call directly. } begin QueueClick(Self, Ord(AExecute)); end; function TTBItemViewer.IsAccessible: Boolean; { Returns True if MSAA clients should know about the viewer, specifically if it's either shown, off-edge, or clipped (in other words, not completely invisible/inaccessible). } begin { Note: Can't simply check Item.Visible because the chevron item's Visible property is always True } Result := Show or OffEdge or Clipped; end; function TTBItemViewer.GetCaptionText: String; var P: Integer; begin Result := Item.Caption; P := Pos(#9, Result); if P <> 0 then SetLength(Result, P-1); end; function TTBItemViewer.GetHintText: String; begin Result := GetShortHint(Item.Hint); { If there is no short hint, use the caption for the hint. Like Office, strip any trailing colon or ellipsis. } if (Result = '') and not(tboNoAutoHint in Item.EffectiveOptions) and (not(tbisSubmenu in Item.ItemStyle) or (tbisCombo in Item.ItemStyle) or not CaptionShown) then Result := StripAccelChars(StripTrailingPunctuation(GetCaptionText)); { Call associated action's OnHint event handler to post-process the hint } if Assigned(Item.ActionLink) and (Item.ActionLink.Action is TCustomAction) then begin if not TCustomAction(Item.ActionLink.Action).DoHint(Result) then Result := ''; { Note: TControlActionLink.DoShowHint actually misinterprets the result of DoHint, but we get it right... } end; { Add shortcut text } if (Result <> '') and Application.HintShortCuts and (Item.ShortCut <> scNone) then Result := Format('%s (%s)', [Result, ShortCutToText(Item.ShortCut)]); end; function TTBItemViewer.CaptionShown: Boolean; begin Result := (GetCaptionText <> '') and (not IsToolbarSize or (Item.ImageIndex < 0) or (Item.DisplayMode in [nbdmTextOnly, nbdmImageAndText])) or (tboImageAboveCaption in Item.EffectiveOptions); end; function TTBItemViewer.ImageShown: Boolean; begin {}{should also return false if Images=nil (use UsedImageList?)} ImageShown := (Item.ImageIndex >= 0) and ((Item.DisplayMode in [nbdmDefault, nbdmImageAndText]) or (IsToolbarStyle and (Item.DisplayMode = nbdmTextOnlyInMenus))); end; function TTBItemViewer.GetImageList: TCustomImageList; var V: TTBView; begin Result := Item.Images; if Assigned(Result) then Exit; V := View; repeat if Assigned(V.FCurParentItem) then begin Result := V.FCurParentItem.SubMenuImages; if Assigned(Result) then Break; end; if Assigned(V.FParentItem) then begin Result := V.FParentItem.SubMenuImages; if Assigned(Result) then Break; end; V := V.FParentView; until V = nil; end; function TTBItemViewer.IsRotated: Boolean; { Returns True if the caption should be drawn with rotated (vertical) text, underneath the image } begin Result := (View.Orientation = tbvoVertical) and not (tboNoRotation in Item.EffectiveOptions) and not (tboImageAboveCaption in Item.EffectiveOptions); end; procedure TTBItemViewer.CalcSize(const Canvas: TCanvas; var AWidth, AHeight: Integer); var ToolbarStyle: Boolean; DC: HDC; TextMetrics: TTextMetric; H, LeftMargin: Integer; ImgList: TCustomImageList; S: String; RotatedFont, SaveFont: HFONT; begin ToolbarStyle := IsToolbarStyle; DC := Canvas.Handle; ImgList := GetImageList; if ToolbarStyle then begin AWidth := 6; AHeight := 6; end else begin AWidth := 0; AHeight := 0; end; if not ToolbarStyle or CaptionShown then begin if not IsRotated then begin GetTextMetrics(DC, TextMetrics); Inc(AHeight, TextMetrics.tmHeight); Inc(AWidth, GetTextWidth(DC, GetCaptionText, True)); if ToolbarStyle then Inc(AWidth, 6); end else begin { Vertical text isn't always the same size as horizontal text, so we have to select the rotated font into the DC to get an accurate size } RotatedFont := CreateRotatedFont(DC); SaveFont := SelectObject(DC, RotatedFont); GetTextMetrics(DC, TextMetrics); Inc(AWidth, TextMetrics.tmHeight); Inc(AHeight, GetTextWidth(DC, GetCaptionText, True)); if ToolbarStyle then Inc(AHeight, 6); SelectObject(DC, SaveFont); DeleteObject(RotatedFont); end; end; if ToolbarStyle and ImageShown and Assigned(ImgList) then begin if not IsRotated and not(tboImageAboveCaption in Item.EffectiveOptions) then begin Inc(AWidth, ImgList.Width + 1); if AHeight < ImgList.Height + 6 then AHeight := ImgList.Height + 6; end else begin Inc(AHeight, ImgList.Height); if AWidth < ImgList.Width + 7 then AWidth := ImgList.Width + 7; end; end; if ToolbarStyle and (tbisSubmenu in Item.ItemStyle) then begin if tbisCombo in Item.ItemStyle then Inc(AWidth, tbDropdownComboArrowWidth) else if tboDropdownArrow in Item.EffectiveOptions then begin if View.Orientation <> tbvoVertical then Inc(AWidth, tbDropdownArrowWidth) else Inc(AHeight, tbDropdownArrowWidth); end; end; if not ToolbarStyle then begin Inc(AHeight, TextMetrics.tmExternalLeading + tbMenuVerticalMargin); if Assigned(ImgList) then begin H := ImgList.Height + 3; if H > AHeight then AHeight := H; LeftMargin := MulDiv(ImgList.Width + 3, AHeight, H); end else LeftMargin := AHeight; Inc(AWidth, LeftMargin + tbMenuImageTextSpace + tbMenuLeftTextMargin + tbMenuRightTextMargin); S := Item.GetShortCutText; if S <> '' then Inc(AWidth, (AHeight - 6) + GetTextWidth(DC, S, True)); Inc(AWidth, AHeight); end; end; procedure TTBItemViewer.DrawItemCaption(const Canvas: TCanvas; ARect: TRect; const ACaption: String; ADrawDisabledShadow: Boolean; AFormat: UINT); var DC: HDC; procedure Draw; begin if not IsRotated then DrawTextStr(DC, ACaption, ARect, AFormat) else DrawRotatedText(DC, ACaption, ARect, AFormat); end; var ShadowColor, HighlightColor, SaveTextColor: DWORD; begin DC := Canvas.Handle; if not ADrawDisabledShadow then Draw else begin ShadowColor := GetSysColor(COLOR_BTNSHADOW); HighlightColor := GetSysColor(COLOR_BTNHIGHLIGHT); OffsetRect(ARect, 1, 1); SaveTextColor := SetTextColor(DC, HighlightColor); Draw; OffsetRect(ARect, -1, -1); SetTextColor(DC, ShadowColor); Draw; SetTextColor(DC, SaveTextColor); end; end; procedure TTBItemViewer.Paint(const Canvas: TCanvas; const ClientAreaRect: TRect; IsSelected, IsPushed, UseDisabledShadow: Boolean); var ShowEnabled, HasArrow: Boolean; MenuCheckWidth, MenuCheckHeight: Integer; function GetDrawTextFlags: UINT; begin Result := 0; if not AreKeyboardCuesEnabled and (vsUseHiddenAccels in View.FStyle) and not(vsShowAccels in View.FState) then Result := DT_HIDEPREFIX; end; procedure DrawSubmenuArrow; var BR: TRect; Bmp: TBitmap; procedure DrawWithColor(AColor: TColor); const ROP_DSPDxax = $00E20746; var DC: HDC; SaveTextColor, SaveBkColor: TColorRef; begin Canvas.Brush.Color := AColor; DC := Canvas.Handle; SaveTextColor := SetTextColor(DC, clWhite); SaveBkColor := SetBkColor(DC, clBlack); BitBlt(DC, BR.Left, BR.Top, MenuCheckWidth, MenuCheckHeight, Bmp.Canvas.Handle, 0, 0, ROP_DSPDxax); SetBkColor(DC, SaveBkColor); SetTextColor(DC, SaveTextColor); Canvas.Brush.Style := bsClear; end; begin Bmp := TBitmap.Create; try Bmp.Monochrome := True; Bmp.Width := MenuCheckWidth; Bmp.Height := MenuCheckHeight; BR := Rect(0, 0, MenuCheckWidth, MenuCheckHeight); DrawFrameControl(Bmp.Canvas.Handle, BR, DFC_MENU, DFCS_MENUARROW); OffsetRect(BR, ClientAreaRect.Right - MenuCheckWidth, ClientAreaRect.Top + ((ClientAreaRect.Bottom - ClientAreaRect.Top) - MenuCheckHeight) div 2); if not UseDisabledShadow then begin if ShowEnabled and (tbisCombo in Item.ItemStyle) and IsSelected then begin OffsetRect(BR, 1, 1); DrawWithColor(clBtnText); end else DrawWithColor(Canvas.Font.Color); end else begin OffsetRect(BR, 1, 1); DrawWithColor(clBtnHighlight); OffsetRect(BR, -1, -1); DrawWithColor(clBtnShadow); end; finally Bmp.Free; end; end; procedure DrawDropdownArrow(R: TRect; Rotated: Boolean); procedure DrawWithColor(AColor: TColor); var X, Y: Integer; P: array[0..2] of TPoint; begin X := (R.Left + R.Right) div 2; Y := (R.Top + R.Bottom) div 2; if not Rotated then begin Dec(Y); P[0].X := X-2; P[0].Y := Y; P[1].X := X+2; P[1].Y := Y; P[2].X := X; P[2].Y := Y+2; end else begin Dec(X); P[0].X := X; P[0].Y := Y+2; P[1].X := X; P[1].Y := Y-2; P[2].X := X-2; P[2].Y := Y; end; Canvas.Pen.Color := AColor; Canvas.Brush.Color := AColor; Canvas.Polygon(P); end; begin if not UseDisabledShadow then DrawWithColor(Canvas.Font.Color) else begin OffsetRect(R, 1, 1); DrawWithColor(clBtnHighlight); OffsetRect(R, -1, -1); DrawWithColor(clBtnShadow); end; end; function GetDitherBitmap: TBitmap; begin Result := AllocPatternBitmap(clBtnFace, clBtnHighlight); Result.HandleType := bmDDB; { needed for Win95, or else brush is solid white } end; const EdgeStyles: array[Boolean] of UINT = (BDR_RAISEDINNER, BDR_SUNKENOUTER); BlackCheckMarkPoints: array[0..6] of TPoint = ( (X: -2; Y: -2), (X: 0; Y: 0), (X: 4; Y: -4), (X: 4; Y: -3), (X: 0; Y: 1), (X: -2; Y: -1), (X: -2; Y: -2)); WhiteCheckMarkPoints: array[0..4] of TPoint = ( (X: -3; Y: -2), (X: -3; Y: -1), (X: 0; Y: 2), (X: 5; Y: -3), (X: 5; Y: -5)); var ToolbarStyle, ImageIsShown: Boolean; R, RC, RD: TRect; S: String; ImgList: TCustomImageList; I, X, Y: Integer; BlackPoints: array[0..6] of TPoint; WhitePoints: array[0..4] of TPoint; DrawTextFlags: UINT; LeftMargin: Integer; TextMetrics: TTextMetric; begin ToolbarStyle := IsToolbarStyle; ShowEnabled := Item.Enabled or View.Customizing; HasArrow := (tbisSubmenu in Item.ItemStyle) and ((tbisCombo in Item.ItemStyle) or (tboDropdownArrow in Item.EffectiveOptions)); MenuCheckWidth := GetSystemMetrics(SM_CXMENUCHECK); MenuCheckHeight := GetSystemMetrics(SM_CYMENUCHECK); ImgList := GetImageList; ImageIsShown := ImageShown and Assigned(ImgList); LeftMargin := 0; if not ToolbarStyle then begin if Assigned(ImgList) then LeftMargin := MulDiv(ImgList.Width + 3, ClientAreaRect.Bottom, ImgList.Height + 3) else LeftMargin := ClientAreaRect.Bottom; end; { Border } RC := ClientAreaRect; if ToolbarStyle then begin if HasArrow then begin if tbisCombo in Item.ItemStyle then begin Dec(RC.Right, tbDropdownComboMargin); RD := RC; Dec(RC.Right, tbDropdownComboArrowWidth - tbDropdownComboMargin); RD.Left := RC.Right; end else begin if View.Orientation <> tbvoVertical then RD := Rect(RC.Right - tbDropdownArrowWidth - tbDropdownArrowMargin, 0, RC.Right - tbDropdownArrowMargin, RC.Bottom) else RD := Rect(0, RC.Bottom - tbDropdownArrowWidth - tbDropdownArrowMargin, RC.Right, RC.Bottom - tbDropdownArrowMargin); end; end else SetRectEmpty(RD); if (IsSelected and ShowEnabled) or Item.Checked or (csDesigning in Item.ComponentState) then begin if not(tbisCombo in Item.ItemStyle) then DrawEdge(Canvas.Handle, RC, EdgeStyles[IsPushed or Item.Checked], BF_RECT) else begin DrawEdge(Canvas.Handle, RC, EdgeStyles[(IsPushed and View.FCapture) or Item.Checked], BF_RECT); if (IsSelected and ShowEnabled) or (csDesigning in Item.ComponentState) then DrawEdge(Canvas.Handle, RD, EdgeStyles[IsPushed and not View.FCapture], BF_RECT); end; end; if HasArrow then begin if not(tbisCombo in Item.ItemStyle) and IsPushed then OffsetRect(RD, 1, 1); DrawDropdownArrow(RD, not(tbisCombo in Item.ItemStyle) and (View.Orientation = tbvoVertical)); end; InflateRect(RC, -1, -1); if Item.Checked and not (IsSelected and ShowEnabled) then begin Canvas.Brush.Bitmap := GetDitherBitmap; Canvas.FillRect(RC); Canvas.Brush.Style := bsClear; end; InflateRect(RC, -1, -1); if Item.Checked or ((IsSelected and IsPushed) and (not(tbisCombo in Item.ItemStyle) or View.FCapture)) then OffsetRect(RC, 1, 1); if HasArrow and not(tbisCombo in Item.ItemStyle) then begin if View.Orientation <> tbvoVertical then Dec(RC.Right, tbDropdownArrowWidth) else Dec(RC.Bottom, tbDropdownArrowWidth); end; end else begin { On selected menu items, fill the background with the selected color. Note: This assumes the brush color was not changed from the initial value. } if IsSelected then begin R := RC; if ImageIsShown or Item.Checked then Inc(R.Left, LeftMargin + tbMenuImageTextSpace); if (tbisCombo in Item.ItemStyle) and IsSelected and ShowEnabled then Dec(R.Right, MenuCheckWidth); Canvas.FillRect(R); end; end; { Adjust brush & font } Canvas.Brush.Style := bsClear; if tboDefault in Item.EffectiveOptions then with Canvas.Font do Style := Style + [fsBold]; GetTextMetrics(Canvas.Handle, TextMetrics); { Caption } if CaptionShown then begin S := GetCaptionText; R := RC; DrawTextFlags := GetDrawTextFlags; if ToolbarStyle then begin if ImageIsShown then begin if not IsRotated and not(tboImageAboveCaption in Item.EffectiveOptions) then Inc(R.Left, ImgList.Width + 1) else Inc(R.Top, ImgList.Height + 1); end; DrawItemCaption(Canvas, R, S, UseDisabledShadow, DT_SINGLELINE or DT_CENTER or DT_VCENTER or DrawTextFlags) end else begin Inc(R.Left, LeftMargin + tbMenuImageTextSpace + tbMenuLeftTextMargin); { Like standard menus, shift the text up one pixel if the text height is 4 pixels less than the total item height. This is done so underlined characters aren't displayed too low. } if (R.Bottom - R.Top) - (TextMetrics.tmHeight + TextMetrics.tmExternalLeading) = tbMenuVerticalMargin then Dec(R.Bottom); Inc(R.Top, TextMetrics.tmExternalLeading); DrawItemCaption(Canvas, R, S, UseDisabledShadow, DT_SINGLELINE or DT_LEFT or DT_VCENTER or DrawTextFlags); end; end; { Shortcut and/or submenu arrow (menus only) } if not ToolbarStyle then begin S := Item.GetShortCutText; if S <> '' then begin R := RC; R.Left := R.Right - (R.Bottom - R.Top) - GetTextWidth(Canvas.Handle, S, True); { Like standard menus, shift the text up one pixel if the text height is 4 pixels less than the total item height. This is done so underlined characters aren't displayed too low. } if (R.Bottom - R.Top) - (TextMetrics.tmHeight + TextMetrics.tmExternalLeading) = tbMenuVerticalMargin then Dec(R.Bottom); Inc(R.Top, TextMetrics.tmExternalLeading); DrawItemCaption(Canvas, R, S, UseDisabledShadow, DT_SINGLELINE or DT_LEFT or DT_VCENTER or DT_NOPREFIX); end; if tbisSubmenu in Item.ItemStyle then begin if tbisCombo in Item.ItemStyle then begin R := RC; R.Left := R.Right - MenuCheckWidth; if IsSelected and ShowEnabled then DrawEdge(Canvas.Handle, R, BDR_SUNKENOUTER, BF_RECT or BF_MIDDLE) else begin Dec(R.Left); if not IsSelected then DrawEdge(Canvas.Handle, R, EDGE_ETCHED, BF_LEFT) else DrawEdge(Canvas.Handle, R, BDR_SUNKENOUTER, BF_LEFT); end; end; DrawSubmenuArrow; end; end; { Image, or check box } if ImageIsShown or (not ToolbarStyle and Item.Checked) then begin R := RC; if ToolbarStyle then begin if not IsRotated and not(tboImageAboveCaption in Item.EffectiveOptions) then R.Right := R.Left + ImgList.Width + 2 else R.Bottom := R.Top + ImgList.Height + 2; end else begin R.Right := R.Left + LeftMargin; if (IsSelected and ShowEnabled) or Item.Checked then DrawEdge(Canvas.Handle, R, EdgeStyles[Item.Checked], BF_RECT or BF_MIDDLE); if Item.Checked and not IsSelected then begin InflateRect(R, -1, -1); Canvas.Brush.Bitmap := GetDitherBitmap; Canvas.FillRect(R); Canvas.Brush.Style := bsClear; InflateRect(R, 1, 1); end; if Item.Checked then OffsetRect(R, 1, 1); end; if ImageIsShown then begin X := R.Left + ((R.Right - R.Left) - ImgList.Width) div 2; Y := R.Top + ((R.Bottom - R.Top) - ImgList.Height) div 2; if ImgList is TTBCustomImageList then TTBCustomImageList(ImgList).DrawState(Canvas, X, Y, Item.ImageIndex, ShowEnabled, IsSelected, Item.Checked) else ImgList.Draw(Canvas, X, Y, Item.ImageIndex, ShowEnabled); end else if not ToolbarStyle and Item.Checked then begin { Draw default check mark or radio button image when user hasn't specified their own } X := (R.Left + R.Right) div 2; Y := (R.Top + R.Bottom) div 2; if Item.RadioItem then begin Canvas.Pen.Color := clBtnText; Canvas.Brush.Color := clBtnText; Canvas.RoundRect(X-3, Y-3, X+2, Y+2, 2, 2); Canvas.Pen.Color := clBtnHighlight; Canvas.Brush.Style := bsClear; Canvas.RoundRect(X-4, Y-4, X+3, Y+3, 6, 6); end else begin Dec(X, 2); Inc(Y); for I := Low(BlackPoints) to High(BlackPoints) do begin BlackPoints[I].X := X + BlackCheckMarkPoints[I].X; BlackPoints[I].Y := Y + BlackCheckMarkPoints[I].Y; end; for I := Low(WhitePoints) to High(WhitePoints) do begin WhitePoints[I].X := X + WhiteCheckMarkPoints[I].X; WhitePoints[I].Y := Y + WhiteCheckMarkPoints[I].Y; end; Canvas.Pen.Color := clBtnText; Polyline(Canvas.Handle, BlackPoints, Length(BlackPoints)); Canvas.Pen.Color := clBtnHighlight; Polyline(Canvas.Handle, WhitePoints, Length(WhitePoints)); end; end; end; end; procedure TTBItemViewer.GetCursor(const Pt: TPoint; var ACursor: HCURSOR); begin end; function TTBItemViewer.GetIndex: Integer; begin Result := View.IndexOf(Self); end; function TTBItemViewer.IsToolbarSize: Boolean; begin Result := View.FIsToolbar or (tboToolbarSize in Item.FEffectiveOptions); end; function TTBItemViewer.IsToolbarStyle: Boolean; begin Result := View.FIsToolbar or (tboToolbarStyle in Item.FEffectiveOptions); end; function TTBItemViewer.IsPtInButtonPart(X, Y: Integer): Boolean; var W: Integer; begin Result := not(tbisSubmenu in Item.ItemStyle); if tbisCombo in Item.ItemStyle then begin if IsToolbarStyle then W := tbDropdownComboArrowWidth else W := GetSystemMetrics(SM_CXMENUCHECK); Result := X < (BoundsRect.Right - BoundsRect.Left) - W; end; end; procedure TTBItemViewer.MouseDown(Shift: TShiftState; X, Y: Integer; var MouseDownOnMenu: Boolean); procedure HandleDefaultDoubleClick(const View: TTBView); { Looks for a tboDefault item in View and ends the modal loop if it finds one. } var I: Integer; Viewer: TTBItemViewer; Item: TTBCustomItem; begin for I := 0 to View.FViewers.Count-1 do begin Viewer := View.Viewers[I]; Item := Viewer.Item; if (Viewer.Show or Viewer.Clipped) and (tboDefault in Item.EffectiveOptions) and (tbisSelectable in Item.ItemStyle) and Item.Enabled and Item.Visible then begin Viewer.Execute(True); Break; end; end; end; var WasAlreadyOpen: Boolean; begin if not Item.Enabled then begin if (View.FParentView = nil) and not View.FIsPopup then View.EndModal; Exit; end; if IsPtInButtonPart(X, Y) then begin if IsToolbarStyle then begin View.CancelChildPopups; View.SetCapture; View.Invalidate(Self); end; end else begin WasAlreadyOpen := (View.FOpenViewer = Self); if View.OpenChildPopup(False) then begin if WasAlreadyOpen and ((View.FParentView = nil) and not View.FIsPopup) then MouseDownOnMenu := True; if (ssDouble in Shift) and not(tbisCombo in Item.ItemStyle) then HandleDefaultDoubleClick(View.FOpenViewerView); end; end; end; procedure TTBItemViewer.MouseMove(X, Y: Integer); begin end; procedure TTBItemViewer.MouseUp(X, Y: Integer; MouseWasDownOnMenu: Boolean); var HadCapture, IsToolbarItem: Boolean; begin HadCapture := View.FCapture; View.CancelCapture; IsToolbarItem := (View.FParentView = nil) and not View.FIsPopup; if not View.FMouseOverSelected or not Item.Enabled or (tbisClicksTransparent in Item.ItemStyle) then begin if IsToolbarItem then View.EndModal; Exit; end; if (tbisSubmenu in Item.ItemStyle) and not IsPtInButtonPart(X, Y) then begin if IsToolbarItem and MouseWasDownOnMenu then View.EndModal; end else begin { it's a 'normal' item } if not IsToolbarStyle or HadCapture then Execute(True); end; end; procedure TTBItemViewer.MouseWheel(WheelDelta, X, Y: Integer); begin end; procedure TTBItemViewer.LosingCapture; begin View.Invalidate(Self); end; procedure TTBItemViewer.Entering; begin if Assigned(Item.FOnSelect) then Item.FOnSelect(Item, Self, True); end; procedure TTBItemViewer.Leaving; begin if Assigned(Item.FOnSelect) then Item.FOnSelect(Item, Self, False); end; procedure TTBItemViewer.KeyDown(var Key: Word; Shift: TShiftState); begin end; function TTBItemViewer.ScreenToClient(const P: TPoint): TPoint; begin Result := View.FWindow.ScreenToClient(P); Dec(Result.X, BoundsRect.Left); Dec(Result.Y, BoundsRect.Top); end; function TTBItemViewer.UsesSameWidth: Boolean; { If UsesSameWidth returns True, the item viewer's width will be expanded to match the widest item viewer on the same view whose UsesSameWidth method also returns True. } begin Result := (tboImageAboveCaption in Item.FEffectiveOptions) and (tboSameWidth in Item.FEffectiveOptions) and IsToolbarSize; end; function TTBItemViewer.DoExecute: Boolean; { Low-level 'execute' handler. Returns True if the caller should call GivePriority on the viewer (normally, if the 'execute' operation was a success and the modal loop is ending). } begin View.EndModalWithClick(Self); Result := True; end; procedure TTBItemViewer.Execute(AGivePriority: Boolean); { Calls DoExecute and, if applicable, View.GivePriority. Note that it is up to the caller to check the viewer's visibility and enabled state. } begin if DoExecute and AGivePriority then View.GivePriority(Self); end; function TTBItemViewer.GetAccRole: Integer; { Returns the MSAA "role" of the viewer. } const { Constants from OleAcc.h } ROLE_SYSTEM_CLIENT = $a; ROLE_SYSTEM_MENUITEM = $c; ROLE_SYSTEM_SEPARATOR = $15; ROLE_SYSTEM_PUSHBUTTON = $2b; ROLE_SYSTEM_BUTTONMENU = $39; begin if Item is TTBControlItem then Result := ROLE_SYSTEM_CLIENT else if tbisSeparator in Item.ItemStyle then Result := ROLE_SYSTEM_SEPARATOR else if View.IsPopup or (vsMenuBar in View.Style) then Result := ROLE_SYSTEM_MENUITEM else if tbisSubmenu in Item.ItemStyle then Result := ROLE_SYSTEM_BUTTONMENU else Result := ROLE_SYSTEM_PUSHBUTTON; end; function TTBItemViewer.GetAccValue(var Value: WideString): Boolean; { Gets the MSAA "value" text of the viewer. Returns True if something was assigned to Value, or False if the viewer does not possess a "value". } begin Result := False; end; { TTBView } constructor TTBView.Create(AOwner: TComponent; AParentView: TTBView; AParentItem: TTBCustomItem; AWindow: TWinControl; AIsToolbar, ACustomizing, AUsePriorityList: Boolean); begin {$IFDEF CLR} { TB2Acc's IAccessible implementations must be called from the same thread that created the view, so verify that the program has [STAThread] } CheckThreadingModel(System.Threading.ApartmentState.STA); {$ENDIF} inherited Create(AOwner); FViewers := TList.Create; FBackgroundColor := clDefault; FCustomizing := ACustomizing; FIsPopup := not AIsToolbar; FIsToolbar := AIsToolbar; FNewViewersGetHighestPriority := True; FParentView := AParentView; FParentItem := AParentItem; if Assigned(FParentItem) then begin //FIsToolbar := FIsToolbar or FParentItem.FDisplayAsToolbar; FParentItem.RegisterNotification(LinkNotification); FParentItem.FreeNotification(Self); end; FUsePriorityList := AUsePriorityList; FWindow := AWindow; UpdateCurParentItem; end; destructor TTBView.Destroy; begin CloseChildPopups; if Assigned(FAccObjectInstance) then begin FAccObjectInstance.ClientIsDestroying; { Get rid of our own reference to FAccObjectInstance. Normally the reference count will be now be zero and FAccObjectInstance will be freed, unless MSAA still holds a reference. } {$IFNDEF CLR} FAccObjectInstance._Release; {$ENDIF} FAccObjectInstance := nil; end; { If parent view is a toolbar, invalidate the open item so that it's redrawn back in the "up" position } if Assigned(ParentView) and ParentView.FIsToolbar then begin Include(ParentView.FState, vsNoAnimation); if Assigned(ParentView.FOpenViewer) then ParentView.Invalidate(ParentView.FOpenViewer); end; if Assigned(FCurParentItem) then FCurParentItem.UnregisterNotification(ItemNotification); if Assigned(FParentItem) then FParentItem.UnregisterNotification(LinkNotification); inherited; FPriorityList.Free; FreeViewers; FreeAndNil(FViewers); { Now that we're destroyed, "focus" the parent view } if Assigned(FParentView) then FParentView.NotifyFocusEvent; end; function TTBView.GetAccObject: TTBBaseAccObject; begin if FAccObjectInstance = nil then begin if not InitializeOleAcc then begin Result := nil; Exit; end; FAccObjectInstance := TTBViewAccObject.Create(Self); { Strictly as an optimization, take a reference for ourself and keep it for the lifetime of the view. (Destroy calls _Release.) } {$IFNDEF CLR} FAccObjectInstance._AddRef; {$ENDIF} end; Result := FAccObjectInstance; end; function TTBView.HandleWMGetObject(var Message: TMessage): Boolean; begin { Note: In a 64-bit build, object identifiers can come in either sign-extended or zero-extended from 32 to 64 bits. Clip to 32 bits here to ensure we accept both forms. } if (ClipToLongint(Message.LParam) = Longint(OBJID_CLIENT)) and InitializeOleAcc then begin Message.Result := LresultFromObjectFunc( {$IFNDEF CLR} ITBAccessible {$ELSE} TypeOf(ITBAccessible).GUID {$ENDIF}, Message.WParam, GetAccObject); Result := True; end else Result := False; end; procedure TTBView.UpdateCurParentItem; var Value: TTBCustomItem; begin Value := ItemContainingItems(FParentItem); if FCurParentItem <> Value then begin CloseChildPopups; if Assigned(FCurParentItem) then FCurParentItem.UnregisterNotification(ItemNotification); FCurParentItem := Value; if Assigned(Value) then Value.RegisterNotification(ItemNotification); RecreateAllViewers; if Assigned(Value) and not(csDesigning in Value.ComponentState) then InitiateActions; end; end; procedure TTBView.InitiateActions; var I: Integer; begin { Use a 'while' instead of a 'for' since an InitiateAction implementation may add/delete items } I := 0; while I < FViewers.Count do begin Viewers[I].Item.InitiateAction; Inc(I); end; end; procedure TTBView.Notification(AComponent: TComponent; Operation: TOperation); begin inherited; if Operation = opRemove then begin if AComponent = FParentItem then begin FParentItem := nil; UpdateCurParentItem; if Assigned(FParentView) then FParentView.CloseChildPopups; end else if AComponent = FOpenViewerWindow then begin FOpenViewerWindow := nil; FOpenViewerView := nil; FOpenViewer := nil; end else if AComponent = FChevronParentView then FChevronParentView := nil; end end; function TTBView.ContainsView(AView: TTBView): Boolean; begin while Assigned(AView) and (AView <> Self) do AView := AView.FParentView; Result := Assigned(AView); end; function TTBView.GetRootView: TTBView; begin Result := Self; while Assigned(Result.FParentView) do Result := Result.FParentView; end; function TTBView.GetParentToolbarView: TTBView; begin Result := Self; while Assigned(Result) and not Result.FIsToolbar do Result := Result.FParentView; end; function TTBView.GetViewer(Index: Integer): TTBItemViewer; begin if (Index < 0) or (Index >= FViewers.Count) then begin TTBCustomItem.IndexError; Result := nil; Exit; end; Result := TTBItemViewer(FViewers.List[Index]); end; function TTBView.GetViewerCount: Integer; begin Result := FViewers.Count; end; procedure TTBView.FreeViewers; var I: Integer; Viewer: TTBItemViewer; begin if Assigned(FViewers) then begin for I := FViewers.Count-1 downto 0 do begin Viewer := Viewers[I]; FViewers.Delete(I); Viewer.Free; end; end; end; procedure TTBView.InvalidatePositions; begin if FValidated then begin FValidated := False; if Assigned(FWindow) and FWindow.HandleAllocated then InvalidateRect(FWindow.Handle, nil, True); end; end; procedure TTBView.ValidatePositions; begin if not FValidated then UpdatePositions; end; procedure TTBView.TryValidatePositions; begin if (FUpdating = 0) and (not Assigned(FParentItem) or not(csLoading in FParentItem.ComponentState)) and (not Assigned(FParentItem.Owner) or not(csLoading in FParentItem.Owner.ComponentState)) then ValidatePositions; end; (*procedure TTBView.TryRevalidatePositions; begin if FValidated then begin if FUpdating = 0 then begin FreePositions; UpdatePositions; end else InvalidatePositions; end; end;*) function TTBView.Find(Item: TTBCustomItem): TTBItemViewer; var I: Integer; begin for I := 0 to FViewers.Count-1 do if Viewers[I].Item = Item then begin Result := Viewers[I]; Exit; end; raise ETBItemError.Create(STBViewerNotFound); end; function TTBView.IndexOf(AViewer: TTBItemViewer): Integer; var I: Integer; begin if Assigned(AViewer) then for I := 0 to FViewers.Count-1 do if FViewers.List[I] = AViewer then begin Result := I; Exit; end; Result := -1; end; procedure TTBView.DeletingViewer(Viewer: TTBItemViewer); begin if FSelected = Viewer then FSelected := nil; if FOpenViewer = Viewer then CloseChildPopups; end; procedure TTBView.RecreateItemViewer(const I: Integer); var OldViewer, NewViewer: TTBItemViewer; J: Integer; begin OldViewer := Viewers[I]; DeletingViewer(OldViewer); NewViewer := OldViewer.Item.GetItemViewerClass(Self).Create(Self, OldViewer.Item, OldViewer.FGroupLevel); FViewers[I] := NewViewer; if Assigned(FPriorityList) then begin J := FPriorityList.IndexOf(OldViewer); if J <> -1 then FPriorityList[J] := NewViewer; end; OldViewer.Free; end; function TTBView.InsertItemViewers(const NewIndex: Integer; const AItem: TTBCustomItem; const AGroupLevel: Integer; const AddToPriorityList, TopOfPriorityList: Boolean): Integer; var NewViewer: TTBItemViewer; LinkItem: TTBCustomItem; I: Integer; begin if AGroupLevel > MaxGroupLevel then begin Result := 0; Exit; end; FViewers.Expand; NewViewer := AItem.GetItemViewerClass(Self).Create(Self, AItem, AGroupLevel); FViewers.Insert(NewIndex, NewViewer); if AddToPriorityList and FUsePriorityList then begin if not TopOfPriorityList then AddToList(FPriorityList, NewViewer) else { When new items are inserted programmatically at run-time, place them at the top of FPriorityList } AddToFrontOfList(FPriorityList, NewViewer); end; Result := 1; { If a new group item is being inserted, insert all its child items too } if not FCustomizing and (tbisEmbeddedGroup in AItem.ItemStyle) then begin LinkItem := ItemContainingItems(AItem); for I := 0 to LinkItem.Count-1 do begin Inc(Result, InsertItemViewers(NewIndex + Result, LinkItem.Items[I], AGroupLevel + 1, AddToPriorityList, TopOfPriorityList)); end; end; end; procedure TTBView.ItemNotification(Ancestor: TTBCustomItem; Relayed: Boolean; Action: TTBItemChangedAction; Index: Integer; Item: TTBCustomItem); procedure ItemInserted; var NewLevel, Start, InsertPoint, Last: Integer; GroupItem, NextItem: TTBCustomItem; Found, SearchAgain: Boolean; begin InvalidatePositions; NewLevel := 0; Start := 0; if Ancestor = FCurParentItem then InsertPoint := FViewers.Count else begin { Ancestor <> FCurParentItem, so apparently an item has been inserted inside a group item } repeat Found := False; while Start < FViewers.Count do begin GroupItem := Viewers[Start].Item; if (tbisEmbeddedGroup in GroupItem.ItemStyle) and (GroupItem = Ancestor) then begin NewLevel := Viewers[Start].FGroupLevel + 1; Inc(Start); Found := True; Break; end; Inc(Start); end; if not Found then { Couldn't find Ancestor; it shouldn't get here } Exit; InsertPoint := Start; SearchAgain := False; while (InsertPoint < FViewers.Count) and (Viewers[InsertPoint].FGroupLevel >= NewLevel) do begin if (Viewers[InsertPoint].Item = Item) and (Viewers[InsertPoint].FGroupLevel = NewLevel) then begin { If the item we were going to insert already exists, then there must be multiple instances of the same group item. This can happen when are two group items on the same toolbar each linking to the same submenu item, with the submenu item containing a group item of its own, and an item is inserted inside that. } SearchAgain := True; Break; end; Inc(InsertPoint); end; until not SearchAgain; end; if InsertPoint = FViewers.Count then begin { Don't add items after the chevron or MDI buttons item } Dec(InsertPoint, FInternalViewersAtEnd); if InsertPoint < 0 then InsertPoint := 0; { just in case? } end; { If the new item wasn't placed at the end, adjust InsertPoint accordingly } if Index < Item.Parent.Count-1 then begin Last := InsertPoint; InsertPoint := Start; NextItem := Item.Parent.Items[Index+1]; while (InsertPoint < Last) and ((Viewers[InsertPoint].Item <> NextItem) or (Viewers[InsertPoint].FGroupLevel <> NewLevel)) do Inc(InsertPoint); end; InsertItemViewers(InsertPoint, Item, NewLevel, True, not(csLoading in Item.ComponentState) and FNewViewersGetHighestPriority); end; procedure ItemDeleting; procedure DeleteItem(DeleteIndex: Integer); var Viewer: TTBItemViewer; begin Viewer := Viewers[DeleteIndex]; DeletingViewer(Viewer); RemoveFromList(FPriorityList, Viewer); FreeAndNil(Viewer); FViewers.Delete(DeleteIndex); end; var I: Integer; DeleteLevel: Integer; begin InvalidatePositions; I := 0; DeleteLevel := 0; while I < FViewers.Count do begin if DeleteLevel > 0 then begin if Viewers[I].FGroupLevel >= DeleteLevel then begin DeleteItem(I); Continue; end else DeleteLevel := 0; end; if Viewers[I].Item = Item then begin { Delete the item, and any group item children afterward } DeleteLevel := Viewers[I].FGroupLevel + 1; DeleteItem(I); Continue; end; Inc(I); end; end; var I: Integer; begin case Action of tbicInserted: ItemInserted; tbicDeleting: ItemDeleting; tbicSubitemsChanged: begin { If Relayed=True, LinkSubitems must have changed on a child group item. Currently there isn't any optimized way of handling this situation; just recreate all viewers. } if Relayed then RecreateAllViewers; end; tbicSubitemsBeginUpdate: BeginUpdate; tbicSubitemsEndUpdate: EndUpdate; tbicInvalidate: begin for I := 0 to FViewers.Count-1 do if Viewers[I].Item = Item then Invalidate(Viewers[I]); end; tbicInvalidateAndResize: InvalidatePositions; tbicRecreateItemViewers: begin InvalidatePositions; for I := 0 to FViewers.Count-1 do if Viewers[I].Item = Item then RecreateItemViewer(I); end; tbicSubMenuImagesChanged: ImagesChanged; else { Prevent TryValidatePositions from being called below on Actions other than those listed above. Currently there are no other Actions, but for forward compatibility, we should ignore unknown Actions completely. } Exit; end; TryValidatePositions; end; procedure TTBView.LinkNotification(Ancestor: TTBCustomItem; Relayed: Boolean; Action: TTBItemChangedAction; Index: Integer; Item: TTBCustomItem); { This notification procedure watches for tbicSubitemsChanged notifications from FParentItem } begin case Action of tbicSubitemsChanged: begin { LinkSubitems may have changed on FParentItem, e.g. on the root item of a toolbar, so see if FCurParentItem needs updating } UpdateCurParentItem; end; tbicSubMenuImagesChanged: begin { In case the images were inherited from the actual parent instead of the linked parent... } if FParentItem <> FCurParentItem then ImagesChanged; end; end; end; procedure TTBView.ImagesChanged; begin InvalidatePositions; TryValidatePositions; if Assigned(FOpenViewerView) then FOpenViewerView.ImagesChanged; end; procedure TTBView.GivePriority(AViewer: TTBItemViewer); { Move item to top of priority list. Rearranges items if necessary. } var I: Integer; begin if Assigned(FChevronParentView) then begin I := AViewer.Index + FChevronParentView.FInternalViewersAtFront; if I < FChevronParentView.FViewers.Count then { range check just in case } FChevronParentView.GivePriority(FChevronParentView.Viewers[I]); Exit; end; if Assigned(FPriorityList) then begin I := FPriorityList.IndexOf(AViewer); if I <> -1 then begin FPriorityList.Move(I, 0); if not FValidated or AViewer.OffEdge then UpdatePositions; end; end; { Call GivePriority on parent view, so that if an item on a submenu is clicked, the parent item of the submenu gets priority. } if Assigned(FParentView) and Assigned(FParentView.FOpenViewer) then FParentView.GivePriority(FParentView.FOpenViewer); end; function TTBView.HighestPriorityViewer: TTBItemViewer; { Returns index of first visible, non-separator item at top of priority list, or -1 if there are no items found } var I: Integer; J: TTBItemViewer; begin ValidatePositions; Result := nil; if Assigned(FPriorityList) then begin for I := 0 to FPriorityList.Count-1 do begin J := TTBItemViewer(FPriorityList[I]); if J.Show and not(tbisSeparator in J.Item.ItemStyle) then begin Result := J; Break; end; end; end else begin for I := 0 to FViewers.Count-1 do begin J := Viewers[I]; if J.Show and not(tbisSeparator in J.Item.ItemStyle) then begin Result := J; Break; end; end; end; end; procedure TTBView.StartTimer(const ATimer: TTBViewTimerID; const Interval: Integer); { Starts a timer. Stops any previously set timer of the same ID first. Note: WM_TIMER messages generated by timers set by the method are handled in PopupMessageLoop. } begin StopTimer(ATimer); if (FWindow is TTBPopupWindow) and FWindow.HandleAllocated then begin SetTimer(FWindow.Handle, ViewTimerBaseID + Ord(ATimer), Interval, nil); Include(FActiveTimers, ATimer); end; end; procedure TTBView.StopAllTimers; var I: TTBViewTimerID; begin for I := Low(I) to High(I) do StopTimer(I); end; procedure TTBView.StopTimer(const ATimer: TTBViewTimerID); begin if ATimer in FActiveTimers then begin if (FWindow is TTBPopupWindow) and FWindow.HandleAllocated then KillTimer(FWindow.Handle, ViewTimerBaseID + Ord(ATimer)); Exclude(FActiveTimers, ATimer); end; end; function TTBView.OpenChildPopup(const SelectFirstItem: Boolean): Boolean; var Item: TTBCustomItem; begin StopTimer(tiClose); StopTimer(tiOpen); if FSelected <> FOpenViewer then begin CloseChildPopups; if Assigned(FSelected) then begin Item := FSelected.Item; if Item.Enabled and (tbisSubmenu in Item.ItemStyle) then Item.CreatePopup(Self, FSelected, not FIsToolbar, SelectFirstItem, False, Point(0, 0), tbpaLeft); end; end; Result := Assigned(FOpenViewer); end; procedure TTBView.CloseChildPopups; begin if Assigned(FOpenViewerView) then FOpenViewerView.CloseChildPopups; StopTimer(tiClose); FOpenViewerWindow.Free; FOpenViewerWindow := nil; FOpenViewerView := nil; FOpenViewer := nil; end; procedure TTBView.CancelChildPopups; begin if FIsToolbar then Exclude(FState, vsDropDownMenus); CloseChildPopups; end; function TTBView.ViewerFromPoint(const P: TPoint): TTBItemViewer; var I: Integer; begin ValidatePositions; for I := 0 to FViewers.Count-1 do begin if Viewers[I].Show and PtInRect(Viewers[I].BoundsRect, P) then begin Result := Viewers[I]; Exit; end; end; Result := nil; end; procedure TTBView.NotifyFocusEvent; { Notifies Active Accessibility of a change in "focus". Has no effect if the view or the root view lacks the vsModal state, or if the modal loop is ending (EndModal* was called). } var I, ChildID, J: Integer; begin { Note: We don't notify about windows not yet shown (e.g. a popup menu that is still initializing) because that would probably confuse screen readers. Also allocating a window handle at this point *might* not be a good idea. } if (vsModal in FState) and (vsModal in GetRootView.FState) and not IsModalEnding and FWindow.HandleAllocated and IsWindowVisible(FWindow.Handle) then begin if Assigned(FSelected) and FSelected.IsAccessible then I := IndexOf(FSelected) else I := -1; if (I < 0) and Assigned(FParentView) then begin { If we have no selected item, report the the selected item on the parent view as having the "focus". Note: With standard menus, when you go from having a selection to no selection on a submenu, it sends two focus events - first with the client window as having the focus, then with the parent item. I figure that's probably a bug, so I don't try to emulate that behavior here. } FParentView.NotifyFocusEvent; end else begin if I >= 0 then begin { Convert viewer index into a one-based child index. (TTBViewAccObject.get_accChild does the inverse.) } ChildID := 1; for J := 0 to I-1 do if Viewers[J].IsAccessible then Inc(ChildID); end else begin { If there is no (accessible) selection and no parent view, report the client window itself as being "focused". This is what happens when a standard context menu has no selection. } ChildID := CHILDID_SELF; end; CallNotifyWinEvent(EVENT_OBJECT_FOCUS, FWindow.Handle, OBJID_CLIENT, ChildID); end; end; end; procedure TTBView.SetSelected(Value: TTBItemViewer); begin Select(Value, False); end; procedure TTBView.Select(Value: TTBItemViewer; ViaMouse: Boolean); { Sets the current selection. When the selection is changing it will also, if necessary, open/close child popups. How exactly this works depends on the setting of ViaMouse. If ViaMouse is True it will delay the opening/closing of popups using timers. } var OldSelected: TTBItemViewer; NewMouseOverSelected: Boolean; P: TPoint; begin OldSelected := FSelected; if Value <> OldSelected then begin { If there's a new selection and the parent item on the parent view isn't currently selected, select it. Also stop any timer running on the parent view. } if Assigned(Value) and Assigned(FParentView) and Assigned(FParentView.FOpenViewer) and (FParentView.FSelected <> FParentView.FOpenViewer) then begin FParentView.Selected := FParentView.FOpenViewer; FParentView.StopTimer(tiClose); FParentView.StopTimer(tiOpen); end; { Handle automatic closing of child popups } if vsModal in FState then begin { If the view is a toolbar, or if the new selection didn't come from the mouse, close child popups immediately } if FIsToolbar or not ViaMouse then begin { Always stop any close timer because CloseChildPopups may not be called below } StopTimer(tiClose); if Value <> FOpenViewer then { ^ But don't close if selection is returning to the open item. Needed for the "FParentView.Selected := FParentView.FOpenViewer" line above to work. } CloseChildPopups; end else begin { Otherwise, delay-close any child popup } if Assigned(FOpenViewerView) and not(tiClose in FActiveTimers) then StartTimer(tiClose, GetMenuShowDelay); end; end; CancelCapture; if Assigned(OldSelected) then OldSelected.Leaving; FSelected := Value; FSelectedViaMouse := ViaMouse; end; NewMouseOverSelected := False; if Assigned(Value) and Assigned(FWindow) then begin P := GetMessagePosAsPoint; if FindDragTarget(P, True) = FWindow then begin P := FWindow.ScreenToClient(P); NewMouseOverSelected := (ViewerFromPoint(P) = Value); if NewMouseOverSelected and FCapture and not Value.IsPtInButtonPart(P.X - Value.BoundsRect.Left, P.Y - Value.BoundsRect.Top) then NewMouseOverSelected := False; end; end; if Value <> OldSelected then begin FMouseOverSelected := NewMouseOverSelected; if Assigned(OldSelected) and (tbisRedrawOnSelChange in OldSelected.Item.ItemStyle) then Invalidate(OldSelected); if Assigned(Value) then begin if tbisRedrawOnSelChange in Value.Item.ItemStyle then Invalidate(Value); Value.Entering; end; NotifyFocusEvent; { Handle automatic opening of a child popup } if vsModal in FState then begin { If the view is a toolbar, immediately open any child popup } if FIsToolbar then begin if Assigned(Value) then begin if ViaMouse and Assigned(FParentView) then begin { On chevron popups, always drop down menus when mouse passes over them, like Office 2000 } Include(FState, vsDropDownMenus); end; if (vsDropDownMenus in FState) and (ViaMouse or not(tbisNoAutoOpen in Value.Item.ItemStyle)) then OpenChildPopup(not ViaMouse); end; end else begin { Otherwise, delay-open any child popup if the selection came from the mouse } StopTimer(tiOpen); if ViaMouse and Assigned(Value) and (tbisSubmenu in Value.Item.ItemStyle) then StartTimer(tiOpen, GetMenuShowDelay); end; end; end else if FMouseOverSelected <> NewMouseOverSelected then begin FMouseOverSelected := NewMouseOverSelected; if Assigned(Value) and FCapture and (tbisRedrawOnMouseOverChange in Value.Item.ItemStyle) then Invalidate(Value); end; end; procedure TTBView.UpdateSelection(const P: TPoint; const AllowNewSelection: Boolean); { Called in response to a mouse movement, this method updates the current selection, updates the vsMouseInWindow view state, and enables/disables scroll timers. } function IsPtInScrollArrow(ADownArrow: Boolean): Boolean; var P2: TPoint; R: TRect; begin Result := False; if (vsModal in FState) and (vsMouseInWindow in FState) and not FCapture and (P.X <> Low(Integer)) then begin P2 := FWindow.ScreenToClient(P); R := FWindow.ClientRect; if PtInRect(R, P2) then begin if ADownArrow then Result := FShowDownArrow and (P2.Y >= R.Bottom - tbMenuScrollArrowHeight) else Result := FShowUpArrow and (P2.Y < tbMenuScrollArrowHeight); end; end; end; var NewSelected, ViewerAtPoint: TTBItemViewer; P2: TPoint; MouseWasInWindow: Boolean; begin ValidatePositions; if FCapture then begin { If we have the capture, don't allow the selection to change. And always set vsMouseInWindow so that if the mouse is released outside the window, the "remove the selection" code below will be reached the next time UpdateSelection is called. } NewSelected := FSelected; Include(FState, vsMouseInWindow); end else begin { If modal, default to keeping the existing selection } if vsModal in FState then NewSelected := FSelected else NewSelected := nil; { Is the mouse inside the window? } MouseWasInWindow := vsMouseInWindow in FState; if (P.X <> Low(Integer)) and Assigned(FWindow) and (FindDragTarget(P, True) = FWindow) then begin { If we're a popup window and the mouse is inside, default to no selection } if FIsPopup then NewSelected := nil; Include(FState, vsMouseInWindow); if AllowNewSelection or Assigned(FSelected) then begin P2 := FWindow.ScreenToClient(P); ViewerAtPoint := ViewerFromPoint(P2); if Assigned(ViewerAtPoint) then NewSelected := ViewerAtPoint; end; end else begin Exclude(FState, vsMouseInWindow); { If we're a popup window and the mouse just moved outside the window while no submenu was open or a non-submenu-displaying item was selected, remove the selection } if FIsPopup and Assigned(NewSelected) and MouseWasInWindow and (not Assigned(FOpenViewerView) or not(tbisSubmenu in NewSelected.Item.ItemStyle)) then NewSelected := nil; end; end; { Now we set the new Selected value } Select(NewSelected, True); { Update scroll arrow timers } if IsPtInScrollArrow(False) then begin StopTimer(tiScrollDown); if not(tiScrollUp in FActiveTimers) then StartTimer(tiScrollUp, 100); end else if IsPtInScrollArrow(True) then begin StopTimer(tiScrollUp); if not(tiScrollDown in FActiveTimers) then StartTimer(tiScrollDown, 100); end else begin StopTimer(tiScrollUp); StopTimer(tiScrollDown); end; end; procedure TTBView.RecreateAllViewers; var Item: TTBCustomItem; I: Integer; begin { Since the FViewers list is being rebuilt, FOpenViewer and FSelected will no longer be valid, so ensure they're set to nil. } CloseChildPopups; Selected := nil; InvalidatePositions; FreeAndNil(FPriorityList); FreeViewers; FInternalViewersAtFront := 0; FInternalViewersAtEnd := 0; { MDI system menu item } Item := GetMDISystemMenuItem; if Assigned(Item) then Inc(FInternalViewersAtFront, InsertItemViewers(FViewers.Count, Item, 0, False, False)); { Items } if Assigned(FCurParentItem) then begin for I := 0 to FCurParentItem.Count-1 do InsertItemViewers(FViewers.Count, FCurParentItem.Items[I], 0, True, False); end; { MDI buttons item } Item := GetMDIButtonsItem; if Assigned(Item) then begin for I := 0 to Item.Count-1 do Inc(FInternalViewersAtEnd, InsertItemViewers(FViewers.Count, Item.Items[I], 0, False, False)); end; { Chevron item } Item := GetChevronItem; if Assigned(Item) then Inc(FInternalViewersAtEnd, InsertItemViewers(FViewers.Count, Item, 0, False, False)); end; function TTBView.CalculatePositions(const CanMoveControls: Boolean; const AOrientation: TTBViewOrientation; AWrapOffset, AChevronOffset, AChevronSize: Integer; var ABaseSize, TotalSize: TPoint; var AWrappedLines: Integer): Boolean; { Returns True if the positions have changed } type TTempPosition = record BoundsRect: TRect; Show, OffEdge, LineSep, Clipped, SameWidth: Boolean; { Include an Integer field to enforce Integer alignment of the record (which we don't get by default due to TRect being wrongly declared as 'packed'). Needed to avoid alignment fault on Delphi.NET 2007 IA-64. } DummyAlignment: Integer; end; TTempPositionArrayItem = record Pos: TTempPosition; end; var DC: HDC; LeftX, TopY, CurX, CurY: Integer; NewPositions: array of TTempPositionArrayItem; GroupSplit, DidWrap: Boolean; LineStart, HighestHeightOnLine, HighestWidthOnLine: Integer; function GetSizeOfGroup(const StartingIndex: Integer): Integer; var I: Integer; begin Result := 0; for I := StartingIndex to FViewers.Count-1 do begin with NewPositions[I] do begin if not Pos.Show then Continue; if tbisSeparator in Viewers[I].Item.ItemStyle then Break; if AOrientation <> tbvoVertical then Inc(Result, Pos.BoundsRect.Right) else Inc(Result, Pos.BoundsRect.Bottom); end; end; end; procedure Mirror; { Reverses the horizontal ordering (i.e. first item becomes last) } var I, NewRight: Integer; begin for I := 0 to FViewers.Count-1 do with NewPositions[I] do if Pos.Show then begin NewRight := TotalSize.X - Pos.BoundsRect.Left; Pos.BoundsRect.Left := TotalSize.X - Pos.BoundsRect.Right; Pos.BoundsRect.Right := NewRight; end; end; procedure HandleMaxHeight; { Decreases, if necessary, the height of the view to FMaxHeight, and adjusts the visibility of the scroll arrows } var MaxOffset, I, MaxTop, MaxBottom: Integer; begin FShowUpArrow := False; FShowDownArrow := False; if (FMaxHeight > 0) and (TotalSize.Y > FMaxHeight) then begin MaxOffset := TotalSize.Y - FMaxHeight; if FScrollOffset > MaxOffset then FScrollOffset := MaxOffset; if FScrollOffset < 0 then FScrollOffset := 0; FShowUpArrow := (FScrollOffset > 0); FShowDownArrow := (FScrollOffset < MaxOffset); MaxTop := 0; if FShowUpArrow then MaxTop := tbMenuScrollArrowHeight; MaxBottom := FMaxHeight; if FShowDownArrow then Dec(MaxBottom, tbMenuScrollArrowHeight); for I := 0 to FViewers.Count-1 do begin with NewPositions[I] do begin if not IsRectEmpty(Pos.BoundsRect) then begin OffsetRect(Pos.BoundsRect, 0, -FScrollOffset); if Pos.Show and ((Pos.BoundsRect.Top < MaxTop) or (Pos.BoundsRect.Bottom > MaxBottom)) then begin Pos.Show := False; Pos.Clipped := True; end; end; end; end; TotalSize.Y := FMaxHeight; end else FScrollOffset := 0; end; procedure FinalizeLine(const LineEnd: Integer; const LastLine: Boolean); var I, RightAlignStart: Integer; Item: TTBCustomItem; IsButton: Boolean; Z: Integer; begin if LineStart <> -1 then begin if DidWrap and (FChevronParentView = nil) then begin { When wrapping on a docked toolbar, extend TotalSize.X/Y to AWrapOffset so that the toolbar always fills the whole row } if (AOrientation = tbvoHorizontal) and (TotalSize.X < AWrapOffset) then TotalSize.X := AWrapOffset else if (AOrientation = tbvoVertical) and (TotalSize.Y < AWrapOffset) then TotalSize.Y := AWrapOffset; end; RightAlignStart := -1; for I := LineStart to LineEnd do begin with NewPositions[I] do begin if not Pos.Show then Continue; Item := Viewers[I].Item; if (RightAlignStart < 0) and (tbisRightAlign in Item.ItemStyle) then RightAlignStart := I; IsButton := FIsToolbar or (tboToolbarSize in Item.FEffectiveOptions); if FIsToolbar then begin if LastLine and not DidWrap and (AOrientation <> tbvoFloating) then begin { In case the toolbar is docked next to a taller/wider toolbar... } HighestWidthOnLine := TotalSize.X; HighestHeightOnLine := TotalSize.Y; end; { Make separators on toolbars as tall/wide as the tallest/widest item } if tbisSeparator in Item.ItemStyle then begin if AOrientation <> tbvoVertical then Pos.BoundsRect.Bottom := Pos.BoundsRect.Top + HighestHeightOnLine else Pos.BoundsRect.Right := Pos.BoundsRect.Left + HighestWidthOnLine; end else begin { Center the item } if AOrientation <> tbvoVertical then begin Z := (HighestHeightOnLine - (Pos.BoundsRect.Bottom - Pos.BoundsRect.Top)) div 2; Inc(Pos.BoundsRect.Top, Z); Inc(Pos.BoundsRect.Bottom, Z); end else begin Z := (HighestWidthOnLine - (Pos.BoundsRect.Right - Pos.BoundsRect.Left)) div 2; Inc(Pos.BoundsRect.Left, Z); Inc(Pos.BoundsRect.Right, Z); end; end; end else begin { Make items in a menu as wide as the widest item } if not IsButton then begin with Pos.BoundsRect do Right := Left + HighestWidthOnLine; end; end; end; end; if RightAlignStart >= 0 then begin Z := 0; for I := LineEnd downto RightAlignStart do begin with NewPositions[I] do begin if not Pos.Show then Continue; if AOrientation <> tbvoVertical then Z := Min(AWrapOffset, TotalSize.X) - Pos.BoundsRect.Right else Z := Min(AWrapOffset, TotalSize.Y) - Pos.BoundsRect.Bottom; end; Break; end; if Z > 0 then begin for I := RightAlignStart to LineEnd do begin with NewPositions[I] do begin if not Pos.Show then Continue; if AOrientation <> tbvoVertical then begin Inc(Pos.BoundsRect.Left, Z); Inc(Pos.BoundsRect.Right, Z); end else begin Inc(Pos.BoundsRect.Top, Z); Inc(Pos.BoundsRect.Bottom, Z); end; end; end; end; end; end; LineStart := -1; HighestHeightOnLine := 0; HighestWidthOnLine := 0; end; procedure PositionItem(const CurIndex: Integer; var Pos: TTempPosition); var O, X, Y: Integer; IsLineSep, Vert: Boolean; begin if LineStart = -1 then begin LineStart := CurIndex; HighestHeightOnLine := 0; HighestWidthOnLine := 0; end; IsLineSep := False; Vert := (AOrientation = tbvoVertical); if not Vert then O := CurX else O := CurY; if (AWrapOffset > 0) and (O > 0) then begin if not Vert then Inc(O, Pos.BoundsRect.Right) else Inc(O, Pos.BoundsRect.Bottom); if (tbisSeparator in Viewers[CurIndex].Item.ItemStyle) and ((GroupSplit and not(tbisNoLineBreak in Viewers[CurIndex].Item.ItemStyle)) or (O + GetSizeOfGroup(CurIndex+1) > AWrapOffset)) then begin DidWrap := True; Inc(AWrappedLines); if not Vert then begin CurX := 0; Inc(CurY, HighestHeightOnLine); end else begin CurY := 0; Inc(CurX, HighestWidthOnLine); end; FinalizeLine(CurIndex-1, False); LineStart := CurIndex+1; if not Vert then begin Pos.BoundsRect.Right := 0; Pos.BoundsRect.Bottom := tbLineSpacing; end else begin Pos.BoundsRect.Right := tbLineSpacing; Pos.BoundsRect.Bottom := 0; end; Pos.LineSep := True; IsLineSep := True; end else if O > AWrapOffset then begin { proceed to next row } DidWrap := True; Inc(AWrappedLines); if not Vert then begin CurX := LeftX; Inc(CurY, HighestHeightOnLine); end else begin CurY := TopY; Inc(CurX, HighestWidthOnLine); end; GroupSplit := True; FinalizeLine(CurIndex-1, False); LineStart := CurIndex; end; end; if Pos.BoundsRect.Bottom > HighestHeightOnLine then HighestHeightOnLine := Pos.BoundsRect.Bottom; if Pos.BoundsRect.Right > HighestWidthOnLine then HighestWidthOnLine := Pos.BoundsRect.Right; X := CurX; Y := CurY; if X < 0 then X := 0; if Y < 0 then Y := 0; OffsetRect(Pos.BoundsRect, X, Y); if IsLineSep then begin if not Vert then begin CurX := LeftX; Inc(CurY, tbLineSpacing); end else begin CurY := TopY; Inc(CurX, tbLineSpacing); end; GroupSplit := False; end; end; var SaveOrientation: TTBViewOrientation; ChevronItem: TTBCustomItem; CalcCanvas: TCanvas; LastWasSep, LastWasButton, IsButton, IsControl: Boolean; Item: TTBCustomItem; Ctl: TControl; ChangedBold: Boolean; I, HighestSameWidthViewerWidth, Total, J, TotalVisibleItems: Integer; IsFirst: Boolean; Viewer: TTBItemViewer; UseChevron, NonControlsOffEdge, TempViewerCreated: Boolean; Margins: TRect; label FoundItemToHide; begin SaveOrientation := FOrientation; AWrappedLines := 1; ChevronItem := GetChevronItem; DC := 0; CalcCanvas := nil; try FOrientation := AOrientation; CalcCanvas := TCanvas.Create; DC := GetDC(0); CalcCanvas.Handle := DC; CalcCanvas.Font.Assign(GetFont); SetLength(NewPositions, FViewers.Count); { Figure out which items should be shown } LastWasSep := True; { set to True initially so it won't show leading seps } for I := 0 to FViewers.Count-1 do begin Item := Viewers[I].Item; IsControl := Item is TTBControlItem; with NewPositions[I] do begin { Pos.Show is initially False since SetLength initializes to zero } if Item = ChevronItem then Continue; if Assigned(FChevronParentView) then begin if IsControl then Continue; FChevronParentView.ValidatePositions; J := I + FChevronParentView.FInternalViewersAtFront; if J < FChevronParentView.FViewers.Count then { range check just in case } Viewer := FChevronParentView.Viewers[J] else Viewer := nil; if (Viewer = nil) or (not Viewer.OffEdge and not(tbisSeparator in Item.ItemStyle)) then Continue; end; if not IsControl then begin if not(tbisEmbeddedGroup in Item.ItemStyle) or FCustomizing then begin Pos.Show := Item.Visible; { Don't display two consecutive separators } if Pos.Show then begin if (tbisSeparator in Item.ItemStyle) and LastWasSep then Pos.Show := False; LastWasSep := tbisSeparator in Item.ItemStyle; end; end; end else begin { Controls can only be rendered on a single Parent, so only include the control if its parent is currently equal to FWindow } Ctl := TTBControlItem(Item).FControl; if Assigned(Ctl) and Assigned(FWindow) and (Ctl.Parent = FWindow) and (Ctl.Visible or (csDesigning in Ctl.ComponentState)) then begin Pos.Show := True; LastWasSep := False; end; end; end; end; { Hide any trailing separators, so that they aren't included in the base size } for I := FViewers.Count-1 downto 0 do begin with NewPositions[I] do if Pos.Show then begin if not(tbisSeparator in Viewers[I].Item.ItemStyle) then Break; Pos.Show := False; end; end; { Calculate sizes of all the items } HighestSameWidthViewerWidth := 0; for I := 0 to FViewers.Count-1 do begin Item := Viewers[I].Item; IsControl := Item is TTBControlItem; with NewPositions[I] do begin { Pos.BoundsRect is currently empty since SetLength initializes to zero } if not Pos.Show then Continue; if not IsControl then begin ChangedBold := False; if tboDefault in Item.EffectiveOptions then with CalcCanvas.Font do if not(fsBold in Style) then begin ChangedBold := True; Style := Style + [fsBold]; end; Viewer := Viewers[I]; TempViewerCreated := False; if Item.NeedToRecreateViewer(Viewer) then begin if CanMoveControls then begin RecreateItemViewer(I); Viewer := Viewers[I]; end else begin Viewer := Item.GetItemViewerClass(Self).Create(Self, Item, 0); TempViewerCreated := True; end; end; try Viewer.CalcSize(CalcCanvas, Pos.BoundsRect.Right, Pos.BoundsRect.Bottom); if Viewer.UsesSameWidth then begin Pos.SameWidth := True; if (Pos.BoundsRect.Right > HighestSameWidthViewerWidth) then HighestSameWidthViewerWidth := Pos.BoundsRect.Right; end; finally if TempViewerCreated then Viewer.Free; end; if ChangedBold then with CalcCanvas.Font do Style := Style - [fsBold]; end else begin Ctl := TTBControlItem(Item).FControl; Pos.BoundsRect.Right := Ctl.Width; Pos.BoundsRect.Bottom := Ctl.Height; end; end; end; { Increase widths of SameWidth items if necessary. Also calculate ABaseSize.X (or Y). } ABaseSize.X := 0; ABaseSize.Y := 0; for I := 0 to FViewers.Count-1 do begin with NewPositions[I] do begin if Pos.SameWidth and (Pos.BoundsRect.Right < HighestSameWidthViewerWidth) then Pos.BoundsRect.Right := HighestSameWidthViewerWidth; if AOrientation <> tbvoVertical then Inc(ABaseSize.X, Pos.BoundsRect.Right) else Inc(ABaseSize.Y, Pos.BoundsRect.Bottom); end; end; { Hide partially visible items, mark them as 'OffEdge' } if AOrientation <> tbvoVertical then Total := ABaseSize.X else Total := ABaseSize.Y; NonControlsOffEdge := False; UseChevron := Assigned(ChevronItem) and (AChevronOffset > 0) and (Total > AChevronOffset); if UseChevron then begin Dec(AChevronOffset, AChevronSize); while Total > AChevronOffset do begin { Count number of items. Stop loop if <= 1 } TotalVisibleItems := 0; for I := FViewers.Count-1 downto 0 do begin if NewPositions[I].Pos.Show and not(tbisSeparator in Viewers[I].Item.ItemStyle) then Inc(TotalVisibleItems); end; if TotalVisibleItems <= 1 then Break; { Hide any trailing separators } for I := FViewers.Count-1 downto 0 do begin if NewPositions[I].Pos.Show then begin if not(tbisSeparator in Viewers[I].Item.ItemStyle) then Break; NewPositions[I].Pos.Show := False; if AOrientation <> tbvoVertical then Dec(Total, NewPositions[I].Pos.BoundsRect.Right) else Dec(Total, NewPositions[I].Pos.BoundsRect.Bottom); goto FoundItemToHide; end; end; { Find an item to hide } if Assigned(FPriorityList) then I := FPriorityList.Count-1 else I := FViewers.Count-1; while I >= 0 do begin if Assigned(FPriorityList) then begin Viewer := TTBItemViewer(FPriorityList[I]); J := Viewer.Index; end else begin Viewer := Viewers[I]; J := I; end; if NewPositions[J].Pos.Show and not(tbisSeparator in Viewer.Item.ItemStyle) then begin NewPositions[J].Pos.Show := False; NewPositions[J].Pos.OffEdge := True; if AOrientation <> tbvoVertical then Dec(Total, NewPositions[J].Pos.BoundsRect.Right) else Dec(Total, NewPositions[J].Pos.BoundsRect.Bottom); if not NonControlsOffEdge and not(Viewer.Item is TTBControlItem) then NonControlsOffEdge := True; goto FoundItemToHide; end; Dec(I); end; Break; { prevent endless loop } FoundItemToHide: { Don't show two consecutive separators } LastWasSep := True; { set to True initially so it won't show leading seps } for J := 0 to FViewers.Count-1 do begin Item := Viewers[J].Item; with NewPositions[J] do begin if Pos.Show then begin if (tbisSeparator in Item.ItemStyle) and LastWasSep then begin Pos.Show := False; if AOrientation <> tbvoVertical then Dec(Total, Pos.BoundsRect.Right) else Dec(Total, Pos.BoundsRect.Bottom); end; LastWasSep := tbisSeparator in Item.ItemStyle; end; end; end; end; end; { Hide any trailing separators after items were hidden } for I := FViewers.Count-1 downto 0 do begin with NewPositions[I] do if Pos.Show then begin if not(tbisSeparator in Viewers[I].Item.ItemStyle) then Break; Pos.Show := False; end; end; { Set the ABaseSize.Y (or X) *after* items were hidden } for I := 0 to FViewers.Count-1 do begin with NewPositions[I] do if Pos.Show then begin if AOrientation <> tbvoVertical then begin if Pos.BoundsRect.Bottom > ABaseSize.Y then ABaseSize.Y := Pos.BoundsRect.Bottom; end else begin if Pos.BoundsRect.Right > ABaseSize.X then ABaseSize.X := Pos.BoundsRect.Right; end; end; end; { On menus, set all non-separator items to be as tall as the tallest item } {if not FIsToolbar then begin J := 0; for I := 0 to FViewers.Count-1 do begin Item := Viewers[I].Item; with NewPositions[I] do if Pos.Show and not(tbisSeparator in Item.ItemStyle) and not(tboToolbarSize in Item.FEffectiveOptions) and (Pos.BoundsRect.Bottom - Pos.BoundsRect.Top > J) then J := Pos.BoundsRect.Bottom - Pos.BoundsRect.Top; end; for I := 0 to FViewers.Count-1 do begin Item := Viewers[I].Item; with NewPositions[I] do if Pos.Show and not(tbisSeparator in Item.ItemStyle) and not(tboToolbarSize in Item.FEffectiveOptions) then Pos.BoundsRect.Bottom := Pos.BoundsRect.Top + J; end; end;} { Calculate the position of the items } GetMargins(AOrientation, Margins); LeftX := Margins.Left; TopY := Margins.Top; if AWrapOffset > 0 then begin Dec(AWrapOffset, Margins.Right); if AWrapOffset < 1 then AWrapOffset := 1; end; CurX := LeftX; CurY := TopY; GroupSplit := False; DidWrap := False; LastWasButton := FIsToolbar; LineStart := -1; for I := 0 to FViewers.Count-1 do begin Item := Viewers[I].Item; with NewPositions[I] do begin if not Pos.Show then Continue; IsButton := FIsToolbar or (tboToolbarSize in Item.FEffectiveOptions); if LastWasButton and not IsButton then begin { On a menu, if last item was a button and the current item isn't, proceed to next row } CurX := LeftX; CurY := TotalSize.Y; end; LastWasButton := IsButton; PositionItem(I, NewPositions[I].Pos); if IsButton and (AOrientation <> tbvoVertical) then Inc(CurX, Pos.BoundsRect.Right - Pos.BoundsRect.Left) else Inc(CurY, Pos.BoundsRect.Bottom - Pos.BoundsRect.Top); if Pos.BoundsRect.Right > TotalSize.X then TotalSize.X := Pos.BoundsRect.Right; if Pos.BoundsRect.Bottom > TotalSize.Y then TotalSize.Y := Pos.BoundsRect.Bottom; end; end; if FViewers.Count <> 0 then FinalizeLine(FViewers.Count-1, True); Inc(TotalSize.X, Margins.Right); Inc(TotalSize.Y, Margins.Bottom); if AOrientation = tbvoVertical then Mirror; HandleMaxHeight; if CanMoveControls then begin for I := 0 to FViewers.Count-1 do begin Item := Viewers[I].Item; if Item is TTBControlItem then begin if NewPositions[I].Pos.Show then begin Ctl := TTBControlItem(Item).FControl; if not EqualRect(NewPositions[I].Pos.BoundsRect, Ctl.BoundsRect) then Ctl.BoundsRect := NewPositions[I].Pos.BoundsRect; end else if NewPositions[I].Pos.OffEdge or NewPositions[I].Pos.Clipped then begin { Simulate hiding of OddEdge controls by literally moving them off the edge. Do the same for Clipped controls. } Ctl := TTBControlItem(Item).FControl; Ctl.SetBounds(FWindow.ClientWidth, FWindow.ClientHeight, Ctl.Width, Ctl.Height); end; end; end; end; { Set size of line separators } if FIsToolbar then for I := 0 to FViewers.Count-1 do begin Item := Viewers[I].Item; with NewPositions[I] do if Pos.Show and (tbisSeparator in Item.ItemStyle) and Pos.LineSep then begin if AOrientation <> tbvoVertical then Pos.BoundsRect.Right := TotalSize.X else Pos.BoundsRect.Bottom := TotalSize.Y; end; end; { Position the chevron item } if UseChevron then begin if CanMoveControls then ChevronItem.Enabled := NonControlsOffEdge; NewPositions[FViewers.Count-1].Pos.Show := True; I := AChevronOffset; if AOrientation <> tbvoVertical then begin if I < TotalSize.X then I := TotalSize.X; NewPositions[FViewers.Count-1].Pos.BoundsRect := Bounds(I, 0, AChevronSize, TotalSize.Y); end else begin if I < TotalSize.Y then I := TotalSize.Y; NewPositions[FViewers.Count-1].Pos.BoundsRect := Bounds(0, I, TotalSize.X, AChevronSize); end; end; { Commit changes } Result := False; if CanMoveControls then begin for I := 0 to FViewers.Count-1 do begin Viewer := Viewers[I]; with NewPositions[I] do begin if not Result and (not EqualRect(Viewer.BoundsRect, Pos.BoundsRect) or (Viewer.Show <> Pos.Show) or ((tbisLineSep in Viewer.State) <> Pos.LineSep)) then Result := True; Viewer.FBoundsRect := Pos.BoundsRect; Viewer.FShow := Pos.Show; Viewer.FOffEdge := Pos.OffEdge; Viewer.FClipped := Pos.Clipped; if Pos.LineSep then Include(Viewer.State, tbisLineSep) else Exclude(Viewer.State, tbisLineSep); end; end; end; finally FOrientation := SaveOrientation; if Assigned(CalcCanvas) then CalcCanvas.Handle := 0; if DC <> 0 then ReleaseDC(0, DC); CalcCanvas.Free; end; if (ABaseSize.X = 0) or (ABaseSize.Y = 0) then begin { If there are no visible items... } {}{scale this?} ABaseSize.X := 23; ABaseSize.Y := 22; if TotalSize.X < 23 then TotalSize.X := 23; if TotalSize.Y < 22 then TotalSize.Y := 22; end; end; procedure TTBView.DoUpdatePositions(var ASize: TPoint); { This is called by UpdatePositions } var WrappedLines: Integer; begin { Don't call InvalidatePositions before CalculatePositions so that endless recursion doesn't happen if an item's CalcSize uses a method that calls ValidatePositions } CalculatePositions(True, FOrientation, FWrapOffset, FChevronOffset, FChevronSize, FBaseSize, ASize, WrappedLines); FValidated := True; { Need to call ValidateRect before AutoSize, otherwise Windows will erase the client area during a resize } if FWindow.HandleAllocated then ValidateRect(FWindow.Handle, nil); AutoSize(ASize.X, ASize.Y); if FWindow.HandleAllocated then DoubleBufferedRepaint(FWindow.Handle); end; function TTBView.UpdatePositions: TPoint; { Called whenever the size or orientation of a view changes. When items are added or removed from the view, InvalidatePositions must be called instead, otherwise the view may not be redrawn properly. } begin Result.X := 0; Result.Y := 0; DoUpdatePositions(Result); end; procedure TTBView.AutoSize(AWidth, AHeight: Integer); begin end; function TTBView.GetChevronItem: TTBCustomItem; begin Result := nil; end; procedure TTBView.GetMargins(AOrientation: TTBViewOrientation; var Margins: TRect); begin if AOrientation = tbvoFloating then begin Margins.Left := 4; Margins.Top := 2; Margins.Right := 4; Margins.Bottom := 1; end else begin Margins.Left := 0; Margins.Top := 0; Margins.Right := 0; Margins.Bottom := 0; end; end; function TTBView.GetMDIButtonsItem: TTBCustomItem; begin Result := nil; end; function TTBView.GetMDISystemMenuItem: TTBCustomItem; begin Result := nil; end; function TTBView.GetFont: TFont; begin if Assigned(ToolbarFont) then Result := ToolbarFont else begin { ToolbarFont is destroyed during unit finalization, but in rare cases this method may end up being called from ValidatePositions *after* unit finalization if Application.Run is never called; see the "EConvertError" newsgroup thread. We can't return nil because that would cause an exception in the calling function, so just return the window font. It's not the *right* font, but it shouldn't matter since the app is exiting anyway. } Result := {$IFNDEF CLR}TControlAccess{$ENDIF}(FWindow).Font; end; end; procedure TTBView.DrawItem(Viewer: TTBItemViewer; DrawTo: TCanvas; Offscreen: Boolean); const COLOR_MENUHILIGHT = 29; clMenuHighlight = TColor(COLOR_MENUHILIGHT or $80000000); var Bmp: TBitmap; DrawToDC, BmpDC: HDC; DrawCanvas: TCanvas; R1, R2, R3: TRect; IsOpen, IsSelected, IsPushed: Boolean; ToolbarStyle: Boolean; UseDisabledShadow: Boolean; SaveIndex, SaveIndex2: Integer; WindowOrg: TPoint; BkColor: TColor; begin ValidatePositions; if tbisInvalidated in Viewer.State then begin Offscreen := True; Exclude(Viewer.State, tbisInvalidated); end; R1 := Viewer.BoundsRect; if not Viewer.Show or IsRectEmpty(R1) or (Viewer.Item is TTBControlItem) then Exit; R2 := R1; OffsetRect(R2, -R2.Left, -R2.Top); IsOpen := FOpenViewer = Viewer; IsSelected := (FSelected = Viewer); IsPushed := IsSelected and (IsOpen or (FMouseOverSelected and FCapture)); ToolbarStyle := Viewer.IsToolbarStyle; DrawToDC := DrawTo.Handle; Bmp := nil; { Must deselect any currently selected handles before calling SaveDC, because if they are left selected and DeleteObject gets called on them after the SaveDC call, it will fail on Win9x/Me, and thus leak GDI resources. } DrawTo.Refresh; SaveIndex := SaveDC(DrawToDC); try IntersectClipRect(DrawToDC, R1.Left, R1.Top, R1.Right, R1.Bottom); GetClipBox(DrawToDC, R3); if IsRectEmpty(R3) then Exit; if not Offscreen then begin MoveWindowOrg(DrawToDC, R1.Left, R1.Top); { Tweak the brush origin so that the checked background drawn behind checked items always looks the same regardless of whether the item is positioned on an even or odd Left or Top coordinate. } if GetWindowOrgEx(DrawToDC, WindowOrg) then SetBrushOrgEx(DrawToDC, -WindowOrg.X, -WindowOrg.Y, nil); DrawCanvas := DrawTo; end else begin Bmp := TBitmap.Create; Bmp.Width := R2.Right; Bmp.Height := R2.Bottom; DrawCanvas := Bmp.Canvas; BmpDC := DrawCanvas.Handle; SaveIndex2 := SaveDC(BmpDC); SetWindowOrgEx(BmpDC, R1.Left, R1.Top, nil); FWindow.Perform(WM_ERASEBKGND, WPARAM(BmpDC), 0); RestoreDC(BmpDC, SaveIndex2); end; { Initialize brush } if not ToolbarStyle and IsSelected then begin {$IFNDEF TB2K_USE_STRICT_O2K_MENU_STYLE} if AreFlatMenusEnabled then { Windows XP uses a different fill color for selected menu items when flat menus are enabled } DrawCanvas.Brush.Color := clMenuHighlight else {$ENDIF} DrawCanvas.Brush.Color := clHighlight; end else DrawCanvas.Brush.Style := bsClear; { Initialize font } DrawCanvas.Font.Assign(GetFont); if Viewer.Item.Enabled then begin if not ToolbarStyle and IsSelected then DrawCanvas.Font.Color := clHighlightText else begin if ToolbarStyle then DrawCanvas.Font.Color := clBtnText else DrawCanvas.Font.Color := tbMenuTextColor; end; UseDisabledShadow := False; end else begin DrawCanvas.Font.Color := clGrayText; { Use the disabled shadow if either: 1. The item is a toolbar-style item. 2. The item is not selected, and the background color equals the button-face color. 3. The gray-text color is the same as the background color. Note: Windows actually uses dithered text in this case. } BkColor := ColorToRGB({$IFNDEF CLR}TControlAccess{$ENDIF}(FWindow).Color); UseDisabledShadow := ToolbarStyle or (not IsSelected and (BkColor = ColorToRGB(clBtnFace))) or (ColorToRGB(clGrayText) = BkColor); end; Viewer.Paint(DrawCanvas, R2, IsSelected, IsPushed, UseDisabledShadow); if Offscreen then BitBlt(DrawToDC, R1.Left, R1.Top, Bmp.Width, Bmp.Height, DrawCanvas.Handle, 0, 0, SRCCOPY); finally DrawTo.Refresh; { must do this before a RestoreDC } RestoreDC(DrawToDC, SaveIndex); Bmp.Free; end; end; procedure TTBView.DrawSubitems(ACanvas: TCanvas); var ClipRect: TRect; procedure DoDraw(const AViewer: TTBItemViewer); var Temp: TRect; begin { Speed optimization: Only call DrawItem on viewers that intersect the canvas's clipping rectangle. Without this check, moving the mouse across a toolbar with thousands of visible items uses 100% of the CPU. } if AViewer.Show and IntersectRect(Temp, ClipRect, AViewer.BoundsRect) then DrawItem(AViewer, ACanvas, False) else begin { Not going to draw the item. Go ahead and clear the tbisInvalidated flag if it's set so it won't needlessly double-buffer next time. } Exclude(AViewer.State, tbisInvalidated); end; end; var I: Integer; begin ValidatePositions; ClipRect := ACanvas.ClipRect; { Draw non-selected items before drawing the selected item, so that when the selection is changing there's no brief window in which two items appear to be selected } for I := 0 to FViewers.Count-1 do begin if (vsDrawInOrder in FState) or (Viewers[I] <> FSelected) then DoDraw(Viewers[I]); end; if not(vsDrawInOrder in FState) and Assigned(FSelected) then DoDraw(FSelected); Exclude(FState, vsDrawInOrder); end; procedure TTBView.Invalidate(AViewer: TTBItemViewer); begin if not FValidated or not Assigned(FWindow) or not FWindow.HandleAllocated then Exit; if AViewer.Show and not IsRectEmpty(AViewer.BoundsRect) and not(AViewer.Item is TTBControlItem) then begin Include(AViewer.State, tbisInvalidated); InvalidateRect(FWindow.Handle, {$IFNDEF CLR}@{$ENDIF} AViewer.BoundsRect, False); end; end; procedure TTBView.SetAccelsVisibility(AShowAccels: Boolean); var I: Integer; Viewer: TTBItemViewer; begin { Always show accels when keyboard cues are enabled } AShowAccels := AShowAccels or not(vsUseHiddenAccels in FStyle) or AreKeyboardCuesEnabled; if AShowAccels <> (vsShowAccels in FState) then begin if AShowAccels then Include(FState, vsShowAccels) else Exclude(FState, vsShowAccels); if Assigned(FWindow) and FWindow.HandleAllocated and IsWindowVisible(FWindow.Handle) then { ^ the visibility check is just an optimization } for I := 0 to FViewers.Count-1 do begin Viewer := Viewers[I]; if Viewer.CaptionShown and (FindAccelChar(Viewer.GetCaptionText) <> #0) then Invalidate(Viewer); end; end; end; function TTBView.FirstSelectable: TTBItemViewer; var FirstViewer: TTBItemViewer; begin Result := NextSelectable(nil, True); if Assigned(Result) then begin FirstViewer := Result; while tbisDontSelectFirst in Result.Item.ItemStyle do begin Result := NextSelectable(Result, True); if Result = FirstViewer then { don't loop endlessly if all items have the tbisDontSelectFirst style } Break; end; end; end; function TTBView.NextSelectable(CurViewer: TTBItemViewer; GoForward: Boolean): TTBItemViewer; var I, J: Integer; begin ValidatePositions; Result := nil; if FViewers.Count = 0 then Exit; J := -1; I := IndexOf(CurViewer); while True do begin if GoForward then begin Inc(I); if I >= FViewers.Count then I := 0; end else begin Dec(I); if I < 0 then I := FViewers.Count-1; end; if J = -1 then J := I else if I = J then Exit; if (Viewers[I].Show or Viewers[I].Clipped) and Viewers[I].Item.Visible and (tbisSelectable in Viewers[I].Item.ItemStyle) then Break; end; Result := Viewers[I]; end; function TTBView.NextSelectableWithAccel(CurViewer: TTBItemViewer; Key: Char; RequirePrimaryAccel: Boolean; var IsOnlyItemWithAccel: Boolean): TTBItemViewer; function IsAccelItem(const Index: Integer; const Primary, EnabledItems: Boolean): Boolean; var S: String; LastAccel: Char; Viewer: TTBItemViewer; Item: TTBCustomItem; begin Result := False; Viewer := Viewers[Index]; Item := Viewer.Item; if (Viewer.Show or Viewer.Clipped) and (tbisSelectable in Item.ItemStyle) and (Item.Enabled = EnabledItems) and Item.Visible and Viewer.CaptionShown then begin S := Viewer.GetCaptionText; if S <> '' then begin LastAccel := FindAccelChar(S); if Primary then begin if LastAccel <> #0 then Result := (CharToLower(LastAccel) = CharToLower(Key)); end else if (LastAccel = #0) and (Key <> ' ') then Result := (CharToLower(S[1]) = CharToLower(Key)); end; end; end; function FindAccel(I: Integer; const Primary, EnabledItems: Boolean): Integer; var J: Integer; begin Result := -1; J := -1; while True do begin Inc(I); if I >= FViewers.Count then I := 0; if J = -1 then J := I else if I = J then Break; if IsAccelItem(I, Primary, EnabledItems) then begin Result := I; Break; end; end; end; var Start, I: Integer; Primary, EnabledItems: Boolean; begin ValidatePositions; Result := nil; IsOnlyItemWithAccel := False; if FViewers.Count = 0 then Exit; Start := IndexOf(CurViewer); for Primary := True downto False do if not RequirePrimaryAccel or Primary then for EnabledItems := True downto False do begin I := FindAccel(Start, Primary, EnabledItems); if I <> -1 then begin Result := Viewers[I]; IsOnlyItemWithAccel := not EnabledItems or (FindAccel(I, Primary, EnabledItems) = I); Exit; end; end; end; procedure TTBView.EnterToolbarLoop(Options: TTBEnterToolbarLoopOptions); var ModalHandler: TTBModalHandler; begin if vsModal in FState then Exit; ModalHandler := TTBModalHandler.Create(FWindow.Handle); try { remove all states except... } FState := FState * [vsShowAccels]; try Include(FState, vsModal); { Must ensure that DoneAction is reset to tbdaNone *before* calling NotifyFocusEvent so that the IsModalEnding call it makes won't return True } FDoneActionData.DoneAction := tbdaNone; { Now that the vsModal state has been added, send an MSAA focus event } if Assigned(Selected) then NotifyFocusEvent; ModalHandler.Loop(Self, tbetMouseDown in Options, tbetExecuteSelected in Options, tbetFromMSAA in Options, False); finally { Remove vsModal state from the root view before any TTBView.Destroy methods get called (as a result of the CloseChildPopups call below), so that NotifyFocusEvent becomes a no-op } Exclude(FState, vsModal); StopAllTimers; CloseChildPopups; UpdateSelection(Point(Low(Integer), Low(Integer)), True); end; finally ModalHandler.Free; end; SetAccelsVisibility(False); ProcessDoneAction(FDoneActionData, False); end; procedure TTBView.SetCustomizing(Value: Boolean); begin if FCustomizing <> Value then begin FCustomizing := Value; RecreateAllViewers; end; end; procedure TTBView.BeginUpdate; begin Inc(FUpdating); end; procedure TTBView.EndUpdate; begin Dec(FUpdating); if FUpdating = 0 then TryValidatePositions; end; procedure TTBView.GetOffEdgeControlList(const List: TList); var I: Integer; Item: TTBCustomItem; begin for I := 0 to FViewers.Count-1 do begin Item := Viewers[I].Item; if (Item is TTBControlItem) and Viewers[I].OffEdge and (TTBControlItem(Item).FControl is TWinControl) then List.Add(TTBControlItem(Item).FControl); end; end; procedure TTBView.SetCapture; begin FCapture := True; end; procedure TTBView.CancelCapture; begin if FCapture then begin FCapture := False; LastPos.X := Low(LastPos.X); if Assigned(FSelected) then FSelected.LosingCapture; end; end; procedure TTBView.KeyDown(var Key: Word; Shift: TShiftState); procedure SelNextItem(const ParentView: TTBView; const GoForward: Boolean); begin ParentView.Selected := ParentView.NextSelectable(ParentView.FSelected, GoForward); ParentView.ScrollSelectedIntoView; end; procedure HelpKey; var V: TTBView; ContextID: Integer; begin ContextID := 0; V := Self; while Assigned(V) do begin if Assigned(V.FSelected) then begin ContextID := V.FSelected.Item.HelpContext; if ContextID <> 0 then Break; end; V := V.FParentView; end; if ContextID <> 0 then EndModalWithHelp(ContextID); end; var ParentTBView: TTBView; begin ParentTBView := GetParentToolbarView; case Key of VK_TAB: begin SelNextItem(Self, GetKeyState(VK_SHIFT) >= 0); end; VK_RETURN: begin ExecuteSelected(True); end; VK_MENU, VK_F10: begin EndModal; end; VK_ESCAPE: begin Key := 0; if FParentView = nil then EndModal else FParentView.CancelChildPopups; end; VK_LEFT, VK_RIGHT: begin if (Self = ParentTBView) and (Orientation = tbvoVertical) then OpenChildPopup(True) else if Key = VK_LEFT then begin if Assigned(ParentTBView) and (ParentTBView.Orientation <> tbvoVertical) then begin if (Self = ParentTBView) or (FParentView = ParentTBView) then SelNextItem(ParentTBView, False) else FParentView.CloseChildPopups; end else begin if Assigned(FParentView) then FParentView.CancelChildPopups; end; end else begin if ((Self = ParentTBView) or not OpenChildPopup(True)) and (Assigned(ParentTBView) and (ParentTBView.Orientation <> tbvoVertical)) then begin { If we're on ParentTBView, or if the selected item can't display a submenu, proceed to next item on ParentTBView } SelNextItem(ParentTBView, True); end; end; end; VK_UP, VK_DOWN: begin if (Self = ParentTBView) and (Orientation <> tbvoVertical) then OpenChildPopup(True) else SelNextItem(Self, Key = VK_DOWN); end; VK_HOME, VK_END: begin Selected := NextSelectable(nil, Key = VK_HOME); ScrollSelectedIntoView; end; VK_F1: HelpKey; else Exit; { don't set Key to 0 for unprocessed keys } end; Key := 0; end; function TTBView.IsModalEnding: Boolean; begin Result := (GetRootView.FDoneActionData.DoneAction <> tbdaNone); end; procedure TTBView.EndModal; var RootView: TTBView; begin RootView := GetRootView; RootView.FDoneActionData.DoneAction := tbdaCancel; end; procedure TTBView.EndModalWithClick(AViewer: TTBItemViewer); var RootView: TTBView; begin RootView := GetRootView; RootView.FDoneActionData.ClickItem := AViewer.Item; RootView.FDoneActionData.Sound := AViewer.FView.FIsPopup; RootView.FDoneActionData.DoneAction := tbdaClickItem; end; procedure TTBView.EndModalWithHelp(AContextID: Integer); var RootView: TTBView; begin RootView := GetRootView; RootView.FDoneActionData.ContextID := AContextID; RootView.FDoneActionData.DoneAction := tbdaHelpContext; end; procedure TTBView.EndModalWithSystemMenu(AWnd: HWND; AKey: Word); var RootView: TTBView; begin RootView := GetRootView; RootView.FDoneActionData.Wnd := AWnd; RootView.FDoneActionData.Key := AKey; RootView.FDoneActionData.DoneAction := tbdaOpenSystemMenu; end; procedure TTBView.ExecuteSelected(AGivePriority: Boolean); { Normally called after an Enter or accelerator key press on the view, this method 'executes' or opens the selected item. It ends the modal loop, except when a submenu is opened. } var Item: TTBCustomItem; begin if Assigned(FSelected) and FSelected.Item.Enabled then begin Item := FSelected.Item; if (tbisCombo in Item.ItemStyle) or not OpenChildPopup(True) then begin if tbisSelectable in Item.ItemStyle then FSelected.Execute(AGivePriority) else EndModal; end end else EndModal; {$IFNDEF CLR} Exit; asm db 0,'Toolbar2000 (C) 1998-2008 Jordan Russell',0 end; {$ENDIF} end; procedure TTBView.Scroll(ADown: Boolean); var CurPos, NewPos, I: Integer; begin ValidatePositions; if ADown then begin NewPos := High(NewPos); CurPos := FMaxHeight - tbMenuScrollArrowHeight; for I := 0 to FViewers.Count-1 do begin with Viewers[I] do if Clipped and not(tbisSeparator in Item.ItemStyle) and (BoundsRect.Bottom < NewPos) and (BoundsRect.Bottom > CurPos) then NewPos := BoundsRect.Bottom; end; if NewPos = High(NewPos) then Exit; Dec(NewPos, FMaxHeight - tbMenuScrollArrowHeight); end else begin NewPos := Low(NewPos); CurPos := tbMenuScrollArrowHeight; for I := 0 to FViewers.Count-1 do begin with Viewers[I] do if Clipped and not(tbisSeparator in Item.ItemStyle) and (BoundsRect.Top > NewPos) and (BoundsRect.Top < CurPos) then NewPos := BoundsRect.Top; end; if NewPos = Low(NewPos) then Exit; Dec(NewPos, tbMenuScrollArrowHeight); end; Inc(FScrollOffset, NewPos); UpdatePositions; end; procedure TTBView.ScrollSelectedIntoView; begin ValidatePositions; if (FSelected = nil) or not FSelected.Clipped then Exit; if FSelected.BoundsRect.Top < tbMenuScrollArrowHeight then begin Dec(FScrollOffset, tbMenuScrollArrowHeight - FSelected.BoundsRect.Top); UpdatePositions; end else if FSelected.BoundsRect.Bottom > FMaxHeight - tbMenuScrollArrowHeight then begin Dec(FScrollOffset, (FMaxHeight - tbMenuScrollArrowHeight) - FSelected.BoundsRect.Bottom); UpdatePositions; end; end; procedure TTBView.SetUsePriorityList(Value: Boolean); begin if FUsePriorityList <> Value then begin FUsePriorityList := Value; RecreateAllViewers; end; end; function TTBView.GetCaptureWnd: HWND; begin Result := GetRootView.FCaptureWnd; end; procedure TTBView.CancelMode; var View: TTBView; begin EndModal; { Hide all parent/child popup windows. Can't actually destroy them using CloseChildPopups because this method may be called while inside TTBEditItemViewer's message loop, and it could result in the active TTBEditItemViewer instance being destroyed (leading to an AV). } View := Self; while Assigned(View.FOpenViewerView) do View := View.FOpenViewerView; repeat View.StopAllTimers; if View.FWindow is TTBPopupWindow then View.FWindow.Visible := False; View := View.FParentView; until View = nil; { Note: This doesn't remove the selection from a top-level toolbar item. Unfortunately, we can't do 'Selected := nil' because it would destroy child popups and that must'nt happen for the reason stated above. } end; procedure TTBView.HandleHintShowMessage(var Message: TCMHintShow); procedure UpdateInfo(var Info: {$IFDEF JR_D12}Controls.{$ENDIF} THintInfo); var V: TTBItemViewer; begin Info.HintStr := ''; V := ViewerFromPoint(Info.CursorPos); if Assigned(V) then begin Info.CursorRect := V.BoundsRect; Info.HintStr := V.GetHintText; Info.HintData := V; end; end; {$IFNDEF CLR} begin UpdateInfo(Message.HintInfo^); end; {$ELSE} var Info: THintInfo; begin Info := Message.HintInfo; UpdateInfo(Info); Message.HintInfo := Info; end; {$ENDIF} { TTBModalHandler } constructor TTBModalHandler.Create(AExistingWnd: HWND); procedure RemoveFocusIfOnOtherThread; { This ensures that the message loop will receive key messages when an Adobe Reader (8.1.2) control embedded in a TWebBrowser is currently focused. The Reader control is actually hosted in a separate thread (in a separate process, AcroRd32.exe). When Alt/Alt+[letter] is pressed, Reader calls GetAncestor(..., GA_ROOT) and forwards the WM_SYSCOMMAND/WM_SYSCHAR message to that window using SendMessage (not PostMessage, for some reason). The focus, however, is left on the Reader control. Consequently, any keystrokes will generate key messages in the Reader thread's queue instead of ours. To avoid that, call SetFocus(0) to remove the focus if it's currently on another thread's window. When no window has the focus, key messages will be posted to the active window, which *should* be a form owned by the same thread as us. } var FocusWnd: HWND; begin FocusWnd := GetFocus; if (FocusWnd <> 0) and (GetWindowThreadProcessId(FocusWnd, nil) <> GetCurrentThreadId) then begin FSaveFocusWnd := FocusWnd; SetFocus(0); end; end; begin inherited Create; LastPos := GetMessagePosAsPoint; if AExistingWnd <> 0 then FWnd := AExistingWnd else begin FWnd := {$IFDEF ALLOCHWND_CLASSES}Classes.{$ENDIF} AllocateHWnd(WndProc); FCreatedWnd := True; end; RemoveFocusIfOnOtherThread; { Like standard menus, don't allow other apps to steal the focus during our modal loop. This also prevents us from losing activation when "active window tracking" is enabled and the user moves the mouse over another application's window. } CallLockSetForegroundWindow(True); SetCapture(FWnd); SetCursor(LoadCursor(0, IDC_ARROW)); CallNotifyWinEvent(EVENT_SYSTEM_MENUSTART, FWnd, OBJID_CLIENT, CHILDID_SELF); FInited := True; end; destructor TTBModalHandler.Destroy; begin CallLockSetForegroundWindow(False); if FWnd <> 0 then begin if GetCapture = FWnd then ReleaseCapture; if FInited then CallNotifyWinEvent(EVENT_SYSTEM_MENUEND, FWnd, OBJID_CLIENT, CHILDID_SELF); if FCreatedWnd then {$IFDEF ALLOCHWND_CLASSES}Classes.{$ENDIF} DeallocateHWnd(FWnd); end; if (FSaveFocusWnd <> 0) and (GetFocus = 0) then SetFocus(FSaveFocusWnd); inherited; end; procedure TTBModalHandler.WndProc(var Msg: TMessage); begin Msg.Result := DefWindowProc(FWnd, Msg.Msg, Msg.WParam, Msg.LParam); if (Msg.Msg = WM_CANCELMODE) and Assigned(FRootPopup) then begin try { We can receive a WM_CANCELMODE message during a modal loop if a dialog pops up. Respond by hiding menus to make it look like the modal loop has returned, even though it really hasn't yet. Note: Similar code in TTBCustomToolbar.WMCancelMode. } FRootPopup.View.CancelMode; except Application.HandleException(Self); end; end; end; procedure TTBModalHandler.Loop(const RootView: TTBView; const AMouseDown, AExecuteSelected, AFromMSAA, TrackRightButton: Boolean); var OriginalActiveWindow: HWND; function GetActiveView: TTBView; begin Result := RootView; while Assigned(Result.FOpenViewerView) do Result := Result.FOpenViewerView; end; function GetCaptureView: TTBView; begin Result := RootView; while Assigned(Result) and not Result.FCapture do Result := Result.FOpenViewerView; end; procedure UpdateAllSelections(const P: TPoint; const AllowNewSelection: Boolean); var View, CapView: TTBView; begin View := GetActiveView; CapView := GetCaptureView; while Assigned(View) do begin if (CapView = nil) or (View = CapView) then View.UpdateSelection(P, AllowNewSelection); View := View.FParentView; end; end; function GetSelectedViewer(var AView: TTBView; var AViewer: TTBItemViewer): Boolean; { Returns True if AViewer <> nil. } var View: TTBView; begin { Look for a capture item first } AView := GetCaptureView; if Assigned(AView) then AViewer := AView.FSelected else begin AView := nil; AViewer := nil; View := RootView; repeat if Assigned(View.FSelected) and View.FMouseOverSelected then begin AView := View; AViewer := View.FSelected; Break; end; if vsMouseInWindow in View.FState then begin { ...there is no current selection, but the mouse is still in the window. This can happen if the mouse is over the non-client area of the toolbar or popup window, or in an area not containing an item. } AView := View; Break; end; View := View.FOpenViewerView; until View = nil; end; Result := Assigned(AViewer); end; function ContinueLoop: Boolean; begin { Don't continue if the mouse capture is lost, if a (modeless) top-level window is shown causing the active window to change, or if EndModal* was called. } Result := (GetCapture = FWnd) and (GetActiveWindow = OriginalActiveWindow) and not RootView.IsModalEnding; end; function SendKeyEvent(const View: TTBView; var Key: Word; const Shift: TShiftState): Boolean; begin Result := True; if Assigned(View.FSelected) then begin View.FSelected.KeyDown(Key, Shift); if RootView.IsModalEnding then Exit; end; if Key <> 0 then begin View.KeyDown(Key, Shift); if RootView.IsModalEnding then Exit; end; Result := False; end; procedure DoHintMouseMessage(const Ctl: TControl; const P: TPoint); var M: TMessage; begin {$IFDEF CLR} M := TMessage.Create; {$ENDIF} M.Msg := WM_MOUSEMOVE; M.WParam := 0; M.LParam := MAKELPARAM(Word(P.X), Word(P.Y)); M.Result := 0; Application.HintMouseMessage(Ctl, M); end; procedure MouseMoved; var Cursor: HCURSOR; View: TTBView; Viewer: TTBItemViewer; P: TPoint; begin UpdateAllSelections(LastPos, True); Cursor := 0; if GetSelectedViewer(View, Viewer) then begin P := View.FWindow.ScreenToClient(LastPos); if ((vsAlwaysShowHints in View.FStyle) or (tboShowHint in Viewer.Item.FEffectiveOptions)) and not View.FCapture then begin { Display popup hint for the item. Update is called first to minimize flicker caused by the hiding & showing of the hint window. } View.FWindow.Update; DoHintMouseMessage(View.FWindow, P); end else Application.CancelHint; Dec(P.X, Viewer.BoundsRect.Left); Dec(P.Y, Viewer.BoundsRect.Top); Viewer.GetCursor(P, Cursor); end else Application.CancelHint; if Cursor = 0 then Cursor := LoadCursor(0, IDC_ARROW); SetCursor(Cursor); if Assigned(Viewer) then Viewer.MouseMove(P.X, P.Y); end; procedure UpdateAppHint; var View: TTBView; begin View := RootView; while Assigned(View.FOpenViewerView) and Assigned(View.FOpenViewerView.FSelected) do View := View.FOpenViewerView; if Assigned(View.FSelected) then Application.Hint := GetLongHint(View.FSelected.Item.Hint) else Application.Hint := ''; end; procedure HandleTimer(const View: TTBView; const ID: TTBViewTimerID); begin case ID of tiOpen: begin { Similar to standard menus, always close child popups, even if Selected = OpenViewer. Note: CloseChildPopups and OpenChildPopup will stop the tiClose and tiOpen timers respectively. } View.CloseChildPopups; View.OpenChildPopup(False); end; tiClose: begin { Note: CloseChildPopups stops the tiClose timer. } View.CloseChildPopups; end; tiScrollUp: begin if View.FShowUpArrow then View.Scroll(False) else View.StopTimer(tiScrollUp); end; tiScrollDown: begin if View.FShowDownArrow then View.Scroll(True) else View.StopTimer(tiScrollDown); end; end; end; var MouseDownOnMenu: Boolean; Msg: TMsg; P: TPoint; Ctl: TControl; View: TTBView; ConvertedKey: Char; IsOnlyItemWithAccel: Boolean; MouseIsDown: Boolean; Key: Word; Shift: TShiftState; Viewer: TTBItemViewer; begin RootView.FDoneActionData.DoneAction := tbdaNone; RootView.ValidatePositions; try try RootView.FCaptureWnd := FWnd; MouseDownOnMenu := False; if AMouseDown then begin P := RootView.FSelected.ScreenToClient(GetMessagePosAsPoint); RootView.FSelected.MouseDown([], P.X, P.Y, MouseDownOnMenu); if RootView.IsModalEnding then Exit; MouseDownOnMenu := False; { never set MouseDownOnMenu to True on first click } end else if AExecuteSelected then begin RootView.ExecuteSelected(not AFromMSAA); if RootView.IsModalEnding then Exit; end; OriginalActiveWindow := GetActiveWindow; while ContinueLoop do begin TBUpdateAnimation; { Examine the next message before popping it out of the queue } if not PeekMessage(Msg, 0, 0, 0, PM_NOREMOVE) then begin { No message available; wait for one to arrive } if TBIsAnimationInProgress then { While animating, if no message arrives within 1 ms, loop back and call TBUpdateAnimation again to see if it's ready for a new frame. Note: We don't use a timer to call TBUpdateAnimation because on Windows 98, timers only have a resolution of 55 ms in my tests, too poor for smooth animation. (timeBeginPeriod does not help.) Sleep and MsgWaitForMultipleObjects, on the other hand, appear to have a resolution of 5 ms by default. (Better resolution is possible with a call to timeBeginPeriod, but we don't need it.) Note: On 2000/XP, timers and Sleep both have a resolution of 10-15 ms by default. } MsgWaitForMultipleObjects(0, {$IFNDEF CLR} THandle(nil^) {$ELSE} [] {$ENDIF}, False, 1, QS_ALLINPUT) else WaitMessage; Continue; end; case Msg.message of WM_LBUTTONDOWN, WM_RBUTTONDOWN: begin P := Msg.pt; Ctl := FindDragTarget(P, True); { Was the mouse not clicked on a popup, or was it clicked on a popup that is not a child of RootView? (The latter can happen when in customization mode, for example, if the user right-clicks a popup menu being customized and the context menu is displayed.) } if not(Ctl is TTBPopupWindow) or not RootView.ContainsView(TTBPopupWindow(Ctl).View) then begin { If the root view is a popup, or if the root view is a toolbar and the user clicked outside the toolbar or in its non-client area (e.g. on its drag handle), exit } if RootView.FIsPopup or (Ctl <> RootView.FWindow) or not PtInRect(RootView.FWindow.ClientRect, RootView.FWindow.ScreenToClient(P)) then Exit else if Msg.message = WM_LBUTTONDOWN then begin { If the user clicked inside a toolbar on anything but an item, exit } UpdateAllSelections(P, True); if (RootView.FSelected = nil) or not RootView.FMouseOverSelected or (tbisClicksTransparent in RootView.FSelected.Item.ItemStyle) then Exit; end; end; end; end; { Now pop the message out of the queue } if not PeekMessage(Msg, 0, Msg.message, Msg.message, PM_REMOVE or PM_NOYIELD) then Continue; case Msg.message of $4D: { This undocumented message is sent to the focused window when F1 is pressed. Windows handles it by sending a WM_HELP message to the same window. We don't want this to happen while a menu is up, so swallow the message. } ; WM_CONTEXTMENU: { Windows still sends WM_CONTEXTMENU messages for "context menu" keystrokes even if WM_KEYUP messages are never dispatched, so it must specifically ignore this message } ; WM_KEYFIRST..WM_KEYLAST: begin Application.CancelHint; MouseIsDown := (GetKeyState(VK_LBUTTON) < 0) or (TrackRightButton and (GetKeyState(VK_RBUTTON) < 0)); case Msg.message of WM_KEYDOWN, WM_SYSKEYDOWN: begin if Msg.wParam = VK_PROCESSKEY then { Don't let IME process the key } Msg.wParam := WPARAM(ImmGetVirtualKey(Msg.hwnd)); Key := Word(Msg.wParam); if not MouseIsDown or (Key = VK_F1) then begin if SendKeyEvent(GetActiveView, Key, KeyDataToShiftState(ClipToLongint(Msg.lParam))) then Exit; { If it's not handled by a KeyDown method, translate it into a WM_*CHAR message } if Key <> 0 then TranslateMessage(Msg); end; end; WM_CHAR, WM_SYSCHAR: if not MouseIsDown then begin Key := Word(Msg.wParam); View := GetActiveView; {$IFDEF CLR} { On .NET, under Windows 9x/Me we must convert the character code from ANSI->Unicode. (We shouldn't get any double-byte characters due to our VK_PROCESSKEY handling above.) } if Marshal.SystemDefaultCharSize = 1 then ConvertedKey := Encoding.GetEncoding(GetInputLocaleCodePage). GetChars([Byte(Key)])[0] else {$ENDIF} ConvertedKey := Chr(Key); Viewer := View.NextSelectableWithAccel(View.FSelected, ConvertedKey, False, IsOnlyItemWithAccel); if Viewer = nil then begin if (Key in [VK_SPACE, Ord('-')]) and not RootView.FIsPopup and (View = RootView) and (GetActiveWindow <> 0) then begin RootView.EndModalWithSystemMenu(GetActiveWindow, Key); Exit; end else MessageBeep(0); end else begin View.Selected := Viewer; View.ScrollSelectedIntoView; if IsOnlyItemWithAccel then View.ExecuteSelected(True); end; end; end; end; WM_TIMER: begin Ctl := FindControl(Msg.hwnd); if Assigned(Ctl) and (Ctl is TTBPopupWindow) and (Msg.wParam >= ViewTimerBaseID + Ord(Low(TTBViewTimerID))) and (Msg.wParam <= ViewTimerBaseID + Ord(High(TTBViewTimerID))) then begin if Assigned(TTBPopupWindow(Ctl).FView) then HandleTimer(TTBPopupWindow(Ctl).FView, TTBViewTimerID(Msg.wParam - ViewTimerBaseID)); end else DispatchMessage(Msg); end; $118: ; { ^ Like standard menus, don't dispatch WM_SYSTIMER messages (the internal Windows message used for things like caret blink and list box scrolling). } WM_MOUSEFIRST..WM_MOUSELAST: case Msg.message of WM_MOUSEMOVE: begin if (Msg.pt.X <> LastPos.X) or (Msg.pt.Y <> LastPos.Y) then begin LastPos := Msg.pt; MouseMoved; end; end; WM_MOUSEWHEEL: if GetSelectedViewer(View, Viewer) then begin P := Viewer.ScreenToClient(Msg.pt); Viewer.MouseWheel(Smallint(Msg.wParam shr 16), P.X, P.Y); end; WM_LBUTTONDOWN, WM_LBUTTONDBLCLK, WM_RBUTTONDOWN: if (Msg.message <> WM_RBUTTONDOWN) or TrackRightButton then begin Application.CancelHint; MouseDownOnMenu := False; Exclude(RootView.FState, vsIgnoreFirstMouseUp); UpdateAllSelections(Msg.pt, True); if GetSelectedViewer(View, Viewer) then begin if Msg.message <> WM_LBUTTONDBLCLK then Shift := [] else Shift := [ssDouble]; P := Viewer.ScreenToClient(Msg.pt); Viewer.MouseDown(Shift, P.X, P.Y, MouseDownOnMenu); LastPos := GetMessagePosAsPoint; end; end; WM_LBUTTONUP, WM_RBUTTONUP: if (Msg.message = WM_LBUTTONUP) or TrackRightButton then begin UpdateAllSelections(Msg.pt, False); { ^ False is used so that when a popup menu is displayed with the cursor currently inside it, the item under the cursor won't be accidentally selected when the user releases the button. The user must move the mouse at at least one pixel (generating a WM_MOUSEMOVE message), and then release the button. } if not GetSelectedViewer(View, Viewer) then begin { Mouse was not released over any item. Cancel out of the loop if it's outside all views, or is inside unused space on a topmost toolbar } if not Assigned(View) or ((View = RootView) and RootView.FIsToolbar) then begin if not(vsIgnoreFirstMouseUp in RootView.FState) then Exit else Exclude(RootView.FState, vsIgnoreFirstMouseUp); end; end else begin P := Viewer.ScreenToClient(Msg.pt); Viewer.MouseUp(P.X, P.Y, MouseDownOnMenu); end; end; end; else DispatchMessage(Msg); end; if not ContinueLoop then Exit; if LastPos.X = Low(LastPos.X) then begin { The capture was released; generate a fake mouse movement to update the selection } LastPos := GetMessagePosAsPoint; MouseMoved; end; UpdateAppHint; end; finally RootView.CancelCapture; end; finally RootView.FCaptureWnd := 0; Application.Hint := ''; { Make sure there are no outstanding WM_*CHAR messages } RemoveMessages(WM_CHAR, WM_DEADCHAR); RemoveMessages(WM_SYSCHAR, WM_SYSDEADCHAR); { Nor any outstanding 'send WM_HELP' messages caused by an earlier press of the F1 key } RemoveMessages($4D, $4D); end; end; { TTBPopupView } procedure TTBPopupView.AutoSize(AWidth, AHeight: Integer); begin with FWindow do SetBounds(Left, Top, AWidth + (PopupMenuWindowNCSize * 2), AHeight + (PopupMenuWindowNCSize * 2)); end; function TTBPopupView.GetFont: TFont; begin Result := (Owner as TTBPopupWindow).Font; end; { TTBPopupWindow } constructor TTBPopupWindow.CreatePopupWindow(AOwner: TComponent; const AParentView: TTBView; const AItem: TTBCustomItem; const ACustomizing: Boolean); begin inherited Create(AOwner); Visible := False; SetBounds(0, 0, 320, 240); ControlStyle := ControlStyle - [csCaptureMouse]; ShowHint := True; Color := tbMenuBkColor; FView := GetViewClass.Create(Self, AParentView, AItem, Self, False, ACustomizing, False); Include(FView.FState, vsModal); { Inherit the font from the parent view, or use the system menu font if there is no parent view } if Assigned(AParentView) then Font.Assign(AParentView.GetFont) else Font.Assign(ToolbarFont); { Inherit the accelerator visibility state from the parent view. If there is no parent view (i.e. it's a standalone popup menu), then default to hiding accelerator keys, but change this in CreateWnd if the last input came from the keyboard. } if Assigned(AParentView) then begin if vsUseHiddenAccels in AParentView.FStyle then Include(FView.FStyle, vsUseHiddenAccels); if vsShowAccels in AParentView.FState then Include(FView.FState, vsShowAccels); end else Include(FView.FStyle, vsUseHiddenAccels); if Application.Handle <> 0 then { Use Application.Handle if possible so that the taskbar button for the app doesn't pop up when a TTBEditItem on a popup menu is focused } ParentWindow := Application.Handle else { When Application.Handle is zero, use GetDesktopWindow() as the parent window, not zero, otherwise UpdateControlState won't show the window } ParentWindow := GetDesktopWindow; end; destructor TTBPopupWindow.Destroy; begin Destroying; { Before destroying the window handle we need to close any child popups so that pixels behind the popups are properly restored without generating a WM_PAINT message. } if Assigned(FView) then FView.CloseChildPopups; { Ensure window handle is destroyed *before* FView is freed, since DestroyWindowHandle calls CallNotifyWinEvent which may result in FView.HandleWMObject being called } if HandleAllocated then DestroyWindowHandle; FreeAndNil(FView); inherited; end; function TTBPopupWindow.GetViewClass: TTBViewClass; begin Result := TTBPopupView; end; procedure TTBPopupWindow.CreateParams(var Params: TCreateParams); const CS_DROPSHADOW = $00020000; begin inherited; with Params do begin Style := (Style and not (WS_CHILD or WS_GROUP or WS_TABSTOP)) or WS_POPUP; ExStyle := ExStyle or WS_EX_TOPMOST or WS_EX_TOOLWINDOW; WindowClass.Style := WindowClass.Style or CS_SAVEBITS; { Enable drop shadow effect on Windows XP and later } if IsWindowsXP then WindowClass.Style := WindowClass.Style or CS_DROPSHADOW; end; end; procedure TTBPopupWindow.CreateWnd; const WM_CHANGEUISTATE = $0127; WM_QUERYUISTATE = $0129; UIS_INITIALIZE = 3; UISF_HIDEACCEL = $2; var B: Boolean; begin inherited; { On a top-level popup window, send WM_CHANGEUISTATE & WM_QUERYUISTATE messages to the window to see if the last input came from the keyboard and if the accelerator keys should be shown } if (FView.ParentView = nil) and not FAccelsVisibilitySet then begin FAccelsVisibilitySet := True; SendMessage(Handle, WM_CHANGEUISTATE, UIS_INITIALIZE, 0); B := (SendMessage(Handle, WM_QUERYUISTATE, 0, 0) and UISF_HIDEACCEL = 0); FView.SetAccelsVisibility(B); end; end; procedure TTBPopupWindow.DestroyWindowHandle; begin { Before destroying the window handle, we must stop any animation, otherwise the animation thread will use an invalid handle } TBEndAnimation(WindowHandle); { Cleanly destroy any timers before the window handle is destroyed } if Assigned(FView) then FView.StopAllTimers; CallNotifyWinEvent(EVENT_SYSTEM_MENUPOPUPEND, WindowHandle, OBJID_CLIENT, CHILDID_SELF); inherited; end; procedure TTBPopupWindow.WMGetObject(var Message: TMessage); begin if not FView.HandleWMGetObject(Message) then inherited; end; procedure TTBPopupWindow.CMShowingChanged(var Message: TMessage); const ShowFlags: array[Boolean] of UINT = ( SWP_NOSIZE or SWP_NOMOVE or SWP_NOZORDER or SWP_NOACTIVATE or SWP_HIDEWINDOW, SWP_NOSIZE or SWP_NOMOVE or SWP_NOZORDER or SWP_NOACTIVATE or SWP_SHOWWINDOW); SPI_GETMENUFADE = $1012; var Blend: Boolean; begin { Must override TCustomForm/TForm's CM_SHOWINGCHANGED handler so that the form doesn't get activated when Visible is set to True. } { Handle animation. NOTE: I do not recommend trying to enable animation on Windows 95 and NT 4.0 because there's a difference in the way the SetWindowPos works on those versions. See the comment in the TBStartAnimation function of TB2Anim.pas. } {$IFNDEF TB2K_NO_ANIMATION} if ((FView.ParentView = nil) or not(vsNoAnimation in FView.FParentView.FState)) and Showing and (FView.Selected = nil) and not IsWindowVisible(WindowHandle) and GetSystemParametersInfoBool(SPI_GETMENUANIMATION, False) then begin Blend := GetSystemParametersInfoBool(SPI_GETMENUFADE, False); if Blend or (FAnimationDirection <> []) then begin TBStartAnimation(WindowHandle, Blend, FAnimationDirection); Exit; end; end; {$ENDIF} { No animation... } if not Showing then begin { Call TBEndAnimation to ensure WS_EX_LAYERED style is removed before hiding, otherwise windows under the popup window aren't repainted properly. } TBEndAnimation(WindowHandle); end; SetWindowPos(WindowHandle, 0, 0, 0, 0, 0, ShowFlags[Showing]); end; procedure TTBPopupWindow.WMEraseBkgnd(var Message: TWMEraseBkgnd); begin { May be necessary in some cases... } TBEndAnimation(WindowHandle); inherited; end; procedure TTBPopupWindow.WMPaint(var Message: TWMPaint); begin { Must abort animation when a WM_PAINT message is received } TBEndAnimation(WindowHandle); inherited; end; procedure TTBPopupWindow.Paint; begin FView.DrawSubitems(Canvas); PaintScrollArrows; end; procedure TTBPopupWindow.PaintScrollArrows; procedure DrawArrow(const R: TRect; ADown: Boolean); var X, Y: Integer; P: array[0..2] of TPoint; begin X := (R.Left + R.Right) div 2; Y := (R.Top + R.Bottom) div 2; Dec(Y); P[0].X := X-3; P[0].Y := Y; P[1].X := X+3; P[1].Y := Y; P[2].X := X; P[2].Y := Y; if ADown then Inc(P[2].Y, 3) else begin Inc(P[0].Y, 3); Inc(P[1].Y, 3); end; Canvas.Pen.Color := tbMenuTextColor; Canvas.Brush.Color := tbMenuTextColor; Canvas.Polygon(P); end; begin if FView.FShowUpArrow then DrawArrow(Rect(0, 0, ClientWidth, tbMenuScrollArrowHeight), False); if FView.FShowDownArrow then DrawArrow(Bounds(0, ClientHeight - tbMenuScrollArrowHeight, ClientWidth, tbMenuScrollArrowHeight), True); end; procedure TTBPopupWindow.WMClose(var Message: TWMClose); begin { do nothing -- ignore Alt+F4 keypresses } end; procedure TTBPopupWindow.WMNCCalcSize(var Message: TWMNCCalcSize); procedure ApplyToRect(var R: TRect); begin InflateRect(R, -PopupMenuWindowNCSize, -PopupMenuWindowNCSize); end; {$IFDEF CLR} var Params: TNCCalcSizeParams; {$ENDIF} begin {$IFNDEF CLR} ApplyToRect(Message.CalcSize_Params.rgrc[0]); {$ELSE} Params := Message.CalcSize_Params; ApplyToRect(Params.rgrc0); Message.CalcSize_Params := Params; {$ENDIF} inherited; end; procedure PopupWindowNCPaintProc(Wnd: HWND; DC: HDC; AppData: TObject); var R: TRect; {$IFNDEF TB2K_USE_STRICT_O2K_MENU_STYLE} Brush: HBRUSH; {$ENDIF} begin GetWindowRect(Wnd, R); OffsetRect(R, -R.Left, -R.Top); {$IFNDEF TB2K_USE_STRICT_O2K_MENU_STYLE} if not AreFlatMenusEnabled then begin {$ENDIF} DrawEdge(DC, R, EDGE_RAISED, BF_RECT or BF_ADJUST); FrameRect(DC, R, GetSysColorBrush(COLOR_BTNFACE)); {$IFNDEF TB2K_USE_STRICT_O2K_MENU_STYLE} end else begin FrameRect(DC, R, GetSysColorBrush(COLOR_BTNSHADOW)); Brush := CreateSolidBrush(ColorToRGB(TTBPopupWindow(AppData).Color)); InflateRect(R, -1, -1); FrameRect(DC, R, Brush); InflateRect(R, -1, -1); FrameRect(DC, R, Brush); DeleteObject(Brush); end; {$ENDIF} end; procedure TTBPopupWindow.WMNCPaint(var Message: TMessage); var DC: HDC; begin DC := GetWindowDC(Handle); try SelectNCUpdateRgn(Handle, DC, HRGN(Message.WParam)); PopupWindowNCPaintProc(Handle, DC, Self); finally ReleaseDC(Handle, DC); end; end; procedure TTBPopupWindow.WMPrint(var Message: TMessage); begin HandleWMPrint(Handle, Message, PopupWindowNCPaintProc, Self); end; procedure TTBPopupWindow.WMPrintClient(var Message: {$IFNDEF CLR} TMessage {$ELSE} TWMPrintClient {$ENDIF}); begin HandleWMPrintClient(PaintHandler, Message); end; procedure TTBPopupWindow.CMHintShow(var Message: TCMHintShow); begin FView.HandleHintShowMessage(Message); end; { TTBItemContainer } constructor TTBItemContainer.Create(AOwner: TComponent); begin inherited; FItem := TTBRootItem.Create(Self); FItem.ParentComponent := Self; end; destructor TTBItemContainer.Destroy; begin FItem.Free; inherited; end; function TTBItemContainer.GetItems: TTBCustomItem; begin Result := FItem; end; procedure TTBItemContainer.GetChildren(Proc: TGetChildProc; Root: TComponent); begin FItem.GetChildren(Proc, Root); end; function TTBItemContainer.GetImages: TCustomImageList; begin Result := FItem.SubMenuImages; end; procedure TTBItemContainer.SetImages(Value: TCustomImageList); begin FItem.SubMenuImages := Value; end; { TTBPopupMenu } constructor TTBPopupMenu.Create(AOwner: TComponent); begin inherited; FItem := GetRootItemClass.Create(Self); FItem.ParentComponent := Self; FItem.OnClick := RootItemClick; end; destructor TTBPopupMenu.Destroy; begin FItem.Free; inherited; end; function TTBPopupMenu.GetItems: TTBCustomItem; begin Result := FItem; end; procedure TTBPopupMenu.GetChildren(Proc: TGetChildProc; Root: TComponent); begin FItem.GetChildren(Proc, Root); end; procedure TTBPopupMenu.SetChildOrder(Child: TComponent; Order: Integer); begin FItem.SetChildOrder(Child, Order); end; function TTBPopupMenu.GetRootItemClass: TTBRootItemClass; begin Result := TTBRootItem; end; function TTBPopupMenu.GetImages: TCustomImageList; begin Result := FItem.SubMenuImages; end; function TTBPopupMenu.GetLinkSubitems: TTBCustomItem; begin Result := FItem.LinkSubitems; end; function TTBPopupMenu.GetOptions: TTBItemOptions; begin Result := FItem.Options; end; procedure TTBPopupMenu.SetImages(Value: TCustomImageList); begin FItem.SubMenuImages := Value; end; procedure TTBPopupMenu.SetLinkSubitems(Value: TTBCustomItem); begin FItem.LinkSubitems := Value; end; procedure TTBPopupMenu.SetOptions(Value: TTBItemOptions); begin FItem.Options := Value; end; procedure TTBPopupMenu.RootItemClick(Sender: TObject); begin if Sender = FItem then Sender := Self; DoPopup(Sender); end; {$IFNDEF JR_D5} procedure TTBPopupMenu.DoPopup(Sender: TObject); begin if Assigned(OnPopup) then OnPopup(Sender); end; {$ENDIF} procedure TTBPopupMenu.Popup(X, Y: Integer); begin PopupEx(X, Y, False); end; function TTBPopupMenu.PopupEx(X, Y: Integer; ReturnClickedItemOnly: Boolean = False): TTBCustomItem; begin {$IFDEF JR_D5} {$IFDEF JR_D9} SetPopupPoint(Point(X, Y)); {$ELSE} PPoint(@PopupPoint)^ := Point(X, Y); {$ENDIF} {$ENDIF} Result := FItem.Popup(X, Y, TrackButton = tbRightButton, TTBPopupAlignment(Alignment), ReturnClickedItemOnly); end; function TTBPopupMenu.IsShortCut(var Message: TWMKey): Boolean; begin Result := FItem.IsShortCut(Message); end; { TTBImageList } constructor TTBCustomImageList.Create(AOwner: TComponent); begin inherited; FCheckedImagesChangeLink := TChangeLink.Create; FCheckedImagesChangeLink.OnChange := ImageListChanged; FDisabledImagesChangeLink := TChangeLink.Create; FDisabledImagesChangeLink.OnChange := ImageListChanged; FHotImagesChangeLink := TChangeLink.Create; FHotImagesChangeLink.OnChange := ImageListChanged; FImagesBitmap := TBitmap.Create; FImagesBitmap.OnChange := ImagesBitmapChanged; FImagesBitmapMaskColor := clFuchsia; end; destructor TTBCustomImageList.Destroy; begin FreeAndNil(FImagesBitmap); FreeAndNil(FHotImagesChangeLink); FreeAndNil(FDisabledImagesChangeLink); FreeAndNil(FCheckedImagesChangeLink); inherited; end; procedure TTBCustomImageList.ImagesBitmapChanged(Sender: TObject); begin if not ImagesBitmap.Empty then begin Clear; AddMasked(ImagesBitmap, FImagesBitmapMaskColor); end; end; procedure TTBCustomImageList.ImageListChanged(Sender: TObject); begin Change; end; {$IFDEF CLR} procedure TTBCustomImageList.WriteLeft(Writer: TWriter); begin Writer.WriteInteger(DesignInfo shr 16); end; procedure TTBCustomImageList.WriteTop(Writer: TWriter); begin Writer.WriteInteger(DesignInfo and $FFFF); end; {$ENDIF} procedure TTBCustomImageList.DefineProperties(Filer: TFiler); {$IFNDEF CLR} type TProc = procedure(ASelf: TObject; Filer: TFiler); {$ELSE} var Ancestor: TComponent; AncestorInfo: Longint; DesignInfo: Longint; {$ENDIF} begin if (Filer is TReader) or FImagesBitmap.Empty then inherited else begin {$IFNDEF CLR} { Bypass TCustomImageList.DefineProperties when we've got an ImageBitmap } TProc(@TComponentAccess.DefineProperties)(Self, Filer); {$ELSE} { On .NET I'm not aware of any way to bypass an inherited method, so we have to handle DefineProperties all by ourself. The following code is copied from TComponentHelper.DefineProperties, with references to private fields changed and the Read* methods removed. } AncestorInfo := 0; DesignInfo := Self.DesignInfo; Ancestor := TComponent(Filer.Ancestor); if Ancestor <> nil then AncestorInfo := Ancestor.DesignInfo; Filer.DefineProperty('Left', nil, WriteLeft, (DesignInfo and $FFFF) <> (AncestorInfo and $FFFF)); Filer.DefineProperty('Top', nil, WriteTop, (DesignInfo shr 16) <> (AncestorInfo shr 16)); {$ENDIF} end; end; procedure TTBCustomImageList.DrawState(Canvas: TCanvas; X, Y, Index: Integer; Enabled, Selected, Checked: Boolean); begin if not Enabled and Assigned(DisabledImages) then DisabledImages.Draw(Canvas, X, Y, Index) else if Checked and Assigned(CheckedImages) then CheckedImages.Draw(Canvas, X, Y, Index, Enabled) else if Selected and Assigned(HotImages) then HotImages.Draw(Canvas, X, Y, Index, Enabled) else Draw(Canvas, X, Y, Index, Enabled); end; procedure TTBCustomImageList.Notification(AComponent: TComponent; Operation: TOperation); begin inherited; if Operation = opRemove then begin if AComponent = CheckedImages then CheckedImages := nil; if AComponent = DisabledImages then DisabledImages := nil; if AComponent = HotImages then HotImages := nil; end; end; procedure TTBCustomImageList.ChangeImages(var AImageList: TCustomImageList; Value: TCustomImageList; AChangeLink: TChangeLink); begin if Value = Self then Value := nil; if AImageList <> Value then begin if Assigned(AImageList) then AImageList.UnregisterChanges(AChangeLink); AImageList := Value; if Assigned(Value) then begin Value.RegisterChanges(AChangeLink); Value.FreeNotification(Self); end; { Don't call Change while loading because it causes the Delphi IDE to think the form has been modified (?). Also, don't call Change while destroying since there's no reason to. } if not(csLoading in ComponentState) and not(csDestroying in ComponentState) then Change; end; end; procedure TTBCustomImageList.SetCheckedImages(Value: TCustomImageList); begin ChangeImages(FCheckedImages, Value, FCheckedImagesChangeLink); end; procedure TTBCustomImageList.SetDisabledImages(Value: TCustomImageList); begin ChangeImages(FDisabledImages, Value, FDisabledImagesChangeLink); end; procedure TTBCustomImageList.SetHotImages(Value: TCustomImageList); begin ChangeImages(FHotImages, Value, FHotImagesChangeLink); end; procedure TTBCustomImageList.SetImagesBitmap(Value: TBitmap); begin FImagesBitmap.Assign(Value); end; procedure TTBCustomImageList.SetImagesBitmapMaskColor(Value: TColor); begin if FImagesBitmapMaskColor <> Value then begin FImagesBitmapMaskColor := Value; ImagesBitmapChanged(nil); end; end; { TTBBaseAccObject } { According to the MSAA docs: "With Active Accessibility 2.0, servers can return E_NOTIMPL from IDispatch methods and Active Accessibility will implement the IAccessible interface for them." And there was much rejoicing. } {$IFNDEF CLR} function TTBBaseAccObject.GetIDsOfNames(const IID: TGUID; Names: Pointer; NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; begin Result := E_NOTIMPL; end; function TTBBaseAccObject.GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult; begin Result := E_NOTIMPL; end; function TTBBaseAccObject.GetTypeInfoCount(out Count: Integer): HResult; begin Result := E_NOTIMPL; end; function TTBBaseAccObject.Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer; Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; begin Result := E_NOTIMPL; end; {$ENDIF} { Initialization & finalization } procedure TBInitToolbarSystemFont; var NonClientMetrics: TNonClientMetrics; begin if GetSystemNonClientMetrics(NonClientMetrics) then ToolbarFont.Handle := CreateFontIndirect(NonClientMetrics.lfMenuFont); end; initialization ToolbarFont := TFont.Create; TBInitToolbarSystemFont; finalization DestroyClickWnd; FreeAndNil(ToolbarFont); end.