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