unit TB97; { Toolbar97 version 1.63 (with Delphi 4 support) Copyright (C) 1998 by Jordan Russell e-mail: jordanr@iname.com home page: http://www.connect.net/jordanr/ (alternate address: http://www.digicron.com/jordanr/) *PLEASE NOTE* Before making any bug reports please first verify you are using the latest version by checking my home page. And if you do report a bug, please, if applicable, include a code sample. You are free to use Toolbar97 in compiled form for any purpose. However, use in commercial or shareware applications requires registration. The Toolbar97 source code or DCU, in whole or in part, modified or unmodified, may not be redistributed for profit or as part of another commercial or shareware software package without express written permission from me. This code is distributed "as is" without any warranties, express or implied. Notes: - I cannot support modified versions of this code. So if you encounter a possible bug while using a modified version, always first revert back to the my original code before making an attempt to contact me. - While debugging the toolbar code you might want to enable the 'TB97DisableLock' conditional define, as described below. - In the WM_NCPAINT handlers, GetWindowRect is used to work around a possible VCL problem. The Width, Height, and BoundsRect properties are sometimes wrong. So it avoids any use of these properties in the WM_NCPAINT handlers. - In case you are unsure of its meaning, NewStyleControls is a VCL variable set to True at application startup if the user is running Windows 95 or NT 4.0 or later. } {$IFNDEF WIN32} Delphi 1 is not supported. {$ENDIF} {$ALIGN ON} {$BOOLEVAL OFF} {$LONGSTRINGS ON} {$WRITEABLECONST ON} {x$DEFINE TB97DisableLock} { Remove the 'x' to enable the define. It will disable calls to LockWindowUpdate, which it calls to disable screen updates while dragging. You should temporarily enable that while debugging so you are able to see your code window if you have something like a breakpoint that's set inside the dragging routines } { Determine Delphi/C++Builder version } {$IFNDEF VER90} { if it's not Delphi 2.0 } {$IFNDEF VER93} { and it's not C++Builder 1.0 } {$DEFINE TB97Delphi3orHigher} { then it must be Delphi 3 or C++Builder 3 } {$ENDIF} {$ENDIF} interface uses Windows, Messages, Classes, Controls, Forms, Menus, Graphics, Buttons, StdCtrls, ExtCtrls; const Toolbar97Version = '1.63'; WM_TB97DoneCreating = WM_USER + 5038; { used internally } WM_TB97DoneCreating_Magic = $73A590F4; { used internally } WM_TB97PaintDockedNCArea = WM_USER + 5039; { used internally } type { TDock97 } TDockBoundLinesValues = (blTop, blBottom, blLeft, blRight); TDockBoundLines = set of TDockBoundLinesValues; TDockPosition = (dpTop, dpBottom, dpLeft, dpRight); TDockType = (dtNotDocked, dtTopBottom, dtLeftRight); TDockableTo = set of TDockPosition; TCustomToolWindow97 = class; TInsertRemoveEvent = procedure(Sender: TObject; Inserting: Boolean; Bar: TCustomToolWindow97) of object; TRequestDockEvent = procedure(Sender: TObject; Bar: TCustomToolWindow97; var Accept: Boolean) of object; TDock97 = class(TCustomControl) private { Property values } FPosition: TDockPosition; FAllowDrag: Boolean; FBoundLines: TDockBoundLines; FBkg, FBkgCache: TBitmap; FBkgTransparent, FBkgOnToolbars: Boolean; FFixAlign: Boolean; FLimitToOneRow: Boolean; FOnInsertRemoveBar: TInsertRemoveEvent; FOnRequestDock: TRequestDockEvent; FOnResize: TNotifyEvent; { Internal } DisableArrangeToolbars: Integer; { Increment to disable ArrangeToolbars } DockList: TList; { List of the visible toolbars docked. Items are casted in TCustomToolWindow97's. But, at design time, all docked toolbars are here regardless of visibility } RowSizes: TList; { List of the width or height of each row, depending on what Position is set to. Items are casted info Longint's } { Property access methods } procedure SetAllowDrag (Value: Boolean); procedure SetBackground (Value: TBitmap); procedure SetBackgroundOnToolbars (Value: Boolean); procedure SetBackgroundTransparent (Value: Boolean); procedure SetBoundLines (Value: TDockBoundLines); procedure SetFixAlign (Value: Boolean); procedure SetPosition (Value: TDockPosition); function GetToolbarCount: Integer; function GetToolbars (Index: Integer): TCustomToolWindow97; { Internal } procedure FreeRowInfo; function GetRowOf (const XY: Integer; var Before: Boolean): Integer; function GetDesignModeRowOf (const XY: Integer): Integer; function GetHighestRow: Integer; function GetNumberOfToolbarsOnRow (const Row: Integer; const NotIncluding: TCustomToolWindow97): Integer; procedure RemoveBlankRows; procedure InsertRowBefore (const BeforeRow: Integer); procedure BuildRowInfo; procedure ChangeDockList (const Insert: Boolean; const Bar: TCustomToolWindow97; const IsVisible: Boolean); procedure ChangeWidthHeight (const IsClientWidthAndHeight: Boolean; NewWidth, NewHeight: Integer); procedure ArrangeToolbars; procedure DrawBackground (const DC: HDC; const IntersectClippingRect: TRect; const ExcludeClippingRect: PRect; const DrawRect: TRect); procedure InvalidateBackgrounds; procedure BackgroundChanged (Sender: TObject); function UsingBackground: Boolean; { Messages } procedure CMColorChanged (var Message: TMessage); message CM_COLORCHANGED; procedure CMSysColorChange (var Message: TMessage); message CM_SYSCOLORCHANGE; procedure WMMove (var Message: TWMMove); message WM_MOVE; procedure WMSize (var Message: TWMSize); message WM_SIZE; procedure WMNCCalcSize (var Message: TWMNCCalcSize); message WM_NCCALCSIZE; procedure WMNCPaint (var Message: TMessage); message WM_NCPAINT; protected procedure AlignControls (AControl: TControl; var Rect: TRect); override; function GetPalette: HPALETTE; override; procedure Loaded; override; procedure SetParent (AParent: TWinControl); override; procedure Paint; override; procedure VisibleChanging; override; public constructor Create (AOwner: TComponent); override; procedure CreateParams (var Params: TCreateParams); override; destructor Destroy; override; function GetRowSize (const Row: Integer; const DefaultToolbar: TCustomToolWindow97): Integer; property ToolbarCount: Integer read GetToolbarCount; property Toolbars[Index: Integer]: TCustomToolWindow97 read GetToolbars; published property AllowDrag: Boolean read FAllowDrag write SetAllowDrag default True; property Background: TBitmap read FBkg write SetBackground; property BackgroundOnToolbars: Boolean read FBkgOnToolbars write SetBackgroundOnToolbars default True; property BackgroundTransparent: Boolean read FBkgTransparent write SetBackgroundTransparent default False; property BoundLines: TDockBoundLines read FBoundLines write SetBoundLines default []; property Color default clBtnFace; property FixAlign: Boolean read FFixAlign write SetFixAlign default False; property LimitToOneRow: Boolean read FLimitToOneRow write FLimitToOneRow default False; property PopupMenu; property Position: TDockPosition read FPosition write SetPosition default dpTop; property OnInsertRemoveBar: TInsertRemoveEvent read FOnInsertRemoveBar write FOnInsertRemoveBar; property OnRequestDock: TRequestDockEvent read FOnRequestDock write FOnRequestDock; property OnResize: TNotifyEvent read FOnResize write FOnResize; end; { TCustomToolWindow97 } TToolWindowArrangeType = (atNone, atMoveControls, atMoveControlsAndResize); TToolWindowParams = record CallAlignControls, ResizeEightCorner, ResizeClipCursor: Boolean; end; TPositionReadIntProc = function(const ToolbarName, Value: String; const Default: Longint; const ExtraData: Pointer): Longint; TPositionReadStringProc = function(const ToolbarName, Value, Default: String; const ExtraData: Pointer): String; TPositionWriteIntProc = procedure(const ToolbarName, Value: String; const Data: Longint; const ExtraData: Pointer); TPositionWriteStringProc = procedure(const ToolbarName, Value, Data: String; const ExtraData: Pointer); TCustomToolWindow97 = class(TCustomControl) private { Property variables } FDockPos, FDockRow: Integer; FDocked: Boolean; FDockedTo, FDefaultDock: TDock97; FOnClose, FOnDockChanged, FOnDockChanging, FOnRecreated, FOnRecreating, FOnResize, FOnVisibleChanged: TNotifyEvent; FActivateParent, FHideWhenInactive, FCloseButton, FFullSize, FResizable, FDragHandle: Boolean; FDockableTo: TDockableTo; FParams: TToolWindowParams; { Misc. } FUpdatingBounds, { Incremented while internally changing the bounds. This allows it to move the toolbar freely in design mode and prevents the SizeChanging protected method from begin called } FDisableArrangeControls, { Incremented to disable ArrangeControls } FHidden: Integer; { Incremented while the toolbar is temporarily hidden } FArrangeNeeded: Boolean; FInactiveCaption: Boolean; { True when the caption of the toolbar is currently the inactive color } FFloatingTopLeft: TPoint; { When floating. These are not used (and FloatParent isn't created) in design mode } FloatParent: TWinControl; { The actual Parent of the toolbar when it is floating } MDIParentForm: TForm; { Either the owner form, or the MDI parent if the owner form is an MDI child form } NotOnScreen: Boolean; { True if the toolbar is currently hidden from view. This is True while the toolbar is creating or when the application is deactivated } CloseButtonDown: Boolean; { True if Close button is currently depressed } { Property access methods } procedure SetCloseButton (Value: Boolean); procedure SetDefaultDock (Value: TDock97); procedure SetDockedTo (Value: TDock97); procedure SetDockPos (Value: Integer); procedure SetDockRow (Value: Integer); procedure SetDragHandle (Value: Boolean); procedure SetFullSize (Value: Boolean); procedure SetResizable (Value: Boolean); { Internal } procedure MoveOnScreen (const OnlyIfFullyOffscreen: Boolean); procedure CustomArrangeControls (const ArrangeType: TToolWindowArrangeType; const WasDockedTo, DockingTo: TDock97; var NewClientSize: TPoint); procedure ArrangeControls; procedure DrawDraggingOutline (const DC: HDC; const NewRect, OldRect: PRect; const NewDocking, OldDocking: Boolean); class function NewMainWindowHook (var Message: TMessage): Boolean; procedure BeginMoving (const InitX, InitY: Integer); procedure BeginSizing (const HitTestValue: Integer; var Accept: Boolean; var NewRect: TRect); procedure DrawFloatingNCArea (const Clip: HRGN; const RedrawBorder, RedrawCaption, RedrawCloseButton: Boolean); procedure DrawDockedNCArea (const Clip: HRGN); procedure InvalidateDockedNCArea; procedure ValidateDockedNCArea; procedure SetNotOnScreen (const Value: Boolean); procedure SetInactiveCaption (const Value: Boolean); { Messages } procedure CMColorChanged (var Message: TMessage); message CM_COLORCHANGED; procedure CMTextChanged (var Message: TMessage); message CM_TEXTCHANGED; procedure CMShowingChanged (var Message: TMessage); message CM_SHOWINGCHANGED; procedure CMVisibleChanged (var Message: TMessage); message CM_VISIBLECHANGED; procedure WMActivate (var Message: TWMActivate); message WM_ACTIVATE; procedure WMClose (var Message: TWMClose); message WM_CLOSE; procedure WMGetMinMaxInfo (var Message: TWMGetMinMaxInfo); message WM_GETMINMAXINFO; procedure WMMove (var Message: TWMMove); message WM_MOVE; procedure WMMouseActivate (var Message: TWMMouseActivate); message WM_MOUSEACTIVATE; procedure WMNCCalcSize (var Message: TWMNCCalcSize); message WM_NCCALCSIZE; procedure WMNCHitTest (var Message: TWMNCHitTest); message WM_NCHITTEST; procedure WMNCLButtonDown (var Message: TWMNCLButtonDown); message WM_NCLBUTTONDOWN; procedure WMNCPaint (var Message: TMessage); message WM_NCPAINT; procedure WMTB97PaintDockedNCArea (var Message: TMessage); message WM_TB97PaintDockedNCArea; procedure WMSize (var Message: TWMSize); message WM_SIZE; protected property ActivateParent: Boolean read FActivateParent write FActivateParent default True; property Color default clBtnFace; property CloseButton: Boolean read FCloseButton write SetCloseButton default True; property DefaultDock: TDock97 read FDefaultDock write SetDefaultDock; property DockableTo: TDockableTo read FDockableTo write FDockableTo default [dpTop, dpBottom, dpLeft, dpRight]; property DockedTo: TDock97 read FDockedTo write SetDockedTo; property DockPos: Integer read FDockPos write SetDockPos default -1; property DockRow: Integer read FDockRow write SetDockRow default 0; property DragHandle: Boolean read FDragHandle write SetDragHandle default True; property FullSize: Boolean read FFullSize write SetFullSize default False; property HideWhenInactive: Boolean read FHideWhenInactive write FHideWhenInactive default True; property Params: TToolWindowParams read FParams; property Resizable: Boolean read FResizable write SetResizable default True; property OnClose: TNotifyEvent read FOnClose write FOnClose; property OnDockChanged: TNotifyEvent read FOnDockChanged write FOnDockChanged; property OnDockChanging: TNotifyEvent read FOnDockChanging write FOnDockChanging; property OnRecreated: TNotifyEvent read FOnRecreated write FOnRecreated; property OnRecreating: TNotifyEvent read FOnRecreating write FOnRecreating; property OnResize: TNotifyEvent read FOnResize write FOnResize; property OnVisibleChanged: TNotifyEvent read FOnVisibleChanged write FOnVisibleChanged; { Overridden methods } procedure AlignControls (AControl: TControl; var Rect: TRect); override; procedure CreateParams (var Params: TCreateParams); override; function GetPalette: HPALETTE; override; procedure Loaded; override; procedure MouseDown (Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; procedure Notification (AComponent: TComponent; Operation: TOperation); override; procedure Paint; override; function PaletteChanged (Foreground: Boolean): Boolean; override; procedure SetParent (AParent: TWinControl); override; { Methods accessible to descendants } procedure ReadPositionData (const ReadIntProc: TPositionReadIntProc; const ReadStringProc: TPositionReadStringProc; const ExtraData: Pointer); dynamic; procedure DoneReadingPositionData; dynamic; procedure WritePositionData (const WriteIntProc: TPositionWriteIntProc; const WriteStringProc: TPositionWriteStringProc; const ExtraData: Pointer); dynamic; procedure GetParams (var Params: TToolWindowParams); dynamic; procedure ResizeBegin (HitTestValue: Integer); dynamic; procedure ResizeTrack (var Rect: TRect; const OrigRect: TRect); dynamic; procedure ResizeEnd (Accept: Boolean); dynamic; procedure GetBarSize (var ASize: Integer; const DockType: TDockType); virtual; abstract; procedure GetDockRowSize (var AHeightOrWidth: Integer); procedure GetMinimumSize (var AClientWidth, AClientHeight: Integer); virtual; abstract; procedure InitializeOrdering; dynamic; procedure OrderControls (const CanMoveControls: Boolean; const WasDockedTo, DockingTo: TDock97; var NewClientSize: TPoint); virtual; abstract; procedure SizeChanging (const AWidth, AHeight: Integer); virtual; public property Docked: Boolean read FDocked; constructor Create (AOwner: TComponent); override; destructor Destroy; override; procedure SetBounds (ALeft, ATop, AWidth, AHeight: Integer); override; procedure BeginUpdate; procedure EndUpdate; published property Height stored False; property Width stored False; property ClientHeight stored True; property ClientWidth stored True; end; { TCustomToolbar97 } TCustomToolbar97 = class(TCustomToolWindow97) private FFloatingRightX: Integer; SizeData: Pointer; { Lists } SlaveInfo, { List of slave controls. Items are pointers to TSlaveInfo's } GroupInfo, { List of the control "groups". List items are pointers to TGroupInfo's } LineSeps, { List of the Y locations of line separators. Items are casted in TLineSep's } OrderList: TList; { List of the child controls, arranged using the current "OrderIndex" values } { Property access methods } function GetOrderIndex (Control: TControl): Integer; procedure SetOrderIndex (Control: TControl; Value: Integer); { Internal } function ShouldBeVisible (const Control: TControl; const LeftOrRight: Boolean; const SetIt: Boolean): Boolean; procedure FreeGroupInfo (const List: TList); procedure BuildGroupInfo (const List: TList; const TranslateSlave: Boolean; const OldDockType, NewDockType: TDockType); { Messages } procedure CMControlListChange (var Message: TCMControlListChange); message CM_CONTROLLISTCHANGE; protected procedure Paint; override; procedure ReadPositionData (const ReadIntProc: TPositionReadIntProc; const ReadStringProc: TPositionReadStringProc; const ExtraData: Pointer); override; procedure WritePositionData (const WriteIntProc: TPositionWriteIntProc; const WriteStringProc: TPositionWriteStringProc; const ExtraData: Pointer); override; procedure GetParams (var Params: TToolWindowParams); override; procedure ResizeBegin (HitTestValue: Integer); override; procedure ResizeTrack (var Rect: TRect; const OrigRect: TRect); override; procedure ResizeEnd (Accept: Boolean); override; procedure GetBarSize (var ASize: Integer; const DockType: TDockType); override; procedure GetMinimumSize (var AClientWidth, AClientHeight: Integer); override; procedure InitializeOrdering; override; procedure OrderControls (const CanMoveControls: Boolean; const WasDockedTo, DockingTo: TDock97; var NewClientSize: TPoint); override; public property OrderIndex[Control: TControl]: Integer read GetOrderIndex write SetOrderIndex; constructor Create (AOwner: TComponent); override; destructor Destroy; override; procedure SetSlaveControl (const ATopBottom, ALeftRight: TControl); published property ClientHeight stored False; property ClientWidth stored False; end; { TToolbar97 } TToolbar97 = class(TCustomToolbar97) published property ActivateParent; property Caption; property Color; property CloseButton; property DefaultDock; property DockableTo; property DockedTo; property DockPos; property DockRow; property DragHandle; property FullSize; property HideWhenInactive; property ParentShowHint; property PopupMenu; property ShowHint; property TabOrder; property Visible; property OnClose; property OnDragDrop; property OnDragOver; property OnRecreated; property OnRecreating; property OnDockChanged; property OnDockChanging; property OnResize; property OnVisibleChanged; end; { TToolWindow97 } TToolWindow97 = class(TCustomToolWindow97) private FMinClientWidth, FMinClientHeight: Integer; FBarHeight, FBarWidth: Integer; protected procedure CreateParams (var Params: TCreateParams); override; procedure ReadPositionData (const ReadIntProc: TPositionReadIntProc; const ReadStringProc: TPositionReadStringProc; const ExtraData: Pointer); override; procedure WritePositionData (const WriteIntProc: TPositionWriteIntProc; const WriteStringProc: TPositionWriteStringProc; const ExtraData: Pointer); override; procedure GetBarSize (var ASize: Integer; const DockType: TDockType); override; procedure GetMinimumSize (var AClientWidth, AClientHeight: Integer); override; procedure OrderControls (const CanMoveControls: Boolean; const WasDockedTo, DockingTo: TDock97; var NewClientSize: TPoint); override; procedure SizeChanging (const AWidth, AHeight: Integer); override; public constructor Create (AOwner: TComponent); override; published property ActivateParent; property Caption; property Color; property CloseButton; property DefaultDock; property DockableTo; property DockedTo; property DockPos; property DockRow; property DragHandle; property FullSize; property HideWhenInactive; property MinClientHeight: Integer read FMinClientHeight write FMinClientHeight default 32; property MinClientWidth: Integer read FMinClientWidth write FMinClientWidth default 32; property ParentShowHint; property PopupMenu; property Resizable; property ShowHint; property TabOrder; property Visible; property OnClose; property OnDragDrop; property OnDragOver; property OnDockChanged; property OnDockChanging; property OnRecreated; property OnRecreating; property OnResize; property OnVisibleChanged; end; { TToolbarSep97 } TToolbarSepSize = 1..MaxInt; TToolbarSep97 = class(TGraphicControl) private FBlank: Boolean; FSizeHorz, FSizeVert: TToolbarSepSize; procedure SetBlank (Value: Boolean); procedure SetSizeHorz (Value: TToolbarSepSize); procedure SetSizeVert (Value: TToolbarSepSize); protected procedure MouseDown (Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; procedure Paint; override; procedure SetParent (AParent: TWinControl); override; public constructor Create (AOwner: TComponent); override; published { These two properties don't need to be stored since it automatically gets resized based on the setting of SizeHorz and SizeVert } property Width stored False; property Height stored False; property Blank: Boolean read FBlank write SetBlank default False; property SizeHorz: TToolbarSepSize read FSizeHorz write SetSizeHorz default 6; property SizeVert: TToolbarSepSize read FSizeVert write SetSizeVert default 6; end; { TToolbarButton97 } TButtonDisplayMode = (dmBoth, dmGlyphOnly, dmTextOnly); TButtonState97 = (bsUp, bsDisabled, bsDown, bsExclusive, bsMouseIn); TNumGlyphs97 = 1..5; TToolbarButton97 = class(TGraphicControl) private FAllowAllUp: Boolean; FDisplayMode: TButtonDisplayMode; FDown: Boolean; FDropdownArrow: Boolean; FDropdownCombo: Boolean; FDropdownMenu: TPopupMenu; FFlat: Boolean; FGlyph: Pointer; FGroupIndex: Integer; FLayout: TButtonLayout; FMargin: Integer; FModalResult: TModalResult; FNoBorder: Boolean; FOldDisabledStyle: Boolean; FOpaque: Boolean; FRepeating: Boolean; FRepeatDelay, FRepeatInterval: Integer; FShowBorderWhenInactive: Boolean; FSpacing: Integer; FWordWrap: Boolean; FOnMouseEnter, FOnMouseExit: TNotifyEvent; { Internal } FInClick: Boolean; FMouseInControl: Boolean; FMouseIsDown: Boolean; FMenuIsDown: Boolean; FHooked: Boolean; FUsesDropdown: Boolean; FRepeatTimer: TTimer; procedure GlyphChanged(Sender: TObject); procedure UpdateExclusive; procedure SetAllowAllUp (Value: Boolean); function GetCallDormant: Boolean; procedure SetCallDormant (Value: Boolean); procedure SetDown (Value: Boolean); procedure SetDisplayMode (Value: TButtonDisplayMode); procedure SetDropdownArrow (Value: Boolean); procedure SetDropdownCombo (Value: Boolean); procedure SetDropdownMenu (Value: TPopupMenu); procedure SetFlat (Value: Boolean); function GetGlyph: TBitmap; procedure SetGlyph (Value: TBitmap); function GetGlyphMask: TBitmap; procedure SetGlyphMask (Value: TBitmap); procedure SetGroupIndex (Value: Integer); procedure SetLayout (Value: TButtonLayout); procedure SetMargin (Value: Integer); procedure SetNoBorder (Value: Boolean); function GetNumGlyphs: TNumGlyphs97; procedure SetNumGlyphs (Value: TNumGlyphs97); procedure SetOldDisabledStyle (Value: Boolean); procedure SetOpaque (Value: Boolean); procedure SetSpacing (Value: Integer); procedure SetWordWrap (Value: Boolean); procedure UpdateTracking; procedure Redraw (const Erase: Boolean); function PointInButton (X, Y: Integer): Boolean; procedure ButtonMouseTimerHandler (Sender: TObject); procedure RepeatTimerHandler (Sender: TObject); class function DeactivateHook (var Message: TMessage): Boolean; procedure WMLButtonDblClk (var Message: TWMLButtonDblClk); message WM_LBUTTONDBLCLK; procedure CMEnabledChanged (var Message: TMessage); message CM_ENABLEDCHANGED; procedure CMButtonPressed (var Message: TMessage); message CM_BUTTONPRESSED; procedure CMDialogChar (var Message: TCMDialogChar); message CM_DIALOGCHAR; procedure CMFontChanged (var Message: TMessage); message CM_FONTCHANGED; procedure CMTextChanged (var Message: TMessage); message CM_TEXTCHANGED; procedure CMSysColorChange (var Message: TMessage); message CM_SYSCOLORCHANGE; procedure CMMouseLeave (var Message: TMessage); message CM_MOUSELEAVE; procedure WMCancelMode (var Message: TWMCancelMode); message WM_CANCELMODE; protected FState: TButtonState97; function GetPalette: HPALETTE; override; procedure Loaded; override; procedure Notification (AComponent: TComponent; Operation: TOperation); 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; public property CallDormant: Boolean read GetCallDormant write SetCallDormant; constructor Create(AOwner: TComponent); override; destructor Destroy; override; procedure Click; override; procedure MouseEntered; procedure MouseLeft; published property AllowAllUp: Boolean read FAllowAllUp write SetAllowAllUp default False; property GroupIndex: Integer read FGroupIndex write SetGroupIndex default 0; property DisplayMode: TButtonDisplayMode read FDisplayMode write SetDisplayMode default dmBoth; property Down: Boolean read FDown write SetDown default False; property DragCursor; property DragMode; property DropdownArrow: Boolean read FDropdownArrow write SetDropdownArrow default True; property DropdownCombo: Boolean read FDropdownCombo write SetDropdownCombo default False; property DropdownMenu: TPopupMenu read FDropdownMenu write SetDropdownMenu; property Caption; property Enabled; property Flat: Boolean read FFlat write SetFlat default True; property Font; property Glyph: TBitmap read GetGlyph write SetGlyph; property GlyphMask: TBitmap read GetGlyphMask write SetGlyphMask; property Layout: TButtonLayout read FLayout write SetLayout default blGlyphLeft; property Margin: Integer read FMargin write SetMargin default -1; property ModalResult: TModalResult read FModalResult write FModalResult default 0; property NoBorder: Boolean read FNoBorder write SetNoBorder default False; property NumGlyphs: TNumGlyphs97 read GetNumGlyphs write SetNumGlyphs default 1; property OldDisabledStyle: Boolean read FOldDisabledStyle write SetOldDisabledStyle default False; property Opaque: Boolean read FOpaque write SetOpaque default True; property ParentFont; property ParentShowHint; 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 ShowBorderWhenInactive: Boolean read FShowBorderWhenInactive write FShowBorderWhenInactive default False; property ShowHint; property Spacing: Integer read FSpacing write SetSpacing default 4; property Visible; property WordWrap: Boolean read FWordWrap write SetWordWrap default False; property OnClick; property OnDblClick; property OnDragDrop; property OnDragOver; property OnEndDrag; property OnMouseDown; property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter; property OnMouseExit: TNotifyEvent read FOnMouseExit write FOnMouseExit; property OnMouseMove; property OnMouseUp; property OnStartDrag; end; { TEdit97 } TEdit97 = class(TCustomEdit) private MouseInControl: Boolean; procedure RedrawBorder (const Clip: HRGN); procedure NewAdjustHeight; procedure CMEnabledChanged (var Message: TMessage); message CM_ENABLEDCHANGED; procedure CMFontChanged (var Message: TMessage); message CM_FONTCHANGED; procedure CMMouseEnter (var Message: TMessage); message CM_MOUSEENTER; procedure CMMouseLeave (var Message: TMessage); message CM_MOUSELEAVE; procedure WMSetFocus (var Message: TWMSetFocus); message WM_SETFOCUS; procedure WMKillFocus (var Message: TWMKillFocus); message WM_KILLFOCUS; procedure WMNCCalcSize (var Message: TWMNCCalcSize); message WM_NCCALCSIZE; procedure WMNCPaint (var Message: TMessage); message WM_NCPAINT; protected procedure Loaded; override; public constructor Create (AOwner: TComponent); override; published property CharCase; property DragCursor; property DragMode; property Enabled; property Font; property HideSelection; {$IFDEF TB97Delphi3orHigher} property ImeMode; property ImeName; {$ENDIF} property MaxLength; property OEMConvert; property ParentColor; property ParentCtl3D; property ParentFont; property ParentShowHint; property PasswordChar; property PopupMenu; property ReadOnly; property ShowHint; property TabOrder; property TabStop; property Text; property Visible; property OnChange; property OnClick; property OnDblClick; property OnDragDrop; property OnDragOver; property OnEndDrag; property OnEnter; property OnExit; property OnKeyDown; property OnKeyPress; property OnKeyUp; property OnMouseDown; property OnMouseMove; property OnMouseUp; property OnStartDrag; end; procedure RegLoadToolbarPositions (const Form: TForm; const BaseRegistryKey: String); procedure RegSaveToolbarPositions (const Form: TForm; const BaseRegistryKey: String); procedure IniLoadToolbarPositions (const Form: TForm; const Filename: String); procedure IniSaveToolbarPositions (const Form: TForm; const Filename: String); procedure CustomLoadToolbarPositions (const Form: TForm; const ReadIntProc: TPositionReadIntProc; const ReadStringProc: TPositionReadStringProc; const ExtraData: Pointer); procedure CustomSaveToolbarPositions (const Form: TForm; const WriteIntProc: TPositionWriteIntProc; const WriteStringProc: TPositionWriteStringProc; const ExtraData: Pointer); procedure AddFloatingNCAreaToRect (var R: TRect; const Resizable: Boolean); function GetDockTypeOf (const Control: TDock97): TDockType; procedure Register; var ButtonMouseInControl: TToolbarButton97 = nil; implementation uses CommCtrl, Registry, IniFiles, SysUtils, Consts; const { Exception messages } STB97DockNotFormOwner = 'TDock97 must be owned by a form'; STB97DockParentNotAllowed = 'A TDock97 control cannot be placed inside a tool window or another TDock97'; STB97DockCannotHide = 'Cannot hide a TDock97'; STB97DockCannotChangePosition = 'Cannot change Position of a TDock97 if it already contains controls'; STB97ToolwinNotFormOwner = 'Tool windows must be owned by a form'; STB97ToolwinNameNotSet = 'Cannot save tool window''s position because Name property is not set'; STB97ToolwinDockedToNameNotSet = 'Cannot save tool window''s position because DockedTo''s Name property not set'; STB97ToolwinParentNotAllowed = 'A tool window can only be placed on a TDock97 or directly on the form'; STB97ToolbarControlNotChildOfToolbar = 'Control is not a child of the toolbar'; STB97SepParentNotAllowed = 'TToolbarSep97 can only be placed on a TToolbar97'; { All spacing & margin values are here. It's recommended that you don't try changing any of this! } LineSpacing = 6; DropdownComboWidth = 11; TopMarginNotDocked = 2; TopMargin: array[Boolean] of Integer = (TopMarginNotDocked, 0); BottomMarginNotDocked = 1; BottomMargin: array[Boolean] of Integer = (BottomMarginNotDocked, 0); LeftMarginNotDocked = 4; LeftMargin: array[Boolean] of Integer = (LeftMarginNotDocked, 0); RightMarginNotDocked = 4; RightMargin: array[Boolean] of Integer = (RightMarginNotDocked, 0); DockedBorderSize = 2; DockedBorderSize2 = DockedBorderSize*2; DragHandleSize = 9; DefaultBarWidthHeight = 8; ForceDockAtTopRow = 0; ForceDockAtLeftPos = -8; PositionLeftOrRight = [dpLeft, dpRight]; { Constants for TCustomToolWindow97 registry values/data. Don't localize any of these names! } rvRev = 'Rev'; rdCurrentRev = 2; rvVisible = 'Visible'; rvDockedTo = 'DockedTo'; rdDockedToFloating = '+'; rvDockRow = 'DockRow'; rvDockPos = 'DockPos'; rvFloatLeft = 'FloatLeft'; rvFloatTop = 'FloatTop'; { TCustomToolbar97 specific } rvFloatRightX = 'FloatRightX'; { TToolWindow97 specific } rvClientWidth = 'ClientWidth'; rvClientHeight = 'ClientHeight'; type { Used internally by the TCustomToolbar97.Resize* procedures } PToolbar97SizeData = ^TToolbar97SizeData; TToolbar97SizeData = record HitTest: Integer; NewSizes: TList; { List of valid new sizes. Items are casted into TSmallPoints } CurRightX: Integer; DisableSensCheck, OpSide: Boolean; SizeSens: Integer; end; { Used in TCustomToolbar97.GroupInfo lists } PGroupInfo = ^TGroupInfo; TGroupInfo = record GroupWidth, { Width in pixels of the group, if all controls were lined up left-to-right } GroupHeight: Integer; { Heights in pixels of the group, if all controls were lined up top-to-bottom } Members: TList; end; { Used in TCustomToolbar97.SlaveInfo lists } PSlaveInfo = ^TSlaveInfo; TSlaveInfo = record LeftRight, TopBottom: TControl; end; { Used in TCustomToolbar97.LineSeps lists } TLineSep = packed record Y: SmallInt; Blank: Boolean; Unused: Boolean; end; { Use by CompareControls } PCompareExtra = ^TCompareExtra; TCompareExtra = record Toolbar: TCustomToolbar97; ComparePositions: Boolean; CurDockType: TDockType; end; TFloatParent = class(TWinControl) protected procedure CreateParams (var Params: TCreateParams); override; end; THookedFormID = (hkParentForm, hkChildForm); PHookedFormInfo = ^THookedFormInfo; THookedFormInfo = record Form: TForm; ID: THookedFormID; InstalledMainHook: Boolean; SaveActiveControl: HWND; RefCount: Integer; end; PMainHookedFormInfo = ^TMainHookedFormInfo; TMainHookedFormInfo = record Form: TForm; RefCount: Integer; end; procedure InstallHooks (const AID: THookedFormID; const AForm: TForm; const InstallMainHook: Boolean); forward; procedure UninstallHooks (const AID: THookedFormID; const AForm: TForm); forward; var HookedForms, MainHookedForms, DoneCreatingList: TList; CWPHookHandle: HHOOK; ButtonHookRefCount: Longint = 0; { See TToolbarButton97.ButtonMouseTimerHandler for info on this } ButtonMouseTimer: TTimer = nil; procedure Register; begin RegisterComponents ('Toolbar97', [TDock97, TToolbar97, TToolWindow97, TToolbarButton97, TToolbarSep97, TEdit97]); end; { Misc. functions } function GetSmallCaptionHeight: Integer; { Returns height of the caption of a small window } begin if NewStyleControls then Result := GetSystemMetrics(SM_CYSMCAPTION) else { Win 3.x doesn't support small captions, so, like Office 97, use the size of normal captions minus one } Result := GetSystemMetrics(SM_CYCAPTION) - 1; end; function GetBorderSize (const Resizable: Boolean): TPoint; { Returns size of a thick border. Note that, depending on the Windows version, this may not be the same as the actual window metrics since it draws its own border } const XMetrics: array[Boolean] of Integer = (SM_CXDLGFRAME, SM_CXFRAME); YMetrics: array[Boolean] of Integer = (SM_CYDLGFRAME, SM_CYFRAME); begin Result.X := GetSystemMetrics(XMetrics[Resizable]); Result.Y := GetSystemMetrics(YMetrics[Resizable]); end; procedure AddFloatingNCAreaToRect (var R: TRect; const Resizable: Boolean); begin with GetBorderSize(Resizable) do begin Dec (R.Left, X); Inc (R.Right, X); Inc (R.Bottom, GetSmallCaptionHeight + Y*2); end; end; procedure AddDockedNCAreaToSize (var S: TPoint; const LeftRight, DragHandle: Boolean); begin if not LeftRight then begin Inc (S.X, DockedBorderSize2 + (Ord(DragHandle) * DragHandleSize)); Inc (S.Y, DockedBorderSize2); end else begin Inc (S.X, DockedBorderSize2); Inc (S.Y, DockedBorderSize2 + (Ord(DragHandle) * DragHandleSize)); end; end; (* not currently used function GetDragFullWindows: Boolean; var S: BOOL; begin Result := False; if SystemParametersInfo(SPI_GETDRAGFULLWINDOWS, 0, @S, 0) then Result := S; end; *) function GetDesktopArea: TRect; { Returns a rectangle of the screen. But, under Win95 and NT 4.0, it excludes the area taken up by the taskbar. } begin if not SystemParametersInfo(SPI_GETWORKAREA, 0, @Result, 0) then { SPI_GETWORKAREA is only supported by Win95 and NT 4.0. So it fails under Win 3.x. In that case, return a rectangle of the entire screen } Result := Rect(0, 0, GetSystemMetrics(SM_CXSCREEN), GetSystemMetrics(SM_CYSCREEN)); end; function GetMDIParent (const Form: TForm): TForm; { Returns the parent of the specified MDI child form. But, if Form isn't a MDI child, it simply returns Form. } var I, J: Integer; begin Result := Form; if Form = nil then Exit; if Form.FormStyle = fsMDIChild then for I := 0 to Screen.FormCount-1 do with Screen.Forms[I] do begin if FormStyle <> fsMDIForm then Continue; for J := 0 to MDIChildCount-1 do if MDIChildren[J] = Form then begin Result := Screen.Forms[I]; Exit; end; end; end; function GetDockTypeOf (const Control: TDock97): TDockType; begin if Control = nil then Result := dtNotDocked else begin if not(Control.Position in PositionLeftOrRight) then Result := dtTopBottom else Result := dtLeftRight; end; end; procedure ShowHideFloatParents (const Form: TForm; const AppActive: Boolean); var HideFloatingToolbars: Boolean; I: Integer; ParentForm: TForm; begin { First call ShowHideFloatParent on child forms } for I := 0 to Form.MDIChildCount-1 do ShowHideFloatParents (Form.MDIChildren[I], AppActive); { Hide any child toolbars if: the application is not active or is minimized, or the form (or its MDI parent) is not visible or is minimized } HideFloatingToolbars := IsIconic(Application.Handle) or not IsWindowVisible(Form.Handle) or IsIconic(Form.Handle); ParentForm := GetMDIParent(Form); if ParentForm <> Form then HideFloatingToolbars := HideFloatingToolbars or not IsWindowVisible(ParentForm.Handle) or IsIconic(ParentForm.Handle); for I := 0 to Form.ComponentCount-1 do if Form.Components[I] is TCustomToolWindow97 then with TCustomToolWindow97(Form.Components[I]) do begin SetNotOnScreen (not Docked and (HideFloatingToolbars or (FHideWhenInactive and not AppActive))); SetInactiveCaption (not Docked and (not FHideWhenInactive and not AppActive)); end; end; function FormCallWndProcHook (Code: Integer; WParam: WPARAM; LParam: LPARAM): LRESULT; stdcall; var I: Integer; Wnd: HWND; Ctl: TWinControl; begin if Code = HC_ACTION then begin case PCWPStruct(LParam).Message of WM_DESTROY, WM_SETFOCUS, WM_WINDOWPOSCHANGED: begin for I := 0 to HookedForms.Count-1 do with PHookedFormInfo(HookedForms.List[I])^ do begin { uses List property for speed } Wnd := PCWPStruct(LParam).hwnd; case PCWPStruct(LParam).Message of WM_DESTROY: if Wnd = SaveActiveControl then SaveActiveControl := 0; WM_SETFOCUS: begin if Form.HandleAllocated and IsChild(Form.Handle, Wnd) then begin SaveActiveControl := 0; while True do begin Ctl := FindControl(Wnd); if Ctl <> nil then begin if (Ctl <> Form) and Ctl.HandleAllocated and (GetParentForm(Ctl) = Form) then SaveActiveControl := Ctl.Handle; Break; end; Wnd := GetParent(Wnd); if Wnd = 0 then Break; end; Break; end; end; WM_WINDOWPOSCHANGED: if Form.HandleAllocated and (Wnd = Form.Handle) then ShowHideFloatParents (Form, Application.Active); end; end; end; end; end; Result := CallNextHookEx(CWPHookHandle, Code, WParam, LParam); end; procedure InstallHooks (const AID: THookedFormID; const AForm: TForm; const InstallMainHook: Boolean); var I: Integer; Info: PHookedFormInfo; AlreadyExists: Boolean; MainInfo: PMainHookedFormInfo; begin for I := 0 to HookedForms.Count-1 do with PHookedFormInfo(HookedForms[I])^ do { If AForm already exists in list with the same ID, only increment the reference count } if (ID = AID) and (Form = AForm) then begin Inc (RefCount); Exit; end; New (Info); try with Info^ do begin Form := AForm; ID := AID; InstalledMainHook := InstallMainHook; if InstallMainHook then begin AlreadyExists := False; for I := 0 to MainHookedForms.Count-1 do with PMainHookedFormInfo(MainHookedForms[I])^ do if (Form = AForm) then begin Inc (RefCount); AlreadyExists := True; Break; end; if not AlreadyExists then begin New (MainInfo); with MainInfo^ do begin Form := AForm; RefCount := 1; end; MainHookedForms.Add (MainInfo); if MainHookedForms.Count = 1 then Application.HookMainWindow (TCustomToolWindow97.NewMainWindowHook); end; end; SaveActiveControl := 0; RefCount := 1; end; HookedForms.Add (Info); if HookedForms.Count = 1 then CWPHookHandle := SetWindowsHookEx(WH_CALLWNDPROC, FormCallWndProcHook, 0, GetCurrentThreadId); except Dispose (Info); raise; end; end; procedure UninstallHooks (const AID: THookedFormID; const AForm: TForm); var I, J: Integer; begin for I := HookedForms.Count-1 downto 0 do with PHookedFormInfo(HookedForms[I])^ do if (ID = AID) and (Form = AForm) then begin Dec (RefCount); if RefCount = 0 then begin if InstalledMainHook then begin for J := MainHookedForms.Count-1 downto 0 do with PMainHookedFormInfo(MainHookedForms[J])^ do if (Form = AForm) then begin Dec (RefCount); if RefCount = 0 then begin Dispose (PMainHookedFormInfo(MainHookedForms[J])); MainHookedForms.Delete (J); if MainHookedForms.Count = 0 then Application.UnhookMainWindow (TCustomToolWindow97.NewMainWindowHook); end; end; end; Dispose (PHookedFormInfo(HookedForms[I])); HookedForms.Delete (I); if HookedForms.Count = 0 then begin UnhookWindowsHookEx (CWPHookHandle); CWPHookHandle := 0; end; end; end; end; type TListSortExCompare = function (const Item1, Item2, ExtraData: Pointer): Integer; procedure ListSortEx (const List: TList; const Compare: TListSortExCompare; const ExtraData: Pointer); { Similar to TList.Sort, but lets you pass a user-defined ExtraData pointer } procedure QuickSortEx (L: Integer; const R: Integer); var I, J: Integer; P: Pointer; begin repeat I := L; J := R; P := List[(L + R) shr 1]; repeat while Compare(List[I], P, ExtraData) < 0 do Inc(I); while Compare(List[J], P, ExtraData) > 0 do Dec(J); if I <= J then begin List.Exchange (I, J); Inc (I); Dec (J); end; until I > J; if L < J then QuickSortEx (L, J); L := I; until I >= R; end; begin if List.Count > 1 then QuickSortEx (0, List.Count-1); end; procedure ProcessPaintMessages; { Dispatches all pending WM_PAINT messages. In effect, this is like an 'UpdateWindow' on all visible windows } var Msg: TMsg; begin while PeekMessage(Msg, 0, WM_PAINT, WM_PAINT, PM_NOREMOVE) do begin case Integer(GetMessage(Msg, 0, WM_PAINT, WM_PAINT)) of -1: Break; { if GetMessage failed } 0: begin { Repost WM_QUIT messages } PostQuitMessage (Msg.WParam); Break; end; end; DispatchMessage (Msg); end; end; {$IFNDEF TB97Delphi3orHigher} type PMaxLogPalette = ^TMaxLogPalette; TMaxLogPalette = packed record palVersion: Word; palNumEntries: Word; palPalEntry: array[Byte] of TPaletteEntry; end; function CopyPalette (Palette: HPALETTE): HPALETTE; var PaletteSize: Integer; LogPal: TMaxLogPalette; begin Result := 0; if Palette = 0 then Exit; PaletteSize := 0; if GetObject(Palette, SizeOf(PaletteSize), @PaletteSize) = 0 then Exit; if PaletteSize = 0 then Exit; with LogPal do begin palVersion := $0300; palNumEntries := PaletteSize; GetPaletteEntries (Palette, 0, PaletteSize, palPalEntry); end; Result := CreatePalette(PLogPalette(@LogPal)^); end; {$ENDIF} { TDock97 - internal } constructor TDock97.Create (AOwner: TComponent); begin inherited; if not(AOwner is TForm) then raise EInvalidOperation.Create(STB97DockNotFormOwner); { because TCustomToolWindow97 depends on docks being in the form's component list } FAllowDrag := True; FBkgOnToolbars := True; DockList := TList.Create; RowSizes := TList.Create; Inc (DisableArrangeToolbars); try ControlStyle := ControlStyle + [csAcceptsControls, csNoStdEvents] - [csClickEvents, csCaptureMouse, csOpaque]; FBkg := TBitmap.Create; FBkg.OnChange := BackgroundChanged; Position := dpTop; Color := clBtnFace; finally Dec (DisableArrangeToolbars); end; { Rearranging was disabled, so manually rearrange it now } ArrangeToolbars; end; procedure TDock97.CreateParams (var Params: TCreateParams); begin inherited; { Disable complete redraws when size changes. CS_H/VREDRAW cause flicker and are not necessary for this control at run time } if not(csDesigning in ComponentState) then with Params.WindowClass do Style := Style and not(CS_HREDRAW or CS_VREDRAW); end; destructor TDock97.Destroy; begin FBkgCache.Free; FBkg.Free; FreeRowInfo; RowSizes.Free; DockList.Free; inherited; end; procedure TDock97.SetParent (AParent: TWinControl); begin if (AParent is TCustomToolWindow97) or (AParent is TDock97) then raise EInvalidOperation.Create(STB97DockParentNotAllowed); inherited; end; procedure TDock97.VisibleChanging; begin if Visible then raise EInvalidOperation.Create(STB97DockCannotHide); inherited; end; procedure TDock97.FreeRowInfo; begin if Assigned(RowSizes) then RowSizes.Clear; end; procedure TDock97.BuildRowInfo; var R, I, Size, HighestSize: Integer; begin FreeRowInfo; for R := 0 to GetHighestRow do begin HighestSize := DefaultBarWidthHeight; for I := 0 to DockList.Count-1 do begin with TCustomToolWindow97(DockList[I]) do begin if FDockRow <> R then Continue; GetBarSize (Size, GetDockTypeOf(Self)); if Size > HighestSize then HighestSize := Size; end; end; RowSizes.Add (Pointer(HighestSize)); end; end; function TDock97.GetRowSize (const Row: Integer; const DefaultToolbar: TCustomToolWindow97): Integer; begin if Row < RowSizes.Count then Result := Longint(RowSizes[Row]) else begin { If it's out of bounds } if DefaultToolbar = nil then Result := 0 else DefaultToolbar.GetBarSize (Result, GetDockTypeOf(Self)); end; end; function TDock97.GetRowOf (const XY: Integer; var Before: Boolean): Integer; { Returns row number of the specified coordinate. Before is set to True if it was close to being in between two rows. } var HighestRow, R, CurY, NextY: Integer; begin Result := 0; Before := False; HighestRow := GetHighestRow; CurY := 0; for R := 0 to HighestRow+1 do begin if R <= HighestRow then NextY := CurY + GetRowSize(R, nil) + DockedBorderSize2 else NextY := High(NextY); if XY <= CurY+5 then begin Result := R; Before := True; Break; end; if (XY >= CurY+5) and (XY <= NextY-5) then begin Result := R; Break; end; CurY := NextY; end; end; function TDock97.GetDesignModeRowOf (const XY: Integer): Integer; { Similar to GetRowOf, but is a little different to accomidate design mode better } var HighestRowPlus1, R, CurY, NextY: Integer; begin Result := 0; HighestRowPlus1 := GetHighestRow+1; CurY := 0; for R := 0 to HighestRowPlus1 do begin Result := R; if R = HighestRowPlus1 then Break; NextY := CurY + GetRowSize(R, nil) + DockedBorderSize2; if XY < NextY then Break; CurY := NextY; end; end; function TDock97.GetHighestRow: Integer; { Returns highest used row number, or -1 if no rows are used } var I: Integer; begin Result := -1; for I := 0 to DockList.Count-1 do with TCustomToolWindow97(DockList[I]) do if FDockRow > Result then Result := FDockRow; end; function TDock97.GetNumberOfToolbarsOnRow (const Row: Integer; const NotIncluding: TCustomToolWindow97): Integer; { Returns number of toolbars on the specified row. The toolbar specified by "NotIncluding" is not included in the count. } var I: Integer; begin Result := 0; for I := 0 to DockList.Count-1 do if (TCustomToolWindow97(DockList[I]).FDockRow = Row) and (DockList[I] <> NotIncluding) then Inc (Result); end; procedure TDock97.RemoveBlankRows; { Deletes any blank row numbers, adjusting the docked toolbars' FDockRow as needed } var HighestRow, R, I: Integer; RowIsEmpty: Boolean; begin HighestRow := GetHighestRow; R := 0; while R <= HighestRow do begin RowIsEmpty := True; for I := 0 to DockList.Count-1 do if TCustomToolWindow97(DockList[I]).FDockRow = R then begin RowIsEmpty := False; Break; end; if RowIsEmpty then begin { Shift all ones higher than R back one } for I := 0 to DockList.Count-1 do with TCustomToolWindow97(DockList[I]) do if FDockRow > R then Dec (FDockRow); Dec (HighestRow); end; Inc (R); end; end; procedure TDock97.InsertRowBefore (const BeforeRow: Integer); { Inserts a blank row before BeforeRow, adjusting all the docked toolbars' FDockRow as needed } var I: Integer; begin for I := 0 to DockList.Count-1 do with TCustomToolWindow97(DockList[I]) do if FDockRow >= BeforeRow then Inc (FDockRow); end; procedure TDock97.ChangeWidthHeight (const IsClientWidthAndHeight: Boolean; NewWidth, NewHeight: Integer); { Same as setting Width/Height or ClientWidth/ClientHeight directly, but does not lose Align position. } begin if IsClientWidthAndHeight then begin Inc (NewWidth, Width-ClientWidth); Inc (NewHeight, Height-ClientHeight); end; case Align of alTop, alLeft: SetBounds (Left, Top, NewWidth, NewHeight); alBottom: SetBounds (Left, Top-NewHeight+Height, NewWidth, NewHeight); alRight: SetBounds (Left-NewWidth+Width, Top, NewWidth, NewHeight); end; end; procedure TDock97.AlignControls (AControl: TControl; var Rect: TRect); begin ArrangeToolbars; end; function CompareDockRowPos (const Item1, Item2, ExtraData: Pointer): Integer; far; begin if TCustomToolWindow97(Item1).FDockRow <> TCustomToolWindow97(Item2).FDockRow then Result := TCustomToolWindow97(Item1).FDockRow - TCustomToolWindow97(Item2).FDockRow else Result := TCustomToolWindow97(Item1).FDockPos - TCustomToolWindow97(Item2).FDockPos; end; procedure TDock97.ArrangeToolbars; { The main procedure to arrange all the toolbars docked to it } var LeftRight: Boolean; EmptySize: Integer; HighestRow, R, CurDockPos, CurRowPixel, I, J, K: Integer; HighestRowSize, CurRowSize: Integer; begin if (DisableArrangeToolbars > 0) or (csLoading in ComponentState) then Exit; { Work around VCL alignment bug when docking toolbars taller or wider than the client height or width of the form. } if not(csDesigning in ComponentState) and HandleAllocated then SetWindowPos (Handle, HWND_TOP, 0, 0, 0, 0, SWP_NOACTIVATE or SWP_NOMOVE or SWP_NOSIZE); LeftRight := Position in PositionLeftOrRight; if DockList.Count = 0 then begin EmptySize := Ord(FFixAlign); if csDesigning in ComponentState then EmptySize := 9; if not LeftRight then ChangeWidthHeight (False, Width, EmptySize) else ChangeWidthHeight (False, EmptySize, Height); Exit; end; { Ensure list is in correct ordering according to DockRow/DockPos } ListSortEx (DockList, CompareDockRowPos, nil); { If LimitToOneRow is True, only use the first row } if FLimitToOneRow then for I := 0 to DockList.Count-1 do with TCustomToolWindow97(DockList[I]) do FDockRow := 0; { Remove any blank rows } RemoveBlankRows; { Find highest row number } HighestRow := GetHighestRow; { Arrange, first without actually moving the toolbars onscreen } R := 0; while R <= HighestRow do begin CurDockPos := 0; for I := 0 to DockList.Count-1 do begin with TCustomToolWindow97(DockList[I]) do begin if FDockRow <> R then Continue; if FullSize then { If FullSize, make sure there aren't any other toolbars on the same row. If there are, shift them down a row. } for J := 0 to DockList.Count-1 do if (J <> I) and (TCustomToolWindow97(DockList[J]).FDockRow = R) then begin for K := 0 to DockList.Count-1 do with TCustomToolWindow97(DockList[K]) do if (K <> I) and (FDockRow >= R) then begin Inc (FDockRow); if FDockRow > HighestRow then HighestRow := FDockRow; end; Break; end; if FDockPos <= CurDockPos then FDockPos := CurDockPos else CurDockPos := FDockPos; if not LeftRight then Inc (CurDockPos, Width) else Inc (CurDockPos, Height); end; end; Inc (R); end; { Rebuild the RowInfo, since rows numbers may have shifted } BuildRowInfo; { Try to move all the toolbars that are offscreen to a fully visible position } for R := 0 to HighestRow do begin for I := 0 to DockList.Count-1 do begin with TCustomToolWindow97(DockList[I]) do begin if FDockRow <> R then Continue; if FullSize then FDockPos := 0 else for J := DockList.Count-1 downto I do begin with TCustomToolWindow97(DockList[J]) do begin if FDockRow <> R then Continue; if not LeftRight then begin if FDockPos+Width > Self.ClientWidth then begin Dec (TCustomToolWindow97(DockList[I]).FDockPos, ((FDockPos+Width) - Self.ClientWidth)); Break; end; end else begin if FDockPos+Height > Self.ClientHeight then begin Dec (TCustomToolWindow97(DockList[I]).FDockPos, ((FDockPos+Height) - Self.ClientHeight)); Break; end; end; end; end; end; end; end; { Arrange again, this time actually moving the toolbars } CurRowPixel := 0; for R := 0 to HighestRow do begin CurDockPos := 0; HighestRowSize := DefaultBarWidthHeight; for I := 0 to DockList.Count-1 do begin with TCustomToolWindow97(DockList[I]) do begin if FDockRow <> R then Continue; CurRowSize := DockedBorderSize2 + GetRowSize(FDockRow, TCustomToolWindow97(DockList[I])); if CurRowSize > HighestRowSize then HighestRowSize := CurRowSize; if FDockPos <= CurDockPos then FDockPos := CurDockPos else CurDockPos := FDockPos; Inc (FUpdatingBounds); try if not LeftRight then begin J := Width; if FullSize then J := Self.ClientWidth; SetBounds (CurDockPos, CurRowPixel, J, CurRowSize) end else begin J := Height; if FullSize then J := Self.ClientHeight; SetBounds (CurRowPixel, CurDockPos, CurRowSize, J); end; finally Dec (FUpdatingBounds); end; if not LeftRight then Inc (CurDockPos, Width) else Inc (CurDockPos, Height); end; end; Inc (CurRowPixel, HighestRowSize); end; { Set the size of the dock } if not LeftRight then ChangeWidthHeight (True, ClientWidth, CurRowPixel) else ChangeWidthHeight (True, CurRowPixel, ClientHeight); end; procedure TDock97.ChangeDockList (const Insert: Boolean; const Bar: TCustomToolWindow97; const IsVisible: Boolean); { Inserts or removes Bar. It inserts only if IsVisible is True, or is in design mode } var Modified: Boolean; begin Modified := False; if Insert then begin { Delete if already exists } if DockList.IndexOf(Bar) <> -1 then DockList.Remove (Bar); { Only add to dock list if visible } if (csDesigning in ComponentState) or IsVisible then begin DockList.Add (Bar); Modified := True; end; end else begin if DockList.IndexOf(Bar) <> -1 then begin DockList.Remove (Bar); Modified := True; end; end; if Modified then begin ArrangeToolbars; { This corrects a problem in past versions when toolbar is shown after it was initially hidden } Bar.ArrangeControls; if Assigned(FOnInsertRemoveBar) then FOnInsertRemoveBar (Self, Insert, Bar); end; end; procedure TDock97.Loaded; begin inherited; { Rearranging is disabled while the component is loading, so now that it's loaded, rearrange it. } ArrangeToolbars; end; function TDock97.GetPalette: HPALETTE; begin Result := FBkg.Palette; end; procedure TDock97.DrawBackground (const DC: HDC; const IntersectClippingRect: TRect; const ExcludeClippingRect: PRect; const DrawRect: TRect); var UseBmp: TBitmap; R2: TRect; SaveIndex: Integer; begin UseBmp := FBkg; { When FBkgTransparent is True, it keeps a cached copy of the background that has the transparent color already translated. Without the cache, redraws can be very slow. Note: The cache is cleared in the OnChange event of FBkg } if FBkgTransparent then begin if FBkgCache = nil then begin FBkgCache := TBitmap.Create; with FBkgCache do begin Palette := CopyPalette(FBkg.Palette); Width := FBkg.Width; Height := FBkg.Height; Canvas.Brush.Color := Self.Color; Canvas.BrushCopy (Rect(0, 0, Width, Height), FBkg, Rect(0, 0, Width, Height), FBkg.Canvas.Pixels[0, Height-1] or $02000000); end; end; UseBmp := FBkgCache; end; SaveIndex := SaveDC(DC); try with IntersectClippingRect do IntersectClipRect (DC, Left, Top, Right, Bottom); if Assigned(ExcludeClippingRect) then with ExcludeClippingRect^ do ExcludeClipRect (DC, Left, Top, Right, Bottom); if UseBmp.Palette <> 0 then begin SelectPalette (DC, UseBmp.Palette, True); RealizePalette (DC); end; R2 := DrawRect; while R2.Left < R2.Right do begin while R2.Top < R2.Bottom do begin BitBlt (DC, R2.Left, R2.Top, UseBmp.Width, UseBmp.Height, UseBmp.Canvas.Handle, 0, 0, SRCCOPY); Inc (R2.Top, UseBmp.Height); end; R2.Top := DrawRect.Top; Inc (R2.Left, UseBmp.Width); end; finally { Restores the clipping region and palette back } RestoreDC (DC, SaveIndex); end; end; procedure TDock97.Paint; var R, R2: TRect; P1, P2: TPoint; begin inherited; with Canvas do begin R := ClientRect; { Draw dotted border in design mode } if csDesigning in ComponentState then begin Pen.Style := psDot; Pen.Color := clBtnShadow; Brush.Style := bsClear; Rectangle (R.Left, R.Top, R.Right, R.Bottom); Pen.Style := psSolid; InflateRect (R, -1, -1); end; { Draw the Background } if UsingBackground then begin R2 := ClientRect; { Make up for nonclient area } P1 := ClientToScreen(Point(0, 0)); P2 := Parent.ClientToScreen(BoundsRect.TopLeft); Dec (R2.Left, Left + (P1.X-P2.X)); Dec (R2.Top, Top + (P1.Y-P2.Y)); DrawBackground (Canvas.Handle, R, nil, R2); end; end; end; procedure TDock97.WMMove (var Message: TWMMove); begin inherited; if UsingBackground then InvalidateBackgrounds; end; procedure TDock97.WMSize (var Message: TWMSize); begin inherited; ArrangeToolbars; if Assigned(FOnResize) then FOnResize (Self); end; procedure TDock97.WMNCCalcSize (var Message: TWMNCCalcSize); begin inherited; with Message.CalcSize_Params^.rgrc[0] do begin { Don't add a border when width or height is zero (or one in case of FixAlign=True) } if ((Right-Left) <= 1) or ((Bottom-Top) <= 1) then Exit; if blTop in BoundLines then Inc (Top); if blBottom in BoundLines then Dec (Bottom); if blLeft in BoundLines then Inc (Left); if blRight in BoundLines then Dec (Right); end; end; procedure TDock97.WMNCPaint (var Message: TMessage); var R, R2: TRect; DC: HDC; NewClipRgn: HRGN; HighlightPen, ShadowPen, SavePen: HPEN; begin { This works around WM_NCPAINT problem described at top of source code } {no! R := Rect(0, 0, Width, Height);} GetWindowRect (Handle, R); OffsetRect (R, -R.Left, -R.Top); { Don't draw border when width or height is zero (or one in case of FixAlign=True) } if ((R.Right-R.Left) <= 1) or ((R.Bottom-R.Top) <= 1) then Exit; DC := GetWindowDC(Handle); try { Use update region } if (Message.WParam <> 0) and (Message.WParam <> 1) then begin GetWindowRect (Handle, R2); if SelectClipRgn(DC, Message.WParam) = ERROR then begin NewClipRgn := CreateRectRgnIndirect(R2); SelectClipRgn (DC, NewClipRgn); DeleteObject (NewClipRgn); end; OffsetClipRgn (DC, -R2.Left, -R2.Top); end; { Draw BoundLines } HighlightPen := CreatePen(PS_SOLID, 1, GetSysColor(COLOR_BTNHIGHLIGHT)); ShadowPen := CreatePen(PS_SOLID, 1, GetSysColor(COLOR_BTNSHADOW)); if blTop in BoundLines then begin SavePen := SelectObject(DC, ShadowPen); MoveToEx (DC, R.Left, R.Top, nil); LineTo (DC, R.Right, R.Top); SelectObject (DC, SavePen); end; if blLeft in BoundLines then begin SavePen := SelectObject(DC, ShadowPen); MoveToEx (DC, R.Left, R.Top, nil); LineTo (DC, R.Left, R.Bottom); SelectObject (DC, SavePen); end; if blBottom in BoundLines then begin SavePen := SelectObject(DC, HighlightPen); MoveToEx (DC, R.Left, R.Bottom-1, nil); LineTo (DC, R.Right, R.Bottom-1); SelectObject (DC, SavePen); end; if blRight in BoundLines then begin SavePen := SelectObject(DC, HighlightPen); MoveToEx (DC, R.Right-1, R.Top, nil); LineTo (DC, R.Right-1, R.Bottom); SelectObject (DC, SavePen); end; DeleteObject (ShadowPen); DeleteObject (HighlightPen); finally ReleaseDC (Handle, DC); end; end; procedure TDock97.CMColorChanged (var Message: TMessage); begin if UsingBackground then { Erase the cache } BackgroundChanged (FBkg); inherited; end; procedure TDock97.CMSysColorChange (var Message: TMessage); begin inherited; if UsingBackground then { Erase the cache } BackgroundChanged (FBkg); end; { TDock97 - property access methods } procedure TDock97.SetAllowDrag (Value: Boolean); var I: Integer; begin if FAllowDrag <> Value then begin FAllowDrag := Value; for I := 0 to ControlCount-1 do if (Controls[I] is TCustomToolWindow97) and TCustomToolWindow97(Controls[I]).HandleAllocated then { Recalculate the non-client area } SetWindowPos (TCustomToolWindow97(Controls[I]).Handle, 0, 0, 0, 0, 0, SWP_FRAMECHANGED or SWP_NOACTIVATE or SWP_NOMOVE or SWP_NOSIZE or SWP_NOZORDER); end; end; procedure TDock97.SetBackground (Value: TBitmap); begin FBkg.Assign (Value); end; function TDock97.UsingBackground: Boolean; begin Result := (FBkg.Width <> 0) and (FBkg.Height <> 0); end; procedure TDock97.InvalidateBackgrounds; { Called after background is changed } var I: Integer; begin Invalidate; { Synchronize child toolbars also } for I := 0 to DockList.Count-1 do with TCustomToolWindow97(DockList[I]) do begin InvalidateDockedNCArea; Invalidate; end; end; procedure TDock97.BackgroundChanged (Sender: TObject); begin { Erase the cache } FBkgCache.Free; FBkgCache := nil; InvalidateBackgrounds; end; procedure TDock97.SetBackgroundOnToolbars (Value: Boolean); begin if FBkgOnToolbars <> Value then begin FBkgOnToolbars := Value; InvalidateBackgrounds; end; end; procedure TDock97.SetBackgroundTransparent (Value: Boolean); begin if FBkgTransparent <> Value then begin FBkgTransparent := Value; if UsingBackground then { Erase the cache } BackgroundChanged (FBkg); end; end; procedure TDock97.SetBoundLines (Value: TDockBoundLines); begin if FBoundLines <> Value then begin FBoundLines := Value; { Recalculate the non-client area } SetWindowPos (Handle, 0, 0, 0, 0, 0, SWP_FRAMECHANGED or SWP_NOACTIVATE or SWP_NOMOVE or SWP_NOSIZE or SWP_NOZORDER); end; end; procedure TDock97.SetFixAlign (Value: Boolean); begin if FFixAlign <> Value then begin FFixAlign := Value; ArrangeToolbars; end; end; procedure TDock97.SetPosition (Value: TDockPosition); begin if ControlCount <> 0 then raise EInvalidOperation.Create(STB97DockCannotChangePosition); FPosition := Value; case Position of dpTop: Align := alTop; dpBottom: Align := alBottom; dpLeft: Align := alLeft; dpRight: Align := alRight; end; end; function TDock97.GetToolbarCount: Integer; begin Result := DockList.Count; end; function TDock97.GetToolbars (Index: Integer): TCustomToolWindow97; begin Result := TCustomToolWindow97(DockList[Index]); end; { TFloatParent - Internal } procedure TFloatParent.CreateParams (var Params: TCreateParams); begin inherited; with Params do begin Style := WS_CHILD; ExStyle := 0; end; end; { Global procedures } procedure CustomLoadToolbarPositions (const Form: TForm; const ReadIntProc: TPositionReadIntProc; const ReadStringProc: TPositionReadStringProc; const ExtraData: Pointer); function FindDock (AName: String): TDock97; var I: Integer; begin Result := nil; for I := 0 to Form.ComponentCount-1 do if (Form.Components[I] is TDock97) and (Form.Components[I].Name = AName) then begin Result := TDock97(Form.Components[I]); Break; end; end; procedure ReadValues (const Toolbar: TCustomToolWindow97; const NewDock: TDock97); begin with Toolbar do begin FDockRow := ReadIntProc(Name, rvDockRow, FDockRow, ExtraData); FDockPos := ReadIntProc(Name, rvDockPos, FDockPos, ExtraData); FFloatingTopLeft.X := ReadIntProc(Name, rvFloatLeft, 0, ExtraData); FFloatingTopLeft.Y := ReadIntProc(Name, rvFloatTop, 0, ExtraData); ReadPositionData (ReadIntProc, ReadStringProc, ExtraData); DockedTo := NewDock; DoneReadingPositionData; end; end; var DocksDisabled: TList; I: Integer; ADock: TDock97; DockedToName: String; begin DocksDisabled := TList.Create; try with Form do for I := 0 to ComponentCount-1 do if Components[I] is TDock97 then begin Inc (TDock97(Components[I]).DisableArrangeToolbars); DocksDisabled.Add (Components[I]); end; for I := 0 to Form.ComponentCount-1 do if Form.Components[I] is TCustomToolWindow97 then with TCustomToolWindow97(Form.Components[I]) do begin if Name = '' then raise Exception.Create (STB97ToolWinNameNotSet); if ReadIntProc(Name, rvRev, 0, ExtraData) = rdCurrentRev then begin Visible := ReadIntProc(Name, rvVisible, Ord(Visible), ExtraData) <> 0; DockedToName := ReadStringProc(Name, rvDockedTo, '', ExtraData); if DockedToName <> '' then begin if DockedToName <> rdDockedToFloating then begin ADock := FindDock(DockedToName); if (ADock <> nil) and (ADock.FAllowDrag) then ReadValues (TCustomToolWindow97(Form.Components[I]), ADock); end else begin ReadValues (TCustomToolWindow97(Form.Components[I]), nil); MoveOnScreen (True); end; end; end; end; finally for I := DocksDisabled.Count-1 downto 0 do begin Dec (TDock97(DocksDisabled[I]).DisableArrangeToolbars); TDock97(DocksDisabled[I]).ArrangeToolbars; end; DocksDisabled.Free; end; end; procedure CustomSaveToolbarPositions (const Form: TForm; const WriteIntProc: TPositionWriteIntProc; const WriteStringProc: TPositionWriteStringProc; const ExtraData: Pointer); var I: Integer; N: String; begin for I := 0 to Form.ComponentCount-1 do if Form.Components[I] is TCustomToolWindow97 then with TCustomToolWindow97(Form.Components[I]) do begin if Name = '' then raise Exception.Create (STB97ToolwinNameNotSet); if not Docked then N := rdDockedToFloating else begin if DockedTo.FAllowDrag then begin N := DockedTo.Name; if N = '' then raise Exception.Create (STB97ToolwinDockedToNameNotSet); end else N := ''; end; WriteIntProc (Name, rvRev, rdCurrentRev, ExtraData); WriteIntProc (Name, rvVisible, Ord(Visible), ExtraData); with TCustomToolWindow97(Form.Components[I]) do begin WriteStringProc (Name, rvDockedTo, N, ExtraData); WriteIntProc (Name, rvDockRow, FDockRow, ExtraData); WriteIntProc (Name, rvDockPos, FDockPos, ExtraData); WriteIntProc (Name, rvFloatLeft, FFloatingTopLeft.X, ExtraData); WriteIntProc (Name, rvFloatTop, FFloatingTopLeft.Y, ExtraData); WritePositionData (WriteIntProc, WriteStringProc, ExtraData); end; end; end; function IniReadInt (const ToolbarName, Value: String; const Default: Longint; const ExtraData: Pointer): Longint; far; begin Result := TIniFile(ExtraData).ReadInteger(ToolbarName, Value, Default); end; function IniReadString (const ToolbarName, Value, Default: String; const ExtraData: Pointer): String; far; begin Result := TIniFile(ExtraData).ReadString(ToolbarName, Value, Default); end; procedure IniWriteInt (const ToolbarName, Value: String; const Data: Longint; const ExtraData: Pointer); far; begin TIniFile(ExtraData).WriteInteger (ToolbarName, Value, Data); end; procedure IniWriteString (const ToolbarName, Value, Data: String; const ExtraData: Pointer); far; begin TIniFile(ExtraData).WriteString (ToolbarName, Value, Data); end; procedure IniLoadToolbarPositions (const Form: TForm; const Filename: String); var Ini: TIniFile; begin Ini := TIniFile.Create(Filename); try CustomLoadToolbarPositions (Form, IniReadInt, IniReadString, Ini); finally Ini.Free; end; end; procedure IniSaveToolbarPositions (const Form: TForm; const Filename: String); var Ini: TIniFile; begin Ini := TIniFile.Create(Filename); try CustomSaveToolbarPositions (Form, IniWriteInt, IniWriteString, Ini); finally Ini.Free; end; end; function RegReadInt (const ToolbarName, Value: String; const Default: Longint; const ExtraData: Pointer): Longint; far; begin Result := TRegIniFile(ExtraData).ReadInteger(ToolbarName, Value, Default); end; function RegReadString (const ToolbarName, Value, Default: String; const ExtraData: Pointer): String; far; begin Result := TRegIniFile(ExtraData).ReadString(ToolbarName, Value, Default); end; procedure RegWriteInt (const ToolbarName, Value: String; const Data: Longint; const ExtraData: Pointer); far; begin TRegIniFile(ExtraData).WriteInteger (ToolbarName, Value, Data); end; procedure RegWriteString (const ToolbarName, Value, Data: String; const ExtraData: Pointer); far; begin TRegIniFile(ExtraData).WriteString (ToolbarName, Value, Data); end; procedure RegLoadToolbarPositions (const Form: TForm; const BaseRegistryKey: String); var Reg: TRegIniFile; begin Reg := TRegIniFile.Create(BaseRegistryKey); try CustomLoadToolbarPositions (Form, RegReadInt, RegReadString, Reg); finally Reg.Free; end; end; procedure RegSaveToolbarPositions (const Form: TForm; const BaseRegistryKey: String); var Reg: TRegIniFile; begin Reg := TRegIniFile.Create(BaseRegistryKey); try CustomSaveToolbarPositions (Form, RegWriteInt, RegWriteString, Reg); finally Reg.Free; end; end; { TCustomToolWindow97 - Internal } constructor TCustomToolWindow97.Create (AOwner: TComponent); begin inherited; GetParams (FParams); if not(AOwner is TForm) then raise EInvalidOperation.Create(STB97ToolwinNotFormOwner); { because it frequently casts Owner into a TForm } MDIParentForm := GetMDIParent(TForm(AOwner)); Inc (FDisableArrangeControls); try ControlStyle := ControlStyle + [csAcceptsControls, csClickEvents, csDoubleClicks, csSetCaption] - [csCaptureMouse{capturing is done manually}, csOpaque]; if not(csDesigning in ComponentState) then begin FloatParent := TFloatParent.Create(TForm(AOwner)); FloatParent.Parent := MDIParentForm; { Set up the hooks for the parent form of the toolbar, and a main window hook } InstallHooks (hkParentForm, MDIParentForm, True); { Add a another hook if it's owner is an MDI child } if TForm(AOwner).FormStyle = fsMDIChild then InstallHooks (hkChildForm, TForm(AOwner), False); { Need to move it offscreen while loading to prevent any flashing as it's updating } SetNotOnScreen (True); end else FloatParent := TForm(AOwner); FInactiveCaption := not Application.Active; FActivateParent := True; FDockableTo := [dpTop, dpBottom, dpLeft, dpRight]; FCloseButton := True; FDragHandle := True; FResizable := True; FHideWhenInactive := True; FDockPos := -1; Color := clBtnFace; DockedTo := nil; if not(csDesigning in ComponentState) then begin { Since SetNotOnScreen(True) was called, it needs to restore the toolbars back by posting a message which will be processed once it's done loading. } if DoneCreatingList.IndexOf(Self) = -1 then { can't have duplicates } DoneCreatingList.Add (Self); PostMessage (Application.Handle, WM_TB97DoneCreating, WM_TB97DoneCreating_Magic, WM_TB97DoneCreating_Magic); end; finally Dec (FDisableArrangeControls); end; end; destructor TCustomToolWindow97.Destroy; begin if not(csDesigning in ComponentState) then begin DoneCreatingList.Remove (Self); { just in case } UninstallHooks (hkParentForm, MDIParentForm); if TForm(Owner).FormStyle = fsMDIChild then UninstallHooks (hkChildForm, TForm(Owner)); end; inherited; end; procedure TCustomToolWindow97.SetNotOnScreen (const Value: Boolean); begin if NotOnScreen <> Value then begin NotOnScreen := Value; { Update the actual visibility of the toolbar by sending a CM_SHOWINGCHANGED message. CM_SHOWINGCHANGED cannot be sent if the handle has not been allocated yet, so check HandleAllocated first } if HandleAllocated then Perform (CM_SHOWINGCHANGED, 0, 0); end; end; procedure TCustomToolWindow97.SetInactiveCaption (const Value: Boolean); begin if FInactiveCaption <> Value then begin FInactiveCaption := Value; DrawFloatingNCArea (0, False, True, False); end; end; procedure TCustomToolWindow97.WMMove (var Message: TWMMove); begin inherited; if Docked and DockedTo.UsingBackground then begin { Needs to redraw so that background is lined up with the dock at the new position } InvalidateDockedNCArea; { To minimize flicker, InvalidateRect is called with the Erase parameter set to False instead of calling the Invalidate method } if HandleAllocated then InvalidateRect (Handle, nil, False); end; end; procedure TCustomToolWindow97.WMSize (var Message: TWMSize); begin inherited; if Assigned(FOnResize) then FOnResize (Self); end; procedure TCustomToolWindow97.WMGetMinMaxInfo (var Message: TWMGetMinMaxInfo); begin inherited; { Because the window uses the WS_THICKFRAME style (but not for the usual purpose), it must process the WM_GETMINMAXINFO message to remove the minimum and maximum size limits it imposes by default. } with Message.MinMaxInfo^ do begin with ptMinTrackSize do begin X := 1; Y := 1; { Note to self: Don't put GetMinimumSize code here, since ClientWidth/Height values are sometimes invalid during a RecreateWnd } end; with ptMaxTrackSize do begin { Because of the 16-bit (signed) size limitations of Windows 95, Smallints must be used instead of Integers or Longints } X := High(Smallint); Y := High(Smallint); end; end; end; procedure TCustomToolWindow97.CMShowingChanged (var Message: TMessage); const ShowFlags: array[Boolean] of UINT = ( SWP_NOSIZE or SWP_NOMOVE or SWP_NOZORDER or SWP_NOACTIVATE or SWP_HIDEWINDOW, SWP_NOSIZE or SWP_NOMOVE or SWP_NOZORDER or SWP_NOACTIVATE or SWP_SHOWWINDOW); begin { inherited isn't called since TCustomToolWindow97 handles CM_SHOWINGCHANGED itself. For reference, the original TWinControl implementation is: const ShowFlags: array[Boolean] of Word = ( SWP_NOSIZE + SWP_NOMOVE + SWP_NOZORDER + SWP_NOACTIVATE + SWP_HIDEWINDOW, SWP_NOSIZE + SWP_NOMOVE + SWP_NOZORDER + SWP_NOACTIVATE + SWP_SHOWWINDOW); begin SetWindowPos(FHandle, 0, 0, 0, 0, 0, ShowFlags[FShowing]); end; } SetWindowPos (Handle, 0, 0, 0, 0, 0, ShowFlags[Showing and not NotOnScreen]); end; procedure TCustomToolWindow97.CreateParams (var Params: TCreateParams); begin inherited; if Parent = FloatParent then with Params do begin { Note: WS_THICKFRAME and WS_BORDER styles are included to ensure that sizing grips are displayed on child controls with scrollbars. The thick frame or border is not drawn by Windows; TCustomToolWindow97 handles all border drawing by itself. } if not(csDesigning in ComponentState) then Style := WS_POPUP or WS_THICKFRAME or WS_BORDER else Style := Style or WS_THICKFRAME or WS_BORDER; ExStyle := 0; end; end; procedure TCustomToolWindow97.Notification (AComponent: TComponent; Operation: TOperation); begin inherited; if (Operation = opRemove) and (AComponent = FDefaultDock) then FDefaultDock := nil; end; procedure TCustomToolWindow97.MoveOnScreen (const OnlyIfFullyOffscreen: Boolean); { Moves the (floating) toolbar so that it is fully (or at least mostly) in view on the screen } var R, S, Test: TRect; begin if not Docked then begin R := BoundsRect; S := GetDesktopArea; if OnlyIfFullyOffscreen and IntersectRect(Test, R, S) then Exit; if R.Right > S.Right then OffsetRect (R, S.Right - R.Right, 0); if R.Bottom > S.Bottom then OffsetRect (R, 0, S.Bottom - R.Bottom); if R.Left < S.Left then OffsetRect (R, S.Left - R.Left, 0); if R.Top < S.Top then OffsetRect (R, 0, S.Top - R.Top); BoundsRect := R; end; end; procedure TCustomToolWindow97.ReadPositionData (const ReadIntProc: TPositionReadIntProc; const ReadStringProc: TPositionReadStringProc; const ExtraData: Pointer); begin end; procedure TCustomToolWindow97.DoneReadingPositionData; begin end; procedure TCustomToolWindow97.WritePositionData (const WriteIntProc: TPositionWriteIntProc; const WriteStringProc: TPositionWriteStringProc; const ExtraData: Pointer); begin end; procedure TCustomToolWindow97.InitializeOrdering; begin end; procedure TCustomToolWindow97.GetDockRowSize (var AHeightOrWidth: Integer); begin GetBarSize (AHeightOrWidth, GetDockTypeOf(DockedTo)); if Docked then with DockedTo do begin BuildRowInfo; AHeightOrWidth := DockedTo.GetRowSize(FDockRow, Self); end; end; procedure TCustomToolWindow97.SizeChanging (const AWidth, AHeight: Integer); begin end; procedure TCustomToolWindow97.Loaded; var R: TRect; begin inherited; { Adjust coordinates if it was initially floating } if not(csDesigning in ComponentState) and not Docked then begin R := BoundsRect; MapWindowPoints (TForm(Owner).Handle, 0, R, 2); BoundsRect := R; MoveOnScreen (False); end; InitializeOrdering; { Arranging of controls is disabled while component was loading, so rearrange it now } ArrangeControls; end; procedure TCustomToolWindow97.BeginUpdate; begin Inc (FDisableArrangeControls); end; procedure TCustomToolWindow97.EndUpdate; begin Dec (FDisableArrangeControls); if FArrangeNeeded and (FDisableArrangeControls = 0) then ArrangeControls; end; procedure TCustomToolWindow97.CustomArrangeControls (const ArrangeType: TToolWindowArrangeType; const WasDockedTo, DockingTo: TDock97; var NewClientSize: TPoint); var WH: Integer; begin if (FDisableArrangeControls > 0) or { Prevent flicker while loading or destroying } (csLoading in ComponentState) or { Following line added in 1.53 to stop the access violations that 1.52 was causing while destroying. } (csDestroying in ComponentState) or (Parent = nil) or (Parent.HandleAllocated and (csDestroying in Parent.ComponentState)) then begin FArrangeNeeded := True; Exit; end; FArrangeNeeded := False; NewClientSize.X := 0; NewClientSize.Y := 0; Inc (FDisableArrangeControls); try OrderControls (ArrangeType <> atNone, WasDockedTo, DockingTo, NewClientSize); if ArrangeType = atMoveControlsAndResize then with NewClientSize do begin if Docked then begin GetDockRowSize (WH); if not(DockedTo.Position in PositionLeftOrRight) then begin if WH > Y then Y := WH; if FullSize then X := DockedTo.ClientWidth - (Width-ClientWidth); end else begin if WH > X then X := WH; if FullSize then Y := DockedTo.ClientHeight - (Height-ClientHeight); end; end; if (ClientWidth <> X) or (ClientHeight <> Y) then begin Inc (FUpdatingBounds); try SetBounds (Left, Top, (Width-ClientWidth) + X, (Height-ClientHeight) + Y); finally Dec (FUpdatingBounds); end; end; end; finally Dec (FDisableArrangeControls); end; end; procedure TCustomToolWindow97.ArrangeControls; var TempSize: TPoint; begin CustomArrangeControls (atMoveControlsAndResize, DockedTo, DockedTo, TempSize); end; procedure TCustomToolWindow97.AlignControls (AControl: TControl; var Rect: TRect); { VCL calls this whenever any child controls in the toolbar are moved, sized, inserted, etc. It doesn't need to make use of the AControl and Rect parameters. } begin if Params.CallAlignControls then inherited; ArrangeControls; end; procedure TCustomToolWindow97.SetBounds (ALeft, ATop, AWidth, AHeight: Integer); begin if (FUpdatingBounds = 0) and ((AWidth <> Width) or (AHeight <> Height)) then SizeChanging (AWidth, AHeight); { This allows you to drag the toolbar around the dock at design time } if (csDesigning in ComponentState) and not(csLoading in ComponentState) and Docked and (FUpdatingBounds = 0) and ((ALeft <> Left) or (ATop <> Top)) then begin if not(DockedTo.Position in PositionLeftOrRight) then begin FDockRow := DockedTo.GetDesignModeRowOf(ATop+(Height div 2)); FDockPos := ALeft; end else begin FDockRow := DockedTo.GetDesignModeRowOf(ALeft+(Width div 2)); FDockPos := ATop; end; inherited SetBounds (Left, Top, AWidth, AHeight); { only pass any size changes } DockedTo.ArrangeToolbars; { let ArrangeToolbars take care of position changes } end else begin inherited; if not(csLoading in ComponentState) and not Docked and (FUpdatingBounds = 0) then FFloatingTopLeft := BoundsRect.TopLeft; end; end; procedure TCustomToolWindow97.SetParent (AParent: TWinControl); begin if not(csDesigning in ComponentState) and (AParent = TForm(Owner)) then AParent := FloatParent; if (AParent <> nil) and not(AParent is TDock97) and not(AParent = Owner) and not(AParent is TFloatParent) then raise EInvalidOperation.Create(STB97ToolwinParentNotAllowed); if not(csDestroying in ComponentState) and Assigned(FOnRecreating) then FOnRecreating (Self); if Parent is TDock97 then TDock97(Parent).ChangeDockList (False, Self, Visible or (FHidden <> 0)); { Ensure that the handle is destroyed now so that any messages in the queue get flushed. This is neccessary since existing messages may reference FDockedTo or FDocked, which is changed below. } inherited SetParent (nil); { ^ Note to self: SetParent is used instead of DestroyHandle because it does additional processing } if not(AParent is TDock97) then FDockedTo := nil else FDockedTo := TDock97(AParent); FDocked := FDockedTo <> nil; try inherited; except { Failure is rare, but just in case, restore FDockedTo and FDocked back. } if not(Parent is TDock97) then FDockedTo := nil else FDockedTo := TDock97(Parent); FDocked := FDockedTo <> nil; raise; end; if Parent is TDock97 then TDock97(Parent).ChangeDockList (True, Self, Visible or (FHidden <> 0)); if not(csDestroying in ComponentState) and Assigned(FOnRecreated) then FOnRecreated (Self); end; function GetCaptionRect (const Control: TCustomToolWindow97; const AdjustForBorder, MinusCloseButton: Boolean): TRect; begin Result := Rect(0, 0, Control.ClientWidth, GetSmallCaptionHeight-1); if MinusCloseButton then Dec (Result.Right, GetSmallCaptionHeight-1); if AdjustForBorder then with GetBorderSize(Control.Resizable) do OffsetRect (Result, X, Y); end; function GetCloseButtonRect (const Control: TCustomToolWindow97; const AdjustForBorder: Boolean): TRect; begin Result := Rect(0, 0, Control.ClientWidth, GetSmallCaptionHeight-1); if AdjustForBorder then with GetBorderSize(Control.Resizable) do OffsetRect (Result, X, Y); Result.Left := Result.Right - (GetSmallCaptionHeight-1); end; procedure TCustomToolWindow97.WMNCCalcSize (var Message: TWMNCCalcSize); begin { Doesn't call inherited since it overrides the normal NC sizes } Message.Result := 0; with Message.CalcSize_Params^ do begin if not Docked then begin with GetBorderSize(Resizable) do InflateRect (rgrc[0], -X, -Y); Inc (rgrc[0].Top, GetSmallCaptionHeight); end else begin InflateRect (rgrc[0], -DockedBorderSize, -DockedBorderSize); if DockedTo.FAllowDrag and FDragHandle then begin if not(DockedTo.Position in PositionLeftOrRight) then Inc (rgrc[0].Left, DragHandleSize) else Inc (rgrc[0].Top, DragHandleSize); end; end; end; end; procedure TCustomToolWindow97.DrawFloatingNCArea (const Clip: HRGN; const RedrawBorder, RedrawCaption, RedrawCloseButton: Boolean); { Redraws all the non-client area (the border, title bar, and close button) of the toolbar when it is floating. } const CaptionBkColors: array[Boolean] of Integer = (COLOR_ACTIVECAPTION, COLOR_INACTIVECAPTION); CaptionTextColors: array[Boolean] of Integer = (COLOR_CAPTIONTEXT, COLOR_INACTIVECAPTIONTEXT); procedure Win3DrawCaption (const DC: HDC; const R: TRect); { Emulates DrawCaption, which isn't supported in Win 3.x } const Ellipsis = '...'; var R2: TRect; SaveTextColor, SaveBkColor: TColorRef; SaveFont: HFONT; Cap: String; function CaptionTextWidth: Integer; var Size: TSize; begin GetTextExtentPoint32 (DC, PChar(Cap), Length(Cap), Size); Result := Size.cx; end; begin R2 := R; { Fill the rectangle } FillRect (DC, R2, GetSysColorBrush(CaptionBkColors[FInactiveCaption])); Inc (R2.Left); Dec (R2.Right); SaveFont := SelectObject(DC, CreateFont(-11, 0, 0, 0, FW_NORMAL, 0, 0, 0, 0, 0, 0, 0, 0, 'MS Sans Serif')); { Add ellipsis to caption if necessary } Cap := Caption; if CaptionTextWidth > R2.Right-R2.Left then begin Cap := Cap + Ellipsis; while (CaptionTextWidth > R2.Right-R2.Left) and (Length(Cap) > 4) do Delete (Cap, Length(Cap)-Length(Ellipsis), 1) end; { Draw the text } SaveBkColor := SetBkColor(DC, GetSysColor(CaptionBkColors[FInactiveCaption])); SaveTextColor := SetTextColor(DC, GetSysColor(CaptionTextColors[FInactiveCaption])); DrawText (DC, PChar(Cap), Length(Cap), R2, DT_SINGLELINE or DT_NOPREFIX or DT_VCENTER); SetTextColor (DC, SaveTextColor); SetBkColor (DC, SaveBkColor); DeleteObject (SelectObject(DC, SaveFont)); end; const CloseButtonState: array[Boolean] of UINT = (0, DFCS_PUSHED); ActiveCaptionFlags: array[Boolean] of UINT = (DC_ACTIVE, 0); var DC: HDC; R: TRect; NewClipRgn: HRGN; NewDrawCaption: function(p1: HWND; p2: HDC; const p3: TRect; p4: UINT): BOOL; stdcall; SavePen: HPEN; SaveIndex: Integer; I: Integer; begin if Docked then Exit; DC := GetWindowDC(Handle); try { Use update region } if (Clip <> 0) and (Clip <> 1) then begin GetWindowRect (Handle, R); if SelectClipRgn(DC, Clip) = ERROR then begin NewClipRgn := CreateRectRgnIndirect(R); SelectClipRgn (DC, NewClipRgn); DeleteObject (NewClipRgn); end; OffsetClipRgn (DC, -R.Left, -R.Top); end; { Border } if RedrawBorder then begin { This works around WM_NCPAINT problem described at top of source code } {no! R := Rect(0, 0, Width, Height);} GetWindowRect (Handle, R); OffsetRect (R, -R.Left, -R.Top); for I := 1 to GetBorderSize(Resizable).X do case I of 1: DrawEdge (DC, R, EDGE_RAISED, BF_RECT or BF_ADJUST); 2: ; else FrameRect (DC, R, GetSysColorBrush(COLOR_BTNFACE)); InflateRect (R, -1, -1); end; end; if RedrawCaption and FCloseButton and RedrawCloseButton then SaveIndex := SaveDC(DC) else SaveIndex := 0; try if SaveIndex <> 0 then with GetCloseButtonRect(Self, True) do { Reduces flicker } ExcludeClipRect (DC, Left, Top, Right, Bottom); { Caption } if RedrawCaption then begin R := GetCaptionRect(Self, True, FCloseButton); if NewStyleControls then begin { Use a dynamic import of DrawCaption since it's Win95/NT 4.0 only. Also note that Delphi's Win32 help for DrawCaption is totally wrong! I got updated info from www.microsoft.com/msdn/sdk/ } NewDrawCaption := GetProcAddress(GetModuleHandle(user32), 'DrawCaption'); NewDrawCaption (Handle, DC, R, DC_TEXT or DC_SMALLCAP or ActiveCaptionFlags[FInactiveCaption]); end else Win3DrawCaption (DC, R); { Line below caption } R := GetCaptionRect(Self, True, False); SavePen := SelectObject(DC, CreatePen(PS_SOLID, 1, GetSysColor(COLOR_BTNFACE))); MoveToEx (DC, R.Left, R.Bottom, nil); LineTo (DC, R.Right, R.Bottom); DeleteObject (SelectObject(DC, SavePen)); end; finally if SaveIndex <> 0 then RestoreDC (DC, SaveIndex); end; { Close button } if FCloseButton then begin if RedrawCloseButton then begin R := GetCloseButtonRect(Self, True); InflateRect (R, -1, -1); DrawFrameControl (DC, R, DFC_CAPTION, DFCS_CAPTIONCLOSE or CloseButtonState[CloseButtonDown]); end; if RedrawCaption then begin { Caption-colored frame around close button } R := GetCloseButtonRect(Self, True); FrameRect (DC, R, GetSysColorBrush(CaptionBkColors[FInactiveCaption])); end; end; finally ReleaseDC (Handle, DC); end; end; procedure TCustomToolWindow97.ValidateDockedNCArea; var Msg: TMsg; begin if HandleAllocated then while PeekMessage(Msg, Handle, WM_TB97PaintDockedNCArea, WM_TB97PaintDockedNCArea, PM_REMOVE or PM_NOYIELD) do ; end; procedure TCustomToolWindow97.InvalidateDockedNCArea; begin ValidateDockedNCArea; if HandleAllocated then PostMessage (Handle, WM_TB97PaintDockedNCArea, 0, 0); end; procedure TCustomToolWindow97.WMTB97PaintDockedNCArea (var Message: TMessage); begin DrawDockedNCArea (0); end; procedure TCustomToolWindow97.DrawDockedNCArea (const Clip: HRGN); { Redraws all the non-client area of the toolbar when it is docked. } var DC: HDC; R: TRect; NewClipRgn: HRGN; DockType: TDockType; X, Y: Integer; R2, R3, R4: TRect; P1, P2: TPoint; Brush: HBRUSH; Clr: TColorRef; UsingBackground: Boolean; procedure DrawRaisedEdge (R: TRect; const FillInterior: Boolean); const FillMiddle: array[Boolean] of UINT = (0, BF_MIDDLE); begin DrawEdge (DC, R, BDR_RAISEDINNER, BF_RECT or FillMiddle[FillInterior]); end; begin ValidateDockedNCArea; if not Docked then Exit; DC := GetWindowDC(Handle); try { Use update region } if (Clip <> 0) and (Clip <> 1) then begin GetWindowRect (Handle, R); if SelectClipRgn(DC, Clip) = ERROR then begin NewClipRgn := CreateRectRgnIndirect(R); SelectClipRgn (DC, NewClipRgn); DeleteObject (NewClipRgn); end; OffsetClipRgn (DC, -R.Left, -R.Top); end; { This works around WM_NCPAINT problem described at top of source code } {no! R := Rect(0, 0, Width, Height);} GetWindowRect (Handle, R); OffsetRect (R, -R.Left, -R.Top); if not(DockedTo.Position in PositionLeftOrRight) then DockType := dtTopBottom else DockType := dtLeftRight; Brush := CreateSolidBrush(ColorToRGB(Color)); { Border } DrawRaisedEdge (R, False); R2 := R; InflateRect (R2, -1, -1); FrameRect (DC, R2, Brush); UsingBackground := DockedTo.UsingBackground and DockedTo.FBkgOnToolbars; { Draw the Background } if UsingBackground then begin R2 := R; P1 := DockedTo.ClientToScreen(Point(0, 0)); P2 := DockedTo.Parent.ClientToScreen(DockedTo.BoundsRect.TopLeft); Dec (R2.Left, Left + DockedTo.Left + (P1.X-P2.X)); Dec (R2.Top, Top + DockedTo.Top + (P1.Y-P2.Y)); InflateRect (R, -1, -1); GetWindowRect (Handle, R4); R3 := ClientRect; with ClientToScreen(Point(0, 0)) do OffsetRect (R3, X-R4.Left, Y-R4.Top); DockedTo.DrawBackground (DC, R, @R3, R2); end; { The drag handle at the left, or top } if DockedTo.FAllowDrag and FDragHandle then begin Clr := GetSysColor(COLOR_BTNHIGHLIGHT); if DockType <> dtLeftRight then begin Y := ClientHeight+2; if not UsingBackground then begin FillRect (DC, Rect(2, 2, 4, Y), Brush); FillRect (DC, Rect(10, 2, 11, Y), Brush); end; DrawRaisedEdge (Rect(4, 2, 7, Y), True); SetPixelV (DC, 4, Y-1, Clr); DrawRaisedEdge (Rect(7, 2, 10, Y), True); SetPixelV (DC, 7, Y-1, Clr); end else begin X := ClientWidth+2; if not UsingBackground then begin FillRect (DC, Rect(2, 2, X, 4), Brush); FillRect (DC, Rect(2, 10, X, 11), Brush); end; DrawRaisedEdge (Rect(2, 4, X, 7), True); SetPixelV (DC, X-1, 4, Clr); DrawRaisedEdge (Rect(2, 7, X, 10), True); SetPixelV (DC, X-1, 7, Clr); end; end; DeleteObject (Brush); finally ReleaseDC (Handle, DC); end; end; procedure TCustomToolWindow97.WMNCPaint (var Message: TMessage); begin { Don't call inherited because it overrides the default NC painting } if Docked then DrawDockedNCArea (Message.WParam) else DrawFloatingNCArea (Message.WParam, True, True, True); end; procedure TCustomToolWindow97.Paint; var R, R2, R3: TRect; P1, P2: TPoint; begin inherited; if Docked and DockedTo.UsingBackground and DockedTo.FBkgOnToolbars then begin R := ClientRect; R2 := R; P1 := DockedTo.ClientToScreen(Point(0, 0)); P2 := DockedTo.Parent.ClientToScreen(DockedTo.BoundsRect.TopLeft); Dec (R2.Left, Left + DockedTo.Left + (P1.X-P2.X)); Dec (R2.Top, Top + DockedTo.Top + (P1.Y-P2.Y)); GetWindowRect (Handle, R3); with ClientToScreen(Point(0, 0)) do begin Inc (R2.Left, R3.Left-X); Inc (R2.Top, R3.Top-Y); end; DockedTo.DrawBackground (Canvas.Handle, R, nil, R2); end; end; function TCustomToolWindow97.GetPalette: HPALETTE; begin if Docked and DockedTo.UsingBackground then Result := DockedTo.FBkg.Palette else Result := 0; end; function TCustomToolWindow97.PaletteChanged (Foreground: Boolean): Boolean; begin Result := inherited PaletteChanged(Foreground); if Result and not Foreground then begin { There seems to be a bug in Delphi's palette handling. When the form is inactive and another window realizes a palette, docked TToolbar97s weren't getting redrawn. So this workaround code was added. } InvalidateDockedNCArea; Invalidate; end; end; procedure DrawDragRect (const DC: HDC; const NewRect, OldRect: PRect; const NewSize, OldSize: TSize; const Brush: HBRUSH; BrushLast: HBRUSH); { Draws a dragging outline, hiding the old one if neccessary. This is completely flicker free, unlike the old DrawFocusRect method. In case you're wondering, I got a lot of ideas from the MFC sources. Either NewRect or OldRect can be nil or empty. NOTE: If the specific DC had a clipping region, it will be gone when this function exits. } const BlankRect: TRect = (Left: 0; Top: 0; Right: 0; Bottom: 0); var rgnNew, rgnOutside, rgnInside, rgnLast, rgnUpdate: HRGN; R: TRect; SaveBrush: HBRUSH; begin rgnLast := 0; rgnUpdate := 0; { First, determine the update region and select it } if NewRect = nil then begin R := BlankRect; rgnOutside := CreateRectRgnIndirect(R); end else begin R := NewRect^; rgnOutside := CreateRectRgnIndirect(R); InflateRect (R, -NewSize.cx, -NewSize.cy); IntersectRect (R, R, NewRect^); end; rgnInside := CreateRectRgnIndirect(R); rgnNew := CreateRectRgnIndirect(BlankRect); CombineRgn (rgnNew, rgnOutside, rgnInside, RGN_XOR); if BrushLast = 0 then BrushLast := Brush; if OldRect <> nil then begin { Find difference between new region and old region } rgnLast := CreateRectRgnIndirect(BlankRect); with OldRect^ do SetRectRgn (rgnOutside, Left, Top, Right, Bottom); R := OldRect^; InflateRect (R, -OldSize.cx, -OldSize.cy); IntersectRect (R, R, OldRect^); SetRectRgn (rgnInside, R.Left, R.Top, R.Right, R.Bottom); CombineRgn (rgnLast, rgnOutside, rgnInside, RGN_XOR); { Only diff them if brushes are the same} if Brush = BrushLast then begin rgnUpdate := CreateRectRgnIndirect(BlankRect); CombineRgn (rgnUpdate, rgnLast, rgnNew, RGN_XOR); end; end; if (Brush <> BrushLast) and (OldRect <> nil) then begin { Brushes are different -- erase old region first } SelectClipRgn (DC, rgnLast); GetClipBox (DC, R); SaveBrush := SelectObject(DC, BrushLast); PatBlt (DC, R.Left, R.Top, R.Right-R.Left, R.Bottom-R.Top, PATINVERT); SelectObject (DC, SaveBrush); end; { Draw into the update/new region } if rgnUpdate <> 0 then SelectClipRgn (DC, rgnUpdate) else SelectClipRgn (DC, rgnNew); GetClipBox (DC, R); SaveBrush := SelectObject(DC, Brush); PatBlt (DC, R.Left, R.Top, R.Right-R.Left, R.Bottom-R.Top, PATINVERT); SelectObject (DC, SaveBrush); { Free regions } if rgnNew <> 0 then DeleteObject (rgnNew); if rgnOutside <> 0 then DeleteObject (rgnOutside); if rgnInside <> 0 then DeleteObject (rgnInside); if rgnLast <> 0 then DeleteObject (rgnLast); if rgnUpdate <> 0 then DeleteObject (rgnUpdate); { Clean up DC } SelectClipRgn (DC, 0); end; procedure TCustomToolWindow97.DrawDraggingOutline (const DC: HDC; const NewRect, OldRect: PRect; const NewDocking, OldDocking: Boolean); function CreateHalftoneBrush: HBRUSH; const Patterns: array[Boolean] of Word = ($5555, $AAAA); var I: Integer; GrayPattern: array[0..7] of Word; GrayBitmap: HBITMAP; begin for I := 0 to 7 do GrayPattern[I] := Patterns[Odd(I)]; GrayBitmap := CreateBitmap(8, 8, 1, 1, @GrayPattern); Result := CreatePatternBrush(GrayBitmap); DeleteObject (GrayBitmap); end; var NewSize, OldSize: TSize; Brush: HBRUSH; begin Brush := CreateHalftoneBrush; try with GetBorderSize(Resizable) do begin if NewDocking then NewSize.cx := 1 else NewSize.cx := X; NewSize.cy := NewSize.cx; if OldDocking then OldSize.cx := 1 else OldSize.cx := X; OldSize.cy := OldSize.cx; end; DrawDragRect (DC, NewRect, OldRect, NewSize, OldSize, Brush, Brush); finally DeleteObject (Brush); end; end; procedure TCustomToolWindow97.CMColorChanged (var Message: TMessage); begin { Make sure non-client area is redrawn } InvalidateDockedNCArea; inherited; { the inherited handler calls Invalidate } end; procedure TCustomToolWindow97.CMTextChanged (var Message: TMessage); begin inherited; { Update the title bar to use the new Caption } DrawFloatingNCArea (0, False, True, False); end; procedure TCustomToolWindow97.CMVisibleChanged (var Message: TMessage); begin if (FHidden = 0) and not(csDesigning in ComponentState) and Docked then DockedTo.ChangeDockList (Visible, Self, Visible); inherited; if (FHidden = 0) and Assigned(FOnVisibleChanged) then FOnVisibleChanged (Self); end; procedure TCustomToolWindow97.WMActivate (var Message: TWMActivate); function GetParentToolWindow (Control: TControl): TCustomToolWindow97; { Returns the parent toolbar (direct or indirect) of the control, or nil if it is not a child of a TCustomToolWindow97 } begin Result := nil; while Control <> nil do begin if Control is TCustomToolWindow97 then begin Result := TCustomToolWindow97(Control); Break; end; Control := Control.Parent; end; end; function FindFirstFocusableNonToolWindowControl (const ParentControl: TWinControl): TWinControl; var List: TList; I: Integer; CurControl: TWinControl; begin Result := nil; List := TList.Create; try with ParentControl do begin GetTabOrderList (List); for I := 0 to List.Count-1 do begin CurControl := List[I]; if CurControl.TabStop and CurControl.CanFocus and (GetParentToolWindow(CurControl) = nil) then begin Result := CurControl; Break; end; end; end; finally List.Free; end; end; var Ctl: TWinControl; I: Integer; begin if Docked then begin inherited; Exit; end; SendMessage (MDIParentForm.Handle, WM_NCACTIVATE, Ord(Message.Active <> WA_INACTIVE), 0); inherited; if Message.Active = WA_INACTIVE then begin Ctl := FindFirstFocusableNonToolWindowControl(TForm(Owner)); for I := 0 to HookedForms.Count-1 do with PHookedFormInfo(HookedForms[I])^ do if Form = TForm(Owner) then begin if SaveActiveControl <> 0 then Ctl := FindControl(SaveActiveControl); Break; end; if Ctl = nil then { Can't leave Ctl set to nil or the VCL will automatically pick a new ActiveControl (which we don't want, because it could be another tool window). So just set Ctl to FloatParent, which effectively leaves no currently focused control on the form. } Ctl := FloatParent; TForm(Owner).ActiveControl := Ctl; end; end; procedure TCustomToolWindow97.WMMouseActivate (var Message: TWMMouseActivate); begin if Docked or (csDesigning in ComponentState) then inherited else begin { When floating, prevent the toolbar from activating when clicked. This is so it doesn't take the focus away from the window that had it } Message.Result := MA_NOACTIVATE; { Similar to calling BringWindowToTop, but doesn't activate it } SetWindowPos (Handle, HWND_TOP, 0, 0, 0, 0, SWP_NOACTIVATE or SWP_NOMOVE or SWP_NOSIZE); { Since it is returning MA_NOACTIVATE, activate the form instead. } if FActivateParent and (GetActiveWindow <> Handle) then begin { ^ Note to self: That must be in there so that double-clicks work properly on controls like Edits } SetActiveWindow (MDIParentForm.Handle); if MDIParentForm <> TForm(Owner) then { if it's an MDI child form } BringWindowToTop (TForm(Owner).Handle); end; end; end; procedure TCustomToolWindow97.BeginMoving (const InitX, InitY: Integer); type PDockedSize = ^TDockedSize; TDockedSize = record Dock: TDock97; Size: TPoint; end; var NewDockedSizes: TList; {items are pointers to TDockedSizes} MouseOverDock: TDock97; MoveRect: TRect; PreventDocking: Boolean; ScreenDC: HDC; NPoint, DPoint: TPoint; procedure Dropped; var NewDockRow: Integer; Before: Boolean; MoveRectClient: TRect; C: Integer; begin if MouseOverDock <> nil then begin MoveRectClient := MoveRect; MapWindowPoints (0, MouseOverDock.Handle, MoveRectClient, 2); if not(MouseOverDock.Position in PositionLeftOrRight) then C := (MoveRectClient.Top+MoveRectClient.Bottom) div 2 else C := (MoveRectClient.Left+MoveRectClient.Right) div 2; NewDockRow := MouseOverDock.GetRowOf(C, Before); if Before then MouseOverDock.InsertRowBefore (NewDockRow) else if FullSize and (MouseOverDock.GetNumberOfToolbarsOnRow(NewDockRow, Self) <> 0) then begin Inc (NewDockRow); MouseOverDock.InsertRowBefore (NewDockRow); end; FDockRow := NewDockRow; if not(MouseOverDock.Position in PositionLeftOrRight) then FDockPos := MoveRectClient.Left else FDockPos := MoveRectClient.Top; DockedTo := MouseOverDock; end else begin FFloatingTopLeft := MoveRect.TopLeft; DockedTo := nil; end; { Make sure it doesn't go completely off the screen } MoveOnScreen (True); end; procedure MouseMoved; var OldMouseOverDock: TDock97; OldMoveRect: TRect; Pos: TPoint; function CheckIfCanDockTo (Control: TDock97): Boolean; const DockSensX = 32; DockSensY = 20; var R, S, Temp: TRect; I: Integer; Sens: Integer; begin with Control do begin Result := False; R := ClientRect; MapWindowPoints (Handle, 0, R, 2); for I := 0 to NewDockedSizes.Count-1 do with PDockedSize(NewDockedSizes[I])^ do begin if Dock <> Control then Continue; S := Bounds(Pos.X-MulDiv(Size.X-1, NPoint.X, DPoint.X), Pos.Y-MulDiv(Size.Y-1, NPoint.Y, DPoint.Y), Size.X, Size.Y); Break; end; if (R.Left = R.Right) or (R.Top = R.Bottom) then begin if not(Control.Position in PositionLeftOrRight) then InflateRect (R, 0, 1) else InflateRect (R, 1, 0); end; { Like Office 97, distribute ~32 pixels of extra dock detection area to the left side if the toolbar was grabbed at the left, both sides if the toolbar was grabbed at the middle, or the right side if toolbar was grabbed at the right. If outside, don't try to dock. } Sens := MulDiv(DockSensX, NPoint.X, DPoint.X); if (Pos.X < R.Left-(DockSensX-Sens)) or (Pos.X > R.Right-1+Sens) then Exit; { Don't try to dock to the left or right if pointer is above or below the boundaries of the dock } if (Control.Position in PositionLeftOrRight) and ((Pos.Y < R.Top) or (Pos.Y >= R.Bottom)) then Exit; { And also distribute ~20 pixels of extra dock detection area to the top or bottom side } Sens := MulDiv(DockSensY, NPoint.Y, DPoint.Y); if (Pos.Y < R.Top-(DockSensY-Sens)) or (Pos.Y > R.Bottom-1+Sens) then Exit; Result := IntersectRect(Temp, R, S); end; end; var R: TRect; D: TDockPosition; I: Integer; Accept: Boolean; begin OldMouseOverDock := MouseOverDock; OldMoveRect := MoveRect; GetCursorPos (Pos); { Check if it can dock } MouseOverDock := nil; if not PreventDocking then begin { Search through the form's controls and see if it can find a Dock97. If it finds one, assign it to MouseOverDock. } with TForm(Owner) do for D := Low(D) to High(D) do if D in DockableTo then for I := 0 to ComponentCount-1 do if (Components[I] is TDock97) and (TDock97(Components[I]).Position = D) and TDock97(Components[I]).FAllowDrag and CheckIfCanDockTo(TDock97(Components[I])) then begin MouseOverDock := TDock97(Components[I]); Accept := True; if Assigned(MouseOverDock.FOnRequestDock) then MouseOverDock.FOnRequestDock (MouseOverDock, Self, Accept); if Accept then Break else MouseOverDock := nil; end; end; { If not docking, clip the point so it doesn't get dragged under the taskbar } if MouseOverDock = nil then begin R := GetDesktopArea; if Pos.X < R.Left then Pos.X := R.Left; if Pos.X > R.Right then Pos.X := R.Right; if Pos.Y < R.Top then Pos.Y := R.Top; if Pos.Y > R.Bottom then Pos.Y := R.Bottom; end; for I := 0 to NewDockedSizes.Count-1 do with PDockedSize(NewDockedSizes[I])^ do begin if Dock <> MouseOverDock then Continue; MoveRect := Bounds(Pos.X-MulDiv(Size.X-1, NPoint.X, DPoint.X), Pos.Y-MulDiv(Size.Y-1, NPoint.Y, DPoint.Y), Size.X, Size.Y); Break; end; { Make sure title bar (or at least part of the toolbar) is still accessible if it's dragged almost completely off the screen. This prevents the problem seen in Office 97 where you drag it offscreen so that only the border is visible, sometimes leaving you no way to move it back short of resetting the toolbar. } if MouseOverDock = nil then begin R := GetDesktopArea; with GetBorderSize(Resizable) do InflateRect (R, -(X+4), -(Y+4)); if MoveRect.Bottom < R.Top then OffsetRect (MoveRect, 0, R.Top-MoveRect.Bottom); if MoveRect.Top > R.Bottom then OffsetRect (MoveRect, 0, R.Bottom-MoveRect.Top); if MoveRect.Right < R.Left then OffsetRect (MoveRect, R.Left-MoveRect.Right, 0); if MoveRect.Left > R.Right then OffsetRect (MoveRect, R.Right-MoveRect.Left, 0); I := GetDesktopArea.Top - GetBorderSize(Resizable).Y - GetSmallCaptionHeight + 4; if MoveRect.Top < I then OffsetRect (MoveRect, 0, I-MoveRect.Top); end; { Update the dragging outline } DrawDraggingOutline (ScreenDC, @MoveRect, @OldMoveRect, MouseOverDock <> nil, OldMouseOverDock <> nil); end; var Accept: Boolean; R: TRect; Msg: TMsg; NewDockedSize: PDockedSize; I: Integer; begin Accept := False; NPoint := Point(InitX, InitY); { Adjust for non-client area } GetWindowRect (Handle, R); R.BottomRight := ClientToScreen(Point(0, 0)); Dec (NPoint.X, R.Left-R.Right); Dec (NPoint.Y, R.Top-R.Bottom); DPoint := Point(Width-1, Height-1); PreventDocking := GetKeyState(VK_CONTROL) < 0; { Set up potential sizes for each dock type } NewDockedSizes := TList.Create; try SetRectEmpty (R); CustomArrangeControls (atNone, DockedTo, nil, R.BottomRight); AddFloatingNCAreaToRect (R, Resizable); New (NewDockedSize); try with NewDockedSize^ do begin Dock := nil; Size := Point(R.Right-R.Left, R.Bottom-R.Top); end; NewDockedSizes.Add (NewDockedSize); except Dispose (NewDockedSize); raise; end; with TForm(Owner) do for I := 0 to ComponentCount-1 do begin if not(Components[I] is TDock97) then Continue; New (NewDockedSize); try with NewDockedSize^ do begin Dock := TDock97(Components[I]); if Components[I] <> DockedTo then CustomArrangeControls (atNone, DockedTo, TDock97(Components[I]), Size) else Size := Self.ClientRect.BottomRight; AddDockedNCAreaToSize (Size, TDock97(Components[I]).Position in PositionLeftOrRight, FDragHandle); end; NewDockedSizes.Add (NewDockedSize); except Dispose (NewDockedSize); raise; end; end; { Before locking, make sure all pending paint messages are processed } ProcessPaintMessages; { This uses LockWindowUpdate to suppress all window updating so the dragging outlines doesn't sometimes get garbled. (This is safe, and in fact, is the main purpose of the LockWindowUpdate function) IMPORTANT! While debugging you might want to enable the 'TB97DisableLock' conditional define (see top of the source code). } {$IFNDEF TB97DisableLock} LockWindowUpdate (GetDesktopWindow); {$ENDIF} { Get a DC of the entire screen. Works around the window update lock by specifying DCX_LOCKWINDOWUPDATE. } ScreenDC := GetDCEx(GetDesktopWindow, 0, DCX_LOCKWINDOWUPDATE or DCX_CACHE or DCX_WINDOW); try SetCapture (Handle); { Initialize } MouseOverDock := nil; SetRectEmpty (MoveRect); MouseMoved; { Stay in message loop until capture is lost. Capture is removed either by this procedure manually doing it, or by an outside influence (like a message box or menu popping up) } while GetCapture = Handle do begin case Integer(GetMessage(Msg, 0, 0, 0)) of -1: Break; { if GetMessage failed } 0: begin { Repost WM_QUIT messages } PostQuitMessage (Msg.WParam); Break; end; end; case Msg.Message of WM_KEYDOWN, WM_KEYUP: { Ignore all keystrokes while dragging. But process Ctrl and Escape } case Msg.WParam of VK_CONTROL: if PreventDocking <> (Msg.Message = WM_KEYDOWN) then begin PreventDocking := Msg.Message = WM_KEYDOWN; MouseMoved; end; VK_ESCAPE: Break; end; WM_MOUSEMOVE: { Note to self: WM_MOUSEMOVE messages should never be dispatched here to ensure no hints get shown during the drag process } MouseMoved; WM_LBUTTONDOWN, WM_LBUTTONDBLCLK: { Make sure it doesn't begin another loop } Break; WM_LBUTTONUP: begin Accept := True; Break; end; WM_RBUTTONDOWN..WM_MBUTTONDBLCLK: { Ignore all other mouse up/down messages } ; else TranslateMessage (Msg); DispatchMessage (Msg); end; end; finally { Since it sometimes breaks out of the loop without capture being released } if GetCapture = Handle then ReleaseCapture; { Hide dragging outline and release the DC } DrawDraggingOutline (ScreenDC, nil, @MoveRect, False, MouseOverDock <> nil); ReleaseDC (GetDesktopWindow, ScreenDC); { Release window update lock } {$IFNDEF TB97DisableLock} LockWindowUpdate (0); {$ENDIF} end; { Move to new position } if Accept then Dropped; finally for I := NewDockedSizes.Count-1 downto 0 do Dispose (PDockedSize(NewDockedSizes[I])); NewDockedSizes.Free; end; end; procedure TCustomToolWindow97.MouseDown (Button: TMouseButton; Shift: TShiftState; X, Y: Integer); function ControlExistsAtPos (const P: TPoint): Boolean; var I: Integer; begin Result := False; for I := 0 to ControlCount-1 do if not(Controls[I] is TToolbarSep97) and Controls[I].Visible and PtInRect(Controls[I].BoundsRect, P) then begin Result := True; Break; end; end; begin inherited; if (Button <> mbLeft) or { Ignore message if user clicked on a child control that was probably disabled } ControlExistsAtPos(Point(X, Y)) or (Docked and not DockedTo.FAllowDrag) then Exit; { Handle double click } if ssDouble in Shift then begin if Docked then DockedTo := nil else begin FDockRow := ForceDockAtTopRow; FDockPos := ForceDockAtLeftPos; DockedTo := DefaultDock; end; Exit; end; BeginMoving (X, Y); end; procedure TCustomToolWindow97.WMNCHitTest (var Message: TWMNCHitTest); var P: TPoint; BorderSize: TPoint; C: Integer; begin inherited; with Message do if Docked then begin if Result = HTNOWHERE then Result := HTCLIENT; end else begin P := SmallPointToPoint(Pos); Dec (P.X, Left); Dec (P.Y, Top); if Result <> HTCLIENT then begin if PtInRect(GetCaptionRect(Self, True, False), P) then begin if FCloseButton and PtInRect(GetCloseButtonRect(Self, True), P) then Result := HTCLOSE else Result := HTCLIENT; end else begin if Result in [HTLEFT..HTBOTTOMRIGHT] {set covers all resizing corners} then Result := HTNOWHERE; { handles all resize hit-tests itself } if Resizable then begin BorderSize := GetBorderSize(Resizable); C := BorderSize.X + (GetSmallCaptionHeight-1); if not Params.ResizeEightCorner then begin if (P.Y >= 0) and (P.Y < BorderSize.Y) then Result := HTTOP else if (P.Y < Height) and (P.Y >= Height-BorderSize.Y-1) then Result := HTBOTTOM else if (P.X >= 0) and (P.X < BorderSize.X) then Result := HTLEFT else if (P.X < Width) and (P.X >= Width-BorderSize.X-1) then Result := HTRIGHT; end else begin if (P.X >= 0) and (P.X < BorderSize.X) then begin Result := HTLEFT; if (P.Y < C) then Result := HTTOPLEFT else if (P.Y >= Height-C) then Result := HTBOTTOMLEFT; end else if (P.X < Width) and (P.X >= Width-BorderSize.X-1) then begin Result := HTRIGHT; if (P.Y < C) then Result := HTTOPRIGHT else if (P.Y >= Height-C) then Result := HTBOTTOMRIGHT; end else if (P.Y >= 0) and (P.Y < BorderSize.Y) then begin Result := HTTOP; if (P.X < C) then Result := HTTOPLEFT else if (P.X >= Width-C) then Result := HTTOPRIGHT; end else if (P.Y < Height) and (P.Y >= Height-BorderSize.Y-1) then begin Result := HTBOTTOM; if (P.X < C) then Result := HTBOTTOMLEFT else if (P.X >= Width-C) then Result := HTBOTTOMRIGHT; end; end; end; end; end; end; end; procedure TCustomToolWindow97.WMNCLButtonDown (var Message: TWMNCLButtonDown); procedure CloseButtonLoop; var Accept, NewCloseButtonDown: Boolean; P: TPoint; Msg: TMsg; begin Accept := False; CloseButtonDown := True; DrawFloatingNCArea (0, False, False, True); SetCapture (Handle); try while GetCapture = Handle do begin case Integer(GetMessage(Msg, 0, 0, 0)) of -1: Break; { if GetMessage failed } 0: begin { Repost WM_QUIT messages } PostQuitMessage (Msg.WParam); Break; end; end; case Msg.Message of WM_KEYDOWN, WM_KEYUP: { Ignore all keystrokes while in a close button loop } ; WM_MOUSEMOVE: begin { Note to self: WM_MOUSEMOVE messages should never be dispatched here to ensure no hints get shown } GetCursorPos (P); Dec (P.X, Left); Dec (P.Y, Top); NewCloseButtonDown := PtInRect(GetCloseButtonRect(Self, True), P); if CloseButtonDown <> NewCloseButtonDown then begin CloseButtonDown := NewCloseButtonDown; DrawFloatingNCArea (0, False, False, True); end; end; WM_LBUTTONDOWN, WM_LBUTTONDBLCLK: { Make sure it doesn't begin another loop } Break; WM_LBUTTONUP: begin if CloseButtonDown then Accept := True; Break; end; WM_RBUTTONDOWN..WM_MBUTTONDBLCLK: { Ignore all other mouse up/down messages } ; else TranslateMessage (Msg); DispatchMessage (Msg); end; end; finally if GetCapture = Handle then ReleaseCapture; if CloseButtonDown <> False then begin CloseButtonDown := False; DrawFloatingNCArea (0, False, False, True); end; end; if Accept then begin { Hide the window after close button is pushed } Hide; if Assigned(FOnClose) then FOnClose (Self); end; end; var Accept: Boolean; NewRect: TRect; begin case Message.HitTest of HTLEFT..HTBOTTOMRIGHT: if not Docked then begin Accept := False; SetRectEmpty (NewRect); BeginSizing (Message.HitTest, Accept, NewRect); if Accept then begin Inc (FDisableArrangeControls); try BoundsRect := NewRect; finally Dec (FDisableArrangeControls); end; ArrangeControls; { Make sure it doesn't go completely off the screen } MoveOnScreen (True); end; end; HTCLOSE: if not Docked then CloseButtonLoop; else inherited; end; end; procedure TCustomToolWindow97.GetParams (var Params: TToolWindowParams); begin with Params do begin CallAlignControls := True; ResizeEightCorner := True; ResizeClipCursor := True; end; end; procedure TCustomToolWindow97.ResizeBegin; begin end; procedure TCustomToolWindow97.ResizeTrack (var Rect: TRect; const OrigRect: TRect); begin end; procedure TCustomToolWindow97.ResizeEnd; begin end; procedure TCustomToolWindow97.BeginSizing (const HitTestValue: Integer; var Accept: Boolean; var NewRect: TRect); var DragX, DragY, ReverseX, ReverseY: Boolean; MinWidth, MinHeight: Integer; DragRect, OrigDragRect: TRect; ScreenDC: HDC; OrigPos, OldPos: TPoint; procedure MouseMoved; var Pos: TPoint; OldDragRect: TRect; begin GetCursorPos (Pos); { It needs to check if the cursor actually moved since last time. This is because a call to LockWindowUpdate (apparently) generates a mouse move message even when mouse hasn't moved. } if (Pos.X = OldPos.X) and (Pos.Y = OldPos.Y) then Exit; OldPos := Pos; OldDragRect := DragRect; DragRect := OrigDragRect; if DragX then begin if not ReverseX then Inc (DragRect.Right, Pos.X-OrigPos.X) else Inc (DragRect.Left, Pos.X-OrigPos.X); end; if DragY then begin if not ReverseY then Inc (DragRect.Bottom, Pos.Y-OrigPos.Y) else Inc (DragRect.Top, Pos.Y-OrigPos.Y); end; if DragRect.Right-DragRect.Left < MinWidth then begin if not ReverseX then DragRect.Right := DragRect.Left + MinWidth else DragRect.Left := DragRect.Right - MinWidth; end; if DragRect.Bottom-DragRect.Top < MinHeight then begin if not ReverseY then DragRect.Bottom := DragRect.Top + MinHeight else DragRect.Top := DragRect.Bottom - MinHeight; end; ResizeTrack (DragRect, OrigDragRect); DrawDraggingOutline (ScreenDC, @DragRect, @OldDragRect, False, False); end; var Msg: TMsg; R: TRect; begin Accept := False; GetMinimumSize (MinWidth, MinHeight); Inc (MinWidth, Width-ClientWidth); Inc (MinHeight, Height-ClientHeight); DragX := HitTestValue in [HTLEFT, HTRIGHT, HTTOPLEFT, HTTOPRIGHT, HTBOTTOMLEFT, HTBOTTOMRIGHT]; ReverseX := HitTestValue in [HTLEFT, HTTOPLEFT, HTBOTTOMLEFT]; DragY := HitTestValue in [HTTOP, HTTOPLEFT, HTTOPRIGHT, HTBOTTOM, HTBOTTOMLEFT, HTBOTTOMRIGHT]; ReverseY := HitTestValue in [HTTOP, HTTOPLEFT, HTTOPRIGHT]; ResizeBegin (HitTestValue); try { Before locking, make sure all pending paint messages are processed } ProcessPaintMessages; { This uses LockWindowUpdate to suppress all window updating so the dragging outlines doesn't sometimes get garbled. (This is safe, and in fact, is the main purpose of the LockWindowUpdate function) IMPORTANT! While debugging you might want to enable the 'TB97DisableLock' conditional define (see top of the source code). } {$IFNDEF TB97DisableLock} LockWindowUpdate (GetDesktopWindow); {$ENDIF} { Get a DC of the entire screen. Works around the window update lock by specifying DCX_LOCKWINDOWUPDATE. } ScreenDC := GetDCEx(GetDesktopWindow, 0, DCX_LOCKWINDOWUPDATE or DCX_CACHE or DCX_WINDOW); try SetCapture (Handle); if Params.ResizeClipCursor then begin R := GetDesktopArea; ClipCursor (@R); end; { Initialize } OrigDragRect := BoundsRect; DragRect := OrigDragRect; DrawDraggingOutline (ScreenDC, @DragRect, nil, False, False); GetCursorPos (OrigPos); OldPos := OrigPos; { Stay in message loop until capture is lost. Capture is removed either by this procedure manually doing it, or by an outside influence (like a message box or menu popping up) } while GetCapture = Handle do begin case Integer(GetMessage(Msg, 0, 0, 0)) of -1: Break; { if GetMessage failed } 0: begin { Repost WM_QUIT messages } PostQuitMessage (Msg.WParam); Break; end; end; case Msg.Message of WM_KEYDOWN, WM_KEYUP: { Ignore all keystrokes while sizing except for Escape } if Msg.WParam = VK_ESCAPE then Break; WM_MOUSEMOVE: { Note to self: WM_MOUSEMOVE messages should never be dispatched here to ensure no hints get shown during the drag process } MouseMoved; WM_LBUTTONDOWN, WM_LBUTTONDBLCLK: { Make sure it doesn't begin another loop } Break; WM_LBUTTONUP: begin Accept := True; Break; end; WM_RBUTTONDOWN..WM_MBUTTONDBLCLK: { Ignore all other mouse up/down messages } ; else TranslateMessage (Msg); DispatchMessage (Msg); end; end; finally { Since it sometimes breaks out of the loop without capture being released } if GetCapture = Handle then ReleaseCapture; ClipCursor (nil); { Hide dragging outline and release the DC } DrawDraggingOutline (ScreenDC, nil, @DragRect, False, False); ReleaseDC (GetDesktopWindow, ScreenDC); { Release window update lock } {$IFNDEF TB97DisableLock} LockWindowUpdate (0); {$ENDIF} end; finally ResizeEnd (Accept); end; if Accept then NewRect := DragRect; end; procedure TCustomToolWindow97.WMClose (var Message: TWMClose); begin { A floating toolbar does not use WM_CLOSE messages when its close button is clicked, but Windows still sends a WM_CLOSE message if the user presses Alt+F4 while one of the toolbar's controls is focused. Inherited is not called since we do not want Windows' default processing - which destroys the window. Instead, relay the message to the parent form. } SendMessage (MDIParentForm.Handle, WM_CLOSE, 0, 0); { Note to self: MDIParentForm is used instead of TForm(Owner) since MDI childs don't process Alt+F4 as Close } end; class function TCustomToolWindow97.NewMainWindowHook (var Message: TMessage): Boolean; var I: Integer; begin Result := False; case Message.Msg of CM_ACTIVATE, CM_DEACTIVATE: for I := 0 to MainHookedForms.Count-1 do { Hide or restore toolbars when application is deactivated or activated } ShowHideFloatParents (GetMDIParent(PMainHookedFormInfo(MainHookedForms[I]).Form), Message.Msg = CM_ACTIVATE); WM_TB97DoneCreating: if (Message.WParam = WM_TB97DoneCreating_Magic) and (Message.LParam = WM_TB97DoneCreating_Magic) then for I := DoneCreatingList.Count-1 downto 0 do begin ShowHideFloatParents (TCustomToolWindow97(DoneCreatingList[I]).MDIParentForm, Application.Active); DoneCreatingList.Delete (I); end; end; end; { TCustomToolWindow97 - property access methods } procedure TCustomToolWindow97.SetCloseButton (Value: Boolean); begin if FCloseButton <> Value then begin FCloseButton := Value; { Update the close button's visibility } DrawFloatingNCArea (0, False, True, True); end; end; procedure TCustomToolWindow97.SetDefaultDock (Value: TDock97); begin if FDefaultDock <> Value then begin FDefaultDock := Value; if Assigned(Value) then Value.FreeNotification (Self); end; end; procedure TCustomToolWindow97.SetDockedTo (Value: TDock97); var OldDockedTo: TDock97; HiddenInced: Boolean; TempSize: TPoint; begin OldDockedTo := DockedTo; if Assigned(FOnDockChanging) and (Value <> OldDockedTo) then FOnDockChanging (Self); Inc (FUpdatingBounds); try if Assigned(Value) then Inc (Value.DisableArrangeToolbars); try { Before changing between docked and floating state (and vice-versa) or between docks, hide the toolbar. This prevents any flashing while it's being moved } HiddenInced := False; if not(csDesigning in ComponentState) and (Value <> OldDockedTo) and (Visible) then begin Inc (FHidden); HiddenInced := True; if Assigned(OldDockedTo) then { Need to disable arranging of current dock so it doesn't lose it's FDockRow/FDockPos it's going to set later } Inc (OldDockedTo.DisableArrangeToolbars); try Hide; {must Hide AFTER incing Hidden} finally if Assigned(OldDockedTo) then Dec (OldDockedTo.DisableArrangeToolbars); end; end; try if Value <> nil then begin { Must pre-arrange controls in new dock orientation before changing the Parent } if Parent <> nil then CustomArrangeControls (atMoveControls, OldDockedTo, Value, TempSize); if Parent <> Value then begin Inc (FDisableArrangeControls); try Parent := Value; finally Dec (FDisableArrangeControls); end; end; ArrangeControls; { Temporarily put it off the edge of the parent window when changing parents so that no momentary "flicker" occurs when it shows the toolbar again before it gets positioned } if Value <> OldDockedTo then SetBounds (-Width, -Height, Width, Height); end else begin { Must pre-arrange controls in new dock orientation before changing the Parent } if Parent <> nil then CustomArrangeControls (atMoveControls, OldDockedTo, Value, TempSize); Inc (FDisableArrangeControls); try if Parent <> FloatParent then Parent := FloatParent; SetBounds (FFloatingTopLeft.X, FFloatingTopLeft.Y, Width, Height); MoveOnScreen (True); finally Dec (FDisableArrangeControls); end; ArrangeControls; end; finally if HiddenInced then begin Dec (FHidden); Show; end; end; finally if Assigned(Value) then Dec (Value.DisableArrangeToolbars); end; finally Dec (FUpdatingBounds); end; if Assigned(Value) then Value.ArrangeToolbars; if Assigned(FOnDockChanged) and (Value <> OldDockedTo) then FOnDockChanged (Self); end; procedure TCustomToolWindow97.SetDockPos (Value: Integer); begin FDockPos := Value; if Docked then DockedTo.ArrangeToolbars; end; procedure TCustomToolWindow97.SetDockRow (Value: Integer); begin FDockRow := Value; if Docked then DockedTo.ArrangeToolbars; end; procedure TCustomToolWindow97.SetDragHandle (Value: Boolean); begin if FDragHandle <> Value then begin FDragHandle := 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 TCustomToolWindow97.SetFullSize (Value: Boolean); begin if FFullSize <> Value then begin FFullSize := Value; ArrangeControls; end; end; procedure TCustomToolWindow97.SetResizable (Value: Boolean); begin if FResizable <> Value then begin FResizable := Value; if not Docked then begin { Recalculate the non-client area } SetWindowPos (Handle, 0, 0, 0, 0, 0, SWP_FRAMECHANGED or SWP_NOACTIVATE or SWP_NOMOVE or SWP_NOSIZE or SWP_NOZORDER); { The VCL does not automatically realign child controls when the non-client size changes, so do it manually } Realign; end; end; end; { TCustomToolbar97 } constructor TCustomToolbar97.Create (AOwner: TComponent); begin inherited; GroupInfo := TList.Create; SlaveInfo := TList.Create; LineSeps := TList.Create; OrderList := TList.Create; { There hasn't been any child controls added yet, but call ArrangeControls to initialize the toolbar's size } ArrangeControls; end; destructor TCustomToolbar97.Destroy; var I: Integer; begin OrderList.Free; LineSeps.Free; if Assigned(SlaveInfo) then begin for I := SlaveInfo.Count-1 downto 0 do FreeMem (SlaveInfo.Items[I]); SlaveInfo.Free; end; FreeGroupInfo (GroupInfo); GroupInfo.Free; inherited; end; procedure TCustomToolbar97.ReadPositionData (const ReadIntProc: TPositionReadIntProc; const ReadStringProc: TPositionReadStringProc; const ExtraData: Pointer); begin inherited; FFloatingRightX := ReadIntProc(Name, rvFloatRightX, 0, ExtraData); end; procedure TCustomToolbar97.WritePositionData (const WriteIntProc: TPositionWriteIntProc; const WriteStringProc: TPositionWriteStringProc; const ExtraData: Pointer); begin inherited; WriteIntProc (Name, rvFloatRightX, FFloatingRightX, ExtraData); end; procedure TCustomToolbar97.GetMinimumSize (var AClientWidth, AClientHeight: Integer); begin AClientWidth := 0; AClientHeight := 0; end; function CompareControls (const Item1, Item2, ExtraData: Pointer): Integer; far; begin with PCompareExtra(ExtraData)^ do if ComparePositions then begin if CurDockType <> dtLeftRight then Result := TControl(Item1).Left - TControl(Item2).Left else Result := TControl(Item1).Top - TControl(Item2).Top; end else with Toolbar.OrderList do Result := IndexOf(Item1) - IndexOf(Item2); end; procedure TCustomToolbar97.InitializeOrdering; var Extra: TCompareExtra; begin inherited; { Initialize order of items in OrderList } if not(csDesigning in ComponentState) then begin with Extra do begin Toolbar := Self; ComparePositions := True; CurDockType := GetDockTypeOf(DockedTo); end; ListSortEx (OrderList, CompareControls, @Extra); end; end; procedure TCustomToolbar97.GetBarSize (var ASize: Integer; const DockType: TDockType); var I: Integer; begin ASize := DefaultBarWidthHeight; for I := 0 to ControlCount-1 do if not(Controls[I] is TToolbarSep97) then with Controls[I] do begin if ShouldBeVisible(Controls[I], DockType = dtLeftRight, False) then begin if DockType = dtLeftRight then begin if Width > ASize then ASize := Width; end else begin if Height > ASize then ASize := Height; end; end; end; end; procedure TCustomToolbar97.GetParams (var Params: TToolWindowParams); begin inherited; with Params do begin CallAlignControls := False; ResizeEightCorner := False; ResizeClipCursor := False; end; end; procedure TCustomToolbar97.Paint; var S: Integer; begin inherited; { Long separators when not docked } if not Docked then for S := 0 to LineSeps.Count-1 do begin with TLineSep(LineSeps[S]) do begin if Blank then Continue; Canvas.Pen.Color := clBtnShadow; Canvas.MoveTo (1, Y-4); Canvas.LineTo (ClientWidth-1, Y-4); Canvas.Pen.Color := clBtnHighlight; Canvas.MoveTo (1, Y-3); Canvas.LineTo (ClientWidth-1, Y-3); end; end; end; function TCustomToolbar97.ShouldBeVisible (const Control: TControl; const LeftOrRight: Boolean; const SetIt: Boolean): Boolean; { If Control is a master or slave control, it returns the appropriate visibility setting based on the value of LeftOrRight, otherwise it simply returns the current Visible setting. If SetIt is True, it automatically adjusts the Visible properties of both the master and slave control. } var I: Integer; begin for I := 0 to SlaveInfo.Count-1 do with PSlaveInfo(SlaveInfo[I])^ do if TopBottom = Control then begin Result := not LeftOrRight; if SetIt then begin TopBottom.Visible := Result; LeftRight.Visible := not Result; end; Exit; end else if LeftRight = Control then begin Result := LeftOrRight; if SetIt then begin TopBottom.Visible := not Result; LeftRight.Visible := Result; end; Exit; end; Result := Control.Visible; end; procedure TCustomToolbar97.FreeGroupInfo (const List: TList); var I: Integer; L: PGroupInfo; begin if List = nil then Exit; for I := List.Count-1 downto 0 do begin L := List.Items[I]; if Assigned(L) then begin L^.Members.Free; FreeMem (L); end; List.Delete (I); end; end; procedure TCustomToolbar97.BuildGroupInfo (const List: TList; const TranslateSlave: Boolean; const OldDockType, NewDockType: TDockType); var I: Integer; GI: PGroupInfo; Children: TList; {items casted into TControls} NewGroup: Boolean; Extra: TCompareExtra; begin FreeGroupInfo (List); if ControlCount = 0 then Exit; Children := TList.Create; try for I := 0 to ControlCount-1 do if (not TranslateSlave and Controls[I].Visible) or (TranslateSlave and ShouldBeVisible(Controls[I], NewDockType = dtLeftRight, False)) then Children.Add (Controls[I]); with Extra do begin Toolbar := Self; CurDockType := OldDockType; end; if csDesigning in ComponentState then begin Extra.ComparePositions := True; ListSortEx (OrderList, CompareControls, @Extra); end; Extra.ComparePositions := csDesigning in ComponentState; ListSortEx (Children, CompareControls, @Extra); GI := nil; NewGroup := True; for I := 0 to Children.Count-1 do begin if NewGroup then begin NewGroup := False; List.Add (AllocMem(SizeOf(TGroupInfo))); { Note: AllocMem initializes the newly allocated data to zero } GI := List.Last; GI^.Members := TList.Create; end; GI^.Members.Add (Children[I]); if TControl(Children[I]) is TToolbarSep97 then NewGroup := True else begin with TControl(Children[I]) do begin Inc (GI^.GroupWidth, Width); Inc (GI^.GroupHeight, Height); end; end; end; finally Children.Free; end; end; procedure TCustomToolbar97.OrderControls (const CanMoveControls: Boolean; const WasDockedTo, DockingTo: TDock97; var NewClientSize: TPoint); { This arranges the controls on the toolbar } var OldDockType, NewDockType: TDockType; NewDocked: Boolean; RightX, I: Integer; CurBarSize, DockRowSize: Integer; GInfo: TList; AllowWrap: Boolean; BarPosSize, MinPosPixels, MinRowPixels, CurPosPixel, CurLinePixel, G: Integer; NewLine, Prec1Line: Boolean; GI: PGroupInfo; Member: TControl; MemberIsSep: Boolean; GroupPosSize, MemberPosSize: Integer; PreviousSep: TToolbarSep97; PrevMinPosPixels: Integer; NewLineSep: TLineSep; label 1; begin OldDockType := GetDockTypeOf(WasDockedTo); NewDockType := GetDockTypeOf(DockingTo); NewDocked := Assigned(DockingTo); RightX := FFloatingRightX; if (NewDockType <> dtNotDocked) or (RightX = 0) then RightX := High(RightX) else begin { Make sure RightX isn't less than the smallest sized control + margins, in case one of the *LoadToolbarPositions functions happened to read a value too small. } for I := 0 to ControlCount-1 do if not(Controls[I] is TToolbarSep97) then with Controls[I] do if Width + (LeftMarginNotDocked+RightMarginNotDocked) > RightX then RightX := Width + (LeftMarginNotDocked+RightMarginNotDocked); end; if CanMoveControls then for I := 0 to ControlCount-1 do if not(Controls[I] is TToolbarSep97) then ShouldBeVisible (Controls[I], NewDockType = dtLeftRight, True); GetBarSize (CurBarSize, NewDockType); DockRowSize := CurBarSize; if (DockingTo <> nil) and (DockingTo = DockedTo) then GetDockRowSize (DockRowSize); if CanMoveControls then GInfo := GroupInfo else GInfo := TList.Create; try BuildGroupInfo (GInfo, not CanMoveControls, OldDockType, NewDockType); if CanMoveControls then LineSeps.Clear; AllowWrap := not NewDocked; if GInfo.Count <> 0 then begin BarPosSize := CurBarSize; MinPosPixels := 0; CurPosPixel := 0; CurLinePixel := TopMargin[NewDocked]; Prec1Line := True; NewLine := True; PreviousSep := nil; PrevMinPosPixels := 0; for G := 0 to GInfo.Count-1 do begin GI := PGroupInfo(GInfo[G]); if NewDockType <> dtLeftRight then GroupPosSize := GI^.GroupWidth else GroupPosSize := GI^.GroupHeight; if (not AllowWrap) or (Prec1Line) then begin if NewLine then begin NewLine := False; Inc (CurPosPixel, LeftMargin[NewDocked]) end; if CurPosPixel+GroupPosSize+RightMargin[NewDocked] > RightX then goto 1; { I know it's sloppy to use a goto. But it's fast } if CurPosPixel > MinPosPixels then MinPosPixels := CurPosPixel; end else begin 1:CurPosPixel := LeftMargin[NewDocked]; if CurPosPixel > MinPosPixels then MinPosPixels := CurPosPixel; if (G <> 0) and (PGroupInfo(GInfo[G-1])^.Members.Count <> 0) then begin Inc (CurLinePixel, BarPosSize+LineSpacing); if Assigned(PreviousSep) then begin MinPosPixels := PrevMinPosPixels; if CanMoveControls then begin PreviousSep.Width := 0; LongInt(NewLineSep) := 0; NewLineSep.Y := CurLinePixel; NewLineSep.Blank := PreviousSep.Blank; LineSeps.Add (Pointer(NewLineSep)); end; end; end; end; Prec1Line := True; for I := 0 to GI^.Members.Count-1 do begin Member := TControl(GI^.Members[I]); MemberIsSep := Member is TToolbarSep97; with Member do begin if not MemberIsSep then begin if NewDockType <> dtLeftRight then MemberPosSize := Width else MemberPosSize := Height; end else begin if NewDockType <> dtLeftRight then MemberPosSize := TToolbarSep97(Member).SizeHorz else MemberPosSize := TToolbarSep97(Member).SizeVert; end; { If RightX is passed, proceed to next line } if not MemberIsSep and (CurPosPixel+MemberPosSize+RightMargin[NewDocked] > RightX) then begin CurPosPixel := LeftMargin[NewDocked]; if CurPosPixel > MinPosPixels then MinPosPixels := CurPosPixel; Inc (CurLinePixel, CurBarSize); Prec1Line := False; end; if NewDockType <> dtLeftRight then begin if not MemberIsSep then begin if CanMoveControls then SetBounds (CurPosPixel, CurLinePixel+((DockRowSize-Height) div 2), Width, Height); Inc (CurPosPixel, Width); end else begin if CanMoveControls then SetBounds (CurPosPixel, CurLinePixel, TToolbarSep97(Member).SizeHorz, DockRowSize); Inc (CurPosPixel, TToolbarSep97(Member).SizeHorz); end; end else begin if not MemberIsSep then begin if CanMoveControls then SetBounds (CurLinePixel+((DockRowSize-Width) div 2), CurPosPixel, Width, Height); Inc (CurPosPixel, Height); end else begin if CanMoveControls then SetBounds (CurLinePixel, CurPosPixel, DockRowSize, TToolbarSep97(Member).SizeVert); Inc (CurPosPixel, TToolbarSep97(Member).SizeVert); end; end; PrevMinPosPixels := MinPosPixels; if not MemberIsSep then PreviousSep := nil else PreviousSep := TToolbarSep97(Member); if CurPosPixel > MinPosPixels then MinPosPixels := CurPosPixel; end; end; end; end else begin if Docked then begin MinPosPixels := LeftMargin[NewDocked]; CurLinePixel := TopMargin[NewDocked]; Inc (MinPosPixels, DefaultBarWidthHeight); BarPosSize := DockedTo.GetRowSize(FDockRow, Self); end else begin MinPosPixels := LeftMargin[NewDocked] + DefaultBarWidthHeight; CurLinePixel := TopMargin[NewDocked]; BarPosSize := DefaultBarWidthHeight; end; end; if csDesigning in ComponentState then Invalidate; finally if not CanMoveControls then begin FreeGroupInfo (GInfo); GInfo.Free; end; end; Inc (MinPosPixels, RightMargin[NewDocked]); MinRowPixels := CurLinePixel + BarPosSize + BottomMargin[NewDocked]; if NewDockType <> dtLeftRight then begin NewClientSize.X := MinPosPixels; NewClientSize.Y := MinRowPixels; end else begin NewClientSize.X := MinRowPixels; NewClientSize.Y := MinPosPixels; end; end; procedure TCustomToolbar97.CMControlListChange (var Message: TCMControlListChange); { The VCL sends this message is sent whenever a child control is inserted into or deleted from the toolbar } var I: Integer; begin inherited; with Message, OrderList do begin { Delete any previous occurances of Control in OrderList. There shouldn't be any if Inserting=True, but just to be safe, check anyway. } while True do begin I := IndexOf(Control); if I = -1 then Break; Delete (I); end; if Inserting then Add (Control); end; end; function CompareNewSizes (const Item1, Item2, ExtraData: Pointer): Integer; far; begin { Sorts in descending order } if ExtraData = nil then Result := TSmallPoint(Item2).X - TSmallPoint(Item1).X else Result := TSmallPoint(Item2).Y - TSmallPoint(Item1).Y; end; procedure TCustomToolbar97.ResizeBegin (HitTestValue: Integer); var CurBarSize: Integer; procedure BuildNewSizes (const YOrdering: Boolean); { Adds items to the NewSizes list. The list must be empty when this is called } function AddNCAreaToSize (const P: TPoint): TPoint; var R: TRect; begin with R do begin Top := 0; Left := 0; BottomRight := P; end; AddFloatingNCAreaToRect (R, Resizable); OffsetRect (R, -R.Left, -R.Top); Result := R.BottomRight; end; var SaveFloatingRightX: Integer; Max, X, LastY, SkipTo: Integer; S: TPoint; S2: TSmallPoint; begin with PToolbar97SizeData(SizeData)^ do begin SaveFloatingRightX := FFloatingRightX; try FFloatingRightX := 0; CustomArrangeControls (atNone, nil, nil, S); S2 := PointToSmallPoint(AddNCAreaToSize(S)); NewSizes.Add (Pointer(S2)); LastY := S.Y; Max := S.X; SkipTo := High(SkipTo); for X := Max-1 downto LeftMarginNotDocked+CurBarSize+RightMarginNotDocked do begin if X > SkipTo then Continue; FFloatingRightX := X; CustomArrangeControls (atNone, nil, nil, S); if X = S.X then begin if S.Y = LastY then NewSizes.Delete (NewSizes.Count-1); S2 := PointToSmallPoint(AddNCAreaToSize(S)); if NewSizes.IndexOf(Pointer(S2)) = -1 then NewSizes.Add (Pointer(S2)); LastY := S.Y; end else SkipTo := S.X; end; finally FFloatingRightX := SaveFloatingRightX; end; ListSortEx (NewSizes, CompareNewSizes, Pointer(Longint(YOrdering))); end; end; const MaxSizeSens = 12; var I, NewSize: Integer; S, N: TSmallPoint; begin inherited; SizeData := AllocMem(SizeOf(TToolbar97SizeData)); with PToolbar97SizeData(SizeData)^ do begin HitTest := HitTestValue; CurRightX := FFloatingRightX; DisableSensCheck := False; OpSide := False; GetBarSize (CurBarSize, dtNotDocked); NewSizes := TList.Create; BuildNewSizes (HitTestValue in [HTTOP, HTBOTTOM]); SizeSens := MaxSizeSens; { Adjust sensitivity if it's too high } for I := 0 to NewSizes.Count-1 do begin Pointer(S) := NewSizes[I]; if (S.X = Width) and (S.Y = Height) then begin if I > 0 then begin Pointer(N) := NewSizes[I-1]; if HitTestValue in [HTLEFT, HTRIGHT] then NewSize := N.X - S.X - 1 else NewSize := N.Y - S.Y - 1; if NewSize < SizeSens then SizeSens := NewSize; end; if I < NewSizes.Count-1 then begin Pointer(N) := NewSizes[I+1]; if HitTestValue in [HTLEFT, HTRIGHT] then NewSize := S.X - N.X - 1 else NewSize := S.Y - N.Y - 1; if NewSize < SizeSens then SizeSens := NewSize; end; Break; end; end; if SizeSens < 0 then SizeSens := 0; end; end; procedure TCustomToolbar97.ResizeTrack (var Rect: TRect; const OrigRect: TRect); var Pos: TPoint; NCXDiff: Integer; NewOpSide: Boolean; Reverse: Boolean; I: Integer; P: TSmallPoint; begin inherited; with PToolbar97SizeData(SizeData)^ do begin GetCursorPos (Pos); NCXDiff := ClientToScreen(Point(0, 0)).X - Left; Dec (Pos.X, Left); Dec (Pos.Y, Top); if HitTest = HTLEFT then Pos.X := Width-Pos.X else if HitTest = HTTOP then Pos.Y := Height-Pos.Y; { Adjust Pos to make up for the "sizing sensitivity", as seen in Office 97 } if HitTest in [HTLEFT, HTRIGHT] then NewOpSide := Pos.X < Width else NewOpSide := Pos.Y < Height; if (not DisableSensCheck) or (OpSide <> NewOpSide) then begin DisableSensCheck := False; OpSide := NewOpSide; if HitTest in [HTLEFT, HTRIGHT] then begin if (Pos.X >= Width-SizeSens) and (Pos.X < Width+SizeSens) then Pos.X := Width; end else begin if (Pos.Y >= Height-SizeSens) and (Pos.Y < Height+SizeSens) then Pos.Y := Height; end; end; Rect := OrigRect; if HitTest in [HTLEFT, HTRIGHT] then Reverse := Pos.X > Width else Reverse := Pos.Y > Height; if not Reverse then I := NewSizes.Count-1 else I := 0; while True do begin if (not Reverse and (I < 0)) or (Reverse and (I >= NewSizes.Count)) then Break; Pointer(P) := NewSizes[I]; if HitTest in [HTLEFT, HTRIGHT] then begin if (not Reverse and ((I = NewSizes.Count-1) or (Pos.X >= P.X))) or (Reverse and ((I = 0) or (Pos.X < P.X))) then begin if I = 0 then CurRightX := 0 else CurRightX := P.X - NCXDiff*2; if HitTest = HTRIGHT then Rect.Right := Rect.Left + P.X else Rect.Left := Rect.Right - P.X; Rect.Bottom := Rect.Top + P.Y; DisableSensCheck := not EqualRect(Rect, OrigRect); end; end else begin if (not Reverse and ((I = NewSizes.Count-1) or (Pos.Y >= P.Y))) or (Reverse and ((I = 0) or (Pos.Y < P.Y))) then begin if I = NewSizes.Count-1 then CurRightX := 0 else CurRightX := P.X - NCXDiff*2; if HitTest = HTBOTTOM then Rect.Bottom := Rect.Top + P.Y else Rect.Top := Rect.Bottom - P.Y; Rect.Right := Rect.Left + P.X; DisableSensCheck := not EqualRect(Rect, OrigRect); end; end; if not Reverse then Dec (I) else Inc (I); end; end; end; procedure TCustomToolbar97.ResizeEnd (Accept: Boolean); begin inherited; if Assigned(SizeData) then begin with PToolbar97SizeData(SizeData)^ do begin if Accept then FFloatingRightX := CurRightX; NewSizes.Free; end; FreeMem (SizeData); end; end; function TCustomToolbar97.GetOrderIndex (Control: TControl): Integer; begin Result := OrderList.IndexOf(Control); if Result = -1 then raise EInvalidOperation.Create(STB97ToolbarControlNotChildOfToolbar); end; procedure TCustomToolbar97.SetOrderIndex (Control: TControl; Value: Integer); var OldIndex: Integer; begin with OrderList do begin OldIndex := IndexOf(Control); if OldIndex = -1 then raise EInvalidOperation.Create(STB97ToolbarControlNotChildOfToolbar); if Value < 0 then Value := 0; if Value >= Count then Value := Count-1; if Value <> OldIndex then begin Delete (OldIndex); Insert (Value, Control); ArrangeControls; end; end; end; procedure TCustomToolbar97.SetSlaveControl (const ATopBottom, ALeftRight: TControl); var NewVersion: PSlaveInfo; begin GetMem (NewVersion, SizeOf(TSlaveInfo)); with NewVersion^ do begin TopBottom := ATopBottom; LeftRight := ALeftRight; end; SlaveInfo.Add (NewVersion); ArrangeControls; end; { TDockableWindow - internal } constructor TToolWindow97.Create (AOwner: TComponent); var R: TRect; begin inherited; FMinClientWidth := 32; FMinClientHeight := 32; { Initialize the client size to 32x32 } R := GetClientRect; SetBounds (Left, Top, Width - R.Right + 32, Height - R.Bottom + 32); end; procedure TToolWindow97.CreateParams (var Params: TCreateParams); begin inherited; { Disable complete redraws when size changes. CS_H/VREDRAW cause flicker and are not necessary for this control at run time } if not(csDesigning in ComponentState) then with Params.WindowClass do Style := Style and not(CS_HREDRAW or CS_VREDRAW); end; procedure TToolWindow97.ReadPositionData (const ReadIntProc: TPositionReadIntProc; const ReadStringProc: TPositionReadStringProc; const ExtraData: Pointer); begin inherited; { Restore FBarWidth/FBarHeight variables } if Resizable then begin FBarWidth := ReadIntProc(Name, rvClientWidth, FBarWidth, ExtraData); FBarHeight := ReadIntProc(Name, rvClientHeight, FBarHeight, ExtraData); end; end; procedure TToolWindow97.WritePositionData (const WriteIntProc: TPositionWriteIntProc; const WriteStringProc: TPositionWriteStringProc; const ExtraData: Pointer); begin inherited; { Write values of FBarWidth/FBarHeight } WriteIntProc (Name, rvClientWidth, FBarWidth, ExtraData); WriteIntProc (Name, rvClientHeight, FBarHeight, ExtraData); end; procedure TToolWindow97.GetMinimumSize (var AClientWidth, AClientHeight: Integer); begin AClientWidth := FMinClientWidth; AClientHeight := FMinClientHeight; end; procedure TToolWindow97.SizeChanging (const AWidth, AHeight: Integer); begin FBarWidth := AWidth - (Width-ClientWidth); FBarHeight := AHeight - (Height-ClientHeight); end; procedure TToolWindow97.GetBarSize (var ASize: Integer; const DockType: TDockType); begin if DockType <> dtLeftRight then ASize := FBarHeight else ASize := FBarWidth; end; procedure TToolWindow97.OrderControls (const CanMoveControls: Boolean; const WasDockedTo, DockingTo: TDock97; var NewClientSize: TPoint); begin NewClientSize.X := FBarWidth; NewClientSize.Y := FBarHeight; end; { TToolbarSep97 - internal } constructor TToolbarSep97.Create (AOwner: TComponent); begin inherited; FSizeHorz := 6; FSizeVert := 6; ControlStyle := ControlStyle - [csOpaque, csCaptureMouse]; end; procedure TToolbarSep97.SetParent (AParent: TWinControl); begin if (AParent <> nil) and not(AParent is TCustomToolbar97) then raise EInvalidOperation.Create(STB97SepParentNotAllowed); inherited; end; procedure TToolbarSep97.SetBlank (Value: Boolean); begin if FBlank <> Value then begin FBlank := Value; Invalidate; end; end; procedure TToolbarSep97.SetSizeHorz (Value: TToolbarSepSize); begin if FSizeHorz <> Value then begin FSizeHorz := Value; if Parent is TCustomToolbar97 then TCustomToolbar97(Parent).ArrangeControls; end; end; procedure TToolbarSep97.SetSizeVert (Value: TToolbarSepSize); begin if FSizeVert <> Value then begin FSizeVert := Value; if Parent is TCustomToolbar97 then TCustomToolbar97(Parent).ArrangeControls; end; end; procedure TToolbarSep97.Paint; var R: TRect; Z: Integer; begin inherited; if not(Parent is TCustomToolbar97) then Exit; with Canvas do begin { Draw dotted border in design mode } if csDesigning in ComponentState then begin Pen.Style := psDot; Pen.Color := clBtnShadow; Brush.Style := bsClear; R := ClientRect; Rectangle (R.Left, R.Top, R.Right, R.Bottom); Pen.Style := psSolid; end; if not FBlank then if GetDockTypeOf(TCustomToolbar97(Parent).DockedTo) <> dtLeftRight then begin Z := Width div 2; Pen.Color := clBtnShadow; MoveTo (Z-1, 0); LineTo (Z-1, Height); Pen.Color := clBtnHighlight; MoveTo (Z, 0); LineTo (Z, Height); end else begin Z := Height div 2; Pen.Color := clBtnShadow; MoveTo (0, Z-1); LineTo (Width, Z-1); Pen.Color := clBtnHighlight; MoveTo (0, Z); LineTo (Width, Z); end; end; end; procedure TToolbarSep97.MouseDown (Button: TMouseButton; Shift: TShiftState; X, Y: Integer); var P: TPoint; begin inherited; if not(Parent is TCustomToolbar97) then Exit; { Relay the message to the parent toolbar } P := Parent.ScreenToClient(ClientToScreen(Point(X, Y))); TCustomToolbar97(Parent).MouseDown (Button, Shift, P.X, P.Y); end; { TToolbarButton97 - internal } type TGlyphList = class(TImageList) private Used: TBits; FCount: Integer; function AllocateIndex: Integer; public constructor CreateSize (AWidth, AHeight: Integer); destructor Destroy; override; function Add (Image, Mask: TBitmap): Integer; function AddMasked (Image: TBitmap; MaskColor: TColor): Integer; procedure Delete (Index: Integer); property Count: Integer read FCount; end; TGlyphCache = class private GlyphLists: TList; public constructor Create; destructor Destroy; override; function GetList(AWidth, AHeight: Integer): TGlyphList; procedure ReturnList(List: TGlyphList); function Empty: Boolean; end; TBoolInt = record B: Boolean; I: Integer; end; TButtonGlyph = class private FOriginal, FOriginalMask: TBitmap; FCallDormant: Boolean; FGlyphList: array[Boolean] of TGlyphList; FIndexs: array[Boolean, TButtonState97] of Integer; FTransparentColor: TColor; FNumGlyphs: TNumGlyphs97; FOnChange: TNotifyEvent; FOldDisabledStyle: Boolean; procedure GlyphChanged (Sender: TObject); procedure SetGlyph (Value: TBitmap); procedure SetGlyphMask (Value: TBitmap); procedure SetNumGlyphs (Value: TNumGlyphs97); procedure Invalidate; function CreateButtonGlyph (State: TButtonState97): TBoolInt; procedure DrawButtonGlyph (Canvas: TCanvas; const GlyphPos: TPoint; State: TButtonState97); procedure DrawButtonText (Canvas: TCanvas; const Caption: string; TextBounds: TRect; WordWrap: Boolean; State: TButtonState97); procedure CalcButtonLayout (Canvas: TCanvas; const Client: TRect; const Offset: TPoint; DrawGlyph, DrawCaption: Boolean; const Caption: string; WordWrap: Boolean; Layout: TButtonLayout; Margin, Spacing: Integer; DropArrow: Boolean; var GlyphPos, ArrowPos: TPoint; var TextBounds: TRect); public constructor Create; destructor Destroy; override; { returns the text rectangle } function Draw (Canvas: TCanvas; const Client: TRect; const Offset: TPoint; DrawGlyph, DrawCaption: Boolean; const Caption: string; WordWrap: Boolean; Layout: TButtonLayout; Margin, Spacing: Integer; DropArrow: Boolean; State: TButtonState97): TRect; procedure DrawButtonDropArrow (Canvas: TCanvas; const X, Y: Integer; State: TButtonState97); property Glyph: TBitmap read FOriginal write SetGlyph; property GlyphMask: TBitmap read FOriginalMask write SetGlyphMask; property NumGlyphs: TNumGlyphs97 read FNumGlyphs write SetNumGlyphs; property OnChange: TNotifyEvent read FOnChange write FOnChange; end; { TGlyphList } constructor TGlyphList.CreateSize(AWidth, AHeight: Integer); begin inherited CreateSize (AWidth, AHeight); Used := TBits.Create; end; destructor TGlyphList.Destroy; begin Used.Free; inherited; end; function TGlyphList.AllocateIndex: Integer; begin Result := Used.OpenBit; if Result >= Used.Size then begin Result := inherited Add(nil, nil); Used.Size := Result + 1; end; Used[Result] := True; end; function TGlyphList.Add (Image, Mask: TBitmap): Integer; begin Result := AllocateIndex; Replace (Result, Image, Mask); Inc (FCount); end; function TGlyphList.AddMasked (Image: TBitmap; MaskColor: TColor): Integer; procedure BugfreeReplaceMasked (Index: Integer; NewImage: TBitmap; MaskColor: TColor); procedure CheckImage (Image: TGraphic); begin if Image = nil then Exit; if (Image.Height < Height) or (Image.Width < Width) then raise EInvalidOperation.Create({$IFNDEF TB97Delphi3orHigher}LoadStr{$ENDIF}(SInvalidImageSize)); end; var TempIndex: Integer; Image, Mask: TBitmap; begin if HandleAllocated then begin CheckImage(NewImage); TempIndex := inherited AddMasked(NewImage, MaskColor); if TempIndex <> -1 then try Image := TBitmap.Create; Mask := TBitmap.Create; try Image.Height := Height; Image.Width := Width; Mask.Monochrome := True; { ^ Prevents the "invisible glyph" problem when used with certain color schemes. (Fixed in Delphi 3.01) } Mask.Height := Height; Mask.Width := Width; ImageList_Draw (Handle, TempIndex, Image.Canvas.Handle, 0, 0, ILD_NORMAL); ImageList_Draw (Handle, TempIndex, Mask.Canvas.Handle, 0, 0, ILD_MASK); if not ImageList_Replace(Handle, Index, Image.Handle, Mask.Handle) then raise EInvalidOperation.Create({$IFNDEF TB97Delphi3orHigher}LoadStr{$ENDIF}(SReplaceImage)); finally Image.Free; Mask.Free; end; finally inherited Delete(TempIndex); end else raise EInvalidOperation.Create({$IFNDEF TB97Delphi3orHigher}LoadStr{$ENDIF}(SReplaceImage)); end; Change; end; begin Result := AllocateIndex; { This works two very serious bugs in the Delphi 2/BCB and Delphi 3 implementations of the ReplaceMasked method. In the Delphi 2 and BCB versions of the ReplaceMasked method, it incorrectly uses ILD_NORMAL as the last parameter for the second ImageList_Draw call, in effect causing all white colors to be considered transparent also. And in the Delphi 2/3 and BCB versions it doesn't set Monochrome to True on the Mask bitmap, causing the bitmaps to be invisible on certain color schemes. } BugfreeReplaceMasked (Result, Image, MaskColor); Inc (FCount); end; procedure TGlyphList.Delete (Index: Integer); begin if Used[Index] then begin Dec(FCount); Used[Index] := False; end; end; { TGlyphCache } constructor TGlyphCache.Create; begin inherited; GlyphLists := TList.Create; end; destructor TGlyphCache.Destroy; begin GlyphLists.Free; inherited; end; function TGlyphCache.GetList(AWidth, AHeight: Integer): TGlyphList; var I: Integer; begin for I := GlyphLists.Count - 1 downto 0 do begin Result := GlyphLists[I]; with Result do if (AWidth = Width) and (AHeight = Height) then Exit; end; Result := TGlyphList.CreateSize(AWidth, AHeight); GlyphLists.Add(Result); end; procedure TGlyphCache.ReturnList(List: TGlyphList); begin if List = nil then Exit; if List.Count = 0 then begin GlyphLists.Remove(List); List.Free; end; end; function TGlyphCache.Empty: Boolean; begin Result := GlyphLists.Count = 0; end; var GlyphCache: TGlyphCache = nil; Pattern: TBitmap = nil; PatternBtnFace, PatternBtnHighlight: TColor; ButtonCount: Integer = 0; procedure CreateBrushPattern; var X, Y: Integer; begin PatternBtnFace := GetSysColor(COLOR_BTNFACE); PatternBtnHighlight := GetSysColor(COLOR_BTNHIGHLIGHT); Pattern := TBitmap.Create; with Pattern do begin Width := 8; Height := 8; with Canvas do begin Brush.Style := bsSolid; Brush.Color := clBtnFace; FillRect (Rect(0, 0, Width, Height)); for Y := 0 to 7 do for X := 0 to 7 do if Odd(Y) = Odd(X) then { toggles between even/odd pixels } Pixels[X, Y] := clBtnHighlight; { on even/odd rows } end; end; end; { TButtonGlyph } constructor TButtonGlyph.Create; var B: Boolean; I: TButtonState97; begin inherited; FCallDormant := True; FOriginal := TBitmap.Create; FOriginal.OnChange := GlyphChanged; FOriginalMask := TBitmap.Create; FOriginalMask.OnChange := GlyphChanged; FNumGlyphs := 1; for B := False to True do for I := Low(I) to High(I) do FIndexs[B, I] := -1; if GlyphCache = nil then GlyphCache := TGlyphCache.Create; end; destructor TButtonGlyph.Destroy; begin FOriginalMask.Free; FOriginal.Free; Invalidate; if Assigned(GlyphCache) and GlyphCache.Empty then begin GlyphCache.Free; GlyphCache := nil; end; inherited; end; procedure TButtonGlyph.Invalidate; var B: Boolean; I: TButtonState97; begin for B := False to True do begin for I := Low(I) to High(I) do begin if FIndexs[B, I] <> -1 then FGlyphList[B].Delete (FIndexs[B, I]); FIndexs[B, I] := -1; end; GlyphCache.ReturnList (FGlyphList[B]); FGlyphList[B] := nil; end; end; procedure TButtonGlyph.GlyphChanged (Sender: TObject); begin if (Sender = FOriginal) or (Sender = FOriginalMask) then begin if (FOriginal.Width <> 0) and (FOriginal.Height <> 0) then FTransparentColor := FOriginal.Canvas.Pixels[0, FOriginal.Height-1] or $02000000; Invalidate; if Assigned(FOnChange) then FOnChange (Self); end; end; procedure TButtonGlyph.SetGlyph (Value: TBitmap); var Glyphs: Integer; begin Invalidate; FOriginal.Assign (Value); if (Value <> nil) and (Value.Height <> 0) then begin if Value.Width mod Value.Height = 0 then begin Glyphs := Value.Width div Value.Height; if Glyphs > High(TNumGlyphs97) then Glyphs := 1; SetNumGlyphs (Glyphs); end; end; end; procedure TButtonGlyph.SetGlyphMask (Value: TBitmap); begin Invalidate; FOriginalMask.Assign (Value); end; procedure TButtonGlyph.SetNumGlyphs (Value: TNumGlyphs97); begin Invalidate; FNumGlyphs := Value; GlyphChanged (Glyph); end; function TButtonGlyph.CreateButtonGlyph (State: TButtonState97): TBoolInt; const ROP_DSPDxax = $00E20746; ROP_PSDPxax = $00B8074A; ROP_DSna = $00220326; { D & ~S } procedure GenerateMaskBitmapFromDIB (const MaskBitmap, SourceBitmap: TBitmap; const SourceOffset, SourceSize: TPoint; TransColors: array of TColor); { This a special procedure meant for generating monochrome masks from >4 bpp color DIB sections. Because each video driver seems to sport its own interpretation of how to handle DIB sections, a workaround procedure like this was necessary. } type TColorArray = array[0..536870910] of TColorRef; var Info: packed record Header: TBitmapInfoHeader; Colors: array[0..1] of TColorRef; end; W, H: Integer; I, Y, X: Integer; Pixels: ^TColorArray; Pixel: ^TColorRef; MonoPixels: Pointer; MonoPixel, StartMonoPixel: ^Byte; MonoScanLineSize, CurBit: Integer; DC: HDC; MaskBmp: HBITMAP; begin W := SourceBitmap.Width; H := SourceBitmap.Height; MonoScanLineSize := SourceSize.X div 8; if MonoScanLineSize mod 4 <> 0 then { Compensate for scan line boundary } Inc (MonoScanLineSize, 4 - (MonoScanLineSize mod 4)); MonoPixels := AllocMem(MonoScanLineSize * SourceSize.Y); { AllocMem is used because it initializes to zero } try GetMem (Pixels, W * H * 4); try FillChar (Info, SizeOf(Info), 0); with Info do begin with Header do begin biSize := SizeOf(TBitmapInfoHeader); biWidth := W; biHeight := -H; { negative number makes it a top-down DIB } biPlanes := 1; biBitCount := 32; {biCompression := BI_RGB;} { implied due to the FillChar zeroing } end; {Colors[0] := clBlack;} { implied due to the FillChar zeroing } Colors[1] := clWhite; end; DC := CreateCompatibleDC(0); GetDIBits (DC, SourceBitmap.Handle, 0, H, Pixels, PBitmapInfo(@Info)^, DIB_RGB_COLORS); DeleteDC (DC); for I := 0 to High(TransColors) do if TransColors[I] = -1 then TransColors[I] := Pixels[W * (H-1)] and $FFFFFF; { ^ 'and' operation is necessary because the high byte is undefined } MonoPixel := MonoPixels; for Y := SourceOffset.Y to SourceOffset.Y+SourceSize.Y-1 do begin StartMonoPixel := MonoPixel; CurBit := 7; Pixel := @Pixels[(Y * W) + SourceOffset.X]; for X := 0 to SourceSize.X-1 do begin for I := 0 to High(TransColors) do if Pixel^ and $FFFFFF = Cardinal(TransColors[I]) then begin { ^ 'and' operation is necessary because the high byte is undefined } MonoPixel^ := MonoPixel^ or (1 shl CurBit); Break; end; Dec (CurBit); if CurBit < 0 then begin Inc (Integer(MonoPixel)); CurBit := 7; end; Inc (Integer(Pixel), SizeOf(Longint)); { proceed to the next pixel } end; Integer(MonoPixel) := Integer(StartMonoPixel) + MonoScanLineSize; end; finally FreeMem (Pixels); end; { Write new bits into a new HBITMAP, and assign this handle to MaskBitmap } MaskBmp := CreateBitmap(SourceSize.X, SourceSize.Y, 1, 1, nil); with Info.Header do begin biWidth := SourceSize.X; biHeight := -SourceSize.Y; { negative number makes it a top-down DIB } biPlanes := 1; biBitCount := 1; end; DC := CreateCompatibleDC(0); SetDIBits (DC, MaskBmp, 0, SourceSize.Y, MonoPixels, PBitmapInfo(@Info)^, DIB_RGB_COLORS); DeleteDC (DC); finally FreeMem (MonoPixels); end; MaskBitmap.Handle := MaskBmp; end; procedure GenerateMaskBitmap (const MaskBitmap, SourceBitmap: TBitmap; const SourceOffset, SourceSize: TPoint; const TransColors: array of TColor); { Returns handle of a monochrome bitmap, with pixels in SourceBitmap of color TransColor set to white in the resulting bitmap. All other colors of SourceBitmap are set to black in the resulting bitmap. This uses the regular ROP_DSPDxax BitBlt method. } var CanvasHandle: HDC; SaveBkColor: TColorRef; DC: HDC; MaskBmp, SaveBmp: HBITMAP; I: Integer; const ROP: array[Boolean] of DWORD = (SRCPAINT, SRCCOPY); begin CanvasHandle := SourceBitmap.Canvas.Handle; MaskBmp := CreateBitmap(SourceSize.X, SourceSize.Y, 1, 1, nil); DC := CreateCompatibleDC(0); SaveBmp := SelectObject(DC, MaskBmp); SaveBkColor := GetBkColor(CanvasHandle); for I := 0 to High(TransColors) do begin SetBkColor (CanvasHandle, ColorToRGB(TransColors[I])); BitBlt (DC, 0, 0, SourceSize.X, SourceSize.Y, CanvasHandle, SourceOffset.X, SourceOffset.Y, ROP[I = 0]); end; SetBkColor (CanvasHandle, SaveBkColor); SelectObject (DC, SaveBmp); DeleteDC (DC); MaskBitmap.Handle := MaskBmp; end; procedure ReplaceBitmapColorsFromMask (const MaskBitmap, DestBitmap: TBitmap; const DestOffset, DestSize: TPoint; const ReplaceColor: TColor); var DestDC: HDC; SaveBrush: HBRUSH; SaveTextColor, SaveBkColor: TColorRef; begin DestDC := DestBitmap.Canvas.Handle; SaveBrush := SelectObject(DestDC, CreateSolidBrush(ColorToRGB(ReplaceColor))); SaveTextColor := SetTextColor(DestDC, clBlack); SaveBkColor := SetBkColor(DestDC, clWhite); BitBlt (DestDC, DestOffset.X, DestOffset.Y, DestSize.X, DestSize.Y, MaskBitmap.Canvas.Handle, 0, 0, ROP_DSPDxax); SetBkColor (DestDC, SaveBkColor); SetTextColor (DestDC, SaveTextColor); DeleteObject (SelectObject(DestDC, SaveBrush)); end; function CopyBitmapToDDB (const SourceBitmap: TBitmap): TBitmap; { Makes a device-dependent duplicate of SourceBitmap. The color palette, if any, is preserved. } var SB: HBITMAP; SavePalette: HPALETTE; DC: HDC; BitmapInfo: packed record Header: TBitmapInfoHeader; Colors: array[0..255] of TColorRef; end; Bits: Pointer; begin Result := TBitmap.Create; try Result.Palette := CopyPalette(SourceBitmap.Palette); Result.Width := SourceBitmap.Width; Result.Height := SourceBitmap.Height; SB := SourceBitmap.Handle; if SB = 0 then Exit; { it would have a null handle if its width or height was zero } SavePalette := 0; DC := CreateCompatibleDC(0); try if Result.Palette <> 0 then begin SavePalette := SelectPalette(DC, Result.Palette, False); RealizePalette (DC); end; BitmapInfo.Header.biSize := SizeOf(TBitmapInfoHeader); BitmapInfo.Header.biBitCount := 0; { instructs GetDIBits not to fill in the color table } { First retrieve the BitmapInfo header only } if GetDIBits(DC, SB, 0, 0, nil, PBitmapInfo(@BitmapInfo)^, DIB_RGB_COLORS) <> 0 then begin GetMem (Bits, BitmapInfo.Header.biSizeImage); try { Then read the actual bits } if GetDIBits(DC, SB, 0, SourceBitmap.Height, Bits, PBitmapInfo(@BitmapInfo)^, DIB_RGB_COLORS) <> 0 then { And copy them to the resulting bitmap } SetDIBits (DC, Result.Handle, 0, SourceBitmap.Height, Bits, PBitmapInfo(@BitmapInfo)^, DIB_RGB_COLORS); finally FreeMem (Bits); end; end; finally if SavePalette <> 0 then SelectPalette (DC, SavePalette, False); DeleteDC (DC); end; except Result.Free; raise; end; end; const ROPs: array[Boolean] of DWORD = (ROP_PSDPxax, ROP_DSPDxax); var TmpImage, DDB, MonoBmp: TBitmap; I: TButtonState97; B: Boolean; AddPixels, IWidth, IHeight, IWidthA, IHeightA: Integer; IRect, IRectA, SourceRect, R: TRect; DC: HDC; UsesMask: Boolean; {$IFDEF TB97Delphi3orHigher} IsHighColorDIB: Boolean; {$ELSE} const IsHighColorDIB = False; {$ENDIF} begin if (State <> bsDisabled) and (Ord(State) >= NumGlyphs) then State := bsUp; Result.B := True; Result.I := FIndexs[True, State]; if Result.I = -1 then begin Result.B := False; Result.I := FIndexs[False, State]; end; if Result.I <> -1 then Exit; if (FOriginal.Width or FOriginal.Height) = 0 then Exit; UsesMask := (FOriginalMask.Width <> 0) and (FOriginalMask.Height <> 0); B := State <> bsDisabled; { + AddPixels is to make sure the highlight color on generated disabled glyphs doesn't get cut off } AddPixels := Ord(State = bsDisabled); IWidth := FOriginal.Width div FNumGlyphs + AddPixels; IHeight := FOriginal.Height + AddPixels; IRect := Rect(0, 0, IWidth, IHeight); IWidthA := IWidth - AddPixels; IHeightA := IHeight - AddPixels; IRectA := Rect(0, 0, IWidthA, IHeightA); if FGlyphList[B] = nil then begin if GlyphCache = nil then GlyphCache := TGlyphCache.Create; FGlyphList[B] := GlyphCache.GetList(IWidth, IHeight); end; {$IFDEF TB97Delphi3orHigher} IsHighColorDIB := FOriginal.PixelFormat > pf4bit; {$ENDIF} TmpImage := TBitmap.Create; try TmpImage.Width := IWidth; TmpImage.Height := IHeight; TmpImage.Canvas.Brush.Color := clBtnFace; TmpImage.Palette := CopyPalette(FOriginal.Palette); I := State; if Ord(I) >= NumGlyphs then I := bsUp; SourceRect := Bounds(Ord(I) * IWidthA, 0, IWidthA, IHeightA); if State <> bsDisabled then begin TmpImage.Canvas.CopyRect (IRectA, FOriginal.Canvas, SourceRect); if not UsesMask then begin {$IFDEF TB97Delphi3orHigher} { Use clDefault instead of FTransparentColor whereever possible to ensure compatibility with all video drivers when using high-color (> 4 bpp) DIB glyphs } FIndexs[B, State] := FGlyphList[B].AddMasked(TmpImage, clDefault); {$ELSE} FIndexs[B, State] := FGlyphList[B].AddMasked(TmpImage, FTransparentColor); {$ENDIF} end else begin MonoBmp := TBitmap.Create; try MonoBmp.Monochrome := True; MonoBmp.Width := IWidth; MonoBmp.Height := IHeight; MonoBmp.Canvas.CopyRect (IRectA, FOriginalMask.Canvas, SourceRect); FIndexs[B, State] := FGlyphList[B].Add(TmpImage, MonoBmp); finally MonoBmp.Free; end; end; end else begin MonoBmp := TBitmap.Create; try { Uses the CopyBitmapToDDB to work around a Delphi 3 flaw. If you copy a DIB to a second bitmap via Assign, change the HandleType of the second bitmap to bmDDB, then try to read the Handle property, Delphi converts it back to a DIB. } DDB := CopyBitmapToDDB(FOriginal); try if NumGlyphs > 1 then with TmpImage.Canvas do begin CopyRect (IRectA, DDB.Canvas, SourceRect); { Convert white to clBtnHighlight } if not IsHighColorDIB then GenerateMaskBitmap (MonoBmp, DDB, SourceRect.TopLeft, IRectA.BottomRight, [GetNearestColor(FOriginal.Canvas.Handle, clWhite)]) else GenerateMaskBitmapFromDIB (MonoBmp, FOriginal, SourceRect.TopLeft, IRectA.BottomRight, [clWhite]); ReplaceBitmapColorsFromMask (MonoBmp, TmpImage, IRectA.TopLeft, IRectA.BottomRight, clBtnHighlight); { Convert gray to clBtnShadow } if not IsHighColorDIB then GenerateMaskBitmap (MonoBmp, DDB, SourceRect.TopLeft, IRectA.BottomRight, [GetNearestColor(FOriginal.Canvas.Handle, clGray)]) else GenerateMaskBitmapFromDIB (MonoBmp, FOriginal, SourceRect.TopLeft, IRectA.BottomRight, [clGray]); ReplaceBitmapColorsFromMask (MonoBmp, TmpImage, IRectA.TopLeft, IRectA.BottomRight, clBtnShadow); if not UsesMask then begin { Generate the transparent mask in MonoBmp. The reason why it doesn't just use a mask color is because the mask needs to be of the glyph -before- the clBtnHighlight/Shadow were translated } if not IsHighColorDIB then GenerateMaskBitmap (MonoBmp, DDB, SourceRect.TopLeft, IRectA.BottomRight, FTransparentColor) else GenerateMaskBitmapFromDIB (MonoBmp, FOriginal, SourceRect.TopLeft, IRectA.BottomRight, [-1]); end else MonoBmp.Canvas.CopyRect (IRectA, FOriginalMask.Canvas, SourceRect); with MonoBmp do begin Width := Width + AddPixels; Height := Height + AddPixels; { Set the additional bottom and right row on disabled glyph masks to white so that it always shines through, since the bottom and right row on TmpImage was left uninitialized } Canvas.Pen.Color := clWhite; Canvas.PolyLine ([Point(0, Height-1), Point(Width-1, Height-1), Point(Width-1, -1)]); end; FIndexs[B, State] := FGlyphList[B].Add(TmpImage, MonoBmp); end else begin { Create a disabled version } if FOldDisabledStyle then begin { "Old" TSpeedButton style } if not UsesMask then begin if IsHighColorDIB then GenerateMaskBitmapFromDIB (MonoBmp, FOriginal, SourceRect.TopLeft, IRectA.BottomRight, [clBlack]) else begin with MonoBmp do begin Assign (DDB); { must be a DDB for this to work right } Canvas.Brush.Color := clBlack; Monochrome := True; end; end; end else begin MonoBmp.Assign (DDB); { must be a DDB for this to work right } with TBitmap.Create do try Monochrome := True; Width := FOriginalMask.Width; Height := FOriginalMask.Height; R := Rect(0, 0, Width, Height); Canvas.CopyRect (R, FOriginalMask.Canvas, R); DC := Canvas.Handle; with MonoBmp.Canvas do begin BitBlt (Handle, 0, 0, IWidthA, IHeightA, DC, SourceRect.Left, SourceRect.Top, ROP_DSna); BitBlt (Handle, 0, 0, IWidthA, IHeightA, DC, SourceRect.Left, SourceRect.Top, SRCPAINT); end; finally Free; end; MonoBmp.Canvas.Brush.Color := clBlack; MonoBmp.Monochrome := True; end; end else begin { The new Office 97 / MFC look } if not UsesMask then begin with TmpImage.Canvas do begin if not IsHighColorDIB then GenerateMaskBitmap (MonoBmp, DDB, IRectA.TopLeft, IRectA.BottomRight, [FTransparentColor, clWhite, clSilver]) else GenerateMaskBitmapFromDIB (MonoBmp, FOriginal, SourceRect.TopLeft, IRectA.BottomRight, [-1, clWhite, clSilver]); end; end else begin { Generate the mask in MonoBmp. Make clWhite and clSilver transparent. } if not IsHighColorDIB then GenerateMaskBitmap (MonoBmp, DDB, SourceRect.TopLeft, IRectA.BottomRight, [clWhite, clSilver]) else GenerateMaskBitmapFromDIB (MonoBmp, FOriginal, SourceRect.TopLeft, IRectA.BottomRight, [clWhite, clSilver]); { and all the white colors in FOriginalMask } with TBitmap.Create do try Monochrome := True; Width := FOriginalMask.Width; Height := FOriginalMask.Height; R := Rect(0, 0, Width, Height); Canvas.CopyRect (R, FOriginalMask.Canvas, R); DC := Canvas.Handle; with MonoBmp.Canvas do begin BitBlt (Handle, 0, 0, IWidthA, IHeightA, DC, SourceRect.Left, SourceRect.Top, ROP_DSna); BitBlt (Handle, 0, 0, IWidthA, IHeightA, DC, SourceRect.Left, SourceRect.Top, SRCPAINT); end; finally Free; end; end; end; with TmpImage.Canvas do begin Brush.Color := clBtnFace; FillRect (IRect); Brush.Color := clBtnHighlight; DC := Handle; SetTextColor (DC, clBlack); SetBkColor (DC, clWhite); BitBlt (DC, 1, 1, IWidthA, IHeightA, MonoBmp.Canvas.Handle, 0, 0, ROPs[FOldDisabledStyle]); Brush.Color := clBtnShadow; DC := Handle; SetTextColor (DC, clBlack); SetBkColor (DC, clWhite); BitBlt (DC, 0, 0, IWidthA, IHeightA, MonoBmp.Canvas.Handle, 0, 0, ROPs[FOldDisabledStyle]); end; FIndexs[B, State] := FGlyphList[B].AddMasked(TmpImage, clBtnFace); end; finally DDB.Free; end; finally MonoBmp.Free; end; end; finally TmpImage.Free; end; Result.B := B; Result.I := FIndexs[B, State]; { Note: Due to a bug in graphics.pas, Delphi 2's VCL crashes if Dormant is called on an empty bitmap, so to prevent this it must check Handle first } if {$IFNDEF TB97Delphi3orHigher} (FOriginal.Handle <> 0) and {$ENDIF} FCallDormant then FOriginal.Dormant; {$IFNDEF TB97Delphi3orHigher} if FOriginalMask.Handle <> 0 then {$ENDIF} FOriginalMask.Dormant; end; procedure TButtonGlyph.DrawButtonGlyph (Canvas: TCanvas; const GlyphPos: TPoint; State: TButtonState97); var Index: TBoolInt; begin if (FOriginal = nil) or (FOriginal.Width = 0) or (FOriginal.Height = 0) then Exit; Index := CreateButtonGlyph(State); ImageList_DrawEx (FGlyphList[Index.B].Handle, Index.I, Canvas.Handle, GlyphPos.X, GlyphPos.Y, 0, 0, CLR_NONE, CLR_NONE, ILD_TRANSPARENT); end; procedure TButtonGlyph.DrawButtonText (Canvas: TCanvas; const Caption: string; TextBounds: TRect; WordWrap: Boolean; State: TButtonState97); var Format: UINT; begin Format := DT_CENTER or DT_VCENTER; if not WordWrap then Format := Format or DT_SINGLELINE else Format := Format or DT_WORDBREAK; with Canvas do begin Brush.Style := bsClear; if State = bsDisabled then begin OffsetRect (TextBounds, 1, 1); Font.Color := clBtnHighlight; DrawText (Handle, PChar(Caption), Length(Caption), TextBounds, Format); OffsetRect (TextBounds, -1, -1); Font.Color := clBtnShadow; DrawText (Handle, PChar(Caption), Length(Caption), TextBounds, Format); end else DrawText (Handle, PChar(Caption), Length(Caption), TextBounds, Format); end; end; procedure TButtonGlyph.DrawButtonDropArrow (Canvas: TCanvas; const X, Y: Integer; State: TButtonState97); begin with Canvas do begin if State = bsDisabled then begin Pen.Color := clBtnHighlight; Brush.Color := clBtnHighlight; Polygon ([Point(X+5, Y+1), Point(X+9, Y+1), Point(X+7, Y+3)]); Pen.Color := clBtnShadow; Brush.Color := clBtnShadow; Polygon ([Point(X+4, Y), Point(X+8, Y), Point(X+6, Y+2)]); end else begin Pen.Color := Font.Color; Brush.Color := Font.Color; Polygon ([Point(X+4, Y), Point(X+8, Y), Point(X+6, Y+2)]); end; end; end; procedure TButtonGlyph.CalcButtonLayout (Canvas: TCanvas; const Client: TRect; const Offset: TPoint; DrawGlyph, DrawCaption: Boolean; const Caption: string; WordWrap: Boolean; Layout: TButtonLayout; Margin, Spacing: Integer; DropArrow: Boolean; var GlyphPos, ArrowPos: TPoint; var TextBounds: TRect); var TextPos: TPoint; ClientSize, GlyphSize, TextSize, ArrowSize: TPoint; TotalSize: TPoint; Format: UINT; Margin1, Spacing1: Integer; LayoutLeftOrRight: Boolean; begin { calculate the item sizes } ClientSize := Point(Client.Right-Client.Left, Client.Bottom-Client.Top); if DrawGlyph and (FOriginal <> nil) then GlyphSize := Point(FOriginal.Width div FNumGlyphs, FOriginal.Height) else GlyphSize := Point(0, 0); if DropArrow then ArrowSize := Point(9, 3) else ArrowSize := Point(0, 0); LayoutLeftOrRight := Layout in [blGlyphLeft, blGlyphRight]; if not LayoutLeftOrRight and ((GlyphSize.X = 0) or (GlyphSize.Y = 0)) then begin Layout := blGlyphLeft; LayoutLeftOrRight := True; end; if DrawCaption and (Caption <> '') then begin TextBounds := Rect(0, 0, Client.Right-Client.Left, 0); if LayoutLeftOrRight then Dec (TextBounds.Right, ArrowSize.X); Format := DT_CALCRECT; if WordWrap then begin Format := Format or DT_WORDBREAK; Margin1 := 4; if LayoutLeftOrRight and (GlyphSize.X <> 0) and (GlyphSize.Y <> 0) then begin if Spacing = -1 then Spacing1 := 4 else Spacing1 := Spacing; Dec (TextBounds.Right, GlyphSize.X + Spacing1); if Margin <> -1 then Margin1 := Margin else if Spacing <> -1 then Margin1 := Spacing; end; Dec (TextBounds.Right, Margin1 * 2); end; DrawText (Canvas.Handle, PChar(Caption), Length(Caption), TextBounds, Format); TextSize := Point(TextBounds.Right - TextBounds.Left, TextBounds.Bottom - TextBounds.Top); end else begin TextBounds := Rect(0, 0, 0, 0); TextSize := Point(0,0); end; { If the layout has the glyph on the right or the left, then both the text and the glyph are centered vertically. If the glyph is on the top or the bottom, then both the text and the glyph are centered horizontally.} if LayoutLeftOrRight then begin GlyphPos.Y := (ClientSize.Y - GlyphSize.Y + 1) div 2; TextPos.Y := (ClientSize.Y - TextSize.Y + 1) div 2; end else begin GlyphPos.X := (ClientSize.X - GlyphSize.X - ArrowSize.X + 1) div 2; TextPos.X := (ClientSize.X - TextSize.X + 1) div 2; if (GlyphSize.X = 0) or (GlyphSize.Y = 0) then ArrowPos.X := TextPos.X + TextSize.X else ArrowPos.X := GlyphPos.X + GlyphSize.X; end; { if there is no text or no bitmap, then Spacing is irrelevant } if (TextSize.X = 0) or (TextSize.Y = 0) or (GlyphSize.X = 0) or (GlyphSize.Y = 0) then Spacing := 0; { adjust Margin and Spacing } if Margin = -1 then begin if Spacing = -1 then begin TotalSize := Point(GlyphSize.X + TextSize.X + ArrowSize.X, GlyphSize.Y + TextSize.Y); if LayoutLeftOrRight then Margin := (ClientSize.X - TotalSize.X) div 3 else Margin := (ClientSize.Y - TotalSize.Y) div 3; Spacing := Margin; end else begin TotalSize := Point(GlyphSize.X + Spacing + TextSize.X + ArrowSize.X, GlyphSize.Y + Spacing + TextSize.Y); if LayoutLeftOrRight then Margin := (ClientSize.X - TotalSize.X + 1) div 2 else Margin := (ClientSize.Y - TotalSize.Y + 1) div 2; end; end else begin if Spacing = -1 then begin TotalSize := Point(ClientSize.X - (Margin + GlyphSize.X + ArrowSize.X), ClientSize.Y - (Margin + GlyphSize.Y)); if LayoutLeftOrRight then Spacing := (TotalSize.X - TextSize.X) div 2 else Spacing := (TotalSize.Y - TextSize.Y) div 2; end; end; case Layout of blGlyphLeft: begin GlyphPos.X := Margin; TextPos.X := GlyphPos.X + GlyphSize.X + Spacing; ArrowPos.X := TextPos.X + TextSize.X; end; blGlyphRight: begin ArrowPos.X := ClientSize.X - Margin - ArrowSize.X; GlyphPos.X := ArrowPos.X - GlyphSize.X; TextPos.X := GlyphPos.X - Spacing - TextSize.X; end; blGlyphTop: begin GlyphPos.Y := Margin; TextPos.Y := GlyphPos.Y + GlyphSize.Y + Spacing; end; blGlyphBottom: begin GlyphPos.Y := ClientSize.Y - Margin - GlyphSize.Y; TextPos.Y := GlyphPos.Y - Spacing - TextSize.Y; end; end; if (GlyphSize.X = 0) or (GlyphSize.Y = 0) then ArrowPos.Y := TextPos.Y + (TextSize.Y - ArrowSize.Y) div 2 else ArrowPos.Y := GlyphPos.Y + (GlyphSize.Y - ArrowSize.Y) div 2; { fixup the result variables } with GlyphPos do begin Inc (X, Client.Left + Offset.X); Inc (Y, Client.Top + Offset.Y); end; with ArrowPos do begin Inc (X, Client.Left + Offset.X); Inc (Y, Client.Top + Offset.Y); end; OffsetRect (TextBounds, TextPos.X + Client.Left + Offset.X, TextPos.Y + Client.Top + Offset.X); end; function TButtonGlyph.Draw (Canvas: TCanvas; const Client: TRect; const Offset: TPoint; DrawGlyph, DrawCaption: Boolean; const Caption: string; WordWrap: Boolean; Layout: TButtonLayout; Margin, Spacing: Integer; DropArrow: Boolean; State: TButtonState97): TRect; var GlyphPos, ArrowPos: TPoint; begin CalcButtonLayout (Canvas, Client, Offset, DrawGlyph, DrawCaption, Caption, WordWrap, Layout, Margin, Spacing, DropArrow, GlyphPos, ArrowPos, Result); if DrawGlyph then DrawButtonGlyph (Canvas, GlyphPos, State); if DrawCaption then DrawButtonText (Canvas, Caption, Result, WordWrap, State); if DropArrow then DrawButtonDropArrow (Canvas, ArrowPos.X, ArrowPos.Y, State); end; { TDropdownList } type TDropdownList = class(TComponent) private List: TList; Window: HWND; procedure WndProc (var Message: TMessage); protected procedure Notification (AComponent: TComponent; Operation: TOperation); override; public constructor Create (AOwner: TComponent); override; destructor Destroy; override; procedure AddMenu (Menu: TPopupMenu); end; var DropdownList: TDropdownList; constructor TDropdownList.Create (AOwner: TComponent); begin inherited; List := TList.Create; end; destructor TDropdownList.Destroy; begin List.Free; inherited; end; procedure TDropdownList.WndProc (var Message: TMessage); { This procedure is based on code from TPopupList.WndProc (menus.pas) } var I: Integer; MenuItem: TMenuItem; FindKind: TFindItemKind; ContextID: Integer; begin try with List do case Message.Msg of WM_COMMAND: for I := 0 to Count-1 do if TPopupMenu(Items[I]).DispatchCommand(TWMCommand(Message).ItemID) then Exit; WM_INITMENUPOPUP: for I := 0 to Count-1 do if TPopupMenu(Items[I]).DispatchPopup(TWMInitMenuPopup(Message).MenuPopup) then Exit; WM_MENUSELECT: with TWMMenuSelect(Message) do begin FindKind := fkCommand; if MenuFlag and MF_POPUP <> 0 then FindKind := fkHandle; for I := 0 to Count-1 do begin MenuItem := TPopupMenu(Items[I]).FindItem(IDItem, FindKind); if MenuItem <> nil then begin Application.Hint := MenuItem.Hint; Exit; end; end; Application.Hint := ''; end; WM_HELP: with TWMHelp(Message).HelpInfo^ do begin for I := 0 to Count-1 do if TPopupMenu(Items[I]).Handle = hItemHandle then begin ContextID := TPopupMenu(Items[I]).GetHelpContext(iCtrlID, True); if ContextID = 0 then ContextID := TPopupMenu(Items[I]).GetHelpContext(hItemHandle, False); if Screen.ActiveForm = nil then Exit; if (biHelp in Screen.ActiveForm.BorderIcons) then Application.HelpCommand (HELP_CONTEXTPOPUP, ContextID) else Application.HelpContext (ContextID); Exit; end; end; end; with Message do Result := DefWindowProc(Window, Msg, wParam, lParam); except Application.HandleException (Self); end; end; procedure TDropdownList.AddMenu (Menu: TPopupMenu); begin if List.IndexOf(Menu) = -1 then begin if List.Count = 0 then Window := AllocateHWnd(WndProc); Menu.FreeNotification (DropdownList); List.Add (Menu); end; end; procedure TDropdownList.Notification (AComponent: TComponent; Operation: TOperation); begin inherited; if Operation = opRemove then begin List.Remove (AComponent); if List.Count = 0 then DeallocateHWnd (Window); end; end; { TToolbarButton97 } constructor TToolbarButton97.Create (AOwner: TComponent); begin inherited; if not(csDesigning in ComponentState) then begin if ButtonHookRefCount = 0 then Application.HookMainWindow (TToolbarButton97.DeactivateHook); Inc (ButtonHookRefCount); FHooked := True; end; SetBounds (Left, Top, 23, 22); ControlStyle := [csCaptureMouse, csDoubleClicks, csOpaque]; FGlyph := TButtonGlyph.Create; TButtonGlyph(FGlyph).OnChange := GlyphChanged; ParentFont := True; FFlat := True; FOpaque := True; FSpacing := 4; FMargin := -1; FLayout := blGlyphLeft; FDropdownArrow := True; FRepeatDelay := 400; FRepeatInterval := 100; Inc (ButtonCount); end; destructor TToolbarButton97.Destroy; begin if ButtonMouseInControl = Self then begin ButtonMouseTimer.Enabled := False; ButtonMouseInControl := nil; end; TButtonGlyph(FGlyph).Free; Dec (ButtonCount); if ButtonCount = 0 then begin Pattern.Free; Pattern := nil; end; if FHooked then begin Dec (ButtonHookRefCount); if ButtonHookRefCount = 0 then Application.UnhookMainWindow (TToolbarButton97.DeactivateHook); end; inherited; end; procedure TToolbarButton97.Paint; const EdgeStyles: array[Boolean, Boolean] of UINT = ( (EDGE_RAISED, EDGE_SUNKEN), (BDR_RAISEDINNER, BDR_SUNKENOUTER)); FlagStyles: array[Boolean] of UINT = (BF_RECT or BF_SOFT or BF_MIDDLE, BF_RECT); var Bmp: TBitmap; DrawCanvas: TCanvas; PaintRect, R: TRect; Offset: TPoint; begin if FOpaque or not FFlat then Bmp := TBitmap.Create else Bmp := nil; try if FOpaque or not FFlat then begin Bmp.Width := Width; Bmp.Height := Height; DrawCanvas := Bmp.Canvas; with DrawCanvas do begin Brush.Color := Self.Color; FillRect (ClientRect); end; end else DrawCanvas := Canvas; if not Enabled then begin FState := bsDisabled; FMouseIsDown := False; end else if FState = bsDisabled then if FDown and (GroupIndex <> 0) then FState := bsExclusive else FState := bsUp; DrawCanvas.Font := Self.Font; PaintRect := Rect(0, 0, Width, Height); if ((not FNoBorder) and ((not FFlat) or (FState in [bsDown, bsExclusive]) or (FMouseInControl and (FState <> bsDisabled)))) or (csDesigning in ComponentState) then begin if DropdownCombo and FUsesDropdown then begin R := PaintRect; R.Left := R.Right - DropdownComboWidth; Dec (R.Right, 2); DrawEdge (DrawCanvas.Handle, R, EdgeStyles[FFlat, (FState in [bsDown, bsExclusive]) and FMenuIsDown], FlagStyles[FFlat]); Dec (PaintRect.Right, DropdownComboWidth); end; DrawEdge (DrawCanvas.Handle, PaintRect, EdgeStyles[FFlat, (FState in [bsDown, bsExclusive]) and (not(DropdownCombo and FUsesDropdown) or not FMenuIsDown)], FlagStyles[FFlat]); end else if DropdownCombo and FUsesDropdown then Dec (PaintRect.Right, DropdownComboWidth); if not FNoBorder then begin if FFlat then InflateRect (PaintRect, -1, -1) else InflateRect (PaintRect, -2, -2); end; if (FState in [bsDown, bsExclusive]) and (not(DropdownCombo and FUsesDropdown) or not FMenuIsDown) then begin if (FState = bsExclusive) and (not FFlat or not FMouseInControl) then begin if Pattern = nil then CreateBrushPattern; DrawCanvas.Brush.Bitmap := Pattern; DrawCanvas.FillRect(PaintRect); end; Offset.X := 1; Offset.Y := 1; end else begin Offset.X := 0; Offset.Y := 0; end; TButtonGlyph(FGlyph).Draw (DrawCanvas, PaintRect, Offset, FDisplayMode <> dmTextOnly, FDisplayMode <> dmGlyphOnly, Caption, FWordWrap, FLayout, FMargin, FSpacing, FDropdownArrow and not FDropdownCombo and FUsesDropdown, FState); if FDropdownCombo and FUsesDropdown then TButtonGlyph(FGlyph).DrawButtonDropArrow (DrawCanvas, Width-DropdownComboWidth-2, Height div 2 - 1, FState); if FOpaque or not FFlat then Canvas.Draw (0, 0, Bmp); finally if FOpaque or not FFlat then Bmp.Free; end; end; procedure TToolbarButton97.UpdateTracking; var P: TPoint; begin if Enabled then begin GetCursorPos (P); { Use FindDragTarget instead of PtInRect since we want to check based on the Z order } FMouseInControl := not (FindDragTarget(P, True) = Self); if FMouseInControl then MouseLeft else MouseEntered; end; end; procedure TToolbarButton97.Loaded; var State: TButtonState97; begin inherited; if Enabled then State := bsUp else State := bsDisabled; TButtonGlyph(FGlyph).CreateButtonGlyph (State); end; procedure TToolbarButton97.Notification (AComponent: TComponent; Operation: TOperation); begin inherited; if (AComponent = FDropdownMenu) and (Operation = opRemove) then FDropdownMenu := nil; end; function TToolbarButton97.PointInButton (X, Y: Integer): Boolean; begin Result := (X >= 0) and (X < ClientWidth-(DropdownComboWidth * Ord(FDropdownCombo and FUsesDropdown))) and (Y >= 0) and (Y < ClientHeight); end; procedure TToolbarButton97.MouseDown (Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin if not Enabled then begin inherited; Exit; end; if Button <> mbLeft then begin MouseEntered; inherited; end else begin { We know mouse has to be over the control if the mouse went down. } if not FMouseInControl then begin { Doesn't call MouseEntered since the redrawing it does is unnecessary here } FMouseInControl := True; if Assigned(FOnMouseEnter) then FOnMouseEnter (Self); end; FMenuIsDown := FUsesDropdown and (not FDropdownCombo or (X >= Width-DropdownComboWidth)); try if not FDown then begin FState := bsDown; Redraw (True); end else if FAllowAllUp then Redraw (True); if not FMenuIsDown then FMouseIsDown := True; inherited; if FMenuIsDown then Click else if FRepeating then begin inherited Click; if not Assigned(FRepeatTimer) then FRepeatTimer := TTimer.Create(Self); FRepeatTimer.Enabled := False; FRepeatTimer.Interval := FRepeatDelay; FRepeatTimer.OnTimer := RepeatTimerHandler; FRepeatTimer.Enabled := True; end; finally FMenuIsDown := False; end; end; end; procedure TToolbarButton97.MouseMove (Shift: TShiftState; X, Y: Integer); function GetActiveForm: {$IFDEF TB97Delphi3orHigher} TCustomForm {$ELSE} TForm {$ENDIF}; { Returns the active top-level form } var Ctl: TWinControl; begin Result := nil; Ctl := FindControl(GetActiveWindow); if Assigned(Ctl) then begin Result := GetParentForm(Ctl); if Result is TForm then Result := GetMDIParent(TForm(Result)); end; end; var P: TPoint; NewState: TButtonState97; PtInButton: Boolean; begin inherited; { Check if mouse just entered the control. It works better to check this in MouseMove rather than using CM_MOUSEENTER, since the VCL doesn't send a CM_MOUSEENTER in all cases Use FindDragTarget instead of PtInRect since we want to check based on the Z order } P := ClientToScreen(Point(X, Y)); if (ButtonMouseInControl <> Self) and (FindDragTarget(P, True) = Self) then begin if Assigned(ButtonMouseInControl) then ButtonMouseInControl.MouseLeft; { Like Office 97, only draw the active borders when the application is active } if FShowBorderWhenInactive or Application.Active then begin ButtonMouseInControl := Self; ButtonMouseTimer.OnTimer := ButtonMouseTimerHandler; ButtonMouseTimer.Enabled := True; MouseEntered; end; end; if FMouseIsDown then begin PtInButton := PointInButton(X, Y); if PtInButton and Assigned(FRepeatTimer) then FRepeatTimer.Enabled := True; if FDown then NewState := bsExclusive else begin if PtInButton then NewState := bsDown else NewState := bsUp; end; if NewState <> FState then begin FState := NewState; Redraw (True); end; end; end; procedure TToolbarButton97.RepeatTimerHandler (Sender: TObject); var P: TPoint; begin FRepeatTimer.Interval := FRepeatInterval; GetCursorPos (P); P := ScreenToClient(P); if Repeating and FMouseIsDown and MouseCapture and PointInButton(P.X, P.Y) then inherited Click else FRepeatTimer.Enabled := False; end; procedure TToolbarButton97.WMCancelMode (var Message: TWMCancelMode); begin FRepeatTimer.Free; FRepeatTimer := nil; if FMouseIsDown then begin FMouseIsDown := False; if FGroupIndex <> 0 then begin if FDown then FState := bsExclusive; end; MouseLeft; end; { Delphi's default processing of WM_CANCELMODE sends a "fake" WM_LBUTTONUP message to the control, so inherited must only be called after setting FMouseIsDown to False } inherited; end; procedure TToolbarButton97.MouseUp (Button: TMouseButton; Shift: TShiftState; X, Y: Integer); var DoClick: Boolean; begin FRepeatTimer.Free; FRepeatTimer := nil; { Remove active border when right button is clicked } if (Button = mbRight) and Enabled then begin FMouseIsDown := False; MouseLeft; end; inherited; if (Button = mbLeft) and FMouseIsDown then begin FMouseIsDown := False; DoClick := PointInButton(X, Y); if FGroupIndex <> 0 then begin if DoClick then SetDown (not FDown) else begin if FDown then FState := bsExclusive; end; end; if DoClick and not FRepeating then Click else begin if FState = bsDown then FState := bsUp; UpdateTracking; end; end; end; procedure TToolbarButton97.Click; const { TPM_RIGHTBUTTON works better on Windows 3.x } ButtonFlags: array[Boolean] of UINT = (TPM_RIGHTBUTTON, TPM_LEFTBUTTON); AlignFlags: array[TPopupAlignment] of UINT = (TPM_LEFTALIGN, TPM_RIGHTALIGN, TPM_CENTERALIGN); var SaveAlignment: TPopupAlignment; PopupPoint: TPoint; RepostList: TList; {pointers to TMsg's} Msg: TMsg; Repost: Boolean; I: Integer; P: TPoint; Form: {$IFDEF TB97Delphi3orHigher} TCustomForm {$ELSE} TForm {$ENDIF}; begin FInClick := True; try if FState in [bsUp, bsMouseIn] then begin FState := bsDown; Redraw (True); end; { Stop tracking } MouseLeft; if (not FUsesDropdown) or (FDropdownCombo and not FMenuIsDown) then begin Form := GetParentForm(Self); if Form <> nil then Form.ModalResult := ModalResult; inherited; end else begin { It must release its capture before displaying the popup menu since this control uses csCaptureMouse. If it doesn't, the VCL seems to get confused and think the mouse is still captured even after the popup menu is displayed, causing mouse problems after the menu is dismissed. } MouseCapture := False; try SaveAlignment := DropdownMenu.Alignment; try DropdownMenu.Alignment := paLeft; PopupPoint := Point(0, Height); if (Parent is TCustomToolWindow97) and (GetDockTypeOf(TCustomToolWindow97(Parent).DockedTo) = dtLeftRight) then begin { Drop out right or left side } if TCustomToolWindow97(Parent).DockedTo.Position = dpLeft then PopupPoint := Point(Width, 0) else begin PopupPoint := Point(0, 0); DropdownMenu.Alignment := paRight; end; end; PopupPoint := ClientToScreen(PopupPoint); with DropdownMenu do begin PopupComponent := Self; { Starting with version 1.54, this avoids using the Popup method of TPopupMenu because it uses the "track right button" flag (which disallowed the "click and drag" selecting motion many people are accustomed to). } if Assigned(OnPopup) then OnPopup (DropdownMenu); TrackPopupMenu (Handle, AlignFlags[Alignment] or ButtonFlags[NewStyleControls], PopupPoint.X, PopupPoint.Y, 0, DropdownList.Window, nil); end; finally DropdownMenu.Alignment := SaveAlignment; end; finally { To prevent a mouse click from redisplaying the menu, filter all mouse up/down messages, and repost the ones that don't need removing. This is sort of bulky, but it's the only way I could find that works perfectly and like Office 97. } RepostList := TList.Create; try while PeekMessage(Msg, 0, WM_LBUTTONDOWN, WM_MBUTTONDBLCLK, PM_REMOVE or PM_NOYIELD) do { ^ The WM_LBUTTONDOWN to WM_MBUTTONDBLCLK range encompasses all of the DOWN and DBLCLK messages for the three buttons } with Msg do begin Repost := True; case Message of 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; end; finally FInClick := False; if FState = bsDown then FState := bsUp; { Need to check if it's destroying in case the OnClick handler freed the button. If it doesn't check this here, it can sometimes cause an access violation } if not(csDestroying in ComponentState) then begin Redraw (True); UpdateTracking; end; end; end; function TToolbarButton97.GetPalette: HPALETTE; begin Result := Glyph.Palette; end; function TToolbarButton97.GetGlyph: TBitmap; begin Result := TButtonGlyph(FGlyph).Glyph; end; procedure TToolbarButton97.SetGlyph (Value: TBitmap); begin TButtonGlyph(FGlyph).Glyph := Value; Redraw (True); end; function TToolbarButton97.GetGlyphMask: TBitmap; begin Result := TButtonGlyph(FGlyph).GlyphMask; end; procedure TToolbarButton97.SetGlyphMask (Value: TBitmap); begin TButtonGlyph(FGlyph).GlyphMask := Value; Redraw (True); end; function TToolbarButton97.GetNumGlyphs: TNumGlyphs97; begin Result := TButtonGlyph(FGlyph).NumGlyphs; end; procedure TToolbarButton97.SetNumGlyphs (Value: TNumGlyphs97); begin if Value < Low(TNumGlyphs97) then Value := Low(TNumGlyphs97) else if Value > High(TNumGlyphs97) then Value := High(TNumGlyphs97); if Value <> TButtonGlyph(FGlyph).NumGlyphs then begin TButtonGlyph(FGlyph).NumGlyphs := Value; Redraw (True); end; end; procedure TToolbarButton97.GlyphChanged(Sender: TObject); begin Redraw (True); end; procedure TToolbarButton97.UpdateExclusive; var Msg: TMessage; begin if (FGroupIndex <> 0) and (Parent <> nil) then begin Msg.Msg := CM_BUTTONPRESSED; Msg.WParam := FGroupIndex; Msg.LParam := Longint(Self); Msg.Result := 0; Parent.Broadcast (Msg); end; end; procedure TToolbarButton97.SetDown (Value: Boolean); begin if FGroupIndex = 0 then Value := False; if Value <> FDown then begin if FDown and (not FAllowAllUp) then Exit; FDown := Value; if Value then FState := bsExclusive else FState := bsUp; Redraw (True); if Value then UpdateExclusive; end; end; procedure TToolbarButton97.SetFlat (Value: Boolean); begin if FFlat <> Value then begin FFlat := Value; if FOpaque or not FFlat then ControlStyle := ControlStyle + [csOpaque] else ControlStyle := ControlStyle - [csOpaque]; Redraw (True); end; end; procedure TToolbarButton97.SetGroupIndex (Value: Integer); begin if FGroupIndex <> Value then begin FGroupIndex := Value; UpdateExclusive; end; end; procedure TToolbarButton97.SetLayout (Value: TButtonLayout); begin if FLayout <> Value then begin FLayout := Value; Redraw (True); end; end; procedure TToolbarButton97.SetMargin (Value: Integer); begin if (FMargin <> Value) and (Value >= -1) then begin FMargin := Value; Redraw (True); end; end; procedure TToolbarButton97.SetNoBorder (Value: Boolean); begin if FNoBorder <> Value then begin FNoBorder := Value; Invalidate; end; end; procedure TToolbarButton97.SetOldDisabledStyle (Value: Boolean); begin if FOldDisabledStyle <> Value then begin FOldDisabledStyle := Value; with TButtonGlyph(FGlyph) do begin FOldDisabledStyle := Value; Invalidate; end; Redraw (True); end; end; procedure TToolbarButton97.SetOpaque (Value: Boolean); begin if FOpaque <> Value then begin FOpaque := Value; if FOpaque or not FFlat then ControlStyle := ControlStyle + [csOpaque] else ControlStyle := ControlStyle - [csOpaque]; Invalidate; end; end; procedure TToolbarButton97.Redraw (const Erase: Boolean); var AddedOpaque: Boolean; begin if FOpaque or not FFlat or not Erase then begin { Temporarily add csOpaque to the style. This prevents Invalidate from erasing, which isn't needed when Erase is false. } AddedOpaque := False; if not(csOpaque in ControlStyle) then begin AddedOpaque := True; ControlStyle := ControlStyle + [csOpaque]; end; try Invalidate; finally if AddedOpaque then ControlStyle := ControlStyle - [csOpaque]; end; end else if not(FOpaque or not FFlat) then Invalidate; end; procedure TToolbarButton97.SetSpacing (Value: Integer); begin if Value <> FSpacing then begin FSpacing := Value; Redraw (True); end; end; procedure TToolbarButton97.SetAllowAllUp (Value: Boolean); begin if FAllowAllUp <> Value then begin FAllowAllUp := Value; UpdateExclusive; end; end; procedure TToolbarButton97.SetDropdownMenu (Value: TPopupMenu); begin if FDropdownMenu <> Value then begin FDropdownMenu := Value; FUsesDropdown := Assigned(Value); if Assigned(Value) then begin Value.FreeNotification (Self); DropdownList.AddMenu (Value); end; if FDropdownArrow then Redraw (True); end; end; procedure TToolbarButton97.SetWordWrap (Value: Boolean); begin if FWordWrap <> Value then begin FWordWrap := Value; Redraw (True); end; end; procedure TToolbarButton97.SetDropdownArrow (Value: Boolean); begin if FDropdownArrow <> Value then begin FDropdownArrow := Value; Redraw (True); end; end; procedure TToolbarButton97.SetDropdownCombo (Value: Boolean); var W: Integer; begin if FDropdownCombo <> Value then begin FDropdownCombo := Value; if not(csLoading in ComponentState) then begin if Value then Width := Width + DropdownComboWidth else begin W := Width - DropdownComboWidth; if W < 1 then W := 1; Width := W; end; end; Redraw (True); end; end; procedure TToolbarButton97.SetDisplayMode (Value: TButtonDisplayMode); begin if FDisplayMode <> Value then begin FDisplayMode := Value; Redraw (True); end; end; function TToolbarButton97.GetCallDormant: Boolean; begin Result := TButtonGlyph(FGlyph).FCallDormant; end; procedure TToolbarButton97.SetCallDormant (Value: Boolean); begin TButtonGlyph(FGlyph).FCallDormant := Value; end; procedure TToolbarButton97.WMLButtonDblClk (var Message: TWMLButtonDblClk); begin inherited; if FDown then DblClick; end; procedure TToolbarButton97.CMEnabledChanged (var Message: TMessage); const NewState: array[Boolean] of TButtonState97 = (bsDisabled, bsUp); begin TButtonGlyph(FGlyph).CreateButtonGlyph (NewState[Enabled]); UpdateTracking; Redraw (True); end; procedure TToolbarButton97.CMButtonPressed (var Message: TMessage); var Sender: TToolbarButton97; begin { UpdateExclusive broadcasts these messages } if Message.WParam = FGroupIndex then begin Sender := TToolbarButton97(Message.LParam); if Sender <> Self then begin if Sender.Down and FDown then begin FDown := False; FState := bsUp; Redraw (True); end; FAllowAllUp := Sender.AllowAllUp; end; end; end; procedure TToolbarButton97.CMDialogChar (var Message: TCMDialogChar); begin with Message do if IsAccel(CharCode, Caption) and Enabled and Visible then begin { NOTE: There is a bug in TSpeedButton where accelerator keys are still processed even when the button is not visible. The 'and Visible' corrects it, so TToolbarButton97 doesn't have this problem. } Click; Result := 1; end else inherited; end; procedure TToolbarButton97.CMFontChanged (var Message: TMessage); begin Redraw (True); end; procedure TToolbarButton97.CMTextChanged (var Message: TMessage); begin Redraw (True); end; procedure TToolbarButton97.CMSysColorChange (var Message: TMessage); begin inherited; if Assigned(Pattern) and ((PatternBtnFace <> TColor(GetSysColor(COLOR_BTNFACE))) or (PatternBtnHighlight <> TColor(GetSysColor(COLOR_BTNHIGHLIGHT)))) then begin Pattern.Free; Pattern := nil; end; with TButtonGlyph(FGlyph) do begin Invalidate; CreateButtonGlyph (FState); end; end; procedure TToolbarButton97.MouseEntered; begin if Enabled and not FMouseInControl then begin FMouseInControl := True; if FState = bsUp then FState := bsMouseIn; Redraw (FDown); if Assigned(FOnMouseEnter) then FOnMouseEnter (Self); end; end; procedure TToolbarButton97.MouseLeft; begin if Enabled and FMouseInControl and not FMouseIsDown then begin if (FState = bsMouseIn) or (not FInClick and (FState = bsDown)) then FState := bsUp; FMouseInControl := False; Redraw (True); if ButtonMouseInControl = Self then begin ButtonMouseTimer.Enabled := False; ButtonMouseInControl := nil; end; if Assigned(FOnMouseExit) then FOnMouseExit (Self); end; end; procedure TToolbarButton97.CMMouseLeave (var Message: TMessage); begin inherited; MouseLeft; end; procedure TToolbarButton97.ButtonMouseTimerHandler (Sender: TObject); var P: TPoint; begin { The button mouse timer is used to periodically check if mouse has left. Normally it receives a CM_MOUSELEAVE, but the VCL does not send a CM_MOUSELEAVE if the mouse is moved quickly from the button to another application's window. For some reason, this problem doesn't seem to occur on Windows NT 4 -- only 95 and 3.x. The timer (which ticks 8 times a second) is only enabled when the application is active and the mouse is over a button, so it uses virtually no processing power. For something interesting to try: If you want to know just how often this is called, try putting a Beep call in here } GetCursorPos (P); if FindDragTarget(P, True) <> Self then MouseLeft; end; class function TToolbarButton97.DeactivateHook (var Message: TMessage): Boolean; begin Result := False; { Hide any active border when application is deactivated } if (Message.Msg = CM_DEACTIVATE) and Assigned(ButtonMouseInControl) and not ButtonMouseInControl.FShowBorderWhenInactive then ButtonMouseInControl.MouseLeft; end; { TEdit97 - internal } constructor TEdit97.Create (AOwner: TComponent); begin inherited; AutoSize := False; Ctl3D := False; BorderStyle := bsNone; ControlStyle := ControlStyle - [csFramed]; {fixes a VCL bug with Win 3.x} Height := 19; end; procedure TEdit97.CMMouseEnter (var Message: TMessage); begin inherited; MouseInControl := True; RedrawBorder (0); end; procedure TEdit97.CMMouseLeave (var Message: TMessage); begin inherited; MouseInControl := False; RedrawBorder (0); end; procedure TEdit97.NewAdjustHeight; var DC: HDC; SaveFont: HFONT; Metrics: TTextMetric; begin DC := GetDC(0); SaveFont := SelectObject(DC, Font.Handle); GetTextMetrics (DC, Metrics); SelectObject (DC, SaveFont); ReleaseDC (0, DC); Height := Metrics.tmHeight + 6; end; procedure TEdit97.Loaded; begin inherited; if not(csDesigning in ComponentState) then NewAdjustHeight; end; procedure TEdit97.CMEnabledChanged (var Message: TMessage); const EnableColors: array[Boolean] of TColor = (clBtnFace, clWindow); begin inherited; Color := EnableColors[Enabled]; end; procedure TEdit97.CMFontChanged (var Message: TMessage); begin inherited; if not((csDesigning in ComponentState) and (csLoading in ComponentState)) then NewAdjustHeight; end; procedure TEdit97.WMSetFocus (var Message: TWMSetFocus); begin inherited; if not(csDesigning in ComponentState) then RedrawBorder (0); end; procedure TEdit97.WMKillFocus (var Message: TWMKillFocus); begin inherited; if not(csDesigning in ComponentState) then RedrawBorder (0); end; procedure TEdit97.WMNCCalcSize (var Message: TWMNCCalcSize); begin inherited; InflateRect (Message.CalcSize_Params^.rgrc[0], -3, -3); end; procedure TEdit97.WMNCPaint (var Message: TMessage); begin inherited; RedrawBorder (Message.WParam); end; procedure TEdit97.RedrawBorder (const Clip: HRGN); var DC: HDC; R: TRect; NewClipRgn: HRGN; BtnFaceBrush, WindowBrush: HBRUSH; begin DC := GetWindowDC(Handle); try { Use update region } if (Clip <> 0) and (Clip <> 1) then begin GetWindowRect (Handle, R); if SelectClipRgn(DC, Clip) = ERROR then begin NewClipRgn := CreateRectRgnIndirect(R); SelectClipRgn (DC, NewClipRgn); DeleteObject (NewClipRgn); end; OffsetClipRgn (DC, -R.Left, -R.Top); end; { This works around WM_NCPAINT problem described at top of source code } {no! R := Rect(0, 0, Width, Height);} GetWindowRect (Handle, R); OffsetRect (R, -R.Left, -R.Top); BtnFaceBrush := GetSysColorBrush(COLOR_BTNFACE); WindowBrush := GetSysColorBrush(COLOR_WINDOW); if ((csDesigning in ComponentState) and Enabled) or (not(csDesigning in ComponentState) and (Focused or (MouseInControl and not(Screen.ActiveControl is TEdit97)))) then begin DrawEdge (DC, R, BDR_SUNKENOUTER, BF_RECT or BF_ADJUST); with R do begin FillRect (DC, Rect(Left, Top, Left+1, Bottom-1), BtnFaceBrush); FillRect (DC, Rect(Left, Top, Right-1, Top+1), BtnFaceBrush); end; DrawEdge (DC, R, BDR_SUNKENINNER, BF_BOTTOMRIGHT); InflateRect (R, -1, -1); FrameRect (DC, R, WindowBrush); end else begin FrameRect (DC, R, BtnFaceBrush); InflateRect (R, -1, -1); FrameRect (DC, R, BtnFaceBrush); InflateRect (R, -1, -1); FrameRect (DC, R, WindowBrush); end; finally ReleaseDC (Handle, DC); end; end; const Sig: PChar = '- Toolbar97 version ' + Toolbar97Version + {$IFDEF VER90} '/D2'+ {$ENDIF} {$IFDEF VER93} '/CB1'+ {$ENDIF} {$IFDEF VER100} '/D3'+ {$ENDIF} {$IFDEF VER110} '/CB3'+ {$ENDIF} ' by Jordan Russell -'; initialization Sig := Sig; HookedForms := TList.Create; MainHookedForms := TList.Create; DoneCreatingList := TList.Create; DropdownList := TDropdownList.Create(nil); ButtonMouseTimer := TTimer.Create(nil); ButtonMouseTimer.Enabled := False; ButtonMouseTimer.Interval := 125; { 8 times a second } finalization ButtonMouseTimer.Free; DropdownList.Free; DoneCreatingList.Free; MainHookedForms.Free; HookedForms.Free; end.