unit TBXDkPanels; // TBX Package // Copyright 2001-2004 Alex A. Denisov. All Rights Reserved // See TBX.chm for license and installation instructions // // $Id: TBXDkPanels.pas 21 2004-05-29 22:16:01Z Alex@ZEISS $ interface {$I ..\..\Source\TB2Ver.inc} {$I TBX.inc} uses Windows, Messages, Classes, Graphics, Controls, StdCtrls, ExtCtrls, Forms, TB2Dock, TB2Item, TBX, TBXThemes, ImgList, Menus; const { New hit test constants for page scrollers } HTSCROLLPREV = 30; HTSCROLLNEXT = 31; type { TTBXControlMargins } TTBXControlMargins = class(TPersistent) private FLeft, FTop, FRight, FBottom: Integer; FOnChange: TNotifyEvent; procedure SetBottom(Value: Integer); procedure SetLeft(Value: Integer); procedure SetRight(Value: Integer); procedure SetTop(Value: Integer); public procedure Assign(Src: TPersistent); override; procedure Modified; dynamic; property OnChange: TNotifyEvent read FOnChange write FOnChange; published property Left: Integer read FLeft write SetLeft default 0; property Top: Integer read FTop write SetTop default 0; property Right: Integer read FRight write SetRight default 0; property Bottom: Integer read FBottom write SetBottom default 0; end; { TTBXMultiDock } TTBXMultiDock = class(TTBDock) protected LastValidRowSize: Integer; function Accepts(ADockableWindow: TTBCustomDockableWindow): Boolean; override; procedure ValidateInsert(AComponent: TComponent); override; public procedure ArrangeToolbars; override; procedure Paint; override; procedure ResizeVisiblePanels(NewSize: Integer); end; { TTBXCustomDockablePanel } TDPCaptionRotation = (dpcrAuto, dpcrAlwaysHorz, dpcrAlwaysVert); TTBXResizingStage = (rsBeginResizing, rsResizing, rsEndResizing); TTBXDockedResizing = procedure(Sender: TObject; Vertical: Boolean; var NewSize: Integer; Stage: TTBXResizingStage; var AllowResize: Boolean) of object; TDockKinds = set of (dkStandardDock, dkMultiDock); {TTBXDockablePanel = class(TTBCustomDockableWindow)} {vb-} TTBXCustomDockablePanel = class(TTBCustomDockableWindow) {vb+} private FBorderSize: Integer; FCaptionRotation: TDPCaptionRotation; FDockedWidth: Integer; FDockedHeight: Integer; FEffectiveColor: TColor; FFloatingWidth: Integer; FFloatingHeight: Integer; FHorzResizeCursor: TCursor; {vb+} FHorzSplitCursor : TCursor; {vb+} FIsResizing: Boolean; FIsSplitting: Boolean; FMinClientWidth: Integer; FMinClientHeight: Integer; FMaxClientWidth: Integer; FMaxClientHeight: Integer; FSmoothDockedResize: Boolean; FSnapDistance: Integer; FShowCaptionWhenDocked: Boolean; FSplitHeight: Integer; FSplitWidth: Integer; FSupportedDocks: TDockKinds; FVertResizeCursor: TCursor; {vb+} FVertSplitCursor : TCursor; {vb+} FOnDockedResizing: TTBXDockedResizing; function CalcSize(ADock: TTBDock): TPoint; procedure SetBorderSize(Value: Integer); procedure SetCaptionRotation(Value: TDPCaptionRotation); procedure SetDockedHeight(Value: Integer); procedure SetDockedWidth(Value: Integer); procedure SetFloatingHeight(Value: Integer); procedure SetFloatingWidth(Value: Integer); procedure SetMinClientHeight(Value: Integer); procedure SetMinClientWidth(Value: Integer); procedure SetShowCaptionWhenDocked(Value: Boolean); procedure SetSnapDistance(Value: 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 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; procedure WMNCHitTest(var Message: TWMNCHitTest); message WM_NCHITTEST; procedure WMNCCalcSize(var Message: TWMNCCalcSize); message WM_NCCALCSIZE; procedure WMNCLButtonDown(var Message: TWMNCLButtonDown); message WM_NCLBUTTONDOWN; procedure WMSetCursor(var Message: TWMSetCursor); message WM_SETCURSOR; procedure WMWindowPosChanged(var Message: TWMWindowPosChanged); message WM_WINDOWPOSCHANGED; procedure SetSplitHeight(Value: Integer); procedure SetSplitWidth(Value: Integer); protected BlockSizeUpdate: Boolean; procedure AdjustClientRect(var Rect: TRect); override; procedure BeginDockedSizing(HitTest: Integer); procedure BeginSplitResizing(HitTest: Integer); function CalcNCSizes: TPoint; override; function CanAutoSize(var NewWidth, NewHeight: Integer): Boolean; override; function CanDockTo(ADock: TTBDock): Boolean; override; function CanSplitResize(EdgePosition: TTBDockPosition): Boolean; procedure ConstrainedResize(var MinWidth, MinHeight, MaxWidth, MaxHeight: Integer); override; function DoArrange(CanMoveControls: Boolean; PreviousDockType: TTBDockType; NewFloating: Boolean; NewDock: TTBDock): TPoint; override; function DoBeginDockedResizing(Vertical: Boolean): Boolean; virtual; function DoDockedResizing(Vertical: Boolean; var NewSize: Integer): Boolean; virtual; function DoEndDockedResizing(Vertical: Boolean): Boolean; virtual; procedure DrawNCArea(const DrawToDC: Boolean; const ADC: HDC; const Clip: HRGN); override; procedure GetBaseSize(var ASize: TPoint); override; function GetDockedCloseButtonRect(LeftRight: Boolean): TRect; override; procedure GetDockPanelInfo(out DockPanelInfo: TTBXDockPanelInfo); virtual; function GetFloatingWindowParentClass: TTBFloatingWindowParentClass; override; procedure GetMinMaxSize(var AMinClientWidth, AMinClientHeight, AMaxClientWidth, AMaxClientHeight: Integer); override; function GetViewType: Integer; function IsVertCaption: Boolean; virtual; procedure Loaded; override; procedure Paint; override; procedure SetParent(AParent: TWinControl); override; procedure SizeChanging(const AWidth, AHeight: Integer); override; procedure UpdateEffectiveColor; property IsResizing: Boolean read FIsResizing; property IsSplitting: Boolean read FIsSplitting; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; function GetFloatingBorderSize: TPoint; override; procedure ReadPositionData(const Data: TTBReadPositionData); override; procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override; procedure UpdateChildColors; procedure WritePositionData(const Data: TTBWritePositionData); override; property EffectiveColor: TColor read FEffectiveColor; property CaptionRotation: TDPCaptionRotation read FCaptionRotation write SetCaptionRotation default dpcrAuto; property Color default clNone; property CloseButtonWhenDocked default True; property DblClickUndock default False; { client size constraints should be restored before other size related properties } property MaxClientHeight: Integer read FMaxClientHeight write FMaxClientHeight default 0; property MaxClientWidth: Integer read FMaxClientWidth write FMaxClientWidth default 0; property MinClientHeight: Integer read FMinClientHeight write SetMinClientHeight default 32; property MinClientWidth: Integer read FMinClientWidth write SetMinClientWidth default 32; property BorderSize: Integer read FBorderSize write SetBorderSize default 0; property DockedWidth: Integer read FDockedWidth write SetDockedWidth default 128; property DockedHeight: Integer read FDockedHeight write SetDockedHeight default 128; property FloatingWidth: Integer read FFloatingWidth write SetFloatingWidth default 0; property FloatingHeight: Integer read FFloatingHeight write SetFloatingHeight default 0; property Height stored False; property HorzResizeCursor: TCursor read FHorzResizeCursor write FHorzResizeCursor default crSizeWE; {vb+} property HorzSplitCursor: TCursor read FHorzSplitCursor write FHorzSplitCursor default crHSplit; {vb+} property ShowCaptionWhenDocked: Boolean read FShowCaptionWhenDocked write SetShowCaptionWhenDocked default True; property SplitHeight: Integer read FSplitHeight write SetSplitHeight default 0; property SplitWidth: Integer read FSplitWidth write SetSplitWidth default 0; property SupportedDocks: TDockKinds read FSupportedDocks write FSupportedDocks; property SmoothDockedResize: Boolean read FSmoothDockedResize write FSmoothDockedResize default True; property SnapDistance: Integer read FSnapDistance write SetSnapDistance default 0; property VertResizeCursor: TCursor read FVertResizeCursor write FVertResizeCursor default crSizeNS; {vb+} property VertSplitCursor: TCursor read FVertSplitCursor write FVertSplitCursor default crVSplit; {vb+} property Width stored False; property OnDockedResizing: TTBXDockedResizing read FOnDockedResizing write FOnDockedResizing; end; {vb+} { TTBXDockablePanel } TTBXDockablePanel = class(TTBXCustomDockablePanel) {vb+} published { client size constraints should be restored before other size related properties } property MaxClientHeight; property MaxClientWidth; property MinClientHeight; property MinClientWidth; property ActivateParent; property Align; property Anchors; property BorderSize; property BorderStyle; property Caption; property CaptionRotation; property Color; property CloseButton; property CloseButtonWhenDocked; property CurrentDock; property DblClickUndock; property DefaultDock; property DockableTo; property DockedWidth; property DockedHeight; property DockMode; property DockPos; property DockRow; property FloatingWidth; property FloatingHeight; property FloatingMode; property Font; property Height; property HideWhenInactive; property HorzResizeCursor; {vb+} property HorzSplitCursor; {vb+} property LastDock; property ParentFont; property ParentShowHint; property PopupMenu; property Resizable; property ShowCaption; property ShowCaptionWhenDocked; property ShowHint; property SplitHeight; property SplitWidth; property SupportedDocks; property SmoothDrag; property SmoothDockedResize; property SnapDistance; property TabOrder; property UseLastDock; property VertResizeCursor; {vb+} property VertSplitCursor; {vb+} property Visible; property Width stored False; property OnClose; property OnCloseQuery; {$IFDEF JR_D5} property OnContextPopup; {$ENDIF} property OnDragDrop; property OnDragOver; property OnDockChanged; property OnDockChanging; property OnDockChangingHidden; property OnDockedResizing; property OnMouseDown; property OnMouseMove; property OnMouseUp; property OnMove; property OnRecreated; property OnRecreating; property OnResize; property OnVisibleChanged; end; { TTBXPanelObject } TControlPaintOptions = set of (cpoDoubleBuffered); TTBXPanelObject = class(TCustomControl) private FDisableScroll: Boolean; FMouseInControl: Boolean; FPaintOptions: TControlPaintOptions; FPushed: Boolean; FSmartFocus: Boolean; FSpaceAsClick: Boolean; FOnMouseEnter: TNotifyEvent; FOnMouseLeave: TNotifyEvent; procedure CMParentColorChanged(var Message: TMessage); message CM_PARENTCOLORCHANGED; procedure CMEnabledChanged(var Message: TMessage); message CM_ENABLEDCHANGED; procedure MouseTimerHandler(Sender: TObject); procedure RemoveMouseTimer; procedure SetPaintOptions(Value: TControlPaintOptions); procedure TBMThemeChange(var Message); message TBM_THEMECHANGE; procedure WMEraseBkgnd(var Message: TMessage); message WM_ERASEBKGND; procedure WMKillFocus(var Message: TMessage); message WM_KILLFOCUS; procedure WMSetFocus(var Message: TMessage); message WM_SETFOCUS; protected procedure CreateParams(var Params: TCreateParams); override; procedure DoMouseEnter; virtual; procedure DoMouseLeave; virtual; procedure KeyDown(var Key: Word; Shift: TShiftState); override; procedure KeyUp(var Key: Word; Shift: TShiftState); override; procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; procedure MouseMove(Shift: TShiftState; X, Y: Integer); override; procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; function GetMinHeight: Integer; virtual; function GetMinWidth: Integer; virtual; property Color default clNone; property MouseInControl: Boolean read FMouseInControl; property PaintOptions: TControlPaintOptions read FPaintOptions write SetPaintOptions; property ParentColor default False; property Pushed: Boolean read FPushed; property SpaceAsClick: Boolean read FSpaceAsClick write FSpaceAsClick default False; property SmartFocus: Boolean read FSmartFocus write FSmartFocus default False; property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter; property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; procedure MakeVisible; procedure MouseEntered; procedure MouseLeft; end; { TTBXAlignmentPanel } TTBXAlignmentPanel = class(TTBXPanelObject) private FMargins: TTBXControlMargins; procedure MarginsChangeHandler(Sender: TObject); procedure SetMargins(Value: TTBXControlMargins); protected procedure AdjustClientRect(var Rect: TRect); override; procedure Paint; override; function GetMinHeight: Integer; override; function GetMinWidth: Integer; override; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; published property ParentColor; property Align; property Anchors; property AutoSize; property Color; property Constraints; property DragCursor; property DragKind; property DragMode; property Enabled; property Font; property Margins: TTBXControlMargins read FMargins write SetMargins; property ParentFont; property ShowHint; property TabOrder; property TabStop; property Visible; property OnClick; {$IFDEF JR_D5} property OnContextPopup; {$ENDIF} property OnDblClick; property OnDragDrop; property OnDragOver; property OnEndDock; property OnEndDrag; property OnMouseDown; property OnMouseEnter; property OnMouseLeave; property OnMouseMove; property OnMouseUp; property OnStartDock; property OnStartDrag; end; { TTBXTextObject } TTBXTextObject = class(TTBXPanelObject) private FAlignment: TLeftRight; FMargins: TTBXControlMargins; FWrapping: TTextWrapping; FShowAccelChar: Boolean; FUpdating: Boolean; procedure CMEnabledChanged(var Message: TMessage); message CM_ENABLEDCHANGED; procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED; procedure CMTextChanged(var Message: TMessage); message CM_TEXTCHANGED; procedure MarginsChangeHandler(Sender: TObject); procedure SetAlignment(Value: TLeftRight); procedure SetMargins(Value: TTBXControlMargins); procedure SetShowAccelChar(Value: Boolean); procedure SetWrapping(Value: TTextWrapping); protected procedure AdjustFont(AFont: TFont); virtual; procedure AdjustHeight; procedure CreateParams(var Params: TCreateParams); override; function CanAutoSize(var NewWidth, NewHeight: Integer): Boolean; override; procedure DoAdjustHeight(ACanvas: TCanvas; var NewHeight: Integer); virtual; function DoDrawText(ACanvas: TCanvas; var Rect: TRect; Flags: Longint): Integer; virtual; procedure DoMarginsChanged; virtual; function GetFocusRect(const R: TRect): TRect; virtual; function GetLabelText: string; virtual; function GetTextAlignment: TAlignment; virtual; function GetTextMargins: TRect; virtual; procedure Loaded; override; procedure Paint; override; property Alignment: TLeftRight read FAlignment write SetAlignment default taLeftJustify; property AutoSize default True; property PaintOptions default [cpoDoubleBuffered]; property ShowAccelChar: Boolean read FShowAccelChar write SetShowAccelChar default True; property Margins: TTBXControlMargins read FMargins write SetMargins; property Wrapping: TTextWrapping read FWrapping write SetWrapping default twNone; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; function GetControlsAlignment: TAlignment; override; end; { TTBXCustomLabel } TTBXCustomLabel = class(TTBXTextObject) private FFocusControl: TWinControl; FUnderline: Boolean; FUnderlineColor: TColor; procedure CMDialogChar(var Message: TCMDialogChar); message CM_DIALOGCHAR; procedure SetUnderline(Value: Boolean); procedure SetUnderlineColor(Value: TColor); procedure SetFocusControl(Value: TWinControl); protected function GetTextMargins: TRect; override; procedure Notification(AComponent: TComponent; Operation: TOperation); override; procedure Paint; override; property FocusControl: TWinControl read FFocusControl write SetFocusControl; property Underline: Boolean read FUnderline write SetUnderline default False; property UnderlineColor: TColor read FUnderlineColor write SetUnderlineColor default clBtnShadow; property Wrapping default twWrap; public constructor Create(AOwner: TComponent); override; end; { TTBXLabel } TTBXLabel = class(TTBXCustomLabel) published property Action; {vb+} property Align; property Alignment; property Anchors; property AutoSize; property BiDiMode; property Caption; property Color; property Constraints; property DragCursor; property DragKind; property DragMode; property Enabled; property FocusControl; property Font; property Margins; // property PaintOptions; property ParentBiDiMode; property ParentColor; property ParentFont; property ParentShowHint; property PopupMenu; property ShowAccelChar; property ShowHint; property Underline; property UnderlineColor; property Visible; property Wrapping; property OnClick; {$IFDEF JR_D5} property OnContextPopup; {$ENDIF} property OnDblClick; property OnDragDrop; property OnDragOver; property OnEndDock; property OnEndDrag; property OnMouseDown; property OnMouseEnter; property OnMouseLeave; property OnMouseMove; property OnMouseUp; property OnStartDock; property OnStartDrag; end; { TTBXCustomLink } TTBXCustomLink = class(TTBXTextObject) private FImageChangeLink: TChangeLink; FImageIndex: TImageIndex; FImages: TCustomImageList; procedure ImageListChange(Sender: TObject); procedure SetImageIndex(Value: TImageIndex); procedure SetImages(Value: TCustomImageList); procedure CMDialogChar(var Message: TCMDialogChar); message CM_DIALOGCHAR; procedure CMDialogKey(var Message: TCMDialogKey); message CM_DIALOGKEY; procedure WMNCHitTest(var Message: TWMNCHitTest); message WM_NCHITTEST; protected procedure AdjustFont(AFont: TFont); override; procedure DoAdjustHeight(ACanvas: TCanvas; var NewHeight: Integer); override; procedure DoMouseEnter; override; procedure DoMouseLeave; override; function GetFocusRect(const R: TRect): TRect; override; function GetTextAlignment: TAlignment; override; function GetTextMargins: TRect; override; procedure Paint; override; procedure Notification(AComponent: TComponent; Operation: TOperation); override; property Cursor default crHandPoint; property ImageIndex: TImageIndex read FImageIndex write SetImageIndex; property Images: TCustomImageList read FImages write SetImages; property SmartFocus default True; property TabStop default True; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; function GetControlsAlignment: TAlignment; override; end; { TTBXLink } TTBXLink = class(TTBXCustomLink) published property Action; {vb+} property Align; property Alignment; property Anchors; property AutoSize; property BiDiMode; property Caption; property Color; property Constraints; property DragCursor; property DragKind; property DragMode; property Enabled; property Font; property ImageIndex; property Images; property Margins; // property PaintOptions; property ParentBiDiMode; property ParentColor; property ParentFont; property ParentShowHint; property PopupMenu; property ShowAccelChar; property ShowHint; property SmartFocus; property TabOrder; property TabStop; property Visible; property Wrapping; property OnClick; {$IFDEF JR_D5} property OnContextPopup; {$ENDIF} property OnDblClick; property OnDragDrop; property OnDragOver; property OnEndDock; property OnEndDrag; property OnEnter; property OnExit; property OnMouseDown; property OnMouseEnter; property OnMouseLeave; property OnMouseMove; property OnMouseUp; property OnStartDock; property OnStartDrag; end; { TTBXCustomButton } TTBXCustomButton = class; TButtonLayout = (blGlyphLeft, blGlyphTop, blGlyphRight, blGlyphBottom); TButtonStyle = (bsNormal, bsFlat); TDropDownEvent = procedure(Sender: TTBXCustomButton; var AllowDropDown: Boolean) of object; TTBXCustomButton = class(TTBXTextObject) private FAlignment: TAlignment; FAllowAllUnchecked: Boolean; FBorderSize: Integer; FChecked: Boolean; FDropdownCombo: Boolean; FDropdownMenu: TPopupMenu; FButtonStyle: TButtonStyle; FGlyphSpacing: Integer; FGroupIndex: Integer; FImageChangeLink: TChangeLink; FImageIndex: TImageIndex; FImages: TCustomImageList; FInClick: Boolean; FLayout: TButtonLayout; FMenuVisible: Boolean; FModalResult: TModalResult; FRepeating: Boolean; FRepeatDelay: Integer; FRepeatInterval: Integer; FRepeatTimer: TTimer; FOnDropDown: TDropDownEvent; procedure ImageListChange(Sender: TObject); procedure RepeatTimerHandler(Sender: TObject); procedure SetAlignment(Value: TAlignment); procedure SetAllowAllUnchecked(Value: Boolean); procedure SetBorderSize(Value: Integer); procedure SetButtonStyle(Value: TButtonStyle); procedure SetChecked(Value: Boolean); procedure SetDropdownCombo(Value: Boolean); procedure SetDropdownMenu(Value: TPopupMenu); procedure SetGlyphSpacing(Value: Integer); procedure SetGroupIndex(Value: Integer); procedure SetImageIndex(Value: TImageIndex); procedure SetImages(Value: TCustomImageList); procedure SetLayout(Value: TButtonLayout); procedure CMDialogChar(var Message: TCMDialogChar); message CM_DIALOGCHAR; procedure CMDialogKey(var Message: TCMDialogKey); message CM_DIALOGKEY; procedure WMCancelMode(var Message: TWMCancelMode); message WM_CANCELMODE; procedure WMLButtonDblClk(var Message: TWMLButtonDblClk); message WM_LBUTTONDBLCLK; procedure WMNCHitTest(var Message: TWMNCHitTest); message WM_NCHITTEST; protected function ArrowVisible: Boolean; procedure DoAdjustHeight(ACanvas: TCanvas; var NewHeight: Integer); override; function DoDrawText(ACanvas: TCanvas; var Rect: TRect; Flags: Longint): Integer; override; function DoDropDown: Boolean; virtual; procedure DoMouseEnter; override; procedure DoMouseLeave; override; function GetFocusRect(const R: TRect): TRect; override; procedure GetItemInfo(out ItemInfo: TTBXItemInfo); virtual; function GetTextAlignment: TAlignment; override; function GetTextMargins: TRect; override; procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; procedure MouseMove(Shift: TShiftState; X, Y: Integer); override; procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; procedure Paint; override; function PtInButtonPart(const Pt: TPoint): Boolean; virtual; procedure Notification(AComponent: TComponent; Operation: TOperation); override; procedure UpdateCheckedState; property Alignment: TAlignment read FAlignment write SetAlignment default taCenter; property AllowAllUnchecked: Boolean read FAllowAllUnchecked write SetAllowAllUnchecked default False; property BorderSize: Integer read FBorderSize write SetBorderSize default 4; property ButtonStyle: TButtonStyle read FButtonStyle write SetButtonStyle default bsNormal; property Checked: Boolean read FChecked write SetChecked default False; property DropdownCombo: Boolean read FDropdownCombo write SetDropdownCombo default False; property DropdownMenu: TPopupMenu read FDropdownMenu write SetDropdownMenu; property GlyphSpacing: Integer read FGlyphSpacing write SetGlyphSpacing default 4; property GroupIndex: Integer read FGroupIndex write SetGroupIndex default 0; property ImageIndex: TImageIndex read FImageIndex write SetImageIndex; property Images: TCustomImageList read FImages write SetImages; property Layout: TButtonLayout read FLayout write SetLayout default blGlyphLeft; property ModalResult: TModalResult read FModalResult write FModalResult default 0; property Repeating: Boolean read FRepeating write FRepeating default False; property RepeatDelay: Integer read FRepeatDelay write FRepeatDelay default 400; property RepeatInterval: Integer read FRepeatInterval write FRepeatInterval default 100; property SmartFocus default True; property TabStop default True; property OnDropDown: TDropDownEvent read FOnDropDown write FOnDropDown; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; procedure Click; override; function GetControlsAlignment: TAlignment; override; end; { TTBXButton } TTBXButton = class(TTBXCustomButton) published property Action; {vb+} property Align; property Alignment; property GroupIndex; property AllowAllUnchecked; property Anchors; property AutoSize; property BiDiMode; property BorderSize; property ButtonStyle; property Caption; property Checked; property Constraints; property DragCursor; property DragKind; property DragMode; property DropDownCombo; property DropDownMenu; property Enabled; property Font; property GlyphSpacing; property ImageIndex; property Images; property Layout; property Margins; property ModalResult; // property PaintOptions; property ParentBiDiMode; property ParentFont; property ParentShowHint; property PopupMenu; property Repeating; property RepeatDelay; property RepeatInterval; property ShowAccelChar; property ShowHint; property SmartFocus; property TabOrder; property TabStop; property Visible; property Wrapping; property OnClick; {$IFDEF JR_D5} property OnContextPopup; {$ENDIF} property OnDblClick; property OnDragDrop; property OnDragOver; property OnDropDown; property OnEndDock; property OnEndDrag; property OnMouseDown; property OnMouseEnter; property OnMouseLeave; property OnMouseMove; property OnMouseUp; property OnStartDock; property OnStartDrag; end; { TTBXCustomCheckBox } TTBXCustomCheckBox = class(TTBXTextObject) private FAllowGrayed: Boolean; FState: TCheckBoxState; FOnChange: TNotifyEvent; function GetChecked: Boolean; procedure CMDialogChar(var Message: TCMDialogChar); message CM_DIALOGCHAR; procedure CMDialogKey(var Message: TCMDialogKey); message CM_DIALOGKEY; procedure CNCommand(var Message: TWMCommand); message CN_COMMAND; procedure SetChecked(Value: Boolean); procedure SetState(Value: TCheckBoxState); procedure WMNCHitTest(var Message: TWMNCHitTest); message WM_NCHITTEST; protected procedure Click; override; procedure DoAdjustHeight(ACanvas: TCanvas; var NewHeight: Integer); override; procedure DoChange; virtual; procedure DoMouseEnter; override; procedure DoMouseLeave; override; function DoSetState(var NewState: TCheckBoxState): Boolean; virtual; function GetGlyphSize: Integer; function GetFocusRect(const R: TRect): TRect; override; function GetTextAlignment: TAlignment; override; function GetTextMargins: TRect; override; procedure Paint; override; procedure Toggle; virtual; property AllowGrayed: Boolean read FAllowGrayed write FAllowGrayed default False; property Checked: Boolean read GetChecked write SetChecked stored False; property SmartFocus default True; property State: TCheckBoxState read FState write SetState default cbUnchecked; property TabStop default True; property OnChange: TNotifyEvent read FOnChange write FOnChange; public constructor Create(AOwner: TComponent); override; end; TTBXCheckBox = class(TTBXCustomCheckBox) published property Action; {vb+} property Align; property Alignment; property AllowGrayed; property Anchors; property AutoSize; property BiDiMode; property Caption; property Checked; property Color; property Constraints; property DragCursor; property DragKind; property DragMode; property Enabled; property Font; property Margins; // property PaintOptions; property ParentBiDiMode; property ParentColor; property ParentFont; property ParentShowHint; property PopupMenu; property ShowAccelChar; property ShowHint; property SmartFocus; property State; property TabOrder; property TabStop; property Visible; property Wrapping; property OnChange; property OnClick; {$IFDEF JR_D5} property OnContextPopup; {$ENDIF} property OnDblClick; property OnDragDrop; property OnDragOver; property OnEndDock; property OnEndDrag; property OnMouseDown; property OnMouseEnter; property OnMouseLeave; property OnMouseMove; property OnMouseUp; property OnStartDock; property OnStartDrag; end; { TTBXCustomRadioButton } TTBXCustomRadioButton = class(TTBXTextObject) private FChecked: Boolean; FGroupIndex: Integer; FOnChange: TNotifyEvent; procedure SetChecked(Value: Boolean); procedure CMDialogChar(var Message: TCMDialogChar); message CM_DIALOGCHAR; procedure CNCommand(var Message: TWMCommand); message CN_COMMAND; procedure SetGroupIndex(Value: Integer); procedure TurnSiblingsOff; procedure WMNCHitTest(var Message: TWMNCHitTest); message WM_NCHITTEST; protected procedure Click; override; procedure DoAdjustHeight(ACanvas: TCanvas; var NewHeight: Integer); override; procedure DoChange; virtual; procedure DoMouseEnter; override; procedure DoMouseLeave; override; function DoSetChecked(var Value: Boolean): Boolean; virtual; function GetGlyphSize: Integer; function GetFocusRect(const R: TRect): TRect; override; function GetTextAlignment: TAlignment; override; function GetTextMargins: TRect; override; procedure Paint; override; property Checked: Boolean read FChecked write SetChecked default False; property GroupIndex: Integer read FGroupIndex write SetGroupIndex default 0; property SmartFocus default True; property TabStop default True; property OnChange: TNotifyEvent read FOnChange write FOnChange; public constructor Create(AOwner: TComponent); override; end; TTBXRadioButton = class(TTBXCustomRadioButton) published property Action; {vb+} property Align; property Alignment; property Anchors; property AutoSize; property BiDiMode; property Caption; property Checked; property Color; property Constraints; property DragCursor; property DragKind; property DragMode; property Enabled; property Font; property GroupIndex; property Margins; // property PaintOptions; property ParentBiDiMode; property ParentColor; property ParentFont; property ParentShowHint; property PopupMenu; property ShowAccelChar; property ShowHint; property SmartFocus; property TabOrder; property TabStop; property Visible; property Wrapping; property OnChange; property OnClick; {$IFDEF JR_D5} property OnContextPopup; {$ENDIF} property OnDblClick; property OnDragDrop; property OnDragOver; property OnEndDock; property OnEndDrag; property OnMouseDown; property OnMouseEnter; property OnMouseLeave; property OnMouseMove; property OnMouseUp; property OnStartDock; property OnStartDrag; end; { TTBXPageScroller } TTBXPageScrollerOrientation = (tpsoVertical, tpsoHorizontal); TTBXPageScrollerButtons = set of (tpsbPrev, tpsbNext); TTBXCustomPageScroller = class(TWinControl) private FAutoRangeCount: Integer; FAutoRange: Boolean; FAutoScroll: Boolean; FButtonSize: Integer; FMargin: Integer; FOrientation: TTBXPageScrollerOrientation; FPosition: Integer; FPosRange: Integer; FRange: Integer; FScrollDirection: Integer; FScrollCounter: Integer; FScrollPending: Boolean; FScrollTimer: TTimer; FUpdatingButtons: Boolean; FVisibleButtons: TTBXPageScrollerButtons; procedure CalcAutoRange; function IsRangeStored: Boolean; procedure ScrollTimerTimer(Sender: TObject); procedure SetButtonSize(Value: Integer); procedure SetAutoRange(Value: Boolean); procedure SetOrientation(Value: TTBXPageScrollerOrientation); procedure SetPosition(Value: Integer); procedure SetRange(Value: Integer); procedure StopScrolling; procedure ValidatePosition(var NewPos: Integer); procedure CMParentColorChanged(var Message: TMessage); message CM_PARENTCOLORCHANGED; procedure WMMouseMove(var Message: TWMMouseMove); message WM_MOUSEMOVE; procedure WMNCCalcSize(var Message: TWMNCCalcSize); message WM_NCCALCSIZE; procedure WMEraseBkgnd(var Message: TWmEraseBkgnd); message WM_ERASEBKGND; procedure WMNCHitTest(var Message: TWMNCHitTest); message WM_NCHITTEST; procedure WMNCLButtonDown(var Message: TWMNCLButtonDown); message WM_NCLBUTTONDOWN; procedure WMNCMouseLeave(var Message: TMessage); message $2A2 {WM_NCMOUSELEAVE}; procedure WMNCMouseMove(var Message: TWMNCMouseMove); message WM_NCMOUSEMOVE; procedure WMNCPaint(var Message: TMessage); message WM_NCPAINT; procedure WMSize(var Message: TWMSize); message WM_SIZE; protected procedure AdjustClientRect(var Rect: TRect); override; procedure AlignControls(AControl: TControl; var ARect: TRect); override; function AutoScrollEnabled: Boolean; virtual; procedure BeginScrolling(HitTest: Integer); function CalcClientArea: TRect; function CanAutoSize(var NewWidth, NewHeight: Integer): Boolean; override; procedure ConstrainedResize(var MinWidth, MinHeight, MaxWidth, MaxHeight: Integer); override; procedure CreateParams(var Params: TCreateParams); override; procedure DoSetRange(Value: Integer); virtual; procedure DrawNCArea(const DrawToDC: Boolean; const ADC: HDC; const Clip: HRGN); virtual; procedure HandleScrollTimer; virtual; procedure Loaded; override; procedure RecalcNCArea; procedure Resizing; virtual; procedure UpdateButtons; property AutoScroll: Boolean read FAutoScroll write FAutoScroll default True; property ButtonSize: Integer read FButtonSize write SetButtonSize default 10; property Orientation: TTBXPageScrollerOrientation read FOrientation write SetOrientation default tpsoVertical; property Position: Integer read FPosition write SetPosition default 0; property Margin: Integer read FMargin write FMargin default 0; property Range: Integer read FRange write SetRange stored IsRangeStored; public constructor Create(AOwner: TComponent); override; procedure DisableAutoRange; procedure EnableAutoRange; procedure ScrollToCenter(ARect: TRect); overload; procedure ScrollToCenter(AControl: TControl); overload; property AutoRange: Boolean read FAutoRange write SetAutoRange default False; end; TTBXPageScroller = class(TTBXCustomPageScroller) public property Position; published property Align; property Anchors; property AutoRange; property AutoScroll; property ButtonSize; property Color; property Constraints; property DockSite; property DragCursor; property DragKind; property DragMode; property DoubleBuffered; property Enabled; property Ctl3D; property Font; property Margin; property Orientation; property ParentBiDiMode; property ParentColor; property ParentCtl3D; property ParentFont; property ParentShowHint; property PopupMenu; property Range; property ShowHint; property TabOrder; property TabStop; property Visible; property OnCanResize; property OnClick; property OnConstrainedResize; {$IFDEF JR_D5} property OnContextPopup; {$ENDIF} property OnDblClick; property OnDockDrop; property OnDockOver; property OnDragDrop; property OnDragOver; property OnEndDock; property OnEndDrag; property OnEnter; property OnExit; property OnGetSiteInfo; property OnMouseDown; property OnMouseMove; property OnMouseUp; property OnMouseWheel; property OnMouseWheelDown; property OnMouseWheelUp; property OnResize; property OnStartDock; property OnStartDrag; property OnUnDock; end; implementation uses TB2Common, TBXUtils, SysUtils; type TWinControlAccess = class(TWinControl); TDockAccess = class(TTBXMultiDock); TTBDockableWindowAccess = class(TTBCustomDockableWindow); const { Constants for TTBXDockablePanel-specific registry values. Do not localize! } rvDockedWidth = 'DPDockedWidth'; rvDockedHeight = 'DPDockedHeight'; rvFloatingWidth = 'DPFloatingWidth'; rvFloatingHeight = 'DPFloatingHeight'; rvSplitWidth = 'DPSplitWidth'; rvSplitHeight = 'DPSplitHeight'; HT_TB2k_Border = 2000; HT_TB2k_Close = 2001; HT_TB2k_Caption = 2002; HT_TBX_SPLITRESIZELEFT = 86; HT_TBX_SPLITRESIZERIGHT = 87; HT_TBX_SPLITRESIZETOP = 88; HT_TBX_SPLITRESIZEBOTTOM = 89; DockedBorderSize = 2; ScrollDelay = 300; ScrollInterval = 75; var MouseTimer: TTimer = nil; MouseInObject: TTBXPanelObject = nil; ObjectCount: Integer = 0; procedure UpdateNCArea(Control: TWinControl; ViewType: Integer); var W, H: Integer; begin with Control do begin { Keep the client rect at the same position relative to screen } W := ClientWidth; H := ClientHeight; SetWindowPos(Handle, 0, 0, 0, 0, 0, SWP_FRAMECHANGED or SWP_NOACTIVATE or SWP_NOZORDER or SWP_NOREDRAW or SWP_NOMOVE or SWP_NOSIZE); W := W - ClientWidth; H := H - ClientHeight; if (W <> 0) or (H <> 0) then SetWindowPos(Handle, 0, Left - W div 2, Top - H div 2, Width + W, Height + H, SWP_FRAMECHANGED or SWP_NOACTIVATE or SWP_NOZORDER); RedrawWindow(Handle, nil, 0, RDW_FRAME or RDW_INVALIDATE or RDW_ERASE or RDW_UPDATENOW or RDW_ALLCHILDREN); end; end; function GetMinControlHeight(Control: TControl): Integer; begin if Control.Align = alClient then begin if Control is TTBXPanelObject then Result := TTBXPanelObject(Control).GetMinHeight else Result := Control.Constraints.MinHeight; end else Result := Control.Height; end; function GetMinControlWidth(Control: TControl): Integer; begin if Control.Align = alClient then begin if Control is TTBXPanelObject then Result := TTBXPanelObject(Control).GetMinWidth else Result := Control.Constraints.MinWidth; end else Result := Control.Width; end; function IsActivated(AWinControl: TWinControl): Boolean; var C: TWinControl; begin { Returns true if AWinControl contains a focused control } C := Screen.ActiveControl; Result := True; while C <> nil do if C = AWinControl then Exit else C := C.Parent; Result := False; end; procedure ApplyMargins(var R: TRect; const Margins: TTBXControlMargins); overload; begin with Margins do begin Inc(R.Left, Left); Inc(R.Top, Top); Dec(R.Right, Right); Dec(R.Bottom, Bottom); end; end; procedure ApplyMargins(var R: TRect; const Margins: TRect); overload; begin with Margins do begin Inc(R.Left, Left); Inc(R.Top, Top); Dec(R.Right, Right); Dec(R.Bottom, Bottom); end; end; procedure DrawFocusRect2(Canvas: TCanvas; const R: TRect); var DC: HDC; C1, C2: TColor; begin DC := Canvas.Handle; C1 := SetTextColor(DC, clBlack); C2 := SetBkColor(DC, clWhite); Canvas.DrawFocusRect(R); SetTextColor(DC, C1); SetBkColor(DC, C2); end; function GetRealAlignment(Control: TControl): TAlignment; const ReverseAlignment: array [TAlignment] of TAlignment = (taRightJustify, taLeftJustify, taCenter); begin Result := Control.GetControlsAlignment; if Control.UseRightToLeftAlignment then Result := ReverseAlignment[Result]; end; function CompareEffectiveDockPos(const Item1, Item2, ExtraData: Pointer): Integer; far; begin Result := TTBCustomDockableWindow(Item1).EffectiveDockPos - TTBCustomDockableWindow(Item2).EffectiveDockPos; end; function CompareDockPos(const Item1, Item2, ExtraData: Pointer): Integer; far; var P1, P2: Integer; begin P1 := TTBCustomDockableWindow(Item1).DockPos; P2 := TTBCustomDockableWindow(Item2).DockPos; if csLoading in TTBCustomDockableWindow(Item1).ComponentState then begin if P1 < 0 then P1 := MaxInt; if P2 < 0 then P2 := MaxInt; end; Result := P1 - P2; end; //----------------------------------------------------------------------------// { TTBXControlMargins } procedure TTBXControlMargins.Assign(Src: TPersistent); begin inherited; Modified; end; procedure TTBXControlMargins.Modified; begin if Assigned(FOnChange) then FOnChange(Self); end; procedure TTBXControlMargins.SetBottom(Value: Integer); begin if FBottom <> Value then begin FBottom := Value; Modified; end; end; procedure TTBXControlMargins.SetLeft(Value: Integer); begin if FLeft <> Value then begin FLeft := Value; Modified; end; end; procedure TTBXControlMargins.SetRight(Value: Integer); begin if FRight <> Value then begin FRight := Value; Modified; end; end; procedure TTBXControlMargins.SetTop(Value: Integer); begin if FTop <> Value then begin FTop := Value; Modified; end; end; //----------------------------------------------------------------------------// { TTBXMultiDock } function TTBXMultiDock.Accepts(ADockableWindow: TTBCustomDockableWindow): Boolean; begin Result := ADockableWindow is TTBXDockablePanel; end; procedure TTBXMultiDock.ArrangeToolbars; const DSGN_DROPZONESIZE = 16; type TPosRec = record Panel: TTBXDockablePanel; MinSize, MaxSize, Size, Pos: Integer; CanStretch: Boolean; end; var NewDockList: TList; PosData: array of TPosRec; LeftRight: Boolean; I, J, K, L, DragIndex, ResizeIndex, ForcedWidth: Integer; EmptySize, ClientW, ClientH, DockSize, TotalSize, TotalMinimumSize, TotalMaximumSize: Integer; {DragIndexPos: Integer;} {vb-} T: TTBXDockablePanel; S: TPoint; CurRowPixel, CurRowSize: Integer; StretchPanelCount: Integer; Stretching: Boolean; AccDelta, Acc: Extended; Delta, IntAcc: Integer; MinWidth, MaxWidth, EffectiveMinWidth, EffectiveMaxWidth: Integer; R: TRect; function IndexOfDraggingToolbar(const List: TList): Integer; {vb+} { Returns index of toolbar in List that's currently being dragged, or -1 } var I: Integer; begin for I := 0 to List.Count-1 do if TTBCustomDockableWindow(List[I]).DragMode then begin Result := I; Exit; end; Result := -1; end; procedure GetSizes(Panel: TTBXDockablePanel; out Size, MinSize, MaxSize: Integer); var Sz: TPoint; MinWidth, MinHeight, MaxWidth, MaxHeight: Integer; begin Panel.GetBaseSize(Sz); if LeftRight then begin Size := Panel.SplitHeight; end else begin Size := Panel.SplitWidth; end; MinWidth := 0; MaxWidth := 0; MinHeight := 0; MaxHeight := 0; Panel.ConstrainedResize(MinWidth, MinHeight, MaxWidth, MaxHeight); if not LeftRight then begin MinSize := MinWidth; MaxSize := MaxWidth end else begin MinSize := MinHeight; MaxSize := MaxHeight end; if MaxSize < MinSize then begin MaxSize := DockSize; if MaxSize < MinSize then MaxSize := MinSize; end; if Size < MinSize then Size := MinSize else if Size > MaxSize then Size := MaxSize; end; procedure GetMinMaxWidth(Panel: TTBXDockablePanel; out Min, Max: Integer); var MinWidth, MinHeight, MaxWidth, MaxHeight: Integer; begin MinWidth := 0; MaxWidth := 0; MinHeight := 0; MaxHeight := 0; Panel.ConstrainedResize(MinWidth, MinHeight, MaxWidth, MaxHeight); if LeftRight then begin Min := MinWidth; Max := MaxWidth end else begin Min := MinHeight; Max := MaxHeight end; end; begin if (DisableArrangeToolbars > 0) or (csLoading in ComponentState) then begin ArrangeToolbarsNeeded := True; Exit; end; NewDockList := nil; PosData := nil; DisableArrangeToolbars := DisableArrangeToolbars + 1; try LeftRight := Position in [dpLeft, dpRight]; if not HasVisibleToolbars then begin EmptySize := Ord(FixAlign); if csDesigning in ComponentState then EmptySize := 7; if not LeftRight then ChangeWidthHeight(Width, EmptySize) else ChangeWidthHeight(EmptySize, Height); Exit; end; ClientW := Width - NonClientWidth; if ClientW < 0 then ClientW := 0; ClientH := Height - NonClientHeight; if ClientH < 0 then ClientH := 0; if not LeftRight then DockSize := ClientW else DockSize := ClientH; { Leave some space for dropping other panels in design time } if csDesigning in ComponentState then Dec(DockSize, DSGN_DROPZONESIZE); if DockSize < 0 then DockSize := 0; for I := DockList.Count - 1 downto 0 do begin T := DockList[I]; if csDestroying in T.ComponentState then begin DockList.Delete(I); DockVisibleList.Remove(T); end; end; { always limit to one row } for I := 0 to DockList.Count - 1 do with TTBCustomDockableWindow(DockList[I]) do DockRow := 0; { Copy DockList to NewDockList, and ensure it is in correct ordering according to DockRow/DockPos } NewDockList := TList.Create; NewDockList.Count := DockList.Count; for I := 0 to NewDockList.Count - 1 do NewDockList[I] := DockList[I]; {I := NewDockList.IndexOf(DragToolbar); {vb-} I := IndexOfDraggingToolbar(NewDockList); {vb+} ListSortEx(NewDockList, CompareDockPos, nil); {DragIndex := NewDockList.IndexOf(DragToolbar); {vb-} DragIndex := IndexOfDraggingToolbar(NewDockList); {vb+} {if (I <> -1) and DragSplitting then {vb-} if (I <> -1) and TTBCustomDockableWindow(NewDockList[DragIndex]).DragSplitting then {vb+} begin { When splitting, don't allow the toolbar being dragged to change positions in the dock list } NewDockList.Move(DragIndex, I); DragIndex := I; end; ListSortEx(DockVisibleList, CompareDockPos, nil); { Create a temporary array that holds new position data for the toolbars and get size info } SetLength(PosData, 0); for I := 0 to NewDockList.Count - 1 do begin T := NewDockList[I]; if ToolbarVisibleOnDock(T) then begin SetLength(PosData, Length(PosData) + 1); with PosData[Length(PosData) - 1] do begin Panel := T as TTBXDockablePanel; Pos := Panel.DockPos; GetSizes(Panel, Size, MinSize, MaxSize{, OrigWidth}); end; end; end; { Update drag index... } if DragIndex >= 0 then for I := 0 to Length(PosData) - 1 do if NewDockList.IndexOf(PosData[I].Panel) = DragIndex then begin DragIndex := I; Break; end; { Count total sizes and set initial positions } {DragIndexPos := 0;} {vb-} TotalSize := 0; TotalMinimumSize := 0; TotalMaximumSize := 0; for I := 0 to Length(PosData) - 1 do with PosData[I] do begin {if I = DragIndex then DragIndexPos := Panel.DockPos;} {vb-} Pos := TotalSize; Inc(TotalSize, Size); Inc(TotalMinimumSize, MinSize); Inc(TotalMaximumSize, MaxSize); end; if DockSize <> TotalSize then begin begin { Proportionally stretch and shrink toolbars } if TotalMinimumSize >= DockSize then for I := 0 to Length(PosData) - 1 do PosData[I].Size := PosData[I].MinSize else if TotalMaximumSize <= DockSize then for I := 0 to Length(PosData) - 1 do PosData[I].Size := PosData[I].MaxSize else begin Delta := DockSize - TotalSize; StretchPanelCount := 0; Stretching := TotalSize < DockSize; // otherwise, shrinking for I := 0 to Length(PosData) - 1 do with PosData[I] do begin if Stretching then CanStretch := Size < MaxSize else CanStretch := Size > MinSize; if CanStretch then Inc(StretchPanelCount); end; Assert(StretchPanelCount > 0); while Delta <> 0 do begin Assert(StretchPanelCount <> 0); AccDelta := Delta / StretchPanelCount; Acc := 0; IntAcc := 0; for I := 0 to Length(PosData) - 1 do with PosData[I] do if CanStretch then begin Acc := Acc + AccDelta; Inc(Size, Round(Acc) - IntAcc); IntAcc := Round(Acc); end; TotalSize := 0; for I := 0 to Length(PosData) - 1 do with PosData[I] do begin if CanStretch then if Stretching then begin if Size > MaxSize then begin Size := MaxSize; CanStretch := False; Dec(StretchPanelCount); end; end else begin if Size < MinSize then begin Size := MinSize; CanStretch := False; Dec(StretchPanelCount); end; end; Inc(TotalSize, Size); end; Delta := DockSize - TotalSize; end; end; TotalSize := 0; for I := 0 to Length(PosData) - 1 do with PosData[I] do begin Pos := TotalSize; Inc(TotalSize, Size); end; end end; for I := 0 to NewDockList.Count - 1 do begin for J := 0 to Length(PosData) - 1 do with PosData[J] do begin if Panel = NewDockList[I] then begin Panel.EffectiveDockRowAccess := 0; Panel.EffectiveDockPosAccess := PosData[J].Pos; end; end; if CommitNewPositions then begin T := NewDockList[I]; T.DockRow := T.EffectiveDockRow; T.DockPos := T.EffectiveDockPos; DockList[I] := NewDockList[I]; end; end; ResizeIndex := -1; for I := 0 to Length(PosData) - 1 do with PosData[I] do if Panel is TTBXDockablePanel and Panel.IsResizing then begin ResizeIndex := I; Break; end; { Calculate the size of the dock } if ResizeIndex < 0 then begin CurRowSize := 0; for I := 0 to Length(PosData) - 1 do with PosData[I] do begin Panel.CurrentSize := Size; Panel.GetBaseSize(S); if LeftRight then K := S.X + Panel.CalcNCSizes.X else K := S.Y + Panel.CalcNCSizes.Y; if (DragIndex = I) and (Length(PosData) > 1) and (LastValidRowSize > 0) then K := 0; if K > CurRowSize then CurRowSize := K; end; end else begin EffectiveMinWidth := 0; EffectiveMaxWidth := 0; for I := 0 to Length(PosData) - 1 do begin GetMinMaxWidth(PosData[I].Panel, MinWidth, MaxWidth); if MinWidth > EffectiveMinWidth then EffectiveMinWidth := MinWidth; if (MaxWidth >= MinWidth) and (MaxWidth < EffectiveMaxWidth) then EffectiveMaxWidth := MaxWidth; end; if LeftRight then CurRowSize := PosData[ResizeIndex].Panel.Width else CurRowSize := PosData[ResizeIndex].Panel.Height; if (EffectiveMaxWidth > EffectiveMinWidth) and (CurRowSize > EffectiveMaxWidth) then CurRowSize := EffectiveMaxWidth; if CurRowSize < EffectiveMinWidth then CurRowSize := EffectiveMinWidth; end; if CurRowSize > 0 then LastValidRowSize := CurRowSize; { Now actually move the toolbars } for I := 0 to Length(PosData) - 1 do with PosData[I] do begin if LeftRight then R := Bounds(0, Pos, CurRowSize, Size) else R := Bounds(Pos, 0, Size, CurRowSize); Panel.BoundsRect := R; { This is to fix some weird behavior in design time } if csDesigning in ComponentState then with R do MoveWindow(Panel.Handle, Left, Top, Right - Left, Bottom - Top, True); end; { Set the size of the dock } if not LeftRight then ChangeWidthHeight(Width, CurRowSize + NonClientHeight) else ChangeWidthHeight(CurRowSize + NonClientWidth, Height); finally DisableArrangeToolbars := DisableArrangeToolbars - 1; ArrangeToolbarsNeeded := False; CommitNewPositions := False; SetLength(PosData, 0); NewDockList.Free; end; end; procedure TTBXMultiDock.Paint; var R: TRect; begin { Draw dotted border in design mode } if csDesigning in ComponentState then begin R := ClientRect; with Canvas do begin Pen.Style := psSolid; Pen.Color := clBtnHighlight; Brush.Color := clBtnHighlight; Brush.Style := bsFDiagonal; Rectangle(R.Left, R.Top, R.Right, R.Bottom); Pen.Style := psSolid; end; end; end; procedure TTBXMultiDock.ResizeVisiblePanels(NewSize: Integer); var I: Integer; begin BeginUpdate; try for I := 0 to DockVisibleList.Count - 1 do if Position in [dpLeft, dpRight] then TTBXDockablePanel(DockVisibleList[I]).DockedWidth := NewSize else TTBXDockablePanel(DockVisibleList[I]).DockedHeight := NewSize; finally EndUpdate; end; end; procedure TTBXMultiDock.ValidateInsert(AComponent: TComponent); begin if not (AComponent is TTBXDockablePanel) then raise EInvalidOperation.CreateFmt('Cannot insert %s into TTBXMultiDock', [AComponent.ClassName]); end; //----------------------------------------------------------------------------// { TTBXPanelObject } procedure TTBXPanelObject.CMEnabledChanged(var Message: TMessage); begin inherited; if not Enabled and FMouseInControl then begin FMouseInControl := False; RemoveMouseTimer; DoMouseLeave; Invalidate; Perform(WM_CANCELMODE, 0, 0); end; end; procedure TTBXPanelObject.CMParentColorChanged(var Message: TMessage); begin if Message.WParam = 0 then begin Message.WParam := 1; Message.LParam := GetEffectiveColor(Parent); end; inherited; Invalidate; end; constructor TTBXPanelObject.Create(AOwner: TComponent); begin inherited; ControlStyle := ControlStyle + [csAcceptsControls, csClickEvents, csDoubleClicks] - [csOpaque]; if MouseTimer = nil then begin MouseTimer := TTimer.Create(nil); MouseTimer.Enabled := False; MouseTimer.Interval := 125; end; Inc(ObjectCount); ParentColor := False; Color := clNone; AddThemeNotification(Self); end; procedure TTBXPanelObject.CreateParams(var Params: TCreateParams); begin inherited CreateParams(Params); if not (csDesigning in ComponentState) then with Params.WindowClass do style := style and not (CS_HREDRAW or CS_VREDRAW); // if cpoTransparent in PaintOptions then // Params.ExStyle := Params.ExStyle or WS_EX_TRANSPARENT; end; destructor TTBXPanelObject.Destroy; begin RemoveThemeNotification(Self); RemoveMouseTimer; Dec(ObjectCount); if ObjectCount = 0 then begin MouseTimer.Free; MouseTimer := nil; end; inherited; end; procedure TTBXPanelObject.DoMouseEnter; begin if Assigned(FOnMouseEnter) then FOnMouseEnter(Self); end; procedure TTBXPanelObject.DoMouseLeave; begin if Assigned(FOnMouseLeave) then FOnMouseLeave(Self); end; function TTBXPanelObject.GetMinHeight: Integer; begin Result := Height; end; function TTBXPanelObject.GetMinWidth: Integer; begin Result := Width; end; procedure TTBXPanelObject.KeyDown(var Key: Word; Shift: TShiftState); begin inherited; if SpaceAsClick and (Key = VK_SPACE) then begin FPushed := True; Invalidate; end; end; procedure TTBXPanelObject.KeyUp(var Key: Word; Shift: TShiftState); begin if SpaceAsClick and Pushed and (Key = VK_SPACE) then begin FPushed := False; Click; Invalidate; end; inherited; end; procedure TTBXPanelObject.MakeVisible; procedure HandleScroll(SW: TControl); begin if SW is TScrollingWinControl then TScrollingWinControl(SW).ScrollInView(Self) else if SW is TTBXCustomPageScroller then TTBXCustomPageScroller(SW).ScrollToCenter(Self) else if (Parent <> nil) and (Parent <> SW) then HandleScroll(Parent); end; begin HandleScroll(Parent); end; procedure TTBXPanelObject.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin if (Button = mbLeft) and not FPushed then begin FPushed := True; Invalidate; end; if Enabled then MouseEntered; if not SmartFocus and CanFocus then SetFocus else if SmartFocus and CanFocus and Assigned(Parent) and IsActivated(Parent) then begin FDisableScroll := True; SetFocus; FDisableScroll := False; end; inherited; end; procedure TTBXPanelObject.MouseEntered; begin if Enabled and not FMouseInControl then begin FMouseInControl := True; DoMouseEnter; end; end; procedure TTBXPanelObject.MouseLeft; begin if Enabled and FMouseInControl then begin FMouseInControl := False; RemoveMouseTimer; DoMouseLeave; Invalidate; end; end; procedure TTBXPanelObject.MouseMove(Shift: TShiftState; X, Y: Integer); var P: TPoint; DragTarget: TControl; begin P := ClientToScreen(Point(X, Y)); DragTarget := FindDragTarget(P, True); if (MouseInObject <> Self) and (DragTarget = Self) then begin if Assigned(MouseInObject) then MouseInObject.MouseLeft; MouseInObject := Self; MouseTimer.OnTimer := MouseTimerHandler; MouseTimer.Enabled := True; MouseEntered; end else if (DragTarget <> Self) and (Mouse.Capture = Handle) and FMouseInControl then begin MouseLeft; end; inherited; end; procedure TTBXPanelObject.MouseTimerHandler(Sender: TObject); var P: TPoint; begin GetCursorPos(P); if FindDragTarget(P, True) <> Self then MouseLeft; end; procedure TTBXPanelObject.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin FPushed := False; Invalidate; inherited; end; procedure TTBXPanelObject.RemoveMouseTimer; begin if MouseInObject = Self then begin MouseTimer.Enabled := False; MouseInObject := nil; end; end; procedure TTBXPanelObject.SetPaintOptions(Value: TControlPaintOptions); begin if Value <> FPaintOptions then begin FPaintOptions := Value; if cpoDoubleBuffered in Value then DoubleBuffered := True else DoubleBuffered := False; RecreateWnd; end; end; procedure TTBXPanelObject.TBMThemeChange(var Message); var R: TRect; begin if HandleAllocated then begin R := ClientRect; InvalidateRect(Handle, @R, True); end; end; procedure TTBXPanelObject.WMEraseBkgnd(var Message: TMessage); begin if not DoubleBuffered or (Message.wParam = Message.lParam) then begin if Color = clNone then DrawParentBackground(Self, TWMEraseBkgnd(Message).DC, ClientRect) else FillRectEx(TWMEraseBkgnd(Message).DC, ClientRect, Color); end; Message.Result := 1; end; procedure TTBXPanelObject.WMKillFocus(var Message: TMessage); begin FPushed := False; Invalidate; end; procedure TTBXPanelObject.WMSetFocus(var Message: TMessage); begin inherited; if not FDisableScroll then MakeVisible; Invalidate; end; //----------------------------------------------------------------------------// { TTBXDockablePanel } procedure TTBXCustomDockablePanel.AdjustClientRect(var Rect: TRect); begin inherited AdjustClientRect(Rect); if BorderSize <> 0 then InflateRect(Rect, -BorderSize, -BorderSize); end; procedure TTBXCustomDockablePanel.BeginDockedSizing(HitTest: Integer); var OrigPos, OldPos: TPoint; Msg: TMsg; DockRect, DragRect, OrigDragRect, OldDragRect: TRect; NCSizes: TPoint; EdgeRect, OldEdgeRect: TRect; ScreenDC: HDC; EraseEdgeRect, CommitResizing: Boolean; Form: TCustomForm; LeftRight: Boolean; function RectToScreen(const R: TRect): TRect; begin Result := R; Result.TopLeft := Parent.ClientToScreen(Result.TopLeft); Result.BottomRight := Parent.ClientToScreen(Result.BottomRight); end; function RectToClient(const R: TRect): TRect; begin Result := R; Result.TopLeft := Parent.ScreenToClient(Result.TopLeft); Result.BottomRight := Parent.ScreenToClient(Result.BottomRight); end; function GetEdgeRect(const R: TRect): TRect; begin Result := DockRect; case HitTest of HTLEFT: begin Result.Left := R.Left - 1; Result.Right := R.Left + 1 end; HTRIGHT: begin Result.Left := R.Right - 1; Result.Right := R.Right + 1 end; HTTOP: begin Result.Top := R.Top - 1; Result.Bottom := R.Top + 1 end; HTBOTTOM: begin Result.Top := R.Bottom - 1; Result.Bottom := R.Bottom + 1 end; end; end; procedure MouseMoved; var Pos: TPoint; NewWidth: Integer; NewHeight: Integer; begin GetCursorPos(Pos); if (Pos.X = OldPos.X) and (Pos.Y = OldPos.Y) then Exit; DragRect := OrigDragRect; case HitTest of HTLEFT: begin NewWidth := DragRect.Right - (DragRect.Left + Pos.X - OrigPos.X - 1); if DoDockedResizing(False, NewWidth) then DragRect.Left := DragRect.Right - NewWidth; end; HTRIGHT: begin NewWidth := (DragRect.Right + Pos.X - OrigPos.X) - DragRect.Left; if DoDockedResizing(False, NewWidth) then DragRect.Right := DragRect.Left + NewWidth; end; HTTOP: begin NewHeight := DragRect.Bottom - (DragRect.Top + Pos.Y - OrigPos.Y - 1); if DoDockedResizing(True, NewHeight) then DragRect.Top := DragRect.Bottom - NewHeight; end; HTBOTTOM: begin NewHeight := (DragRect.Bottom + Pos.Y - OrigPos.Y) - DragRect.Top; if DoDockedResizing(True, NewHeight) then DragRect.Bottom := DragRect.Top + NewHeight; end; end; if not CompareMem(@OldDragRect, @DragRect, SizeOf(TRect)) then begin if SmoothDockedResize then begin CurrentDock.BeginUpdate; if HitTest in [HTLEFT, HTRIGHT] then begin BlockSizeUpdate := True; DockedWidth := DragRect.Right - DragRect.Left - NCSizes.X; end else begin BlockSizeUpdate := True; DockedHeight := DragRect.Bottom - DragRect.Top - NCSizes.Y; end; BlockSizeUpdate := False; CurrentDock.EndUpdate; end else begin EdgeRect := GetEdgeRect(DragRect); DrawDraggingOutline(ScreenDC, EdgeRect, OldEdgeRect); OldEdgeRect := EdgeRect; EraseEdgeRect := True; end; OldPos := Pos; OldDragRect := DragRect; end; end; begin LeftRight := HitTest in [HTLEFT, HTRIGHT]; if DoBeginDockedResizing(HitTest in [HTTOP, HTBOTTOM]) then try SetCapture(Handle); ScreenDC := GetDC(0); OrigDragRect := RectToScreen(BoundsRect); DockRect := RectToScreen(CurrentDock.ClientRect); OldDragRect := Rect(0, 0, 0, 0); NCSizes := CalcNCSizes; DragRect := OrigDragRect; GetCursorPos(OrigPos); OldPos := OrigPos; FIsResizing := True; if not SmoothDockedResize then begin EdgeRect := GetEdgeRect(DragRect); DrawDraggingOutline(ScreenDC, EdgeRect, Rect(0, 0, 0, 0)); OldEdgeRect := EdgeRect; EraseEdgeRect := True; end else EraseEdgeRect := False; while GetCapture = Handle do begin case Integer(GetMessage(Msg, 0, 0, 0)) of -1: Break; 0: begin PostQuitMessage(Msg.WParam); Break; end; end; case Msg.Message of WM_KEYDOWN, WM_KEYUP: if Msg.WParam = VK_ESCAPE then Break; WM_MOUSEMOVE: MouseMoved; WM_LBUTTONDOWN, WM_LBUTTONDBLCLK:Break; WM_LBUTTONUP: Break; WM_RBUTTONDOWN..WM_MBUTTONDBLCLK:; else TranslateMessage(Msg); DispatchMessage(Msg); end; end; finally if GetCapture = Handle then ReleaseCapture; CommitResizing := DoEndDockedResizing(HitTest in [HTTOP, HTBOTTOM]); if EraseEdgeRect then begin DrawDraggingOutline(ScreenDC, Rect(0, 0, 0, 0), OldEdgeRect); if CommitResizing and not IsRectEmpty(OldDragRect) then with OldDragRect do begin BlockSizeUpdate := True; if LeftRight then DockedWidth := Right - Left - NCSizes.X else DockedHeight := Bottom - Top - NCSizes.Y; BlockSizeUpdate := False; end; end else if not CommitResizing then begin BlockSizeUpdate := True; BoundsRect := RectToClient(OrigDragRect); BlockSizeUpdate := False; end; ReleaseDC(0, ScreenDC); FIsResizing := False; if csDesigning in ComponentState then begin Form := GetParentForm(Self); if (Form <> nil) and (Form.Designer <> nil) then Form.Designer.Modified; end; end; end; procedure TTBXCustomDockablePanel.BeginSplitResizing(HitTest: Integer); type TPosRec = record Panel: TTBXDockablePanel; OrigPos, OrigSize, OrigWidth, Pos, Size, MinSize, MaxSize: Integer; end; var Dock: TDockAccess; PosData: array of TPosRec; I: Integer; LeftRight, Smooth, CommitResizing: Boolean; DockSize, TotalSize, TotalMinSize, TotalMaxSize: Integer; OrigCursorPos, OldCursorPos: TPoint; Msg: TMsg; EffectiveIndex: Integer; {EffectivePanel: TTBXDockablePanel;} {vb-} EffectivePanel: TTBXCustomDockablePanel; {vb+} PanelRect, DockRect, EdgeRect, OrigEdgeRect, OldEdgeRect: TRect; EdgePosition: TTBDockPosition; ScreenDC: HDC; EraseEdgeRect: Boolean; Form: TCustomForm; Delta: Integer; procedure GetSizes(Panel: TTBXDockablePanel; out Size, MinSize, MaxSize, W: Integer); var Sz: TPoint; MinWidth, MinHeight, MaxWidth, MaxHeight: Integer; begin Panel.GetBaseSize(Sz); if not LeftRight then begin Size := Panel.Width; W := Panel.Height; end else begin Size := Panel.Height; W := Panel.Width; end; MinWidth := 0; MaxWidth := 0; MinHeight := 0; MaxHeight := 0; Panel.ConstrainedResize(MinWidth, MinHeight, MaxWidth, MaxHeight); if not LeftRight then begin MinSize := MinWidth; MaxSize := MaxWidth; end else begin MinSize := MinHeight; MaxSize := MaxHeight end; if MaxSize < MinSize then begin MaxSize := DockSize; if MaxSize < MinSize then MaxSize := MinSize; end; if Size < MinSize then Size := MinSize else if Size > MaxSize then Size := MaxSize; end; procedure BlockSizeUpdates(DoBlock: Boolean); var I: Integer; begin for I := 0 to Length(PosData) - 1 do with PosData[I].Panel do BlockSizeUpdate := DoBlock; end; procedure SetSizes(RestoreOriginal: Boolean = False); var I: Integer; R: TRect; begin Dock.BeginUpdate; BlockSizeUpdates(True); for I := 0 to Length(PosData) - 1 do with PosData[I] do begin if LeftRight then begin if RestoreOriginal then R := Bounds(0, OrigPos, OrigWidth, OrigSize) else R := Bounds(0, Pos, OrigWidth, Size); end else begin if RestoreOriginal then R := Bounds(OrigPos, 0, OrigSize, OrigWidth) else R := Bounds(Pos, 0, Size, OrigWidth); end; if LeftRight then Panel.SplitHeight := Size else Panel.SplitWidth := Size; Panel.BoundsRect := R; { This is to fix some weird behavior in design time } if csDesigning in ComponentState then with R do MoveWindow(Panel.Handle, Left, Top, Right - Left, Bottom - Top, True); end; BlockSizeUpdates(False); Dock.EndUpdate; end; function GetEdgeRect(R: TRect): TRect; begin Result := R; case EdgePosition of dpRight: begin Result.Left := Result.Right - 1; Inc(Result.Right); end; dpBottom: begin Result.Top := Result.Bottom - 1; Inc(Result.Bottom); end; end; end; function RectToScreen(const R: TRect): TRect; begin Result := R; Result.TopLeft := Parent.ClientToScreen(Result.TopLeft); Result.BottomRight := Parent.ClientToScreen(Result.BottomRight); end; function RectToClient(const R: TRect): TRect; begin Result := R; Result.TopLeft := Parent.ScreenToClient(Result.TopLeft); Result.BottomRight := Parent.ScreenToClient(Result.BottomRight); end; procedure MouseMoved; var CursorPos: TPoint; I, P, Acc: Integer; begin GetCursorPos(CursorPos); if (CursorPos.X = OldCursorPos.X) and (CursorPos.Y = OldCursorPos.Y) then Exit; case EdgePosition of dpRight: Delta := CursorPos.X - OrigCursorPos.X; dpBottom: Delta := CursorPos.Y - OrigCursorPos.Y; end; if Delta = 0 then Exit; for I := 0 to Length(PosData) - 1 do with PosData[I] do begin Pos := OrigPos; Size := OrigSize; end; Acc := Delta; for I := EffectiveIndex downto 0 do with PosData[I] do begin Inc(Size, Acc); Acc := 0; if Size > MaxSize then begin Acc := Size - MaxSize; Size := MaxSize; end else if Size < MinSize then begin Acc := Size - MinSize; Size := MinSize; end; if Acc = 0 then Break; end; if Acc <> 0 then Dec(Delta, Acc); Acc := Delta; for I := EffectiveIndex + 1 to Length(PosData) - 1 do with PosData[I] do begin Dec(Size, Acc); Acc := 0; if Size > MaxSize then begin Acc := MaxSize - Size; Size := MaxSize; end else if Size < MinSize then begin Acc := MinSize - Size; Size := MinSize; end; if Acc = 0 then Break; end; if Acc <> 0 then begin Dec(Delta, Acc); for I := 0 to EffectiveIndex do with PosData[I] do Size := OrigSize; Acc := Delta; for I := EffectiveIndex downto 0 do with PosData[I] do begin Inc(Size, Acc); Acc := 0; if Size > MaxSize then begin Acc := Size - MaxSize; Size := MaxSize; end else if Size < MinSize then begin Acc := Size - MinSize; Size := MinSize; end; if Acc = 0 then Break; end; end; P := 0; for I := 0 to Length(PosData) - 1 do with PosData[I] do begin Pos := P; Inc(P, Size); end; if Smooth then SetSizes else begin EdgeRect := DockRect; if LeftRight then begin Inc(EdgeRect.Top, PosData[EffectiveIndex + 1].Pos - 1); EdgeRect.Bottom := EdgeRect.Top + 2; end else begin Inc(EdgeRect.Left, PosData[EffectiveIndex + 1].Pos - 1); EdgeRect.Right := EdgeRect.Left + 2; end; DrawDraggingOutline(ScreenDC, EdgeRect, OldEdgeRect); EraseEdgeRect := True; end; OldCursorPos := CursorPos; OldEdgeRect := EdgeRect; end; begin if not (CurrentDock is TTBXMultiDock) then Exit; Dock := TDockAccess(CurrentDock); SetLength(PosData, Dock.DockVisibleList.Count); for I := 0 to Dock.DockVisibleList.Count - 1 do with PosData[I] do begin { only docks with TTBXDockablePanels can be resized } if not (TTBCustomDockableWindow(Dock.DockVisibleList[I]) is TTBXDockablePanel) then Exit; Panel := TTBXDockablePanel(Dock.DockVisibleList[I]); end; LeftRight := Dock.Position in [dpLeft, dpRight]; if not LeftRight then DockSize := Dock.Width - Dock.NonClientWidth else DockSize := Dock.Height - Dock.NonClientHeight; if DockSize < 0 then DockSize := 0; { See if we can actually resize anything } TotalSize := 0; TotalMinSize := 0; TotalMaxSize := 0; for I := 0 to Length(PosData) - 1 do with PosData[I] do begin GetSizes(Panel, Size, MinSize, MaxSize, OrigWidth); OrigSize := Size; OrigPos := TotalSize; Pos := OrigPos; Inc(TotalSize, Size); Inc(TotalMinSize, MinSize); Inc(TotalMaxSize, MaxSize); end; if (TotalMinSize > DockSize) or (TotalMaxSize < DockSize) then Exit; { Get effective edge and panel } case HitTest of HT_TBX_SPLITRESIZETOP: EdgePosition := dpTop; HT_TBX_SPLITRESIZEBOTTOM: EdgePosition := dpBottom; HT_TBX_SPLITRESIZELEFT: EdgePosition := dpLeft; else EdgePosition := dpRight; end; Smooth := True; EffectivePanel := Self; for I := 0 to Length(PosData) - 1 do with PosData[I] do begin if not Panel.SmoothDockedResize then Smooth := False; if Panel = Self then begin EffectiveIndex := I; if EdgePosition in [dpLeft, dpTop] then begin Assert(I > 0); EffectivePanel := PosData[I - 1].Panel; if EdgePosition = dpLeft then EdgePosition := dpRight else EdgePosition := dpBottom; Dec(EffectiveIndex); end; end; end; try SetCapture(Handle); ScreenDC := GetDC(0); with EffectivePanel do PanelRect := RectToScreen(BoundsRect); DockRect := RectToScreen(Dock.ClientRect); GetCursorPos(OrigCursorPos); OldCursorPos := OrigCursorPos; OrigEdgeRect := GetEdgeRect(PanelRect); OldEdgeRect := Rect(0, 0, 0, 0); EdgeRect := OrigEdgeRect; FIsSplitting := True; if not Smooth then begin DrawDraggingOutline(ScreenDC, EdgeRect, Rect(0, 0, 0, 0)); OldEdgeRect := EdgeRect; EraseEdgeRect := True; end else EraseEdgeRect := False; while GetCapture = Handle do begin case Integer(GetMessage(Msg, 0, 0, 0)) of -1: Break; 0: begin PostQuitMessage(Msg.WParam); Break; end; end; case Msg.Message of WM_KEYDOWN, WM_KEYUP: if Msg.WParam = VK_ESCAPE then Break; WM_MOUSEMOVE: MouseMoved; WM_LBUTTONDOWN, WM_LBUTTONDBLCLK:Break; WM_LBUTTONUP: Break; WM_RBUTTONDOWN..WM_MBUTTONDBLCLK:; else TranslateMessage(Msg); DispatchMessage(Msg); end; end; finally if GetCapture = Handle then ReleaseCapture; CommitResizing := True; if EraseEdgeRect then begin DrawDraggingOutline(ScreenDC, Rect(0, 0, 0, 0), OldEdgeRect); if CommitResizing then SetSizes; end else if not CommitResizing then SetSizes(True); ReleaseDC(0, ScreenDC); FIsSplitting := False; if csDesigning in ComponentState then begin Form := GetParentForm(Self); if (Form <> nil) and (Form.Designer <> nil) then Form.Designer.Modified; end; end; end; function TTBXCustomDockablePanel.CalcNCSizes: TPoint; begin if not Docked then begin Result.X := 0; Result.Y := 0; end else begin Result.X := DockedBorderSize * 2; Result.Y := DockedBorderSize * 2; if ShowCaptionWhenDocked then if IsVertCaption then Inc(Result.X, GetSystemMetrics(SM_CYSMCAPTION)) else Inc(Result.Y, GetSystemMetrics(SM_CYSMCAPTION)); end; end; function TTBXCustomDockablePanel.CalcSize(ADock: TTBDock): TPoint; begin if Assigned(ADock) then begin if ADock.Position in [dpLeft, dpRight] then begin Result.X := FDockedWidth; Result.Y := ADock.ClientHeight - CalcNCSizes.Y; end else begin Result.X := ADock.ClientWidth - CalcNCSizes.X; Result.Y := FDockedHeight; end; end else begin { if floating width and height are yet undefined, copy them from docked width and height } if FFloatingWidth = 0 then begin if Docked and (CurrentDock.Position in [dpTop, dpBottom]) then FFloatingWidth := Width {CurrentDock.ClientWidth} - CalcNCSizes.X else FFloatingWidth := FDockedWidth; end; if FFloatingHeight = 0 then begin if Docked and (CurrentDock.Position in [dpLeft, dpRight]) then FFloatingHeight := {CurrentDock.ClientHeight} Height - CalcNCSizes.Y else FFloatingHeight := FDockedHeight; end; Result.X := FFloatingWidth; Result.Y := FFloatingHeight; end; end; function TTBXCustomDockablePanel.CanAutoSize(var NewWidth, NewHeight: Integer): Boolean; begin Result := True; end; function TTBXCustomDockablePanel.CanDockTo(ADock: TTBDock): Boolean; begin Result := inherited CanDockTo(ADock); if Result then begin if ADock is TTBXMultiDock then begin Result := dkMultiDock in SupportedDocks; end else begin Result := dkStandardDock in SupportedDocks;; end; end; end; function TTBXCustomDockablePanel.CanSplitResize(EdgePosition: TTBDockPosition): Boolean; var Dock: TDockAccess; begin Result := Docked and (CurrentDock is TTBXMultiDock) and HandleAllocated; if not Result then Exit; Dock := TDockAccess(CurrentDock); ListSortEx(Dock.DockVisibleList, CompareEffectiveDockPos, nil); if Dock.Position in [dpLeft, dpRight] then begin case EdgePosition of dpTop: Result := EffectiveDockPos > 0; dpBottom: Result := Dock.DockVisibleList.Last <> Self; else Result := False; end; end else begin case EdgePosition of dpLeft: Result := EffectiveDockPos > 0; dpRight: Result := Dock.DockVisibleList.Last <> Self; else Result := False; end; end; end; procedure TTBXCustomDockablePanel.CMColorChanged(var Message: TMessage); begin UpdateEffectiveColor; Brush.Color := Color; 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; Invalidate; UpdateChildColors; end; procedure TTBXCustomDockablePanel.CMControlChange(var Message: TCMControlChange); begin inherited; if Message.Inserting and (Color = clNone) then Message.Control.Perform(CM_PARENTCOLORCHANGED, 1, EffectiveColor); end; procedure TTBXCustomDockablePanel.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; procedure TTBXCustomDockablePanel.ConstrainedResize(var MinWidth, MinHeight, MaxWidth, MaxHeight: Integer); var Sz: TPoint; begin Sz := CalcNCSizes; if MinClientWidth > 0 then MinWidth := MinClientWidth + Sz.X; if MinClientHeight > 0 then MinHeight := MinClientHeight + Sz.Y; if MaxClientWidth > 0 then MaxWidth := MaxClientWidth + Sz.X; if MaxClientHeight > 0 then MaxHeight := MaxClientHeight + Sz.Y; end; constructor TTBXCustomDockablePanel.Create(AOwner: TComponent); begin inherited; FMinClientWidth := 32; FMinClientHeight := 32; FDockedWidth := 128; FDockedHeight := 128; FHorzResizeCursor := crSizeWE; {vb+} FHorzSplitCursor := crHSplit; {vb+} FVertResizeCursor := crSizeNS; {vb+} FVertSplitCursor := crVSplit; {vb+} CloseButtonWhenDocked := True; DblClickUndock := False; FShowCaptionWhenDocked := True; FSmoothDockedResize := True; BlockSizeUpdate := True; SetBounds(Left, Top, 128, 128); BlockSizeUpdate := False; FullSize := True; Color := clNone; AddThemeNotification(Self); SupportedDocks := [dkStandardDock, dkMultiDock]; end; destructor TTBXCustomDockablePanel.Destroy; begin RemoveThemeNotification(Self); inherited; end; function TTBXCustomDockablePanel.DoArrange(CanMoveControls: Boolean; PreviousDockType: TTBDockType; NewFloating: Boolean; NewDock: TTBDock): TPoint; begin Result := CalcSize(NewDock); end; function TTBXCustomDockablePanel.DoBeginDockedResizing(Vertical: Boolean): Boolean; var Sz: Integer; begin Result := True; if Vertical then Sz := Height else Sz := Width; if Assigned(FOnDockedResizing) then FOnDockedResizing(Self, Vertical, Sz, rsBeginResizing, Result); if Result then if Vertical then Height := Sz else Width := Sz; end; function TTBXCustomDockablePanel.DoDockedResizing(Vertical: Boolean; var NewSize: Integer): Boolean; const MIN_PARENT_CLIENT_SIZE = 32; var NCSizes: TPoint; CW, CH: Integer; DockParent: TWinControl; ClientSize: TPoint; begin NCSizes := CalcNCSizes; DockParent := Parent.Parent; ClientSize := GetClientSizeEx(DockParent); Assert(DockParent <> nil); if not Vertical then begin CW := ClientSize.X - MIN_PARENT_CLIENT_SIZE + Width; if NewSize > CW then NewSize := CW; CW := NewSize - NCSizes.X; if CW < MinClientWidth then CW := MinClientWidth else if (MaxClientWidth > MinClientWidth) and (CW > MaxClientWidth) then CW := MaxClientWidth; NewSize := CW + NCSizes.X; end else begin CH := ClientSize.Y - MIN_PARENT_CLIENT_SIZE + Height; if NewSize > CH then NewSize := CH; CH := NewSize - NCSizes.Y; if CH < MinClientHeight then CH := MinClientHeight else if (MaxClientHeight > MinClientHeight) and (CH > MaxClientHeight) then CH := MaxClientHeight; NewSize := CH + NCSizes.Y; end; Result := True; if Assigned(FOnDockedResizing) then FOnDockedResizing(Self, Vertical, NewSize, rsResizing, Result); end; function TTBXCustomDockablePanel.DoEndDockedResizing(Vertical: Boolean): Boolean; var Sz: Integer; begin Result := True; if Vertical then Sz := Height else Sz := Width; if Assigned(FOnDockedResizing) then FOnDockedResizing(Self, Vertical, Sz, rsEndResizing, Result); if Result then if Vertical then Height := Sz else Width := Sz; end; procedure TTBXCustomDockablePanel.DrawNCArea(const DrawToDC: Boolean; const ADC: HDC; const Clip: HRGN); var DC: HDC; R, CR: TRect; ACanvas: TCanvas; Sz: Integer; DockPanelInfo: TTBXDockPanelInfo; S: string; begin if not Docked or not HandleAllocated then Exit; if not DrawToDC then DC := GetWindowDC(Handle) else DC := ADC; Assert(DC <> 0, 'TTBXToolWindow.DrawNCArea Error'); try GetDockPanelInfo(DockPanelInfo); GetWindowRect(Handle, R); OffsetRect(R, -R.Left, -R.Top); if not DrawToDC then begin SelectNCUpdateRgn(Handle, DC, Clip); CR := R; with DockPanelInfo.BorderSize, CR do begin InflateRect(CR, -X, -Y); if DockPanelInfo.ShowCaption then begin Sz := GetSystemMetrics(SM_CYSMCAPTION); if DockPanelInfo.IsVertical then Inc(Top, Sz) else Inc(Left, Sz); end; ExcludeClipRect(DC, Left, Top, Right, Bottom); end; end; S := Caption; DockPanelInfo.Caption := PChar(S); ACanvas := TCanvas.Create; try ACanvas.Handle := DC; ACanvas.Brush.Color := EffectiveColor; CurrentTheme.PaintDockPanelNCArea(ACanvas, R, DockPanelInfo); finally ACanvas.Handle := 0; ACanvas.Free; end; finally if not DrawToDC then ReleaseDC(Handle, DC); end; end; procedure TTBXCustomDockablePanel.GetBaseSize(var ASize: TPoint); begin ASize := CalcSize(CurrentDock); end; function TTBXCustomDockablePanel.GetDockedCloseButtonRect(LeftRight: Boolean): TRect; var X, Y, Z: Integer; begin Z := GetSystemMetrics(SM_CYSMCAPTION) - 1; if LeftRight or not IsVertCaption then begin X := (ClientWidth + DockedBorderSize) - Z; Y := DockedBorderSize; end else begin X := DockedBorderSize; Y := ClientHeight + DockedBorderSize - Z; end; Result := Bounds(X, Y, Z, Z); end; procedure TTBXCustomDockablePanel.GetDockPanelInfo(out DockPanelInfo: TTBXDockPanelInfo); begin FillChar(DockPanelInfo, SizeOf(DockPanelInfo), 0); DockPanelInfo.WindowHandle := WindowHandle; DockPanelInfo.ViewType := GetViewType; if CurrentDock <> nil then DockPanelInfo.IsVertical := not IsVertCaption; DockPanelInfo.AllowDrag := CurrentDock.AllowDrag; DockPanelInfo.BorderStyle := BorderStyle; CurrentTheme.GetViewBorder(DockPanelInfo.ViewType, DockPanelInfo.BorderSize); DockPanelInfo.ClientWidth := ClientWidth; DockPanelInfo.ClientHeight := ClientHeight; DockPanelInfo.ShowCaption := ShowCaptionWhenDocked; DockPanelInfo.EffectiveColor := EffectiveColor; if ShowCaptionWhenDocked and CloseButtonWhenDocked then begin DockPanelInfo.CloseButtonState := CDBS_VISIBLE; if CloseButtonDown then DockPanelInfo.CloseButtonState := DockPanelInfo.CloseButtonState or CDBS_PRESSED; if CloseButtonHover then DockPanelInfo.CloseButtonState := DockPanelInfo.CloseButtonState or CDBS_HOT; end; end; function TTBXCustomDockablePanel.GetFloatingBorderSize: TPoint; begin CurrentTheme.GetViewBorder(GetViewType or DPVT_FLOATING, Result); end; function TTBXCustomDockablePanel.GetFloatingWindowParentClass: TTBFloatingWindowParentClass; begin Result := TTBXFloatingWindowParent; end; procedure TTBXCustomDockablePanel.GetMinMaxSize(var AMinClientWidth, AMinClientHeight, AMaxClientWidth, AMaxClientHeight: Integer); begin AMinClientWidth := FMinClientWidth; AMinClientHeight := FMinClientHeight; AMaxClientWidth := FMaxClientWidth; AMaxClientHeight := FMaxClientHeight; end; function TTBXCustomDockablePanel.GetViewType: Integer; begin Result := DPVT_NORMAL; if Floating then Result := Result or DPVT_FLOATING; if Resizable then Result := Result or DPVT_RESIZABLE; end; function TTBXCustomDockablePanel.IsVertCaption: Boolean; begin case CaptionRotation of dpcrAlwaysHorz: Result := False; dpcrAlwaysVert: Result := Docked; else // dpcrAuto: Result := Docked and (CurrentDock.Position in [dpTop, dpBottom]); end; end; procedure TTBXCustomDockablePanel.Loaded; begin inherited; UpdateChildColors; end; procedure TTBXCustomDockablePanel.Paint; begin if csDesigning in ComponentState then with Canvas do begin Pen.Style := psDot; Pen.Color := clBtnShadow; Brush.Style := bsClear; with ClientRect do Rectangle(Left, Top, Right, Bottom); Pen.Style := psSolid; end; end; procedure TTBXCustomDockablePanel.ReadPositionData(const Data: TTBReadPositionData); begin with Data do begin FDockedWidth := ReadIntProc(Name, rvDockedWidth, FDockedWidth, ExtraData); FDockedHeight := ReadIntProc(Name, rvDockedHeight, FDockedHeight, ExtraData); FFloatingWidth := ReadIntProc(Name, rvFloatingWidth, FFloatingWidth, ExtraData); FFloatingHeight := ReadIntProc(Name, rvFloatingHeight, FFloatingHeight, ExtraData); FSplitWidth := ReadIntProc(Name, rvSplitWidth, FSplitWidth, ExtraData); FSplitHeight := ReadIntProc(Name, rvSplitHeight, FSplitHeight, ExtraData); end; end; procedure TTBXCustomDockablePanel.SetBorderSize(Value: Integer); begin if FBorderSize <> Value then begin FBorderSize := Value; Realign; end; end; procedure TTBXCustomDockablePanel.SetBounds(ALeft, ATop, AWidth, AHeight: Integer); begin inherited SetBounds(ALeft, ATop, AWidth, AHeight); end; procedure TTBXCustomDockablePanel.SetCaptionRotation(Value: TDPCaptionRotation); begin if FCaptionRotation <> Value then begin FCaptionRotation := Value; if Docked and HandleAllocated then SetWindowPos(Handle, 0, 0, 0, 0, 0, SWP_FRAMECHANGED or SWP_NOACTIVATE or SWP_NOMOVE or SWP_NOSIZE or SWP_NOZORDER); end; end; procedure TTBXCustomDockablePanel.SetDockedHeight(Value: Integer); begin if Value < MinClientHeight then Value := MinClientHeight; if Value <> FDockedHeight then begin FDockedHeight := Value; if Docked and (CurrentDock.Position in [dpTop, dpBottom]) then begin BlockSizeUpdate := True; Height := Value + CalcNCSizes.Y; BlockSizeUpdate := False; end; end; end; procedure TTBXCustomDockablePanel.SetDockedWidth(Value: Integer); begin if Value < MinClientWidth then Value := MinClientWidth; if Value <> FDockedWidth then begin FDockedWidth := Value; if Docked and (CurrentDock.Position in [dpLeft, dpRight]) then begin BlockSizeUpdate := True; Width := Value + CalcNCSizes.X; BlockSizeUpdate := False; end; end; end; procedure TTBXCustomDockablePanel.SetFloatingHeight(Value: Integer); begin { FloatingHeight (and floating width) can be set to 0 while panel is docked. This will force to restore floating dimensions from docked size } if Value < 0 then Value := 0; if not Docked and (Value < MinClientHeight) then Value := MinClientHeight; if Value <> FFloatingHeight then begin FFloatingHeight := Value; if not Docked then begin BlockSizeUpdate := True; Height := Value + CalcNCSizes.Y; BlockSizeUpdate := False; end; end; end; procedure TTBXCustomDockablePanel.SetFloatingWidth(Value: Integer); begin { See comment for TTBXDockablePanel.SetFloatingHeight } if Value < 0 then Value := 0; if not Docked and (Value < MinClientWidth) then Value := MinClientWidth; if Value <> FFloatingWidth then begin FFloatingWidth := Value; if not Docked then begin BlockSizeUpdate := True; Width := Value + CalcNCSizes.X; BlockSizeUpdate := False; end; end; end; procedure TTBXCustomDockablePanel.SetMinClientHeight(Value: Integer); begin if Value < 8 then Value := 8; FMinClientHeight := Value; end; procedure TTBXCustomDockablePanel.SetMinClientWidth(Value: Integer); begin if Value < 8 then Value := 8; FMinClientWidth := Value; end; procedure TTBXCustomDockablePanel.SetParent(AParent: TWinControl); begin inherited; if AParent is TTBXFloatingWindowParent then TTBXFloatingWindowParent(AParent).SnapDistance := SnapDistance; end; procedure TTBXCustomDockablePanel.SetShowCaptionWhenDocked(Value: Boolean); begin if FShowCaptionWhenDocked <> Value then begin FShowCaptionWhenDocked := Value; if Docked then begin if HandleAllocated then SetWindowPos(Handle, 0, 0, 0, 0, 0, SWP_FRAMECHANGED or SWP_NOACTIVATE or SWP_NOMOVE or SWP_NOSIZE or SWP_NOZORDER); end; end; end; procedure TTBXCustomDockablePanel.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 TTBXCustomDockablePanel.SetSplitHeight(Value: Integer); begin if Value < 0 then Value := 0; if FSplitHeight <> Value then begin FSplitHeight := Value; if Docked and (CurrentDock.Position in [dpLeft, dpRight]) and (CurrentDock is TTBXMultiDock) then CurrentDock.ArrangeToolbars; end; end; procedure TTBXCustomDockablePanel.SetSplitWidth(Value: Integer); begin if Value < 0 then Value := 0; if FSplitWidth <> Value then begin FSplitWidth := Value; if Docked and (CurrentDock.Position in [dpTop, dpBottom]) and (CurrentDock is TTBXMultiDock) then CurrentDock.ArrangeToolbars; end; end; procedure TTBXCustomDockablePanel.SizeChanging(const AWidth, AHeight: Integer); begin if not BlockSizeUpdate then begin if Docked and (CurrentDock.Position in [dpLeft, dpRight]) then FDockedWidth := AWidth - CalcNCSizes.X else if Floating then FFloatingWidth := AWidth - CalcNCSizes.X; if Docked and (CurrentDock.Position in [dpTop, dpBottom]) then FDockedHeight := AHeight - CalcNCSizes.Y else if Floating then FFloatingHeight := AHeight - CalcNCSizes.Y; end; end; procedure TTBXCustomDockablePanel.TBMGetEffectiveColor(var Message: TMessage); begin Message.WParam := EffectiveColor; Message.Result := 1; end; procedure TTBXCustomDockablePanel.TBMGetViewType(var Message: TMessage); begin Message.Result := GetViewType; end; procedure TTBXCustomDockablePanel.TBMThemeChange(var Message: TMessage); var M: TMessage; begin case Message.WParam of TSC_BEFOREVIEWCHANGE: BeginUpdate; TSC_AFTERVIEWCHANGE: begin EndUpdate; UpdateEffectiveColor; if HandleAllocated and not (csDestroying in ComponentState) and (Parent is TTBXFloatingWindowParent) then UpdateNCArea(TTBXFloatingWindowParent(Parent), GetViewType) else UpdateNCArea(Self, GetViewType); Invalidate; M.Msg := CM_PARENTCOLORCHANGED; M.WParam := 1; M.LParam := EffectiveColor; M.Result := 0; Broadcast(M); end; end; end; procedure TTBXCustomDockablePanel.UpdateChildColors; var M: TMessage; begin M.Msg := CM_PARENTCOLORCHANGED; M.WParam := 1; M.LParam := EffectiveColor; M.Result := 0; Broadcast(M); end; procedure TTBXCustomDockablePanel.UpdateEffectiveColor; begin if Color = clNone then FEffectiveColor := CurrentTheme.GetViewColor(GetViewType) else FEffectiveColor := Color; end; procedure TTBXCustomDockablePanel.WMEraseBkgnd(var Message: TWMEraseBkgnd); var BRUSH: HBRUSH; begin BRUSH := CreateSolidBrush(ColorToRGB(EffectiveColor)); FillRect(Message.DC, Clientrect, BRUSH); DeleteObject(BRUSH); Message.Result := 1; end; procedure TTBXCustomDockablePanel.WMNCCalcSize(var Message: TWMNCCalcSize); begin Message.Result := 0; if Docked then with Message.CalcSize_Params^ do begin InflateRect(rgrc[0], -DockedBorderSize, -DockedBorderSize); if ShowCaptionWhenDocked then if IsVertCaption then Inc(rgrc[0].Left, GetSystemMetrics(SM_CYSMCAPTION)) else Inc(rgrc[0].Top, GetSystemMetrics(SM_CYSMCAPTION)) end; end; procedure TTBXCustomDockablePanel.WMNCHitTest(var Message: TWMNCHitTest); const CResizeMargin = 2; var P: TPoint; R: TRect; Sz: Integer; IsVertical, UseDefaultHandler: Boolean; begin if Docked then begin UseDefaultHandler := False; if csDesigning in ComponentState then with Message do begin P := SmallPointToPoint(Pos); GetWindowRect(Handle, R); if PtInRect(R, P) then begin Result := 0; case CurrentDock.Position of dpLeft: if P.X >= R.Right - CResizeMargin then Result := HTRIGHT; dpTop: if P.Y >= R.Bottom - CResizeMargin then Result := HTBOTTOM; dpRight: if P.X <= R.Left + CResizeMargin then Result := HTLEFT; dpBottom: if P.Y <= R.Top + CResizeMargin then Result := HTTOP; end; if Result = 0 then begin if (P.X >= R.Right - CResizeMargin) and CanSplitResize(dpRight) then Result := HT_TBX_SPLITRESIZERIGHT else if (P.Y >= R.Bottom - CResizeMargin) and CanSplitResize(dpBottom) then Result := HT_TBX_SPLITRESIZEBOTTOM else if (P.X <= R.Left + CResizeMargin) and CanSplitResize(dpLeft) then Result := HT_TBX_SPLITRESIZELEFT else if (P.Y <= R.Top + CResizeMargin) and CanSplitResize(dpTop) then Result := HT_TBX_SPLITRESIZETOP; end; UseDefaultHandler := Result <> 0; end; if UseDefaultHandler then DefaultHandler(Message) else inherited; end; with Message do begin P := SmallPointToPoint(Pos); GetWindowRect(Handle, R); if Resizable then case CurrentDock.Position of dpLeft: if P.X >= R.Right - CResizeMargin then Result := HTRIGHT; dpTop: if P.Y >= R.Bottom - CResizeMargin then Result := HTBOTTOM; dpRight: if P.X <= R.Left + CResizeMargin then Result := HTLEFT; dpBottom: if P.Y <= R.Top + CResizeMargin then Result := HTTOP; end; if Result = 0 then begin if (P.X >= R.Right - CResizeMargin) and CanSplitResize(dpRight) then Result := HT_TBX_SPLITRESIZERIGHT else if (P.Y >= R.Bottom - CResizeMargin) and CanSplitResize(dpBottom) then Result := HT_TBX_SPLITRESIZEBOTTOM else if (P.X <= R.Left + CResizeMargin) and CanSplitResize(dpLeft) then Result := HT_TBX_SPLITRESIZELEFT else if (P.Y <= R.Top + CResizeMargin) and CanSplitResize(dpTop) then Result := HT_TBX_SPLITRESIZETOP; end; if (Result <> HTCLIENT) and ((Result < HTLEFT) or (Result > HTBOTTOM)) and ((Result < HT_TBX_SPLITRESIZELEFT) or (Result > HT_TBX_SPLITRESIZEBOTTOM)) then begin Result := HTNOWHERE; InflateRect(R, -DockedBorderSize, -DockedBorderSize); if PtInRect(R, P) and ShowCaptionWhenDocked and not (csDesigning in ComponentState) then begin { caption area } IsVertical := not IsVertCaption; if CloseButtonWhenDocked then begin Sz := GetSystemMetrics(SM_CYSMCAPTION); if IsVertical then Inc(Sz, 4) else Dec(Sz, 4); end else Sz := 0; if (IsVertical and (P.X >= R.Right - Sz) and (P.Y < R.Top + Sz)) or (not IsVertical and (P.Y >= R.Bottom - Sz) and (P.X < R.Left + Sz)) then Result := HT_TB2k_Close else Result := HT_TB2k_Border; end; end; end; end else inherited; end; procedure TTBXCustomDockablePanel.WMNCLButtonDown(var Message: TWMNCLButtonDown); var OldCursor: HCURSOR; begin if Message.HitTest in [HTLEFT..HTBOTTOM] then BeginDockedSizing(Message.HitTest) else if Message.HitTest in [HT_TBX_SPLITRESIZELEFT..HT_TBX_SPLITRESIZEBOTTOM] then BeginSplitResizing(Message.HitTest) else begin if (Message.HitTest = HT_TB2k_Border) and IsMovable then begin OldCursor := SetCursor(LoadCursor(0, IDC_SIZEALL)); try inherited; finally SetCursor(OldCursor); end; end else inherited; end; end; procedure TTBXCustomDockablePanel.WMSetCursor(var Message: TWMSetCursor); var Cur: TCursor; {vb+} begin {if Docked and CurrentDock.AllowDrag and (Message.CursorWnd = WindowHandle) and (Smallint(Message.HitTest) = HT_TB2k_Border) and ShowCaptionWhenDocked then begin SetCursor(LoadCursor(0, IDC_ARROW)); Message.Result := 1; Exit; end else if Docked and CurrentDock.AllowDrag and (Message.CursorWnd = WindowHandle) then begin if (Message.HitTest = HT_TBX_SPLITRESIZELEFT) or (Message.HitTest = HT_TBX_SPLITRESIZERIGHT) then begin SetCursor(LoadCursor(0, IDC_SIZEWE)); Message.Result := 1; Exit; end else if (Message.HitTest = HT_TBX_SPLITRESIZETOP) or (Message.HitTest = HT_TBX_SPLITRESIZEBOTTOM) then begin SetCursor(LoadCursor(0, IDC_SIZENS)); Message.Result := 1; Exit; end; end; } {vb-} if Docked and CurrentDock.AllowDrag and (Message.CursorWnd = WindowHandle) then begin Cur := crNone; case Message.HitTest of HTLEFT, HTRIGHT: Cur := HorzResizeCursor; HTTOP, HTBOTTOM: Cur := VertResizeCursor; HT_TBX_SPLITRESIZELEFT, HT_TBX_SPLITRESIZERIGHT: Cur := HorzSplitCursor; HT_TBX_SPLITRESIZETOP, HT_TBX_SPLITRESIZEBOTTOM: Cur := VertSplitCursor; HT_TB2k_Border: if ShowCaptionWhenDocked then Cur := crArrow; end; if Cur <> crNone then begin SetCursor(Screen.Cursors[Cur]); Message.Result := 1; Exit; end; end; inherited; end; procedure TTBXCustomDockablePanel.WMWindowPosChanged(var Message: TWMWindowPosChanged); begin inherited; if (Message.WindowPos^.flags and SWP_NOSIZE) = 0 then begin Realign; Update; end; if (Message.WindowPos^.flags and SWP_SHOWWINDOW) <> 0 then begin UpdateEffectiveColor; UpdateChildColors; end; end; procedure TTBXCustomDockablePanel.WritePositionData(const Data: TTBWritePositionData); begin with Data do begin WriteIntProc(Name, rvDockedWidth, FDockedWidth, ExtraData); WriteIntProc(Name, rvDockedHeight, FDockedHeight, ExtraData); WriteIntProc(Name, rvFloatingWidth, FFloatingWidth, ExtraData); WriteIntProc(Name, rvFloatingHeight, FFloatingHeight, ExtraData); WriteIntProc(Name, rvSplitWidth, FSplitWidth, ExtraData); WriteIntProc(Name, rvSplitHeight, FSplitHeight, ExtraData); end; end; //----------------------------------------------------------------------------// { TTBXTextObject } procedure TTBXTextObject.AdjustFont(AFont: TFont); begin end; procedure TTBXTextObject.AdjustHeight; var NewHeight: Integer; begin if HandleAllocated and not FUpdating and ([csReading, csLoading] * ComponentState = []) and AutoSize then begin FUpdating := True; try NewHeight := 0; DoAdjustHeight(StockCompatibleBitmap.Canvas, NewHeight); SetBounds(Left, Top, Width, NewHeight); finally FUpdating := False; end; end; end; function TTBXTextObject.CanAutoSize(var NewWidth, NewHeight: Integer): Boolean; begin if not FUpdating and ([csReading, csLoading] * ComponentState = []) and AutoSize then begin FUpdating := True; try NewHeight := 0; DoAdjustHeight(StockCompatibleBitmap.Canvas, NewHeight); Result := True; finally FUpdating := False; end; end else Result := False; end; procedure TTBXTextObject.CMEnabledChanged(var Message: TMessage); begin inherited; Invalidate; end; procedure TTBXTextObject.CMFontChanged(var Message: TMessage); begin inherited; Invalidate; AdjustHeight; end; procedure TTBXTextObject.CMTextChanged(var Message: TMessage); begin inherited; Invalidate; AdjustHeight; end; constructor TTBXTextObject.Create(AOwner: TComponent); begin inherited; ControlStyle := ControlStyle + [csSetCaption, csDoubleClicks]; FMargins := TTBXControlMargins.Create; FMargins.OnChange := MarginsChangeHandler; FShowAccelChar := True; PaintOptions := [cpoDoubleBuffered]; AutoSize := True; Width := 100; end; procedure TTBXTextObject.CreateParams(var Params: TCreateParams); begin inherited; if not (csDesigning in ComponentState) then with Params.WindowClass do style := style or CS_HREDRAW; end; destructor TTBXTextObject.Destroy; begin FMargins.Free; inherited; end; procedure TTBXTextObject.DoAdjustHeight(ACanvas: TCanvas; var NewHeight: Integer); const WordWraps: array [TTextWrapping] of Word = (0, DT_END_ELLIPSIS, DT_PATH_ELLIPSIS, DT_WORDBREAK); var R: TRect; EffectiveMargins: TRect; begin R := ClientRect; EffectiveMargins := GetTextMargins; with Margins do begin Inc(EffectiveMargins.Left, Left); Inc(EffectiveMargins.Right, Right); Inc(EffectiveMargins.Top, Top); Inc(EffectiveMargins.Bottom, Bottom); end; ApplyMargins(R, EffectiveMargins); NewHeight := DoDrawText(ACanvas, R, (DT_EXPANDTABS or DT_CALCRECT) or WordWraps[Wrapping]); with EffectiveMargins do Inc(NewHeight, Top + Bottom); end; function TTBXTextObject.DoDrawText(ACanvas: TCanvas; var Rect: TRect; Flags: Integer): Integer; var Text: string; begin Text := GetLabelText; if (Flags and DT_CALCRECT <> 0) and ((Text = '') or (Text[1] = '&') and (Text[2] = #0)) then Text := Text + ' '; Flags := DrawTextBiDiModeFlags(Flags); ACanvas.Font := Font; AdjustFont(ACanvas.Font); if Flags and DT_CALCRECT = DT_CALCRECT then begin Flags := Flags and not DT_VCENTER; Result := DrawText(ACanvas.Handle, PChar(Text), Length(Text), Rect, Flags); end else if not Enabled then begin OffsetRect(Rect, 1, 1); ACanvas.Font.Color := clBtnHighlight; DrawText(ACanvas.Handle, PChar(Text), Length(Text), Rect, Flags); OffsetRect(Rect, -1, -1); ACanvas.Font.Color := clBtnShadow; Result := DrawText(ACanvas.Handle, PChar(Text), Length(Text), Rect, Flags); end else begin Result := DrawText(ACanvas.Handle, PChar(Text), Length(Text), Rect, Flags); end; end; procedure TTBXTextObject.DoMarginsChanged; begin Invalidate; AdjustHeight; end; function TTBXTextObject.GetControlsAlignment: TAlignment; begin Result := FAlignment; end; function TTBXTextObject.GetFocusRect(const R: TRect): TRect; begin { R is the client rectangle without the margins } Result := Rect(0, 0, 0, 0); end; function TTBXTextObject.GetLabelText: string; begin Result := Caption; end; function TTBXTextObject.GetTextAlignment: TAlignment; begin Result := Alignment; end; function TTBXTextObject.GetTextMargins: TRect; const ZeroRect: TRect = (Left: 0; Top: 0; Right: 0; Bottom: 0); begin Result := ZeroRect; end; procedure TTBXTextObject.Loaded; begin inherited; AdjustHeight; end; procedure TTBXTextObject.MarginsChangeHandler(Sender: TObject); begin DoMarginsChanged; end; procedure TTBXTextObject.Paint; const Alignments: array [TAlignment] of Integer = (DT_LEFT, DT_RIGHT, DT_CENTER); WordWraps: array [TTextWrapping] of Integer = (DT_SINGLELINE, DT_SINGLELINE or DT_END_ELLIPSIS, DT_SINGLELINE or DT_PATH_ELLIPSIS, DT_WORDBREAK); ShowAccelChars: array [Boolean] of Integer = (DT_NOPREFIX, 0); var R, R2: TRect; DrawStyle: Longint; CaptionHeight: Integer; begin with Canvas do begin R := ClientRect; ApplyMargins(R, Margins); if Focused then DrawFocusRect2(Canvas, GetFocusRect(R)); DrawStyle := DT_EXPANDTABS or WordWraps[Wrapping] or Alignments[GetRealAlignment(Self)] or ShowAccelChars[ShowAccelChar]; Brush.Style := bsClear; ApplyMargins(R, GetTextMargins); R2 := R; CaptionHeight := DoDrawText(Canvas, R2, DrawStyle or DT_CALCRECT); R.Top := (R.Top + R.Bottom - CaptionHeight) div 2; R.Bottom := R.Top + CaptionHeight; DoDrawText(Canvas, R, DrawStyle); Brush.Style := bsSolid; end; end; procedure TTBXTextObject.SetAlignment(Value: TLeftRight); begin FAlignment := Value; Invalidate; end; procedure TTBXTextObject.SetMargins(Value: TTBXControlMargins); begin FMargins.Assign(Value); end; procedure TTBXTextObject.SetShowAccelChar(Value: Boolean); begin if FShowAccelChar <> Value then begin FShowAccelChar := Value; AdjustHeight; Invalidate; end; end; procedure TTBXTextObject.SetWrapping(Value: TTextWrapping); begin FWrapping := Value; Invalidate; AdjustHeight; end; //----------------------------------------------------------------------------// { TTBXCustomLabel } procedure TTBXCustomLabel.CMDialogChar(var Message: TCMDialogChar); begin if (FFocusControl <> nil) and Enabled and ShowAccelChar and IsAccel(Message.CharCode, Caption) then with FFocusControl do if CanFocus then begin SetFocus; Message.Result := 1; end; end; constructor TTBXCustomLabel.Create(AOwner: TComponent); begin inherited; Wrapping := twWrap; FUnderlineColor := clBtnShadow; TabStop := False; end; function TTBXCustomLabel.GetTextMargins: TRect; const BottomMargin: array [Boolean] of Integer = (0, 1); begin with Result do begin Left := 0; Top := 0; Right := 0; Result.Bottom := BottomMargin[Underline]; end; end; procedure TTBXCustomLabel.Notification(AComponent: TComponent; Operation: TOperation); begin inherited; inherited Notification(AComponent, Operation); if (Operation = opRemove) and (AComponent = FFocusControl) then FFocusControl := nil; end; procedure TTBXCustomLabel.Paint; var Rect: TRect; begin inherited; if Underline then with Canvas do begin Rect := ClientRect; ApplyMargins(Rect, Margins); ApplyMargins(Rect, GetTextMargins); Pen.Color := UnderlineColor; MoveTo(Rect.Left, Rect.Bottom); LineTo(Rect.Right, Rect.Bottom); end; end; procedure TTBXCustomLabel.SetFocusControl(Value: TWinControl); begin if FFocusControl <> Value then begin if FFocusControl <> nil then FFocusControl.RemoveFreeNotification(Self); FFocusControl := Value; if FFocusControl <> nil then FFocusControl.FreeNotification(Self); end; end; procedure TTBXCustomLabel.SetUnderline(Value: Boolean); begin if Value <> FUnderline then begin FUnderline := Value; Invalidate; AdjustHeight; end; end; procedure TTBXCustomLabel.SetUnderlineColor(Value: TColor); begin FUnderlineColor := Value; Invalidate; end; //----------------------------------------------------------------------------// { TTBXCustomLink } procedure TTBXCustomLink.AdjustFont(AFont: TFont); begin if MouseInControl then AFont.Style := AFont.Style + [fsUnderline]; end; procedure TTBXCustomLink.CMDialogChar(var Message: TCMDialogChar); begin with Message do if Enabled and ShowAccelChar and IsAccel(CharCode, GetLabelText) and CanFocus and Visible then begin Click; Result := 1; end else inherited; end; procedure TTBXCustomLink.CMDialogKey(var Message: TCMDialogKey); begin with Message do if (CharCode = VK_RETURN) and Focused and (KeyDataToShiftState(Message.KeyData) = []) then begin Click; Result := 1; end else inherited; end; constructor TTBXCustomLink.Create(AOwner: TComponent); begin inherited; FImageChangeLink := TChangeLink.Create; FImageChangeLink.OnChange := ImageListChange; SmartFocus := True; SpaceAsClick := True; TabStop := True; Cursor := crHandPoint; end; destructor TTBXCustomLink.Destroy; begin FImageChangeLink.Free; inherited; end; procedure TTBXCustomLink.DoAdjustHeight(ACanvas: TCanvas; var NewHeight: Integer); begin inherited DoAdjustHeight(ACanvas, NewHeight); if Images <> nil then if NewHeight < Images.Height + 4 then NewHeight := Images.Height + 4; end; procedure TTBXCustomLink.DoMouseEnter; begin inherited; Invalidate; end; procedure TTBXCustomLink.DoMouseLeave; begin inherited; Invalidate; end; function TTBXCustomLink.GetControlsAlignment: TAlignment; begin Result := GetTextAlignment; end; function TTBXCustomLink.GetFocusRect(const R: TRect): TRect; const WordWraps: array [TTextWrapping] of Integer = (DT_SINGLELINE or DT_VCENTER, DT_SINGLELINE or DT_VCENTER or DT_END_ELLIPSIS, DT_SINGLELINE or DT_VCENTER or DT_PATH_ELLIPSIS, DT_WORDBREAK); var TR: TRect; ShowImage: Boolean; begin Result := R; ShowImage := Assigned(Images) and (ImageIndex >= 0) and (ImageIndex < Images.Count); { Text Rectangle } TR := R; ApplyMargins(TR, GetTextMargins); DoDrawText(Canvas, TR, (DT_EXPANDTABS or DT_CALCRECT) or WordWraps[Wrapping] or DT_LEFT); if ShowImage then begin if GetRealAlignment(Self) = taLeftJustify then begin Result.Left := R.Left; Result.Right := TR.Right; end else begin Result.Left := TR.Left; Result.Right := R.Right; end; end else begin Result.Right := TR.Right; Result.Left := TR.Left; end; Dec(Result.Left, 2); Inc(Result.Right, 2); end; function TTBXCustomLink.GetTextAlignment: TAlignment; begin Result := taLeftJustify; end; function TTBXCustomLink.GetTextMargins: TRect; begin Result := Rect(2, 1, 2, 1); if Assigned(Images) then with Result do begin if GetRealAlignment(Self) = taLeftJustify then Inc(Left, Images.Width + 5) else Inc(Right, Images.Width + 5); end; end; procedure TTBXCustomLink.ImageListChange(Sender: TObject); begin if Sender = Images then begin Invalidate; AdjustHeight; end; end; procedure TTBXCustomLink.Notification(AComponent: TComponent; Operation: TOperation); begin inherited; if (AComponent = Images) and (Operation = opRemove) then Images := nil; end; procedure TTBXCustomLink.Paint; var Rect, R: TRect; begin inherited; if Assigned(Images) and (ImageIndex >= 0) and (ImageIndex < Images.Count) then with Canvas do begin Rect := ClientRect; ApplyMargins(Rect, Margins); if GetRealAlignment(Self) = taLeftJustify then R.Left := Rect.Left + 2 else R.Left := Rect.Right - 2 - Images.Width; R.Top := (Rect.Top + Rect.Bottom - Images.Height) div 2; R.Right := R.Left + Images.Width; R.Bottom := R.Top + Images.Height; if Enabled then Images.Draw(Canvas, R.Left, R.Top, ImageIndex) else DrawTBXImage(Canvas, R, Images, ImageIndex, ISF_DISABLED); end; end; procedure TTBXCustomLink.SetImageIndex(Value: TImageIndex); begin if FImageIndex <> Value then begin FImageIndex := Value; if Assigned(Images) then Invalidate; end; end; procedure TTBXCustomLink.SetImages(Value: TCustomImageList); begin if FImages <> nil then FImages.UnRegisterChanges(FImageChangeLink); FImages := Value; if FImages <> nil then begin FImages.RegisterChanges(FImageChangeLink); FImages.FreeNotification(Self); end; Invalidate; AdjustHeight; end; procedure TTBXCustomLink.WMNCHitTest(var Message: TWMNCHitTest); var P: TPoint; R: TRect; begin inherited; if not (csDesigning in ComponentState) then begin P := ScreenToClient(SmallPointToPoint(Message.Pos)); R := ClientRect; ApplyMargins(R, Margins); R := GetFocusRect(R); if not PtInRect(R, P) then Message.Result := HTTRANSPARENT; end; end; //----------------------------------------------------------------------------// { TTBXCustomButton } function TTBXCustomButton.ArrowVisible: Boolean; begin Result := DropDownMenu <> nil; end; procedure TTBXCustomButton.Click; var Form: TCustomForm; Pt: TPoint; R: TRect; SaveAlignment: TPopupAlignment; procedure RemoveClicks; var RepostList: TList; Repost: Boolean; I: Integer; Msg: TMsg; P: TPoint; begin RepostList := TList.Create; try while PeekMessage(Msg, 0, WM_LBUTTONDOWN, WM_MBUTTONDBLCLK, PM_REMOVE) do with Msg do begin Repost := True; case Message of WM_QUIT: begin { Throw back any WM_QUIT messages } PostQuitMessage(wParam); Break; end; WM_LBUTTONDOWN, WM_LBUTTONDBLCLK, WM_RBUTTONDOWN, WM_RBUTTONDBLCLK, WM_MBUTTONDOWN, WM_MBUTTONDBLCLK: begin P := SmallPointToPoint(TSmallPoint(lParam)); Windows.ClientToScreen(hwnd, P); if FindDragTarget(P, True) = Self then Repost := False; end; end; if Repost then begin RepostList.Add(AllocMem(SizeOf(TMsg))); PMsg(RepostList.Last)^ := Msg; end; end; finally for I := 0 to RepostList.Count-1 do begin with PMsg(RepostList[I])^ do PostMessage(hwnd, message, wParam, lParam); FreeMem(RepostList[I]); end; RepostList.Free; end; end; begin if FRepeating and not FMenuVisible then inherited else try FInClick := True; if (GroupIndex <> 0) and not FMenuVisible then SetChecked(not Checked); MouseLeft; if (DropDownMenu = nil) or (DropDownCombo and not FMenuVisible) then begin if ModalResult <> 0 then begin Form := GetParentForm(Self); if Form <> nil then Form.ModalResult := ModalResult; end; inherited; end else begin MouseCapture := False; SaveAlignment := paLeft; // to avoid compiler warnings if DoDropDown then try Pt := Point(0, Height); Pt := ClientToScreen(Pt); SaveAlignment := DropDownMenu.Alignment; DropDownMenu.PopupComponent := Self; if DropDownMenu is TTBXPopupMenu then begin R := ClientRect; ApplyMargins(R, Margins); R.TopLeft := ClientToScreen(R.TopLeft); R.BottomRight := ClientToScreen(R.BottomRight); TTBXPopupMenu(DropDownMenu).PopupEx(R); end else DropDownMenu.Popup(Pt.X, Pt.Y); finally DropDownMenu.Alignment := SaveAlignment; if Pushed then FPushed := False; Invalidate; RemoveClicks; end else inherited; end; finally FInClick := False; end; end; procedure TTBXCustomButton.CMDialogChar(var Message: TCMDialogChar); begin with Message do if Enabled and ShowAccelChar and IsAccel(CharCode, GetLabelText) and CanFocus and Visible then begin Click; Result := 1; end else inherited; end; procedure TTBXCustomButton.CMDialogKey(var Message: TCMDialogKey); begin with Message do if (CharCode = VK_RETURN) and Focused and (KeyDataToShiftState(Message.KeyData) = []) then begin Click; Result := 1; end else inherited; end; constructor TTBXCustomButton.Create(AOwner: TComponent); begin inherited; FAlignment := taCenter; FBorderSize := 4; FGlyphSpacing := 4; FImageChangeLink := TChangeLink.Create; FImageChangeLink.OnChange := ImageListChange; FRepeatDelay := 400; FRepeatInterval := 100; SmartFocus := True; SpaceAsClick := True; TabStop := True; end; destructor TTBXCustomButton.Destroy; begin FImageChangeLink.Free; inherited; end; procedure TTBXCustomButton.DoAdjustHeight(ACanvas: TCanvas; var NewHeight: Integer); var Sz: Integer; begin if Length(GetLabelText) = 0 then begin if Images <> nil then NewHeight := Images.Height + BorderSize * 2 else if BorderSize * 2 >= 16 then NewHeight := BorderSize * 2 else NewHeight := 16; end else begin inherited DoAdjustHeight(ACanvas, NewHeight); if Images <> nil then if Layout in [blGlyphLeft, blGlyphRight] then begin Sz := Images.Height + BorderSize * 2; if NewHeight < Sz then NewHeight := Sz; end; end; end; function TTBXCustomButton.DoDrawText(ACanvas: TCanvas; var Rect: TRect; Flags: Integer): Integer; var ItemInfo: TTBXItemInfo; Text: string; begin Text := GetLabelText; if (Flags and DT_CALCRECT <> 0) and ((Text = '') or (Text[1] = '&') and (Text[2] = #0)) then Text := Text + ' '; Flags := DrawTextBiDiModeFlags(Flags); ACanvas.Font := Font; AdjustFont(ACanvas.Font); if Flags and DT_CALCRECT = DT_CALCRECT then begin Flags := Flags and not DT_VCENTER; Result := DrawText(ACanvas.Handle, PChar(Text), Length(Text), Rect, Flags); end else begin GetItemInfo(ItemInfo); ACanvas.Font.Color := clNone; CurrentTheme.PaintCaption(Canvas, Rect, ItemInfo, Text, Flags, False); Flags := Flags or DT_CALCRECT; Result := DrawText(ACanvas.Handle, PChar(Text), Length(Text), Rect, Flags); end; end; function TTBXCustomButton.DoDropDown: Boolean; begin Result := FDropDownMenu <> nil; if Result and Assigned(FOnDropDown) then FOnDropDown(Self, Result); end; procedure TTBXCustomButton.DoMouseEnter; begin inherited; Invalidate; end; procedure TTBXCustomButton.DoMouseLeave; begin inherited; Invalidate; end; function TTBXCustomButton.GetControlsAlignment: TAlignment; begin Result := GetTextAlignment; end; function TTBXCustomButton.GetFocusRect(const R: TRect): TRect; begin Result := R; InflateRect(Result, -2, -2); end; procedure TTBXCustomButton.GetItemInfo(out ItemInfo: TTBXItemInfo); const ViewTypes: array [TButtonStyle] of Integer = (VT_TOOLBAR or TVT_EMBEDDED, VT_TOOLBAR); begin FillChar(ItemInfo, SizeOf(ItemInfo), 0); ItemInfo.ViewType := ViewTypes[ButtonStyle]; ItemInfo.Enabled := Enabled; ItemInfo.ItemOptions := IO_TOOLBARSTYLE or IO_APPACTIVE; ItemInfo.Pushed := Pushed and (MouseInControl or FMenuVisible); if FMenuVisible and DropDownCombo then ItemInfo.Pushed := False; if FMenuVisible then ItemInfo.IsPopupParent := True; ItemInfo.Selected := Checked; ItemInfo.IsVertical := False; if ArrowVisible and DropDownCombo then ItemInfo.ComboPart := cpCombo; if MouseInControl or FMenuVisible then ItemInfo.HoverKind := hkMouseHover; end; function TTBXCustomButton.GetTextAlignment: TAlignment; begin Result := FAlignment; end; function TTBXCustomButton.GetTextMargins: TRect; var L, Sz: Integer; IsSpecialDropDown: Boolean; begin Result := Rect(BorderSize, BorderSize, BorderSize, BorderSize); L := Length(GetLabelText); if (Images <> nil) and (L > 0) then Sz := GlyphSpacing else Sz := 0; if Assigned(Images) then with Result do case Layout of blGlyphLeft: Inc(Left, Images.Width + Sz); blGlyphTop: Inc(Top, Images.Height + Sz); blGlyphRight: Inc(Right, Images.Width + Sz); blGlyphBottom: Inc(Bottom, Images.Height + Sz); end; if ArrowVisible then begin if DropDownCombo then Inc(Result.Right, CurrentTheme.SplitBtnArrowWidth) else begin IsSpecialDropDown := (L > 0) and (Images <> nil) and (Layout in [blGlyphTop, blGlyphBottom]); if not IsSpecialDropDown then Inc(Result.Right, CurrentTheme.DropDownArrowWidth); end; end; end; procedure TTBXCustomButton.ImageListChange(Sender: TObject); begin if Sender = Images then begin Invalidate; AdjustHeight; end; end; procedure TTBXCustomButton.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); var R: TRect; begin inherited; if Enabled and (Button = mbLeft) then begin R := ClientRect; ApplyMargins(R, Margins); FMenuVisible := not FInClick and Assigned(DropDownMenu) and (not DropDownCombo or (X >= R.Right - CurrentTheme.SplitBtnArrowWidth)); try if FMenuVisible then begin ControlState := ControlState - [csClicked]; if not FInClick then begin Click; end; end else if Repeating then begin Click; ControlState := ControlState - [csClicked]; if not Assigned(FRepeatTimer) then FRepeatTimer := TTimer.Create(Self); FRepeatTimer.Interval := RepeatDelay; FRepeatTimer.OnTimer := RepeatTimerHandler; FRepeatTimer.Enabled := True; end; finally FMenuVisible := False; end; end; end; procedure TTBXCustomButton.MouseMove(Shift: TShiftState; X, Y: Integer); begin inherited; if Assigned(FRepeatTimer) and PtInButtonPart(Point(X, Y)) then FRepeatTimer.Enabled := True; end; procedure TTBXCustomButton.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin inherited; if Button = mbLeft then begin FRepeatTimer.Free; FRepeatTimer := nil; end; end; procedure TTBXCustomButton.Notification(AComponent: TComponent; Operation: TOperation); begin inherited; if Operation = opRemove then begin if AComponent = Images then Images := nil else if AComponent = DropdownMenu then DropdownMenu := nil; end; end; procedure TTBXCustomButton.Paint; const Alignments: array [TAlignment] of Integer = (DT_LEFT, DT_RIGHT, DT_CENTER); WordWraps: array [TTextWrapping] of Integer = (DT_SINGLELINE, DT_SINGLELINE or DT_END_ELLIPSIS, DT_SINGLELINE or DT_PATH_ELLIPSIS, DT_WORDBREAK); ShowAccelChars: array [Boolean] of Integer = (DT_NOPREFIX, 0); var CR, IR, TR: TRect; W, X: Integer; Text: string; ItemInfo: TTBXItemInfo; RealAlignment: TAlignment; CaptionHeight: Integer; DrawStyle: Cardinal; ShowArrow: Boolean; begin CR := ClientRect; ApplyMargins(CR, Margins); ShowArrow := ArrowVisible; GetItemInfo(ItemInfo); if ShowArrow and DropDownCombo then begin TR := CR; TR.Left := TR.Right - CurrentTheme.SplitBtnArrowWidth; CR.Right := TR.Left; ItemInfo.ComboPart := cpSplitRight; ItemInfo.Pushed := FMenuVisible; CurrentTheme.PaintButton(Canvas, TR, ItemInfo); ItemInfo.ComboPart := cpSplitLeft; ItemInfo.Pushed := Pushed and not FMenuVisible; CurrentTheme.PaintButton(Canvas, CR, ItemInfo); end else CurrentTheme.PaintButton(Canvas, CR, ItemInfo); if Focused then DrawFocusRect2(Canvas, GetFocusRect(CR)); InflateRect(CR, -BorderSize, -BorderSize); if ShowArrow and not DropDownCombo then begin TR := CR; TR.Left := TR.Right - CurrentTheme.DropdownArrowWidth; CurrentTheme.PaintDropDownArrow(Canvas, TR, ItemInfo); CR.Right := TR.Left - CurrentTheme.DropdownArrowMargin; end; Text := GetLabelText; DrawStyle := 0; if (Length(Text) > 0) or (Images <> nil) then begin RealAlignment := GetRealAlignment(Self); if Length(Text) = 0 then begin IR.Top := (CR.Top + CR.Bottom - Images.Height) div 2; IR.Bottom := IR.Top + Images.Height; case RealAlignment of taLeftJustify: IR.Left := CR.Left; taRightJustify: IR.Left := CR.Right - Images.Width; else IR.Left := (CR.Left + CR.Right - Images.Width) div 2; end; IR.Right := IR.Left + Images.Width; end else begin TR := CR; DrawStyle := DT_EXPANDTABS or WordWraps[Wrapping] or Alignments[RealAlignment] or ShowAccelChars[ShowAccelChar]; if (Images = nil) or (Layout in [blGlyphTop, blGlyphBottom]) then begin CaptionHeight := DoDrawText(Canvas, TR, DrawStyle or DT_CALCRECT); TR := CR; if Images = nil then begin TR.Top := (TR.Top + TR.Bottom - CaptionHeight) div 2; end else begin TR.Top := (CR.Top + CR.Bottom - Images.Height - GlyphSpacing - CaptionHeight) div 2; IR.Top := TR.Top; if Layout = blGlyphTop then Inc(TR.Top, Images.Height + GlyphSpacing) else Inc(IR.Top, CaptionHeight + GlyphSpacing); TR.Bottom := TR.Top + CaptionHeight; IR.Bottom := IR.Top + Images.Height; case RealAlignment of taLeftJustify: IR.Left := CR.Left; taRightJustify: IR.Left := CR.Right - Images.Width; else IR.Left := (CR.Left + CR.Right - Images.Width) div 2; end; IR.Right := IR.Left + Images.Width; end; end else begin IR.Left := CR.Left; if Layout = blGlyphLeft then Inc(TR.Left, Images.Width + GlyphSpacing) else Dec(TR.Right, Images.Width + GlyphSpacing); IR.Right := IR.Left + Images.Width; IR.Top := (CR.Top + CR.Bottom - Images.Height) div 2; IR.Bottom := IR.Top + Images.Height; CaptionHeight := DoDrawText(Canvas, TR, DrawStyle or DT_CALCRECT); TR.Top := (CR.Top + CR.Bottom - CaptionHeight) div 2; TR.Bottom := TR.Top + CaptionHeight; W := Images.Width + GlyphSpacing + TR.Right - TR.Left; case RealAlignment of taLeftJustify: X := CR.Left; taRightJustify: X := CR.Right - W; else X := (CR.Left + CR.Right - W) div 2; end; case Layout of blGlyphLeft: begin if X < CR.Left then X := CR.Left; IR.Left := X; IR.Right := X + Images.Width; OffsetRect(TR, IR.Right + GlyphSpacing - TR.Left, 0); if TR.Right > CR.Right then TR.Right := CR.Right; DrawStyle := DrawStyle and not DT_RIGHT and not DT_CENTER or DT_LEFT; end; blGlyphRight: begin OffsetRect(TR, X - TR.Left, 0); IR.Left := TR.Right + GlyphSpacing; IR.Right := IR.Left + Images.Width; DrawStyle := DrawStyle and not DT_CENTER and not DT_LEFT or DT_RIGHT; end; end; end; end; if Images <> nil then CurrentTheme.PaintImage(Canvas, IR, ItemInfo, Images, ImageIndex); if Length(Text) > 0 then begin Brush.Style := bsClear; DoDrawText(Canvas, TR, DrawStyle); Brush.Style := bsSolid; end; end; end; function TTBXCustomButton.PtInButtonPart(const Pt: TPoint): Boolean; var R: TRect; begin R := ClientRect; ApplyMargins(R, Margins); Result := PtInRect(R, Pt); end; procedure TTBXCustomButton.RepeatTimerHandler(Sender: TObject); var P: TPoint; begin FRepeatTimer.Interval := RepeatInterval; GetCursorPos(P); P := ScreenToClient(P); if not MouseCapture then begin FRepeatTimer.Free; FRepeatTimer := nil; end else if Repeating and Pushed and PtInButtonPart(P) then Click else FRepeatTimer.Enabled := False; end; procedure TTBXCustomButton.SetAlignment(Value: TAlignment); begin FAlignment := Value; Invalidate; end; procedure TTBXCustomButton.SetAllowAllUnchecked(Value: Boolean); begin if FAllowAllUnchecked <> Value then begin FAllowAllUnchecked := Value; UpdateCheckedState; end; end; procedure TTBXCustomButton.SetBorderSize(Value: Integer); begin FBorderSize := Value; Invalidate; AdjustHeight; end; procedure TTBXCustomButton.SetButtonStyle(Value: TButtonStyle); begin FButtonStyle := Value; Invalidate; end; procedure TTBXCustomButton.SetChecked(Value: Boolean); begin if FGroupIndex = 0 then Value := False; if FChecked <> Value then begin if FChecked and not AllowAllUnchecked then Exit; FChecked := Value; Invalidate; if Value then UpdateCheckedState; end; end; procedure TTBXCustomButton.SetDropdownCombo(Value: Boolean); begin FDropdownCombo := Value; Invalidate; end; procedure TTBXCustomButton.SetDropdownMenu(Value: TPopupMenu); begin if FDropdownMenu <> Value then begin if FDropDownMenu <> nil then RemoveFreeNotification(FDropDownMenu); FDropDownMenu := Value; if FDropDownMenu <> nil then FreeNotification(FDropDownMenu); Invalidate; end; end; procedure TTBXCustomButton.SetGlyphSpacing(Value: Integer); begin FGlyphSpacing := Value; Invalidate; AdjustHeight; end; procedure TTBXCustomButton.SetGroupIndex(Value: Integer); begin if FGroupIndex <> Value then begin FGroupIndex := Value; UpdateCheckedState; end; end; procedure TTBXCustomButton.SetImageIndex(Value: TImageIndex); begin if FImageIndex <> Value then begin FImageIndex := Value; if Assigned(Images) then Invalidate; end; end; procedure TTBXCustomButton.SetImages(Value: TCustomImageList); begin if FImages <> nil then FImages.UnRegisterChanges(FImageChangeLink); FImages := Value; if FImages <> nil then begin FImages.RegisterChanges(FImageChangeLink); FImages.FreeNotification(Self); end; Invalidate; AdjustHeight; end; procedure TTBXCustomButton.SetLayout(Value: TButtonLayout); begin FLayout := Value; Invalidate; AdjustHeight; end; procedure TTBXCustomButton.UpdateCheckedState; var I: Integer; C: TControl; begin if (FGroupIndex <> 0) and (Parent <> nil) then with Parent do for I := 0 to ControlCount - 1 do begin C := Controls[I]; if (C <> Self) and (C is TTBXCustomButton) then with TTBXCustomButton(C) do if FGroupIndex = Self.FGroupIndex then begin if Self.Checked and FChecked then begin FChecked := False; Invalidate; end; FAllowAllUnchecked := Self.AllowAllUnchecked; end; end; end; procedure TTBXCustomButton.WMCancelMode(var Message: TWMCancelMode); begin FRepeatTimer.Free; FRepeatTimer := nil; MouseLeft; end; procedure TTBXCustomButton.WMLButtonDblClk(var Message: TWMLButtonDblClk); begin Perform(WM_LBUTTONDOWN, Message.Keys, Longint(Message.Pos)); end; //----------------------------------------------------------------------------// procedure TTBXCustomButton.WMNCHitTest(var Message: TWMNCHitTest); var P: TPoint; R: TRect; begin inherited; if not (csDesigning in ComponentState) then begin P := ScreenToClient(SmallPointToPoint(Message.Pos)); R := ClientRect; ApplyMargins(R, Margins); if not PtInRect(R, P) then Message.Result := HTTRANSPARENT; end; end; { TTBXAlignmentPanel } procedure TTBXAlignmentPanel.AdjustClientRect(var Rect: TRect); begin inherited AdjustClientRect(Rect); with Margins do begin Inc(Rect.Left, Left); Inc(Rect.Top, Top); Dec(Rect.Right, Right); Dec(Rect.Bottom, Bottom); end; end; constructor TTBXAlignmentPanel.Create(AOwner: TComponent); begin inherited; FMargins := TTBXControlMargins.Create; FMargins.OnChange := MarginsChangeHandler; end; destructor TTBXAlignmentPanel.Destroy; begin FMargins.Free; inherited; end; function TTBXAlignmentPanel.GetMinHeight: Integer; var I: Integer; Control: TControl; begin Result := 0; for I := 0 to ControlCount - 1 do begin Control := Controls[I]; if Control.Visible then if Control.Align in [alTop, alBottom] then Inc(Result, Control.Height) else if Control.Align = alClient then Inc(Result, GetMinControlHeight(Control)); end; Inc(Result, Margins.Top + Margins.Bottom); end; function TTBXAlignmentPanel.GetMinWidth: Integer; var I: Integer; Control: TControl; begin Result := 0; for I := 0 to ControlCount - 1 do begin Control := Controls[I]; if Control.Visible then if Control.Align in [alLeft, alRight] then Inc(Result, Control.Width) else if Control.Align = alClient then Inc(Result, GetMinControlWidth(Control)); end; Inc(Result, Margins.Left + Margins.Right); end; procedure TTBXAlignmentPanel.MarginsChangeHandler(Sender: TObject); begin Realign; Invalidate; end; procedure TTBXAlignmentPanel.Paint; var R: TRect; DC: HDC; begin if csDesigning in ComponentState then begin DC := Canvas.Handle; R := ClientRect; SaveDC(DC); InflateRect(R, -1, -1); with R do ExcludeClipRect(DC, Left, Top, Right, Bottom); InflateRect(R, 1, 1); DitherRect(DC, R, clBtnFace, clBtnShadow); RestoreDC(DC, -1); end; end; procedure TTBXAlignmentPanel.SetMargins(Value: TTBXControlMargins); begin FMargins.Assign(Value); end; //----------------------------------------------------------------------------// { TTBXCustomPageScroller } procedure TTBXCustomPageScroller.AdjustClientRect(var Rect: TRect); begin if Orientation = tpsoVertical then begin if tpsbPrev in FVisibleButtons then Dec(Rect.Top, ButtonSize); if tpsbNext in FVisibleButtons then Inc(Rect.Bottom, ButtonSize); OffsetRect(Rect, 0, -Position); if Range > Rect.Bottom - Rect.Top then Rect.Bottom := Rect.Top + Range; end else begin if tpsbPrev in FVisibleButtons then Dec(Rect.Left, ButtonSize); if tpsbNext in FVisibleButtons then Inc(Rect.Right, ButtonSize); OffsetRect(Rect, -Position, 0); if Range > Rect.Right - Rect.Left then Rect.Right := Rect.Left + Range; end; end; procedure TTBXCustomPageScroller.AlignControls(AControl: TControl; var ARect: TRect); begin CalcAutoRange; UpdateButtons; ARect := ClientRect; inherited AlignControls(AControl, ARect); end; function TTBXCustomPageScroller.AutoScrollEnabled: Boolean; begin Result := not AutoSize and not (DockSite and UseDockManager); end; procedure TTBXCustomPageScroller.BeginScrolling(HitTest: Integer); var Msg: TMsg; begin if HitTest = HTSCROLLPREV then FScrollDirection := -1 else FScrollDirection := 1; try SetCapture(Handle); FScrollCounter := FScrollDirection * 8; FScrollPending := True; FScrollTimer.Enabled := True; DrawNCArea(False, 0, 0); HandleScrollTimer; FScrollPending := True; FScrollTimer.Interval := ScrollDelay; while GetCapture = Handle do begin case Integer(GetMessage(Msg, 0, 0, 0)) of -1: Break; 0: begin PostQuitMessage(Msg.WParam); Break; end; end; case Msg.Message of WM_KEYDOWN, WM_KEYUP: if Msg.WParam = VK_ESCAPE then Break; WM_LBUTTONDOWN, WM_LBUTTONDBLCLK: begin Break; end; WM_LBUTTONUP: begin Break; end; WM_RBUTTONDOWN..WM_MBUTTONDBLCLK:; WM_TIMER: begin HandleScrollTimer; end; else TranslateMessage(Msg); DispatchMessage(Msg); end; end; finally StopScrolling; if GetCapture = Handle then ReleaseCapture; end; end; procedure TTBXCustomPageScroller.CalcAutoRange; var I: Integer; Bias: Integer; NewRange, AlignMargin: Integer; CW, CH: Integer; Control: TControl; begin if (FAutoRangeCount <= 0) and AutoRange then begin if AutoScrollEnabled then begin NewRange := 0; AlignMargin := 0; if Position > 0 then Bias := ButtonSize else Bias := 0; CW := ClientWidth; CH := ClientHeight; DisableAlign; for I := 0 to ControlCount - 1 do begin Control := Controls[I]; if Control.Visible or (csDesigning in Control.ComponentState) and not (csNoDesignVisible in Control.ControlStyle) then begin if Orientation = tpsoVertical then begin if Control.Align in [alTop, alBottom, alClient] then Control.Width := CW; case Control.Align of alTop, alNone: if (Control.Align = alTop) or (Control.Anchors * [akTop, akBottom] = [akTop]) then NewRange := Max(NewRange, Position + Control.Top + Control.Height + Bias); alBottom: Inc(AlignMargin, Control.Height); alClient: Inc(AlignMargin, GetMinControlHeight(Control)); end end else begin if Control.Align in [alLeft, alRight, alClient] then Control.Height := CH; case Control.Align of alLeft, alNone: if (Control.Align = alLeft) or (Control.Anchors * [akLeft, akRight] = [akLeft]) then NewRange := Max(NewRange, Position + Control.Left + Control.Width + Bias); alRight: Inc(AlignMargin, Control.Width); alClient: Inc(AlignMargin, GetMinControlWidth(Control)); end; end; end; end; EnableAlign; DoSetRange(NewRange + AlignMargin + Margin); end else DoSetRange(0); end; end; function TTBXCustomPageScroller.CalcClientArea: TRect; begin Result := ClientRect; if Orientation = tpsoVertical then begin if tpsbPrev in FVisibleButtons then Dec(Result.Top, ButtonSize); if tpsbNext in FVisibleButtons then Inc(Result.Bottom, ButtonSize); end else begin if tpsbPrev in FVisibleButtons then Dec(Result.Left, ButtonSize); if tpsbNext in FVisibleButtons then Inc(Result.Right, ButtonSize); end; end; function TTBXCustomPageScroller.CanAutoSize(var NewWidth, NewHeight: Integer): Boolean; begin Result := NewHeight > FButtonSize * 3; end; procedure TTBXCustomPageScroller.CMParentColorChanged(var Message: TMessage); begin if (Message.WParam = 0) then begin Message.WParam := 1; Message.LParam := GetEffectiveColor(Parent); end; inherited; end; procedure TTBXCustomPageScroller.ConstrainedResize(var MinWidth, MinHeight, MaxWidth, MaxHeight: Integer); begin // do not call inherited here end; constructor TTBXCustomPageScroller.Create(AOwner: TComponent); begin inherited; ControlStyle := ControlStyle + [csAcceptsControls, csClickEvents, csDoubleClicks]; FAutoScroll := True; FButtonSize := 10; FScrollTimer := TTimer.Create(Self); FScrollTimer.Enabled := False; FScrollTimer.Interval := 60; FScrollTimer.OnTimer := ScrollTimerTimer; Width := 64; Height := 64; end; procedure TTBXCustomPageScroller.CreateParams(var Params: TCreateParams); begin inherited CreateParams(Params); with Params.WindowClass do style := style and not (CS_HREDRAW or CS_VREDRAW); end; procedure TTBXCustomPageScroller.DisableAutoRange; begin Inc(FAutoRangeCount); end; procedure TTBXCustomPageScroller.DoSetRange(Value: Integer); begin FRange := Value; if FRange < 0 then FRange := 0; UpdateButtons; end; procedure TTBXCustomPageScroller.DrawNCArea(const DrawToDC: Boolean; const ADC: HDC; const Clip: HRGN); const CBtns: array [TTBXPageScrollerOrientation, Boolean] of Integer = ((PSBT_UP, PSBT_DOWN), (PSBT_LEFT, PSBT_RIGHT)); var DC: HDC; R, CR, BR: TRect; ACanvas: TCanvas; PrevBtnSize, NextBtnSize: Integer; begin if FVisibleButtons = [] then Exit; if not DrawToDC then DC := GetWindowDC(Handle) else DC := ADC; try GetWindowRect(Handle, R); OffsetRect(R, -R.Left, -R.Top); if not DrawToDC then begin SelectNCUpdateRgn(Handle, DC, Clip); CR := R; PrevBtnSize := 0; NextBtnSize := 0; if tpsbPrev in FVisibleButtons then PrevBtnSize := ButtonSize; if tpsbNext in FVisibleButtons then NextBtnSize := ButtonSize; if Orientation = tpsoVertical then begin Inc(CR.Top, PrevBtnSize); Dec(CR.Bottom, NextBtnSize); end else begin Inc(CR.Left, PrevBtnSize); Dec(CR.Right, NextBtnSize); end; with CR do ExcludeClipRect(DC, Left, Top, Right, Bottom); end; ACanvas := TCanvas.Create; try ACanvas.Handle := DC; ACanvas.Brush.Color := Color; ACanvas.FillRect(R); if tpsbPrev in FVisibleButtons then begin BR := R; if Orientation = tpsoVertical then BR.Bottom := BR.Top + ButtonSize else BR.Right := BR.Left + ButtonSize; CurrentTheme.PaintPageScrollButton(ACanvas, BR, CBtns[Orientation, False], FScrollDirection < 0); end; if tpsbNext in FVisibleButtons then begin BR := R; if Orientation = tpsoVertical then BR.Top := BR.Bottom - ButtonSize else BR.Left := BR.Right - ButtonSize; CurrentTheme.PaintPageScrollButton(ACanvas, BR, CBtns[Orientation, True], FScrollDirection > 0); end; finally ACanvas.Handle := 0; ACanvas.Free; end; finally if not DrawToDC then ReleaseDC(Handle, DC); end; end; procedure TTBXCustomPageScroller.EnableAutoRange; begin if FAutoRangeCount > 0 then begin Dec(FAutoRangeCount); if FAutoRangeCount = 0 then CalcAutoRange; end; end; procedure TTBXCustomPageScroller.HandleScrollTimer; var Pt: TPoint; R: TRect; OldPosition: Integer; OldDirection: Integer; begin GetCursorPos(Pt); GetWindowRect(Handle, R); if not PtInRect(R, Pt) then begin StopScrolling; end else if FScrollDirection = 0 then begin FScrollTimer.Enabled := False; FScrollCounter := 0; end else begin OldPosition := Position; OldDirection := FScrollDirection; if ((FScrollDirection > 0) and (FScrollCounter < 0)) or ((FScrollDirection < 0) and (FScrollCounter > 0)) then FScrollCounter := 0; if FScrollDirection > 0 then Inc(FScrollCounter) else Dec(FScrollCounter); Position := Position + FScrollCounter; if Position = OldPosition then begin ReleaseCapture; FScrollTimer.Enabled := False; DrawNCArea(False, 0, 0); end else begin if FScrollPending or (FScrollDirection * OldDirection <= 0) or (FScrollDirection * OldDirection <= 0) then DrawNCArea(False, 0, 0); end; end; if FScrollPending then FScrollTimer.Interval := ScrollInterval; FScrollPending := False; end; function TTBXCustomPageScroller.IsRangeStored: Boolean; begin Result := not AutoRange; end; procedure TTBXCustomPageScroller.Loaded; begin inherited; UpdateButtons; end; procedure TTBXCustomPageScroller.RecalcNCArea; begin SetWindowPos(Handle, 0, 0, 0, 0, 0, SWP_FRAMECHANGED or SWP_NOACTIVATE or SWP_NOZORDER or SWP_NOMOVE or SWP_NOSIZE); end; procedure TTBXCustomPageScroller.Resizing; begin // do nothing by default end; procedure TTBXCustomPageScroller.ScrollTimerTimer(Sender: TObject); begin HandleScrollTimer; end; procedure TTBXCustomPageScroller.ScrollToCenter(ARect: TRect); var X, Y: Integer; begin if Orientation = tpsoVertical then begin if ARect.Bottom - ARect.Top < Range then Y := (ARect.Top + ARect.Bottom) div 2 else Y := ARect.Top; Position := Position + Y - Height div 2; end else begin if ARect.Right - ARect.Left < Range then X := (ARect.Left + ARect.Right) div 2 else X := ARect.Left; Position := Position + X - Width div 2; end; end; procedure TTBXCustomPageScroller.ScrollToCenter(AControl: TControl); var R: TRect; begin R := AControl.ClientRect; R.TopLeft := ScreenToClient(AControl.ClientToScreen(R.TopLeft)); R.BottomRight := ScreenToClient(AControl.ClientToScreen(R.BottomRight)); ScrollToCenter(R); end; procedure TTBXCustomPageScroller.SetAutoRange(Value: Boolean); begin if FAutoRange <> Value then begin FAutoRange := Value; if Value then CalcAutoRange else Range := 0; end; end; procedure TTBXCustomPageScroller.SetButtonSize(Value: Integer); begin if FButtonSize <> Value then begin FButtonSize := Value; UpdateButtons; end; end; procedure TTBXCustomPageScroller.SetOrientation(Value: TTBXPageScrollerOrientation); begin if Orientation <> Value then begin FOrientation := Value; Realign; end; end; procedure TTBXCustomPageScroller.SetPosition(Value: Integer); var OldPos: Integer; begin if csReading in ComponentState then FPosition := Value else begin ValidatePosition(Value); if FPosition <> Value then begin OldPos := FPosition; FPosition := Value; if OldPos > 0 then Inc(OldPos, ButtonSize); if Value > 0 then Inc(Value, ButtonSize); if Orientation = tpsoHorizontal then ScrollBy(OldPos - Value, 0) else ScrollBy(0, OldPos - Value); UpdateButtons; end; end; end; procedure TTBXCustomPageScroller.SetRange(Value: Integer); begin FAutoRange := False; DoSetRange(Value); end; procedure TTBXCustomPageScroller.StopScrolling; begin if (FScrollDirection <> 0) or (FScrollCounter <> 0) or (FScrollTimer.Enabled) then begin FScrollDirection := 0; FScrollCounter := 0; FScrollTimer.Enabled := False; if HandleAllocated and IsWindowVisible(Handle) then DrawNCArea(False, 0, 0); end; end; procedure TTBXCustomPageScroller.UpdateButtons; var Sz: Integer; OldVisibleButtons: TTBXPageScrollerButtons; RealignNeeded: Boolean; begin RealignNeeded := False; if not FUpdatingButtons and HandleAllocated then try FUpdatingButtons := True; if Orientation = tpsoHorizontal then Sz := Width else Sz := Height; OldVisibleButtons := FVisibleButtons; FVisibleButtons := []; FPosRange := Range - Sz; if FPosRange < 0 then FPosRange := 0; if FPosition > FPosRange - 1 then begin FPosition := FPosRange; RealignNeeded := True; end; if Sz > ButtonSize * 3 then begin if Position > 0 then Include(FVisibleButtons, tpsbPrev); if Range - Position > Sz then Include(FVisibleButtons, tpsbNext); end; if FVisibleButtons <> OldVisibleButtons then begin RecalcNCArea; RealignNeeded := True; end; finally FUpdatingButtons := False; if RealignNeeded then Realign; end; end; procedure TTBXCustomPageScroller.ValidatePosition(var NewPos: Integer); begin if NewPos < 0 then NewPos := 0; if NewPos > FPosRange then NewPos := FPosRange; end; procedure TTBXCustomPageScroller.WMEraseBkgnd(var Message: TWmEraseBkgnd); begin if Color = clNone then begin DrawParentBackground(Self, Message.DC, ClientRect); Message.Result := 1; end else inherited; end; procedure TTBXCustomPageScroller.WMMouseMove(var Message: TWMMouseMove); begin if AutoScroll then StopScrolling; inherited; end; procedure TTBXCustomPageScroller.WMNCCalcSize(var Message: TWMNCCalcSize); begin with Message.CalcSize_Params^ do begin if Orientation = tpsoVertical then begin if tpsbPrev in FVisibleButtons then Inc(rgrc[0].Top, ButtonSize); if tpsbNext in FVisibleButtons then Dec(rgrc[0].Bottom, ButtonSize); end else begin if tpsbPrev in FVisibleButtons then Inc(rgrc[0].Left, ButtonSize); if tpsbNext in FVisibleButtons then Dec(rgrc[0].Right, ButtonSize); end; Message.Result := 0; end; end; procedure TTBXCustomPageScroller.WMNCHitTest(var Message: TWMNCHitTest); var Pt: TPoint; R: TRect; begin DefaultHandler(Message); with Message do if Result <> HTCLIENT then begin Pt := SmallPointToPoint(Pos); GetWindowRect(Handle, R); if PtInRect(R, Pt) then begin if (tpsbPrev in FVisibleButtons) then begin if Orientation = tpsoVertical then begin if Pt.Y < R.Top + ButtonSize then Result := HTSCROLLPREV end else begin if Pt.X < R.Left + ButtonSize then Result := HTSCROLLPREV end; end; if (tpsbNext in FVisibleButtons) then begin if Orientation = tpsoVertical then begin if Pt.Y >= R.Bottom - ButtonSize then Result := HTSCROLLNEXT; end else begin if Pt.X >= R.Right - ButtonSize then Result := HTSCROLLNEXT; end; end; end; end; end; procedure TTBXCustomPageScroller.WMNCLButtonDown(var Message: TWMNCLButtonDown); begin if (Win32MajorVersion >= 5) or (Win32MajorVersion = 4) and (Win32MinorVersion >= 10) then CallTrackMouseEvent(Handle, TME_LEAVE or $10 {TME_NONCLIENT}); if not AutoScroll and (Message.HitTest in [HTSCROLLPREV, HTSCROLLNEXT]) then BeginScrolling(Message.HitTest) else inherited; end; procedure TTBXCustomPageScroller.WMNCMouseLeave(var Message: TMessage); begin if AutoScroll then StopScrolling; inherited; end; procedure TTBXCustomPageScroller.WMNCMouseMove(var Message: TWMNCMouseMove); var OldScrollDirection: Integer; begin if (Win32MajorVersion >= 5) or (Win32MajorVersion = 4) and (Win32MinorVersion >= 10) then CallTrackMouseEvent(Handle, TME_LEAVE or $10 {TME_NONCLIENT}); if AutoScroll then begin OldScrollDirection := FScrollDirection; case Message.HitTest of HTSCROLLPREV: FScrollDirection := -1; HTSCROLLNEXT: FScrollDirection := 1; else StopScrolling; inherited; Exit; end; if OldScrollDirection <> FScrollDirection then begin FScrollCounter := 0; FScrollPending := True; FScrollTimer.Interval := ScrollDelay; FScrollTimer.Enabled := True; DrawNCArea(False, 0, 0); end; end; end; procedure TTBXCustomPageScroller.WMNCPaint(var Message: TMessage); begin DrawNCArea(False, 0, HRGN(Message.WParam)); end; procedure TTBXCustomPageScroller.WMSize(var Message: TWMSize); begin FUpdatingButtons := True; try CalcAutoRange; finally FUpdatingButtons := False; end; Inc(FAutoRangeCount); inherited; Resizing; Dec(FAutoRangeCount); end; { TTBXCustomCheckBox } procedure TTBXCustomCheckBox.Click; begin Toggle; Invalidate; inherited; end; procedure TTBXCustomCheckBox.CMDialogChar(var Message: TCMDialogChar); begin with Message do if Enabled and ShowAccelChar and IsAccel(CharCode, GetLabelText) and CanFocus and Visible then begin Click; Result := 1; end else inherited; end; procedure TTBXCustomCheckBox.CMDialogKey(var Message: TCMDialogKey); begin with Message do if (CharCode = VK_RETURN) and Focused and (KeyDataToShiftState(Message.KeyData) = []) then begin Click; Result := 1; end else inherited; end; procedure TTBXCustomCheckBox.CNCommand(var Message: TWMCommand); begin if Message.NotifyCode = BN_CLICKED then Toggle; end; constructor TTBXCustomCheckBox.Create(AOwner: TComponent); begin inherited; SmartFocus := True; SpaceAsClick := True; TabStop := True; end; procedure TTBXCustomCheckBox.DoAdjustHeight(ACanvas: TCanvas; var NewHeight: Integer); begin inherited DoAdjustHeight(ACanvas, NewHeight); if NewHeight < GetGlyphSize + 4 then NewHeight := GetGlyphSize + 4; end; procedure TTBXCustomCheckBox.DoChange; begin if Assigned(FOnChange) then FOnChange(Self); end; procedure TTBXCustomCheckBox.DoMouseEnter; begin inherited; Invalidate; end; procedure TTBXCustomCheckBox.DoMouseLeave; begin inherited; Invalidate; end; function TTBXCustomCheckBox.DoSetState(var NewState: TCheckBoxState): Boolean; begin Result := True; end; function TTBXCustomCheckBox.GetChecked: Boolean; begin Result := State = cbChecked; end; function TTBXCustomCheckBox.GetFocusRect(const R: TRect): TRect; const Alignments: array [TLeftRight] of Word = (DT_LEFT, DT_RIGHT); WordWraps: array [TTextWrapping] of Integer = (DT_SINGLELINE or DT_VCENTER, DT_SINGLELINE or DT_VCENTER or DT_END_ELLIPSIS, DT_SINGLELINE or DT_VCENTER or DT_PATH_ELLIPSIS, DT_WORDBREAK); var TR: TRect; begin TR := R; ApplyMargins(TR, GetTextMargins); DoDrawText(Canvas, TR, (DT_EXPANDTABS or DT_CALCRECT) or WordWraps[Wrapping] or Alignments[Alignment]); Result := R; Result.Right := TR.Right + 2; Result.Left := TR.Left - 2; end; function TTBXCustomCheckBox.GetGlyphSize: Integer; begin Result := 13; end; function TTBXCustomCheckBox.GetTextAlignment: TAlignment; begin Result := taLeftJustify; end; function TTBXCustomCheckBox.GetTextMargins: TRect; begin Result := Rect(2, 2, 2, 2); with Result do if GetRealAlignment(Self) = taLeftJustify then Inc(Left, GetGlyphSize + 6) else Inc(Right, GetGlyphSize + 6); end; procedure TTBXCustomCheckBox.Paint; const EnabledState: array [Boolean] of Integer = (PFS_DISABLED, 0); StateFlags: array [TCheckBoxState] of Integer = (0, PFS_CHECKED, PFS_MIXED); HotState: array [Boolean] of Integer = (0, PFS_HOT); PushedState: array [Boolean] of Integer = (0, PFS_PUSHED); FocusedState: array [Boolean] of Integer = (0, PFS_FOCUSED); var Rect: TRect; Sz, Flags: Integer; begin inherited; with Canvas do begin Rect := ClientRect; ApplyMargins(Rect, Margins); Sz := GetGlyphSize; if Alignment = taLeftJustify then Rect.Right := Rect.Left + GetGlyphSize else Rect.Left := Rect.Right - GetGlyphSize; Rect.Top := (Rect.Top + Rect.Bottom + 1 - Sz) div 2; Rect.Bottom := Rect.Top + Sz; Brush.Color := clBtnShadow; Flags := EnabledState[Enabled]; if Enabled then Flags := Flags or StateFlags[State] or HotState[MouseInControl] or PushedState[Pushed and MouseInControl] or FocusedState[Focused]; CurrentTheme.PaintFrameControl(Canvas, Rect, PFC_CHECKBOX, Flags, nil); end; end; procedure TTBXCustomCheckBox.SetChecked(Value: Boolean); begin if Value then State := cbChecked else State := cbUnchecked; end; procedure TTBXCustomCheckBox.SetState(Value: TCheckBoxState); begin if (FState <> Value) and DoSetState(Value) then begin FState := Value; Invalidate; DoChange; end; end; procedure TTBXCustomCheckBox.Toggle; begin case State of cbUnchecked: if AllowGrayed then State := cbGrayed else State := cbChecked; cbChecked: State := cbUnchecked; cbGrayed: State := cbChecked; end; end; procedure TTBXCustomCheckBox.WMNCHitTest(var Message: TWMNCHitTest); var P: TPoint; R: TRect; SL, SR: Integer; begin inherited; if not (csDesigning in ComponentState) then begin P := ScreenToClient(SmallPointToPoint(Message.Pos)); R := ClientRect; ApplyMargins(R, Margins); SL := R.Left; SR := R.Right; R := GetFocusRect(R); if GetRealAlignment(Self) = taLeftJustify then R.Left := SL else R.Right := SR; if not PtInRect(R, P) then Message.Result := HTTRANSPARENT; end; end; { TTBXCustomRadioButton } procedure TTBXCustomRadioButton.Click; begin if not Checked then Checked := True; Invalidate; inherited; end; procedure TTBXCustomRadioButton.CMDialogChar(var Message: TCMDialogChar); begin with Message do if Enabled and ShowAccelChar and IsAccel(CharCode, GetLabelText) and CanFocus and Visible then begin Click; Result := 1; end else inherited; end; procedure TTBXCustomRadioButton.CNCommand(var Message: TWMCommand); begin if Message.NotifyCode = BN_CLICKED then Checked := not Checked; end; constructor TTBXCustomRadioButton.Create(AOwner: TComponent); begin inherited; SmartFocus := True; SpaceAsClick := True; TabStop := True; end; procedure TTBXCustomRadioButton.DoAdjustHeight(ACanvas: TCanvas; var NewHeight: Integer); begin inherited DoAdjustHeight(ACanvas, NewHeight); if NewHeight < GetGlyphSize + 4 then NewHeight := GetGlyphSize + 4; end; procedure TTBXCustomRadioButton.DoChange; begin if Assigned(FOnChange) then FOnChange(Self); end; procedure TTBXCustomRadioButton.DoMouseEnter; begin inherited; Invalidate; end; procedure TTBXCustomRadioButton.DoMouseLeave; begin inherited; Invalidate; end; function TTBXCustomRadioButton.DoSetChecked(var Value: Boolean): Boolean; begin Result := True; end; function TTBXCustomRadioButton.GetFocusRect(const R: TRect): TRect; const Alignments: array [TLeftRight] of Word = (DT_LEFT, DT_RIGHT); WordWraps: array [TTextWrapping] of Integer = (DT_SINGLELINE or DT_VCENTER, DT_SINGLELINE or DT_VCENTER or DT_END_ELLIPSIS, DT_SINGLELINE or DT_VCENTER or DT_PATH_ELLIPSIS, DT_WORDBREAK); var TR: TRect; begin TR := R; ApplyMargins(TR, GetTextMargins); DoDrawText(Canvas, TR, (DT_EXPANDTABS or DT_CALCRECT) or WordWraps[Wrapping] or Alignments[Alignment]); Result := R; Result.Right := TR.Right + 2; Result.Left := TR.Left - 2; end; function TTBXCustomRadioButton.GetGlyphSize: Integer; begin Result := 13; end; function TTBXCustomRadioButton.GetTextAlignment: TAlignment; begin Result := taLeftJustify; end; function TTBXCustomRadioButton.GetTextMargins: TRect; begin Result := Rect(2, 2, 2, 2); with Result do if GetRealAlignment(Self) = taLeftJustify then Inc(Left, GetGlyphSize + 6) else Inc(Right, GetGlyphSize + 6); end; procedure TTBXCustomRadioButton.Paint; const EnabledState: array [Boolean] of Integer = (PFS_DISABLED, 0); CheckedState: array [Boolean] of Integer = (0, PFS_CHECKED); HotState: array [Boolean] of Integer = (0, PFS_HOT); PushedState: array [Boolean] of Integer = (0, PFS_PUSHED); FocusedState: array [Boolean] of Integer = (0, PFS_FOCUSED); var Rect: TRect; Sz, Flags: Integer; begin inherited; with Canvas do begin Rect := ClientRect; with Margins do begin Inc(Rect.Left, Left); Inc(Rect.Top, Top); Dec(Rect.Right, Right); Dec(Rect.Bottom, Bottom); end; Sz := GetGlyphSize; if Alignment = taLeftJustify then Rect.Right := Rect.Left + GetGlyphSize else Rect.Left := Rect.Right - GetGlyphSize; Rect.Top := (Rect.Top + Rect.Bottom + 1 - Sz) div 2; Rect.Bottom := Rect.Top + Sz; Brush.Color := clBtnShadow; Flags := EnabledState[Enabled]; if Enabled then Flags := Flags or CheckedState[Checked] or HotState[MouseInControl] or PushedState[Pushed and MouseInControl] or FocusedState[Focused]; CurrentTheme.PaintFrameControl(Canvas, Rect, PFC_RADIOBUTTON, Flags, nil); end; end; procedure TTBXCustomRadioButton.SetChecked(Value: Boolean); begin if (Value <> FChecked) and DoSetChecked(Value) then begin FChecked := Value; TabStop := Value; if Value then TurnSiblingsOff; Invalidate; DoChange; end; end; procedure TTBXCustomRadioButton.SetGroupIndex(Value: Integer); begin FGroupIndex := Value; if Checked then TurnSiblingsOff; end; procedure TTBXCustomRadioButton.TurnSiblingsOff; var I: Integer; Sibling: TControl; begin if Parent <> nil then with Parent do for I := 0 to ControlCount - 1 do begin Sibling := Controls[I]; if (Sibling <> Self) and (Sibling is TTBXCustomRadioButton) then with TTBXCustomRadioButton(Sibling) do begin if GroupIndex = Self.GroupIndex then SetChecked(False); end; end; end; procedure TTBXCustomRadioButton.WMNCHitTest(var Message: TWMNCHitTest); var P: TPoint; R: TRect; SL, SR: Integer; begin inherited; if not (csDesigning in ComponentState) then begin P := ScreenToClient(SmallPointToPoint(Message.Pos)); R := ClientRect; ApplyMargins(R, Margins); SL := R.Left; SR := R.Right; R := GetFocusRect(R); if GetRealAlignment(Self) = taLeftJustify then R.Left := SL else R.Right := SR; if not PtInRect(R, P) then Message.Result := HTTRANSPARENT; end; end; end.