{ MP } unit TB2Item; { Toolbar2000 Copyright (C) 1998-2005 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: https://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: https://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.277 2005/06/23 21:55:44 jr Exp $ } interface {$I TB2Ver.inc} {x$DEFINE TB2K_NO_ANIMATION} { Enabling the above define disables all menu animation. For debugging purpose only. } {x$DEFINE TB2K_USE_STRICT_O2K_MENU_STYLE} { Enabling the above define forces it to use clBtnFace for the menu color instead of clMenu, and disables the use of flat menu borders on Windows XP with themes enabled. } uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, CommCtrl, Menus, ActnList, ImgList, TB2Anim, UITypes; const WM_TB2K_POPUPSHOWING = WM_USER + 554; { Parameter in LParam of WM_TB2K_POPUPSHOWING } TPS_ANIMSTART = 1; // animation query: if Result <> 0, do not animate! TPS_ANIMFINISHED = 2; // only fired when animation thread is done TPS_NOANIM = 3; // fired when animation is done, or if showing with no animation 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 { MP }, tbdaHelpKeyword { /MP }); PTBDoneActionData = ^TTBDoneActionData; TTBDoneActionData = record DoneAction: TTBDoneAction; case TTBDoneAction of tbdaClickItem: (ClickItem: TTBCustomItem; Sound: Boolean); tbdaOpenSystemMenu: (Wnd: HWND; Key: Cardinal); tbdaHelpContext: (ContextID: Integer); { MP } tbdaHelpKeyword: (HelpKeyword: String[100]); 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; TTBItemData = record Item: TTBCustomItem; end; PTBItemDataArray = ^TTBItemDataArray; TTBItemDataArray = array[0..$7FFFFFFF div SizeOf(TTBItemData)-1] of TTBItemData; 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, tbisStretch); 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; TTBPopupPositionRec = record PositionAsSubmenu: Boolean; Alignment: TTBPopupAlignment; Opposite: Boolean; MonitorRect: TRect; ParentItemRect: TRect; NCSizeX: Integer; NCSizeY: Integer; X, Y, W, H: Integer; AnimDir: TTBAnimationDirection; PlaySound: Boolean; end; TTBCustomItem = class(TComponent) private FActionLink: TTBCustomItemActionLink; FAutoCheck: Boolean; FCaption: String; FChecked: Boolean; FDisplayMode: TTBItemDisplayMode; FEnabled: Boolean; FEffectiveOptions: TTBItemOptions; FGroupIndex: Integer; FHelpContext: THelpContext; { MP } FHelpKeyword: String; FHint: String; FImageIndex: TImageIndex; FImages: TCustomImageList; FImagesChangeLink: TTBImageChangeLink; FItems: PTBItemDataArray; FItemCount: Integer; 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); function FindItemWithShortCut(AShortCut: TShortCut; var ATopmostParent: TTBCustomItem): TTBCustomItem; function FixOptions(const AOptions: TTBItemOptions): TTBItemOptions; function GetAction: TBasicAction; function GetItem(Index: Integer): TTBCustomItem; procedure ImageListChangeHandler(Sender: TObject); procedure InternalNotify(Ancestor: TTBCustomItem; NestingLevel: Integer; Action: TTBItemChangedAction; Index: Integer; Item: TTBCustomItem); function IsAutoCheckStored: Boolean; 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; procedure GetPopupPosition(ParentView: TTBView; PopupWindow: TTBPopupWindow; var PopupPositionRec: TTBPopupPositionRec); virtual; function GetPopupWindowClass: TTBPopupWindowClass; virtual; 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; PositionAsSubmenu: Boolean): TTBCustomItem; procedure RecreateItemViewers; procedure SetChildOrder(Child: TComponent; Order: Integer); override; procedure SetName(const NewName: TComponentName); override; procedure SetParentComponent(Value: TComponent); override; 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; function GetTopComponent: TComponent; procedure Add(AItem: TTBCustomItem); procedure Clear; procedure Click; virtual; function ContainsItem(AItem: TTBCustomItem): Boolean; procedure Delete(Index: Integer); 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; PositionAsSubmenu: Boolean = False): TTBCustomItem; procedure PostClick; procedure RegisterNotification(ANotify: TTBItemChangedProc); procedure Remove(Item: TTBCustomItem); procedure UnregisterNotification(ANotify: TTBItemChangedProc); procedure ViewBeginUpdate; procedure ViewEndUpdate; procedure ChangeScale(M, D: Integer); virtual; property Action: TBasicAction read GetAction write SetAction; property AutoCheck: Boolean read FAutoCheck write FAutoCheck stored IsAutoCheckStored default False; property Caption: String read FCaption write SetCaption stored IsCaptionStored; property Count: Integer read FItemCount; 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; { MP } property HelpKeyword: String read FHelpKeyword write FHelpKeyword stored IsHelpContextStored; 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; function IsAutoCheckLinked: Boolean; virtual; function IsCaptionLinked: Boolean; override; function IsCheckedLinked: Boolean; override; function IsEnabledLinked: Boolean; override; function IsHelpContextLinked: Boolean; override; { MP } function IsHelpLinked: Boolean; override; function IsHintLinked: Boolean; override; function IsImageIndexLinked: Boolean; override; function IsShortCutLinked: Boolean; override; function IsVisibleLinked: Boolean; override; function IsOnExecuteLinked: Boolean; override; procedure SetAutoCheck(Value: Boolean); override; procedure SetCaption(const Value: String); override; procedure SetChecked(Value: Boolean); override; procedure SetEnabled(Value: Boolean); override; procedure SetHelpContext(Value: THelpContext); override; { MP } procedure SetHelpKeyword(const Value: string); 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; TTBBaseAccObject = class(TInterfacedObject, IDispatch) public procedure ClientIsDestroying; virtual; abstract; { 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; 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(OldSelected: TTBItemViewer); 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; virtual; 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: IDispatch; function GetHintText: String; function IsAccessible: Boolean; function IsToolbarStyle: Boolean; virtual; function ScreenToClient(const P: TPoint): TPoint; end; PTBItemViewerArray = ^TTBItemViewerArray; TTBItemViewerArray = array[0..$7FFFFFFF div SizeOf(TTBItemViewer)-1] of TTBItemViewer; 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 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; FViewerCount: Integer; FViewers: PTBItemViewerArray; FWindow: TWinControl; FWrapOffset: Integer; procedure DeletingViewer(Viewer: TTBItemViewer); procedure DrawItem(Viewer: TTBItemViewer; DrawTo: TCanvas; Offscreen: Boolean); procedure FreeViewers; 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); procedure SetState(AState: TTBViewState); property DoneActionData: TTBDoneActionData read FDoneActionData write FDoneActionData; property ShowDownArrow: Boolean read FShowDownArrow; {vb+} property ShowUpArrow: Boolean read FShowUpArrow; {vb+} public constructor CreateView(AOwner: TComponent; AParentView: TTBView; AParentItem: TTBCustomItem; AWindow: TWinControl; AIsToolbar, ACustomizing, AUsePriorityList: Boolean); 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); { MP } procedure EndModalWithHelp(AContextID: Integer); overload; procedure EndModalWithHelp(HelpKeyword: string); overload; { /MP } procedure EndModalWithSystemMenu(AWnd: HWND; AKey: Cardinal); procedure EndUpdate; procedure EnterToolbarLoop(Options: TTBEnterToolbarLoopOptions); virtual; procedure ExecuteSelected(AGivePriority: Boolean); function Find(Item: TTBCustomItem): TTBItemViewer; function FirstSelectable: TTBItemViewer; function GetAccObject: IDispatch; function GetCaptureWnd: HWND; function GetFont: TFont; virtual; procedure GetOffEdgeControlList(const List: TList); procedure GivePriority(AViewer: TTBItemViewer); 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: PPoint; const AllowNewSelection: Boolean); function UpdatePositions: TPoint; procedure ValidatePositions; function ViewerFromPoint(const P: TPoint): TTBItemViewer; function GetMonitor: TMonitor; virtual; 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: PTBItemViewerArray read FViewers; property ViewerCount: Integer read FViewerCount; 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; { MP } property HelpKeyword; 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; { MP } property HelpKeyword; 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; constructor CreateControlItem(AOwner: TComponent; AControl: TControl); 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 GetMonitor: TMonitor; override; 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 CMHintShowPause(var Message: TMessage); message CM_HINTSHOWPAUSE; 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: TMessage); message WM_PRINTCLIENT; procedure WMTB2kStepAnimation(var Message: TMessage); message WM_TB2K_STEPANIMATION; procedure WMTB2kAnimationEnded (var Message: TMessage); message WM_TB2K_ANIMATIONENDED; protected procedure CreateParams(var Params: TCreateParams); override; procedure CreateWnd; override; procedure DestroyWindowHandle; override; function GetNCSize: TPoint; dynamic; function GetViewClass: TTBViewClass; dynamic; procedure Paint; override; procedure PaintScrollArrows; virtual; property AnimationDirection: TTBAnimationDirection read FAnimationDirection; {MP} procedure Cancel; dynamic; public constructor CreatePopupWindow(AOwner: TComponent; const AParentView: TTBView; const AItem: TTBCustomItem; const ACustomizing: Boolean; const PopupPoint: TPoint); virtual; destructor Destroy; override; procedure BeforeDestruction; 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 function GetRootItemClass: TTBRootItemClass; dynamic; procedure SetChildOrder(Child: TComponent; Order: Integer); override; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; function IsShortCut(var Message: TWMKey): Boolean; override; procedure Popup(X, Y: Integer); override; function PopupEx(X, Y: Integer; ReturnClickedItemOnly: Boolean = False): TTBCustomItem; procedure GetChildren(Proc: TGetChildProc; Root: TComponent); override; 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); 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; procedure TBInitToolbarSystemFont; function GetToolbarFont(PixelsPerInch: Integer): TFont; overload; function GetToolbarFont(Control: TControl): TFont; overload; type TTBModalHandler = class private FCreatedWnd: Boolean; FInited: Boolean; FWnd: HWND; FRootPopup: TTBPopupWindow; procedure WndProc(var Msg: TMessage); public constructor Create(AExistingWnd: HWND); destructor Destroy; override; procedure Loop(const RootView: TTBView; const AMouseDown, AExecuteSelected, AFromMSAA, TrackRightButton: Boolean); property RootPopup: TTBPopupWindow read FRootPopup write FRootPopup; property Wnd: HWND read FWnd; class procedure DoLockForegroundWindow(LockCode: Cardinal); class procedure LockForegroundWindow; class procedure UnlockForegroundWindow; end; function ProcessDoneAction(const DoneActionData: TTBDoneActionData; const ReturnClickedItemOnly: Boolean): TTBCustomItem; implementation uses MMSYSTEM, TB2Consts, TB2Common, IMM, TB2Acc, Winapi.oleacc, Types, PasTools, Generics.Collections, TB2Toolbar; var LastPos: TPoint; threadvar ClickWndRefCount: Integer; ClickWnd: HWND; ClickList: TList; type PItemChangedNotificationData = ^TItemChangedNotificationData; TItemChangedNotificationData = record Proc: TTBItemChangedProc; RefCount: Integer; end; TComponentAccess = class(TComponent); TControlAccess = class(TControl); const ViewTimerBaseID = 9000; MaxGroupLevel = 10; { Misc. } var ShortCutToTextFixes: TStrings = nil; function ShortCutToTextFix(AShortCut: TShortCut): string; begin Result := ShortCutToText(AShortCut); // WORKAROUND: German keyboard driver is giving wrong name for VK_MULTIPLY if (AShortCut = ShortCut(VK_MULTIPLY, [])) and (Result = ' (ZEHNERTASTATUR)') then begin Result := ShortCutToText(ShortCut(VK_ADD, [])); Result := StringReplace(Result, '+', '*', []); end; end; procedure DestroyClickWnd; begin if ClickWnd <> 0 then begin Classes.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 := Classes.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] := Pointer(1); { ^ The special value of Pointer(1) 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 PlaySoundA('MenuCommand', 0, SND_ALIAS or SND_ASYNC or SND_NODEFAULT or SND_NOSTOP); Result := DoneActionData.ClickItem; if not ReturnClickedItemOnly then Result.PostClick; end; tbdaOpenSystemMenu: begin SendMessage(DoneActionData.Wnd, WM_SYSCOMMAND, SC_KEYMENU, DoneActionData.Key); end; tbdaHelpContext: begin { Based on code in TPopupList.WndProc: } if Assigned(Screen.ActiveForm) and (biHelp in Screen.ActiveForm.BorderIcons) then Application.HelpCommand(HELP_CONTEXTPOPUP, DoneActionData.ContextID) else Application.HelpContext(DoneActionData.ContextID); end; { MP } tbdaHelpKeyword: begin Application.HelpKeyword(string(DoneActionData.HelpKeyword)); end; { /MP } end; end; { TTBItemDataArray routines } procedure InsertIntoItemArray(var AItems: PTBItemDataArray; var AItemCount: Integer; NewIndex: Integer; AItem: TTBCustomItem); begin ReallocMem(AItems, (AItemCount+1) * SizeOf(AItems[0])); if NewIndex < AItemCount then System.Move(AItems[NewIndex], AItems[NewIndex+1], (AItemCount-NewIndex) * SizeOf(AItems[0])); AItems[NewIndex].Item := AItem; Inc(AItemCount); end; procedure DeleteFromItemArray(var AItems: PTBItemDataArray; var AItemCount: Integer; Index: Integer); begin Dec(AItemCount); if Index < AItemCount then System.Move(AItems[Index+1], AItems[Index], (AItemCount-Index) * SizeOf(AItems[0])); ReallocMem(AItems, AItemCount * SizeOf(AItems[0])); end; procedure InsertIntoViewerArray(var AItems: PTBItemViewerArray; var AItemCount: Integer; NewIndex: Integer; AItem: TTBItemViewer); begin ReallocMem(AItems, (AItemCount+1) * SizeOf(AItems[0])); if NewIndex < AItemCount then System.Move(AItems[NewIndex], AItems[NewIndex+1], (AItemCount-NewIndex) * SizeOf(AItems[0])); AItems[NewIndex] := AItem; Inc(AItemCount); end; procedure DeleteFromViewerArray(var AItems: PTBItemViewerArray; var AItemCount: Integer; Index: Integer); begin Dec(AItemCount); if Index < AItemCount then System.Move(AItems[Index+1], AItems[Index], (AItemCount-Index) * SizeOf(AItems[0])); ReallocMem(AItems, AItemCount * SizeOf(AItems[0])); end; { TTBCustomItemActionLink } procedure TTBCustomItemActionLink.AssignClient(AClient: TObject); begin FClient := AClient as TTBCustomItem; end; function TTBCustomItemActionLink.IsAutoCheckLinked: Boolean; begin Result := (FClient.AutoCheck = (Action as TCustomAction).AutoCheck); end; 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; { MP } function TTBCustomItemActionLink.IsHelpLinked: Boolean; begin Result := inherited IsHelpLinked and (FClient.HelpContext = (Action as TCustomAction).HelpContext) and (FClient.HelpKeyword = (Action as TCustomAction).HelpKeyword){ and (FClient.HelpType = (Action as TCustomAction).HelpType);} // TODO end; { /MP } 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 MethodsEqual(TMethod(FClient.OnClick), TMethod(Action.OnExecute)); end; procedure TTBCustomItemActionLink.SetAutoCheck(Value: Boolean); begin if IsAutoCheckLinked then FClient.AutoCheck := Value; end; 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 { MP } IsHelpLinked { /MP } then FClient.HelpContext := Value; end; { MP } procedure TTBCustomItemActionLink.SetHelpKeyword(const Value: String); begin if IsHelpLinked then FClient.HelpKeyword := Value; end; { /MP } 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); FreeMem(FItems); FActionLink.Free; FActionLink := nil; FreeAndNil(FSubMenuImagesChangeLink); FreeAndNil(FImagesChangeLink); inherited; if Assigned(FNotifyList) then begin for I := FNotifyList.Count-1 downto 0 do Dispose(PItemChangedNotificationData(FNotifyList[I])); FNotifyList.Free; end; FLinkParents.Free; ReleaseClickWnd; end; function TTBCustomItem.IsAutoCheckStored: Boolean; begin Result := (ActionLink = nil) or not FActionLink.IsAutoCheckLinked; end; 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 { MP } Result := (ActionLink = nil) or not FActionLink.IsHelpLinked; 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 if not CheckDefaults or (Self.AutoCheck = False) then Self.AutoCheck := AutoCheck; 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; { MP } if not CheckDefaults or (Self.HelpKeyword = '') then Self.HelpKeyword := HelpKeyword; { /MP } 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 FItemCount-1 do Proc(FItems[I].Item); 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; function TTBCustomItem.GetTopComponent: TComponent; begin if Parent <> nil then Result := Parent.GetTopComponent else Result := FParentComponent; 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 Intf: ITBItems; begin if FParent <> nil then FParent.Remove(Self); if Value <> nil then begin if Value is TTBCustomItem then TTBCustomItem(Value).Add(Self) else if Value.GetInterface(ITBItems, Intf) then Intf.GetItems.Add(Self); 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; 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 := Message.LParam; if (I >= 0) and (I < List.Count) then begin Item := List[I]; List[I] := nil; if Item = Pointer(1) then { is it a destroyed item? } 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 } if (not Assigned(ActionLink) and AutoCheck) or (Assigned(ActionLink) and not ActionLink.IsAutoCheckLinked and AutoCheck) then 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 not MethodsEqual(TMethod(FOnClick), TMethod(Action.OnExecute)) then FOnClick(Self) else if not(csDesigning in ComponentState) and (ActionLink <> nil) then ActionLink.Execute(Self) else if Assigned(FOnClick) then FOnClick(Self); end; end; function TTBCustomItem.GetItem(Index: Integer): TTBCustomItem; begin if (Index < 0) or (Index >= FItemCount) then IndexError; Result := FItems[Index].Item; 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 := FLinkParents[I]; if P <> Parent then RelayToParentOf(P); end; if Assigned(FNotifyList) then begin I := 0; while I < FNotifyList.Count do begin with PItemChangedNotificationData(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 } if MethodsEqual(TMethod(PItemChangedNotificationData(FNotifyList[I])^.Proc), TMethod(SaveProc)) then 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 > FItemCount) then IndexError; InsertIntoItemArray(FItems, FItemCount, NewIndex, AItem); AItem.FParent := Self; ViewBeginUpdate; try Notify(tbicInserted, NewIndex, AItem); AItem.RefreshOptions; finally ViewEndUpdate; end; end; procedure TTBCustomItem.Delete(Index: Integer); begin if (Index < 0) or (Index >= FItemCount) then IndexError; Notify(tbicDeleting, Index, FItems[Index].Item); FItems[Index].Item.FParent := nil; DeleteFromItemArray(FItems, FItemCount, Index); end; function TTBCustomItem.IndexOf(AItem: TTBCustomItem): Integer; var I: Integer; begin for I := 0 to FItemCount-1 do if FItems[I].Item = 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 >= FItemCount) 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: PItemChangedNotificationData; begin if FNotifyList = nil then FNotifyList := TList.Create; for I := 0 to FNotifyList.Count-1 do with PItemChangedNotificationData(FNotifyList[I])^ do if MethodsEqual(TMethod(ANotify), TMethod(Proc)) then begin Inc(RefCount); Exit; end; FNotifyList.Expand; New(Data); Data.Proc := ANotify; Data.RefCount := 1; FNotifyList.Add(Data); end; procedure TTBCustomItem.UnregisterNotification(ANotify: TTBItemChangedProc); var I: Integer; Data: PItemChangedNotificationData; begin if Assigned(FNotifyList) then for I := 0 to FNotifyList.Count-1 do begin Data := FNotifyList[I]; if MethodsEqual(TMethod(Data.Proc), TMethod(ANotify)) then begin Dec(Data.RefCount); if Data.RefCount = 0 then begin FNotifyList.Delete(I); Dispose(Data); if FNotifyList.Count = 0 then begin FNotifyList.Free; FNotifyList := nil; end; 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; procedure TTBCustomItem.GetPopupPosition(ParentView: TTBView; PopupWindow: TTBPopupWindow; var PopupPositionRec: TTBPopupPositionRec); var X2, Y2: Integer; RepeatCalcX: Boolean; 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.FViewerCount-1 do begin V := ParentView.FViewers[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; begin with PopupPositionRec do begin { 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 + NCSizeY; 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 + NCSizeX; Dec(X2, W); if not Opposite then Include(PopupWindow.View.FState, vsOppositePopup) else begin if X2 < MonitorRect.Left then begin Opposite := False; RepeatCalcX := True; end else Include(PopupWindow.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; end; end; function TTBCustomItem.CreatePopup(const ParentView: TTBView; const ParentViewer: TTBItemViewer; const PositionAsSubmenu, SelectFirstItem, Customizing: Boolean; const APopupPoint: TPoint; const Alignment: TTBPopupAlignment): TTBPopupWindow; var EventItem, ParentItem: TTBCustomItem; Opposite: Boolean; ChevronParentView: TTBView; ChevronMenu: Boolean; X, Y, W, H: Integer; P: TPoint; ParentItemRect: TRect; MonitorRect: TRect; PopupRec: TTBPopupPositionRec; NCSize: TPoint; begin EventItem := ItemContainingItems(Self); if EventItem <> Self then EventItem.DoPopup(Self, True); DoPopup(Self, False); ChevronParentView := GetChevronParentView; ChevronMenu := False; // shut up if ChevronParentView = nil then ParentItem := Self else begin ParentItem := ChevronParentView.FParentItem; Assert(ParentItem.ParentComponent is TTBCustomToolbar); ChevronMenu := (ParentItem.ParentComponent is TTBCustomToolbar) and TTBCustomToolbar(ParentItem.ParentComponent).ChevronMenu; end; Opposite := Assigned(ParentView) and (vsOppositePopup in ParentView.FState); Result := GetPopupWindowClass.CreatePopupWindow(nil, ParentView, ParentItem, Customizing, APopupPoint); try if Assigned(ChevronParentView) then begin ChevronParentView.FreeNotification(Result.View); Result.View.FChevronParentView := ChevronParentView; Result.View.FIsToolbar := not ChevronMenu; 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 { MP (display menu on correct monitor) } MonitorRect := GetRectOfMonitorContainingRect(ParentItemRect, True); {MonitorRect := GetRectOfMonitorContainingPoint(APopupPoint, False);} {vb-} { MP } {MonitorRect := GetRectOfMonitorContainingPoint(APopupPoint, True);} {vb+} end else begin ParentItemRect.TopLeft := APopupPoint; ParentItemRect.BottomRight := APopupPoint; {MonitorRect := GetRectOfMonitorContainingPoint(APopupPoint, False);} {vb-} MonitorRect := GetRectOfMonitorContainingPoint(APopupPoint, True); {vb+} end; Result.View.FMonitorRect := MonitorRect; { Initialize item positions and size of the popup window } NCSize := Result.GetNCSize; if ChevronParentView = nil then Result.View.FMaxHeight := (MonitorRect.Bottom - MonitorRect.Top) - (NCSize.Y * 2) else Result.View.WrapOffset := (MonitorRect.Right - MonitorRect.Left) - (NCSize.X * 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 - NCSize.X; Y := ParentItemRect.Top - NCSize.Y; 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; PopupRec.PositionAsSubmenu := PositionAsSubmenu; PopupRec.Alignment := Alignment; PopupRec.Opposite := Opposite; PopupRec.MonitorRect := MonitorRect; PopupRec.ParentItemRect := ParentItemRect; PopupRec.NCSizeX := NCSize.X; PopupRec.NCSizeY := NCSize.Y; PopupRec.X := X; PopupRec.Y := Y; PopupRec.W := W; PopupRec.H := H; PopupRec.AnimDir := []; PopupRec.PlaySound := True; GetPopupPosition(ParentView, Result, PopupRec); X := PopupRec.X; Y := PopupRec.Y; W := PopupRec.W; H := PopupRec.H; Result.FAnimationDirection := PopupRec.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 PopupRec.PlaySound or 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; PlaySoundA('MenuPopup', 0, SND_ALIAS or SND_ASYNC or SND_NODEFAULT or SND_NOSTOP); end else begin PlaySoundA('MenuPopup', 0, SND_ALIAS or SND_ASYNC or SND_NODEFAULT or SND_NOSTOP); Result.Visible := True; end; end; NotifyWinEvent(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; PositionAsSubmenu: Boolean): TTBCustomItem; var ModalHandler: TTBModalHandler; Popup: TTBPopupWindow; DoneActionData: TTBDoneActionData; begin ModalHandler := TTBModalHandler.Create(0); try Popup := CreatePopup(nil, nil, PositionAsSubmenu, 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; PositionAsSubmenu: Boolean = False): TTBCustomItem; var P: TPoint; begin P.X := X; P.Y := Y; Result := OpenPopup(False, TrackRightButton, P, Alignment, ReturnClickedItemOnly, PositionAsSubmenu); 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 1; begin Result := False; ShiftState := KeyDataToShiftState(Message.KeyData); ShortCut := Menus.ShortCut(Message.CharCode, ShiftState); 1: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 1; 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.GetShortCutText: String; var P: Integer; begin P := Pos(#9, Caption); if P = 0 then begin if ShortCut <> 0 then Result := ShortCutToTextFix(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 FItemCount-1 do begin Item := FItems[I].Item; 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; procedure TTBCustomItem.ChangeScale(M, D: Integer); var I: Integer; begin for I := 0 to Count - 1 do begin Items[I].ChangeScale(M, D); 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 Inc(AHeight, DivRoundUp(GetTextHeight(Canvas.Handle) * 2, 3)) 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; constructor TTBControlItem.CreateControlItem(AOwner: TComponent; AControl: TControl); begin FControl := AControl; AControl.FreeNotification(Self); Create(AOwner); 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 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: IDispatch; begin if FAccObjectInstance = nil then begin 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: IDispatch; begin { Ensure FAccObjectInstance is created by calling GetAccObject } 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); { MP } if IsToolbarStyle and not (vsMenuBar in View.Style) then Result := StripAccelChars(StripTrailingPunctuation(Result), True); end; function TTBItemViewer.GetHintText: String; var P: Integer; LongHint: string; HintStyleCaption: string; begin if Pos('|', Item.Hint) > 0 then begin Result := GetShortHint(Item.Hint); LongHint := GetLongHint(Item.Hint); end else begin LongHint := Item.Hint; end; HintStyleCaption := StripAccelChars(StripTrailingPunctuation(GetCaptionText)); { 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) or (LongHint <> '')) and (not(tbisSubmenu in Item.ItemStyle) or (tbisCombo in Item.ItemStyle) or not CaptionShown) then Result := HintStyleCaption; { 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; if Result = '' then Result := LongHint; // "Select all" and "Select All" are still the same if SameText(LongHint, Result) then LongHint := ''; if CaptionShown and (LongHint = '') and SameText(Result, HintStyleCaption) then Result := ''; { Add shortcut text } if (Result <> '') and Application.HintShortCuts then begin { Custom shortcut } P := Pos(#9, Item.Caption); if (P <> 0) and (P < Length(Item.Caption)) then Result := Format('%s (%s)', [Result, Copy(Item.Caption, P+ 1, MaxInt)]) else if (Item.ShortCut <> scNone) then Result := Format('%s (%s)', [Result, ShortCutToTextFix(Item.ShortCut)]); end; if LongHint <> '' then Result := Result + '|' + GetLongHint(LongHint); 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 DrawText(DC, PChar(ACaption), Length(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); CheckMarkPoints: array[0..11] of TPoint = ( { Black } (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), { White } (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; Points: array[0..11] 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 := GetSystemMetricsForControl(View.FWindow, SM_CXMENUCHECK); MenuCheckHeight := GetSystemMetricsForControl(View.FWindow, 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); System.Move(CheckMarkPoints, Points, 12 * SizeOf(TPoint)); for I := Low(Points) to High(Points) do begin Inc(Points[I].X, X); Inc(Points[I].Y, Y); end; Canvas.Pen.Color := clBtnText; Polyline(Canvas.Handle, Points[0], 7); Canvas.Pen.Color := clBtnHighlight; Polyline(Canvas.Handle, Points[7], 5); 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 := GetSystemMetricsForControl(View.FWindow, 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.FViewerCount-1 do begin Viewer := View.FViewers[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(OldSelected: TTBItemViewer); 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.CreateView(AOwner: TComponent; AParentView: TTBView; AParentItem: TTBCustomItem; AWindow: TWinControl; AIsToolbar, ACustomizing, AUsePriorityList: Boolean); begin Create(AOwner); 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. } FAccObjectInstance._Release; 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; { Now that we're destroyed, "focus" the parent view } if Assigned(FParentView) then FParentView.NotifyFocusEvent; end; function TTBView.GetAccObject: IDispatch; begin if FAccObjectInstance = nil then begin 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.) } FAccObjectInstance._AddRef; end; Result := FAccObjectInstance; end; function TTBView.HandleWMGetObject(var Message: TMessage): Boolean; begin if (Message.LParam = Integer(OBJID_CLIENT)) then begin Message.Result := LresultFromObject(ITBAccessible, 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 < FViewerCount do begin FViewers[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; procedure TTBView.FreeViewers; var VI: PTBItemViewerArray; I, C: Integer; begin if Assigned(FViewers) then begin VI := FViewers; C := FViewerCount; FViewers := nil; FViewerCount := 0; for I := C-1 downto 0 do FreeAndNil(VI[I]); FreeMem(VI); 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 FViewerCount-1 do if FViewers[I].Item = Item then begin Result := FViewers[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 FViewerCount-1 do if FViewers[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 := FViewers[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; NewViewer := AItem.GetItemViewerClass(Self).Create(Self, AItem, AGroupLevel); InsertIntoViewerArray(FViewers, FViewerCount, 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.FItems[I].Item, 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 := FViewerCount else begin { Ancestor <> FCurParentItem, so apparently an item has been inserted inside a group item } repeat Found := False; while Start < FViewerCount do begin GroupItem := FViewers[Start].Item; if (tbisEmbeddedGroup in GroupItem.ItemStyle) and (GroupItem = Ancestor) then begin NewLevel := FViewers[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 < FViewerCount) and (FViewers[InsertPoint].FGroupLevel >= NewLevel) do begin if (FViewers[InsertPoint].Item = Item) and (FViewers[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 = FViewerCount 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.FItems[Index+1].Item; while (InsertPoint < Last) and ((FViewers[InsertPoint].Item <> NextItem) or (FViewers[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 := FViewers[DeleteIndex]; DeletingViewer(Viewer); RemoveFromList(FPriorityList, Viewer); FreeAndNil(Viewer); DeleteFromViewerArray(FViewers, FViewerCount, DeleteIndex); end; var I: Integer; DeleteLevel: Integer; begin InvalidatePositions; I := 0; DeleteLevel := 0; while I < FViewerCount do begin if DeleteLevel > 0 then begin if FViewers[I].FGroupLevel >= DeleteLevel then begin DeleteItem(I); Continue; end else DeleteLevel := 0; end; if FViewers[I].Item = Item then begin { Delete the item, and any group item children afterward } DeleteLevel := FViewers[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 FViewerCount-1 do if FViewers[I].Item = Item then Invalidate(FViewers[I]); end; tbicInvalidateAndResize: InvalidatePositions; tbicRecreateItemViewers: begin InvalidatePositions; for I := 0 to FViewerCount-1 do if FViewers[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.FViewerCount then { range check just in case } FChevronParentView.GivePriority(FChevronParentView.FViewers[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 := 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 FViewerCount-1 do begin J := FViewers[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); {MP} if Assigned(FOpenViewerWindow) then FOpenViewerWindow.Cancel; CloseChildPopups; end; function TTBView.ViewerFromPoint(const P: TPoint): TTBItemViewer; var I: Integer; begin ValidatePositions; for I := 0 to FViewerCount-1 do begin if FViewers[I].Show and PtInRect(FViewers[I].BoundsRect, P) then begin Result := FViewers[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 FViewers[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; NotifyWinEvent(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 := SmallPointToPoint(TSmallPoint(GetMessagePos())); 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(OldSelected); 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: PPoint; 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 Assigned(P) 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 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 Assigned(P) 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 Exclude(FState, vsMouseInWindow); { If FCapture is True, don't allow the selection to change } if FCapture and (NewSelected <> FSelected) then NewSelected := FSelected; { If we're a popup window and there is a selection... } if FIsPopup and Assigned(NewSelected) then begin { If the mouse just moved out of the window and no submenu was open, remove the highlight } if not FCapture and MouseWasInWindow and not(vsMouseInWindow in FState) and (not Assigned(FOpenViewerView) or not(tbisSubmenu in NewSelected.Item.ItemStyle)) then NewSelected := nil; 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(FViewerCount, Item, 0, False, False)); { Items } if Assigned(FCurParentItem) then begin for I := 0 to FCurParentItem.Count-1 do InsertItemViewers(FViewerCount, FCurParentItem.FItems[I].Item, 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(FViewerCount, Item.FItems[I].Item, 0, False, False)); end; { Chevron item } Item := GetChevronItem; if Assigned(Item) then Inc(FInternalViewersAtEnd, InsertItemViewers(FViewerCount, 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 PTempPosition = ^TTempPosition; TTempPosition = record BoundsRect: TRect; Show, OffEdge, LineSep, Clipped, SameWidth: Boolean; end; PTempPositionArray = ^TTempPositionArray; TTempPositionArray = array[0..$7FFFFFFF div SizeOf(TTempPosition)-1] of TTempPosition; var DC: HDC; LeftX, TopY, CurX, CurY, I: Integer; NewPositions: PTempPositionArray; GroupSplit, DidWrap: Boolean; LineStart, HighestHeightOnLine, HighestWidthOnLine: Integer; function GetSizeOfGroup(const StartingIndex: Integer): Integer; var I: Integer; begin Result := 0; for I := StartingIndex to FViewerCount-1 do begin if not NewPositions[I].Show then Continue; if tbisSeparator in FViewers[I].Item.ItemStyle then Break; with NewPositions[I] do begin if AOrientation <> tbvoVertical then Inc(Result, BoundsRect.Right) else Inc(Result, 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 FViewerCount-1 do with NewPositions[I] do if Show then begin NewRight := TotalSize.X - BoundsRect.Left; BoundsRect.Left := TotalSize.X - BoundsRect.Right; 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 FViewerCount-1 do begin if not IsRectEmpty(NewPositions[I].BoundsRect) then begin OffsetRect(NewPositions[I].BoundsRect, 0, -FScrollOffset); if NewPositions[I].Show and ((NewPositions[I].BoundsRect.Top < MaxTop) or (NewPositions[I].BoundsRect.Bottom > MaxBottom)) then begin NewPositions[I].Show := False; NewPositions[I].Clipped := True; 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; Pos: PTempPosition; 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 Pos := @NewPositions[I]; if not Pos.Show then Continue; Item := FViewers[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, tbisStretch] * 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; if RightAlignStart >= 0 then begin Z := 0; for I := LineEnd downto RightAlignStart do begin Pos := @NewPositions[I]; 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; Break; end; if Z > 0 then begin for I := RightAlignStart to LineEnd do begin Pos := @NewPositions[I]; 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; 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 FViewers[CurIndex].Item.ItemStyle) and ((GroupSplit and not(tbisNoLineBreak in FViewers[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; HighestSameWidthViewerWidth, Total, J, TotalVisibleItems: Integer; IsFirst: Boolean; Viewer: TTBItemViewer; UseChevron, NonControlsOffEdge, TempViewerCreated: Boolean; Margins: TRect; label 1; begin SaveOrientation := FOrientation; AWrappedLines := 1; ChevronItem := GetChevronItem; NewPositions := nil; DC := 0; CalcCanvas := nil; try FOrientation := AOrientation; CalcCanvas := TCanvas.Create; DC := GetDC(0); CalcCanvas.Handle := DC; CalcCanvas.Font.Assign(GetFont); NewPositions := AllocMem(FViewerCount * SizeOf(TTempPosition)); { Figure out which items should be shown } LastWasSep := True; { set to True initially so it won't show leading seps } for I := 0 to FViewerCount-1 do begin Item := FViewers[I].Item; IsControl := Item is TTBControlItem; with NewPositions[I] do begin { Show is initially False since AllocMem 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.FViewerCount then { range check just in case } Viewer := FChevronParentView.FViewers[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 Show := Item.Visible; { Don't display two consecutive separators } if Show then begin if (tbisSeparator in Item.ItemStyle) and LastWasSep then 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 Show := True; LastWasSep := False; end; end; end; end; { Hide any trailing separators, so that they aren't included in the base size } for I := FViewerCount-1 downto 0 do begin with NewPositions[I] do if Show then begin if not(tbisSeparator in FViewers[I].Item.ItemStyle) then Break; Show := False; end; end; { Calculate sizes of all the items } HighestSameWidthViewerWidth := 0; for I := 0 to FViewerCount-1 do begin Item := FViewers[I].Item; IsControl := Item is TTBControlItem; with NewPositions[I] do begin { BoundsRect is currently empty since AllocMem initializes to zero } if not 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 := FViewers[I]; TempViewerCreated := False; if Item.NeedToRecreateViewer(Viewer) then begin if CanMoveControls then begin RecreateItemViewer(I); Viewer := FViewers[I]; end else begin Viewer := Item.GetItemViewerClass(Self).Create(Self, Item, 0); TempViewerCreated := True; end; end; try Viewer.CalcSize(CalcCanvas, BoundsRect.Right, BoundsRect.Bottom); if Viewer.UsesSameWidth then begin SameWidth := True; if (BoundsRect.Right > HighestSameWidthViewerWidth) then HighestSameWidthViewerWidth := 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; BoundsRect.Right := Ctl.Width; 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 FViewerCount-1 do begin with NewPositions[I] do begin if SameWidth and (BoundsRect.Right < HighestSameWidthViewerWidth) then BoundsRect.Right := HighestSameWidthViewerWidth; if AOrientation <> tbvoVertical then Inc(ABaseSize.X, BoundsRect.Right) else Inc(ABaseSize.Y, 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 := FViewerCount-1 downto 0 do begin if NewPositions[I].Show and not(tbisSeparator in FViewers[I].Item.ItemStyle) then Inc(TotalVisibleItems); end; if TotalVisibleItems <= 1 then Break; { Hide any trailing separators } for I := FViewerCount-1 downto 0 do begin with NewPositions[I] do if Show then begin if not(tbisSeparator in FViewers[I].Item.ItemStyle) then Break; Show := False; if AOrientation <> tbvoVertical then Dec(Total, BoundsRect.Right) else Dec(Total, BoundsRect.Bottom); goto 1; end; end; { Find an item to hide } if Assigned(FPriorityList) then I := FPriorityList.Count-1 else I := FViewerCount-1; while I >= 0 do begin if Assigned(FPriorityList) then begin Viewer := FPriorityList[I]; J := Viewer.Index; end else begin Viewer := FViewers[I]; J := I; end; if NewPositions[J].Show and not(tbisSeparator in Viewer.Item.ItemStyle) then begin NewPositions[J].Show := False; NewPositions[J].OffEdge := True; if AOrientation <> tbvoVertical then Dec(Total, NewPositions[J].BoundsRect.Right) else Dec(Total, NewPositions[J].BoundsRect.Bottom); if not NonControlsOffEdge and not(Viewer.Item is TTBControlItem) then NonControlsOffEdge := True; goto 1; end; Dec(I); end; Break; { prevent endless loop } 1: { Don't show two consecutive separators } LastWasSep := True; { set to True initially so it won't show leading seps } for J := 0 to FViewerCount-1 do begin Item := FViewers[J].Item; with NewPositions[J] do begin if Show then begin if (tbisSeparator in Item.ItemStyle) and LastWasSep then begin Show := False; if AOrientation <> tbvoVertical then Dec(Total, BoundsRect.Right) else Dec(Total, BoundsRect.Bottom); end; LastWasSep := tbisSeparator in Item.ItemStyle; end; end; end; end; end; { Hide any trailing separators after items were hidden } for I := FViewerCount-1 downto 0 do begin with NewPositions[I] do if Show then begin if not(tbisSeparator in FViewers[I].Item.ItemStyle) then Break; Show := False; end; end; { Set the ABaseSize.Y (or X) *after* items were hidden } for I := 0 to FViewerCount-1 do begin with NewPositions[I] do if Show then begin if AOrientation <> tbvoVertical then begin if BoundsRect.Bottom > ABaseSize.Y then ABaseSize.Y := BoundsRect.Bottom; end else begin if BoundsRect.Right > ABaseSize.X then ABaseSize.X := 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 FViewerCount-1 do begin Item := FViewers[I].Item; with NewPositions[I] do if Show and not(tbisSeparator in Item.ItemStyle) and not(tboToolbarSize in Item.FEffectiveOptions) and (BoundsRect.Bottom - BoundsRect.Top > J) then J := BoundsRect.Bottom - BoundsRect.Top; end; for I := 0 to FViewerCount-1 do begin Item := FViewers[I].Item; with NewPositions[I] do if Show and not(tbisSeparator in Item.ItemStyle) and not(tboToolbarSize in Item.FEffectiveOptions) then BoundsRect.Bottom := 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 FViewerCount-1 do begin Item := FViewers[I].Item; with NewPositions[I] do begin if not 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]); if IsButton and (AOrientation <> tbvoVertical) then Inc(CurX, BoundsRect.Right - BoundsRect.Left) else Inc(CurY, BoundsRect.Bottom - BoundsRect.Top); if BoundsRect.Right > TotalSize.X then TotalSize.X := BoundsRect.Right; if BoundsRect.Bottom > TotalSize.Y then TotalSize.Y := BoundsRect.Bottom; end; end; if FViewerCount <> 0 then FinalizeLine(FViewerCount-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 FViewerCount-1 do begin Item := FViewers[I].Item; if Item is TTBControlItem then begin if NewPositions[I].Show then begin Ctl := TTBControlItem(Item).FControl; if not EqualRect(NewPositions[I].BoundsRect, Ctl.BoundsRect) then Ctl.BoundsRect := NewPositions[I].BoundsRect; end else if NewPositions[I].OffEdge or NewPositions[I].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 FViewerCount-1 do begin Item := FViewers[I].Item; with NewPositions[I] do if Show and (tbisSeparator in Item.ItemStyle) and LineSep then begin if AOrientation <> tbvoVertical then BoundsRect.Right := TotalSize.X else BoundsRect.Bottom := TotalSize.Y; end; end; { Position the chevron item } if UseChevron then begin if CanMoveControls then ChevronItem.Enabled := NonControlsOffEdge; NewPositions[FViewerCount-1].Show := True; I := AChevronOffset; if AOrientation <> tbvoVertical then begin if I < TotalSize.X then I := TotalSize.X; NewPositions[FViewerCount-1].BoundsRect := Bounds(I, 0, AChevronSize, TotalSize.Y); end else begin if I < TotalSize.Y then I := TotalSize.Y; NewPositions[FViewerCount-1].BoundsRect := Bounds(0, I, TotalSize.X, AChevronSize); end; end; { Commit changes } Result := False; if CanMoveControls then begin for I := 0 to FViewerCount-1 do begin if not Result and (not EqualRect(FViewers[I].BoundsRect, NewPositions[I].BoundsRect) or (FViewers[I].Show <> NewPositions[I].Show) or (tbisLineSep in FViewers[I].State <> NewPositions[I].LineSep)) then Result := True; FViewers[I].FBoundsRect := NewPositions[I].BoundsRect; FViewers[I].FShow := NewPositions[I].Show; FViewers[I].FOffEdge := NewPositions[I].OffEdge; FViewers[I].FClipped := NewPositions[I].Clipped; if NewPositions[I].LineSep then Include(FViewers[I].State, tbisLineSep) else Exclude(FViewers[I].State, tbisLineSep); end; end; finally FOrientation := SaveOrientation; if Assigned(CalcCanvas) then CalcCanvas.Handle := 0; if DC <> 0 then ReleaseDC(0, DC); CalcCanvas.Free; FreeMem(NewPositions); 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 Bmp: TBitmap; CtlCanvas: TControlCanvas; 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 } if not CalculatePositions(True, FOrientation, FWrapOffset, FChevronOffset, FChevronSize, FBaseSize, ASize, WrappedLines) then begin { If the new positions are identical to the previous ones, continue using the previous ones, and don't redraw } FValidated := True; { Just because the positions are the same doesn't mean the size hasn't changed. (If a shrunken toolbar moves between docks, the positions of the non-OffEdge items may be the same on the new dock as on the old dock.) } AutoSize(ASize.X, ASize.Y); end else begin if not(csDesigning in ComponentState) then begin 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 Assigned(FWindow) and FWindow.HandleAllocated and IsWindowVisible(FWindow.Handle) and (FWindow.ClientWidth > 0) and (FWindow.ClientHeight > 0) then begin CtlCanvas := nil; Bmp := TBitmap.Create; try CtlCanvas := TControlCanvas.Create; CtlCanvas.Control := FWindow; Bmp.Width := FWindow.ClientWidth; Bmp.Height := FWindow.ClientHeight; SendMessage(FWindow.Handle, WM_ERASEBKGND, WPARAM(Bmp.Canvas.Handle), 0); SendMessage(FWindow.Handle, WM_PAINT, WPARAM(Bmp.Canvas.Handle), 0); BitBlt(CtlCanvas.Handle, 0, 0, Bmp.Width, Bmp.Height, Bmp.Canvas.Handle, 0, 0, SRCCOPY); ValidateRect(FWindow.Handle, nil); finally CtlCanvas.Free; Bmp.Free; end; end; end else begin { Delphi's handling of canvases is different at design time -- child controls aren't clipped from a parent control's canvas, so the above offscreen rendering code doesn't work right at design-time } InvalidatePositions; FValidated := True; AutoSize(ASize.X, ASize.Y); end; end; 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 Result := GetToolbarFont(GetMonitorPixelsPerInch(GetMonitor)); if not Assigned(Result) then 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 := TControlAccess(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; 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. } SetBrushOrgEx(DrawToDC, R1.Left and 1, R1.Top and 1, 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(TControlAccess(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 I: Integer; begin for I := 0 to FViewerCount-1 do begin if (vsDrawInOrder in FState) or (FViewers[I] <> FSelected) then DrawItem(FViewers[I], ACanvas, False); end; if not(vsDrawInOrder in FState) and Assigned(FSelected) then DrawItem(FSelected, ACanvas, False); 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, @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 FViewerCount-1 do begin Viewer := FViewers[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 FViewerCount = 0 then Exit; J := -1; I := IndexOf(CurViewer); while True do begin if GoForward then begin Inc(I); if I >= FViewerCount then I := 0; end else begin Dec(I); if I < 0 then I := FViewerCount-1; end; if J = -1 then J := I else if I = J then Exit; if (FViewers[I].Show or FViewers[I].Clipped) and FViewers[I].Item.Visible and (tbisSelectable in FViewers[I].Item.ItemStyle) then Break; end; Result := FViewers[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 := FViewers[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 := AnsiCompareText(LastAccel, Key) = 0; end else if (LastAccel = #0) and (Key <> ' ') then Result := AnsiCompareText(S[1], Key) = 0; 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 >= FViewerCount 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 FViewerCount = 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 := FViewers[I]; IsOnlyItemWithAccel := not EnabledItems or (FindAccel(I, Primary, EnabledItems) = I); Exit; end; end; end; procedure TTBView.EnterToolbarLoop(Options: TTBEnterToolbarLoopOptions); var ModalHandler: TTBModalHandler; P: TPoint; 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; GetCursorPos(P); UpdateSelection(@P, True); end; finally ModalHandler.Free; end; SetAccelsVisibility(False); Selected := nil; // caused flicker: FWindow.Update; 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 FViewerCount-1 do begin Item := FViewers[I].Item; if (Item is TTBControlItem) and FViewers[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; { MP } HelpKeyword: string; 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; { MP } if ContextID <> 0 then begin EndModalWithHelp(ContextID); Exit; end; HelpKeyword := ''; V := Self; while Assigned(V) do begin if Assigned(V.FSelected) then begin HelpKeyword := V.FSelected.Item.HelpKeyword; if HelpKeyword <> '' then Break; end; V := V.FParentView; end; if HelpKeyword <> '' then EndModalWithHelp(HelpKeyword); { /MP } 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; { MP } procedure TTBView.EndModalWithHelp(HelpKeyword: string); var RootView: TTBView; begin RootView := GetRootView; RootView.FDoneActionData.HelpKeyword := ShortString(HelpKeyword); RootView.FDoneActionData.DoneAction := tbdaHelpKeyword; end; { /MP } procedure TTBView.EndModalWithSystemMenu(AWnd: HWND; AKey: Cardinal); 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; Exit; asm db 0,'Toolbar2000 (C) 1998-2005 Jordan Russell',0 end; 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 FViewerCount-1 do begin with FViewers[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 FViewerCount-1 do begin with FViewers[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.SetState(AState: TTBViewState); begin FState := AState; end; function TTBView.GetMonitor: TMonitor; begin if ParentView <> nil then begin Result := ParentView.GetMonitor; end else if not IsRectEmpty(FMonitorRect) then begin Result := Screen.MonitorFromRect(FMonitorRect); end else begin Result := GetMonitorFromControl(Window); end; end; { TTBModalHandler } const LSFW_LOCK = 1; LSFW_UNLOCK = 2; var LockSetForegroundWindowInited: BOOL; LockSetForegroundWindow: function(uLockCode: UINT): BOOL; stdcall; constructor TTBModalHandler.Create(AExistingWnd: HWND); begin inherited Create; LastPos := SmallPointToPoint(TSmallPoint(GetMessagePos())); if AExistingWnd <> 0 then FWnd := AExistingWnd else begin FWnd := Classes.AllocateHWnd(WndProc); FCreatedWnd := True; end; { 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. } LockForegroundWindow; SetCapture(FWnd); SetCursor(LoadCursor(0, IDC_ARROW)); NotifyWinEvent(EVENT_SYSTEM_MENUSTART, FWnd, OBJID_CLIENT, CHILDID_SELF); FInited := True; end; class procedure TTBModalHandler.DoLockForegroundWindow(LockCode: Cardinal); begin if not LockSetForegroundWindowInited then begin LockSetForegroundWindow := GetProcAddress(GetModuleHandle(user32), 'LockSetForegroundWindow'); InterlockedExchange(Integer(LockSetForegroundWindowInited), Ord(True)); end; { Should always, as supported since Windows 2000 } if Assigned(LockSetForegroundWindow) then LockSetForegroundWindow(LockCode); end; class procedure TTBModalHandler.LockForegroundWindow; begin DoLockForegroundWindow(LSFW_LOCK); end; class procedure TTBModalHandler.UnlockForegroundWindow; begin DoLockForegroundWindow(LSFW_UNLOCK); end; destructor TTBModalHandler.Destroy; begin UnlockForegroundWindow; if FWnd <> 0 then begin if GetCapture = FWnd then ReleaseCapture; if FInited then NotifyWinEvent(EVENT_SYSTEM_MENUEND, FWnd, OBJID_CLIENT, CHILDID_SELF); if FCreatedWnd then Classes.DeallocateHWnd(FWnd); end; 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; procedure UpdateAllSelections(const P: TPoint; const AllowNewSelection: Boolean); var View, CapView: TTBView; begin View := GetActiveView; CapView := View; while Assigned(CapView) and not CapView.FCapture do CapView := CapView.FParentView; 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 AView := nil; AViewer := nil; { Look for a capture item first } View := RootView; repeat if View.FCapture then begin AView := View; AViewer := View.FSelected; Break; end; View := View.FOpenViewerView; until View = nil; if View = nil then begin 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: TWMMouseMove; begin M.Msg := WM_MOUSEMOVE; M.Keys := 0; M.Pos := PointToSmallPoint(P); Application.HintMouseMessage(Ctl, TMessage(M)); end; procedure MouseMoved; var View: TTBView; Cursor: HCURSOR; Item: TTBCustomItem; P: TPoint; R: TRect; begin UpdateAllSelections(LastPos, True); View := GetActiveView; Cursor := 0; if Assigned(View.FSelected) and Assigned(View.FWindow) then begin Item := View.FSelected.Item; P := View.FWindow.ScreenToClient(LastPos); if ((vsAlwaysShowHints in View.FStyle) or (tboShowHint in 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; R := View.FSelected.BoundsRect; Dec(P.X, R.Left); Dec(P.Y, R.Top); View.FSelected.GetCursor(P, Cursor); end else Application.CancelHint; if Cursor = 0 then Cursor := LoadCursor(0, IDC_ARROW); SetCursor(Cursor); 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; IsOnlyItemWithAccel: Boolean; MouseIsDown: Boolean; Key: Word; Shift: TShiftState; Viewer: TTBItemViewer; begin FillChar(RootView.FDoneActionData, SizeOf(RootView.FDoneActionData), 0); RootView.ValidatePositions; try try RootView.FCaptureWnd := FWnd; MouseDownOnMenu := False; if AMouseDown then begin P := RootView.FSelected.ScreenToClient(SmallPointToPoint(TSmallPoint(GetMessagePos()))); 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 { Examine the next message before popping it out of the queue } if not PeekMessage(Msg, 0, 0, 0, PM_NOREMOVE) then begin WaitMessage; Continue; end; case Msg.message of WM_LBUTTONDOWN, WM_RBUTTONDOWN: begin P := SmallPointToPoint(TSmallPoint(Msg.lParam)); Windows.ClientToScreen(Msg.hwnd, P); 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 := ImmGetVirtualKey(Msg.hwnd); if not MouseIsDown or (Msg.wParam = VK_F1) then begin Key := Word(Msg.wParam); if SendKeyEvent(GetActiveView, Key, KeyDataToShiftState(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 View := GetActiveView; Viewer := View.NextSelectableWithAccel(View.FSelected, Chr(Msg.WParam), False, IsOnlyItemWithAccel); if Viewer = nil then begin if (Msg.WParam in [VK_SPACE, Ord('-')]) and not RootView.FIsPopup and (View = RootView) and (GetActiveWindow <> 0) then begin RootView.EndModalWithSystemMenu(GetActiveWindow, Msg.WParam); 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(WPARAM(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; if GetSelectedViewer(View, Viewer) then begin P := Viewer.ScreenToClient(Msg.pt); Viewer.MouseMove(P.X, P.Y); end; end; WM_MOUSEWHEEL: if GetSelectedViewer(View, Viewer) then begin P := Viewer.ScreenToClient(Msg.pt); Viewer.MouseWheel(Smallint(LongRec(Msg.wParam).Hi), 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 := SmallPointToPoint(TSmallPoint(GetMessagePos())); 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 begin Exit; end; if LastPos.X = Low(LastPos.X) then begin LastPos := SmallPointToPoint(TSmallPoint(GetMessagePos())); 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 TTBPopupWindow(FWindow) do with GetNCSize do SetBounds(Left, Top, AWidth + (X * 2), AHeight + (Y * 2)); end; function TTBPopupView.GetMonitor: TMonitor; begin Result := Screen.MonitorFromRect(FWindow.BoundsRect); 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; const PopupPoint: TPoint); begin inherited Create(AOwner); Visible := False; SetBounds(PopupPoint.X, PopupPoint.Y, 320, 240); ControlStyle := ControlStyle - [csCaptureMouse]; ShowHint := True; Color := tbMenuBkColor; FView := GetViewClass.CreateView(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(GetToolbarFont(GetMonitorPixelsPerInch(Screen.MonitorFromPoint(PopupPoint)))); { 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; { Ensure window handle is destroyed *before* FView is freed, since DestroyWindowHandle calls NotifyWinEvent which may result in FView.HandleWMObject being called } if HandleAllocated then DestroyWindowHandle; FreeAndNil(FView); inherited; end; {MP} procedure TTBPopupWindow.Cancel; begin { noop } end; procedure TTBPopupWindow.BeforeDestruction; begin { The inherited BeforeDestruction method hides the form. We need to close any child popups first, so that pixels behind the popups are properly restored without generating a WM_PAINT message. } if Assigned(FView) then FView.CloseChildPopups; inherited; end; function TTBPopupWindow.GetNCSize: TPoint; begin Result.X := PopupMenuWindowNCSize; Result.Y := PopupMenuWindowNCSize; 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; 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; NotifyWinEvent(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 Animate: BOOL; 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 SystemParametersInfo(SPI_GETMENUANIMATION, 0, @Animate, 0) and Animate then begin Blend := SystemParametersInfo(SPI_GETMENUFADE, 0, @Animate, 0) and Animate; if Blend or (FAnimationDirection <> []) then begin if SendMessage(WindowHandle, WM_TB2K_POPUPSHOWING, TPS_ANIMSTART, 0) = 0 then begin { Start animation only if WM_TB2K_POPUPSHOWING returns zero (or not handled) } TBStartAnimation(WindowHandle, Blend, FAnimationDirection); Exit; end; 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]); if Showing then SendNotifyMessage(WindowHandle, WM_TB2K_POPUPSHOWING, TPS_NOANIM, 0); end; procedure TTBPopupWindow.WMTB2kAnimationEnded(var Message: TMessage); begin SendNotifyMessage(WindowHandle, WM_TB2K_POPUPSHOWING, TPS_ANIMFINISHED, 0); end; procedure TTBPopupWindow.WMTB2kStepAnimation(var Message: TMessage); begin TBStepAnimation(Message); 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); begin with GetNCSize do InflateRect(Message.CalcSize_Params^.rgrc[0], -X, -Y); inherited; end; procedure PopupWindowNCPaintProc(Control: TControl; Wnd: HWND; DC: HDC; AppData: Longint); 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(Self, Handle, DC, Longint(Self)); finally ReleaseDC(Handle, DC); end; end; procedure TTBPopupWindow.WMPrint(var Message: TMessage); begin HandleWMPrint(Self, Handle, Message, PopupWindowNCPaintProc, Longint(Self)); end; procedure TTBPopupWindow.WMPrintClient(var Message: TMessage); begin HandleWMPrintClient(Self, Message); end; procedure TTBPopupWindow.CMHintShow(var Message: TCMHintShow); begin with Message.HintInfo^ do begin HintStr := ''; if Assigned(FView.Selected) then begin CursorRect := FView.Selected.BoundsRect; HintStr := FView.FSelected.GetHintText; end; end; end; procedure TTBPopupWindow.CMHintShowPause(var Message: TMessage); begin // Hint was not active previously if not Boolean(Message.WParam) then begin PInteger(Message.LParam)^ := PInteger(Message.LParam)^ * 2; end; 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; procedure TTBPopupMenu.Popup(X, Y: Integer); begin PopupEx(X, Y, False); end; function TTBPopupMenu.PopupEx(X, Y: Integer; ReturnClickedItemOnly: Boolean = False): TTBCustomItem; begin SetPopupPoint(Point(X, Y)); 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; procedure TTBCustomImageList.DefineProperties(Filer: TFiler); type TProc = procedure(ASelf: TObject; Filer: TFiler); begin if (Filer is TReader) or FImagesBitmap.Empty then inherited else { Bypass TCustomImageList.DefineProperties when we've got an ImageBitmap } TProc(@TComponentAccess.DefineProperties)(Self, Filer); 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. } 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; { Initialization & finalization } var ToolbarFonts: TDictionary; ToolbarFont: TFont; function CreateToolbarFont(PixelsPerInch: Integer): HFONT; var NonClientMetrics: TNonClientMetrics; begin FillChar(NonClientMetrics, SizeOf(NonClientMetrics), 0); NonClientMetrics.cbSize := SizeOf(NonClientMetrics); Assert(HasSystemParametersInfoForPixelsPerInch); if SystemParametersInfoForPixelsPerInch(SPI_GETNONCLIENTMETRICS, SizeOf(NonClientMetrics), @NonClientMetrics, 0, PixelsPerInch) then begin Result := CreateFontIndirect(NonClientMetrics.lfMenuFont); end else begin Result := 0; end; end; function GetToolbarFont(Control: TControl; PixelsPerInch: Integer): TFont; overload; var H: HFONT; begin // Temporary redundant legacy fallback to limit impact of per-monitor DPI change if not HasSystemParametersInfoForPixelsPerInch then begin Result := ToolbarFont; end else begin // See the comment in TTBView.GetFont if not Assigned(ToolbarFonts) then begin Result := nil; end else begin if PixelsPerInch < 0 then begin PixelsPerInch := GetControlPixelsPerInch(Control); end; if not ToolbarFonts.TryGetValue(PixelsPerInch, Result) then begin H := CreateToolbarFont(PixelsPerInch); if H <> 0 then begin Result := TFont.Create; Result.Handle := H; ToolbarFonts.Add(PixelsPerInch, Result); end else begin Result := nil; end; end end; end; end; function GetToolbarFont(PixelsPerInch: Integer): TFont; overload; begin Result := GetToolbarFont(nil, PixelsPerInch); end; function GetToolbarFont(Control: TControl): TFont; overload; begin Result := GetToolbarFont(Control, -1); end; procedure TBInitToolbarSystemFont; var NonClientMetrics: TNonClientMetrics; FontPair: TPair; begin NonClientMetrics.cbSize := SizeOf(NonClientMetrics); if SystemParametersInfo(SPI_GETNONCLIENTMETRICS, 0, @NonClientMetrics, 0) then begin ToolbarFont.Handle := CreateFontIndirect(NonClientMetrics.lfMenuFont); end; for FontPair in ToolbarFonts do begin FontPair.Value.Handle := CreateToolbarFont(FontPair.Key); end; end; procedure TBFinalizeToolbarSystemFont; var Font: TFont; begin for Font in ToolbarFonts.Values do begin Font.Free; end; end; initialization ToolbarFonts := TDictionary.Create; ToolbarFont := TFont.Create; TBInitToolbarSystemFont; finalization DestroyClickWnd; FreeAndNil(ToolbarFont); TBFinalizeToolbarSystemFont; FreeAndNil(ToolbarFonts); end.