admin/expertcad
1
0
Fork 0
mirror of http://gitlab.expertsoft.com.ua/git/expertcad synced 2026-01-11 17:25:39 +02:00
Code Issues Packages Projects Releases Wiki Activity
expertcad/POWERCAD30/UNITS/pcMsBar.pas
ShevaIV 00e2ad8635 initial commit
2025-05-12 10:07:51 +03:00

3877 lines
124 KiB
ObjectPascal
Raw Permalink Blame History

unit PCMSBar;
{$ALIGN ON}
{$BOOLEVAL OFF}
{$LONGSTRINGS ON}
{$WRITEABLECONST ON}
{ 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 higher
(or a future version of C++Builder) }
{$ENDIF}
{$ENDIF}
interface
uses
Windows, Messages, Classes, Controls, Forms, Menus, Graphics, Buttons,
StdCtrls, ExtCtrls, Dialogs;
type
{ TPCDock }
TDockBoundLinesValues = (blTop, blBottom, blLeft, blRight);
TDockBoundLines = set of TDockBoundLinesValues;
TDockPosition = (dpTop, dpBottom, dpLeft, dpRight);
TDockType = (dtNotDocked, dtTopBottom, dtLeftRight);
TPCOfficeBar = class;
TInsertRemoveEvent = procedure (Sender: TObject; Inserting: Boolean;
Bar: TPCOfficeBar) of object;
TPCDock = class(TCustomControl)
private
{ Property values }
FPosition: TDockPosition;
FAllowDrag: Boolean;
FBoundLines: TDockBoundLines;
FBkg, FBkgCache: TBitmap;
FBkgTransparent: Boolean;
FFixAlign: Boolean;
FLimitToOneRow: Boolean;
FOnInsertRemoveBar: TInsertRemoveEvent;
FOnResize: TNotifyEvent;
{ Internal }
DisableArrangeToolbars: Integer; { Increment to disable ArrangeToolbars }
DockList: TList; { List of the visible toolbars docked. Items are casted in TPCOfficeBar's.
But, at design time, all docked toolbars are here regardless of visibility }
RowInfo: TList; { List of info on each row. Items are pointers to TRowInfo's }
{ Property access methods }
procedure SetAllowDrag (Value: Boolean);
procedure SetBackground (Value: TBitmap);
procedure SetBackgroundTransparent (Value: Boolean);
procedure SetBoundLines (Value: TDockBoundLines);
procedure SetFixAlign (Value: Boolean);
procedure SetPosition (Value: TDockPosition);
function GetToolbarCount: Integer;
function GetToolbars (Index: Integer): TPCOfficeBar;
{ Internal }
procedure FreeRowInfo;
function GetRowOf (const Y: Integer; var Before: Boolean): Integer;
function GetDesignModeRowOf (const Y: Integer): Integer;
function GetHighestRow: Integer;
procedure RemoveBlankRows;
procedure InsertRowBefore (const BeforeRow: Integer);
procedure BuildRowInfo;
procedure ChangeDockList (const Insert: Boolean; const Bar: TPCOfficeBar;
const IsVisible: Boolean);
procedure ChangeWidthHeight (const IsClientWidthAndHeight: Boolean;
NewWidth, NewHeight: Integer);
procedure DrawBackground (const Canvas: TCanvas;
const ClippingRect, DrawRect: TRect);
procedure InvalidateBackgrounds;
procedure BackgroundChanged (Sender: TObject);
{ Messages }
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
procedure ArrangeToolbars;
constructor Create (AOwner: TComponent); override;
procedure CreateParams (var Params: TCreateParams); override;
destructor Destroy; override;
property ToolbarCount: Integer read GetToolbarCount;
property Toolbars[Index: Integer]: TPCOfficeBar read GetToolbars;
published
property AllowDrag: Boolean read FAllowDrag write SetAllowDrag default True;
property Background: TBitmap read FBkg write SetBackground;
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 OnResize: TNotifyEvent read FOnResize write FOnResize;
end;
{ TPCOfficeBar }
TPCOfficeBar = class(TCustomControl)
private
{ Property variables }
FBarHeight, FBarWidth, FDockedTotalBarHeight, FDockedTotalBarWidth, FDockPos, FDockRow: Integer;
FDefaultDock: TPCDock;
FOnRecreating, FOnRecreated, FOnDockChanging, FOnDockChanged, FOnClose: TNotifyEvent;
FCanDockLeftRight, FCloseButton: Boolean;
FFloatingRect: TRect;
FFloatingRightX: Integer;
{ 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 }
{ Misc. }
UpdatingBounds, { Increment while internally changing the bounds. This allows it to move the toolbar freely }
DisableArrangeControls, { Increment to disable ArrangeControls }
Hidden: Integer; { Incremented while the toolbar is temporarily hidden }
{ 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 off the screen, hidden from view.
This is True when the toolbar is hidden when application is deactivated }
VirtualLeft: Integer; { The Left value the toolbar should be restored to when moving from off the screen }
CloseButtonDown: Boolean; { True if Close button is currently depressed }
OldFormWindowProc, OldChildFormWindowProc: Pointer; { The previous form window procedures }
{ Property access methods }
procedure SetCloseButton (Value: Boolean);
procedure SetDefaultDock (Value: TPCDock);
function GetDockedTo: TPCDock;
procedure SetDockedTo (Value: TPCDock);
procedure SetDockPos (Value: Integer);
procedure SetDockRow (Value: Integer);
function GetOrderIndex (Control: TControl): Integer;
procedure SetOrderIndex (Control: TControl; Value: Integer);
{ Internal }
procedure FreeGroupInfo (const List: TList);
procedure BuildGroupInfo (const List: TList; const TranslateSlave: Boolean;
const OldDockType, NewDockType: TDockType);
procedure MoveOnScreen (const OnlyIfFullyOffscreen: Boolean);
procedure ShouldBeVisible (const Control: TControl; const DockType: TDockType;
const SetIt: Boolean; var AVisible: Boolean);
procedure AutoArrangeControls;
procedure ArrangeControls (const CanMove, CanResize: Boolean;
const OldDockType: TDockType; const DockingTo: TPCDock; RightX: Integer;
const NewClientSize: PPoint);
procedure DrawDraggingOutline (const DC: HDC; const NewRect, OldRect: PRect;
const NewDocking, OldDocking: Boolean);
procedure NewFormWindowProc (var Message: TMessage);
procedure NewChildFormWindowProc (var Message: TMessage);
function NewMainWindowHook (var Message: TMessage): Boolean;
procedure BeginMoving (const InitX, InitY: Integer);
procedure BeginSizing (const HitTestValue: Integer);
procedure DrawNCArea (const Clip: HRGN; const RedrawBorder, RedrawCaption, RedrawCloseButton: Boolean);
procedure SetNotOnScreen (const Value: Boolean);
{ Messages }
procedure CMTextChanged (var Message: TMessage); message CM_TEXTCHANGED;
procedure CMVisibleChanged (var Message: TMessage); message CM_VISIBLECHANGED;
procedure CMControlListChange (var Message: TCMControlListChange); message CM_CONTROLLISTCHANGE;
procedure WMMove (var Message: TWMMove); message WM_MOVE;
procedure WMActivate (var Message: TWMActivate); message WM_ACTIVATE;
procedure WMMouseActivate (var Message: TWMMouseActivate); message WM_MOUSEACTIVATE;
procedure WMGetMinMaxInfo (var Message: TWMGetMinMaxInfo); message WM_GETMINMAXINFO;
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 WMNCCalcSize (var Message: TWMNCCalcSize); message WM_NCCALCSIZE;
protected
{ Internal }
function GetVirtualBoundsRect: TRect;
procedure SetVirtualBounds (ALeft, ATop, AWidth, AHeight: Integer);
procedure SetVirtualBoundsRect (const R: TRect);
{ Overridden methods }
procedure AlignControls (AControl: TControl; var Rect: TRect); override;
procedure CreateParams (var Params: TCreateParams); override;
procedure Loaded; override;
procedure MouseDown (Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
procedure Notification (AComponent: TComponent; Operation: TOperation); override;
procedure Paint; override;
procedure SetBounds (ALeft, ATop, AWidth, AHeight: Integer); override;
procedure SetParent (AParent: TWinControl); override;
public
{ Public declarations }
property FloatingRect: TRect read FFloatingRect write FFloatingRect;
property OrderIndex[Control: TControl]: Integer read GetOrderIndex write SetOrderIndex;
constructor Create (AOwner: TComponent); override;
destructor Destroy; override;
procedure SetSlaveControl (const ATopBottom, ALeftRight: TControl);
Procedure RealignControls(DWidth:Integer);
published
{ Published declarations }
property CanDockLeftRight: Boolean read FCanDockLeftRight write FCanDockLeftRight default True;
property Caption;
property Color default clBtnFace;
property CloseButton: Boolean read FCloseButton write SetCloseButton default True;
property DefaultDock: TPCDock read FDefaultDock write SetDefaultDock;
property DockedTo: TPCDock read GetDockedTo write SetDockedTo;
property DockRow: Integer read FDockRow write SetDockRow default 0;
property DockPos: Integer read FDockPos write SetDockPos default -1;
property ParentShowHint;
property PopupMenu;
property ShowHint;
property Visible;
property OnClose: TNotifyEvent read FOnClose write FOnClose;
property OnRecreated: TNotifyEvent read FOnRecreated write FOnRecreated;
property OnRecreating: TNotifyEvent read FOnRecreating write FOnRecreating;
property OnDockChanged: TNotifyEvent read FOnDockChanged write FOnDockChanged;
property OnDockChanging: TNotifyEvent read FOnDockChanging write FOnDockChanging;
end;
{ TPCSep }
TToolbarSepSize = 1..MaxInt;
TPCSep = 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
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;
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);
type
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);
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);
implementation
uses
CommCtrl, Registry, IniFiles, SysUtils, Consts, U_Common;
{$R *.DCR}
const
{ Exception messages }
STB97DockNotFormOwner = 'TPCDock must be owned by a form';
STB97DockParentNotAllowed = 'A TPCDock control cannot be placed inside a TPCOfficeBar or another TPCDock';
STB97DockCannotHide = 'Cannot hide a TPCDock';
STB97DockCannotChangePosition = 'Cannot change Position of a TPCDock if it already contains controls';
STB97ToolbarNotFormOwner = 'TPCOfficeBar must be owned by a form';
STB97ToolbarNameNotSet = 'Name property not set';
STB97ToolbarDockToNameNotSet = 'DockTo''s Name property not set';
STB97ToolbarParentNotAllowed = 'TPCOfficeBar can only be placed on a TPCDock or directly on the form';
STB97ToolbarControlNotChildOfToolbar = 'Control is not a child of the toolbar';
STB97SepParentNotAllowed = 'TPCSep can only be placed on a TPCOfficeBar';
{ All spacing & margin values are here. It's recommended that you don't
try changing any of this! }
LineSpacing = 6;
DropdownComboWidth = 11;
{ TopMargin is really a left margin when docked to left or right side.
Likewise, LeftMargin is really a top margin. }
TopMargin: array[TDockType] of Integer = (2, 2, 2);
BottomMargin: array[TDockType] of Integer = (1, 2, 2);
LeftMargin: array[Boolean, TDockType] of Integer = ((4, 2, 2), (4, 11, 11));
RightMargin: array[TDockType] of Integer = (4, 2, 2);
DefaultBarWidthHeight = 8;
ForceDockAtTopRow = 0;
ForceDockAtLeftPos = -8;
PositionLeftOrRight = [dpLeft, dpRight];
{ Names of registry values }
rvVisible = 'Visible';
rvDockedTo = 'DockedTo';
rvDockRow = 'DockRow';
rvDockPos = 'DockPos';
rvFloatLeft = 'FloatLeft';
rvFloatTop = 'FloatTop';
rvFloatRight = 'FloatRight';
rvFloatBottom = 'FloatBottom';
rvFloatRightX = 'FloatRightX';
type
{ Used in 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 SlaveInfo lists }
PSlaveInfo = ^TSlaveInfo;
TSlaveInfo = record
LeftRight,
TopBottom: TControl;
end;
{ Used in RowInfo lists }
PRowInfo = ^TRowInfo;
TRowInfo = record
BarHeight, BarWidth, DockedTotalBarHeight, DockedTotalBarWidth: Integer;
end;
{ Used in LineSeps lists }
TLineSep = record
Y: SmallInt;
Blank: Boolean;
Unused: Boolean;
end;
{ Use by CompareControls }
PCompareExtra = ^TCompareExtra;
TCompareExtra = record
Toolbar: TPCOfficeBar;
ComparePositions: Boolean;
CurDockType: TDockType;
end;
TFloatParent = class(TWinControl)
protected
procedure CreateParams (var Params: TCreateParams); override;
end;
function InstallNewWindowProc (const AID: Integer; const AForm: TForm;
const NewProc: TWndMethod; const NewHook: TWindowHook): Pointer; forward;
procedure UninstallNewWindowProc (const AID: Integer; const AForm: TForm); forward;
type
PUsedFormInfo = ^TUsedFormInfo;
TUsedFormInfo = record
ID: Integer;
Form: TForm;
Old, New: Pointer;
Hook: TWindowHook;
RefCount: Integer;
end;
var
UsedForms: TList;
{ See TToolbarButton97.ButtonMouseTimerHandler for info on these }
ButtonMouseTimer: TTimer = nil;
{ Misc. functions }
function GetCaptionHeight: 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: Integer;
{ Returns width 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 }
begin
Result := GetSystemMetrics(SM_CXFRAME);
end;
procedure AddNCAreaToRect (var R: TRect);
begin
Dec (R.Left, GetBorderSize);
Inc (R.Right, GetBorderSize);
Inc (R.Bottom, GetCaptionHeight + GetBorderSize*2);
end;
procedure RemoveNCAreaFromRect (var R: TRect);
begin
Inc (R.Left, GetBorderSize);
Dec (R.Right, GetBorderSize);
Dec (R.Bottom, GetCaptionHeight + GetBorderSize*2);
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 GetParenTPCOfficeBar (Control: TControl): TPCOfficeBar;
{ Returns the parent toolbar (direct or indirect) of the control, or nil if it
is not a child of a TPCOfficeBar }
begin
Result := nil;
while Control <> nil do begin
if Control is TPCOfficeBar then begin
Result := TPCOfficeBar(Control);
Break;
end;
Control := Control.Parent;
end;
end;
function ControlIsChildOf (Control, IsChildOf: TControl): Boolean;
{ Returns True if Control is directly or indirectly a child of IsChildOf }
begin
Result := False;
while Control <> nil do begin
if Control = IsChildOf then begin
Result := True;
Break;
end;
Control := Control.Parent;
end;
end;
function InstallNewWindowProc (const AID: Integer; const AForm: TForm;
const NewProc: TWndMethod; const NewHook: TWindowHook): Pointer;
{ Installs a new window procedure on the specified form that overrides the
existing one. Also, if NewHook <> nil, it adds a main window hook.
It returns the address of old window procedure, which the new window
procedure should call. }
var
I: Integer;
Info: PUsedFormInfo;
begin
Result := nil;
for I := 0 to UsedForms.Count-1 do
with PUsedFormInfo(UsedForms[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
ID := AID;
Form := AForm;
New := MakeObjectInstance(NewProc);
Old := Pointer(SetWindowLong(AForm.Handle, GWL_WNDPROC, LongInt(New)));
Hook := NewHook;
if Assigned(Hook) then
Application.HookMainWindow (Hook);
RefCount := 1;
Result := Old;
end;
UsedForms.Add (Info);
except
Dispose (Info);
raise;
end;
end;
procedure UninstallNewWindowProc (const AID: Integer; const AForm: TForm);
{ Removes the new window procedure installing using InstallNewWindowProc from
the specified form. }
var
I: Integer;
begin
for I := UsedForms.Count-1 downto 0 do
begin
with PUsedFormInfo(UsedForms[I])^ do
begin
if (ID = AID) and (Form = AForm) then
begin
Dec (RefCount);
if RefCount = 0 then
begin
if Form.HandleAllocated then
SetWindowLong (Form.Handle, GWL_WNDPROC, LongInt(Old));
FreeObjectInstance (New);
if Assigned(Hook) then
Application.UnhookMainWindow (Hook);
Dispose (PUsedFormInfo(UsedForms[I]));
UsedForms.Delete (I);
end;
end;
end;
end;
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.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 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;
procedure ShowHideFloatParents (const Form: TForm; const AppActive: Boolean);
var
HideFloatingToolbars: Boolean;
I: Integer;
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 is not visible or is minimized }
HideFloatingToolbars := not AppActive or IsIconic(Application.Handle) or
not IsWindowVisible(Form.Handle) or IsIconic(Form.Handle);
for I := 0 to Form.ComponentCount-1 do
if Form.Components[I] is TPCOfficeBar then
with TPCOfficeBar(Form.Components[I]) do
SetNotOnScreen ((DockedTo = nil) and HideFloatingToolbars);
end;
function GetDockTypeOf (const Control: TPCDock): TDockType;
begin
if Control = nil then
Result := dtNotDocked
else begin
if not(Control.Position in PositionLeftOrRight) then
Result := dtTopBottom
else
Result := dtLeftRight;
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;
{ TPCDock - internal }
constructor TPCDock.Create (AOwner: TComponent);
begin
inherited Create (AOwner);
if not(AOwner is TCustomForm) then
raise EInvalidOperation.Create(STB97DockNotFormOwner);
{ because TPCOfficeBar depends on docks being in the form's component list }
FAllowDrag := True;
DockList := TList.Create;
RowInfo := 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 TPCDock.CreateParams (var Params: TCreateParams);
begin
inherited CreateParams (Params);
{ 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 TPCDock.Destroy;
begin
if Assigned(FBkgCache) then
FBkgCache.Free;
if Assigned(FBkg) then
FBkg.Free;
FreeRowInfo;
if Assigned(RowInfo) then
RowInfo.Free;
if Assigned(DockList) then
DockList.Free;
inherited Destroy;
end;
procedure TPCDock.SetParent (AParent: TWinControl);
begin
if (AParent is TPCOfficeBar) or (AParent is TPCDock) then
raise EInvalidOperation.Create(STB97DockParentNotAllowed);
inherited SetParent (AParent);
end;
procedure TPCDock.VisibleChanging;
begin
if Visible then
raise EInvalidOperation.Create(STB97DockCannotHide);
inherited VisibleChanging;
end;
procedure TPCDock.FreeRowInfo;
var
I: Integer;
begin
if RowInfo = nil then Exit;
for I := RowInfo.Count - 1 downto 0 do
begin
FreeMem (RowInfo.Items[I]);
RowInfo.Delete (I);
end;
end;
procedure TPCDock.BuildRowInfo;
var
R, I: Integer;
HighestBarHeight, HighestBarWidth: Integer;
NewRowInfo: PRowInfo;
begin
FreeRowInfo;
for R := 0 to GetHighestRow do begin
HighestBarHeight := DefaultBarWidthHeight;
HighestBarWidth := DefaultBarWidthHeight;
for I := 0 to DockList.Count-1 do begin
with TPCOfficeBar(DockList[I]) do begin
if FDockRow <> R then Continue;
if FBarHeight > HighestBarHeight then
HighestBarHeight := FBarHeight;
if FBarWidth > HighestBarWidth then
HighestBarWidth := FBarWidth;
end;
end;
GetMem (NewRowInfo, SizeOf(TRowInfo));
try
with NewRowInfo^ do begin
BarHeight := HighestBarHeight;
BarWidth := HighestBarWidth;
DockedTotalBarHeight := TopMargin[dtTopBottom] + HighestBarHeight + BottomMargin[dtTopBottom];
DockedTotalBarWidth := TopMargin[dtLeftRight] + HighestBarWidth + BottomMargin[dtLeftRight];
end;
RowInfo.Add (NewRowInfo);
except
FreeMem (NewRowInfo);
raise;
end;
end;
end;
function GetRowInfo (const Row: Integer; const Dock: TPCDock;
const DefaultToolbar: TPCOfficeBar): TRowInfo;
begin
if Row < Dock.RowInfo.Count then
Result := PRowInfo(Dock.RowInfo[Row])^
else begin
{ If it's out of bounds }
if DefaultToolbar = nil then
FillChar (Result, SizeOf(Result), 0)
else
with Result do begin
BarHeight := DefaultToolbar.FBarHeight;
BarWidth := DefaultToolbar.FBarWidth;
DockedTotalBarHeight := DefaultToolbar.FDockedTotalBarHeight;
DockedTotalBarWidth := DefaultToolbar.FDockedTotalBarWidth;
end;
end;
end;
function TPCDock.GetRowOf (const Y: Integer; var Before: Boolean): Integer;
{ Returns row number of the specified Y. Before is set to True if it was
close to being in between two rows. }
var
HighestRow, R, CurY, NextY: Integer;
CurRowInfo: TRowInfo;
begin
Result := 0; Before := False;
HighestRow := GetHighestRow;
CurY := 0;
for R := 0 to HighestRow+1 do begin
if R <= HighestRow then begin
CurRowInfo := GetRowInfo(R, Self, nil);
if not(Position in PositionLeftOrRight) then
NextY := CurY + CurRowInfo.DockedTotalBarHeight
else
NextY := CurY + CurRowInfo.DockedTotalBarWidth;
end
else
NextY := High(NextY);
if Y <= CurY+5 then begin
Result := R;
Before := True;
Break;
end;
if (Y >= CurY+5) and (Y <= NextY-5) then begin
Result := R;
Break;
end;
CurY := NextY;
end;
end;
function TPCDock.GetDesignModeRowOf (const Y: Integer): Integer;
{ Similar to GetRowOf, but is a little different to accomidate design mode
better }
var
HighestRowPlus1, R, CurY, NextY: Integer;
CurRowInfo: TRowInfo;
begin
Result := 0;
HighestRowPlus1 := GetHighestRow+1;
CurY := 0;
for R := 0 to HighestRowPlus1 do begin
Result := R;
if R = HighestRowPlus1 then Break;
CurRowInfo := GetRowInfo(R, Self, nil);
if not(Position in PositionLeftOrRight) then
NextY := CurY + CurRowInfo.DockedTotalBarHeight
else
NextY := CurY + CurRowInfo.DockedTotalBarWidth;
if Y < NextY then
Break;
CurY := NextY;
end;
end;
function TPCDock.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 TPCOfficeBar(DockList[I]) do
if FDockRow > Result then
Result := FDockRow;
end;
procedure TPCDock.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 TPCOfficeBar(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 TPCOfficeBar(DockList[I]) do
if FDockRow > R then
Dec (FDockRow);
Dec (HighestRow);
end;
Inc (R);
end;
end;
procedure TPCDock.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 TPCOfficeBar(DockList[I]) do
if FDockRow >= BeforeRow then
Inc (FDockRow);
end;
procedure TPCDock.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 TPCDock.AlignControls (AControl: TControl; var Rect: TRect);
begin
ArrangeToolbars;
end;
function CompareDockRowPos (const Item1, Item2, ExtraData: Pointer): Integer; far;
begin
if TPCOfficeBar(Item1).FDockRow <> TPCOfficeBar(Item2).FDockRow then
Result := TPCOfficeBar(Item1).FDockRow - TPCOfficeBar(Item2).FDockRow
else
Result := TPCOfficeBar(Item1).FDockPos - TPCOfficeBar(Item2).FDockPos;
end;
procedure TPCDock.ArrangeToolbars;
{ The main procedure to arrange all the toolbars docked to it }
var
LeftRight: Boolean;
EmptySize: Integer;
HighestRow, R, CurDockPos, CurRowPixel, I, J: Integer;
HighestTotalBarHeight, HighestTotalBarWidth,
CurTotalBarHeight, CurTotalBarWidth: Integer;
begin
if (DisableArrangeToolbars > 0) or (csLoading in ComponentState) then
Exit;
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 TPCOfficeBar(DockList[I]) do
FDockRow := 0;
{ Remove any blank rows }
RemoveBlankRows;
{ Rebuild the RowInfo, since rows numbers were probably shifted after
RemoveBlankRows }
BuildRowInfo;
{ Find highest row number }
HighestRow := GetHighestRow;
{ Arrange, first without actually moving the toolbars onscreen }
for R := 0 to HighestRow do begin
CurDockPos := 0;
for I := 0 to DockList.Count-1 do begin
with TPCOfficeBar(DockList[I]) do begin
if FDockRow <> R then Continue;
if FDockPos <= CurDockPos then
FDockPos := CurDockPos
else
CurDockPos := FDockPos;
if not LeftRight then
Inc (CurDockPos, Width)
else
Inc (CurDockPos, Height);
end;
end;
end;
{ 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
if TPCOfficeBar(DockList[I]).FDockRow <> R then Continue;
for J := DockList.Count-1 downto I do begin
with TPCOfficeBar(DockList[J]) do begin
if FDockRow <> R then Continue;
if not LeftRight then begin
if FDockPos+Width > Self.ClientWidth then begin
TPCOfficeBar(DockList[I]).FDockPos :=
TPCOfficeBar(DockList[I]).FDockPos - ((FDockPos+Width) - Self.ClientWidth);
Break;
end;
end
else begin
if FDockPos+Height > Self.ClientHeight then begin
TPCOfficeBar(DockList[I]).FDockPos :=
TPCOfficeBar(DockList[I]).FDockPos - ((FDockPos+Height) - Self.ClientHeight);
Break;
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;
HighestTotalBarHeight := DefaultBarWidthHeight;
HighestTotalBarWidth := DefaultBarWidthHeight;
for I := 0 to DockList.Count-1 do begin
with TPCOfficeBar(DockList[I]) do begin
if FDockRow <> R then Continue;
CurTotalBarHeight := GetRowInfo(FDockRow, DockedTo, TPCOfficeBar(DockList[I])).DockedTotalBarHeight;
CurTotalBarWidth := GetRowInfo(FDockRow, DockedTo, TPCOfficeBar(DockList[I])).DockedTotalBarWidth;
if CurTotalBarHeight > HighestTotalBarHeight then
HighestTotalBarHeight := CurTotalBarHeight;
if CurTotalBarWidth > HighestTotalBarWidth then
HighestTotalBarWidth := CurTotalBarWidth;
if FDockPos <= CurDockPos then
FDockPos := CurDockPos
else
CurDockPos := FDockPos;
Inc (UpdatingBounds);
try
if not LeftRight then
SetVirtualBounds (CurDockPos, CurRowPixel, Width, CurTotalBarHeight)
else
SetVirtualBounds (CurRowPixel, CurDockPos, CurTotalBarWidth, Height);
finally
Dec (UpdatingBounds);
end;
if not LeftRight then
Inc (CurDockPos, Width)
else
Inc (CurDockPos, Height);
end;
end;
if not LeftRight then
Inc (CurRowPixel, HighestTotalBarHeight)
else
Inc (CurRowPixel, HighestTotalBarWidth);
end;
{ Set the size of the dock }
if not LeftRight then
ChangeWidthHeight (True, ClientWidth, CurRowPixel)
else
ChangeWidthHeight (True, CurRowPixel, ClientHeight);
end;
procedure TPCDock.ChangeDockList (const Insert: Boolean;
const Bar: TPCOfficeBar; 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.AutoArrangeControls;
if Assigned(FOnInsertRemoveBar) then
FOnInsertRemoveBar (Self, Insert, Bar);
end;
end;
procedure TPCDock.Loaded;
begin
inherited Loaded;
{ Rearranging is disabled while the component is loading, so now that it's
loaded, rearrange it. }
ArrangeToolbars;
end;
function TPCDock.GetPalette: HPALETTE;
begin
Result := FBkg.Palette;
end;
procedure TPCDock.DrawBackground (const Canvas: TCanvas;
const ClippingRect, DrawRect: TRect);
var
SaveClipRgn: HRGN;
R2: TRect;
UseBmp: TBitmap;
begin
{ Check if Background is assigned, and make sure it doesn't get caught in
an endless loop }
if Assigned(FBkg) and (FBkg.Width = 0) or (FBkg.Height = 0) then Exit;
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 := 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]);
end;
end;
UseBmp := FBkgCache;
end;
SaveClipRgn := 0;
GetClipRgn (Canvas.Handle, SaveClipRgn);
with ClippingRect do
IntersectClipRect (Canvas.Handle, Left, Top, Right, Bottom);
try
R2 := DrawRect;
while R2.Left < R2.Right do begin
while R2.Top < R2.Bottom do begin
Canvas.Draw (R2.Left, R2.Top, UseBmp);
Inc (R2.Top, UseBmp.Height);
end;
R2.Top := DrawRect.Top;
Inc (R2.Left, UseBmp.Width);
end;
finally
{ Restore the previous clipping region back }
SelectClipRgn (Canvas.Handle, SaveClipRgn);
if SaveClipRgn <> 0 then DeleteObject (SaveClipRgn);
end;
end;
procedure TPCDock.Paint;
var
R, R2: TRect;
P1, P2: TPoint;
begin
inherited Paint;
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 Assigned(FBkg) 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, R, R2);
end;
end;
end;
procedure TPCDock.WMMove (var Message: TWMMove);
begin
inherited;
if (FBkg.Width <> 0) and (FBkg.Height <> 0) then
InvalidateBackgrounds;
end;
procedure TPCDock.WMSize (var Message: TWMSize);
begin
inherited;
if Assigned(FOnResize) then
FOnResize (Self);
end;
procedure TPCDock.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 TPCDock.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 then begin
GetWindowRect (Handle, R2);
{ An invalid region is generally passed when the window is first created }
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 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 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 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 TPCDock.CMSysColorChange (var Message: TMessage);
begin
inherited;
{ Erase the cache }
BackgroundChanged (FBkg);
end;
{ TPCDock - property access methods }
procedure TPCDock.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 TPCOfficeBar then
with TPCOfficeBar(Controls[I]) do begin
Invalidate;
AutoArrangeControls;
end;
end;
end;
procedure TPCDock.SetBackground (Value: TBitmap);
begin
FBkg.Assign (Value);
end;
procedure TPCDock.InvalidateBackgrounds;
{ Called after background is changed }
var
I: Integer;
begin
Invalidate;
{ Synchronize child toolbars also }
for I := 0 to ControlCount-1 do
if Controls[I] is TPCOfficeBar then
Controls[I].Invalidate;
end;
procedure TPCDock.BackgroundChanged (Sender: TObject);
begin
{ Erase the cache }
if Assigned(FBkgCache) then begin
FBkgCache.Free;
FBkgCache := nil;
end;
InvalidateBackgrounds;
end;
procedure TPCDock.SetBackgroundTransparent (Value: Boolean);
begin
if FBkgTransparent <> Value then begin
FBkgTransparent := Value;
{ Erase the cache }
BackgroundChanged (FBkg);
end;
end;
procedure TPCDock.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 TPCDock.SetFixAlign (Value: Boolean);
begin
if FFixAlign <> Value then begin
FFixAlign := Value;
ArrangeToolbars;
end;
end;
procedure TPCDock.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 TPCDock.GetToolbarCount: Integer;
begin
Result := DockList.Count;
end;
function TPCDock.GetToolbars (Index: Integer): TPCOfficeBar;
begin
Result := TPCOfficeBar(DockList[Index]);
end;
{ TFloatParent - Internal }
procedure TFloatParent.CreateParams (var Params: TCreateParams);
begin
inherited CreateParams (Params);
with Params do begin
Style := WS_CHILD;
ExStyle := 0;
end;
end;
{ TPCOfficeBar - Internal }
constructor TPCOfficeBar.Create (AOwner: TComponent);
begin
inherited Create (AOwner);
if not(AOwner is TCustomForm) then
raise EInvalidOperation.Create(STB97ToolbarNotFormOwner);
{ because it frequently casts Owner into a TForm }
MDIParentForm := GetMDIParent(TForm(AOwner));
GroupInfo := TList.Create;
SlaveInfo := TList.Create;
LineSeps := TList.Create;
OrderList := TList.Create;
Inc (DisableArrangeControls);
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 new window procedure for the form (or the MDI parent, if
it's owner is an MDI child) of the toolbar, and a main window hook }
OldFormWindowProc := InstallNewWindowProc(0, MDIParentForm,
NewFormWindowProc, NewMainWindowHook);
{ Add a another window procedure if it's owner is an MDI child }
if TForm(AOwner).FormStyle = fsMDIChild then
OldChildFormWindowProc := InstallNewWindowProc(1, TForm(AOwner),
NewChildFormWindowProc, nil);
{ Need to move it offscreen while loading to prevent any flashing as it's
updating }
SetNotOnScreen (True);
end
else
FloatParent := TForm(AOwner);
FCanDockLeftRight := True;
FCloseButton := True;
FDockPos := -1;
FBarHeight := DefaultBarWidthHeight;
FBarWidth := DefaultBarWidthHeight;
Color := clBtnFace;
DockedTo := nil;
finally
Dec (DisableArrangeControls);
end;
AutoArrangeControls;
end;
function TPCOfficeBar.GetVirtualBoundsRect: TRect;
begin
Result := BoundsRect;
if NotOnScreen then begin
Result.Right := VirtualLeft + (Result.Right-Result.Left);
Result.Left := VirtualLeft;
end;
end;
procedure TPCOfficeBar.SetVirtualBounds (ALeft, ATop, AWidth, AHeight: Integer);
begin
VirtualLeft := ALeft;
{ Move it off the left of the screen when NotOnScreen is True }
if NotOnScreen then
ALeft := -AWidth;
SetBounds (ALeft, ATop, AWidth, AHeight);
end;
procedure TPCOfficeBar.SetVirtualBoundsRect (const R: TRect);
begin
SetVirtualBounds (R.Left, R.Top, R.Right-R.Left, R.Bottom-R.Top);
end;
procedure TPCOfficeBar.SetNotOnScreen (const Value: Boolean);
var
SaveVirtualBounds: TRect;
begin
if NotOnScreen <> Value then begin
SaveVirtualBounds := GetVirtualBoundsRect;
NotOnScreen := Value;
{ Update the bounds so that the change to Value is immediately
reflected }
SetVirtualBoundsRect (SaveVirtualBounds);
end;
end;
procedure TPCOfficeBar.WMMove (var Message: TWMMove);
begin
inherited;
if (DockedTo <> nil) and (DockedTo.FBkg.Width <> 0) and
(DockedTo.FBkg.Height <> 0) then
{ Needs to redraw so that background is lined up with the dock at the
new position }
Repaint;
end;
procedure TPCOfficeBar.WMGetMinMaxInfo (var Message: TWMGetMinMaxInfo);
begin
inherited;
{ This removes the minimum size limit of the window, so it can resize it
to however small is necessary. This has no effect on Win95/NT 4.0 when it
uses the WS_EX_TOOLWINDOW style, but is required for Win 3.x. }
Message.MinMaxInfo^.ptMinTrackSize := Point(1, 1);
end;
procedure TPCOfficeBar.CreateParams (var Params: TCreateParams);
begin
inherited CreateParams (Params);
if Parent = FloatParent then
with Params do begin
if not(csDesigning in ComponentState) then
Style := WS_POPUP
else
Style := Style and not (WS_BORDER or WS_THICKFRAME);
{ Only Win95/NT 4.0 uses WS_EX_TOOLWINDOW }
ExStyle := WS_EX_TOOLWINDOW;
end;
end;
destructor TPCOfficeBar.Destroy;
var
I: Integer;
begin
if Assigned(OrderList) then
OrderList.Free;
if Assigned(LineSeps) then
LineSeps.Free;
if Assigned(SlaveInfo) then begin
for I := SlaveInfo.Count-1 downto 0 do begin
FreeMem (SlaveInfo.Items[I]);
SlaveInfo.Delete (I);
end;
SlaveInfo.Free;
end;
FreeGroupInfo (GroupInfo);
if Assigned(GroupInfo) then
GroupInfo.Free;
if not(csDesigning in ComponentState) then begin
UninstallNewWindowProc (0, MDIParentForm);
if TForm(Owner).FormStyle = fsMDIChild then
UninstallNewWindowProc (1, TForm(Owner));
end;
inherited Destroy;
end;
procedure TPCOfficeBar.Notification (AComponent: TComponent; Operation: TOperation);
begin
inherited Notification (AComponent, Operation);
if (AComponent = FDefaultDock) and (Operation = opRemove) then
FDefaultDock := nil;
end;
procedure TPCOfficeBar.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 DockedTo = nil then begin
R := GetVirtualBoundsRect;
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);
SetVirtualBoundsRect (R);
end;
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 TPCOfficeBar.Loaded;
var
R: TRect;
Extra: TCompareExtra;
begin
inherited Loaded;
{ Adjust coordinates if it was initially floating }
if (not(csDesigning in ComponentState)) and (DockedTo = nil) then begin
{ Read BoundsRect, not VirtualBoundsRect, since it's unable to set the
VirtualBoundsRect while loading }
R := BoundsRect;
MapWindowPoints (TForm(Owner).Handle, 0, R, 2);
SetVirtualBoundsRect (R);
MoveOnScreen (False);
end;
{ 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;
{ Arranging of controls is disabled while component was loading, so rearrange
it now }
AutoArrangeControls;
if not(csDesigning in ComponentState) then
{ Since SetNotOnScreen(True) was called in the Create constructor, it needs
to restore it back }
ShowHideFloatParents (MDIParentForm, Application.Active);
end;
function TPCOfficeBar.GetOrderIndex (Control: TControl): Integer;
begin
Result := OrderList.IndexOf(Control);
if Result = -1 then
raise EInvalidOperation.Create(STB97ToolbarControlNotChildOfToolbar);
end;
procedure TPCOfficeBar.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);
AutoArrangeControls;
end;
end;
end;
procedure TPCOfficeBar.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);
AutoArrangeControls;
end;
Procedure TPCOfficeBar.RealignControls(DWidth:Integer);
var t,i,w,tw: integer;
c: TComponent;
p: TControl;
begin
//cInfoMes = 168
//cCommEdit = 169;
tw := 0;
p := nil;
for i:=0 to ComponentCount-1 do
begin
c := Components[i];
w := TControl(c).width;
t := c.Tag;
if ((t <> 168) and (t <> 169)) then tw := tw+w else
begin
p := TControl(c);
end;
end;
if assigned(p) then P.Width := Dwidth-tw-14;
end;
procedure CustomLoadToolbarPositions (const Form: TForm;
const ReadIntProc: TPositionReadIntProc;
const ReadStringProc: TPositionReadStringProc; const ExtraData: Pointer);
function FindDock (AName: String): TPCDock;
var
I: Integer;
begin
Result := nil;
for I := 0 to Form.ComponentCount-1 do
if (Form.Components[I] is TPCDock) and (Form.Components[I].Name = AName) then begin
Result := TPCDock(Form.Components[I]);
Break;
end;
end;
procedure ReadValues (const Toolbar: TPCOfficeBar);
begin
with Toolbar do begin
FDockRow := ReadIntProc(Name, rvDockRow, FDockRow, ExtraData);
FDockPos := ReadIntProc(Name, rvDockPos, FDockPos, ExtraData);
FFloatingRect.Left := ReadIntProc(Name, rvFloatLeft, 0, ExtraData);
FFloatingRect.Top := ReadIntProc(Name, rvFloatTop, 0, ExtraData);
FFloatingRect.Right := ReadIntProc(Name, rvFloatRight, 0, ExtraData);
FFloatingRect.Bottom := ReadIntProc(Name, rvFloatBottom, 0, ExtraData);
FFloatingRightX := ReadIntProc(Name, rvFloatRightX, 0, ExtraData);
end;
end;
var
DocksDisabled: TList;
I: Integer;
DockX: TPCDock;
DockedToName: String;
begin
DocksDisabled := TList.Create;
try
with Form do
for I := 0 to ComponentCount-1 do
if Components[I] is TPCDock then begin
Inc (TPCDock(Components[I]).DisableArrangeToolbars);
DocksDisabled.Add (Components[I]);
end;
for I := 0 to Form.ComponentCount-1 do
if Form.Components[I] is TPCOfficeBar then
with TPCOfficeBar(Form.Components[I]) do begin
if Length(Name) = 0 then
raise Exception.Create (STB97ToolbarNameNotSet);
Visible := ReadIntProc(Name, rvVisible, Ord(Visible), ExtraData) <> 0;
DockedToName := ReadStringProc(Name, rvDockedTo, '', ExtraData);
if Length(DockedToName) <> 0 then begin
if DockedToName <> 'nil' then begin
DockX := FindDock(DockedToName);
if (DockX <> nil) and (DockX.FAllowDrag) then begin
ReadValues (TPCOfficeBar(Form.Components[I]));
if not IsRectEmpty(FFloatingRect) then
AddNCAreaToRect (FFloatingRect);
DockedTo := DockX;
end;
end
else begin
ReadValues (TPCOfficeBar(Form.Components[I]));
AddNCAreaToRect (FFloatingRect);
DockedTo := nil;
MoveOnScreen (False);
end;
end;
end;
finally
for I := DocksDisabled.Count-1 downto 0 do begin
Dec (TPCDock(DocksDisabled[I]).DisableArrangeToolbars);
TPCDock(DocksDisabled[I]).ArrangeToolbars;
end;
DocksDisabled.Free;
end;
end;
procedure CustomSaveToolbarPositions (const Form: TForm;
const WriteIntProc: TPositionWriteIntProc;
const WriteStringProc: TPositionWriteStringProc; const ExtraData: Pointer);
var
R: TRect;
procedure WriteValues (const Toolbar: TPCOfficeBar; const DockedToName: String);
begin
with Toolbar do begin
WriteStringProc (Name, rvDockedTo, DockedToName, ExtraData);
WriteIntProc (Name, rvDockRow, FDockRow, ExtraData);
WriteIntProc (Name, rvDockPos, FDockPos, ExtraData);
WriteIntProc (Name, rvFloatLeft, R.Left, ExtraData);
WriteIntProc (Name, rvFloatTop, R.Top, ExtraData);
WriteIntProc (Name, rvFloatRight, R.Right, ExtraData);
WriteIntProc (Name, rvFloatBottom, R.Bottom, ExtraData);
WriteIntProc (Name, rvFloatRightX, FFloatingRightX, ExtraData);
end;
end;
var
I: Integer;
begin
for I := 0 to Form.ComponentCount-1 do
if Form.Components[I] is TPCOfficeBar then
with TPCOfficeBar(Form.Components[I]) do begin
if Length(Name) = 0 then
raise Exception.Create (STB97ToolbarNameNotSet);
if (DockedTo <> nil) and (Length(DockedTo.Name) = 0) then
raise Exception.Create (STB97ToolbarDockToNameNotSet);
WriteIntProc (Name, rvVisible, Ord(Visible), ExtraData);
if DockedTo <> nil then begin
if DockedTo.FAllowDrag then begin
R := FFloatingRect;
if not IsRectEmpty(FFloatingRect) then
RemoveNCAreaFromRect (R);
WriteValues (TPCOfficeBar(Form.Components[I]), DockedTo.Name);
end;
end
else begin
R := GetVirtualBoundsRect;
RemoveNCAreaFromRect (R);
WriteValues (TPCOfficeBar(Form.Components[I]), 'nil');
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;
procedure TPCOfficeBar.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
if Assigned(L^.Members) then
L^.Members.Free;
FreeMem (L);
end;
List.Delete (I);
end;
end;
procedure TPCOfficeBar.BuildGroupInfo (const List: TList;
const TranslateSlave: Boolean; const OldDockType, NewDockType: TDockType);
var
I, J: Integer;
IsVisible: Boolean;
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 begin
IsVisible := Controls[I].Visible;
if TranslateSlave then begin
for J := 0 to SlaveInfo.Count-1 do
with PSlaveInfo(SlaveInfo[J])^ do begin
if TopBottom = Controls[I] then begin
IsVisible := NewDockType <> dtLeftRight;
Break;
end;
if LeftRight = Controls[I] then begin
IsVisible := NewDockType = dtLeftRight;
Break;
end;
end;
end;
if IsVisible then
Children.Add (Controls[I]);
end;
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[List.Count-1];
GI^.Members := TList.Create;
end;
GI^.Members.Add (Children[I]);
if TControl(Children[I]) is TPCSep 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 TPCOfficeBar.AutoArrangeControls;
begin
ArrangeControls (True, True, GetDockTypeOf(DockedTo), DockedTo, FFloatingRightX, nil);
end;
procedure TPCOfficeBar.ShouldBeVisible (const Control: TControl;
const DockType: TDockType; const SetIt: Boolean; var AVisible: Boolean);
{ Sets AVisible only if it is a master or slave control. AVisible is left as is
otherwise }
var
J: Integer;
begin
for J := 0 to SlaveInfo.Count-1 do
with PSlaveInfo(SlaveInfo[J])^ do
if TopBottom = Control then begin
AVisible := DockType <> dtLeftRight;
if SetIt then begin
TopBottom.Visible := AVisible;
LeftRight.Visible := not AVisible;
end;
end
else
if LeftRight = Control then begin
AVisible := DockType = dtLeftRight;
if SetIt then begin
TopBottom.Visible := not AVisible;
LeftRight.Visible := AVisible;
end;
end;
end;
procedure TPCOfficeBar.ArrangeControls (const CanMove, CanResize: Boolean;
const OldDockType: TDockType; const DockingTo: TPCDock; RightX: Integer;
const NewClientSize: PPoint);
{ This arranges the controls on the toolbar }
var
NewDockType: TDockType;
OldBarHeight, OldBarWidth, OldDockedTotalBarHeight, OldDockedTotalBarWidth,
I, NewBarHeight, NewBarWidth: Integer;
AllowWrap, V: Boolean;
BarPosSize, CurPosPixel, CurLinePixel, G: Integer;
GInfo: TList;
GI: PGroupInfo;
Member: TControl;
MemberIsSep: Boolean;
GroupPosSize, MemberPosSize: Integer;
NewLine, Prec1Line: Boolean;
MinPosPixels, MinRowPixels, CW, CH: Integer;
DocksBarHeight, DocksBarWidth, DocksTotalBarHeight, DocksTotalBarWidth: Integer;
PreviousSep: TPCSep; PrevMinPosPixels: Integer;
NewLineSep: TLineSep;
DockAllowsDrag: Boolean;
label 1;
begin
if (DisableArrangeControls > 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.HandleAllocated and (csDestroying in Parent.ComponentState)) then
Exit;
NewDockType := GetDockTypeOf(DockingTo);
if (NewDockType <> dtNotDocked) or (RightX = 0) then
RightX := High(RightX);
DockAllowsDrag := (DockedTo = nil) or (DockedTo.FAllowDrag);
Inc (DisableArrangeControls);
try
OldBarWidth := FBarWidth;
OldBarHeight := FBarHeight;
OldDockedTotalBarHeight := FDockedTotalBarHeight;
OldDockedTotalBarWidth := FDockedTotalBarWidth;
try
NewBarHeight := DefaultBarWidthHeight;
NewBarWidth := DefaultBarWidthHeight;
for I := 0 to ControlCount-1 do begin
if Controls[I] is TPCSep then Continue;
with Controls[I] do begin
V := Visible;
ShouldBeVisible (Controls[I], NewDockType, CanMove, V);
if not V then Continue;
if Height > NewBarHeight then
NewBarHeight := Height;
if Width > NewBarWidth then
NewBarWidth := Width;
end;
end;
FBarHeight := NewBarHeight;
FBarWidth := NewBarWidth;
{ the following line is mirrored in BuildRowInfo }
FDockedTotalBarHeight := TopMargin[dtTopBottom] + FBarHeight + BottomMargin[dtTopBottom];
FDockedTotalBarWidth := TopMargin[dtLeftRight] + FBarWidth + BottomMargin[dtLeftRight];
DocksBarHeight := FBarHeight;
DocksBarWidth := FBarWidth;
DocksTotalBarHeight := FDockedTotalBarHeight;
DocksTotalBarWidth := FDockedTotalBarWidth;
if CanMove and (DockingTo <> nil) and (DockingTo = DockedTo) then
with DockingTo do begin
BuildRowInfo;
with GetRowInfo(FDockRow, DockingTo, Self) do begin
DocksBarHeight := BarHeight;
DocksBarWidth := BarWidth;
DocksTotalBarHeight := DockedTotalBarHeight;
DocksTotalBarWidth := DockedTotalBarWidth;
end;
end;
if CanMove then
GInfo := GroupInfo
else
GInfo := TList.Create;
try
BuildGroupInfo (GInfo, not CanMove, OldDockType, NewDockType);
if CanMove then
LineSeps.Clear;
AllowWrap := NewDockType = dtNotDocked;
if GInfo.Count <> 0 then begin
if NewDockType <> dtLeftRight then
BarPosSize := FBarHeight
else
BarPosSize := FBarWidth;
MinPosPixels := 0;
CurPosPixel := 0;
CurLinePixel := TopMargin[NewDockType];
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[DockAllowsDrag, NewDockType])
end;
if CurPosPixel+GroupPosSize+RightMargin[NewDockType] > 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[DockAllowsDrag, NewDockType];
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 CanMove 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 TPCSep;
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 := TPCSep(Member).SizeHorz
else
MemberPosSize := TPCSep(Member).SizeVert;
end;
{ If past right (or bottom) side of screen, proceed to next line }
if not MemberIsSep and
(CurPosPixel+MemberPosSize+RightMargin[NewDockType] > RightX) then begin
CurPosPixel := LeftMargin[DockAllowsDrag, NewDockType];
if CurPosPixel > MinPosPixels then MinPosPixels := CurPosPixel;
Inc (CurLinePixel, FBarHeight);
Prec1Line := False;
end;
if NewDockType <> dtLeftRight then begin
if not MemberIsSep then begin
if CanMove then
SetBounds (CurPosPixel, CurLinePixel+((DocksBarHeight-Height) div 2), Width, Height);
Inc (CurPosPixel, Width);
end
else begin
if CanMove then
SetBounds (CurPosPixel, CurLinePixel, TPCSep(Member).SizeHorz, DocksBarHeight);
Inc (CurPosPixel, TPCSep(Member).SizeHorz);
end;
end
else begin
if not MemberIsSep then begin
if CanMove then
SetBounds (CurLinePixel+((DocksBarWidth-Width) div 2), CurPosPixel, Width, Height);
Inc (CurPosPixel, Height);
end
else begin
if CanMove then
SetBounds (CurLinePixel, CurPosPixel, DocksBarWidth, TPCSep(Member).SizeVert);
Inc (CurPosPixel, TPCSep(Member).SizeVert);
end;
end;
PrevMinPosPixels := MinPosPixels;
if not MemberIsSep then
PreviousSep := nil
else
PreviousSep := TPCSep(Member);
if CurPosPixel > MinPosPixels then MinPosPixels := CurPosPixel;
end;
end;
end;
end
else begin
if DockedTo <> nil then begin
MinPosPixels := LeftMargin[DockAllowsDrag, NewDockType];
CurLinePixel := TopMargin[NewDockType];
if not(DockedTo.Position in PositionLeftOrRight) then begin
Inc (MinPosPixels, DefaultBarWidthHeight);
BarPosSize := GetRowInfo(FDockRow, DockedTo, Self).BarHeight;
end
else begin
Inc (MinPosPixels, DefaultBarWidthHeight);
BarPosSize := GetRowInfo(FDockRow, DockedTo, Self).BarWidth;
end;
end
else begin
MinPosPixels := LeftMargin[DockAllowsDrag, NewDockType] + DefaultBarWidthHeight;
CurLinePixel := TopMargin[NewDockType];
BarPosSize := DefaultBarWidthHeight;
end;
end;
if csDesigning in ComponentState then
Invalidate;
finally
if not CanMove then begin
FreeGroupInfo (GInfo);
GInfo.Free;
end;
end;
if CanMove then begin
CW := ClientWidth;
CH := ClientHeight;
end
else begin
CW := 0;
CH := 0;
end;
Inc (MinPosPixels, RightMargin[NewDockType]);
if NewDockType <> dtLeftRight then
CW := MinPosPixels
else
CH := MinPosPixels;
MinRowPixels := CurLinePixel + BarPosSize + BottomMargin[NewDockType];
if NewDockType <> dtLeftRight then
CH := MinRowPixels
else
CW := MinRowPixels;
if DockedTo <> nil then begin
if NewDockType <> dtLeftRight then begin
if CH < DocksTotalBarHeight then
CH := DocksTotalBarHeight;
end
else begin
if CW < DocksTotalBarWidth then
CW := DocksTotalBarWidth;
end;
end;
if CanResize and ((ClientWidth <> CW) or (ClientHeight <> CH)) then begin
Inc (UpdatingBounds);
try
SetVirtualBounds (Left, Top,
(Width-ClientWidth)+CW, (Height-ClientHeight)+CH);
finally
Dec (UpdatingBounds);
end;
end;
if Assigned(NewClientSize) then begin
NewClientSize^.X := CW;
NewClientSize^.Y := CH;
end;
finally
if not CanMove then begin
FBarWidth := OldBarWidth;
FBarHeight := OldBarHeight;
FDockedTotalBarHeight := OldDockedTotalBarHeight;
FDockedTotalBarWidth := OldDockedTotalBarWidth;
end;
end;
finally
Dec (DisableArrangeControls);
end;
end;
procedure TPCOfficeBar.AlignControls (AControl: TControl; var Rect: TRect);
{ VCL calls this whenever any child controls in the toolbar are moved, sized,
inserted, etc. It doesn't make use of the AControl and Rect parameters,
since it doesn't need to. }
begin
AutoArrangeControls;
end;
procedure TPCOfficeBar.SetBounds (ALeft, ATop, AWidth, AHeight: Integer);
begin
inherited SetBounds (ALeft, ATop, AWidth, AHeight);
{ This allows you to drag the toolbar at design time }
if (csDesigning in ComponentState) and not(csLoading in ComponentState) and
(DockedTo <> nil) and (UpdatingBounds = 0) then begin
if not(DockedTo.Position in PositionLeftOrRight) then begin
FDockRow := DockedTo.GetDesignModeRowOf(ATop+(AHeight div 2));
FDockPos := ALeft;
end
else begin
FDockRow := DockedTo.GetDesignModeRowOf(ALeft+(AWidth div 2));
FDockPos := ATop;
end;
DockedTo.ArrangeToolbars;
end;
end;
procedure TPCOfficeBar.SetParent (AParent: TWinControl);
begin
if not(csDesigning in ComponentState) and (AParent = TForm(Owner)) then
AParent := FloatParent;
if (AParent <> nil) and not(AParent is TPCDock) and
not(AParent = Owner) and not(AParent is TFloatParent) then
raise EInvalidOperation.Create(STB97ToolbarParentNotAllowed);
if not(csDestroying in ComponentState) and Assigned(FOnRecreating) then
FOnRecreating (Self);
if Parent is TPCDock then
TPCDock(Parent).ChangeDockList (False, Self, Visible or (Hidden <> 0));
inherited SetParent (AParent);
if Parent is TPCDock then
TPCDock(Parent).ChangeDockList (True, Self, Visible or (Hidden <> 0));
if not(csDestroying in ComponentState) and Assigned(FOnRecreated) then
FOnRecreated (Self);
end;
procedure TPCOfficeBar.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 GetCaptionRect (const Control: TWinControl;
const AdjustForBorder, MinusCloseButton: Boolean): TRect;
begin
Result := Rect(0, 0, Control.ClientWidth, GetCaptionHeight-1);
if MinusCloseButton then
Dec (Result.Right, GetCaptionHeight-1);
if AdjustForBorder then
OffsetRect (Result, GetBorderSize, GetBorderSize);
end;
function GetCloseButtonRect (const Control: TWinControl;
const AdjustForBorder: Boolean): TRect;
begin
Result := Rect(0, 0, Control.ClientWidth, GetCaptionHeight-1);
if AdjustForBorder then
OffsetRect (Result, GetBorderSize, GetBorderSize);
Result.Left := Result.Right - (GetCaptionHeight-1);
end;
procedure TPCOfficeBar.WMNCCalcSize (var Message: TWMNCCalcSize);
begin
{ Note to self: inherited must be up here or it doesn't work right }
inherited;
if DockedTo = nil then begin
InflateRect (Message.CalcSize_Params^.rgrc[0], -GetBorderSize, -GetBorderSize);
Inc (Message.CalcSize_Params^.rgrc[0].Top, GetCaptionHeight);
end;
end;
procedure TPCOfficeBar.DrawNCArea (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.
At design time, the caption is always drawn with the activated color. }
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;
NewFont, SaveFont: HFONT;
NewBrush: HBRUSH;
Cap: String;
function CaptionTextWidth: Integer;
var
Size: TSize;
begin
GetTextExtentPoint32 (DC, @Cap[1], Length(Cap), Size);
Result := Size.cx;
end;
begin
R2 := R;
{ Fill the rectangle }
NewBrush := CreateSolidBrush(GetSysColor(COLOR_ACTIVECAPTION));
FillRect (DC, R2, NewBrush);
DeleteObject (NewBrush);
Inc (R2.Left);
Dec (R2.Right);
NewFont := CreateFont(-11, 0, 0, 0, FW_NORMAL, 0, 0, 0, 0, 0, 0, 0, 0, 'MS Sans Serif');
SaveFont := SelectObject(DC, NewFont);
{ 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 do begin
if Length(Cap) <= 4 then Break;
Delete (Cap, Length(Cap)-Length(Ellipsis), 1)
end;
end;
{ Draw the text }
SaveBkColor := SetBkColor(DC, GetSysColor(COLOR_ACTIVECAPTION));
SaveTextColor := SetTextColor(DC, GetSysColor(COLOR_CAPTIONTEXT));
DrawText (DC, @Cap[1], Length(Cap), R2, DT_SINGLELINE or DT_NOPREFIX or DT_VCENTER);
SetTextColor (DC, SaveTextColor);
SetBkColor (DC, SaveBkColor);
SelectObject (DC, SaveFont);
DeleteObject (NewFont);
end;
const
CloseButtonState: array[Boolean] of UINT = (0, DFCS_PUSHED);
var
DC: HDC;
R: TRect;
NewClipRgn: HRGN;
I: Integer;
NewDrawCaption: function(p1: HWND; p2: HDC; const p3: TRect; p4: UINT): BOOL; stdcall;
Pen, SavePen: HPEN;
Brush: HBRUSH;
begin
if DockedTo <> nil then Exit;
DC := GetWindowDC(Handle);
try
{ Use update region }
if Clip <> 0 then begin
GetWindowRect (Handle, R);
{ An invalid region is generally passed when the window is first created }
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);
Brush := CreateSolidBrush(GetSysColor(COLOR_BTNFACE));
for I := 1 to GetBorderSize do
case I of
1: DrawEdge (DC, R, EDGE_RAISED, BF_RECT or BF_ADJUST);
2: ;
else
FrameRect (DC, R, Brush);
InflateRect (R, -1, -1);
end;
DeleteObject (Brush);
end;
{ 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_ACTIVE or DC_TEXT or DC_SMALLCAP);
end
else
Win3DrawCaption (DC, R);
{ Line below caption }
R := GetCaptionRect(Self, True, False);
Pen := CreatePen(PS_SOLID, 1, GetSysColor(COLOR_BTNFACE));
SavePen := SelectObject(DC, Pen);
MoveToEx (DC, R.Left, R.Bottom, nil);
LineTo (DC, R.Right, R.Bottom);
SelectObject (DC, SavePen);
DeleteObject (Pen);
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);
Brush := CreateSolidBrush(GetSysColor(COLOR_ACTIVECAPTION));
FrameRect (DC, R, Brush);
DeleteObject (Brush);
end;
end;
finally
ReleaseDC (Handle, DC);
end;
end;
procedure TPCOfficeBar.WMNCPaint (var Message: TMessage);
begin
inherited;
try
DrawNCArea (Message.WParam, True, True, True);
except
//On E:Exception do showmessage(E.Message);
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 TPCOfficeBar.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
Result := 0;
for I := 0 to 7 do
GrayPattern[I] := Patterns[I and 1 <> 0];
GrayBitmap := CreateBitmap(8, 8, 1, 1, @GrayPattern);
if GrayBitmap <> 0 then begin
Result := CreatePatternBrush(GrayBitmap);
DeleteObject (GrayBitmap);
end;
end;
var
NewSize, OldSize: TSize;
Brush: HBRUSH;
begin
Brush := CreateHalftoneBrush;
try
if NewDocking then NewSize.cx := 1 else NewSize.cx := GetBorderSize;
NewSize.cy := NewSize.cx;
if OldDocking then OldSize.cx := 1 else OldSize.cx := GetBorderSize;
OldSize.cy := OldSize.cx;
DrawDragRect (DC, NewRect, OldRect, NewSize, OldSize, Brush, Brush);
finally
DeleteObject (Brush);
end;
end;
procedure TPCOfficeBar.Paint;
procedure DrawRaisedEdge (R: TRect; const FillInterior: Boolean);
const
FillMiddle: array[Boolean] of UINT = (0, BF_MIDDLE);
begin
DrawEdge (Canvas.Handle, R, BDR_RAISEDINNER, BF_RECT or FillMiddle[FillInterior]);
end;
var
DockType: TDockType;
X, Y, S: Integer;
R, R2: TRect;
P1, P2: TPoint;
LS: TLineSep;
begin
inherited Paint;
if DockedTo = nil then
DockType := dtNotDocked
else begin
if not(DockedTo.Position in PositionLeftOrRight) then
DockType := dtTopBottom
else
DockType := dtLeftRight;
end;
if DockType <> dtNotDocked then begin
{ Border }
R := ClientRect;
DrawRaisedEdge (R, False);
{ Draw the Background }
if (DockedTo <> nil) and Assigned(DockedTo.FBkg) 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);
DockedTo.DrawBackground (Canvas, R, R2);
end;
{ The drag handle at the left, or top }
if (DockedTo <> nil) and (DockedTo.FAllowDrag) then
if DockType <> dtLeftRight then begin
Y := ClientHeight-2;
DrawRaisedEdge (Rect(4, 2, 7, Y), True);
Canvas.Pixels[4, Y-1] := clBtnHighlight;
DrawRaisedEdge (Rect(7, 2, 10, Y), True);
Canvas.Pixels[7, Y-1] := clBtnHighlight;
end
else begin
X := ClientWidth-2;
DrawRaisedEdge (Rect(2, 4, X, 7), True);
Canvas.Pixels[X-1, 4] := clBtnHighlight;
DrawRaisedEdge (Rect(2, 7, X, 10), True);
Canvas.Pixels[X-1, 7] := clBtnHighlight;
end;
end;
{ Long separators when not docked }
if DockedTo = nil then
for S := 0 to LineSeps.Count-1 do begin
Pointer(LS) := LineSeps[S];
with LS 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;
procedure TPCOfficeBar.CMTextChanged (var Message: TMessage);
begin
inherited;
{ Update the title bar to use the new Caption }
DrawNCArea (0, False, True, False);
end;
procedure TPCOfficeBar.CMVisibleChanged (var Message: TMessage);
begin
if not(csDesigning in ComponentState) and
(Hidden = 0) and (DockedTo <> nil) then
DockedTo.ChangeDockList (Visible, Self, Visible);
inherited;
end;
procedure TPCOfficeBar.WMActivate (var Message: TWMActivate);
begin
SendMessage (MDIParentForm.Handle, WM_NCACTIVATE, Ord(Message.Active <> WA_INACTIVE), 0);
inherited;
end;
procedure TPCOfficeBar.WMMouseActivate (var Message: TWMMouseActivate);
begin
if (csDesigning in ComponentState) or (DockedTo <> nil) 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 GetActiveForm <> MDIParentForm then
{ Must only activate if it wasn't already activated so it doesn't
change the focus }
SetActiveWindow (MDIParentForm.Handle);
end;
end;
procedure TPCOfficeBar.BeginMoving (const InitX, InitY: Integer);
type
PDockedSize = ^TDockedSize;
TDockedSize = record
Dock: TPCDock;
Size: TPoint;
end;
var
NewDockedSizes: TList; {items are pointers to TDockedSizes}
MouseOverDock: TPCDock;
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 := TPCDock(MouseOverDock).GetRowOf(C, Before);
if Before then
TPCDock(MouseOverDock).InsertRowBefore (NewDockRow);
FDockRow := NewDockRow;
if not(MouseOverDock.Position in PositionLeftOrRight) then
FDockPos := MoveRectClient.Left
else
FDockPos := MoveRectClient.Top;
DockedTo := MouseOverDock;
end
else begin
FFloatingRect := MoveRect;
DockedTo := nil;
end;
{ Make sure it doesn't go completely off the screen }
MoveOnScreen (True);
end;
procedure MouseMoved;
var
OldMouseOverDock: TPCDock;
OldMoveRect: TRect;
Pos: TPoint;
function CheckIfCanDockTo (Control: TPCDock): 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;
I: Integer;
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 begin
{ Try top/bottom first }
for I := 0 to ComponentCount-1 do
if (Components[I] is TPCDock) and
not(TPCDock(Components[I]).Position in PositionLeftOrRight) and
TPCDock(Components[I]).FAllowDrag and
CheckIfCanDockTo(TPCDock(Components[I])) then begin
MouseOverDock := TPCDock(Components[I]);
Break;
end;
{ Then left/right }
if (MouseOverDock = nil) and (FCanDockLeftRight) then
for I := 0 to ComponentCount-1 do
if (Components[I] is TPCDock) and
(TPCDock(Components[I]).Position in PositionLeftOrRight) and
TPCDock(Components[I]).FAllowDrag and
CheckIfCanDockTo(TPCDock(Components[I])) then begin
MouseOverDock := TPCDock(Components[I]);
Break;
end;
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;
InflateRect (R, -(GetBorderSize+4), -(GetBorderSize+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);
end;
{ Update the dragging outline }
DrawDraggingOutline (ScreenDC, @MoveRect, @OldMoveRect, MouseOverDock <> nil,
OldMouseOverDock <> nil);
end;
var
Accept: Boolean;
DT: TDockType;
R: TRect;
SaveShowHint: Boolean;
Msg: TMsg;
NewDockedSize: PDockedSize;
I: Integer;
begin
Accept := False;
NPoint := Point(InitX, InitY);
if DockedTo = nil then begin
{ Adjust for non-client area }
NPoint := ClientToScreen(NPoint);
Dec (NPoint.X, Left);
Dec (NPoint.Y, Top);
end;
DPoint := Point(Width-1, Height-1);
PreventDocking := GetKeyState(VK_CONTROL) < 0;
{ Set up potential sizes for each dock type }
NewDockedSizes := TList.Create;
try
DT := GetDockTypeOf(DockedTo);
SetRectEmpty (R);
ArrangeControls (False, False, DT, nil, FFloatingRightX, @R.BottomRight);
AddNCAreaToRect (R);
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 TPCDock) then Continue;
New (NewDockedSize);
try
with NewDockedSize^ do begin
Dock := TPCDock(Components[I]);
if Components[I] <> DockedTo then
ArrangeControls (False, False, DT, TPCDock(Components[I]), FFloatingRightX, @Size)
else
Size := Self.ClientRect.BottomRight;
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
{ Hints must be disabled while dragging or it can mess up ScreenDC.
Previous value is of Application.ShowHint is restored when done moving }
SaveShowHint := Application.ShowHint;
Application.ShowHint := False;
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 }
if (Msg.WParam = VK_CONTROL) and
(PreventDocking <> (Msg.Message = WM_KEYDOWN)) then begin
PreventDocking := Msg.Message = WM_KEYDOWN;
MouseMoved;
end;
WM_MOUSEMOVE:
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;
Application.ShowHint := SaveShowHint;
end;
finally
{ 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 begin
Dispose (PDockedSize(NewDockedSizes[I]));
NewDockedSizes.Delete (I);
end;
NewDockedSizes.Free;
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 TPCOfficeBar.BeginSizing (const HitTestValue: Integer);
var
NewSizes: TList; { List of valid new sizes. Items are casted into TSmallPoints }
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;
AddNCAreaToRect (R);
OffsetRect (R, -R.Left, -R.Top);
Result := R.BottomRight;
end;
var
DT: TDockType;
Max, X, LastY, SkipTo: Integer;
S, S2: TPoint;
begin
DT := GetDockTypeOf(DockedTo);
ArrangeControls (False, False, DT, nil, 0, @S);
S2 := AddNCAreaToSize(S);
NewSizes.Add (Pointer(PointToSmallPoint(S2)));
LastY := S.Y;
Max := S.X;
SkipTo := High(SkipTo);
for X := Max-1 downto LeftMargin[True, dtNotDocked]+FBarWidth+RightMargin[dtNotDocked] do begin
if X > SkipTo then Continue;
ArrangeControls (False, False, DT, nil, X, @S);
if X = S.X then begin
if S.Y = LastY then
NewSizes.Delete (NewSizes.Count-1);
S2 := AddNCAreaToSize(S);
if NewSizes.IndexOf(Pointer(PointToSmallPoint(S2))) = -1 then
NewSizes.Add (Pointer(PointToSmallPoint(S2)));
LastY := S.Y;
end
else
SkipTo := S.X;
end;
ListSortEx (NewSizes, CompareNewSizes, Pointer(Longint(YOrdering)));
end;
var
DragRect, OrigDragRect: TRect;
CurRightX: Integer;
ScreenDC: HDC;
DisableSensCheck, OpSide: Boolean;
SizeSens: Integer;
procedure MouseMoved;
var
Pos: TPoint;
NCXDiff: Integer;
NewOpSide: Boolean;
OldDragRect: TRect;
Reverse: Boolean;
I: Integer;
P: TSmallPoint;
begin
GetCursorPos (Pos);
NCXDiff := ClientToScreen(Point(0, 0)).X - Left;
Dec (Pos.X, Left); Dec (Pos.Y, Top);
if HitTestValue = HTLEFT then
Pos.X := Width-Pos.X
else
if HitTestValue = HTTOP then
Pos.Y := Height-Pos.Y;
{ Adjust Pos to make up for the "sizing sensitivity", as seen in Office 97 }
if HitTestValue 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 HitTestValue 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;
OldDragRect := DragRect;
if HitTestValue 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 HitTestValue 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
CurRightX := P.X - NCXDiff;
if HitTestValue = HTRIGHT then
DragRect.Right := DragRect.Left + P.X
else
DragRect.Left := DragRect.Right - P.X;
DragRect.Bottom := DragRect.Top + P.Y;
DisableSensCheck := not EqualRect(DragRect, OrigDragRect);
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
CurRightX := P.X - NCXDiff;
if HitTestValue = HTBOTTOM then
DragRect.Bottom := DragRect.Top + P.Y
else
DragRect.Top := DragRect.Bottom - P.Y;
DragRect.Right := DragRect.Left + P.X;
DisableSensCheck := not EqualRect(DragRect, OrigDragRect);
end;
end;
if not Reverse then
Dec (I)
else
Inc (I);
end;
{ Update the dragging outline, only if changed }
if not EqualRect(DragRect, OldDragRect) then
DrawDraggingOutline (ScreenDC, @DragRect, @OldDragRect, False, False);
end;
const
MaxSizeSens = 12;
var
Accept: Boolean;
I, NewSize: Integer;
S, N: TSmallPoint;
SaveShowHint: Boolean;
Msg: TMsg;
begin
Accept := False;
CurRightX := FFloatingRightX;
DisableSensCheck := False;
OpSide := False;
NewSizes := TList.Create;
try
{ Initialize }
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;
DragRect := GetVirtualBoundsRect;
OrigDragRect := DragRect;
{ 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
{ Hints must be disabled while dragging or it can mess up ScreenDC.
Previous value is of Application.ShowHint is restored when done moving }
SaveShowHint := Application.ShowHint;
Application.ShowHint := False;
try
SetCapture (Handle);
{ Initialize }
DrawDraggingOutline (ScreenDC, @DragRect, nil, False, False);
{ 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 }
;
WM_MOUSEMOVE:
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;
Application.ShowHint := SaveShowHint;
end;
finally
{ 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
NewSizes.Free;
end;
if Accept then begin
FFloatingRightX := CurRightX;
FFloatingRect := DragRect;
SetVirtualBoundsRect (FFloatingRect);
AutoArrangeControls;
{ Make sure it doesn't go completely off the screen }
MoveOnScreen (True);
end;
end;
procedure TPCOfficeBar.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 TPCSep) and Controls[I].Visible and
PtInRect(Controls[I].BoundsRect, P) then begin
Result := True;
Break;
end;
end;
begin
inherited MouseDown (Button, Shift, X, Y);
if (Button <> mbLeft) or
{ Only process if AllowDrag is True }
((DockedTo <> nil) and (not DockedTo.FAllowDrag)) or
{ Ignore message if user clicked on a child control that was probably
disabled }
ControlExistsAtPos(Point(X, Y)) then
Exit;
{ Handle double click }
if ssDouble in Shift then begin
if DockedTo <> nil then
DockedTo := nil
else begin
FDockRow := ForceDockAtTopRow;
FDockPos := ForceDockAtLeftPos;
DockedTo := DefaultDock;
end;
Exit;
end;
BeginMoving (X, Y);
end;
procedure TPCOfficeBar.WMNCHitTest (var Message: TWMNCHitTest);
var
P: TPoint;
begin
inherited;
if DockedTo <> nil then Exit;
with Message do begin
P := SmallPointToPoint(Pos);
Dec (P.X, Left); Dec (P.Y, Top);
case Result of
HTNOWHERE: begin
if PtInRect(GetCaptionRect(Self, True, False), P) then begin
Result := HTCLIENT;
if FCloseButton and PtInRect(GetCloseButtonRect(Self, True), P) then
Result := HTCLOSE;
end
else
if (P.Y >= 0) and (P.Y <= GetBorderSize) then Result := HTTOP else
if (P.Y < Height) and (P.Y >= Height-GetBorderSize-1) then Result := HTBOTTOM else
if (P.X >= 0) and (P.X <= GetBorderSize) then Result := HTLEFT else
if (P.X < Width) and (P.X >= Width-GetBorderSize-1) then Result := HTRIGHT;
end;
end;
end;
end;
procedure TPCOfficeBar.WMNCLButtonDown (var Message: TWMNCLButtonDown);
procedure CloseButtonLoop;
var
Accept, NewCloseButtonDown: Boolean;
P: TPoint;
Msg: TMsg;
begin
Accept := False;
CloseButtonDown := True;
DrawNCArea (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
GetCursorPos (P);
Dec (P.X, Left); Dec (P.Y, Top);
NewCloseButtonDown := PtInRect(GetCloseButtonRect(Self, True), P);
if CloseButtonDown <> NewCloseButtonDown then begin
CloseButtonDown := NewCloseButtonDown;
DrawNCArea (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;
DrawNCArea (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;
begin
if DockedTo <> nil then begin
inherited;
Exit;
end;
case Message.HitTest of
HTLEFT, HTRIGHT, HTTOP, HTBOTTOM:
BeginSizing (Message.HitTest);
HTCLOSE:
CloseButtonLoop;
else
inherited;
end;
end;
procedure TPCOfficeBar.NewFormWindowProc (var Message: TMessage);
{ This procedure is only used on MDI parents or non-MDI forms }
begin
case Message.Msg of
WM_ACTIVATE, WM_SETFOCUS:
{ Prevent re-focus of toolbar
Note to self: Must process WM_ACTIVATE too so that it correctly
activates the form when it was deactivated }
if GetParenTPCOfficeBar(MDIParentForm.ActiveControl) <> nil then
Exit;
WM_WINDOWPOSCHANGED:
{ This must be here so the toolbars reappear when the form is
restored after being minimized }
ShowHideFloatParents (MDIParentForm, Application.Active);
end;
with Message do
Result := CallWindowProc(OldFormWindowProc, MDIParentForm.Handle,
Msg, WParam, LParam);
end;
procedure TPCOfficeBar.NewChildFormWindowProc (var Message: TMessage);
{ This procedure is only used on MDI child forms }
begin
case Message.Msg of
WM_WINDOWPOSCHANGED:
{ This must be here so the toolbars reappear when the form is
restored after being minimized }
ShowHideFloatParents (TForm(Owner), Application.Active);
end;
with Message do
Result := CallWindowProc(OldChildFormWindowProc, TForm(Owner).Handle,
Msg, WParam, LParam);
end;
function TPCOfficeBar.NewMainWindowHook (var Message: TMessage): Boolean;
var
T: TPCOfficeBar;
begin
Result := False;
case Message.Msg of
CM_ACTIVATE, CM_DEACTIVATE: begin
{ When application is being activated, make sure it doesn't try to
reactivate a floating toolbar. If this isn't here the form may not
appear when application is activated }
if (Message.Msg = CM_ACTIVATE) and
ControlIsChildOf(Screen.ActiveControl, MDIParentForm) then begin
T := GetParenTPCOfficeBar(Screen.ActiveControl);
if Assigned(T) and (T.DockedTo = nil) then
{ Activate the owner form instead }
Windows.SetActiveWindow (MDIParentForm.Handle);
end;
{ Hide or restore toolbars when application is deactivated or activated }
ShowHideFloatParents (MDIParentForm, Message.Msg = CM_ACTIVATE);
{ Correct the color of the form's caption. }
SendMessage (TForm(Owner).Handle, WM_NCACTIVATE, Ord((Message.Msg = CM_ACTIVATE) and
(FindControl(GetActiveWindow) = MDIParentForm)), 0);
end;
end;
end;
{ TPCOfficeBar - property access methods }
procedure TPCOfficeBar.SetCloseButton (Value: Boolean);
begin
if FCloseButton <> Value then begin
FCloseButton := Value;
{ Update the close button's visibility }
DrawNCArea (0, False, True, True);
end;
end;
procedure TPCOfficeBar.SetDefaultDock (Value: TPCDock);
begin
if FDefaultDock <> Value then begin
FDefaultDock := Value;
if Assigned(Value) then
Value.FreeNotification (Self);
end;
end;
function TPCOfficeBar.GetDockedTo: TPCDock;
begin
if not(Parent is TPCDock) then
Result := nil
else
Result := TPCDock(Parent);
end;
procedure TPCOfficeBar.SetDockedTo (Value: TPCDock);
var
OldDockedTo: TPCDock;
HiddenInced: Boolean;
begin
OldDockedTo := DockedTo;
if Assigned(FOnDockChanging) and (Value <> OldDockedTo) then
FOnDockChanging (Self);
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 (Hidden);
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
ArrangeControls (True, False, GetDockTypeOf(OldDockedTo),
Value, FFloatingRightX, nil);
if Parent <> Value then begin
Inc (DisableArrangeControls);
try
Parent := Value;
finally
Dec (DisableArrangeControls);
end;
end;
AutoArrangeControls;
end
else begin
if IsRectEmpty(FFloatingRect) then begin
FFloatingRect := GetVirtualBoundsRect;
AddNCAreaToRect (FFloatingRect);
OffsetRect (FFloatingRect, -FFloatingRect.Left, -FFloatingRect.Top);
end;
{ Must pre-arrange controls in new dock orientation before changing
the Parent }
if Parent <> nil then
ArrangeControls (True, False, GetDockTypeOf(OldDockedTo),
Value, FFloatingRightX, nil);
Inc (DisableArrangeControls);
try
if Parent <> FloatParent then
Parent := FloatParent;
SetVirtualBoundsRect (FFloatingRect);
finally
Dec (DisableArrangeControls);
end;
AutoArrangeControls;
end;
finally
if HiddenInced then begin
Dec (Hidden);
Show;
end;
end;
finally
if Assigned(Value) then
Dec (Value.DisableArrangeToolbars);
end;
if Assigned(Value) then
Value.ArrangeToolbars;
if Assigned(FOnDockChanged) and (Value <> OldDockedTo) then
FOnDockChanged (Self);
end;
procedure TPCOfficeBar.SetDockPos (Value: Integer);
begin
FDockPos := Value;
if DockedTo <> nil then
DockedTo.ArrangeToolbars;
end;
procedure TPCOfficeBar.SetDockRow (Value: Integer);
begin
FDockRow := Value;
if DockedTo <> nil then
DockedTo.ArrangeToolbars;
end;
{ TPCSep - internal }
constructor TPCSep.Create (AOwner: TComponent);
begin
inherited Create (AOwner);
FSizeHorz := 6;
FSizeVert := 6;
ControlStyle := ControlStyle - [csOpaque, csCaptureMouse];
end;
procedure TPCSep.SetParent (AParent: TWinControl);
begin
if (AParent <> nil) and not(AParent is TPCOfficeBar) then
raise EInvalidOperation.Create(STB97SepParentNotAllowed);
inherited SetParent (AParent);
end;
procedure TPCSep.SetBlank (Value: Boolean);
begin
if FBlank <> Value then begin
FBlank := Value;
Invalidate;
end;
end;
procedure TPCSep.SetSizeHorz (Value: TToolbarSepSize);
begin
if FSizeHorz <> Value then begin
FSizeHorz := Value;
if Parent is TPCOfficeBar then
TPCOfficeBar(Parent).AutoArrangeControls;
end;
end;
procedure TPCSep.SetSizeVert (Value: TToolbarSepSize);
begin
if FSizeVert <> Value then begin
FSizeVert := Value;
if Parent is TPCOfficeBar then
TPCOfficeBar(Parent).AutoArrangeControls;
end;
end;
procedure TPCSep.Paint;
var
R: TRect;
Z: Integer;
begin
inherited Paint;
if not(Parent is TPCOfficeBar) 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(TPCOfficeBar(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 TPCSep.MouseDown (Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
var
P: TPoint;
begin
inherited MouseDown (Button, Shift, X, Y);
{ Relay the message to the parent toolbar }
P := Parent.ScreenToClient(ClientToScreen(Point(X, Y)));
TPCOfficeBar(Parent).MouseDown (Button, Shift, P.X, P.Y);
end;
initialization
UsedForms := TList.Create;
ButtonMouseTimer := TTimer.Create(nil);
ButtonMouseTimer.Enabled := False;
ButtonMouseTimer.Interval := 125; { 8 times a second }
finalization
if Assigned(ButtonMouseTimer) then ButtonMouseTimer.Free;
if Assigned(UsedForms) then UsedForms.Free;
end.
Reference in New Issue View Git Blame Copy Permalink