3838 lines
116 KiB
ObjectPascal
3838 lines
116 KiB
ObjectPascal
unit TBX;
|
|
|
|
// TBX Package
|
|
// Copyright 2001-2004 Alex A. Denisov. All Rights Reserved
|
|
// See TBX.chm for license and installation instructions
|
|
//
|
|
// $Id: TBX.pas 21 2004-05-29 22:16:01Z Alex@ZEISS $
|
|
|
|
interface
|
|
|
|
{$I ..\..\Source\TB2Ver.inc}
|
|
{$I TBX.inc}
|
|
|
|
{x$DEFINE TBX_NO_ANIMATION}
|
|
{ Enabling the above define disables all menu animation. For debugging
|
|
purpose only. } {vb+}
|
|
|
|
uses
|
|
Windows, Messages, Classes, SysUtils, Controls, Graphics, ImgList, Forms,
|
|
TB2Item, TB2Dock, TB2Toolbar, TB2ToolWindow, TB2Anim, TBXUtils, TBXThemes;
|
|
|
|
const
|
|
TBXVersion = 2.1;
|
|
TBXVersionString = '2.1';
|
|
TBXVersionText = 'TBX version ' + TBXVersionString;
|
|
|
|
{ TBX Messages }
|
|
const
|
|
TBM_THEMECHANGE = WM_USER + 314;
|
|
TBM_GETVIEWTYPE = WM_USER + 237;
|
|
TBM_GETEFFECTIVECOLOR = WM_USER + 238;
|
|
|
|
function GetViewType(View: TTBView): Integer;
|
|
function GetWinViewType(Window: TControl): Integer;
|
|
function IsFloating(ViewType: Integer): Boolean;
|
|
|
|
type
|
|
TTextWrapping = (twNone, twEndEllipsis, twPathEllipsis, twWrap);
|
|
TTextTruncation = twNone..twPathEllipsis;
|
|
TTriState = (tsDefault, tsTrue, tsFalse);
|
|
TFontSize = 25..1000;
|
|
|
|
TFontSettings = class(TPersistent)
|
|
private
|
|
FBold: TTriState;
|
|
FItalic: TTriState;
|
|
FUnderline: TTriState;
|
|
FStrikeOut: TTriState;
|
|
FSize: TFontSize;
|
|
FColor: TColor;
|
|
FName: TFontName;
|
|
FOnChange: TNotifyEvent;
|
|
procedure SetBold(Value: TTriState);
|
|
procedure SetColor(Value: TColor);
|
|
procedure SetItalic(Value: TTriState);
|
|
procedure SetName(const Value: TFontName);
|
|
procedure SetSize(Value: TFontSize);
|
|
procedure SetStrikeOut(Value: TTriState);
|
|
procedure SetUnderline(Value: TTriState);
|
|
protected
|
|
procedure Modified;
|
|
property OnChange: TNotifyEvent read FOnChange write FOnChange;
|
|
public
|
|
constructor Create;
|
|
procedure Apply(Font: TFont); overload;
|
|
procedure Apply(var LF: TLogFont; var FontColor: TColor); overload;
|
|
procedure Assign(Src: TPersistent); override;
|
|
function CreateTransformedFont(Src: HFont; var FontColor: TColor): HFont;
|
|
published
|
|
property Bold: TTriState read FBold write SetBold default tsDefault;
|
|
property Italic: TTriState read FItalic write SetItalic default tsDefault;
|
|
property Underline: TTriState read FUnderline write SetUnderline default tsDefault;
|
|
property StrikeOut: TTriState read FStrikeOut write SetStrikeOut default tsDefault;
|
|
property Size: TFontSize read FSize write SetSize default 100; // percent
|
|
property Color: TColor read FColor write SetColor default clNone;
|
|
property Name: TFontName read FName write SetName; // default ''
|
|
end;
|
|
|
|
TTBXPopupPositionInfo = record
|
|
Item: TTBCustomItem; // this is a tentative type, it will be changed
|
|
ParentView: TTBView; // or removed in future versions
|
|
ParentViewer: TTBItemViewer;
|
|
PositionAsSubmenu: Boolean;
|
|
APopupPoint: TPoint;
|
|
Alignment: TTBPopupAlignment;
|
|
PopupWindow: TTBPopupWindow;
|
|
X, Y: Integer;
|
|
ParentItemRect: TRect;
|
|
AppFlags: Integer; // reserved for extensions
|
|
AppData: Integer;
|
|
end;
|
|
|
|
TTBXThemeClass = class of TTBXTheme;
|
|
|
|
function GetStateFlags(const ItemInfo: TTBXItemInfo): Integer;
|
|
function GetTBXTextColor(StateFlags: Integer): TColor;
|
|
procedure DrawTBXCaption(Canvas: TCanvas; Rect: TRect; const Text: string;
|
|
Format: Cardinal; StateFlags: Integer);
|
|
procedure DrawTBXImage(Canvas: TCanvas; Rect: TRect; ImageList: TCustomImageList;
|
|
ImageIndex: Integer; StateFlags: Integer);
|
|
|
|
|
|
type
|
|
{ TTBXItem }
|
|
|
|
TAdjustFontEvent = procedure(Item: TTBCustomItem; Viewer: TTBItemViewer;
|
|
Font: TFont; StateFlags: Integer) of object; // state flags are the combination of ISF_* constants
|
|
TDrawImageEvent = procedure(Item: TTBCustomItem; Viewer: TTBItemViewer;
|
|
Canvas: TCanvas; ImageRect: TRect; ImageOffset: TPoint; StateFlags: Integer) of object;
|
|
|
|
TTBXCustomItem = class(TTBCustomItem)
|
|
private
|
|
FAlwaysSelectFirst: Boolean;
|
|
FFontSettings: TFontSettings;
|
|
FLayout: TTBXItemLayout;
|
|
FMinHeight: Integer;
|
|
FMinWidth: Integer;
|
|
FToolBoxPopup: Boolean;
|
|
FOnAdjustFont: TAdjustFontEvent;
|
|
FOnDrawImage: TDrawImageEvent;
|
|
procedure FontSettingsChanged(Sender: TObject);
|
|
function GetStretch: Boolean;
|
|
procedure SetFontSettings(Value: TFontSettings);
|
|
procedure SetLayout(Value: TTBXItemLayout);
|
|
procedure SetMinHeight(Value: Integer);
|
|
procedure SetMinWidth(Value: Integer);
|
|
procedure SetStretch(Value: Boolean);
|
|
protected
|
|
function CreatePopup(const ParentView: TTBView; const ParentViewer: TTBItemViewer;
|
|
const PositionAsSubmenu, SelectFirstItem, Customizing: Boolean;
|
|
const APopupPoint: TPoint; const Alignment: TTBPopupAlignment): TTBPopupWindow; override;
|
|
function GetItemViewerClass(AView: TTBView): TTBItemViewerClass; override;
|
|
procedure GetPopupPosition(ParentView: TTBView; PopupWindow: TTBPopupWindow;
|
|
var PopupPositionRec: TTBPopupPositionRec); override;
|
|
function GetPopupWindowClass: TTBPopupWindowClass; override;
|
|
property ToolBoxPopup: Boolean read FToolBoxPopup write FToolBoxPopup default False;
|
|
property OnAdjustFont: TAdjustFontEvent read FOnAdjustFont write FOnAdjustFont;
|
|
property OnDrawImage: TDrawImageEvent read FOnDrawImage write FOnDrawImage;
|
|
public
|
|
constructor Create(AOwner: TComponent); override;
|
|
destructor Destroy; override;
|
|
procedure Invalidate;
|
|
property AlwaysSelectFirst: Boolean read FAlwaysSelectFirst write FAlwaysSelectFirst default False;
|
|
property FontSettings: TFontSettings read FFontSettings write SetFontSettings;
|
|
property Layout: TTBXItemLayout read FLayout write SetLayout default tbxlAuto;
|
|
property MinHeight: Integer read FMinHeight write SetMinHeight default 0;
|
|
property MinWidth: Integer read FMinWidth write SetMinWidth default 0;
|
|
property Stretch: Boolean read GetStretch write SetStretch default False;
|
|
end;
|
|
|
|
TTBXItem = class (TTBXCustomItem)
|
|
property Action;
|
|
property AutoCheck;
|
|
property Caption;
|
|
property Checked;
|
|
property DisplayMode;
|
|
property Enabled;
|
|
property FontSettings;
|
|
property GroupIndex;
|
|
property HelpContext;
|
|
property Hint;
|
|
property ImageIndex;
|
|
property Images;
|
|
property InheritOptions;
|
|
property Layout;
|
|
property MaskOptions;
|
|
property MinHeight;
|
|
property MinWidth;
|
|
property Options;
|
|
property RadioItem;
|
|
property ShortCut;
|
|
property Stretch;
|
|
property Visible;
|
|
property OnAdjustFont;
|
|
property OnDrawImage;
|
|
property OnClick;
|
|
property OnSelect;
|
|
end;
|
|
|
|
TTBXItemViewer = class(TTBItemViewer)
|
|
private
|
|
FWide: Boolean;
|
|
protected
|
|
procedure DoPaintCaption(Canvas: TCanvas; const ClientAreaRect: TRect;
|
|
var CaptionRect: TRect; IsTextRotated: Boolean; var PaintDefault: Boolean); virtual;
|
|
function GetAccRole: Integer; override;
|
|
function GetImageSize: TSize; dynamic;
|
|
function GetItemType: Integer; virtual;
|
|
function GetTextFlags: Cardinal; dynamic;
|
|
function GetTextSize(Canvas: TCanvas; const Text: string; TextFlags: Cardinal; Rotated: Boolean; StateFlags: Integer): TSize; dynamic;
|
|
function IsToolbarSize: Boolean; override;
|
|
procedure CalcSize(const Canvas: TCanvas; var AWidth, AHeight: Integer); override;
|
|
procedure DrawItemImage(Canvas: TCanvas; ARect: TRect; ItemInfo: TTBXItemInfo); virtual;
|
|
procedure DoAdjustFont(AFont: TFont; StateFlags: Integer); virtual;
|
|
function GetImageShown: Boolean; virtual;
|
|
function IsPtInButtonPart(X, Y: Integer): Boolean; override;
|
|
procedure MouseUp(X, Y: Integer; MouseWasDownOnMenu: Boolean); override;
|
|
procedure Paint(const Canvas: TCanvas; const ClientAreaRect: TRect; IsHoverItem, IsPushed, UseDisabledShadow: Boolean); override;
|
|
property Wide: Boolean read FWide write FWide default True;
|
|
public
|
|
constructor Create(AView: TTBView; AItem: TTBCustomItem; AGroupLevel: Integer); override;
|
|
function IsToolbarStyle: Boolean; override;
|
|
end;
|
|
|
|
{ TTBXSubmenuItem }
|
|
|
|
TTBXSubmenuItem = class(TTBXCustomItem)
|
|
private
|
|
function GetDropdownCombo: Boolean;
|
|
procedure SetDropdownCombo(Value: Boolean);
|
|
public
|
|
constructor Create(AOwner: TComponent); override;
|
|
published
|
|
property Action;
|
|
property AlwaysSelectFirst;
|
|
property AutoCheck;
|
|
property Caption;
|
|
property Checked;
|
|
property DisplayMode;
|
|
property DropdownCombo: Boolean read GetDropdownCombo write SetDropdownCombo default False;
|
|
property Enabled;
|
|
property FontSettings;
|
|
property GroupIndex;
|
|
property HelpContext;
|
|
property Hint;
|
|
property ImageIndex;
|
|
property Images;
|
|
property InheritOptions;
|
|
property Layout;
|
|
property LinkSubitems;
|
|
property MaskOptions;
|
|
property MinHeight;
|
|
property MinWidth;
|
|
property Options;
|
|
property RadioItem;
|
|
property ShortCut;
|
|
property Stretch;
|
|
property SubMenuImages;
|
|
property ToolBoxPopup;
|
|
property Visible;
|
|
property OnAdjustFont;
|
|
property OnDrawImage;
|
|
property OnClick;
|
|
property OnPopup;
|
|
property OnSelect;
|
|
end;
|
|
|
|
{ TTBXSeparatorItem }
|
|
|
|
TTBXSeparatorItem = class(TTBSeparatorItem)
|
|
private
|
|
FSize: Integer;
|
|
procedure SetSize(Value: Integer);
|
|
public
|
|
constructor Create(AOwner: TComponent); override;
|
|
function GetItemViewerClass(AView: TTBView): TTBItemViewerClass; override;
|
|
published
|
|
property Size: Integer read FSize write SetSize default -1;
|
|
property MaskOptions;
|
|
property Options;
|
|
end;
|
|
|
|
TTBXSeparatorItemViewer = class(TTBSeparatorItemViewer)
|
|
protected
|
|
procedure CalcSize(const Canvas: TCanvas; var AWidth, AHeight: Integer); override;
|
|
procedure Paint(const Canvas: TCanvas; const ClientAreaRect: TRect;
|
|
IsHoverItem, IsPushed, UseDisabledShadow: Boolean); override;
|
|
function IsToolbarSize: Boolean; override;
|
|
public
|
|
function IsToolbarStyle: Boolean; override;
|
|
end;
|
|
|
|
TTBXVisibilityToggleItem = class(TTBXCustomItem)
|
|
private
|
|
FControl: TControl;
|
|
procedure SetControl (Value: TControl);
|
|
procedure UpdateProps;
|
|
protected
|
|
procedure Notification (AComponent: TComponent; Operation: TOperation); override;
|
|
public
|
|
procedure Click; override;
|
|
procedure InitiateAction; override;
|
|
published
|
|
property Caption;
|
|
property Control: TControl read FControl write SetControl;
|
|
property DisplayMode;
|
|
property Enabled;
|
|
property FontSettings;
|
|
property HelpContext;
|
|
property Hint;
|
|
property ImageIndex;
|
|
property Images;
|
|
property InheritOptions;
|
|
property Layout;
|
|
property MaskOptions;
|
|
property MinHeight;
|
|
property MinWidth;
|
|
property Options;
|
|
property ShortCut;
|
|
property Stretch;
|
|
property Visible;
|
|
property OnAdjustFont;
|
|
property OnClick;
|
|
property OnSelect;
|
|
end;
|
|
|
|
{ TTBXPopupWindow }
|
|
|
|
TTBXPopupWindow = class(TTBPopupWindow)
|
|
private
|
|
FControlRect: TRect;
|
|
FShadows: TShadows;
|
|
procedure CMHintShow(var Message: TCMHintShow); message CM_HINTSHOW;
|
|
procedure CMShowingChanged(var Message: TMessage); message CM_SHOWINGCHANGED; {vb+}
|
|
procedure TBMGetViewType(var Message: TMessage); message TBM_GETVIEWTYPE;
|
|
procedure WMNCCalcSize(var Message: TWMNCCalcSize); message WM_NCCALCSIZE;
|
|
procedure WMNCPaint(var Message: TMessage); message WM_NCPAINT;
|
|
procedure WMPrint(var Message: TMessage); message WM_PRINT;
|
|
procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND;
|
|
procedure WMWindowPosChanged(var Message: TWMWindowPosChanged); message WM_WINDOWPOSCHANGED;
|
|
procedure WMTB2kPopupShowing(var Message: TMessage); message WM_TB2K_POPUPSHOWING;
|
|
protected
|
|
procedure CreateParams(var Params: TCreateParams); override;
|
|
procedure CreateShadow; virtual;
|
|
procedure DestroyShadow; virtual;
|
|
function GetNCSize: TPoint; override;
|
|
function GetShowShadow: Boolean; virtual;
|
|
function GetViewClass: TTBViewClass; override;
|
|
procedure PaintScrollArrows; override; {vb+}
|
|
public
|
|
destructor Destroy; override;
|
|
function GetFillColor: TColor;
|
|
end;
|
|
|
|
TTBXPopupView = class(TTBPopupView);
|
|
|
|
{ TTBXToolbarView }
|
|
|
|
TTBXToolbarView = class(TTBToolbarView)
|
|
protected
|
|
procedure GetMargins(AOrientation: TTBViewOrientation; var Margins: TRect); override;
|
|
end;
|
|
|
|
{ TTBXToolbar }
|
|
TTBXItemTransparency = (itAuto, itEnable, itDisable);
|
|
|
|
TTBXToolbar = class(TTBCustomToolbar)
|
|
private
|
|
FEffectiveColor: TColor;
|
|
FItemTransparency: TTBXItemTransparency;
|
|
FSnapDistance: Integer;
|
|
procedure CMColorChanged(var Message: TMessage); message CM_COLORCHANGED;
|
|
procedure CMControlChange(var Message: TCMControlChange); message CM_CONTROLCHANGE;
|
|
procedure CMParentColorChanged(var Message: TMessage); message CM_PARENTCOLORCHANGED;
|
|
procedure SetItemTransparency(const Value: TTBXItemTransparency);
|
|
procedure SetSnapDistance(Value: Integer);
|
|
procedure TBMGetViewType(var Message: TMessage); message TBM_GETVIEWTYPE;
|
|
procedure TBMGetEffectiveColor(var Message: TMessage); message TBM_GETEFFECTIVECOLOR;
|
|
procedure TBMThemeChange(var Message: TMessage); message TBM_THEMECHANGE;
|
|
procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND;
|
|
procedure WMSize(var Message: TWMSize); message WM_SIZE;
|
|
protected
|
|
procedure DrawNCArea(const DrawToDC: Boolean; const ADC: HDC; const Clip: HRGN); override;
|
|
function GetChevronItemClass: TTBChevronItemClass; override;
|
|
function GetFloatingWindowParentClass: TTBFloatingWindowParentClass; override;
|
|
procedure GetToolbarInfo(out ToolbarInfo: TTBXToolbarInfo); virtual;
|
|
function GetViewClass: TTBToolbarViewClass; override;
|
|
procedure Loaded; override; {vb+}
|
|
procedure SetParent(AParent: TWinControl); override;
|
|
procedure UpdateEffectiveColor;
|
|
public
|
|
constructor Create(AOwner: TComponent); override;
|
|
destructor Destroy; override;
|
|
function Embedded: Boolean;
|
|
function GetFloatingBorderSize: TPoint; override;
|
|
procedure UpdateChildColors;
|
|
property EffectiveColor: TColor read FEffectiveColor;
|
|
published
|
|
property ActivateParent;
|
|
property Align;
|
|
property AutoResize;
|
|
property BorderStyle;
|
|
property Caption;
|
|
property ChevronHint;
|
|
property ChevronMoveItems;
|
|
property ChevronPriorityForNewItems;
|
|
property CloseButton;
|
|
property CloseButtonWhenDocked;
|
|
property CurrentDock;
|
|
property DblClickUndock default False;
|
|
property DefaultDock;
|
|
property DockableTo;
|
|
property DockMode;
|
|
property DockPos;
|
|
property DockRow;
|
|
property DragHandleStyle;
|
|
property FloatingMode;
|
|
property Font;
|
|
property FullSize;
|
|
property HideWhenInactive;
|
|
property Images;
|
|
property Items;
|
|
property ItemTransparency: TTBXItemTransparency read FItemTransparency write SetItemTransparency default itAuto;
|
|
property LastDock;
|
|
property LinkSubitems;
|
|
property MenuBar;
|
|
property Options;
|
|
property ParentFont;
|
|
property ParentShowHint;
|
|
property PopupMenu;
|
|
property ProcessShortCuts;
|
|
property Resizable;
|
|
property ShowCaption;
|
|
property ShowHint;
|
|
property ShrinkMode;
|
|
property SmoothDrag;
|
|
property SnapDistance: Integer read FSnapDistance write SetSnapDistance default 0;
|
|
property Stretch;
|
|
property SystemFont;
|
|
property TabOrder;
|
|
property TabStop;
|
|
property UpdateActions;
|
|
property UseLastDock;
|
|
property Visible;
|
|
property Color default clNone;
|
|
property OnClose;
|
|
property OnCloseQuery;
|
|
{$IFDEF JR_D5}
|
|
property OnContextPopup;
|
|
{$ENDIF}
|
|
property OnDragDrop;
|
|
property OnDragOver;
|
|
property OnMouseDown;
|
|
property OnMouseMove;
|
|
property OnMouseUp;
|
|
property OnMove;
|
|
property OnRecreated;
|
|
property OnRecreating;
|
|
property OnDockChanged;
|
|
property OnDockChanging;
|
|
property OnDockChangingHidden;
|
|
property OnResize;
|
|
property OnShortCut;
|
|
property OnVisibleChanged;
|
|
end;
|
|
|
|
{ TTBXChevronItem }
|
|
|
|
TTBXChevronItem = class(TTBChevronItem)
|
|
public
|
|
procedure GetPopupPosition(ParentView: TTBView;
|
|
PopupWindow: TTBPopupWindow; var PopupPositionRec: TTBPopupPositionRec); override;
|
|
function GetPopupWindowClass: TTBPopupWindowClass; override;
|
|
function GetItemViewerClass(AView: TTBView): TTBItemViewerClass; override;
|
|
end;
|
|
|
|
TTBXChevronItemViewer = class(TTBItemViewer)
|
|
protected
|
|
procedure Paint(const Canvas: TCanvas; const ClientAreaRect: TRect;
|
|
IsHoverItem, IsPushed, UseDisabledShadow: Boolean); override;
|
|
end;
|
|
|
|
TTBXChevronPopupWindow = class(TTBXPopupWindow);
|
|
|
|
{ TTBXPopupMenu }
|
|
|
|
TTBXRootItem = class(TTBRootItem)
|
|
private
|
|
FPopupControlRect: TRect;
|
|
protected
|
|
function CreatePopupEx(SelectFirstItem: Boolean; const AControlRect: TRect;
|
|
Alignment: TTBPopupAlignment): TTBPopupWindow; virtual;
|
|
function GetPopupWindowClass: TTBPopupWindowClass; override;
|
|
procedure GetPopupPosition(ParentView: TTBView; PopupWindow: TTBPopupWindow;
|
|
var PopupPositionRec: TTBPopupPositionRec); override;
|
|
function OpenPopupEx(const SelectFirstItem, TrackRightButton: Boolean;
|
|
const ControlRect: TRect; const Alignment: TTBPopupAlignment;
|
|
const ReturnClickedItemOnly: Boolean): TTBCustomItem;
|
|
function PopupEx(const ControlRect: TRect; TrackRightButton: Boolean;
|
|
Alignment: TTBPopupAlignment = tbpaLeft;
|
|
ReturnClickedItemOnly: Boolean = False): TTBCustomItem;
|
|
end;
|
|
|
|
TTBXPopupMenu = class(TTBPopupMenu)
|
|
private
|
|
FToolBoxPopup: Boolean;
|
|
procedure TBMGetViewType(var Message: TMessage); message TBM_GETVIEWTYPE;
|
|
protected
|
|
function GetRootItemClass: TTBRootItemClass; override;
|
|
public
|
|
function PopupEx(const ControlRect: TRect;
|
|
ReturnClickedItemOnly: Boolean = False): TTBCustomItem;
|
|
property ToolBoxPopup: Boolean read FToolBoxPopup write FToolBoxPopup default False;
|
|
end;
|
|
|
|
TTBXFloatingWindowParent = class(TTBFloatingWindowParent)
|
|
private
|
|
FCloseButtonHover: Boolean;
|
|
FSnapDistance: Integer;
|
|
procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE;
|
|
procedure WMEraseBkgnd(var Message: TMessage); message WM_ERASEBKGND;
|
|
procedure WMNCMouseLeave(var Message: TMessage); message $2A2 {WM_NCMOUSELEAVE};
|
|
procedure WMNCMouseMove(var Message: TWMNCMouseMove); message WM_NCMOUSEMOVE;
|
|
procedure WMWindowPosChanging(var Message: TWMWindowPosChanging); message WM_WINDOWPOSCHANGING;
|
|
protected
|
|
procedure CancelNCHover;
|
|
procedure DrawNCArea(const DrawToDC: Boolean; const ADC: HDC;
|
|
const Clip: HRGN; RedrawWhat: TTBToolWindowNCRedrawWhat); override;
|
|
property CloseButtonHover: Boolean read FCloseButtonHover;
|
|
public
|
|
property SnapDistance: Integer read FSnapDistance write FSnapDistance default 0;
|
|
end;
|
|
|
|
TTBXToolWindow = class(TTBToolWindow)
|
|
private
|
|
FEffectiveColor: TColor;
|
|
FSnapDistance: Integer;
|
|
procedure CMColorChanged(var Message: TMessage); message CM_COLORCHANGED;
|
|
procedure CMControlChange(var Message: TCMControlChange); message CM_CONTROLCHANGE;
|
|
procedure CMTextChanged(var Message: TMessage); message CM_TEXTCHANGED;
|
|
procedure SetSnapDistance(Value: Integer);
|
|
procedure TBMGetEffectiveColor(var Message: TMessage); message TBM_GETEFFECTIVECOLOR;
|
|
procedure TBMGetViewType(var Message: TMessage); message TBM_GETVIEWTYPE;
|
|
procedure TBMThemeChange(var Message: TMessage); message TBM_THEMECHANGE;
|
|
procedure WMEraseBkgnd(var Message: TWmEraseBkgnd); message WM_ERASEBKGND;
|
|
protected
|
|
procedure DrawNCArea(const DrawToDC: Boolean; const ADC: HDC; const Clip: HRGN); override;
|
|
function GetFloatingWindowParentClass: TTBFloatingWindowParentClass; override;
|
|
procedure GetToolbarInfo(out ToolbarInfo: TTBXToolbarInfo); virtual;
|
|
procedure SetParent(AParent: TWinControl); override;
|
|
procedure UpdateEffectiveColor;
|
|
public
|
|
constructor Create(AOwner: TComponent); override;
|
|
destructor Destroy; override;
|
|
function GetFloatingBorderSize: TPoint; override;
|
|
procedure UpdateChildColors;
|
|
property EffectiveColor: TColor read FEffectiveColor;
|
|
published
|
|
property Color default clNone;
|
|
property DblClickUndock default False;
|
|
property SnapDistance: Integer read FSnapDistance write SetSnapDistance default 0;
|
|
end;
|
|
|
|
TTBXDock = class(TTBDock)
|
|
private
|
|
FMoving: Boolean;
|
|
FResizing: Boolean;
|
|
FUseParentBackground: Boolean;
|
|
procedure CMColorChanged(var Message: TMessage); message CM_COLORCHANGED;
|
|
procedure TBMGetEffectiveColor(var Message: TMessage); message TBM_GETEFFECTIVECOLOR;
|
|
procedure TBMThemeChange(var Message: TMessage); message TBM_THEMECHANGE;
|
|
procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND;
|
|
procedure WMMove(var Message: TWMMove); message WM_MOVE;
|
|
procedure WMSize(var Message: TWMSize); message WM_SIZE;
|
|
protected
|
|
function ThemedBackground: Boolean; virtual;
|
|
procedure DrawBackground(DC: HDC; const DrawRect: TRect); override;
|
|
procedure Resize; override;
|
|
procedure SetUseParentBackground(Value: Boolean);
|
|
function UsingBackground: Boolean; override;
|
|
public
|
|
constructor Create(AOwner: TComponent); override;
|
|
destructor Destroy; override;
|
|
published
|
|
property Color default clNone;
|
|
property UseParentBackground: Boolean read FUseParentBackground write SetUseParentBackground default False;
|
|
end;
|
|
|
|
{ TTBXMenuAnimation } {vb+}
|
|
|
|
TMenuAnimation = (maNone, maUnfold, maSlide, maFade);
|
|
TAnimationMode = (amNone, amSysDefault, amRandom, amUnfold, amSlide, amFade);
|
|
TAnimationModes = set of TAnimationMode;
|
|
|
|
TTBXMenuAnimation = class
|
|
private
|
|
FAnimationMode: TAnimationMode;
|
|
function SysParamEnabled(Param: Cardinal): Boolean;
|
|
function GetAvailableModes: TAnimationModes;
|
|
function GetMenuAnimation: TMenuAnimation;
|
|
procedure SetAnimationMode(Value: TAnimationMode);
|
|
property MenuAnimation: TMenuAnimation read GetMenuAnimation;
|
|
public
|
|
constructor Create(AAnimationMode: TAnimationMode = amSysDefault);
|
|
property AnimationMode: TAnimationMode read FAnimationMode write SetAnimationMode;
|
|
property AvailableModes: TAnimationModes read GetAvailableModes;
|
|
end;
|
|
|
|
var
|
|
CurrentTheme: TTBXTheme;
|
|
TBXMenuAnimation: TTBXMenuAnimation; { vb+ }
|
|
|
|
{$IFNDEF JR_D6}
|
|
var
|
|
clMoneyGreen: TColor = TColor($C0DCC0);
|
|
clSkyBlue: TColor = TColor($F0CAA6);
|
|
clCream: TColor = TColor($F0FBFF);
|
|
clMedGray: TColor = TColor($A4A0A0);
|
|
{$ENDIF}
|
|
|
|
procedure TBXSetTheme(const AThemeName: string);
|
|
function TBXCurrentTheme: string;
|
|
|
|
procedure AddThemeNotification(AObject: TObject);
|
|
procedure RemoveThemeNotification(AObject: TObject);
|
|
|
|
{ Additional system colors }
|
|
procedure AddTBXColor(var AColor: TColor; const AName: string);
|
|
function TBXIdentToColor(const Ident: string; var Color: Longint): Boolean;
|
|
function TBXColorToString(Color: TColor): string;
|
|
function TBXStringToColor(S: string): TColor;
|
|
procedure TBXGetColorValues(Proc: TGetStrProc);
|
|
|
|
{ Internal routines - do not use }
|
|
function GetPopupMargin(ItemViewer: TTBItemViewer): Integer;
|
|
function GetEffectiveColor(C: TControl): TColor;
|
|
procedure DrawParentBackground(Control: TControl; DC: HDC; R: TRect);
|
|
procedure AddToList(var List: TList; Item: Pointer);
|
|
procedure RemoveFromList(var List: TList; Item: Pointer);
|
|
|
|
implementation
|
|
|
|
{$R tbx_glyphs.res}
|
|
|
|
uses
|
|
TBXExtItems, TBXLists, TB2Common, TBXUxThemes, MultiMon, TBXDefaultTheme,
|
|
{ComCtrls, Menus;} {vb-}
|
|
ComCtrls, Menus, MMSystem; {vb+}
|
|
|
|
type
|
|
TTBItemAccess = class(TTBCustomItem);
|
|
TTBViewAccess = class(TTBView);
|
|
TTBItemViewerAccess = class(TTBItemViewer);
|
|
TTBFloatingWindowParentAccess = class(TTBFloatingWindowParent);
|
|
TTBCustomDockableWindowAccess = class(TTBCustomDockableWindow);
|
|
TTBXToolbarAccess = class(TTBXToolbar);
|
|
TTBBackgroundAccess = class(TTBBackground);
|
|
TControlAccess = class(TControl);
|
|
TTBXThemeAccess = class(TTBXTheme);
|
|
TDockAccess = class(TTBDock);
|
|
TTBPopupWindowAccess = class(TTBPopupWindow); {vb+}
|
|
|
|
{ TTBNexus }
|
|
TTBXNexus = class
|
|
private
|
|
FNotifies: TList;
|
|
procedure TBXSysCommand(var Message: TMessage); message TBX_SYSCOMMAND;
|
|
protected
|
|
procedure Broadcast(Msg: Cardinal; WParam, LParam: Integer);
|
|
public
|
|
constructor Create(const DefaultTheme: string);
|
|
destructor Destroy; override;
|
|
procedure SetTheme(const AThemeName: string);
|
|
function GetTheme: string;
|
|
procedure AddNotifie(AObject: TObject);
|
|
procedure RemoveNotifie(AObject: TObject);
|
|
end;
|
|
|
|
var
|
|
TBXNexus: TTBXNexus;
|
|
|
|
procedure AddThemeNotification(AObject: TObject);
|
|
begin
|
|
TBXNexus.AddNotifie(AObject);
|
|
end;
|
|
|
|
procedure RemoveThemeNotification(AObject: TObject);
|
|
begin
|
|
TBXNexus.RemoveNotifie(AObject);
|
|
end;
|
|
|
|
function GetEffectiveColor(C: TControl): TColor;
|
|
var
|
|
Message: TMessage;
|
|
begin
|
|
if C = nil then Result := clBtnFace
|
|
else
|
|
begin
|
|
Message.Msg := TBM_GETEFFECTIVECOLOR;
|
|
Message.WParam := 0;
|
|
Message.LParam := 0;
|
|
Message.Result := 0;
|
|
C.Dispatch(Message);
|
|
if Message.Result <> 0 then Result := Message.WParam
|
|
else if (C is TForm) and (TForm(C).FormStyle = fsMDIForm) then
|
|
Result := clBtnFace
|
|
else
|
|
Result := TControlAccess(C).Color;
|
|
end;
|
|
end;
|
|
|
|
procedure DrawParentBackground(Control: TControl; DC: HDC; R: TRect);
|
|
var
|
|
Parent: TWinControl;
|
|
Theme: HTHEME;
|
|
R2: TRect;
|
|
Shift: TPoint;
|
|
UsingThemes: Boolean;
|
|
Msg: TMessage;
|
|
begin
|
|
Parent := Control.Parent;
|
|
if Parent = nil then FillRectEx(DC, R, clBtnFace)
|
|
else
|
|
begin
|
|
Shift.X := 0; Shift.Y := 0;
|
|
Shift := Parent.ScreenToClient(Control.ClientToScreen(Shift));
|
|
SaveDC(DC);
|
|
try
|
|
SetWindowOrgEx(DC, Shift.X, Shift.Y, nil);
|
|
Msg.Msg := WM_ERASEBKGND;
|
|
Msg.WParam := Integer(DC); {vb+}
|
|
Msg.LParam := Integer(DC); {vb+}
|
|
Msg.Result := 0;
|
|
Parent.Dispatch(Msg);
|
|
finally
|
|
RestoreDC(DC, -1);
|
|
end;
|
|
|
|
if Msg.Result <> 0 then Exit;
|
|
|
|
UsingThemes := USE_THEMES and not (csDesigning in Control.ComponentState);
|
|
if Parent is TTBDock then
|
|
begin
|
|
SaveDC(DC);
|
|
SetWindowOrgEx(DC, Control.Left, Control.Top, nil);
|
|
TDockAccess(Parent).DrawBackground(DC, R);
|
|
RestoreDC(DC, -1);
|
|
end
|
|
else if not UsingThemes then
|
|
FillRectEx(DC, R, GetEffectiveColor(Parent))
|
|
else
|
|
begin
|
|
{ Unfortunately, DrawThemeParentBackground does seem to have some problems
|
|
with the back buffer. Therefore some sort of workaround is used which
|
|
will work for tab sheets }
|
|
// if Control is TWinControl then
|
|
// DrawThemeParentBackground(TWinControl(Control).Handle, DC, @R);
|
|
|
|
if Parent is TTabSheet then
|
|
begin
|
|
Theme := OpenThemeData(Parent.Handle, 'TAB');
|
|
R2 := Parent.ClientRect;
|
|
R2.TopLeft := Control.ScreenToClient(Parent.ClientToScreen(R2.TopLeft));
|
|
R2.BottomRight := Control.ScreenToClient(Parent.ClientToScreen(R2.BottomRight));
|
|
DrawThemeBackground(Theme, DC, TABP_BODY, 0, R2, @R);
|
|
CloseThemeData(Theme);
|
|
end
|
|
else FillRectEx(DC, R, GetEffectiveColor(Parent));
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function GetViewType(View: TTBView): Integer;
|
|
var
|
|
Message: TMessage;
|
|
begin
|
|
Result := VT_UNKNOWN;
|
|
if (View <> nil) and (View.Owner <> nil) then
|
|
begin
|
|
Message.Msg := TBM_GETVIEWTYPE;
|
|
Message.WParam := 0;
|
|
Message.LParam := 0;
|
|
Message.Result := VT_UNKNOWN;
|
|
View.Window.Dispatch(Message);
|
|
Result := Message.Result;
|
|
end;
|
|
end;
|
|
|
|
function GetWinViewType(Window: TControl): Integer;
|
|
var
|
|
Message: TMessage;
|
|
begin
|
|
Result := VT_UNKNOWN;
|
|
if Window <> nil then
|
|
begin
|
|
Message.Msg := TBM_GETVIEWTYPE;
|
|
Message.WParam := 0;
|
|
Message.LParam := 0;
|
|
Message.Result := VT_UNKNOWN;
|
|
Window.Dispatch(Message);
|
|
Result := Message.Result;
|
|
end;
|
|
end;
|
|
|
|
function IsFloating(ViewType: Integer): Boolean;
|
|
begin
|
|
Result := ViewType and TVT_FLOATING <> 0;
|
|
end;
|
|
|
|
procedure UpdateNCArea(Control: TWinControl; ViewType: Integer);
|
|
begin
|
|
with Control do
|
|
begin
|
|
ClientWidth := ClientWidth;
|
|
ClientHeight := ClientHeight;
|
|
end;
|
|
SetWindowPos(Control.Handle, 0, 0, 0, 0, 0,
|
|
SWP_FRAMECHANGED or SWP_NOACTIVATE or SWP_NOZORDER or SWP_NOMOVE or SWP_NOSIZE);
|
|
Control.Invalidate;
|
|
end;
|
|
|
|
function GetPopupMargin(ItemViewer: TTBItemViewer): Integer;
|
|
var
|
|
ImgList: TCustomImageList;
|
|
Sz: TSize;
|
|
TextMetric: TTextMetric;
|
|
H, M2: Integer;
|
|
Margins: TTBXMargins;
|
|
begin
|
|
Sz.Cx := 0;
|
|
Sz.Cy := 0;
|
|
if ItemViewer is TTBXItemViewer then
|
|
Sz := TTBXItemViewer(ItemViewer).GetImageSize;
|
|
if (Sz.Cx = 0) or (Sz.Cy = 0) then
|
|
begin
|
|
ImgList := TTBItemViewerAccess(ItemViewer).GetImageList;
|
|
if ImgList <> nil then
|
|
begin
|
|
Sz.Cx := ImgList.Width;
|
|
Sz.Cy := ImgList.Height;
|
|
end;
|
|
if (Sz.Cx = 0) or (Sz.Cy = 0) then
|
|
begin
|
|
Sz.Cx := 16;
|
|
Sz.Cy := 16;
|
|
end;
|
|
end;
|
|
StockBitmap1.Canvas.Font := TTBViewAccess(ItemViewer.View).GetFont;
|
|
GetTextMetrics(StockBitmap1.Canvas.Handle, TextMetric);
|
|
|
|
CurrentTheme.GetMargins(MID_MENUITEM, Margins);
|
|
M2 := Margins.TopHeight + Margins.BottomHeight;
|
|
Result := TextMetric.tmHeight + TextMetric.tmExternalLeading + M2;
|
|
H := Sz.CY + M2;
|
|
if H > Result then Result := H;
|
|
Result := (Sz.Cx + M2) * Result div H;
|
|
end;
|
|
|
|
procedure GetOfficeXPPopupPosition1(var PopupPositionRec: TTBPopupPositionRec);
|
|
begin
|
|
with PopupPositionRec do
|
|
begin
|
|
if not PositionAsSubmenu then
|
|
begin
|
|
NCSizeX := 0;
|
|
NCSizeY := 0;
|
|
Dec(ParentItemRect.Right);
|
|
if X = ParentItemRect.Right + 1 then Dec(X);
|
|
if X + W <= ParentItemRect.Left then Inc(X);
|
|
Dec(ParentItemRect.Bottom);
|
|
if Y = ParentItemRect.Bottom + 1 then Dec(Y);
|
|
if Y + H <= ParentItemRect.Top then Inc(Y);
|
|
Dec(W);
|
|
Dec(H);
|
|
end
|
|
else
|
|
begin
|
|
Inc(X, NCSizeX);
|
|
Inc(Y, NCSizeY);
|
|
NCSizeX := 0;
|
|
NCSizeY := 0;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure GetOfficeXPPopupPosition2(var PopupPositionRec: TTBPopupPositionRec);
|
|
begin
|
|
with PopupPositionRec do if not PositionAsSubmenu then
|
|
begin
|
|
Inc(W);
|
|
Inc(H);
|
|
end;
|
|
end;
|
|
|
|
procedure AddToList(var List: TList; Item: Pointer);
|
|
begin
|
|
if List = nil then List := TList.Create;
|
|
List.Add(Item)
|
|
end;
|
|
|
|
|
|
procedure RemoveFromList(var List: TList; Item: Pointer);
|
|
begin
|
|
if List <> nil then
|
|
begin
|
|
List.Remove(Item);
|
|
if List.Count = 0 then
|
|
begin
|
|
List.Free;
|
|
List := nil;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
//============================================================================//
|
|
|
|
{ Misc. Routines }
|
|
|
|
procedure InvalidateAll(const Ctl: TWinControl);
|
|
begin
|
|
if Ctl.HandleAllocated then
|
|
RedrawWindow(Ctl.Handle, nil, 0, RDW_FRAME or RDW_INVALIDATE or
|
|
RDW_ERASE);
|
|
end;
|
|
|
|
function GetStateFlags(const ItemInfo: TTBXItemInfo): Integer;
|
|
const
|
|
CEnabledStates: array [Boolean] of Integer = (ISF_DISABLED, 0);
|
|
CHotStates: array [Boolean] of Integer = (0, ISF_HOT);
|
|
CPushedStates: array [Boolean] of Integer = (0, ISF_PUSHED);
|
|
CSelectedStates: array [Boolean] of Integer = (0, ISF_SELECTED);
|
|
begin
|
|
with ItemInfo do
|
|
Result := CEnabledStates[ItemInfo.Enabled] or CPushedStates[ItemInfo.Pushed] or
|
|
CHotStates[ItemInfo.HoverKind = hkMouseHover] or CSelectedStates[ItemInfo.Selected];
|
|
end;
|
|
|
|
function GetTBXTextColor(StateFlags: Integer): TColor;
|
|
const
|
|
HoverKinds: array [Boolean] of TTBXHoverKind = (hkNone, hkMouseHover);
|
|
var
|
|
ItemInfo: TTBXItemInfo;
|
|
begin
|
|
FillChar(ItemInfo, SizeOf(ItemInfo), 0);
|
|
case StateFlags and ISF_LOCATIONMASK of
|
|
ISF_TOOLBARCOLOR:
|
|
begin
|
|
ItemInfo.ViewType := VT_TOOLBAR;
|
|
ItemInfo.ItemOptions := IO_TOOLBARSTYLE;
|
|
end;
|
|
ISF_MENUCOLOR:
|
|
begin
|
|
ItemInfo.ViewType := VT_DOCKPANEL;
|
|
end;
|
|
ISF_STATUSCOLOR:
|
|
begin
|
|
ItemInfo.ViewType := VT_STATUSBAR;
|
|
end;
|
|
else
|
|
ItemInfo.ViewType := VT_UNKNOWN;
|
|
end;
|
|
ItemInfo.Enabled := StateFlags and ISF_DISABLED = 0;
|
|
ItemInfo.Pushed := StateFlags and ISF_PUSHED <> 0;
|
|
ItemInfo.HoverKind := HoverKinds[StateFlags and ISF_HOT <> 0];
|
|
ItemInfo.Selected := StateFlags and ISF_SELECTED <> 0;
|
|
Result := CurrentTheme.GetItemTextColor(ItemInfo);
|
|
end;
|
|
|
|
procedure DrawTBXCaption(Canvas: TCanvas; Rect: TRect; const Text: string; Format: Cardinal; StateFlags: Integer);
|
|
const
|
|
HoverKinds: array [Boolean] of TTBXHoverKind = (hkNone, hkMouseHover);
|
|
var
|
|
ItemInfo: TTBXItemInfo;
|
|
begin
|
|
FillChar(ItemInfo, SizeOf(ItemInfo), 0);
|
|
case StateFlags and ISF_LOCATIONMASK of
|
|
ISF_TOOLBARCOLOR:
|
|
begin
|
|
ItemInfo.ViewType := VT_TOOLBAR;
|
|
ItemInfo.ItemOptions := IO_TOOLBARSTYLE;
|
|
end;
|
|
ISF_MENUCOLOR:
|
|
begin
|
|
ItemInfo.ViewType := VT_DOCKPANEL;
|
|
end;
|
|
ISF_STATUSCOLOR:
|
|
begin
|
|
ItemInfo.ViewType := VT_STATUSBAR;
|
|
end;
|
|
end;
|
|
ItemInfo.Enabled := StateFlags and ISF_DISABLED = 0;
|
|
ItemInfo.Pushed := StateFlags and ISF_PUSHED <> 0;
|
|
ItemInfo.HoverKind := HoverKinds[StateFlags and ISF_HOT <> 0];
|
|
ItemInfo.Selected := StateFlags and ISF_SELECTED <> 0;
|
|
CurrentTheme.PaintCaption(Canvas, Rect, ItemInfo, Text, Format, False);
|
|
end;
|
|
|
|
procedure DrawTBXImage(Canvas: TCanvas; Rect: TRect; ImageList: TCustomImageList;
|
|
ImageIndex: Integer; StateFlags: Integer);
|
|
const
|
|
HoverKinds: array [Boolean] of TTBXHoverKind = (hkNone, hkMouseHover);
|
|
var
|
|
ItemInfo: TTBXItemInfo;
|
|
begin
|
|
FillChar(ItemInfo, SizeOf(ItemInfo), 0);
|
|
case StateFlags and ISF_LOCATIONMASK of
|
|
ISF_TOOLBARCOLOR:
|
|
begin
|
|
ItemInfo.ViewType := VT_TOOLBAR;
|
|
ItemInfo.ItemOptions := IO_TOOLBARSTYLE;
|
|
end;
|
|
ISF_MENUCOLOR:
|
|
begin
|
|
ItemInfo.ViewType := VT_DOCKPANEL;
|
|
end;
|
|
ISF_STATUSCOLOR:
|
|
begin
|
|
ItemInfo.ViewType := VT_STATUSBAR;
|
|
end;
|
|
end;
|
|
ItemInfo.Enabled := not Boolean(StateFlags and ISF_DISABLED);
|
|
ItemInfo.Pushed := Boolean(StateFlags and ISF_PUSHED);
|
|
ItemInfo.HoverKind := HoverKinds[Boolean(StateFlags and ISF_HOT)];
|
|
ItemInfo.Selected := Boolean(StateFlags and ISF_SELECTED);
|
|
CurrentTheme.PaintImage(Canvas, Rect, ItemInfo, ImageList, ImageIndex);
|
|
end;
|
|
|
|
//============================================================================//
|
|
|
|
{ TFontSettings }
|
|
|
|
procedure TFontSettings.Apply(Font: TFont);
|
|
var
|
|
FS: TFontStyles;
|
|
begin
|
|
if Size <> 100 then Font.Size := (Font.Size * FSize + 50) div 100;
|
|
if Color <> clNone then Font.Color := Color;
|
|
if Name <> '' then Font.Name := Name;
|
|
FS := Font.Style;
|
|
if Bold = tsTrue then Include(FS, fsBold)
|
|
else if Bold = tsFalse then Exclude(FS, fsBold);
|
|
if Italic = tsTrue then Include(FS, fsItalic)
|
|
else if Italic = tsFalse then Exclude(FS, fsItalic);
|
|
if Underline = tsTrue then Include(FS, fsUnderline)
|
|
else if Underline = tsFalse then Exclude(FS, fsUnderline);
|
|
if StrikeOut = tsTrue then Include(FS, fsStrikeOut)
|
|
else if StrikeOut = tsFalse then Exclude(FS, fsStrikeOut);
|
|
Font.Style := FS;
|
|
end;
|
|
|
|
procedure TFontSettings.Apply(var LF: TLogFont; var FontColor: TColor);
|
|
begin
|
|
if Size <> 100 then LF.lfHeight := (LF.lfHeight * Size + 50) div 100;
|
|
if Color <> clNone then FontColor := Color;
|
|
if Name <> '' then StrPLCopy(LF.lfFaceName, Name, 31);
|
|
if Bold = tsTrue then LF.lfWeight := FW_BOLD
|
|
else if Bold = tsFalse then LF.lfWeight := FW_NORMAL;
|
|
if Italic = tsTrue then LF.lfItalic := 1
|
|
else if Italic = tsFalse then LF.lfItalic := 0;
|
|
if Underline = tsTrue then LF.lfUnderline := 1
|
|
else if Underline = tsFalse then LF.lfUnderline := 0;
|
|
if StrikeOut = tsTrue then LF.lfStrikeOut := 1
|
|
else if StrikeOut = tsFalse then LF.lfStrikeOut := 0;
|
|
end;
|
|
|
|
procedure TFontSettings.Assign(Src: TPersistent);
|
|
var
|
|
F: TFontSettings;
|
|
begin
|
|
if Src is TPersistent then
|
|
begin
|
|
F := TFontSettings(Src);
|
|
if (FBold <> F.Bold) or (FItalic <> F.Italic) or (FUnderline <> F.Underline) or
|
|
(FStrikeOut <> F.StrikeOut) or (FSize <> F.Size) or (FColor <> F.Color) or
|
|
(FName <> F.Name) then
|
|
begin
|
|
FBold := F.Bold;
|
|
FItalic := F.Italic;
|
|
FUnderline := F.Underline;
|
|
FStrikeOut := F.StrikeOut;
|
|
FSize := F.Size;
|
|
FColor := F.Color;
|
|
FName := F.Name;
|
|
Modified;
|
|
end;
|
|
end
|
|
else inherited;
|
|
end;
|
|
|
|
constructor TFontSettings.Create;
|
|
begin
|
|
FSize := 100;
|
|
FColor := clNone;
|
|
end;
|
|
|
|
function TFontSettings.CreateTransformedFont(Src: HFont; var FontColor: TColor): HFont;
|
|
var
|
|
LF: TLogFont;
|
|
begin
|
|
GetObject(Src, SizeOf(LF), @LF);
|
|
Apply(LF, FontColor);
|
|
Result := CreateFontIndirect(LF);
|
|
end;
|
|
|
|
procedure TFontSettings.Modified;
|
|
begin
|
|
if Assigned(FOnChange) then FOnChange(Self);
|
|
end;
|
|
|
|
procedure TFontSettings.SetBold(Value: TTriState);
|
|
begin
|
|
if FBold <> Value then
|
|
begin
|
|
FBold := Value;
|
|
Modified;
|
|
end;
|
|
end;
|
|
|
|
procedure TFontSettings.SetColor(Value: TColor);
|
|
begin
|
|
if FColor <> Value then
|
|
begin
|
|
FColor := Value;
|
|
Modified;
|
|
end;
|
|
end;
|
|
|
|
procedure TFontSettings.SetItalic(Value: TTriState);
|
|
begin
|
|
if FItalic <> Value then
|
|
begin
|
|
FItalic := Value;
|
|
Modified;
|
|
end;
|
|
end;
|
|
|
|
procedure TFontSettings.SetName(const Value: TFontName);
|
|
begin
|
|
if FName <> Value then
|
|
begin
|
|
FName := Value;
|
|
Modified;
|
|
end;
|
|
end;
|
|
|
|
procedure TFontSettings.SetSize(Value: TFontSize);
|
|
begin
|
|
if FSize <> Value then
|
|
begin
|
|
FSize := Value;
|
|
Modified;
|
|
end;
|
|
end;
|
|
|
|
procedure TFontSettings.SetStrikeOut(Value: TTriState);
|
|
begin
|
|
if FStrikeOut <> Value then
|
|
begin
|
|
FStrikeOut := Value;
|
|
Modified;
|
|
end;
|
|
end;
|
|
|
|
procedure TFontSettings.SetUnderline(Value: TTriState);
|
|
begin
|
|
if FUnderline <> Value then
|
|
begin
|
|
FUnderline := Value;
|
|
Modified;
|
|
end;
|
|
end;
|
|
|
|
//============================================================================//
|
|
|
|
{ TTBXCustomItem }
|
|
|
|
constructor TTBXCustomItem.Create(AOwner: TComponent);
|
|
begin
|
|
inherited;
|
|
FFontSettings := TFontSettings.Create;
|
|
FFontSettings.OnChange := FontSettingsChanged;
|
|
end;
|
|
|
|
function TTBXCustomItem.CreatePopup(const ParentView: TTBView;
|
|
const ParentViewer: TTBItemViewer; const PositionAsSubmenu,
|
|
SelectFirstItem, Customizing: Boolean; const APopupPoint: TPoint;
|
|
const Alignment: TTBPopupAlignment): TTBPopupWindow;
|
|
var
|
|
DoSelectFirstItem: Boolean;
|
|
begin
|
|
if AlwaysSelectFirst then DoSelectFirstItem := True
|
|
else DoSelectFirstItem := SelectFirstItem;
|
|
Result := inherited CreatePopup(ParentView, ParentViewer, PositionAsSubmenu,
|
|
DoSelectFirstItem, Customizing, APopupPoint, Alignment);
|
|
end;
|
|
|
|
destructor TTBXCustomItem.Destroy;
|
|
begin
|
|
FFontSettings.Free;
|
|
inherited;
|
|
end;
|
|
|
|
procedure TTBXCustomItem.FontSettingsChanged(Sender: TObject);
|
|
begin
|
|
Change(True);
|
|
end;
|
|
|
|
function TTBXCustomItem.GetItemViewerClass(AView: TTBView): TTBItemViewerClass;
|
|
begin
|
|
Result := TTBXItemViewer;
|
|
end;
|
|
|
|
procedure TTBXCustomItem.GetPopupPosition(ParentView: TTBView;
|
|
PopupWindow: TTBPopupWindow; var PopupPositionRec: TTBPopupPositionRec);
|
|
var
|
|
VT: Integer;
|
|
begin
|
|
if CurrentTheme.OfficeXPPopupAlignment then with PopupPositionRec do
|
|
begin
|
|
GetOfficeXPPopupPosition1(PopupPositionRec);
|
|
inherited GetPopupPosition(ParentView, PopupWindow, PopupPositionRec);
|
|
GetOfficeXPPopupPosition2(PopupPositionRec);
|
|
VT := GetWinViewType(PopupWindow);
|
|
PopupPositionRec.PlaySound := not (VT and PVT_LISTBOX = PVT_LISTBOX);
|
|
end
|
|
else inherited;
|
|
end;
|
|
|
|
function TTBXCustomItem.GetPopupWindowClass: TTBPopupWindowClass;
|
|
begin
|
|
Result := TTBXPopupWindow;
|
|
end;
|
|
|
|
function TTBXCustomItem.GetStretch: Boolean;
|
|
begin
|
|
Result := tbisStretch in ItemStyle;
|
|
end;
|
|
|
|
procedure TTBXCustomItem.Invalidate;
|
|
begin
|
|
Change(False);
|
|
end;
|
|
|
|
procedure TTBXCustomItem.SetFontSettings(Value: TFontSettings);
|
|
begin
|
|
FFontSettings.Assign(Value);
|
|
end;
|
|
|
|
procedure TTBXCustomItem.SetLayout(Value: TTBXItemLayout);
|
|
begin
|
|
if Value <> FLayout then
|
|
begin
|
|
FLayout := Value;
|
|
Change(True);
|
|
end;
|
|
end;
|
|
|
|
procedure TTBXCustomItem.SetMinHeight(Value: Integer);
|
|
begin
|
|
if Value <> FMinHeight then
|
|
begin
|
|
FMinHeight := Value;
|
|
Change(True);
|
|
end;
|
|
end;
|
|
|
|
procedure TTBXCustomItem.SetMinWidth(Value: Integer);
|
|
begin
|
|
if Value <> FMinWidth then
|
|
begin
|
|
FMinWidth := Value;
|
|
Change(True);
|
|
end;
|
|
end;
|
|
|
|
procedure TTBXCustomItem.SetStretch(Value: Boolean);
|
|
begin
|
|
if Value xor (tbisStretch in ItemStyle) then
|
|
begin
|
|
if Value then ItemStyle := ItemStyle + [tbisStretch]
|
|
else ItemStyle := ItemStyle - [tbisStretch];
|
|
Change(True);
|
|
end;
|
|
end;
|
|
|
|
|
|
//============================================================================//
|
|
|
|
{ TTBXItemViewer }
|
|
|
|
procedure TTBXItemViewer.CalcSize(const Canvas: TCanvas; var AWidth, AHeight: Integer);
|
|
const
|
|
CMarginIDs: array [Boolean] of Integer = (MID_MENUITEM, MID_TOOLBARITEM);
|
|
CStartSize: array [Boolean] of Integer = (0, 6);
|
|
var
|
|
W, H: Integer;
|
|
ImgSize: TSize;
|
|
Item: TTBCustomItem;
|
|
ItemLayout, SaveLayout: TTBXItemLayout;
|
|
IsCaptionShown: Boolean;
|
|
IsTextRotated: Boolean;
|
|
ToolbarStyle: Boolean;
|
|
S: string;
|
|
TextFlags: Cardinal;
|
|
TextMetric: TTextMetric;
|
|
TextSize: TSize;
|
|
Margins: TTBXMargins;
|
|
begin
|
|
Item := TTBCustomItem(Self.Item);
|
|
ToolbarStyle := IsToolbarStyle;
|
|
ImgSize := GetImageSize;
|
|
if (ImgSize.CX <= 0) or (ImgSize.CY <= 0) then
|
|
begin
|
|
ImgSize.CX := 0;
|
|
ImgSize.CY := 0;
|
|
end;
|
|
|
|
if Item is TTBXCustomItem then ItemLayout := TTBXCustomItem(Item).Layout
|
|
else ItemLayout := tbxlAuto;
|
|
SaveLayout := ItemLayout;
|
|
if ItemLayout = tbxlAuto then
|
|
begin
|
|
if tboImageAboveCaption in Item.EffectiveOptions then ItemLayout := tbxlGlyphTop
|
|
else
|
|
begin
|
|
if View.Orientation <> tbvoVertical then ItemLayout := tbxlGlyphLeft
|
|
else ItemLayout := tbxlGlyphTop;
|
|
end;
|
|
end;
|
|
|
|
{ Setup font }
|
|
TextFlags := 0;
|
|
IsCaptionShown := CaptionShown;
|
|
IsTextRotated := (View.Orientation = tbvoVertical) and ToolbarStyle;
|
|
if IsCaptionShown then
|
|
begin
|
|
S := GetCaptionText;
|
|
if not (SaveLayout = tbxlAuto) or (tboImageAboveCaption in Item.EffectiveOptions) then IsTextRotated := False;
|
|
if IsTextRotated or not ToolbarStyle then TextFlags := DT_SINGLELINE;
|
|
TextSize := GetTextSize(Canvas, S, TextFlags, IsTextRotated, 0);
|
|
end
|
|
else
|
|
begin
|
|
SetLength(S, 0);
|
|
TextSize.CX := 0;
|
|
TextSize.CY := 0;
|
|
IsTextRotated := False;
|
|
end;
|
|
|
|
{ Measure size }
|
|
if ToolbarStyle then
|
|
begin
|
|
AWidth := 6;
|
|
AHeight := 6;
|
|
|
|
if CaptionShown then
|
|
begin
|
|
Inc(AWidth, TextSize.CX);
|
|
Inc(AHeight, TextSize.CY);
|
|
if not IsTextRotated then Inc(AWidth, 4)
|
|
else Inc(AHeight, 4);
|
|
end;
|
|
|
|
if GetImageShown and (ImgSize.CX > 0) and (ImgSize.CY > 0) then
|
|
begin
|
|
if ItemLayout = tbxlGlyphLeft then
|
|
begin
|
|
Inc(AWidth, ImgSize.CX);
|
|
if Wide then Inc(AWidth);
|
|
if AHeight < ImgSize.CY + 6 then AHeight := ImgSize.CY + 6;
|
|
end
|
|
else
|
|
begin
|
|
Inc(AHeight, ImgSize.CY);
|
|
if AWidth < ImgSize.CX + 7 then AWidth := ImgSize.CX + 7;
|
|
end;
|
|
end;
|
|
|
|
if tbisSubmenu in TTBItemAccess(Item).ItemStyle then with CurrentTheme do
|
|
begin
|
|
if tbisCombo in TTBItemAccess(Item).ItemStyle then Inc(AWidth, SplitBtnArrowWidth)
|
|
else if tboDropdownArrow in Item.EffectiveOptions then
|
|
begin
|
|
if (ItemLayout <> tbxlGlyphTop) or (ImgSize.CX = 0) or IsTextRotated then
|
|
begin
|
|
if View.Orientation <> tbvoVertical then Inc(AWidth, DropdownArrowWidth)
|
|
else Inc(AHeight, DropdownArrowWidth);
|
|
end
|
|
else
|
|
begin
|
|
if (ItemLayout = tbxlGlyphTop) and (IsTextRotated xor (View.Orientation <> tbvoVertical)) then
|
|
begin
|
|
W := ImgSize.CX + DropDownArrowWidth + 2;
|
|
if W > AWidth - 7 then AWidth := W + 7;
|
|
end
|
|
else
|
|
begin
|
|
H := ImgSize.CY + DropDownArrowWidth + 2;
|
|
if H > AHeight - 7 then AHeight := H + 7;
|
|
end;
|
|
end
|
|
end;
|
|
end;
|
|
end
|
|
else // Not a ToolbarStyle
|
|
with CurrentTheme do
|
|
begin
|
|
GetTextMetrics(Canvas.Handle, TextMetric);
|
|
Inc(TextSize.CY, TextMetric.tmExternalLeading);
|
|
|
|
AWidth := TextSize.CX;
|
|
AHeight := TextSize.CY;
|
|
|
|
if ImgSize.CY = 0 then ImgSize.CY := 16;
|
|
if AHeight < ImgSize.CY then AHeight := ImgSize.CY;
|
|
|
|
GetMargins(MID_MENUITEM, Margins);
|
|
Inc(AWidth, Margins.LeftWidth + Margins.RightWidth);
|
|
Inc(AHeight, Margins.TopHeight + Margins.BottomHeight);
|
|
|
|
Inc(AWidth, GetPopupMargin(Self) + MenuImageTextSpace + MenuLeftCaptionMargin + MenuRightCaptionMargin);
|
|
S := Item.GetShortCutText;
|
|
if Length(S) > 0 then Inc(AWidth, (AHeight - 6) + GetTextWidth(Canvas.Handle, S, True));
|
|
Inc(AWidth, AHeight); { Note: maybe this should be controlled by the theme }
|
|
end;
|
|
|
|
if Item is TTBXCustomItem then with TTBXCustomItem(Item) do
|
|
begin
|
|
if AWidth < MinWidth then AWidth := MinWidth;
|
|
if AHeight < MinHeight then AHeight := MinHeight;
|
|
end;
|
|
end;
|
|
|
|
constructor TTBXItemViewer.Create(AView: TTBView; AItem: TTBCustomItem; AGroupLevel: Integer);
|
|
begin
|
|
inherited;
|
|
FWide := True;
|
|
end;
|
|
|
|
procedure TTBXItemViewer.DoAdjustFont(AFont: TFont; StateFlags: Integer);
|
|
begin
|
|
if tboDefault in Item.EffectiveOptions then with AFont do Style := Style + [fsBold];
|
|
if Item is TTBXCustomItem then
|
|
with TTBXCustomItem(Item) do
|
|
begin
|
|
FontSettings.Apply(AFont);
|
|
if Assigned(FOnAdjustFont) then FOnAdjustFont(Item, Self, AFont, StateFlags);
|
|
end
|
|
else if Item is TTBXEditItem then
|
|
with TTBXEditItem(Item) do
|
|
begin
|
|
FontSettings.Apply(AFont);
|
|
end;
|
|
end;
|
|
|
|
procedure TTBXItemViewer.DoPaintCaption(Canvas: TCanvas; const ClientAreaRect: TRect;
|
|
var CaptionRect: TRect; IsTextRotated: Boolean; var PaintDefault: Boolean);
|
|
begin
|
|
// do nothing
|
|
end;
|
|
|
|
procedure TTBXItemViewer.DrawItemImage(Canvas: TCanvas; ARect: TRect; ItemInfo: TTBXItemInfo);
|
|
var
|
|
ImgList: TCustomImageList;
|
|
I: TTBXCustomItem;
|
|
begin
|
|
ImgList := GetImageList;
|
|
if (ImgList <> nil) and (Item.ImageIndex >= 0) and (Item.ImageIndex < ImgList.Count) then
|
|
begin
|
|
CurrentTheme.PaintImage(Canvas, ARect, ItemInfo, ImgList, Item.ImageIndex);
|
|
if Item is TTBXCustomItem then
|
|
begin
|
|
I := TTBXCustomItem(Item);
|
|
if Assigned(I.FOnDrawImage) then
|
|
I.FOnDrawImage(I, Self, Canvas, ARect,
|
|
CurrentTheme.GetImageOffset(Canvas, ItemInfo, ImgList),
|
|
GetStateFlags(ItemInfo));
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function TTBXItemViewer.GetAccRole: Integer;
|
|
{ Returns the MSAA "role" of the viewer. }
|
|
const
|
|
{ Constants from OleAcc.h }
|
|
ROLE_SYSTEM_BUTTONDROPDOWNGRID = $3A;
|
|
begin
|
|
Result := inherited GetAccRole;
|
|
if (Item is TTBXCustomItem) and TTBXCustomItem(Item).ToolBoxPopup and
|
|
(tbisSubmenu in TTBXCustomItem(Item).ItemStyle) then
|
|
Result := ROLE_SYSTEM_BUTTONDROPDOWNGRID;
|
|
end;
|
|
|
|
function TTBXItemViewer.GetImageShown: Boolean;
|
|
begin
|
|
Result := (Item.ImageIndex >= 0) and
|
|
((Item.DisplayMode in [nbdmDefault, nbdmImageAndText]) or
|
|
(IsToolbarStyle and (Item.DisplayMode = nbdmTextOnlyInMenus)));
|
|
end;
|
|
|
|
function TTBXItemViewer.GetImageSize: TSize;
|
|
var
|
|
ImgList: TCustomImageList;
|
|
begin
|
|
ImgList := GetImageList;
|
|
with Result do if ImgList <> nil then
|
|
begin
|
|
CX := ImgList.Width;
|
|
CY := ImgList.Height;
|
|
end
|
|
else
|
|
begin
|
|
CX := 0;
|
|
CY := 0;
|
|
end;
|
|
end;
|
|
|
|
function TTBXItemViewer.GetItemType: Integer;
|
|
begin
|
|
if IsToolbarStyle then Result := IT_TOOLBARBUTTON
|
|
else Result := IT_MENUITEM;
|
|
end;
|
|
|
|
function TTBXItemViewer.GetTextFlags: Cardinal;
|
|
begin
|
|
Result := 0;
|
|
if not AreKeyboardCuesEnabled and (vsUseHiddenAccels in View.Style) and
|
|
not (vsShowAccels in View.State) then Result := DT_HIDEPREFIX;
|
|
end;
|
|
|
|
function TTBXItemViewer.GetTextSize(Canvas: TCanvas; const Text: string;
|
|
TextFlags: Cardinal; Rotated: Boolean; StateFlags: Integer): TSize;
|
|
var
|
|
DC: HDC;
|
|
R: TRect;
|
|
RotatedFont, SaveFont: HFONT;
|
|
TextMetric: TTextMetric;
|
|
begin
|
|
{ note: rotated font size is consistent only for single-line captions! }
|
|
if Length(Text) = 0 then with Result do
|
|
begin
|
|
CX := 0;
|
|
CY := 0;
|
|
Exit;
|
|
end;
|
|
|
|
{ Select proper font }
|
|
Canvas.Font := TTBViewAccess(View).GetFont;
|
|
DoAdjustFont(Canvas.Font, StateFlags);
|
|
|
|
if not Rotated then with R, Result do
|
|
begin
|
|
Left := 0; Right := 1;
|
|
Top := 0; Bottom := 0;
|
|
DrawText(Canvas.Handle, PChar(Text), Length(Text), R, TextFlags or DT_CALCRECT);
|
|
CX := Right;
|
|
CY := Bottom;
|
|
end
|
|
else
|
|
begin
|
|
DC := Canvas.Handle;
|
|
RotatedFont := CreateRotatedFont(DC);
|
|
SaveFont := SelectObject(DC, RotatedFont);
|
|
GetTextMetrics(DC, TextMetric);
|
|
Result.CX := TextMetric.tmHeight;
|
|
Result.CY := GetTextWidth(DC, Text, True);
|
|
SelectObject(DC, SaveFont);
|
|
DeleteObject(RotatedFont);
|
|
end;
|
|
end;
|
|
|
|
function TTBXItemViewer.IsPtInButtonPart(X, Y: Integer): Boolean;
|
|
var
|
|
W: Integer;
|
|
begin
|
|
Result := not (tbisSubmenu in TTBItemAccess(Item).ItemStyle);
|
|
if (tbisCombo in TTBItemAccess(Item).ItemStyle) then
|
|
begin
|
|
if IsToolbarStyle then W := CurrentTheme.SplitBtnArrowWidth
|
|
else W := GetSystemMetrics(SM_CXMENUCHECK);
|
|
Result := X < (BoundsRect.Right - BoundsRect.Left) - W;
|
|
end;
|
|
end;
|
|
|
|
function TTBXItemViewer.IsToolbarSize: Boolean;
|
|
begin
|
|
Result := inherited IsToolbarSize;
|
|
Result := Result or ((GetViewType(View) and PVT_TOOLBOX) = PVT_TOOLBOX);
|
|
end;
|
|
|
|
function TTBXItemViewer.IsToolbarStyle: Boolean;
|
|
begin
|
|
Result := inherited IsToolbarStyle;
|
|
Result := Result or ((GetViewType(View) and PVT_TOOLBOX) = PVT_TOOLBOX);
|
|
end;
|
|
|
|
procedure TTBXItemViewer.MouseUp(X, Y: Integer; MouseWasDownOnMenu: Boolean);
|
|
begin
|
|
inherited;
|
|
{ Force the item to behave as a 'normal' menu item
|
|
That is make it respond to mouse as an item with IsToolbarStyle = False }
|
|
if Item.Enabled and not ((tbisSubmenu in TTBItemAccess(Item).ItemStyle) and
|
|
not IsPtInButtonPart(X, Y)) then
|
|
begin
|
|
if View.MouseOverSelected then
|
|
begin
|
|
Execute(True);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TTBXItemViewer.Paint(const Canvas: TCanvas;
|
|
const ClientAreaRect: TRect; IsHoverItem, IsPushed, UseDisabledShadow: Boolean);
|
|
const
|
|
CToolbarStyle: array [Boolean] of Integer = (0, IO_TOOLBARSTYLE);
|
|
CCombo: array [Boolean] of Integer = (0, IO_COMBO);
|
|
CSubmenuItem: array [Boolean] of Integer = (0, IO_SUBMENUITEM);
|
|
CDesigning: array [Boolean] of Integer = (0, IO_DESIGNING);
|
|
CAppActive: array [Boolean] of Integer = (0, IO_APPACTIVE);
|
|
var
|
|
Item: TTBXCustomItem;
|
|
View: TTBViewAccess;
|
|
ItemInfo: TTBXItemInfo;
|
|
|
|
{M: Integer;} {vb-}
|
|
R: TRect;
|
|
ComboRect: TRect;
|
|
CaptionRect: TRect;
|
|
ImageRect: TRect;
|
|
C: TColor;
|
|
|
|
ToolbarStyle: Boolean;
|
|
HasArrow: Boolean;
|
|
IsSplit: Boolean;
|
|
ImageIsShown: Boolean;
|
|
ImageOrCheckShown: Boolean;
|
|
ImgAndArrowWidth: Integer;
|
|
ImgSize: TSize;
|
|
IsComboPushed: Boolean;
|
|
IsCaptionShown: Boolean;
|
|
IsTextRotated: Boolean;
|
|
ItemLayout: TTBXItemLayout;
|
|
PaintDefault: Boolean;
|
|
S: string;
|
|
StateFlags: Integer;
|
|
IsSpecialDropDown: Boolean;
|
|
TextFlags: Cardinal;
|
|
TextMetrics: TTextMetric;
|
|
TextSize: TSize;
|
|
Margins: TTBXMargins;
|
|
begin
|
|
Item := TTBXCustomItem(Self.Item);
|
|
View := TTBViewAccess(Self.View);
|
|
|
|
ToolbarStyle := IsToolbarStyle;
|
|
IsSplit := tbisCombo in Item.ItemStyle;
|
|
IsComboPushed := IsSplit and IsPushed and not View.Capture;
|
|
if IsComboPushed then IsPushed := False;
|
|
|
|
if GetImageShown then
|
|
begin
|
|
ImgSize := GetImageSize;
|
|
with ImgSize do if (CX <= 0) or (CY <= 0) then
|
|
begin
|
|
CX := 0;
|
|
CY := 0;
|
|
ImageIsShown := False;
|
|
end
|
|
else ImageIsShown := True;
|
|
end
|
|
else
|
|
begin
|
|
ImgSize.CX := 0;
|
|
ImgSize.CY := 0;
|
|
ImageIsShown := False;
|
|
end;
|
|
IsSplit := tbisCombo in Item.ItemStyle;
|
|
|
|
FillChar(ItemInfo, SizeOf(ItemInfo), 0);
|
|
ItemInfo.ViewType := GetViewType(View);
|
|
ItemInfo.ItemOptions := CToolbarStyle[ToolbarStyle] or CCombo[IsSplit] or
|
|
CDesigning[csDesigning in Item.ComponentState] or CSubmenuItem[tbisSubmenu in Item.ItemStyle] or
|
|
CAppActive[Application.Active];
|
|
ItemInfo.Enabled := Item.Enabled or View.Customizing;
|
|
ItemInfo.Pushed := IsPushed;
|
|
ItemInfo.Selected := Item.Checked;
|
|
ItemInfo.ImageShown := ImageIsShown;
|
|
ItemInfo.ImageWidth := ImgSize.CX;
|
|
ItemInfo.ImageHeight := ImgSize.CY;
|
|
if IsHoverItem then
|
|
begin
|
|
if not ItemInfo.Enabled and not View.MouseOverSelected then ItemInfo.HoverKind := hkKeyboardHover
|
|
else if ItemInfo.Enabled then ItemInfo.HoverKind := hkMouseHover;
|
|
end
|
|
else ItemInfo.HoverKind := hkNone;
|
|
ItemInfo.IsPopupParent := ToolbarStyle and
|
|
(((vsModal in View.State) and Assigned(View.OpenViewer)) or (tbisSubmenu in Item.ItemStyle)) and
|
|
((IsSplit and IsComboPushed) or (not IsSplit and IsPushed));
|
|
ItemInfo.IsVertical := (View.Orientation = tbvoVertical) and not IsSplit;
|
|
ItemInfo.PopupMargin := GetPopupMargin(Self);
|
|
|
|
ItemLayout := Item.Layout;
|
|
if ItemLayout = tbxlAuto then
|
|
begin
|
|
if tboImageAboveCaption in Item.EffectiveOptions then ItemLayout := tbxlGlyphTop
|
|
else if View.Orientation <> tbvoVertical then ItemLayout := tbxlGlyphLeft
|
|
else ItemLayout := tbxlGlyphTop;
|
|
end;
|
|
|
|
HasArrow := (tbisSubmenu in Item.ItemStyle) and
|
|
((tbisCombo in Item.ItemStyle) or (tboDropdownArrow in Item.EffectiveOptions));
|
|
|
|
if GetImageShown then
|
|
begin
|
|
ImgSize := GetImageSize;
|
|
with ImgSize do if (CX <= 0) or (CY <= 0) then
|
|
begin
|
|
CX := 0;
|
|
CY := 0;
|
|
ImageIsShown := False;
|
|
end
|
|
else ImageIsShown := True;
|
|
end
|
|
else
|
|
begin
|
|
ImgSize.CX := 0;
|
|
ImgSize.CY := 0;
|
|
ImageIsShown := False;
|
|
end;
|
|
ImageOrCheckShown := ImageIsShown or (not ToolbarStyle and Item.Checked);
|
|
|
|
StateFlags := GetStateFlags(ItemInfo);
|
|
|
|
Canvas.Font := TTBViewAccess(View).GetFont;
|
|
Canvas.Font.Color := CurrentTheme.GetItemTextColor(ItemInfo);
|
|
DoAdjustFont(Canvas.Font, StateFlags);
|
|
C := Canvas.Font.Color;
|
|
|
|
{ Setup font }
|
|
TextFlags := GetTextFlags;
|
|
IsCaptionShown := CaptionShown;
|
|
IsTextRotated := (View.Orientation = tbvoVertical) and ToolbarStyle;
|
|
if IsCaptionShown then
|
|
begin
|
|
S := GetCaptionText;
|
|
if (Item.Layout <> tbxlAuto) or (tboImageAboveCaption in Item.EffectiveOptions) then
|
|
IsTextRotated := False;
|
|
if IsTextRotated or not ToolbarStyle then TextFlags := TextFlags or DT_SINGLELINE;
|
|
TextSize := GetTextSize(Canvas, S, TextFlags, IsTextRotated, StateFlags);
|
|
end
|
|
else
|
|
begin
|
|
StateFlags := 0;
|
|
SetLength(S, 0);
|
|
IsTextRotated := False;
|
|
TextSize.CX := 0;
|
|
TextSize.CY := 0;
|
|
end;
|
|
|
|
IsSpecialDropDown := HasArrow and not IsSplit and ToolbarStyle and
|
|
((Item.Layout = tbxlGlyphTop) or (Item.Layout = tbxlAuto) and (tboImageAboveCaption in Item.EffectiveOptions)) and
|
|
(ImgSize.CX > 0) and not (IsTextRotated) and (TextSize.CX > 0);
|
|
|
|
{ Border & Arrows }
|
|
R := ClientAreaRect;
|
|
with CurrentTheme do if ToolbarStyle then
|
|
begin
|
|
GetMargins(MID_TOOLBARITEM, Margins);
|
|
if HasArrow then with R do
|
|
begin
|
|
ItemInfo.ComboPart := cpCombo;
|
|
if IsSplit then
|
|
begin
|
|
ItemInfo.ComboPart := cpSplitLeft;
|
|
ComboRect := R;
|
|
Dec(Right, SplitBtnArrowWidth);
|
|
ComboRect.Left := Right;
|
|
end
|
|
else if not IsSpecialDropDown then
|
|
begin
|
|
if View.Orientation <> tbvoVertical then
|
|
ComboRect := Rect(Right - DropdownArrowWidth - DropdownArrowMargin, 0,
|
|
Right - DropdownArrowMargin, Bottom)
|
|
else
|
|
ComboRect := Rect(0, Bottom - DropdownArrowWidth - DropdownArrowMargin,
|
|
Right, Bottom - DropdownArrowMargin);
|
|
end
|
|
else
|
|
begin
|
|
ImgAndArrowWidth := ImgSize.CX + DropdownArrowWidth + 2;
|
|
ComboRect.Right := (R.Left + R.Right + ImgAndArrowWidth + 2) div 2;
|
|
ComboRect.Left := ComboRect.Right - DropdownArrowWidth;
|
|
ComboRect.Top := (R.Top + R.Bottom - ImgSize.cy - 2 - TextSize.CY) div 2;
|
|
ComboRect.Bottom := ComboRect.Top + ImgSize.CY;
|
|
end;
|
|
end
|
|
else SetRectEmpty(ComboRect);
|
|
|
|
if not IsSplit then
|
|
begin
|
|
PaintButton(Canvas, R, ItemInfo);
|
|
if HasArrow then
|
|
begin
|
|
PaintDropDownArrow(Canvas, ComboRect, ItemInfo);
|
|
if not IsSpecialDropDown then
|
|
begin
|
|
if View.Orientation <> tbvoVertical then Dec(R.Right, DropdownArrowWidth)
|
|
else Dec(R.Bottom, DropdownArrowWidth);
|
|
end;
|
|
end;
|
|
end
|
|
else // IsSplit
|
|
begin
|
|
CurrentTheme.PaintButton(Canvas, R, ItemInfo);
|
|
ItemInfo.Pushed := IsComboPushed;
|
|
ItemInfo.Selected := False;
|
|
ItemInfo.ComboPart := cpSplitRight;
|
|
CurrentTheme.PaintButton(Canvas, ComboRect, ItemInfo);
|
|
ItemInfo.ComboPart := cpSplitLeft;
|
|
ItemInfo.Pushed := IsPushed;
|
|
ItemInfo.Selected := Item.Checked;
|
|
end;
|
|
InflateRect(R, -2, -2);
|
|
end
|
|
else // not toolbar style
|
|
begin
|
|
GetMargins(MID_MENUITEM, Margins);
|
|
PaintMenuItem(Canvas, R, ItemInfo);
|
|
Inc(R.Left, Margins.LeftWidth);
|
|
Dec(R.Right, Margins.RightWidth);
|
|
Inc(R.Top, Margins.TopHeight);
|
|
Dec(R.Bottom, Margins.BottomHeight);
|
|
end;
|
|
|
|
{ Caption }
|
|
if IsCaptionShown then
|
|
begin
|
|
if ToolbarStyle then
|
|
begin
|
|
CaptionRect := R;
|
|
TextFlags := TextFlags or DT_CENTER or DT_VCENTER;
|
|
if ImageIsShown then with CaptionRect do
|
|
case ItemLayout of
|
|
tbxlGlyphLeft:
|
|
begin
|
|
Inc(Left, ImgSize.CX + 3);
|
|
Top := (Top + Bottom - TextSize.CY) div 2;
|
|
Bottom := Top + TextSize.CY;
|
|
Left := (Left + Right - TextSize.CX) div 2;
|
|
Right := Left + TextSize.CX;
|
|
TextFlags := TextFlags and not DT_CENTER;
|
|
end;
|
|
tbxlGlyphTop:
|
|
begin
|
|
Inc(Top, ImgSize.CY + 1);
|
|
if IsTextRotated then Inc(CaptionRect.Top, 3);
|
|
Top := (Top + Bottom - TextSize.CY) div 2;
|
|
Bottom := Top + TextSize.CY;
|
|
Left := (Left + Right - TextSize.CX) div 2;
|
|
Right := Left + TextSize.CX;
|
|
TextFlags := TextFlags and not DT_VCENTER;
|
|
end;
|
|
end
|
|
else
|
|
begin
|
|
with CaptionRect, TextSize do
|
|
begin
|
|
Left := (Left + R.Right - CX) div 2;
|
|
Top := (Top + R.Bottom - CY) div 2;
|
|
Right := Left + CX;
|
|
Bottom := Top + CY;
|
|
end;
|
|
end;
|
|
|
|
Canvas.Font.Color := C;
|
|
PaintDefault := True;
|
|
DoPaintCaption(Canvas, ClientAreaRect, CaptionRect, IsTextRotated, PaintDefault);
|
|
if PaintDefault then
|
|
CurrentTheme.PaintCaption(Canvas, CaptionRect, ItemInfo, S, TextFlags, IsTextRotated);
|
|
end
|
|
else with CurrentTheme do
|
|
begin
|
|
TextFlags := DT_LEFT or DT_VCENTER or TextFlags;
|
|
TextSize := GetTextSize(Canvas, S, TextFlags, False, StateFlags); { TODO : Check if this line is required }
|
|
GetTextMetrics(Canvas.Handle, TextMetrics);
|
|
|
|
CaptionRect := R;
|
|
Inc(CaptionRect.Left, ItemInfo.PopupMargin + MenuImageTextSpace + MenuLeftCaptionMargin);
|
|
with TextMetrics, CaptionRect do
|
|
if (Bottom - Top) - (tmHeight + tmExternalLeading) = Margins.BottomHeight then Dec(Bottom);
|
|
Inc(CaptionRect.Top, TextMetrics.tmExternalLeading);
|
|
|
|
CaptionRect.Right := CaptionRect.Left + TextSize.CX;
|
|
|
|
Canvas.Font.Color := C;
|
|
PaintDefault := True;
|
|
DoPaintCaption(Canvas, ClientAreaRect, CaptionRect, IsTextRotated, PaintDefault);
|
|
if PaintDefault then
|
|
CurrentTheme.PaintCaption(Canvas, CaptionRect, ItemInfo, S, TextFlags, IsTextRotated);
|
|
end;
|
|
end;
|
|
|
|
{ Shortcut and/or submenu arrow (menus only) }
|
|
if not ToolbarStyle then
|
|
begin
|
|
S := Item.GetShortCutText;
|
|
if Length(S) > 0 then
|
|
begin
|
|
CaptionRect := R;
|
|
with CaptionRect, TextMetrics do
|
|
begin
|
|
Left := Right - (Bottom - Top) - GetTextWidth(Canvas.Handle, S, True);
|
|
if (Bottom - Top) - (tmHeight + tmExternalLeading) = Margins.BottomHeight then Dec(Bottom);
|
|
Inc(Top, TextMetrics.tmExternalLeading);
|
|
end;
|
|
Canvas.Font.Color := C;
|
|
PaintDefault := True;
|
|
DoPaintCaption(Canvas, ClientAreaRect, CaptionRect, IsTextRotated, PaintDefault);
|
|
if PaintDefault then
|
|
CurrentTheme.PaintCaption(Canvas, CaptionRect, ItemInfo, S, TextFlags, False);
|
|
end;
|
|
end;
|
|
|
|
{ Image, or check box }
|
|
if ImageOrCheckShown then
|
|
begin
|
|
ImageRect := R;
|
|
|
|
if ToolBarStyle then
|
|
begin
|
|
if IsSpecialDropDown then OffsetRect(ImageRect, (-CurrentTheme.DropdownArrowWidth + 1) div 2, 0);
|
|
if ItemLayout = tbxlGlyphLeft then ImageRect.Right := ImageRect.Left + ImgSize.CX + 2
|
|
else
|
|
begin
|
|
ImageRect.Top := (ImageRect.Top + ImageRect.Bottom - ImgSize.cy - 2 - TextSize.cy) div 2;
|
|
ImageRect.Bottom := ImageRect.Top + ImgSize.CY;
|
|
end;
|
|
end
|
|
else ImageRect.Right := ImageRect.Left + ClientAreaRect.Bottom - ClientAreaRect.Top;
|
|
|
|
if ImageIsShown then with ImageRect, ImgSize do
|
|
begin
|
|
Left := Left + ((Right - Left) - CX) div 2;
|
|
ImageRect.Top := Top + ((Bottom - Top) - CY) div 2;
|
|
Right := Left + CX;
|
|
Bottom := Top + CY;
|
|
DrawItemImage(Canvas, ImageRect, ItemInfo);
|
|
end
|
|
{else if not ToolbarStyle and Item.Checked then
|
|
CurrentTheme.PaintCheckMark(Canvas, ImageRect, ItemInfo);} {vb-}
|
|
else {vb+}
|
|
if not ToolbarStyle and Item.Checked then
|
|
begin
|
|
if Item.RadioItem then
|
|
with ItemInfo do ItemOptions := ItemOptions or IO_RADIO;
|
|
CurrentTheme.PaintCheckMark(Canvas, ImageRect, ItemInfo);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
|
|
//============================================================================//
|
|
|
|
{ TTBXSubmenuItem }
|
|
|
|
constructor TTBXSubmenuItem.Create(AOwner: TComponent);
|
|
begin
|
|
inherited;
|
|
ItemStyle := ItemStyle + [tbisSubMenu, tbisSubitemsEditable];
|
|
end;
|
|
|
|
function TTBXSubmenuItem.GetDropdownCombo: Boolean;
|
|
begin
|
|
Result := tbisCombo in ItemStyle;
|
|
end;
|
|
|
|
procedure TTBXSubmenuItem.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;
|
|
|
|
|
|
|
|
//============================================================================//
|
|
|
|
{ TTBXSeparatorItem }
|
|
|
|
constructor TTBXSeparatorItem.Create(AOwner: TComponent);
|
|
begin
|
|
inherited;
|
|
FSize := -1; // use default from as in TTBSeparatorItem
|
|
end;
|
|
|
|
function TTBXSeparatorItem.GetItemViewerClass(AView: TTBView): TTBItemViewerClass;
|
|
begin
|
|
Result := TTBXSeparatorItemViewer;
|
|
end;
|
|
|
|
procedure TTBXSeparatorItem.SetSize(Value: Integer);
|
|
begin
|
|
if Value < -1 then Value := -1;
|
|
if Value <> FSize then
|
|
begin
|
|
FSize := Value;
|
|
Change(True);
|
|
end;
|
|
end;
|
|
|
|
|
|
//============================================================================//
|
|
|
|
{ TTBXSeparatorItemViewer }
|
|
|
|
procedure TTBXSeparatorItemViewer.CalcSize(const Canvas: TCanvas;
|
|
var AWidth, AHeight: Integer);
|
|
var
|
|
SZ: Integer;
|
|
begin
|
|
SZ := TTBXSeparatorItem(Item).Size;
|
|
if SZ < 0 then
|
|
begin
|
|
if not IsToolbarStyle then SZ := CurrentTheme.MenuSeparatorSize
|
|
else SZ := CurrentTheme.TlbrSeparatorSize;
|
|
if SZ < 0 then inherited CalcSize(Canvas, AWidth, AHeight)
|
|
else
|
|
begin
|
|
AWidth := SZ;
|
|
AHeight := SZ;
|
|
end;
|
|
end
|
|
else if not IsToolbarStyle then
|
|
begin
|
|
AHeight := SZ;
|
|
AWidth := 0;
|
|
end
|
|
else
|
|
begin
|
|
AWidth := SZ;
|
|
AHeight := SZ;
|
|
end;
|
|
end;
|
|
|
|
function TTBXSeparatorItemViewer.IsToolbarSize: Boolean;
|
|
begin
|
|
Result := inherited IsToolbarSize;
|
|
Result := Result or ((GetViewType(View) and PVT_TOOLBOX) = PVT_TOOLBOX);
|
|
end;
|
|
|
|
function TTBXSeparatorItemViewer.IsToolbarStyle: Boolean;
|
|
begin
|
|
Result := inherited IsToolbarStyle;
|
|
Result := Result or ((GetViewType(View) and PVT_TOOLBOX) = PVT_TOOLBOX);
|
|
end;
|
|
|
|
procedure TTBXSeparatorItemViewer.Paint(const Canvas: TCanvas;
|
|
const ClientAreaRect: TRect; IsHoverItem, IsPushed, UseDisabledShadow: Boolean);
|
|
const
|
|
CToolbarStyle: array [Boolean] of Integer = (0, IO_TOOLBARSTYLE);
|
|
CDesigning: array [Boolean] of Integer = (0, IO_DESIGNING);
|
|
var
|
|
Item: TTBXSeparatorItem;
|
|
ItemInfo: TTBXItemInfo;
|
|
R: TRect;
|
|
LineSep, HorzLine: Boolean;
|
|
begin
|
|
Item := TTBXSeparatorItem(Self.Item);
|
|
if Item.Size = 0 then Exit;
|
|
|
|
FillChar(ItemInfo, SizeOf(TTBXItemInfo), 0);
|
|
ItemInfo.ViewType := GetViewType(View);
|
|
ItemInfo.ItemOptions := CToolbarStyle[IsToolbarStyle] or
|
|
CDesigning[csDesigning in Item.ComponentState];
|
|
ItemInfo.Enabled := not Item.Blank;
|
|
ItemInfo.Pushed := IsPushed;
|
|
ItemInfo.Selected := False;
|
|
ItemInfo.ImageShown := False;
|
|
ItemInfo.ImageWidth := 0;
|
|
ItemInfo.ImageHeight := 0;
|
|
ItemInfo.IsVertical := View.Orientation = tbvoVertical;
|
|
if not IsToolbarStyle then ItemInfo.PopupMargin := GetPopupMargin(Self);
|
|
|
|
R := ClientAreaRect;
|
|
LineSep := tbisLineSep in State;
|
|
with ItemInfo do
|
|
begin
|
|
HorzLine := (IsVertical xor LineSep) or View.IsPopup;
|
|
if (((ViewType and VT_POPUP) = VT_POPUP) and
|
|
((ViewType and PVT_CHEVRONMENU) = PVT_CHEVRONMENU)) then
|
|
HorzLine := (HorzLine and LineSep);
|
|
end;
|
|
CurrentTheme.PaintSeparator(Canvas, R, ItemInfo, HorzLine, LineSep);
|
|
end;
|
|
|
|
//============================================================================//
|
|
|
|
{ TTBXVisibilityToggleItem }
|
|
|
|
procedure TTBXVisibilityToggleItem.Click;
|
|
begin
|
|
if Assigned(FControl) then FControl.Visible := not FControl.Visible;
|
|
inherited;
|
|
end;
|
|
|
|
procedure TTBXVisibilityToggleItem.InitiateAction;
|
|
begin
|
|
UpdateProps;
|
|
end;
|
|
|
|
procedure TTBXVisibilityToggleItem.Notification(AComponent: TComponent; Operation: TOperation);
|
|
begin
|
|
inherited;
|
|
if (Operation = opRemove) and (AComponent = FControl) then Control := nil;
|
|
end;
|
|
|
|
procedure TTBXVisibilityToggleItem.SetControl(Value: TControl);
|
|
begin
|
|
if FControl <> Value then
|
|
begin
|
|
FControl := Value;
|
|
if Assigned(Value) then
|
|
begin
|
|
Value.FreeNotification(Self);
|
|
if (Length(Caption) = 0) and not (csLoading in ComponentState) then
|
|
Caption := TControlAccess(Value).Caption;
|
|
end;
|
|
UpdateProps;
|
|
end;
|
|
end;
|
|
|
|
procedure TTBXVisibilityToggleItem.UpdateProps;
|
|
begin
|
|
if (ComponentState * [csDesigning, csLoading, csDestroying] = []) then
|
|
Checked := Assigned(FControl) and FControl.Visible;
|
|
end;
|
|
|
|
//============================================================================//
|
|
|
|
{ TTBXPopupWindow }
|
|
|
|
procedure TTBXPopupWindow.CMHintShow(var Message: TCMHintShow);
|
|
begin
|
|
with Message.HintInfo^ do
|
|
begin
|
|
HintStr := '';
|
|
if Assigned(View.Selected) then
|
|
begin
|
|
CursorRect := View.Selected.BoundsRect;
|
|
HintStr := View.Selected.GetHintText;
|
|
View.Selected.Dispatch(Message);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TTBXPopupWindow.CMShowingChanged(var Message: TMessage); {vb+}
|
|
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);
|
|
var
|
|
MenuAni: TMenuAnimation;
|
|
AniDir: TTBAnimationDirection;
|
|
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 TBX_NO_ANIMATION}
|
|
if ((View.ParentView = nil) or not(vsNoAnimation in View.ParentView.State)) and
|
|
Showing and (View.Selected = nil) and not IsWindowVisible(WindowHandle) and
|
|
(TBXMenuAnimation.AnimationMode <> amNone) then
|
|
begin
|
|
{ Start animation only if WM_TB2K_POPUPSHOWING returns zero (or not handled) }
|
|
if SendMessage(WindowHandle, WM_TB2K_POPUPSHOWING, TPS_ANIMSTART, 0) = 0 then
|
|
begin
|
|
MenuAni := TBXMenuAnimation.MenuAnimation;
|
|
AniDir := TTBPopupWindowAccess(Self).AnimationDirection;
|
|
if MenuAni = maUnfold then
|
|
if [tbadDown, tbadUp] * AniDir <> []
|
|
then Include(AniDir, tbadRight)
|
|
else Include(AniDir, tbadDown);
|
|
TBStartAnimation(WindowHandle, MenuAni = maFade, AniDir);
|
|
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]);
|
|
if Showing then SendNotifyMessage(WindowHandle, WM_TB2K_POPUPSHOWING, TPS_NOANIM, 0);
|
|
end;
|
|
|
|
procedure TTBXPopupWindow.CreateParams(var Params: TCreateParams);
|
|
const
|
|
CS_DROPSHADOW = $00020000;
|
|
begin
|
|
inherited CreateParams(Params);
|
|
with Params do
|
|
begin
|
|
WindowClass.Style := WindowClass.Style and not (CS_DROPSHADOW or CS_DBLCLKS);
|
|
if GetShowShadow and (CurrentTheme.GetPopupShadowType = PST_WINDOWSXP) and IsWindowsXP then
|
|
begin
|
|
WindowClass.Style := WindowClass.Style or CS_DROPSHADOW;
|
|
StrPCopy(WinClassName, ClassName + 'S');
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TTBXPopupWindow.CreateShadow;
|
|
var
|
|
PR: TRect;
|
|
ParentViewer: TTBItemViewer;
|
|
VT: Integer;
|
|
ChevronParent: Boolean;
|
|
begin
|
|
if (CurrentTheme.GetPopupShadowType = PST_WINDOWS2K) and not
|
|
((Win32Platform = VER_PLATFORM_WIN32_NT) and (Win32MajorVersion >= 5)) then Exit;
|
|
|
|
PR := Rect(0, 0, 0, 0);
|
|
if CurrentTheme.GetPopupShadowType = PST_OFFICEXP then
|
|
begin
|
|
if (View <> nil) and (View.ParentView <> nil) then
|
|
begin
|
|
ParentViewer := TTBViewAccess(View.ParentView).OpenViewer;
|
|
ChevronParent := Self is TTBXChevronPopupWindow;
|
|
if ((ParentViewer is TTBXItemViewer) or ChevronParent) then
|
|
begin
|
|
VT := GetViewType(ParentViewer.View);
|
|
if ((VT and PVT_POPUPMENU) <> PVT_POPUPMENU) or ChevronParent then
|
|
begin
|
|
PR := ParentViewer.BoundsRect;
|
|
PR.TopLeft := View.ParentView.Window.ClientToScreen(PR.TopLeft);
|
|
PR.BottomRight := View.ParentView.Window.ClientToScreen(PR.BottomRight);
|
|
end;
|
|
end;
|
|
end
|
|
else if not IsRectEmpty(FControlRect) then
|
|
begin
|
|
PR := FControlRect;
|
|
end;
|
|
end;
|
|
FShadows := TShadows.Create(PR, BoundsRect, 4, 61, TBXLoColor);
|
|
FShadows.Show(Handle);
|
|
end;
|
|
|
|
destructor TTBXPopupWindow.Destroy;
|
|
begin
|
|
DestroyShadow;
|
|
inherited;
|
|
end;
|
|
|
|
procedure TTBXPopupWindow.DestroyShadow;
|
|
var
|
|
SaveShadows: TObject;
|
|
begin
|
|
SaveShadows := FShadows;
|
|
FShadows := nil;
|
|
SaveShadows.Free;
|
|
end;
|
|
|
|
function TTBXPopupWindow.GetFillColor: TColor;
|
|
begin
|
|
Result := CurrentTheme.GetViewColor(GetViewType(View));
|
|
View.BackgroundColor := Result;
|
|
end;
|
|
|
|
function TTBXPopupWindow.GetNCSize: TPoint;
|
|
begin
|
|
Result := inherited GetNCSize;
|
|
CurrentTheme.GetViewBorder(GetViewType(View), Result);
|
|
end;
|
|
|
|
function TTBXPopupWindow.GetShowShadow: Boolean;
|
|
begin
|
|
Result := ((GetViewType(View) and PVT_LISTBOX) <> PVT_LISTBOX );
|
|
end;
|
|
|
|
function TTBXPopupWindow.GetViewClass: TTBViewClass;
|
|
begin
|
|
Result := TTBXPopupView;
|
|
end;
|
|
|
|
procedure TTBXPopupWindow.PaintScrollArrows; {vb+}
|
|
|
|
function _GetPopupMargin: Integer;
|
|
begin
|
|
if View.ParentView <> nil then
|
|
Result := GetPopupMargin(TTBViewAccess(View.ParentView).OpenViewer)
|
|
else if View.ViewerCount > 0 then
|
|
Result := GetPopupMargin(View.Viewers[0])
|
|
else Result := -1;
|
|
end;
|
|
|
|
procedure DrawArrows;
|
|
var
|
|
ItemInfo: TTBXItemInfo;
|
|
Index: Integer;
|
|
begin
|
|
FillChar(ItemInfo, SizeOf(ItemInfo), 0);
|
|
ItemInfo.ViewType := PVT_POPUPMENU;
|
|
ItemInfo.Enabled := True;
|
|
ItemInfo.PopupMargin := _GetPopupMargin;
|
|
if ItemInfo.PopupMargin > 0 then
|
|
begin
|
|
if TTBViewAccess(View).ShowUpArrow then
|
|
for Index := 0 to View.ViewerCount- 1 do
|
|
if View.Viewers[Index].Show then
|
|
begin
|
|
CurrentTheme.PaintMenuItemFrame(Canvas, Rect(0, 0, ClientWidth,
|
|
View.Viewers[Index].BoundsRect.Top), ItemInfo);
|
|
Break;
|
|
end;
|
|
if TTBViewAccess(View).ShowDownArrow then
|
|
for Index := View.ViewerCount- 1 downto 0 do
|
|
if View.Viewers[Index].Show then
|
|
begin
|
|
CurrentTheme.PaintMenuItemFrame(Canvas, Rect(0,
|
|
View.Viewers[Index].BoundsRect.Bottom, ClientWidth,
|
|
ClientHeight), ItemInfo);
|
|
Break;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
begin
|
|
with TTBViewAccess(View) do
|
|
if ShowUpArrow or ShowDownArrow then
|
|
DrawArrows;
|
|
inherited;
|
|
end;
|
|
|
|
procedure TTBXPopupWindow.TBMGetViewType(var Message: TMessage);
|
|
var
|
|
PI: TTBCustomItem;
|
|
begin
|
|
Message.Result := PVT_POPUPMENU;
|
|
if View <> nil then
|
|
if Self is TTBXChevronPopupWindow then
|
|
Message.Result := PVT_CHEVRONMENU
|
|
else
|
|
begin
|
|
PI := View.ParentItem;
|
|
if PI <> nil then
|
|
begin
|
|
if (PI.Count = 1) and (PI.Items[0] is TTBXCustomList) then
|
|
Message.Result := PVT_LISTBOX
|
|
else if PI is TTBXEditItem then
|
|
begin
|
|
Message.Result := PVT_TOOLBOX;
|
|
end
|
|
else if (PI is TTBXCustomItem) and (TTBXCustomItem(PI).ToolBoxPopup) then
|
|
Message.Result := PVT_TOOLBOX
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TTBXPopupWindow.WMEraseBkgnd(var Message: TWmEraseBkgnd);
|
|
var
|
|
Canvas: TCanvas;
|
|
R: TRect;
|
|
begin
|
|
TBEndAnimation(WindowHandle);
|
|
Canvas := TCanvas.Create;
|
|
Canvas.Handle := Message.DC;
|
|
R := ClientRect;
|
|
CurrentTheme.PaintBackgnd(Canvas, R, R, R, GetFillColor, False, GetViewType(View));
|
|
Canvas.Handle := 0;
|
|
Canvas.Free;
|
|
Message.Result := 1;
|
|
end;
|
|
|
|
procedure TTBXPopupWindow.WMNCCalcSize(var Message: TWMNCCalcSize);
|
|
var
|
|
Sz: TPoint;
|
|
begin
|
|
CurrentTheme.GetViewBorder(GetViewType(View), Sz);
|
|
with Message.CalcSize_Params^.rgrc[0], Sz do
|
|
begin
|
|
Inc(Left, X);
|
|
Inc(Top, Y);
|
|
Dec(Right, X);
|
|
Dec(Bottom, Y);
|
|
end;
|
|
Message.Result := 1;
|
|
end;
|
|
|
|
procedure TBXPopupNCPaintProc(Wnd: HWND; DC: HDC; AppData: Longint);
|
|
var
|
|
R, R2: TRect;
|
|
Canvas: TCanvas;
|
|
View: TTBPopupView;
|
|
PopupInfo: TTBXPopupInfo;
|
|
ParentViewer: TTBItemViewer;
|
|
begin
|
|
Assert(DC <> 0, 'TBXPopupNCPaintProc');
|
|
Canvas := TCanvas.Create;
|
|
try
|
|
Canvas.Handle := DC;
|
|
FillChar(PopupInfo, SizeOf(PopupInfo), 0);
|
|
View := TTBPopupView(AppData);
|
|
PopupInfo.WindowHandle := View.Window.Handle;
|
|
PopupInfo.ViewType := GetViewType(View);
|
|
if View.ParentView <> nil then
|
|
begin
|
|
ParentViewer := TTBViewAccess(View.ParentView).OpenViewer;
|
|
if ((ParentViewer is TTBXItemViewer) or (View.Window is TTBXChevronPopupWindow))
|
|
and TTBItemViewerAccess(ParentViewer).IsToolbarStyle then
|
|
begin
|
|
R := ParentViewer.BoundsRect;
|
|
R.TopLeft := View.ParentView.Window.ClientToScreen(R.TopLeft);
|
|
R.BottomRight := View.ParentView.Window.ClientToScreen(R.BottomRight);
|
|
GetWindowRect(Wnd, R2);
|
|
OffsetRect(R, -R2.Left, -R2.Top);
|
|
PopupInfo.ParentRect := R;
|
|
end;
|
|
end
|
|
else if View.ParentItem is TTBXRootItem then
|
|
begin
|
|
R := TTBXRootItem(View.ParentItem).FPopupControlRect;
|
|
if not IsRectEmpty(R) then
|
|
begin
|
|
GetWindowRect(Wnd, R2);
|
|
OffsetRect(R, -R2.Left, -R2.Top);
|
|
PopupInfo.ParentRect := R;
|
|
end;
|
|
end;
|
|
GetWindowRect(Wnd, R);
|
|
OffsetRect(R, -R.Left, -R.Top);
|
|
CurrentTheme.GetViewBorder(PopupInfo.ViewType, PopupInfo.BorderSize);
|
|
R2 := R;
|
|
with PopupInfo.BorderSize do InflateRect(R2, -X, -Y);
|
|
with R2 do ExcludeClipRect(Canvas.Handle, Left, Top, Right, Bottom);
|
|
CurrentTheme.PaintPopupNCArea(Canvas, R, PopupInfo);
|
|
finally
|
|
Canvas.Handle := 0;
|
|
Canvas.Free;
|
|
end;
|
|
end;
|
|
|
|
procedure TTBXPopupWindow.WMNCPaint(var Message: TMessage);
|
|
var
|
|
DC: HDC;
|
|
begin
|
|
DC := GetWindowDC(Handle);
|
|
try
|
|
Assert(DC <> 0, 'TTBXPopupWindow.WMNCPaint');
|
|
SelectNCUpdateRgn(Handle, DC, HRGN(Message.WParam));
|
|
TBXPopupNCPaintProc(Handle, DC, LongInt(Self.View));
|
|
finally
|
|
ReleaseDC(Handle, DC);
|
|
end;
|
|
end;
|
|
|
|
procedure TTBXPopupWindow.WMPrint(var Message: TMessage);
|
|
begin
|
|
HandleWMPrint(Handle, Message, TBXPopupNCPaintProc, LongInt(Self.View));
|
|
end;
|
|
|
|
procedure TTBXPopupWindow.WMTB2kPopupShowing(var Message: TMessage);
|
|
begin
|
|
if Message.WParam in [TPS_ANIMFINISHED, TPS_NOANIM] then
|
|
begin
|
|
if not (csDestroying in ComponentState) and GetShowShadow and
|
|
(CurrentTheme.GetPopupShadowType in [PST_OFFICEXP, PST_WINDOWS2K]) then CreateShadow;
|
|
end;
|
|
end;
|
|
|
|
procedure TTBXPopupWindow.WMWindowPosChanged(var Message: TWMWindowPosChanged);
|
|
begin
|
|
inherited;
|
|
with Message.WindowPos^ do
|
|
if ((flags and SWP_SHOWWINDOW) = 0) and ((flags and SWP_HIDEWINDOW) = 0) then
|
|
begin
|
|
if FShadows <> nil then
|
|
begin
|
|
DestroyShadow;
|
|
CreateShadow;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
|
|
//============================================================================//
|
|
|
|
{ TTBXToolbarView }
|
|
|
|
procedure TTBXToolbarView.GetMargins(AOrientation: TTBViewOrientation; var Margins: TRect);
|
|
var
|
|
VT: Integer;
|
|
M: TTBXMargins;
|
|
begin
|
|
VT := GetWinViewType(TTBXToolbar(Owner));
|
|
if (VT and VT_TOOLBAR) = VT_TOOLBAR then
|
|
begin
|
|
if AOrientation = tbvoFloating then VT := VT or TVT_FLOATING
|
|
else VT := VT and not TVT_FLOATING
|
|
end
|
|
else if (VT and VT_DOCKPANEL) = VT_DOCKPANEL then
|
|
begin
|
|
if AOrientation = tbvoFloating then VT := VT or DPVT_FLOATING
|
|
else VT := VT and not DPVT_FLOATING
|
|
end;
|
|
CurrentTheme.GetViewMargins(VT, M);
|
|
Margins.Left := M.LeftWidth;
|
|
Margins.Top := M.TopHeight;
|
|
Margins.Right := M.RightWidth;
|
|
Margins.Bottom := M.BottomHeight;
|
|
end;
|
|
|
|
|
|
//============================================================================//
|
|
|
|
{ TTBXToolbar }
|
|
|
|
procedure TTBXToolbar.CMColorChanged(var Message: TMessage);
|
|
begin
|
|
UpdateEffectiveColor;
|
|
if Docked and HandleAllocated then
|
|
begin
|
|
RedrawWindow(Handle, nil, 0, RDW_FRAME or RDW_INVALIDATE or
|
|
RDW_ERASE or RDW_UPDATENOW or RDW_ALLCHILDREN);
|
|
end;
|
|
UpdateChildColors;
|
|
Invalidate;
|
|
end;
|
|
|
|
procedure TTBXToolbar.CMControlChange(var Message: TCMControlChange);
|
|
begin
|
|
inherited;
|
|
if Message.Inserting and (Color = clNone) then
|
|
Message.Control.Perform(CM_PARENTCOLORCHANGED, 1, EffectiveColor);
|
|
end;
|
|
|
|
procedure TTBXToolbar.CMParentColorChanged(var Message: TMessage);
|
|
begin
|
|
if Embedded and (Color = clNone) then
|
|
begin
|
|
UpdateEffectiveColor;
|
|
if (Message.WParam = 0) then
|
|
begin
|
|
Message.WParam := 1;
|
|
Message.LParam := EffectiveColor;
|
|
end;
|
|
end;
|
|
inherited;
|
|
Invalidate;
|
|
end;
|
|
|
|
constructor TTBXToolbar.Create(AOwner: TComponent);
|
|
begin
|
|
inherited;
|
|
AddThemeNotification(Self);
|
|
FEffectiveColor := Color;
|
|
Color := clNone;
|
|
ControlStyle := ControlStyle - [csOpaque];
|
|
DblClickUndock := False;
|
|
end;
|
|
|
|
destructor TTBXToolbar.Destroy;
|
|
begin
|
|
RemoveThemeNotification(Self);
|
|
inherited;
|
|
end;
|
|
|
|
procedure TTBXToolbar.DrawNCArea(const DrawToDC: Boolean; const ADC: HDC; const Clip: HRGN);
|
|
var
|
|
DC: HDC;
|
|
R, CR, R2: TRect;
|
|
ACanvas: TCanvas;
|
|
ToolbarInfo: TTBXToolbarInfo;
|
|
UsingBackground: Boolean;
|
|
begin
|
|
if not Docked or not HandleAllocated then Exit;
|
|
|
|
if not DrawToDC then DC := GetWindowDC(Handle)
|
|
else DC := ADC;
|
|
|
|
UsingBackground := TDockAccess(CurrentDock).UsingBackground;
|
|
|
|
try
|
|
GetToolbarInfo(ToolbarInfo);
|
|
GetWindowRect(Handle, R);
|
|
OffsetRect(R, -R.Left, -R.Top);
|
|
if not DrawToDC then
|
|
begin
|
|
SelectNCUpdateRgn(Handle, DC, Clip);
|
|
CR := R;
|
|
with ToolbarInfo.BorderSize, CR do
|
|
begin
|
|
InflateRect(CR, -X, -Y);
|
|
if ToolbarInfo.IsVertical then Inc(Top, GetTBXDragHandleSize(ToolbarInfo))
|
|
else Inc(Left, GetTBXDragHandleSize(ToolbarInfo));
|
|
ExcludeClipRect(DC, Left, Top, Right, Bottom);
|
|
end;
|
|
end;
|
|
|
|
ACanvas := TCanvas.Create;
|
|
try
|
|
ACanvas.Handle := DC;
|
|
if CurrentTheme.SolidToolbarNCArea then
|
|
begin
|
|
ACanvas.Brush.Color := EffectiveColor;
|
|
ACanvas.Brush.Style := bsSolid;
|
|
end
|
|
else if UsingBackground then
|
|
begin
|
|
ACanvas.Brush.Color := EffectiveColor;
|
|
R2 := CurrentDock.ClientRect;
|
|
OffsetRect(R2, -Left, -Top);
|
|
TDockAccess(CurrentDock).DrawBackground(DC, R2);
|
|
if (Color = clNone) and CurrentDock.BackgroundOnToolbars then
|
|
ACanvas.Brush.Style := bsClear;
|
|
end
|
|
else
|
|
begin
|
|
ACanvas.Brush.Color := GetEffectiveColor(CurrentDock);
|
|
ACanvas.FillRect(R);
|
|
ACanvas.Brush.Color := EffectiveColor;
|
|
ACanvas.Brush.Style := bsSolid;
|
|
end;
|
|
|
|
CurrentTheme.PaintToolbarNCArea(ACanvas, R, ToolbarInfo);
|
|
finally
|
|
ACanvas.Handle := 0;
|
|
ACanvas.Free;
|
|
end;
|
|
finally
|
|
if not DrawToDC then ReleaseDC(Handle, DC);
|
|
end;
|
|
end;
|
|
|
|
function TTBXToolbar.Embedded: Boolean;
|
|
begin
|
|
Result := not (Floating or Docked);
|
|
end;
|
|
|
|
function TTBXToolbar.GetChevronItemClass: TTBChevronItemClass;
|
|
begin
|
|
Result := TTBXChevronItem;
|
|
end;
|
|
|
|
function TTBXToolbar.GetFloatingBorderSize: TPoint;
|
|
begin
|
|
CurrentTheme.GetViewBorder(GetViewType(View) or TVT_FLOATING, Result);
|
|
end;
|
|
|
|
function TTBXToolbar.GetFloatingWindowParentClass: TTBFloatingWindowParentClass;
|
|
begin
|
|
Result := TTBXFloatingWindowParent;
|
|
end;
|
|
|
|
procedure TTBXToolbar.GetToolbarInfo(out ToolbarInfo: TTBXToolbarInfo);
|
|
begin
|
|
FillChar(ToolbarInfo, SizeOf(ToolbarInfo), 0);
|
|
ToolbarInfo.WindowHandle := Handle;
|
|
ToolbarInfo.ViewType := GetWinViewType(Self);
|
|
if CurrentDock <> nil then
|
|
ToolbarInfo.IsVertical := CurrentDock.Position in [dpLeft,dpRight];
|
|
ToolbarInfo.AllowDrag := CurrentDock.AllowDrag;
|
|
ToolbarInfo.DragHandleStyle := Ord(DragHandleStyle);
|
|
ToolbarInfo.ClientWidth := ClientWidth;
|
|
ToolbarInfo.ClientHeight := ClientHeight;
|
|
if ToolbarInfo.AllowDrag and CloseButtonWhenDocked then
|
|
begin
|
|
ToolbarInfo.CloseButtonState := CDBS_VISIBLE;
|
|
if CloseButtonDown then ToolbarInfo.CloseButtonState := ToolbarInfo.CloseButtonState or CDBS_PRESSED
|
|
else if CloseButtonHover then ToolbarInfo.CloseButtonState := ToolbarInfo.CloseButtonState or CDBS_HOT;
|
|
end;
|
|
ToolbarInfo.BorderStyle := BorderStyle;
|
|
CurrentTheme.GetViewBorder(ToolbarInfo.ViewType, ToolbarInfo.BorderSize);
|
|
ToolbarInfo.EffectiveColor := EffectiveColor;
|
|
end;
|
|
|
|
function TTBXToolbar.GetViewClass: TTBToolbarViewClass;
|
|
begin
|
|
Result := TTBXToolbarView;
|
|
end;
|
|
|
|
procedure TTBXToolbar.SetItemTransparency(const Value: TTBXItemTransparency);
|
|
begin
|
|
FItemTransparency := Value;
|
|
Invalidate;
|
|
end;
|
|
|
|
procedure TTBXToolbar.Loaded; {vb+}
|
|
begin
|
|
inherited;
|
|
UpdateEffectiveColor;
|
|
end;
|
|
|
|
procedure TTBXToolbar.SetParent(AParent: TWinControl);
|
|
begin
|
|
inherited;
|
|
if AParent is TTBXFloatingWindowParent then
|
|
TTBXFloatingWindowParent(AParent).SnapDistance := SnapDistance;
|
|
end;
|
|
|
|
procedure TTBXToolbar.SetSnapDistance(Value: Integer);
|
|
begin
|
|
if Value < 0 then Value := 0;
|
|
FSnapDistance := Value;
|
|
if (Parent <> nil) and (Parent is TTBXFloatingWindowParent) then
|
|
TTBXFloatingWindowParent(Parent).SnapDistance := Value;
|
|
end;
|
|
|
|
procedure TTBXToolbar.TBMGetEffectiveColor(var Message: TMessage);
|
|
begin
|
|
Message.WParam := EffectiveColor;
|
|
Message.Result := 1;
|
|
end;
|
|
|
|
procedure TTBXToolbar.TBMGetViewType(var Message: TMessage);
|
|
begin
|
|
if MenuBar then Message.Result := TVT_MENUBAR
|
|
else Message.Result := TVT_NORMALTOOLBAR;
|
|
if Floating then Message.Result := Message.Result or TVT_FLOATING;
|
|
if Resizable then Message.Result := Message.Result or TVT_RESIZABLE;
|
|
case ItemTransparency of
|
|
itAuto:
|
|
if not (Floating or Docked) then Message.Result := Message.Result or TVT_EMBEDDED;
|
|
itDisable:
|
|
Message.Result := Message.Result or TVT_EMBEDDED;
|
|
end;
|
|
end;
|
|
|
|
procedure TTBXToolbar.TBMThemeChange(var Message: TMessage);
|
|
begin
|
|
case Message.WParam of
|
|
TSC_BEFOREVIEWCHANGE: BeginUpdate;
|
|
TSC_AFTERVIEWCHANGE:
|
|
begin
|
|
EndUpdate;
|
|
UpdateEffectiveColor;
|
|
if Floating then UpdateNCArea(TTBXFloatingWindowParent(Parent), GetWinViewType(Self))
|
|
else UpdateNCArea(Self, GetWinViewType(Self));
|
|
Invalidate;
|
|
Arrange;
|
|
UpdateChildColors;
|
|
end;
|
|
TSC_APPACTIVATE, TSC_APPDEACTIVATE:
|
|
if MenuBar then Invalidate;
|
|
end;
|
|
end;
|
|
|
|
procedure TTBXToolbar.UpdateChildColors;
|
|
var
|
|
M: TMessage;
|
|
begin
|
|
M.Msg := CM_PARENTCOLORCHANGED;
|
|
M.WParam := 1;
|
|
M.LParam := EffectiveColor;
|
|
M.Result := 0;
|
|
Broadcast(M);
|
|
end;
|
|
|
|
procedure TTBXToolbar.UpdateEffectiveColor;
|
|
begin
|
|
if Color = clNone then
|
|
begin
|
|
if Embedded and (Parent <> nil) then
|
|
FEffectiveColor := GetEffectiveColor(Parent)
|
|
else
|
|
FEffectiveColor := CurrentTheme.GetViewColor(GetViewType(View));
|
|
end
|
|
else FEffectiveColor := Color;
|
|
end;
|
|
|
|
procedure TTBXToolbar.WMEraseBkgnd(var Message: TWmEraseBkgnd);
|
|
var
|
|
Canvas: TCanvas;
|
|
R, CR: TRect;
|
|
Transparent: Boolean;
|
|
begin
|
|
Transparent := False;
|
|
CR := ClientRect;
|
|
if Color = clNone then
|
|
if Docked and (TDockAccess(CurrentDock).UsingBackground) and CurrentDock.BackgroundOnToolbars
|
|
and not CurrentTheme.SolidToolbarClientArea then
|
|
begin
|
|
R := CurrentDock.ClientRect;
|
|
R.TopLeft := ScreenToClient(CurrentDock.ClientToScreen(R.TopLeft));
|
|
R.BottomRight := ScreenToClient(CurrentDock.ClientToScreen(R.BottomRight));
|
|
TDockAccess(CurrentDock).DrawBackground(Message.DC, R);
|
|
Message.Result := 1;
|
|
Transparent := True;
|
|
end
|
|
else if Embedded then
|
|
begin
|
|
Transparent := True;
|
|
DrawParentBackground(Self, Message.DC, CR);
|
|
end;
|
|
|
|
Canvas := TCanvas.Create;
|
|
Canvas.Handle := Message.DC;
|
|
try
|
|
if Docked then
|
|
begin
|
|
R := CurrentDock.ClientRect;
|
|
R.TopLeft := ScreenToClient(CurrentDock.ClientToScreen(R.TopLeft));
|
|
R.BottomRight := ScreenToClient(CurrentDock.ClientToScreen(R.BottomRight));
|
|
end
|
|
else R := Rect(0, 0, 0, 0);
|
|
CurrentTheme.PaintBackgnd(Canvas, R, CR, CR, EffectiveColor, Transparent, GetWinViewType(Self));
|
|
Message.Result := 1;
|
|
finally
|
|
Canvas.Handle := 0;
|
|
Canvas.Free;
|
|
end;
|
|
end;
|
|
|
|
procedure TTBXToolbar.WMSize(var Message: TWMSize);
|
|
var
|
|
I: Integer;
|
|
V: TTBItemViewer;
|
|
R: TRect;
|
|
begin
|
|
inherited;
|
|
if Docked and TDockAccess(CurrentDock).UsingBackground and
|
|
TDockAccess(CurrentDock).BackgroundOnToolbars and
|
|
((CurrentDock is TTBXDock) and not TTBXDock(CurrentDock).FResizing) then
|
|
begin
|
|
for I := 0 to View.ViewerCount - 1 do
|
|
begin
|
|
V := View.Viewers[I];
|
|
if V.Show and not IsRectEmpty(V.BoundsRect) and not (V.Item is TTBControlItem)
|
|
then View.Invalidate(V);
|
|
end;
|
|
Self.Update;
|
|
InvalidateRect(Handle, nil, True);
|
|
for I := 0 to View.ViewerCount - 1 do
|
|
begin
|
|
V := View.Viewers[I];
|
|
if V.Show and not IsRectEmpty(V.BoundsRect) and not (V.Item is TTBControlItem)
|
|
then
|
|
begin
|
|
R := V.BoundsRect;
|
|
ValidateRect(Handle, @R);
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
|
|
//============================================================================//
|
|
|
|
{ TTBXChevronItem }
|
|
|
|
function TTBXChevronItem.GetItemViewerClass(AView: TTBView): TTBItemViewerClass;
|
|
begin
|
|
Result := TTBXChevronItemViewer;
|
|
end;
|
|
|
|
procedure TTBXChevronItem.GetPopupPosition(ParentView: TTBView;
|
|
PopupWindow: TTBPopupWindow; var PopupPositionRec: TTBPopupPositionRec);
|
|
begin
|
|
if CurrentTheme.OfficeXPPopupAlignment then with PopupPositionRec do
|
|
begin
|
|
GetOfficeXPPopupPosition1(PopupPositionRec);
|
|
inherited GetPopupPosition(ParentView, PopupWindow, PopupPositionRec);
|
|
GetOfficeXPPopupPosition2(PopupPositionRec);
|
|
end
|
|
else inherited;
|
|
end;
|
|
|
|
function TTBXChevronItem.GetPopupWindowClass: TTBPopupWindowClass;
|
|
begin
|
|
Result := TTBXChevronPopupWindow;
|
|
end;
|
|
|
|
|
|
//============================================================================//
|
|
|
|
{ TTBXChevronItemViewer }
|
|
|
|
procedure TTBXChevronItemViewer.Paint(const Canvas: TCanvas;
|
|
const ClientAreaRect: TRect; IsHoverItem, IsPushed, UseDisabledShadow: Boolean);
|
|
const
|
|
CDesigning: array [Boolean] of Integer = (0, IO_DESIGNING);
|
|
var
|
|
ItemInfo: TTBXItemInfo;
|
|
begin
|
|
FillChar(ItemInfo, SizeOf(TTBXItemInfo), 0);
|
|
ItemInfo.ViewType := GetViewType(View);
|
|
ItemInfo.ItemOptions := IO_TOOLBARSTYLE or CDesigning[csDesigning in Item.ComponentState];
|
|
ItemInfo.Enabled := Item.Enabled or View.Customizing;
|
|
ItemInfo.Pushed := IsPushed;
|
|
ItemInfo.Selected := False;
|
|
ItemInfo.ImageShown := False;
|
|
ItemInfo.ImageWidth := 0;
|
|
ItemInfo.ImageHeight := 0;
|
|
ItemInfo.IsPopupParent := IsPushed;
|
|
if IsHoverItem then
|
|
begin
|
|
if not ItemInfo.Enabled and not TTBViewAccess(View).MouseOverSelected then ItemInfo.HoverKind := hkKeyboardHover
|
|
else if ItemInfo.Enabled then ItemInfo.HoverKind := hkMouseHover;
|
|
end
|
|
else ItemInfo.HoverKind := hkNone;
|
|
ItemInfo.IsVertical := View.Orientation = tbvoVertical;
|
|
CurrentTheme.PaintChevron(Canvas, ClientAreaRect, ItemInfo);
|
|
end;
|
|
|
|
|
|
//============================================================================//
|
|
|
|
{ TTBXRootItem }
|
|
|
|
function TTBXRootItem.CreatePopupEx(SelectFirstItem: Boolean;
|
|
const AControlRect: TRect; Alignment: TTBPopupAlignment): TTBPopupWindow;
|
|
var
|
|
SavePopupRect: TRect;
|
|
Pt: TPoint;
|
|
begin
|
|
SavePopupRect := FPopupControlRect;
|
|
try
|
|
FPopupControlRect := AControlRect;
|
|
Pt.X := AControlRect.Left;
|
|
Pt.Y := AControlRect.Bottom;
|
|
Result := inherited CreatePopup(nil, nil, False, SelectFirstItem, False, Pt, Alignment);
|
|
if Result is TTBXPopupWindow then TTBXPopupWindow(Result).FControlRect := FPopupControlRect;
|
|
finally
|
|
FPopupControlRect := SavePopupRect;
|
|
end;
|
|
end;
|
|
|
|
procedure TTBXRootItem.GetPopupPosition(ParentView: TTBView;
|
|
PopupWindow: TTBPopupWindow; var PopupPositionRec: TTBPopupPositionRec);
|
|
var
|
|
Y2: Integer;
|
|
VT: Integer;
|
|
begin
|
|
if IsRectEmpty(FPopupControlRect) then inherited
|
|
else with PopupPositionRec do
|
|
begin
|
|
ParentItemRect := FPopupControlRect;
|
|
if Y + H > MonitorRect.Bottom then
|
|
begin
|
|
Y2 := FPopupControlRect.Top - H;
|
|
if Y2 >= MonitorRect.Top then Y := Y2;
|
|
end;
|
|
if Y < MonitorRect.Top then Y := MonitorRect.Top
|
|
else if Y + H > MonitorRect.Bottom then Y := MonitorRect.Bottom - H;
|
|
|
|
if Alignment = tbpaRight then X := FPopupControlRect.Right - W;
|
|
|
|
if X + W > MonitorRect.Right then X := MonitorRect.Right - W;
|
|
if X < MonitorRect.Left then X := MonitorRect.Left;
|
|
end;
|
|
if CurrentTheme.OfficeXPPopupAlignment then with PopupPositionRec do
|
|
begin
|
|
GetOfficeXPPopupPosition1(PopupPositionRec);
|
|
inherited GetPopupPosition(ParentView, PopupWindow, PopupPositionRec);
|
|
GetOfficeXPPopupPosition2(PopupPositionRec);
|
|
VT := GetWinViewType(PopupWindow);
|
|
PopupPositionRec.PlaySound := not (VT and PVT_LISTBOX = PVT_LISTBOX);
|
|
end
|
|
else inherited;
|
|
end;
|
|
|
|
function TTBXRootItem.GetPopupWindowClass: TTBPopupWindowClass;
|
|
begin
|
|
Result := TTBXPopupWindow;
|
|
end;
|
|
|
|
function TTBXRootItem.OpenPopupEx(const SelectFirstItem, TrackRightButton: Boolean;
|
|
const ControlRect: TRect; const Alignment: TTBPopupAlignment;
|
|
const ReturnClickedItemOnly: Boolean): TTBCustomItem;
|
|
var
|
|
ModalHandler: TTBModalHandler;
|
|
Popup: TTBPopupWindow;
|
|
DoneActionData: TTBDoneActionData;
|
|
State: TTBViewState;
|
|
begin
|
|
ModalHandler := TTBModalHandler.Create(0);
|
|
try
|
|
Popup := CreatePopupEx(SelectFirstItem, ControlRect, Alignment);
|
|
try
|
|
State := Popup.View.State;
|
|
Include(State, vsIgnoreFirstMouseUp);
|
|
TTBViewAccess(Popup.View).SetState(State);
|
|
ModalHandler.Loop(Popup.View, False, False, False, TrackRightButton);
|
|
DoneActionData := TTBViewAccess(Popup.View).DoneActionData;
|
|
finally
|
|
{ Remove vsModal state from the root view before any TTBView.Destroy
|
|
methods get called, so that NotifyFocusEvent becomes a no-op }
|
|
State := Popup.View.State;
|
|
Exclude(State, vsModal);
|
|
TTBViewAccess(Popup.View).SetState(State);
|
|
Popup.Free;
|
|
end;
|
|
finally
|
|
ModalHandler.Free;
|
|
end;
|
|
Result := ProcessDoneAction(DoneActionData, ReturnClickedItemOnly);
|
|
end;
|
|
|
|
function TTBXRootItem.PopupEx(const ControlRect: TRect;
|
|
TrackRightButton: Boolean; Alignment: TTBPopupAlignment = tbpaLeft;
|
|
ReturnClickedItemOnly: Boolean = False): TTBCustomItem;
|
|
begin
|
|
Result := OpenPopupEx(False, TrackRightButton, ControlRect,
|
|
Alignment, ReturnClickedItemOnly);
|
|
end;
|
|
|
|
|
|
//============================================================================//
|
|
|
|
{ TTBXPopupMenu }
|
|
|
|
function TTBXPopupMenu.GetRootItemClass: TTBRootItemClass;
|
|
begin
|
|
Result := TTBXRootItem;
|
|
end;
|
|
|
|
function TTBXPopupMenu.PopupEx(const ControlRect: TRect;
|
|
ReturnClickedItemOnly: Boolean = False): TTBCustomItem;
|
|
begin
|
|
{$IFDEF JR_D5}
|
|
{$IFDEF JR_D9}
|
|
SetPopupPoint(Point(ControlRect.Left, ControlRect.Bottom));
|
|
{$ELSE}
|
|
PPoint(@PopupPoint)^ := Point(ControlRect.Left, ControlRect.Bottom);
|
|
{$ENDIF}
|
|
{$ENDIF}
|
|
Result := TTBXRootItem(Items).PopupEx(ControlRect, TrackButton = tbRightButton,
|
|
TTBPopupAlignment(Alignment), ReturnClickedItemOnly);
|
|
end;
|
|
|
|
procedure TTBXPopupMenu.TBMGetViewType(var Message: TMessage);
|
|
begin
|
|
Message.Result := PVT_POPUPMENU;
|
|
end;
|
|
|
|
|
|
//============================================================================//
|
|
|
|
{ TTBXFloatingWindowParent }
|
|
|
|
procedure TTBXFloatingWindowParent.CancelNCHover;
|
|
begin
|
|
if FCloseButtonHover then
|
|
begin
|
|
FCloseButtonHover := False;
|
|
if HandleAllocated and IsWindowVisible(Handle) then
|
|
DrawNCArea(False, 0, 0, [twrdCloseButton]);
|
|
end;
|
|
end;
|
|
|
|
procedure TTBXFloatingWindowParent.CMMouseLeave(var Message: TMessage);
|
|
begin
|
|
inherited;
|
|
CancelNCHover;
|
|
end;
|
|
|
|
procedure TTBXFloatingWindowParent.DrawNCArea(const DrawToDC: Boolean;
|
|
const ADC: HDC; const Clip: HRGN; RedrawWhat: TTBToolWindowNCRedrawWhat);
|
|
const
|
|
CDown: array [Boolean] of Integer = (0, CDBS_PRESSED);
|
|
CHover: array [Boolean] of Integer = (0, CDBS_HOT);
|
|
CBord: array [Boolean] of Integer = (0, WRP_BORDER);
|
|
CCapt: array [Boolean] of Integer = (0, WRP_CAPTION);
|
|
CBtn: array [Boolean] of Integer = (0, WRP_CLOSEBTN);
|
|
var
|
|
DC: HDC;
|
|
R: TRect;
|
|
Canvas: TCanvas;
|
|
WindowInfo: TTBXWindowInfo;
|
|
DockWindow: TTBCustomDockableWindowAccess;
|
|
begin
|
|
if not HandleAllocated then Exit;
|
|
if not DrawToDC then DC := GetWindowDC(Handle)
|
|
else DC := ADC;
|
|
try
|
|
if not DrawToDC then SelectNCUpdateRgn(Handle, DC, Clip);
|
|
GetWindowRect(Handle, R);
|
|
OffsetRect(R, -R.Left, -R.Top);
|
|
with R do IntersectClipRect(DC, Left, Top, Right, Bottom);
|
|
Canvas := TCanvas.Create;
|
|
try
|
|
Canvas.Handle := DC;
|
|
GetWindowRect(Handle, R);
|
|
OffsetRect(R, -R.Left, -R.Top);
|
|
DockWindow := TTBCustomDockableWindowAccess(DockableWindow);
|
|
|
|
FillChar(WindowInfo, SizeOf(WindowInfo), 0);
|
|
WindowInfo.ParentHandle := Handle;
|
|
WindowInfo.WindowHandle := DockWindow.Handle;
|
|
WindowInfo.ViewType := GetWinViewType(DockWindow);
|
|
WindowInfo.ClientWidth := ClientWidth;
|
|
WindowInfo.ClientHeight := ClientHeight;
|
|
WindowInfo.ShowCaption := DockWindow.ShowCaption;
|
|
WindowInfo.FloatingBorderSize := DockWindow.GetFloatingBorderSize;
|
|
if DockWindow.CloseButton and DockWindow.ShowCaption then
|
|
begin
|
|
WindowInfo.CloseButtonState := CDBS_VISIBLE;
|
|
if CloseButtonDown then WindowInfo.CloseButtonState := WindowInfo.CloseButtonState or CDBS_PRESSED
|
|
else if CloseButtonHover then WindowInfo.CloseButtonState := WindowInfo.CloseButtonState or CDBS_HOT;
|
|
end;
|
|
WindowInfo.RedrawPart :=
|
|
CBord[twrdBorder in RedrawWhat] or
|
|
CCapt[twrdCaption in RedrawWhat] or
|
|
CBtn[twrdCloseButton in RedrawWhat];
|
|
WindowInfo.Caption := PChar(Caption);
|
|
WindowInfo.EffectiveColor := GetEffectiveColor(DockWindow);
|
|
WindowInfo.Active := not DockWindow.InactiveCaption;
|
|
Canvas.Brush.Color := WindowInfo.EffectiveColor;
|
|
CurrentTheme.PaintFloatingBorder(Canvas, R, WindowInfo);
|
|
finally
|
|
Canvas.Handle := 0;
|
|
Canvas.Free;
|
|
end;
|
|
finally
|
|
if not DrawToDC then ReleaseDC(Handle, DC);
|
|
end;
|
|
end;
|
|
|
|
procedure TTBXFloatingWindowParent.WMEraseBkgnd(var Message: TMessage);
|
|
begin
|
|
Message.Result := 1;
|
|
end;
|
|
|
|
procedure TTBXFloatingWindowParent.WMNCMouseLeave(var Message: TMessage);
|
|
begin
|
|
if not MouseCapture then CancelNCHover;
|
|
inherited;
|
|
end;
|
|
|
|
procedure TTBXFloatingWindowParent.WMNCMouseMove(var Message: TWMNCMouseMove);
|
|
var
|
|
InArea: Boolean;
|
|
begin
|
|
inherited;
|
|
{ Note: TME_NONCLIENT was introduced in Windows 98 and 2000 }
|
|
if (Win32MajorVersion >= 5) or
|
|
(Win32MajorVersion = 4) and (Win32MinorVersion >= 10) then
|
|
CallTrackMouseEvent (Handle, TME_LEAVE or $10 {TME_NONCLIENT});
|
|
InArea := Message.HitTest = 2001; {HT_TB2k_Close}
|
|
if FCloseButtonHover <> InArea then
|
|
begin
|
|
FCloseButtonHover := InArea;
|
|
if HandleAllocated and IsWindowVisible(Handle) then
|
|
DrawNCArea(False, 0, 0, [twrdCloseButton]);
|
|
end;
|
|
end;
|
|
|
|
procedure TTBXFloatingWindowParent.WMWindowPosChanging(var Message: TWMWindowPosChanging);
|
|
var
|
|
R: TRect;
|
|
MonInfo: TMonitorInfo;
|
|
begin
|
|
if SnapDistance > 0 then with Message.WindowPos^ do
|
|
begin
|
|
if (cx = Width) and (cy = Height) then
|
|
begin
|
|
MonInfo.cbSize := SizeOf(MonInfo);
|
|
GetMonitorInfo(Monitor.Handle, @MonInfo);
|
|
R := MonInfo.rcWork;
|
|
if Abs(x + Width - R.Right) < SnapDistance then x := R.Right - Width;
|
|
if Abs(y + Height - R.Bottom) < SnapDistance then y := R.Bottom - Height;
|
|
if Abs(x - R.Left) < SnapDistance then x := R.Left;
|
|
if Abs(y - R.Top) < SnapDistance then y := R.Top;
|
|
end;
|
|
end;
|
|
inherited;
|
|
end;
|
|
|
|
|
|
//============================================================================//
|
|
|
|
{ TTBXToolWindow }
|
|
|
|
procedure TTBXToolWindow.CMColorChanged(var Message: TMessage);
|
|
begin
|
|
UpdateEffectiveColor;
|
|
if Docked and HandleAllocated then
|
|
RedrawWindow(Handle, nil, 0, RDW_FRAME or RDW_INVALIDATE or
|
|
RDW_ERASE or RDW_UPDATENOW or RDW_ALLCHILDREN);
|
|
UpdateChildColors;
|
|
Invalidate;
|
|
end;
|
|
|
|
procedure TTBXToolWindow.CMControlChange(var Message: TCMControlChange);
|
|
begin
|
|
inherited;
|
|
if Message.Inserting and (Color = clNone) then
|
|
Message.Control.Perform(CM_PARENTCOLORCHANGED, 1, EffectiveColor);
|
|
end;
|
|
|
|
procedure TTBXToolWindow.CMTextChanged(var Message: TMessage);
|
|
begin
|
|
inherited;
|
|
if HandleAllocated then
|
|
begin
|
|
if Docked then RedrawWindow(Handle, nil, 0, RDW_FRAME or RDW_INVALIDATE)
|
|
else RedrawWindow(TTBXFloatingWindowParent(Parent).Handle, nil, 0, RDW_FRAME or RDW_INVALIDATE);
|
|
end;
|
|
end;
|
|
|
|
constructor TTBXToolWindow.Create(AOwner: TComponent);
|
|
begin
|
|
inherited;
|
|
AddThemeNotification(Self);
|
|
DblClickUndock := False;
|
|
FEffectiveColor := Color;
|
|
Color := clNone;
|
|
end;
|
|
|
|
destructor TTBXToolWindow.Destroy;
|
|
begin
|
|
RemoveThemeNotification(Self);
|
|
inherited;
|
|
end;
|
|
|
|
procedure TTBXToolWindow.DrawNCArea(const DrawToDC: Boolean;
|
|
const ADC: HDC; const Clip: HRGN);
|
|
var
|
|
DC: HDC;
|
|
R, CR, R2: TRect;
|
|
ACanvas: TCanvas;
|
|
ToolbarInfo: TTBXToolbarInfo;
|
|
UsingBackground: Boolean;
|
|
begin
|
|
if not Docked or not HandleAllocated then Exit;
|
|
|
|
if not DrawToDC then DC := GetWindowDC(Handle)
|
|
else DC := ADC;
|
|
|
|
UsingBackground := TDockAccess(CurrentDock).UsingBackground;
|
|
|
|
try
|
|
GetToolbarInfo(ToolbarInfo);
|
|
GetWindowRect(Handle, R);
|
|
OffsetRect(R, -R.Left, -R.Top);
|
|
if not DrawToDC then
|
|
begin
|
|
SelectNCUpdateRgn(Handle, DC, Clip);
|
|
CR := R;
|
|
with ToolbarInfo.BorderSize, CR do
|
|
begin
|
|
InflateRect(CR, -X, -Y);
|
|
if ToolbarInfo.IsVertical then Inc(Top, GetTBXDragHandleSize(ToolbarInfo))
|
|
else Inc(Left, GetTBXDragHandleSize(ToolbarInfo));
|
|
ExcludeClipRect(DC, Left, Top, Right, Bottom);
|
|
end;
|
|
end;
|
|
ACanvas := TCanvas.Create;
|
|
try
|
|
ACanvas.Handle := DC;
|
|
ACanvas.Brush.Color := EffectiveColor;
|
|
if CurrentTheme.SolidToolbarNCArea then
|
|
begin
|
|
ACanvas.Brush.Color := EffectiveColor;
|
|
ACanvas.Brush.Style := bsSolid;
|
|
end
|
|
else if UsingBackground then
|
|
begin
|
|
ACanvas.Brush.Color := EffectiveColor;
|
|
R2 := CurrentDock.ClientRect;
|
|
OffsetRect(R2, -Left, -Top);
|
|
TDockAccess(CurrentDock).DrawBackground(DC, R2);
|
|
if (Color = clNone) and CurrentDock.BackgroundOnToolbars then
|
|
ACanvas.Brush.Style := bsClear;
|
|
end
|
|
else
|
|
begin
|
|
ACanvas.Brush.Color := GetEffectiveColor(CurrentDock);
|
|
ACanvas.FillRect(R);
|
|
ACanvas.Brush.Color := EffectiveColor;
|
|
ACanvas.Brush.Style := bsSolid;
|
|
end;
|
|
|
|
CurrentTheme.PaintToolbarNCArea(ACanvas, R, ToolbarInfo);
|
|
finally
|
|
ACanvas.Handle := 0;
|
|
ACanvas.Free;
|
|
end;
|
|
finally
|
|
if not DrawToDC then ReleaseDC(Handle, DC);
|
|
end;
|
|
end;
|
|
|
|
function TTBXToolWindow.GetFloatingBorderSize: TPoint;
|
|
begin
|
|
CurrentTheme.GetViewBorder(GetWinViewType(Self) or TVT_FLOATING, Result);
|
|
end;
|
|
|
|
function TTBXToolWindow.GetFloatingWindowParentClass: TTBFloatingWindowParentClass;
|
|
begin
|
|
Result := TTBXFloatingWindowParent;
|
|
end;
|
|
|
|
procedure TTBXToolWindow.GetToolbarInfo(out ToolbarInfo: TTBXToolbarInfo);
|
|
begin
|
|
FillChar(ToolbarInfo, SizeOf(ToolbarInfo), 0);
|
|
ToolbarInfo.WindowHandle := WindowHandle;
|
|
ToolbarInfo.ViewType := GetWinViewType(Self);
|
|
if CurrentDock <> nil then
|
|
ToolbarInfo.IsVertical := CurrentDock.Position in [dpLeft,dpRight];
|
|
ToolbarInfo.AllowDrag := CurrentDock.AllowDrag;
|
|
ToolbarInfo.DragHandleStyle := Ord(DragHandleStyle);
|
|
ToolbarInfo.ClientWidth := ClientWidth;
|
|
ToolbarInfo.ClientHeight := ClientHeight;
|
|
if ToolbarInfo.AllowDrag and CloseButtonWhenDocked then
|
|
begin
|
|
ToolbarInfo.CloseButtonState := CDBS_VISIBLE;
|
|
if CloseButtonDown then ToolbarInfo.CloseButtonState := ToolbarInfo.CloseButtonState or CDBS_PRESSED;
|
|
if CloseButtonHover then ToolbarInfo.CloseButtonState := ToolbarInfo.CloseButtonState or CDBS_HOT;
|
|
end;
|
|
ToolbarInfo.BorderStyle := BorderStyle;
|
|
ToolbarInfo.EffectiveColor := EffectiveColor;
|
|
CurrentTheme.GetViewBorder(ToolbarInfo.ViewType, ToolbarInfo.BorderSize);
|
|
end;
|
|
|
|
procedure TTBXToolWindow.SetParent(AParent: TWinControl);
|
|
begin
|
|
inherited;
|
|
if AParent is TTBXFloatingWindowParent then
|
|
TTBXFloatingWindowParent(AParent).SnapDistance := SnapDistance;
|
|
end;
|
|
|
|
procedure TTBXToolWindow.SetSnapDistance(Value: Integer);
|
|
begin
|
|
if Value < 0 then Value := 0;
|
|
FSnapDistance := Value;
|
|
if (Parent <> nil) and (Parent is TTBXFloatingWindowParent) then
|
|
TTBXFloatingWindowParent(Parent).SnapDistance := Value;
|
|
end;
|
|
|
|
procedure TTBXToolWindow.TBMGetEffectiveColor(var Message: TMessage);
|
|
begin
|
|
Message.WParam := EffectiveColor;
|
|
Message.Result := 1;
|
|
end;
|
|
|
|
procedure TTBXToolWindow.TBMGetViewType(var Message: TMessage);
|
|
begin
|
|
Message.Result := TVT_TOOLWINDOW;
|
|
if Floating then Message.Result := Message.Result or TVT_FLOATING;
|
|
if Resizable then Message.Result := Message.Result or TVT_RESIZABLE;
|
|
end;
|
|
|
|
procedure TTBXToolWindow.TBMThemeChange(var Message: TMessage);
|
|
begin
|
|
case Message.WParam of
|
|
TSC_BEFOREVIEWCHANGE: BeginUpdate;
|
|
TSC_AFTERVIEWCHANGE:
|
|
begin
|
|
EndUpdate;
|
|
UpdateEffectiveColor;
|
|
if HandleAllocated and not (csDestroying in ComponentState) then
|
|
if Parent is TTBXFloatingWindowParent then
|
|
UpdateNCArea(TTBXFloatingWindowParent(Parent), GetWinViewType(Self))
|
|
else
|
|
UpdateNCArea(Self, GetWinViewType(Self));
|
|
UpdateChildColors;
|
|
Invalidate;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TTBXToolWindow.UpdateChildColors;
|
|
var
|
|
M: TMessage;
|
|
begin
|
|
M.Msg := CM_PARENTCOLORCHANGED;
|
|
M.WParam := 1;
|
|
M.LParam := EffectiveColor;
|
|
M.Result := 0;
|
|
Broadcast(M);
|
|
end;
|
|
|
|
procedure TTBXToolWindow.UpdateEffectiveColor;
|
|
begin
|
|
if Color = clNone then FEffectiveColor := CurrentTheme.GetViewColor(GetWinViewType(Self))
|
|
else FEffectiveColor := Color;
|
|
end;
|
|
|
|
procedure TTBXToolWindow.WMEraseBkgnd(var Message: TWmEraseBkgnd);
|
|
var
|
|
Canvas: TCanvas;
|
|
R, CR: TRect;
|
|
Transparent: Boolean;
|
|
begin
|
|
Transparent := False;
|
|
CR := ClientRect;
|
|
if Color = clNone then
|
|
if Docked and (TDockAccess(CurrentDock).UsingBackground) and CurrentDock.BackgroundOnToolbars
|
|
and not CurrentTheme.SolidToolbarClientArea then
|
|
begin
|
|
R := CurrentDock.ClientRect;
|
|
R.TopLeft := ScreenToClient(CurrentDock.ClientToScreen(R.TopLeft));
|
|
R.BottomRight := ScreenToClient(CurrentDock.ClientToScreen(R.BottomRight));
|
|
SaveDC(Message.DC);
|
|
with CR do IntersectClipRect(Message.DC, Left, Top, Right, Bottom);
|
|
TDockAccess(CurrentDock).DrawBackground(Message.DC, R);
|
|
RestoreDC(Message.DC, -1);
|
|
Message.Result := 1;
|
|
Transparent := True;
|
|
end;
|
|
|
|
Canvas := TCanvas.Create;
|
|
Canvas.Handle := Message.DC;
|
|
try
|
|
if Docked then
|
|
begin
|
|
R := CurrentDock.ClientRect;
|
|
R.TopLeft := ScreenToClient(CurrentDock.ClientToScreen(R.TopLeft));
|
|
R.BottomRight := ScreenToClient(CurrentDock.ClientToScreen(R.BottomRight));
|
|
end
|
|
else R := Rect(0, 0, 0, 0);
|
|
CurrentTheme.PaintBackgnd(Canvas, R, CR, CR, EffectiveColor, Transparent, GetWinViewType(Self));
|
|
Message.Result := 1;
|
|
finally
|
|
Canvas.Handle := 0;
|
|
Canvas.Free;
|
|
end;
|
|
end;
|
|
|
|
//============================================================================//
|
|
|
|
{ Additional system colors }
|
|
|
|
type
|
|
TColorEntry = packed record
|
|
ColorPtr: ^TColor;
|
|
Name: string;
|
|
end;
|
|
|
|
var
|
|
ColorRegistry: array of TColorEntry;
|
|
|
|
procedure AddTBXColor(var AColor: TColor; const AName: string);
|
|
var
|
|
L: Integer;
|
|
begin
|
|
L := Length(ColorRegistry);
|
|
SetLength(ColorRegistry, L + 1);
|
|
with ColorRegistry[L] do
|
|
begin
|
|
ColorPtr := @AColor;
|
|
Name := AName;
|
|
end;
|
|
end;
|
|
|
|
function TBXColorToString(Color: TColor): string;
|
|
var
|
|
I: Integer;
|
|
begin
|
|
if not ColorToIdent(Color, Result) then
|
|
begin
|
|
for I := 0 to Length(ColorRegistry) - 1 do
|
|
if ColorRegistry[I].ColorPtr^ = Color then
|
|
begin
|
|
Result := ColorRegistry[I].Name;
|
|
Exit;
|
|
end;
|
|
FmtStr(Result, '%s%.8x', [HexDisplayPrefix, Color]);
|
|
end;
|
|
end;
|
|
|
|
function TBXIdentToColor(const Ident: string; var Color: Longint): Boolean;
|
|
var
|
|
I: Integer;
|
|
begin
|
|
for I := 0 to Length(ColorRegistry) - 1 do
|
|
if CompareText(ColorRegistry[I].Name, Ident) = 0 then
|
|
begin
|
|
Color := ColorRegistry[I].ColorPtr^;
|
|
Result := True;
|
|
Exit;
|
|
end;
|
|
Result := IdentToColor(Ident, Color);
|
|
end;
|
|
|
|
function TBXStringToColor(S: string): TColor;
|
|
begin
|
|
if not TBXIdentToColor(S, Longint(Result)) then Result := StringToColor(S);
|
|
end;
|
|
|
|
procedure TBXGetColorValues(Proc: TGetStrProc);
|
|
var
|
|
I: Integer;
|
|
begin
|
|
GetColorValues(Proc);
|
|
for I := 0 to Length(ColorRegistry) - 1 do Proc(ColorRegistry[I].Name);
|
|
end;
|
|
|
|
procedure TBXSetTheme(const AThemeName: string);
|
|
begin
|
|
TBXNexus.SetTheme(AThemeName);
|
|
end;
|
|
|
|
function TBXCurrentTheme: string;
|
|
begin
|
|
Result := TBXNexus.GetTheme;
|
|
end;
|
|
|
|
|
|
//============================================================================//
|
|
|
|
|
|
{ TTBXNexus }
|
|
|
|
procedure TTBXNexus.AddNotifie(AObject: TObject);
|
|
begin
|
|
if FNotifies.IndexOf(AObject) < 0 then FNotifies.Add(AObject);
|
|
Exit; asm db 0,'TBX (C) 2001-2003 Alex Denisov',0 end;
|
|
end;
|
|
|
|
procedure TTBXNexus.Broadcast(Msg: Cardinal; WParam, LParam: Integer);
|
|
var
|
|
M: TMessage;
|
|
I: Integer;
|
|
begin
|
|
if FNotifies.Count > 0 then
|
|
begin
|
|
M.Msg := Msg;
|
|
M.WParam := WParam;
|
|
M.LParam := LParam;
|
|
M.Result := 0;
|
|
for I := 0 to FNotifies.Count - 1 do TObject(FNotifies[I]).Dispatch(M);
|
|
end;
|
|
end;
|
|
|
|
constructor TTBXNexus.Create(const DefaultTheme: string);
|
|
begin
|
|
FNotifies := TList.Create;
|
|
CurrentTheme := GetTBXTheme(DefaultTheme);
|
|
AddTBXSysChangeNotification(Self);
|
|
end;
|
|
|
|
destructor TTBXNexus.Destroy;
|
|
begin
|
|
RemoveTBXSysChangeNotification(Self);
|
|
ReleaseTBXTheme(CurrentTheme);
|
|
FNotifies.Free;
|
|
inherited;
|
|
end;
|
|
|
|
function TTBXNexus.GetTheme: string;
|
|
begin
|
|
Result := CurrentTheme.Name;
|
|
end;
|
|
|
|
procedure TTBXNexus.RemoveNotifie(AObject: TObject);
|
|
begin
|
|
FNotifies.Remove(AObject);
|
|
end;
|
|
|
|
procedure TTBXNexus.SetTheme(const AThemeName: string);
|
|
begin
|
|
if IsTBXThemeAvailable(AThemeName) then
|
|
begin
|
|
ReleaseTBXTheme(CurrentTheme);
|
|
CurrentTheme := GetTBXTheme(AThemeName);
|
|
Broadcast(TBM_THEMECHANGE, TSC_BEFOREVIEWCHANGE, 1);
|
|
Broadcast(TBM_THEMECHANGE, TSC_VIEWCHANGE, 1);
|
|
Broadcast(TBM_THEMECHANGE, TSC_AFTERVIEWCHANGE, 1);
|
|
end;
|
|
end;
|
|
|
|
procedure TTBXNexus.TBXSysCommand(var Message: TMessage);
|
|
begin
|
|
{ Retranslate TBX_SYSCOMMAND to TBM_THEMECHANGE }
|
|
if Message.Msg = TBX_SYSCOMMAND then
|
|
Broadcast(TBM_THEMECHANGE, Message.WParam, 0);
|
|
end;
|
|
|
|
procedure InitAdditionalSysColors;
|
|
begin
|
|
{$IFNDEF JR_D7} {vb+}
|
|
AddTBXColor(clHotLight, 'clHotLight');
|
|
{$ENDIF} {vb+}
|
|
{$IFNDEF JR_D6}
|
|
AddTBXColor(clMoneyGreen, 'clMoneyGreen');
|
|
AddTBXColor(clSkyBlue, 'clSkyBlue');
|
|
AddTBXColor(clCream, 'clCream');
|
|
AddTBXColor(clMedGray, 'clMedGray');
|
|
{$ENDIF}
|
|
end;
|
|
|
|
{ TTBXDock }
|
|
|
|
procedure TTBXDock.CMColorChanged(var Message: TMessage);
|
|
var
|
|
I: Integer;
|
|
begin
|
|
inherited;
|
|
for I := 0 to Self.ControlCount - 1 do
|
|
if Controls[I] is TWinControl then
|
|
InvalidateAll(TWinControl(Controls[I]));
|
|
end;
|
|
|
|
constructor TTBXDock.Create(AOwner: TComponent);
|
|
begin
|
|
inherited;
|
|
Color := clNone;
|
|
AddThemeNotification(Self);
|
|
end;
|
|
|
|
destructor TTBXDock.Destroy;
|
|
begin
|
|
RemoveThemeNotification(Self);
|
|
inherited;
|
|
end;
|
|
|
|
procedure TTBXDock.DrawBackground(DC: HDC; const DrawRect: TRect);
|
|
const
|
|
DOCK_POSITIONS: array [TTBDockPosition] of Integer = (DP_TOP, DP_BOTTOM, DP_LEFT, DP_RIGHT);
|
|
var
|
|
Canvas: TCanvas;
|
|
begin
|
|
if UseParentBackground then DrawParentBackground(Self, DC, ClientRect)
|
|
else if ThemedBackground then
|
|
begin
|
|
Canvas := TCanvas.Create;
|
|
Canvas.Handle := DC;
|
|
CurrentTheme.PaintDock(Canvas, ClientRect, DrawRect, DOCK_POSITIONS[Position]);
|
|
Canvas.Handle := 0;
|
|
Canvas.Free;
|
|
end
|
|
else inherited;
|
|
end;
|
|
|
|
procedure TTBXDock.Resize;
|
|
var
|
|
I, J: Integer;
|
|
V: TTBItemViewer;
|
|
R: TRect;
|
|
begin
|
|
inherited Resize;
|
|
if UsingBackground then
|
|
begin
|
|
for J := 0 to ToolbarCount - 1 do
|
|
begin
|
|
Invalidate;
|
|
if Toolbars[J] is TTBXToolbar then with TTBXToolbar(Toolbars[J]) do
|
|
begin
|
|
for I := 0 to View.ViewerCount - 1 do
|
|
begin
|
|
V := View.Viewers[I];
|
|
if V.Show and not IsRectEmpty(V.BoundsRect) and not (V.Item is TTBControlItem)
|
|
then View.Invalidate(V);
|
|
end;
|
|
Update;
|
|
if HandleAllocated then
|
|
RedrawWindow(Handle, nil, 0, RDW_FRAME or RDW_INVALIDATE or RDW_ERASE);
|
|
for I := 0 to View.ViewerCount - 1 do
|
|
begin
|
|
V := View.Viewers[I];
|
|
if V.Show and not IsRectEmpty(V.BoundsRect) and not (V.Item is TTBControlItem)
|
|
then
|
|
begin
|
|
R := V.BoundsRect;
|
|
ValidateRect(Handle, @R);
|
|
end;
|
|
end;
|
|
end
|
|
else if Toolbars[J] is TTBXToolWindow then with TTBXToolWindow(Toolbars[J]) do
|
|
begin
|
|
if HandleAllocated then
|
|
RedrawWindow(Handle, nil, 0, RDW_FRAME or RDW_INVALIDATE or RDW_ERASE);
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TTBXDock.SetUseParentBackground(Value: Boolean);
|
|
begin
|
|
if Value <> FUseParentBackground then
|
|
begin
|
|
FUseParentBackground := Value;
|
|
if HandleAllocated then
|
|
RedrawWindow(Handle, nil, 0, RDW_FRAME or RDW_INVALIDATE or
|
|
RDW_ERASE or RDW_ALLCHILDREN);
|
|
end;
|
|
end;
|
|
|
|
procedure TTBXDock.TBMGetEffectiveColor(var Message: TMessage);
|
|
begin
|
|
if Color <> clNone then Message.WParam := Color
|
|
else if Parent <> nil then Message.WParam := GetEffectiveColor(Parent)
|
|
else Message.WParam := clBtnFace;
|
|
Message.Result := 1;
|
|
end;
|
|
|
|
procedure TTBXDock.TBMThemeChange(var Message: TMessage);
|
|
begin
|
|
case Message.WParam of
|
|
TSC_AFTERVIEWCHANGE:
|
|
begin
|
|
Invalidate;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function TTBXDock.ThemedBackground: Boolean;
|
|
begin
|
|
Result := (Background = nil) and (Color = clNone) and CurrentTheme.PaintDockBackground;
|
|
end;
|
|
|
|
function TTBXDock.UsingBackground: Boolean;
|
|
begin
|
|
Result := UseParentBackground or (ThemedBackground and not FMoving) or
|
|
inherited UsingBackground;
|
|
end;
|
|
|
|
procedure TTBXDock.WMEraseBkgnd(var Message: TWMEraseBkgnd);
|
|
var
|
|
R: TRect;
|
|
C: TColor;
|
|
begin
|
|
R := Self.ClientRect;
|
|
if UsingBackground then
|
|
begin
|
|
DrawBackground(Message.DC, R);
|
|
Message.Result := 1;
|
|
end
|
|
else
|
|
begin
|
|
C := Color;
|
|
if C = clNone then C := GetEffectiveColor(Parent);
|
|
FillRectEx(Message.DC, R, C);
|
|
Message.Result := 1;
|
|
end;
|
|
end;
|
|
|
|
procedure TTBXDock.WMMove(var Message: TWMMove);
|
|
begin
|
|
FMoving := True;
|
|
inherited;
|
|
FMoving := False;
|
|
end;
|
|
|
|
procedure TTBXDock.WMSize(var Message: TWMSize);
|
|
begin
|
|
FResizing := True;
|
|
inherited;
|
|
FResizing := False;
|
|
end;
|
|
|
|
{ TTBXMenuAnimation } {vb+}
|
|
|
|
constructor TTBXMenuAnimation.Create(AAnimationMode: TAnimationMode = amSysDefault);
|
|
begin
|
|
AnimationMode := AAnimationMode;
|
|
end;
|
|
|
|
function TTBXMenuAnimation.GetAvailableModes: TAnimationModes;
|
|
var IsWindows2K: Boolean;
|
|
begin
|
|
Result := [amNone];
|
|
IsWindows2K := (Win32Platform = VER_PLATFORM_WIN32_NT) and
|
|
CheckWin32Version(5);
|
|
if IsWindows2K or ((Win32Platform = VER_PLATFORM_WIN32_WINDOWS) and
|
|
CheckWin32Version(4, 10){Win98}) then
|
|
Result := Result+ [amSysDefault, amRandom, amUnfold, amSlide];
|
|
if IsWindows2K then
|
|
Include(Result, amFade);
|
|
end;
|
|
|
|
function TTBXMenuAnimation.GetMenuAnimation: TMenuAnimation;
|
|
|
|
function GetSysDefault: TMenuAnimation;
|
|
const
|
|
SPI_GETMENUFADE = $1012;
|
|
SysDefAni: array[Boolean] of TMenuAnimation = (maSlide, maFade);
|
|
begin
|
|
if SysParamEnabled(SPI_GETMENUANIMATION)
|
|
then Result := SysDefAni[SysParamEnabled(SPI_GETMENUFADE)]
|
|
else Result := maNone;
|
|
end;
|
|
|
|
function GetRandom: TMenuAnimation;
|
|
var Max: Integer;
|
|
begin
|
|
Max := Ord(High(TMenuAnimation));
|
|
if not (amFade in AvailableModes) then
|
|
Dec(Max);
|
|
Result := Succ(TMenuAnimation(Random(Max)));
|
|
end;
|
|
|
|
begin
|
|
case AnimationMode of
|
|
amSysDefault: Result := GetSysDefault;
|
|
amRandom: Result := GetRandom;
|
|
amUnfold: Result := maUnfold;
|
|
amSlide: Result := maSlide;
|
|
amFade: Result := maFade;
|
|
else
|
|
Result := maNone;
|
|
end;
|
|
end;
|
|
|
|
procedure TTBXMenuAnimation.SetAnimationMode(Value: TAnimationMode);
|
|
var AvailModes: TAnimationModes;
|
|
begin
|
|
AvailModes := AvailableModes;
|
|
while not (Value in AvailModes) do
|
|
Value := Pred(Value);
|
|
FAnimationMode := Value;
|
|
end;
|
|
|
|
function TTBXMenuAnimation.SysParamEnabled(Param: Cardinal): Boolean;
|
|
var B: BOOL;
|
|
begin
|
|
Result := SystemParametersInfo(Param, 0, @B, 0) and B;
|
|
end;
|
|
|
|
{ Work around delayed menu showing in Windows 2000+ } {vb+}
|
|
var
|
|
FixPlaySoundThreadHandle: Cardinal;
|
|
|
|
function FixPlaySoundThreadFunc(Param: Pointer): Integer; stdcall;
|
|
begin
|
|
Sleep(250);
|
|
PlaySound(nil, 0, 0);
|
|
CloseHandle(FixPlaySoundThreadHandle); { Harakiri :~| }
|
|
Result := $4E494150; { :) }
|
|
end;
|
|
|
|
procedure FixPlaySoundDelay;
|
|
var ThreadId: Cardinal;
|
|
begin
|
|
if (Win32Platform = VER_PLATFORM_WIN32_NT) and CheckWin32Version(5) and
|
|
(FixPlaySoundThreadHandle = 0) then
|
|
FixPlaySoundThreadHandle := CreateThread(nil, $1000,
|
|
@FixPlaySoundThreadFunc, nil, 0, ThreadId);
|
|
end;
|
|
|
|
initialization
|
|
FixPlaySoundDelay; {vb+}
|
|
{CurrentTheme := nil;} {vb-}
|
|
RegisterTBXTheme('Default', TTBXDefaultTheme);
|
|
TBXNexus := TTBXNexus.Create('Default');
|
|
TBXMenuAnimation := TTBXMenuAnimation.Create; {vb+}
|
|
{$IFNDEF JR_D7} {vb+}
|
|
InitAdditionalSysColors;
|
|
{$ENDIF} {vb+}
|
|
|
|
finalization
|
|
TBXNexus.Free;
|
|
FreeAndNil(TBXMenuAnimation); {vb+}
|
|
ColorRegistry := nil;
|
|
|
|
end.
|