home *** CD-ROM | disk | FTP | other *** search
/ Delphi Anthology / aDELPHI.iso / Runimage / Delphi50 / Source / Vcl / extctrls.pas < prev    next >
Pascal/Delphi Source File  |  1999-08-11  |  121KB  |  4,301 lines
  1.  
  2. {*******************************************************}
  3. {                                                       }
  4. {       Borland Delphi Visual Component Library         }
  5. {                                                       }
  6. {       Copyright (c) 1995,99 Inprise Corporation       }
  7. {                                                       }
  8. {*******************************************************}
  9.  
  10. unit ExtCtrls;
  11.  
  12. {$S-,W-,R-,H+,X+}
  13. {$C PRELOAD}
  14.  
  15. interface
  16.  
  17. uses Messages, Windows, SysUtils, Classes, Controls, Forms, Menus, Graphics,
  18.   StdCtrls;
  19.  
  20. type
  21.  
  22.   TShapeType = (stRectangle, stSquare, stRoundRect, stRoundSquare,
  23.     stEllipse, stCircle);
  24.  
  25.   TShape = class(TGraphicControl)
  26.   private
  27.     FPen: TPen;
  28.     FBrush: TBrush;
  29.     FShape: TShapeType;
  30.     procedure SetBrush(Value: TBrush);
  31.     procedure SetPen(Value: TPen);
  32.     procedure SetShape(Value: TShapeType);
  33.   protected
  34.     procedure Paint; override;
  35.   public
  36.     constructor Create(AOwner: TComponent); override;
  37.     destructor Destroy; override;
  38.   published
  39.     procedure StyleChanged(Sender: TObject);
  40.     property Align;
  41.     property Anchors;
  42.     property Brush: TBrush read FBrush write SetBrush;
  43.     property DragCursor;
  44.     property DragKind;
  45.     property DragMode;
  46.     property Enabled;
  47.     property Constraints;
  48.     property ParentShowHint;
  49.     property Pen: TPen read FPen write SetPen;
  50.     property Shape: TShapeType read FShape write SetShape default stRectangle;
  51.     property ShowHint;
  52.     property Visible;
  53.     property OnContextPopup;
  54.     property OnDragDrop;
  55.     property OnDragOver;
  56.     property OnEndDock;
  57.     property OnEndDrag;
  58.     property OnMouseDown;
  59.     property OnMouseMove;
  60.     property OnMouseUp;
  61.     property OnStartDock;
  62.     property OnStartDrag;
  63.   end;
  64.  
  65.   TPaintBox = class(TGraphicControl)
  66.   private
  67.     FOnPaint: TNotifyEvent;
  68.   protected
  69.     procedure Paint; override;
  70.   public
  71.     constructor Create(AOwner: TComponent); override;
  72.     property Canvas;
  73.   published
  74.     property Align;
  75.     property Anchors;
  76.     property Color;
  77.     property Constraints;
  78.     property DragCursor;
  79.     property DragKind;
  80.     property DragMode;
  81.     property Enabled;
  82.     property Font;
  83.     property ParentColor;
  84.     property ParentFont;
  85.     property ParentShowHint;
  86.     property PopupMenu;
  87.     property ShowHint;
  88.     property Visible;
  89.     property OnClick;
  90.     property OnContextPopup;
  91.     property OnDblClick;
  92.     property OnDragDrop;
  93.     property OnDragOver;
  94.     property OnEndDock;
  95.     property OnEndDrag;
  96.     property OnMouseDown;
  97.     property OnMouseMove;
  98.     property OnMouseUp;
  99.     property OnPaint: TNotifyEvent read FOnPaint write FOnPaint;
  100.     property OnStartDock;
  101.     property OnStartDrag;
  102.   end;
  103.  
  104.   TImage = class(TGraphicControl)
  105.   private
  106.     FPicture: TPicture;
  107.     FOnProgress: TProgressEvent;
  108.     FStretch: Boolean;
  109.     FCenter: Boolean;
  110.     FIncrementalDisplay: Boolean;
  111.     FTransparent: Boolean;
  112.     FDrawing: Boolean;
  113.     function GetCanvas: TCanvas;
  114.     procedure PictureChanged(Sender: TObject);
  115.     procedure SetCenter(Value: Boolean);
  116.     procedure SetPicture(Value: TPicture);
  117.     procedure SetStretch(Value: Boolean);
  118.     procedure SetTransparent(Value: Boolean);
  119.   protected
  120.     function CanAutoSize(var NewWidth, NewHeight: Integer): Boolean; override;
  121.     function DestRect: TRect;
  122.     function DoPaletteChange: Boolean;
  123.     function GetPalette: HPALETTE; override;
  124.     procedure Paint; override;
  125.     procedure Progress(Sender: TObject; Stage: TProgressStage;
  126.       PercentDone: Byte; RedrawNow: Boolean; const R: TRect; const Msg: string); dynamic;
  127.   public
  128.     constructor Create(AOwner: TComponent); override;
  129.     destructor Destroy; override;
  130.     property Canvas: TCanvas read GetCanvas;
  131.   published
  132.     property Align;
  133.     property Anchors;
  134.     property AutoSize;
  135.     property Center: Boolean read FCenter write SetCenter default False;
  136.     property Constraints;
  137.     property DragCursor;
  138.     property DragKind;
  139.     property DragMode;
  140.     property Enabled;
  141.     property IncrementalDisplay: Boolean read FIncrementalDisplay write FIncrementalDisplay default False;
  142.     property ParentShowHint;
  143.     property Picture: TPicture read FPicture write SetPicture;
  144.     property PopupMenu;
  145.     property ShowHint;
  146.     property Stretch: Boolean read FStretch write SetStretch default False;
  147.     property Transparent: Boolean read FTransparent write SetTransparent default False;
  148.     property Visible;
  149.     property OnClick;
  150.     property OnContextPopup;
  151.     property OnDblClick;
  152.     property OnDragDrop;
  153.     property OnDragOver;
  154.     property OnEndDock;
  155.     property OnEndDrag;
  156.     property OnMouseDown;
  157.     property OnMouseMove;
  158.     property OnMouseUp;
  159.     property OnProgress: TProgressEvent read FOnProgress write FOnProgress;
  160.     property OnStartDock;
  161.     property OnStartDrag;
  162.   end;
  163.  
  164.   TBevelStyle = (bsLowered, bsRaised);
  165.   TBevelShape = (bsBox, bsFrame, bsTopLine, bsBottomLine, bsLeftLine,
  166.     bsRightLine, bsSpacer);
  167.  
  168.   TBevel = class(TGraphicControl)
  169.   private
  170.     FStyle: TBevelStyle;
  171.     FShape: TBevelShape;
  172.     procedure SetStyle(Value: TBevelStyle);
  173.     procedure SetShape(Value: TBevelShape);
  174.   protected
  175.     procedure Paint; override;
  176.   public
  177.     constructor Create(AOwner: TComponent); override;
  178.   published
  179.     property Align;
  180.     property Anchors;
  181.     property Constraints;
  182.     property ParentShowHint;
  183.     property Shape: TBevelShape read FShape write SetShape default bsBox;
  184.     property ShowHint;
  185.     property Style: TBevelStyle read FStyle write SetStyle default bsLowered;
  186.     property Visible;
  187.   end;
  188.  
  189.   TTimer = class(TComponent)
  190.   private
  191.     FInterval: Cardinal;
  192.     FWindowHandle: HWND;
  193.     FOnTimer: TNotifyEvent;
  194.     FEnabled: Boolean;
  195.     procedure UpdateTimer;
  196.     procedure SetEnabled(Value: Boolean);
  197.     procedure SetInterval(Value: Cardinal);
  198.     procedure SetOnTimer(Value: TNotifyEvent);
  199.     procedure WndProc(var Msg: TMessage);
  200.   protected
  201.     procedure Timer; dynamic;
  202.   public
  203.     constructor Create(AOwner: TComponent); override;
  204.     destructor Destroy; override;
  205.   published
  206.     property Enabled: Boolean read FEnabled write SetEnabled default True;
  207.     property Interval: Cardinal read FInterval write SetInterval default 1000;
  208.     property OnTimer: TNotifyEvent read FOnTimer write SetOnTimer;
  209.   end;
  210.  
  211.   TPanelBevel = TBevelCut;
  212.  
  213.   TCustomPanel = class(TCustomControl)
  214.   private
  215.     FAutoSizeDocking: Boolean;
  216.     FBevelInner: TPanelBevel;
  217.     FBevelOuter: TPanelBevel;
  218.     FBevelWidth: TBevelWidth;
  219.     FBorderWidth: TBorderWidth;
  220.     FBorderStyle: TBorderStyle;
  221.     FFullRepaint: Boolean;
  222.     FLocked: Boolean;
  223.     FAlignment: TAlignment;
  224.     procedure CMBorderChanged(var Message: TMessage); message CM_BORDERCHANGED;
  225.     procedure CMTextChanged(var Message: TMessage); message CM_TEXTCHANGED;
  226.     procedure CMCtl3DChanged(var Message: TMessage); message CM_CTL3DCHANGED;
  227.     procedure CMIsToolControl(var Message: TMessage); message CM_ISTOOLCONTROL;
  228.     procedure WMWindowPosChanged(var Message: TWMWindowPosChanged); message WM_WINDOWPOSCHANGED;
  229.     procedure SetAlignment(Value: TAlignment);
  230.     procedure SetBevelInner(Value: TPanelBevel);
  231.     procedure SetBevelOuter(Value: TPanelBevel);
  232.     procedure SetBevelWidth(Value: TBevelWidth);
  233.     procedure SetBorderWidth(Value: TBorderWidth);
  234.     procedure SetBorderStyle(Value: TBorderStyle);
  235.     procedure CMDockClient(var Message: TCMDockClient); message CM_DOCKCLIENT;
  236.   protected
  237.     procedure CreateParams(var Params: TCreateParams); override;
  238.     procedure AdjustClientRect(var Rect: TRect); override;
  239.     function CanAutoSize(var NewWidth, NewHeight: Integer): Boolean; override;
  240.     procedure Paint; override;
  241.     property Alignment: TAlignment read FAlignment write SetAlignment default taCenter;
  242.     property BevelInner: TPanelBevel read FBevelInner write SetBevelInner default bvNone;
  243.     property BevelOuter: TPanelBevel read FBevelOuter write SetBevelOuter default bvRaised;
  244.     property BevelWidth: TBevelWidth read FBevelWidth write SetBevelWidth default 1;
  245.     property BorderWidth: TBorderWidth read FBorderWidth write SetBorderWidth default 0;
  246.     property BorderStyle: TBorderStyle read FBorderStyle write SetBorderStyle default bsNone;
  247.     property Color default clBtnFace;
  248.     property FullRepaint: Boolean read FFullRepaint write FFullRepaint default True;
  249.     property Locked: Boolean read FLocked write FLocked default False;
  250.     property ParentColor default False;
  251.   public
  252.     constructor Create(AOwner: TComponent); override;
  253.     function GetControlsAlignment: TAlignment; override;
  254.   end;
  255.  
  256.   TPanel = class(TCustomPanel)
  257.   public
  258.     property DockManager;
  259.   published
  260.     property Align;
  261.     property Alignment;
  262.     property Anchors;
  263.     property AutoSize;
  264.     property BevelInner;
  265.     property BevelOuter;
  266.     property BevelWidth;
  267.     property BiDiMode;
  268.     property BorderWidth;
  269.     property BorderStyle;
  270.     property Caption;
  271.     property Color;
  272.     property Constraints;
  273.     property Ctl3D;
  274.     property UseDockManager default True;
  275.     property DockSite;
  276.     property DragCursor;
  277.     property DragKind;
  278.     property DragMode;
  279.     property Enabled;
  280.     property FullRepaint;
  281.     property Font;
  282.     property Locked;
  283.     property ParentBiDiMode;
  284.     property ParentColor;
  285.     property ParentCtl3D;
  286.     property ParentFont;
  287.     property ParentShowHint;
  288.     property PopupMenu;
  289.     property ShowHint;
  290.     property TabOrder;
  291.     property TabStop;
  292.     property Visible;
  293.     property OnCanResize;
  294.     property OnClick;
  295.     property OnConstrainedResize;
  296.     property OnContextPopup;
  297.     property OnDockDrop;
  298.     property OnDockOver;
  299.     property OnDblClick;
  300.     property OnDragDrop;
  301.     property OnDragOver;
  302.     property OnEndDock;
  303.     property OnEndDrag;
  304.     property OnEnter;
  305.     property OnExit;
  306.     property OnGetSiteInfo;
  307.     property OnMouseDown;
  308.     property OnMouseMove;
  309.     property OnMouseUp;
  310.     property OnResize;
  311.     property OnStartDock;
  312.     property OnStartDrag;
  313.     property OnUnDock;
  314.   end;
  315.  
  316.   TPage = class(TCustomControl)
  317.   private
  318.     procedure WMNCHitTest(var Message: TWMNCHitTest); message WM_NCHITTEST;
  319.   protected
  320.     procedure ReadState(Reader: TReader); override;
  321.     procedure Paint; override;
  322.   public
  323.     constructor Create(AOwner: TComponent); override;
  324.   published
  325.     property Caption;
  326.     property Height stored False;
  327.     property TabOrder stored False;
  328.     property Visible stored False;
  329.     property Width stored False;
  330.   end;
  331.  
  332.   TNotebook = class(TCustomControl)
  333.   private
  334.     FPageList: TList;
  335.     FAccess: TStrings;
  336.     FPageIndex: Integer;
  337.     FOnPageChanged: TNotifyEvent;
  338.     procedure SetPages(Value: TStrings);
  339.     procedure SetActivePage(const Value: string);
  340.     function GetActivePage: string;
  341.     procedure SetPageIndex(Value: Integer);
  342.   protected
  343.     procedure CreateParams(var Params: TCreateParams); override;
  344.     function GetChildOwner: TComponent; override;
  345.     procedure GetChildren(Proc: TGetChildProc; Root: TComponent); override;
  346.     procedure ReadState(Reader: TReader); override;
  347.     procedure ShowControl(AControl: TControl); override;
  348.   public
  349.     constructor Create(AOwner: TComponent); override;
  350.     destructor Destroy; override;
  351.   published
  352.     property ActivePage: string read GetActivePage write SetActivePage stored False;
  353.     property Align;
  354.     property Anchors;
  355.     property Color;
  356.     property Ctl3D;
  357.     property DragCursor;
  358.     property DragKind;
  359.     property DragMode;
  360.     property Font;
  361.     property Enabled;
  362.     property Constraints;
  363.     property PageIndex: Integer read FPageIndex write SetPageIndex default 0;
  364.     property Pages: TStrings read FAccess write SetPages stored False;
  365.     property ParentColor;
  366.     property ParentCtl3D;
  367.     property ParentFont;
  368.     property ParentShowHint;
  369.     property PopupMenu;
  370.     property ShowHint;
  371.     property TabOrder;
  372.     property TabStop;
  373.     property Visible;
  374.     property OnClick;
  375.     property OnContextPopup;
  376.     property OnDblClick;
  377.     property OnDragDrop;
  378.     property OnDragOver;
  379.     property OnEndDock;
  380.     property OnEndDrag;
  381.     property OnEnter;
  382.     property OnExit;
  383.     property OnMouseDown;
  384.     property OnMouseMove;
  385.     property OnMouseUp;
  386.     property OnPageChanged: TNotifyEvent read FOnPageChanged write FOnPageChanged;
  387.     property OnStartDock;
  388.     property OnStartDrag;
  389.   end;
  390.  
  391. { THeader
  392.   Purpose  - Creates sectioned visual header that allows each section to be
  393.              resized with the mouse.
  394.   Features - This is a design-interactive control.  In design mode, the
  395.              sections are named using the string-list editor.  Each section
  396.              can now be manually resized using the right mouse button the grab
  397.              the divider and drag to the new size.  Changing the section list
  398.              at design (or even run-time), will attempt to maintain the
  399.              section widths for sections that have not been changed.
  400.   Properties:
  401.     Align - Standard property.
  402.     AllowResize - If True, the control allows run-time mouse resizing of the
  403.                   sections.
  404.     BorderStyle - Turns the border on and off.
  405.     Font - Standard property.
  406.     Sections - A special string-list that contains the section text.
  407.     ParentFont - Standard property.
  408.     OnSizing - Event called for each mouse move during a section resize
  409.                operation.
  410.     OnSized - Event called once the size operation is complete.
  411.  
  412.     SectionWidth - Array property allowing run-time getting and setting of
  413.                    each section's width. }
  414.  
  415.   TSectionEvent = procedure(Sender: TObject;
  416.     ASection, AWidth: Integer) of object;
  417.  
  418.   THeader = class(TCustomControl)
  419.   private
  420.     FSections: TStrings;
  421.     FHitTest: TPoint;
  422.     FCanResize: Boolean;
  423.     FAllowResize: Boolean;
  424.     FBorderStyle: TBorderStyle;
  425.     FResizeSection: Integer;
  426.     FMouseOffset: Integer;
  427.     FOnSizing: TSectionEvent;
  428.     FOnSized: TSectionEvent;
  429.     procedure SetBorderStyle(Value: TBorderStyle);
  430.     procedure FreeSections;
  431.     procedure SetSections(Strings: TStrings);
  432.     function GetWidth(X: Integer): Integer;
  433.     procedure SetWidth(X: Integer; Value: Integer);
  434.     procedure WMSetCursor(var Msg: TWMSetCursor); message WM_SETCURSOR;
  435.     procedure WMNCHitTest(var Msg: TWMNCHitTest); message WM_NCHITTEST;
  436.     procedure WMSize(var Msg: TWMSize); message WM_SIZE;
  437.   protected
  438.     procedure Paint; override;
  439.     procedure CreateParams(var Params: TCreateParams); override;
  440.     procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
  441.       X, Y: Integer); override;
  442.     procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
  443.     procedure MouseUp(Button: TMouseButton; Shift: TShiftState;
  444.       X, Y: Integer); override;
  445.     procedure Sizing(ASection, AWidth: Integer); dynamic;
  446.     procedure Sized(ASection, AWidth: Integer); dynamic;
  447.   public
  448.     constructor Create(AOwner: TComponent); override;
  449.     destructor Destroy; override;
  450.     property SectionWidth[X: Integer]: Integer read GetWidth write SetWidth;
  451.   published
  452.     property Align;
  453.     property AllowResize: Boolean read FAllowResize write FAllowResize default True;
  454.     property Anchors;
  455.     property BorderStyle: TBorderStyle read FBorderStyle write SetBorderStyle default bsSingle;
  456.     property Constraints;
  457.     property Enabled;
  458.     property Font;
  459.     property ParentFont;
  460.     property ParentShowHint;
  461.     property PopupMenu;
  462.     property Sections: TStrings read FSections write SetSections;
  463.     property ShowHint;
  464.     property TabOrder;
  465.     property TabStop;
  466.     property Visible;
  467.     property OnContextPopup;
  468.     property OnSizing: TSectionEvent read FOnSizing write FOnSizing;
  469.     property OnSized: TSectionEvent read FOnSized write FOnSized;
  470.   end;
  471.  
  472.   TCustomRadioGroup = class(TCustomGroupBox)
  473.   private
  474.     FButtons: TList;
  475.     FItems: TStrings;
  476.     FItemIndex: Integer;
  477.     FColumns: Integer;
  478.     FReading: Boolean;
  479.     FUpdating: Boolean;
  480.     procedure ArrangeButtons;
  481.     procedure ButtonClick(Sender: TObject);
  482.     procedure ItemsChange(Sender: TObject);
  483.     procedure SetButtonCount(Value: Integer);
  484.     procedure SetColumns(Value: Integer);
  485.     procedure SetItemIndex(Value: Integer);
  486.     procedure SetItems(Value: TStrings);
  487.     procedure UpdateButtons;
  488.     procedure CMEnabledChanged(var Message: TMessage); message CM_ENABLEDCHANGED;
  489.     procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
  490.     procedure WMSize(var Message: TWMSize); message WM_SIZE;
  491.   protected
  492.     procedure Loaded; override;
  493.     procedure ReadState(Reader: TReader); override;
  494.     function CanModify: Boolean; virtual;
  495.     procedure GetChildren(Proc: TGetChildProc; Root: TComponent); override;
  496.     property Columns: Integer read FColumns write SetColumns default 1;
  497.     property ItemIndex: Integer read FItemIndex write SetItemIndex default -1;
  498.     property Items: TStrings read FItems write SetItems;
  499.   public
  500.     constructor Create(AOwner: TComponent); override;
  501.     destructor Destroy; override;
  502.     procedure FlipChildren(AllLevels: Boolean); override;
  503.   end;
  504.  
  505.   TRadioGroup = class(TCustomRadioGroup)
  506.   published
  507.     property Align;
  508.     property Anchors;
  509.     property BiDiMode;
  510.     property Caption;
  511.     property Color;
  512.     property Columns;
  513.     property Ctl3D;
  514.     property DragCursor;
  515.     property DragKind;
  516.     property DragMode;
  517.     property Enabled;
  518.     property Font;
  519.     property ItemIndex;
  520.     property Items;
  521.     property Constraints;
  522.     property ParentBiDiMode;
  523.     property ParentColor;
  524.     property ParentCtl3D;
  525.     property ParentFont;
  526.     property ParentShowHint;
  527.     property PopupMenu;
  528.     property ShowHint;
  529.     property TabOrder;
  530.     property TabStop;
  531.     property Visible;
  532.     property OnClick;
  533.     property OnContextPopup;
  534.     property OnDragDrop;
  535.     property OnDragOver;
  536.     property OnEndDock;
  537.     property OnEndDrag;
  538.     property OnEnter;
  539.     property OnExit;
  540.     property OnStartDock;
  541.     property OnStartDrag;
  542.   end;
  543.  
  544.   NaturalNumber = 1..High(Integer);
  545.  
  546.   TCanResizeEvent = procedure(Sender: TObject; var NewSize: Integer;
  547.     var Accept: Boolean) of object;
  548.  
  549.   TResizeStyle = (rsNone, rsLine, rsUpdate, rsPattern);
  550.  
  551.   TSplitter = class(TGraphicControl)
  552.   private
  553.     FActiveControl: TWinControl;
  554.     FAutoSnap: Boolean;
  555.     FBeveled: Boolean;
  556.     FBrush: TBrush;
  557.     FControl: TControl;
  558.     FDownPos: TPoint;
  559.     FLineDC: HDC;
  560.     FLineVisible: Boolean;
  561.     FMinSize: NaturalNumber;
  562.     FMaxSize: Integer;
  563.     FNewSize: Integer;
  564.     FOldKeyDown: TKeyEvent;
  565.     FOldSize: Integer;
  566.     FPrevBrush: HBrush;
  567.     FResizeStyle: TResizeStyle;
  568.     FSplit: Integer;
  569.     FOnCanResize: TCanResizeEvent;
  570.     FOnMoved: TNotifyEvent;
  571.     FOnPaint: TNotifyEvent;
  572.     procedure AllocateLineDC;
  573.     procedure CalcSplitSize(X, Y: Integer; var NewSize, Split: Integer);
  574.     procedure DrawLine;
  575.     function FindControl: TControl;
  576.     procedure FocusKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
  577.     procedure ReleaseLineDC;
  578.     procedure SetBeveled(Value: Boolean);
  579.     procedure UpdateControlSize;
  580.     procedure UpdateSize(X, Y: Integer);
  581.   protected
  582.     function CanResize(var NewSize: Integer): Boolean; reintroduce; virtual;
  583.     function DoCanResize(var NewSize: Integer): Boolean; virtual;
  584.     procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
  585.       X, Y: Integer); override;
  586.     procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
  587.     procedure MouseUp(Button: TMouseButton; Shift: TShiftState;
  588.       X, Y: Integer); override;
  589.     procedure Paint; override;
  590.     procedure RequestAlign; override;
  591.     procedure StopSizing; dynamic;
  592.   public
  593.     constructor Create(AOwner: TComponent); override;
  594.     destructor Destroy; override;
  595.     property Canvas;
  596.   published
  597.     property Align default alLeft;
  598.     property AutoSnap: Boolean read FAutoSnap write FAutoSnap default True;
  599.     property Beveled: Boolean read FBeveled write SetBeveled default False;
  600.     property Color;
  601.     property Constraints;
  602.     property MinSize: NaturalNumber read FMinSize write FMinSize default 30;
  603.     property ParentColor;
  604.     property ResizeStyle: TResizeStyle read FResizeStyle write FResizeStyle
  605.       default rsPattern;
  606.     property Visible;
  607.     property OnCanResize: TCanResizeEvent read FOnCanResize write FOnCanResize;
  608.     property OnMoved: TNotifyEvent read FOnMoved write FOnMoved;
  609.     property OnPaint: TNotifyEvent read FOnPaint write FOnPaint;
  610.   end;
  611.  
  612. { TControlBar }
  613.  
  614.   TBandPaintOption = (bpoGrabber, bpoFrame);
  615.   TBandPaintOptions = set of TBandPaintOption;
  616.  
  617.   TBandDragEvent = procedure (Sender: TObject; Control: TControl;
  618.     var Drag: Boolean) of object;
  619.   TBandInfoEvent = procedure (Sender: TObject; Control: TControl;
  620.     var Insets: TRect; var PreferredSize, RowCount: Integer) of object;
  621.   TBandMoveEvent = procedure (Sender: TObject; Control: TControl;
  622.     var ARect: TRect) of object;
  623.   TBandPaintEvent = procedure (Sender: TObject; Control: TControl;
  624.     Canvas: TCanvas; var ARect: TRect; var Options: TBandPaintOptions) of object;
  625.  
  626.   TRowSize = 1..MaxInt;
  627.  
  628.   TCustomControlBar = class(TCustomControl)
  629.   private
  630.     FAligning: Boolean;
  631.     FAutoDrag: Boolean;
  632.     FAutoDock: Boolean;
  633.     FDockingControl: TControl;
  634.     FDragControl: TControl;
  635.     FDragOffset: TPoint;
  636.     FDrawing: Boolean;
  637.     FFloating: Boolean;
  638.     FItems: TList;
  639.     FPicture: TPicture;
  640.     FRowSize: TRowSize;
  641.     FRowSnap: Boolean;
  642.     FOnBandDrag: TBandDragEvent;
  643.     FOnBandInfo: TBandInfoEvent;
  644.     FOnBandMove: TBandMoveEvent;
  645.     FOnBandPaint: TBandPaintEvent;
  646.     FOnPaint: TNotifyEvent;
  647.     procedure DoAlignControl(AControl: TControl);
  648.     function FindPos(AControl: TControl): Pointer;
  649.     function HitTest2(X, Y: Integer): Pointer;
  650.     procedure DockControl(AControl: TControl; const ARect: TRect;
  651.       BreakList, IndexList, SizeList: TList; Parent: Pointer;
  652.       ChangedPriorBreak: Boolean; Insets: TRect; PreferredSize,
  653.       RowCount: Integer; Existing: Boolean);
  654.     procedure PictureChanged(Sender: TObject);
  655.     procedure SetPicture(const Value: TPicture);
  656.     procedure SetRowSize(Value: TRowSize);
  657.     procedure SetRowSnap(Value: Boolean);
  658.     procedure UnDockControl(AControl: TControl);
  659.     function UpdateItems(AControl: TControl): Boolean;
  660.     procedure CMControlListChange(var Message: TCMControlListChange); message CM_CONTROLLISTCHANGE;
  661.     procedure CMDesignHitTest(var Message: TCMDesignHitTest); message CM_DESIGNHITTEST;
  662.     procedure CNKeyDown(var Message: TWMKeyDown); message CN_KEYDOWN;
  663.     procedure WMEraseBkgnd(var Message: TWmEraseBkgnd); message WM_ERASEBKGND;
  664.   protected
  665.     procedure AlignControls(AControl: TControl; var ARect: TRect); override;
  666.     function CanAutoSize(var NewWidth, NewHeight: Integer): Boolean; override;
  667.     procedure CreateParams(var Params: TCreateParams); override;
  668.     procedure DoBandMove(Control: TControl; var ARect: TRect); virtual;
  669.     procedure DoBandPaint(Control: TControl; Canvas: TCanvas; var ARect: TRect;
  670.       var Options: TBandPaintOptions); virtual;
  671.     procedure DockOver(Source: TDragDockObject; X, Y: Integer; State: TDragState;
  672.       var Accept: Boolean); override;
  673.     function DoPaletteChange: Boolean;
  674.     function DragControl(AControl: TControl; X, Y: Integer;
  675.       KeepCapture: Boolean = False): Boolean; virtual;
  676.     procedure GetControlInfo(AControl: TControl; var Insets: TRect;
  677.       var PreferredSize, RowCount: Integer); virtual;
  678.     function GetPalette: HPALETTE; override;
  679.     procedure GetSiteInfo(Client: TControl; var InfluenceRect: TRect;
  680.       MousePos: TPoint; var CanDock: Boolean); override;
  681.     function HitTest(X, Y: Integer): TControl;
  682.     procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
  683.       X, Y: Integer); override;
  684.     procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
  685.     procedure MouseUp(Button: TMouseButton; Shift: TShiftState;
  686.       X, Y: Integer); override;
  687.     procedure Paint; override;
  688.     procedure PaintControlFrame(Canvas: TCanvas; AControl: TControl;
  689.       var ARect: TRect); virtual;
  690.   public
  691.     constructor Create(AOwner: TComponent); override;
  692.     destructor Destroy; override;
  693.     procedure FlipChildren(AllLevels: Boolean); override;
  694.     procedure StickControls; virtual;
  695.     property Picture: TPicture read FPicture write SetPicture;
  696.   protected
  697.     property AutoDock: Boolean read FAutoDock write FAutoDock default True;
  698.     property AutoDrag: Boolean read FAutoDrag write FAutoDrag default True;
  699.     property AutoSize;
  700.     property BevelKind default bkTile;
  701.     property DockSite default True;
  702.     property RowSize: TRowSize read FRowSize write SetRowSize default 26;
  703.     property RowSnap: Boolean read FRowSnap write SetRowSnap default True;
  704.     property OnBandDrag: TBandDragEvent read FOnBandDrag write FOnBandDrag;
  705.     property OnBandInfo: TBandInfoEvent read FOnBandInfo write FOnBandInfo;
  706.     property OnBandMove: TBandMoveEvent read FOnBandMove write FOnBandMove;
  707.     property OnBandPaint: TBandPaintEvent read FOnBandPaint write FOnBandPaint;
  708.     property OnPaint: TNotifyEvent read FOnPaint write FOnPaint;
  709.   end;
  710.  
  711.   TControlBar = class(TCustomControlBar)
  712.   public
  713.     property Canvas;
  714.   published
  715.     property Align;
  716.     property Anchors;
  717.     property AutoDock;
  718.     property AutoDrag;
  719.     property AutoSize;
  720.     property BevelEdges;
  721.     property BevelInner;
  722.     property BevelOuter;
  723.     property BevelKind;
  724.     property BevelWidth;
  725.     property BorderWidth;
  726.     property Color;
  727.     property Constraints;
  728.     property DockSite;
  729.     property DragCursor;
  730.     property DragKind;
  731.     property DragMode;
  732.     property Enabled;
  733.     property ParentColor;
  734.     property ParentCtl3D;
  735.     property ParentFont;
  736.     property ParentShowHint;
  737.     property Picture;
  738.     property PopupMenu;
  739.     property RowSize;
  740.     property RowSnap;
  741.     property ShowHint;
  742.     property TabOrder;
  743.     property TabStop;
  744.     property Visible;
  745.     property OnBandDrag;
  746.     property OnBandInfo;
  747.     property OnBandMove;
  748.     property OnBandPaint;
  749.     property OnCanResize;
  750.     property OnClick;
  751.     property OnConstrainedResize;
  752.     property OnContextPopup;
  753.     property OnDockDrop;
  754.     property OnDockOver;
  755.     property OnDblClick;
  756.     property OnDragDrop;
  757.     property OnDragOver;
  758.     property OnEndDock;
  759.     property OnEndDrag;
  760.     property OnEnter;
  761.     property OnExit;
  762.     property OnGetSiteInfo;
  763.     property OnMouseDown;
  764.     property OnMouseMove;
  765.     property OnMouseUp;
  766.     property OnPaint;
  767.     property OnResize;
  768.     property OnStartDock;
  769.     property OnStartDrag;
  770.     property OnUnDock;
  771.   end;
  772.  
  773. procedure Frame3D(Canvas: TCanvas; var Rect: TRect;
  774.   TopColor, BottomColor: TColor; Width: Integer);
  775. procedure NotebookHandlesNeeded(Notebook: TNotebook);
  776.  
  777. implementation
  778.  
  779. uses Consts;
  780.  
  781. { Utility routines }
  782.  
  783. procedure Frame3D(Canvas: TCanvas; var Rect: TRect; TopColor, BottomColor: TColor;
  784.   Width: Integer);
  785.  
  786.   procedure DoRect;
  787.   var
  788.     TopRight, BottomLeft: TPoint;
  789.   begin
  790.     with Canvas, Rect do
  791.     begin
  792.       TopRight.X := Right;
  793.       TopRight.Y := Top;
  794.       BottomLeft.X := Left;
  795.       BottomLeft.Y := Bottom;
  796.       Pen.Color := TopColor;
  797.       PolyLine([BottomLeft, TopLeft, TopRight]);
  798.       Pen.Color := BottomColor;
  799.       Dec(BottomLeft.X);
  800.       PolyLine([TopRight, BottomRight, BottomLeft]);
  801.     end;
  802.   end;
  803.  
  804. begin
  805.   Canvas.Pen.Width := 1;
  806.   Dec(Rect.Bottom); Dec(Rect.Right);
  807.   while Width > 0 do
  808.   begin
  809.     Dec(Width);
  810.     DoRect;
  811.     InflateRect(Rect, -1, -1);
  812.   end;
  813.   Inc(Rect.Bottom); Inc(Rect.Right);
  814. end;
  815.  
  816. // Call HandleNeeded for each page in notebook.  Used to allow anchors to work
  817. // on invisible pages.
  818. procedure NotebookHandlesNeeded(Notebook: TNotebook);
  819. var
  820.   I: Integer;
  821. begin
  822.   if Notebook <> nil then
  823.     for I := 0 to Notebook.FPageList.Count - 1 do
  824.       with TPage(Notebook.FPageList[I]) do
  825.       begin
  826.         DisableAlign;
  827.         try
  828.           HandleNeeded;
  829.           ControlState := ControlState - [csAlignmentNeeded];
  830.         finally
  831.           EnableAlign;
  832.         end;
  833.       end;
  834. end;
  835.  
  836. { TShape }
  837.  
  838. constructor TShape.Create(AOwner: TComponent);
  839. begin
  840.   inherited Create(AOwner);
  841.   ControlStyle := ControlStyle + [csReplicatable];
  842.   Width := 65;
  843.   Height := 65;
  844.   FPen := TPen.Create;
  845.   FPen.OnChange := StyleChanged;
  846.   FBrush := TBrush.Create;
  847.   FBrush.OnChange := StyleChanged;
  848. end;
  849.  
  850. destructor TShape.Destroy;
  851. begin
  852.   FPen.Free;
  853.   FBrush.Free;
  854.   inherited Destroy;
  855. end;
  856.  
  857. procedure TShape.Paint;
  858. var
  859.   X, Y, W, H, S: Integer;
  860. begin
  861.   with Canvas do
  862.   begin
  863.     Pen := FPen;
  864.     Brush := FBrush;
  865.     X := Pen.Width div 2;
  866.     Y := X;
  867.     W := Width - Pen.Width + 1;
  868.     H := Height - Pen.Width + 1;
  869.     if Pen.Width = 0 then
  870.     begin
  871.       Dec(W);
  872.       Dec(H);
  873.     end;
  874.     if W < H then S := W else S := H;
  875.     if FShape in [stSquare, stRoundSquare, stCircle] then
  876.     begin
  877.       Inc(X, (W - S) div 2);
  878.       Inc(Y, (H - S) div 2);
  879.       W := S;
  880.       H := S;
  881.     end;
  882.     case FShape of
  883.       stRectangle, stSquare:
  884.         Rectangle(X, Y, X + W, Y + H);
  885.       stRoundRect, stRoundSquare:
  886.         RoundRect(X, Y, X + W, Y + H, S div 4, S div 4);
  887.       stCircle, stEllipse:
  888.         Ellipse(X, Y, X + W, Y + H);
  889.     end;
  890.   end;
  891. end;
  892.  
  893. procedure TShape.StyleChanged(Sender: TObject);
  894. begin
  895.   Invalidate;
  896. end;
  897.  
  898. procedure TShape.SetBrush(Value: TBrush);
  899. begin
  900.   FBrush.Assign(Value);
  901. end;
  902.  
  903. procedure TShape.SetPen(Value: TPen);
  904. begin
  905.   FPen.Assign(Value);
  906. end;
  907.  
  908. procedure TShape.SetShape(Value: TShapeType);
  909. begin
  910.   if FShape <> Value then
  911.   begin
  912.     FShape := Value;
  913.     Invalidate;
  914.   end;
  915. end;
  916.  
  917. { TPaintBox }
  918.  
  919. constructor TPaintBox.Create(AOwner: TComponent);
  920. begin
  921.   inherited Create(AOwner);
  922.   ControlStyle := ControlStyle + [csReplicatable];
  923.   Width := 105;
  924.   Height := 105;
  925. end;
  926.  
  927. procedure TPaintBox.Paint;
  928. begin
  929.   Canvas.Font := Font;
  930.   Canvas.Brush.Color := Color;
  931.   if csDesigning in ComponentState then
  932.     with Canvas do
  933.     begin
  934.       Pen.Style := psDash;
  935.       Brush.Style := bsClear;
  936.       Rectangle(0, 0, Width, Height);
  937.     end;
  938.   if Assigned(FOnPaint) then FOnPaint(Self);
  939. end;
  940.  
  941. { TImage }
  942.  
  943. constructor TImage.Create(AOwner: TComponent);
  944. begin
  945.   inherited Create(AOwner);
  946.   ControlStyle := ControlStyle + [csReplicatable];
  947.   FPicture := TPicture.Create;
  948.   FPicture.OnChange := PictureChanged;
  949.   FPicture.OnProgress := Progress;
  950.   Height := 105;
  951.   Width := 105;
  952. end;
  953.  
  954. destructor TImage.Destroy;
  955. begin
  956.   FPicture.Free;
  957.   inherited Destroy;
  958. end;
  959.  
  960. function TImage.GetPalette: HPALETTE;
  961. begin
  962.   Result := 0;
  963.   if FPicture.Graphic <> nil then
  964.     Result := FPicture.Graphic.Palette;
  965. end;
  966.  
  967. function TImage.DestRect: TRect;
  968. begin
  969.   if Stretch then
  970.     Result := ClientRect
  971.   else if Center then
  972.     Result := Bounds((Width - Picture.Width) div 2, (Height - Picture.Height) div 2,
  973.       Picture.Width, Picture.Height)
  974.   else
  975.     Result := Rect(0, 0, Picture.Width, Picture.Height);
  976. end;
  977.  
  978. procedure TImage.Paint;
  979. var
  980.   Save: Boolean;
  981. begin
  982.   if csDesigning in ComponentState then
  983.     with inherited Canvas do
  984.     begin
  985.       Pen.Style := psDash;
  986.       Brush.Style := bsClear;
  987.       Rectangle(0, 0, Width, Height);
  988.     end;
  989.   Save := FDrawing;
  990.   FDrawing := True;
  991.   try
  992.     with inherited Canvas do
  993.       StretchDraw(DestRect, Picture.Graphic);
  994.   finally
  995.     FDrawing := Save;
  996.   end;
  997. end;
  998.  
  999. function TImage.DoPaletteChange: Boolean;
  1000. var
  1001.   ParentForm: TCustomForm;
  1002.   Tmp: TGraphic;
  1003. begin
  1004.   Result := False;
  1005.   Tmp := Picture.Graphic;
  1006.   if Visible and (not (csLoading in ComponentState)) and (Tmp <> nil) and
  1007.     (Tmp.PaletteModified) then
  1008.   begin
  1009.     if (Tmp.Palette = 0) then
  1010.       Tmp.PaletteModified := False
  1011.     else
  1012.     begin
  1013.       ParentForm := GetParentForm(Self);
  1014.       if Assigned(ParentForm) and ParentForm.Active and Parentform.HandleAllocated then
  1015.       begin
  1016.         if FDrawing then
  1017.           ParentForm.Perform(wm_QueryNewPalette, 0, 0)
  1018.         else
  1019.           PostMessage(ParentForm.Handle, wm_QueryNewPalette, 0, 0);
  1020.         Result := True;
  1021.         Tmp.PaletteModified := False;
  1022.       end;
  1023.     end;
  1024.   end;
  1025. end;
  1026.  
  1027. procedure TImage.Progress(Sender: TObject; Stage: TProgressStage;
  1028.   PercentDone: Byte; RedrawNow: Boolean; const R: TRect; const Msg: string);
  1029. begin
  1030.   if FIncrementalDisplay and RedrawNow then
  1031.   begin
  1032.     if DoPaletteChange then Update
  1033.     else Paint;
  1034.   end;
  1035.   if Assigned(FOnProgress) then FOnProgress(Sender, Stage, PercentDone, RedrawNow, R, Msg);
  1036. end;
  1037.  
  1038. function TImage.GetCanvas: TCanvas;
  1039. var
  1040.   Bitmap: TBitmap;
  1041. begin
  1042.   if Picture.Graphic = nil then
  1043.   begin
  1044.     Bitmap := TBitmap.Create;
  1045.     try
  1046.       Bitmap.Width := Width;
  1047.       Bitmap.Height := Height;
  1048.       Picture.Graphic := Bitmap;
  1049.     finally
  1050.       Bitmap.Free;
  1051.     end;
  1052.   end;
  1053.   if Picture.Graphic is TBitmap then
  1054.     Result := TBitmap(Picture.Graphic).Canvas
  1055.   else
  1056.     raise EInvalidOperation.Create(SImageCanvasNeedsBitmap);
  1057. end;
  1058.  
  1059. procedure TImage.SetCenter(Value: Boolean);
  1060. begin
  1061.   if FCenter <> Value then
  1062.   begin
  1063.     FCenter := Value;
  1064.     PictureChanged(Self);
  1065.   end;
  1066. end;
  1067.  
  1068. procedure TImage.SetPicture(Value: TPicture);
  1069. begin
  1070.   FPicture.Assign(Value);
  1071. end;
  1072.  
  1073. procedure TImage.SetStretch(Value: Boolean);
  1074. begin
  1075.   if Value <> FStretch then
  1076.   begin
  1077.     FStretch := Value;
  1078.     PictureChanged(Self);
  1079.   end;
  1080. end;
  1081.  
  1082. procedure TImage.SetTransparent(Value: Boolean);
  1083. begin
  1084.   if Value <> FTransparent then
  1085.   begin
  1086.     FTransparent := Value;
  1087.     PictureChanged(Self);
  1088.   end;
  1089. end;
  1090.  
  1091. procedure TImage.PictureChanged(Sender: TObject);
  1092. var
  1093.   G: TGraphic;
  1094. begin
  1095.   if AutoSize and (Picture.Width > 0) and (Picture.Height > 0) then
  1096.     SetBounds(Left, Top, Picture.Width, Picture.Height);
  1097.   G := Picture.Graphic;
  1098.   if G <> nil then
  1099.   begin
  1100.     if not ((G is TMetaFile) or (G is TIcon)) then
  1101.       G.Transparent := FTransparent;
  1102.     if (not G.Transparent) and (Stretch or (G.Width >= Width)
  1103.       and (G.Height >= Height)) then
  1104.       ControlStyle := ControlStyle + [csOpaque]
  1105.     else
  1106.       ControlStyle := ControlStyle - [csOpaque];
  1107.     if DoPaletteChange and FDrawing then Update;
  1108.   end
  1109.   else ControlStyle := ControlStyle - [csOpaque];
  1110.   if not FDrawing then Invalidate;
  1111. end;
  1112.  
  1113. function TImage.CanAutoSize(var NewWidth, NewHeight: Integer): Boolean;
  1114. begin
  1115.   Result := True;
  1116.   if not (csDesigning in ComponentState) or (Picture.Width > 0) and
  1117.     (Picture.Height > 0) then
  1118.   begin
  1119.     if Align in [alNone, alLeft, alRight] then
  1120.       NewWidth := Picture.Width;
  1121.     if Align in [alNone, alTop, alBottom] then
  1122.       NewHeight := Picture.Height;
  1123.   end;
  1124. end;
  1125.  
  1126. { TBevel }
  1127.  
  1128. constructor TBevel.Create(AOwner: TComponent);
  1129. begin
  1130.   inherited Create(AOwner);
  1131.   ControlStyle := ControlStyle + [csReplicatable];
  1132.   FStyle := bsLowered;
  1133.   FShape := bsBox;
  1134.   Width := 50;
  1135.   Height := 50;
  1136. end;
  1137.  
  1138. procedure TBevel.SetStyle(Value: TBevelStyle);
  1139. begin
  1140.   if Value <> FStyle then
  1141.   begin
  1142.     FStyle := Value;
  1143.     Invalidate;
  1144.   end;
  1145. end;
  1146.  
  1147. procedure TBevel.SetShape(Value: TBevelShape);
  1148. begin
  1149.   if Value <> FShape then
  1150.   begin
  1151.     FShape := Value;
  1152.     Invalidate;
  1153.   end;
  1154. end;
  1155.  
  1156. procedure TBevel.Paint;
  1157. const
  1158.   XorColor = $00FFD8CE;
  1159. var
  1160.   Color1, Color2: TColor;
  1161.   Temp: TColor;
  1162.  
  1163.   procedure BevelRect(const R: TRect);
  1164.   begin
  1165.     with Canvas do
  1166.     begin
  1167.       Pen.Color := Color1;
  1168.       PolyLine([Point(R.Left, R.Bottom), Point(R.Left, R.Top),
  1169.         Point(R.Right, R.Top)]);
  1170.       Pen.Color := Color2;
  1171.       PolyLine([Point(R.Right, R.Top), Point(R.Right, R.Bottom),
  1172.         Point(R.Left, R.Bottom)]);
  1173.     end;
  1174.   end;
  1175.  
  1176.   procedure BevelLine(C: TColor; X1, Y1, X2, Y2: Integer);
  1177.   begin
  1178.     with Canvas do
  1179.     begin
  1180.       Pen.Color := C;
  1181.       MoveTo(X1, Y1);
  1182.       LineTo(X2, Y2);
  1183.     end;
  1184.   end;
  1185.  
  1186. begin
  1187.   with Canvas do
  1188.   begin
  1189.     if (csDesigning in ComponentState) then
  1190.     begin
  1191.       if (FShape = bsSpacer) then
  1192.       begin
  1193.         Pen.Style := psDot;
  1194.         Pen.Mode := pmXor;
  1195.         Pen.Color := XorColor;
  1196.         Brush.Style := bsClear;
  1197.         Rectangle(0, 0, ClientWidth, ClientHeight);
  1198.         Exit;
  1199.       end
  1200.       else
  1201.       begin
  1202.         Pen.Style := psSolid;
  1203.         Pen.Mode  := pmCopy;
  1204.         Pen.Color := clBlack;
  1205.         Brush.Style := bsSolid;
  1206.       end;
  1207.     end;
  1208.  
  1209.     Pen.Width := 1;
  1210.  
  1211.     if FStyle = bsLowered then
  1212.     begin
  1213.       Color1 := clBtnShadow;
  1214.       Color2 := clBtnHighlight;
  1215.     end
  1216.     else
  1217.     begin
  1218.       Color1 := clBtnHighlight;
  1219.       Color2 := clBtnShadow;
  1220.     end;
  1221.  
  1222.     case FShape of
  1223.       bsBox: BevelRect(Rect(0, 0, Width - 1, Height - 1));
  1224.       bsFrame:
  1225.         begin
  1226.           Temp := Color1;
  1227.           Color1 := Color2;
  1228.           BevelRect(Rect(1, 1, Width - 1, Height - 1));
  1229.           Color2 := Temp;
  1230.           Color1 := Temp;
  1231.           BevelRect(Rect(0, 0, Width - 2, Height - 2));
  1232.         end;
  1233.       bsTopLine:
  1234.         begin
  1235.           BevelLine(Color1, 0, 0, Width, 0);
  1236.           BevelLine(Color2, 0, 1, Width, 1);
  1237.         end;
  1238.       bsBottomLine:
  1239.         begin
  1240.           BevelLine(Color1, 0, Height - 2, Width, Height - 2);
  1241.           BevelLine(Color2, 0, Height - 1, Width, Height - 1);
  1242.         end;
  1243.       bsLeftLine:
  1244.         begin
  1245.           BevelLine(Color1, 0, 0, 0, Height);
  1246.           BevelLine(Color2, 1, 0, 1, Height);
  1247.         end;
  1248.       bsRightLine:
  1249.         begin
  1250.           BevelLine(Color1, Width - 2, 0, Width - 2, Height);
  1251.           BevelLine(Color2, Width - 1, 0, Width - 1, Height);
  1252.         end;
  1253.     end;
  1254.   end;
  1255. end;
  1256.  
  1257. { TTimer }
  1258.  
  1259. constructor TTimer.Create(AOwner: TComponent);
  1260. begin
  1261.   inherited Create(AOwner);
  1262.   FEnabled := True;
  1263.   FInterval := 1000;
  1264.   FWindowHandle := AllocateHWnd(WndProc);
  1265. end;
  1266.  
  1267. destructor TTimer.Destroy;
  1268. begin
  1269.   FEnabled := False;
  1270.   UpdateTimer;
  1271.   DeallocateHWnd(FWindowHandle);
  1272.   inherited Destroy;
  1273. end;
  1274.  
  1275. procedure TTimer.WndProc(var Msg: TMessage);
  1276. begin
  1277.   with Msg do
  1278.     if Msg = WM_TIMER then
  1279.       try
  1280.         Timer;
  1281.       except
  1282.         Application.HandleException(Self);
  1283.       end
  1284.     else
  1285.       Result := DefWindowProc(FWindowHandle, Msg, wParam, lParam);
  1286. end;
  1287.  
  1288. procedure TTimer.UpdateTimer;
  1289. begin
  1290.   KillTimer(FWindowHandle, 1);
  1291.   if (FInterval <> 0) and FEnabled and Assigned(FOnTimer) then
  1292.     if SetTimer(FWindowHandle, 1, FInterval, nil) = 0 then
  1293.       raise EOutOfResources.Create(SNoTimers);
  1294. end;
  1295.  
  1296. procedure TTimer.SetEnabled(Value: Boolean);
  1297. begin
  1298.   if Value <> FEnabled then
  1299.   begin
  1300.     FEnabled := Value;
  1301.     UpdateTimer;
  1302.   end;
  1303. end;
  1304.  
  1305. procedure TTimer.SetInterval(Value: Cardinal);
  1306. begin
  1307.   if Value <> FInterval then
  1308.   begin
  1309.     FInterval := Value;
  1310.     UpdateTimer;
  1311.   end;
  1312. end;
  1313.  
  1314. procedure TTimer.SetOnTimer(Value: TNotifyEvent);
  1315. begin
  1316.   FOnTimer := Value;
  1317.   UpdateTimer;
  1318. end;
  1319.  
  1320. procedure TTimer.Timer;
  1321. begin
  1322.   if Assigned(FOnTimer) then FOnTimer(Self);
  1323. end;
  1324.  
  1325. { TCustomPanel }
  1326.  
  1327. constructor TCustomPanel.Create(AOwner: TComponent);
  1328. begin
  1329.   inherited Create(AOwner);
  1330.   ControlStyle := [csAcceptsControls, csCaptureMouse, csClickEvents,
  1331.     csSetCaption, csOpaque, csDoubleClicks, csReplicatable];
  1332.   Width := 185;
  1333.   Height := 41;
  1334.   FAlignment := taCenter;
  1335.   BevelOuter := bvRaised;
  1336.   BevelWidth := 1;
  1337.   FBorderStyle := bsNone;
  1338.   Color := clBtnFace;
  1339.   FFullRepaint := True;
  1340.   UseDockManager := True;
  1341. end;
  1342.  
  1343. procedure TCustomPanel.CreateParams(var Params: TCreateParams);
  1344. const
  1345.   BorderStyles: array[TBorderStyle] of DWORD = (0, WS_BORDER);
  1346. begin
  1347.   inherited CreateParams(Params);
  1348.   with Params do
  1349.   begin
  1350.     Style := Style or BorderStyles[FBorderStyle];
  1351.     if NewStyleControls and Ctl3D and (FBorderStyle = bsSingle) then
  1352.     begin
  1353.       Style := Style and not WS_BORDER;
  1354.       ExStyle := ExStyle or WS_EX_CLIENTEDGE;
  1355.     end;
  1356.     WindowClass.style := WindowClass.style and not (CS_HREDRAW or CS_VREDRAW);
  1357.   end;
  1358. end;
  1359.  
  1360. procedure TCustomPanel.CMBorderChanged(var Message: TMessage);
  1361. begin
  1362.   inherited;
  1363.   Invalidate;
  1364. end;
  1365.  
  1366. procedure TCustomPanel.CMTextChanged(var Message: TMessage);
  1367. begin
  1368.   Invalidate;
  1369. end;
  1370.  
  1371. procedure TCustomPanel.CMCtl3DChanged(var Message: TMessage);
  1372. begin
  1373.   if NewStyleControls and (FBorderStyle = bsSingle) then RecreateWnd;
  1374.   inherited;
  1375. end;
  1376.  
  1377. procedure TCustomPanel.CMIsToolControl(var Message: TMessage);
  1378. begin
  1379.   if not FLocked then Message.Result := 1;
  1380. end;
  1381.  
  1382. procedure TCustomPanel.WMWindowPosChanged(var Message: TWMWindowPosChanged);
  1383. var
  1384.   BevelPixels: Integer;
  1385.   Rect: TRect;
  1386. begin
  1387.   if FullRepaint or (Caption <> '') then
  1388.     Invalidate
  1389.   else
  1390.   begin
  1391.     BevelPixels := BorderWidth;
  1392.     if BevelInner <> bvNone then Inc(BevelPixels, BevelWidth);
  1393.     if BevelOuter <> bvNone then Inc(BevelPixels, BevelWidth);
  1394.     if BevelPixels > 0 then
  1395.     begin
  1396.       Rect.Right := Width;
  1397.       Rect.Bottom := Height;
  1398.       if Message.WindowPos^.cx <> Rect.Right then
  1399.       begin
  1400.         Rect.Top := 0;
  1401.         Rect.Left := Rect.Right - BevelPixels - 1;
  1402.         InvalidateRect(Handle, @Rect, True);
  1403.       end;
  1404.       if Message.WindowPos^.cy <> Rect.Bottom then
  1405.       begin
  1406.         Rect.Left := 0;
  1407.         Rect.Top := Rect.Bottom - BevelPixels - 1;
  1408.         InvalidateRect(Handle, @Rect, True);
  1409.       end;
  1410.     end;
  1411.   end;
  1412.   inherited;
  1413. end;
  1414.  
  1415. procedure TCustomPanel.Paint;
  1416. const
  1417.   Alignments: array[TAlignment] of Longint = (DT_LEFT, DT_RIGHT, DT_CENTER);
  1418. var
  1419.   Rect: TRect;
  1420.   TopColor, BottomColor: TColor;
  1421.   FontHeight: Integer;
  1422.   Flags: Longint;
  1423.  
  1424.   procedure AdjustColors(Bevel: TPanelBevel);
  1425.   begin
  1426.     TopColor := clBtnHighlight;
  1427.     if Bevel = bvLowered then TopColor := clBtnShadow;
  1428.     BottomColor := clBtnShadow;
  1429.     if Bevel = bvLowered then BottomColor := clBtnHighlight;
  1430.   end;
  1431.  
  1432. begin
  1433.   Rect := GetClientRect;
  1434.   if BevelOuter <> bvNone then
  1435.   begin
  1436.     AdjustColors(BevelOuter);
  1437.     Frame3D(Canvas, Rect, TopColor, BottomColor, BevelWidth);
  1438.   end;
  1439.   Frame3D(Canvas, Rect, Color, Color, BorderWidth);
  1440.   if BevelInner <> bvNone then
  1441.   begin
  1442.     AdjustColors(BevelInner);
  1443.     Frame3D(Canvas, Rect, TopColor, BottomColor, BevelWidth);
  1444.   end;
  1445.   with Canvas do
  1446.   begin
  1447.     Brush.Color := Color;
  1448.     FillRect(Rect);
  1449.     Brush.Style := bsClear;
  1450.     Font := Self.Font;
  1451.     FontHeight := TextHeight('W');
  1452.     with Rect do
  1453.     begin
  1454.       Top := ((Bottom + Top) - FontHeight) div 2;
  1455.       Bottom := Top + FontHeight;
  1456.     end;
  1457.     Flags := DT_EXPANDTABS or DT_VCENTER or Alignments[FAlignment];
  1458.     Flags := DrawTextBiDiModeFlags(Flags);
  1459.     DrawText(Handle, PChar(Caption), -1, Rect, Flags);
  1460.   end;
  1461. end;
  1462.  
  1463. procedure TCustomPanel.SetAlignment(Value: TAlignment);
  1464. begin
  1465.   FAlignment := Value;
  1466.   Invalidate;
  1467. end;
  1468.  
  1469. procedure TCustomPanel.SetBevelInner(Value: TPanelBevel);
  1470. begin
  1471.   FBevelInner := Value;
  1472.   Realign;
  1473.   Invalidate;
  1474. end;
  1475.  
  1476. procedure TCustomPanel.SetBevelOuter(Value: TPanelBevel);
  1477. begin
  1478.   FBevelOuter := Value;
  1479.   Realign;
  1480.   Invalidate;
  1481. end;
  1482.  
  1483. procedure TCustomPanel.SetBevelWidth(Value: TBevelWidth);
  1484. begin
  1485.   FBevelWidth := Value;
  1486.   Realign;
  1487.   Invalidate;
  1488. end;
  1489.  
  1490. procedure TCustomPanel.SetBorderWidth(Value: TBorderWidth);
  1491. begin
  1492.   FBorderWidth := Value;
  1493.   Realign;
  1494.   Invalidate;
  1495. end;
  1496.  
  1497. procedure TCustomPanel.SetBorderStyle(Value: TBorderStyle);
  1498. begin
  1499.   if FBorderStyle <> Value then
  1500.   begin
  1501.     FBorderStyle := Value;
  1502.     RecreateWnd;
  1503.   end;
  1504. end;
  1505.  
  1506. function TCustomPanel.GetControlsAlignment: TAlignment;
  1507. begin
  1508.   Result := FAlignment;
  1509. end;
  1510.  
  1511. procedure TCustomPanel.AdjustClientRect(var Rect: TRect);
  1512. var
  1513.   BevelSize: Integer;
  1514. begin
  1515.   inherited AdjustClientRect(Rect);
  1516.   InflateRect(Rect, -BorderWidth, -BorderWidth);
  1517.   BevelSize := 0;
  1518.   if BevelOuter <> bvNone then Inc(BevelSize, BevelWidth);
  1519.   if BevelInner <> bvNone then Inc(BevelSize, BevelWidth);
  1520.   InflateRect(Rect, -BevelSize, -BevelSize);
  1521. end;
  1522.  
  1523. procedure TCustomPanel.CMDockClient(var Message: TCMDockClient);
  1524. var
  1525.   R: TRect;
  1526.   Dim: Integer;
  1527. begin
  1528.   if AutoSize then
  1529.   begin
  1530.     FAutoSizeDocking := True;
  1531.     try
  1532.       R := Message.DockSource.DockRect;
  1533.       case Align of
  1534.         alLeft: if Width = 0 then Width := R.Right - R.Left;
  1535.         alRight: if Width = 0 then
  1536.           begin
  1537.             Dim := R.Right - R.Left;
  1538.             SetBounds(Left - Dim, Top, Dim, Height);
  1539.           end;
  1540.         alTop: if Height = 0 then Height := R.Bottom - R.Top;
  1541.         alBottom: if Height = 0 then
  1542.           begin
  1543.             Dim := R.Bottom - R.Top;
  1544.             SetBounds(Left, Top - Dim, Width, Dim);
  1545.           end;
  1546.       end;
  1547.       inherited;
  1548.       Exit;
  1549.     finally
  1550.       FAutoSizeDocking := False;
  1551.     end;
  1552.   end;
  1553.   inherited;
  1554. end;
  1555.  
  1556. function TCustomPanel.CanAutoSize(var NewWidth, NewHeight: Integer): Boolean;
  1557. begin
  1558.   Result := (not FAutoSizeDocking) and inherited CanAutoSize(NewWidth, NewHeight);
  1559. end;
  1560.  
  1561. { TPageAccess }
  1562.  
  1563. type
  1564.   TPageAccess = class(TStrings)
  1565.   private
  1566.     PageList: TList;
  1567.     Notebook: TNotebook;
  1568.   protected
  1569.     function GetCount: Integer; override;
  1570.     function Get(Index: Integer): string; override;
  1571.     procedure Put(Index: Integer; const S: string); override;
  1572.     function GetObject(Index: Integer): TObject; override;
  1573.     procedure SetUpdateState(Updating: Boolean); override;
  1574.   public
  1575.     constructor Create(APageList: TList; ANotebook: TNotebook);
  1576.     procedure Clear; override;
  1577.     procedure Delete(Index: Integer); override;
  1578.     procedure Insert(Index: Integer; const S: string); override;
  1579.     procedure Move(CurIndex, NewIndex: Integer); override;
  1580.   end;
  1581.  
  1582. constructor TPageAccess.Create(APageList: TList; ANotebook: TNotebook);
  1583. begin
  1584.   inherited Create;
  1585.   PageList := APageList;
  1586.   Notebook := ANotebook;
  1587. end;
  1588.  
  1589. function TPageAccess.GetCount: Integer;
  1590. begin
  1591.   Result := PageList.Count;
  1592. end;
  1593.  
  1594. function TPageAccess.Get(Index: Integer): string;
  1595. begin
  1596.   Result := TPage(PageList[Index]).Caption;
  1597. end;
  1598.  
  1599. procedure TPageAccess.Put(Index: Integer; const S: string);
  1600. begin
  1601.   TPage(PageList[Index]).Caption := S;
  1602. end;
  1603.  
  1604. function TPageAccess.GetObject(Index: Integer): TObject;
  1605. begin
  1606.   Result := PageList[Index];
  1607. end;
  1608.  
  1609. procedure TPageAccess.SetUpdateState(Updating: Boolean);
  1610. begin
  1611.   { do nothing }
  1612. end;
  1613.  
  1614. procedure TPageAccess.Clear;
  1615. var
  1616.   I: Integer;
  1617. begin
  1618.   for I := 0 to PageList.Count - 1 do
  1619.     TPage(PageList[I]).Free;
  1620.   PageList.Clear;
  1621. end;
  1622.  
  1623. procedure TPageAccess.Delete(Index: Integer);
  1624. var
  1625.   Form: TCustomForm;
  1626. begin
  1627.   TPage(PageList[Index]).Free;
  1628.   PageList.Delete(Index);
  1629.   NoteBook.PageIndex := 0;
  1630.  
  1631.   if csDesigning in NoteBook.ComponentState then
  1632.   begin
  1633.     Form := GetParentForm(NoteBook);
  1634.     if (Form <> nil) and (Form.Designer <> nil) then
  1635.       Form.Designer.Modified;
  1636.   end;
  1637. end;
  1638.  
  1639. procedure TPageAccess.Insert(Index: Integer; const S: string);
  1640. var
  1641.   Page: TPage;
  1642.   Form: TCustomForm;
  1643. begin
  1644.   Page := TPage.Create(Notebook);
  1645.   with Page do
  1646.   begin
  1647.     Parent := Notebook;
  1648.     Caption := S;
  1649.   end;
  1650.   PageList.Insert(Index, Page);
  1651.  
  1652.   NoteBook.PageIndex := Index;
  1653.  
  1654.   if csDesigning in NoteBook.ComponentState then
  1655.   begin
  1656.     Form := GetParentForm(NoteBook);
  1657.     if (Form <> nil) and (Form.Designer <> nil) then
  1658.       Form.Designer.Modified;
  1659.   end;
  1660. end;
  1661.  
  1662. procedure TPageAccess.Move(CurIndex, NewIndex: Integer);
  1663. var
  1664.   AObject: TObject;
  1665. begin
  1666.   if CurIndex <> NewIndex then
  1667.   begin
  1668.     AObject := PageList[CurIndex];
  1669.     PageList[CurIndex] := PageList[NewIndex];
  1670.     PageList[NewIndex] := AObject;
  1671.   end;
  1672. end;
  1673.  
  1674. { TPage }
  1675.  
  1676. constructor TPage.Create(AOwner: TComponent);
  1677. begin
  1678.   inherited Create(AOwner);
  1679.   Visible := False;
  1680.   ControlStyle := ControlStyle + [csAcceptsControls, csNoDesignVisible];
  1681.   Align := alClient;
  1682. end;
  1683.  
  1684. procedure TPage.Paint;
  1685. begin
  1686.   inherited Paint;
  1687.   if csDesigning in ComponentState then
  1688.     with Canvas do
  1689.     begin
  1690.       Pen.Style := psDash;
  1691.       Brush.Style := bsClear;
  1692.       Rectangle(0, 0, Width, Height);
  1693.     end;
  1694. end;
  1695.  
  1696. procedure TPage.ReadState(Reader: TReader);
  1697. begin
  1698.   if Reader.Parent is TNotebook then
  1699.     TNotebook(Reader.Parent).FPageList.Add(Self);
  1700.   inherited ReadState(Reader);
  1701. end;
  1702.  
  1703. procedure TPage.WMNCHitTest(var Message: TWMNCHitTest);
  1704. begin
  1705.   if not (csDesigning in ComponentState) then
  1706.     Message.Result := HTTRANSPARENT
  1707.   else
  1708.     inherited;
  1709. end;
  1710.  
  1711. { TNotebook }
  1712.  
  1713. var
  1714.   Registered: Boolean = False;
  1715.  
  1716. constructor TNotebook.Create(AOwner: TComponent);
  1717. begin
  1718.   inherited Create(AOwner);
  1719.   Width := 150;
  1720.   Height := 150;
  1721.   FPageList := TList.Create;
  1722.   FAccess := TPageAccess.Create(FPageList, Self);
  1723.   FPageIndex := -1;
  1724.   FAccess.Add(SDefault);
  1725.   PageIndex := 0;
  1726.   Exclude(FComponentStyle, csInheritable);
  1727.   if not Registered then
  1728.   begin
  1729.     Classes.RegisterClasses([TPage]);
  1730.     Registered := True;
  1731.   end;
  1732. end;
  1733.  
  1734. destructor TNotebook.Destroy;
  1735. begin
  1736.   FAccess.Free;
  1737.   FPageList.Free;
  1738.   inherited Destroy;
  1739. end;
  1740.  
  1741. procedure TNotebook.CreateParams(var Params: TCreateParams);
  1742. begin
  1743.   inherited CreateParams(Params);
  1744.   with Params do
  1745.   begin
  1746.     Style := Style or WS_CLIPCHILDREN;
  1747.     WindowClass.style := WindowClass.style and not (CS_HREDRAW or CS_VREDRAW);
  1748.   end;
  1749. end;
  1750.  
  1751. function TNotebook.GetChildOwner: TComponent;
  1752. begin
  1753.   Result := Self;
  1754. end;
  1755.  
  1756. procedure TNotebook.GetChildren(Proc: TGetChildProc; Root: TComponent);
  1757. var
  1758.   I: Integer;
  1759. begin
  1760.   for I := 0 to FPageList.Count - 1 do Proc(TControl(FPageList[I]));
  1761. end;
  1762.  
  1763. procedure TNotebook.ReadState(Reader: TReader);
  1764. begin
  1765.   Pages.Clear;
  1766.   inherited ReadState(Reader);
  1767.   if (FPageIndex <> -1) and (FPageIndex >= 0) and (FPageIndex < FPageList.Count) then
  1768.     with TPage(FPageList[FPageIndex]) do
  1769.     begin
  1770.       BringToFront;
  1771.       Visible := True;
  1772.       Align := alClient;
  1773.     end
  1774.   else FPageIndex := -1;
  1775. end;
  1776.  
  1777. procedure TNotebook.ShowControl(AControl: TControl);
  1778. var
  1779.   I: Integer;
  1780. begin
  1781.   for I := 0 to FPageList.Count - 1 do
  1782.     if FPageList[I] = AControl then
  1783.     begin
  1784.       SetPageIndex(I);
  1785.       Exit;
  1786.     end;
  1787.   inherited ShowControl(AControl);
  1788. end;
  1789.  
  1790. procedure TNotebook.SetPages(Value: TStrings);
  1791. begin
  1792.   FAccess.Assign(Value);
  1793. end;
  1794.  
  1795. procedure TNotebook.SetPageIndex(Value: Integer);
  1796. var
  1797.   ParentForm: TCustomForm;
  1798. begin
  1799.   if csLoading in ComponentState then
  1800.   begin
  1801.     FPageIndex := Value;
  1802.     Exit;
  1803.   end;
  1804.   if (Value <> FPageIndex) and (Value >= 0) and (Value < FPageList.Count) then
  1805.   begin
  1806.     ParentForm := GetParentForm(Self);
  1807.     if ParentForm <> nil then
  1808.       if ContainsControl(ParentForm.ActiveControl) then
  1809.         ParentForm.ActiveControl := Self;
  1810.     with TPage(FPageList[Value]) do
  1811.     begin
  1812.       BringToFront;
  1813.       Visible := True;
  1814.       Align := alClient;
  1815.     end;
  1816.     if (FPageIndex >= 0) and (FPageIndex < FPageList.Count) then
  1817.       TPage(FPageList[FPageIndex]).Visible := False;
  1818.     FPageIndex := Value;
  1819.     if ParentForm <> nil then
  1820.       if ParentForm.ActiveControl = Self then SelectFirst;
  1821.     if Assigned(FOnPageChanged) then
  1822.       FOnPageChanged(Self);
  1823.   end;
  1824. end;
  1825.  
  1826. procedure TNotebook.SetActivePage(const Value: string);
  1827. begin
  1828.   SetPageIndex(FAccess.IndexOf(Value));
  1829. end;
  1830.  
  1831. function TNotebook.GetActivePage: string;
  1832. begin
  1833.   Result := FAccess[FPageIndex];
  1834. end;
  1835.  
  1836. { THeaderStrings }
  1837.  
  1838. const
  1839.   DefaultSectionWidth = 75;
  1840.  
  1841. type
  1842.   PHeaderSection = ^THeaderSection;
  1843.   THeaderSection = record
  1844.     FObject: TObject;
  1845.     Width: Integer;
  1846.     Title: string;
  1847.   end;
  1848.  
  1849. type
  1850.   THeaderStrings = class(TStrings)
  1851.   private
  1852.     FHeader: THeader;
  1853.     FList: TList;
  1854.     procedure ReadData(Reader: TReader);
  1855.     procedure WriteData(Writer: TWriter);
  1856.   protected
  1857.     procedure DefineProperties(Filer: TFiler); override;
  1858.     function Get(Index: Integer): string; override;
  1859.     function GetCount: Integer; override;
  1860.     function GetObject(Index: Integer): TObject; override;
  1861.     procedure Put(Index: Integer; const S: string); override;
  1862.     procedure PutObject(Index: Integer; AObject: TObject); override;
  1863.     procedure SetUpdateState(Updating: Boolean); override;
  1864.   public
  1865.     constructor Create;
  1866.     destructor Destroy; override;
  1867.     procedure Assign(Source: TPersistent); override;
  1868.     procedure Delete(Index: Integer); override;
  1869.     procedure Insert(Index: Integer; const S: string); override;
  1870.     procedure Clear; override;
  1871.   end;
  1872.  
  1873. procedure FreeSection(Section: PHeaderSection);
  1874. begin
  1875.   if Section <> nil then Dispose(Section);
  1876. end;
  1877.  
  1878. function NewSection(const ATitle: string; AWidth: Integer; AObject: TObject): PHeaderSection;
  1879. begin
  1880.   New(Result);
  1881.   with Result^ do
  1882.   begin
  1883.     Title := ATitle;
  1884.     Width := AWidth;
  1885.     FObject := AObject;
  1886.   end;
  1887. end;
  1888.  
  1889. constructor THeaderStrings.Create;
  1890. begin
  1891.   inherited Create;
  1892.   FList := TList.Create;
  1893. end;
  1894.  
  1895. destructor THeaderStrings.Destroy;
  1896. begin
  1897.   if FList <> nil then
  1898.   begin
  1899.     Clear;
  1900.     FList.Free;
  1901.   end;
  1902.   inherited Destroy;
  1903. end;
  1904.  
  1905. procedure THeaderStrings.Assign(Source: TPersistent);
  1906. var
  1907.   I, J: Integer;
  1908.   Strings: TStrings;
  1909.   NewList: TList;
  1910.   Section: PHeaderSection;
  1911.   TempStr: string;
  1912.   Found: Boolean;
  1913. begin
  1914.   if Source is TStrings then
  1915.   begin
  1916.     Strings := TStrings(Source);
  1917.     BeginUpdate;
  1918.     try
  1919.       NewList := TList.Create;
  1920.       try
  1921.         { Delete any sections not in the new list }
  1922.         I := FList.Count - 1;
  1923.         Found := False;
  1924.         while I >= 0 do
  1925.         begin
  1926.           TempStr := Get(I);
  1927.           for J := 0 to Strings.Count - 1 do
  1928.           begin
  1929.             Found := AnsiCompareStr(Strings[J], TempStr) = 0;
  1930.             if Found then Break;
  1931.           end;
  1932.           if not Found then Delete(I);
  1933.           Dec(I);
  1934.         end;
  1935.  
  1936.         { Now iterate over the lists and maintain section widths of sections in
  1937.           the new list }
  1938.         I := 0;
  1939.         for J := 0 to Strings.Count - 1 do
  1940.         begin
  1941.           if (I < FList.Count) and (AnsiCompareStr(Strings[J], Get(I)) = 0) then
  1942.           begin
  1943.             Section := NewSection(Get(I), PHeaderSection(FList[I])^.Width, GetObject(I));
  1944.             Inc(I);
  1945.           end else
  1946.             Section := NewSection(Strings[J],
  1947.               FHeader.Canvas.TextWidth(Strings[J]) + 8, Strings.Objects[J]);
  1948.           NewList.Add(Section);
  1949.         end;
  1950.         Clear;
  1951.         FList.Destroy;
  1952.         FList := NewList;
  1953.         FHeader.Invalidate;
  1954.       except
  1955.         for I := 0 to NewList.Count - 1 do
  1956.           FreeSection(NewList[I]);
  1957.         NewList.Destroy;
  1958.         raise;
  1959.       end;
  1960.     finally
  1961.       EndUpdate;
  1962.     end;
  1963.     Exit;
  1964.   end;
  1965.   inherited Assign(Source);
  1966. end;
  1967.  
  1968. procedure THeaderStrings.DefineProperties(Filer: TFiler);
  1969. begin
  1970.   { This will allow the old file image read in }
  1971.   if Filer is TReader then inherited DefineProperties(Filer);
  1972.   Filer.DefineProperty('Sections', ReadData, WriteData, Count > 0);
  1973. end;
  1974.  
  1975. procedure THeaderStrings.Clear;
  1976. var
  1977.   I: Integer;
  1978. begin
  1979.   for I := 0 to FList.Count - 1 do
  1980.     FreeSection(FList[I]);
  1981.   FList.Clear;
  1982. end;
  1983.  
  1984. procedure THeaderStrings.Delete(Index: Integer);
  1985. begin
  1986.   FreeSection(FList[Index]);
  1987.   FList.Delete(Index);
  1988.   if FHeader <> nil then FHeader.Invalidate;
  1989. end;
  1990.  
  1991. function THeaderStrings.Get(Index: Integer): string;
  1992. begin
  1993.   Result := PHeaderSection(FList[Index])^.Title;
  1994. end;
  1995.  
  1996. function THeaderStrings.GetCount: Integer;
  1997. begin
  1998.   Result := FList.Count;
  1999. end;
  2000.  
  2001. function THeaderStrings.GetObject(Index: Integer): TObject;
  2002. begin
  2003.   Result := PHeaderSection(FList[Index])^.FObject;
  2004. end;
  2005.  
  2006. procedure THeaderStrings.Insert(Index: Integer; const S: string);
  2007. var
  2008.   Width: Integer;
  2009. begin
  2010.   if FHeader <> nil then
  2011.     Width := FHeader.Canvas.TextWidth(S) + 8
  2012.   else Width := DefaultSectionWidth;
  2013.   FList.Expand.Insert(Index, NewSection(S, Width, nil));
  2014.   if FHeader <> nil then FHeader.Invalidate;
  2015. end;
  2016.  
  2017. procedure THeaderStrings.Put(Index: Integer; const S: string);
  2018. var
  2019.   P: PHeaderSection;
  2020.   Width: Integer;
  2021. begin
  2022.   P := FList[Index];
  2023.   if FHeader <> nil then
  2024.     Width := FHeader.Canvas.TextWidth(S) + 8
  2025.   else Width := DefaultSectionWidth;
  2026.   FList[Index] := NewSection(S, Width, P^.FObject);
  2027.   FreeSection(P);
  2028.   if FHeader <> nil then FHeader.Invalidate;
  2029. end;
  2030.  
  2031. procedure THeaderStrings.PutObject(Index: Integer; AObject: TObject);
  2032. begin
  2033.   PHeaderSection(FList[Index])^.FObject := AObject;
  2034.   if FHeader <> nil then FHeader.Invalidate;
  2035. end;
  2036.  
  2037. procedure THeaderStrings.ReadData(Reader: TReader);
  2038. var
  2039.   Width, I: Integer;
  2040.   Str: string;
  2041. begin
  2042.   Reader.ReadListBegin;
  2043.   Clear;
  2044.   while not Reader.EndOfList do
  2045.   begin
  2046.     Str := Reader.ReadString;
  2047.     Width := DefaultSectionWidth;
  2048.     I := 1;
  2049.     if Str[1] = #0 then
  2050.     begin
  2051.       repeat
  2052.         Inc(I);
  2053.       until (I > Length(Str)) or (Str[I] = #0);
  2054.       Width := StrToIntDef(Copy(Str, 2, I - 2), DefaultSectionWidth);
  2055.       System.Delete(Str, 1, I);
  2056.     end;
  2057.     FList.Expand.Insert(FList.Count, NewSection(Str, Width, nil));
  2058.   end;
  2059.   Reader.ReadListEnd;
  2060. end;
  2061.  
  2062. procedure THeaderStrings.SetUpdateState(Updating: Boolean);
  2063. begin
  2064.   if FHeader <> nil then
  2065.   begin
  2066.     SendMessage(FHeader.Handle, WM_SETREDRAW, Ord(not Updating), 0);
  2067.     if not Updating then FHeader.Refresh;
  2068.   end;
  2069. end;
  2070.  
  2071. procedure THeaderStrings.WriteData(Writer: TWriter);
  2072. var
  2073.   I: Integer;
  2074.   HeaderSection: PHeaderSection;
  2075. begin
  2076.   Writer.WriteListBegin;
  2077.   for I := 0 to Count - 1 do
  2078.   begin
  2079.     HeaderSection := FList[I];
  2080.     with HeaderSection^ do
  2081.       Writer.WriteString(Format(#0'%d'#0'%s', [Width, Title]));
  2082.   end;
  2083.   Writer.WriteListEnd;
  2084. end;
  2085.  
  2086. { THeader }
  2087.  
  2088. constructor THeader.Create(AOwner: TComponent);
  2089. begin
  2090.   inherited Create(AOwner);
  2091.   ControlStyle := ControlStyle + [csDesignInteractive, csOpaque];
  2092.   Width := 250;
  2093.   Height := 25;
  2094.   FSections := THeaderStrings.Create;
  2095.   THeaderStrings(FSections).FHeader := Self;
  2096.   FAllowResize := True;
  2097.   FBorderStyle := bsSingle;
  2098. end;
  2099.  
  2100. destructor THeader.Destroy;
  2101. begin
  2102.   FreeSections;
  2103.   FSections.Free;
  2104.   inherited Destroy;
  2105. end;
  2106.  
  2107. procedure THeader.CreateParams(var Params: TCreateParams);
  2108. const
  2109.   BorderStyles: array[TBorderStyle] of DWORD = (0, WS_BORDER);
  2110. begin
  2111.   inherited CreateParams(Params);
  2112.   with Params do
  2113.   begin
  2114.     Style := Style or BorderStyles[FBorderStyle];
  2115.     WindowClass.style := WindowClass.style and not (CS_HREDRAW or CS_VREDRAW);
  2116.   end;
  2117. end;
  2118.  
  2119. procedure THeader.Paint;
  2120. var
  2121.   I, Y, W: Integer;
  2122.   S: string;
  2123.   R: TRect;
  2124. begin
  2125.   with Canvas do
  2126.   begin
  2127.     Font := Self.Font;
  2128.     Brush.Color := clBtnFace;
  2129.     I := 0;
  2130.     Y := (ClientHeight - Canvas.TextHeight('T')) div 2;
  2131.     R := Rect(0, 0, 0, ClientHeight);
  2132.     W := 0;
  2133.     S := '';
  2134.     repeat
  2135.       if I < FSections.Count then
  2136.       begin
  2137.         with PHeaderSection(THeaderStrings(FSections).FList[I])^ do
  2138.         begin
  2139.           W := Width;
  2140.           S := Title;
  2141.         end;
  2142.         Inc(I);
  2143.       end;
  2144.       R.Left := R.Right;
  2145.       Inc(R.Right, W);
  2146.       if (ClientWidth - R.Right < 2) or (I = FSections.Count) then
  2147.         R.Right := ClientWidth;
  2148.       TextRect(Rect(R.Left + 1, R.Top + 1, R.Right - 1, R.Bottom - 1),
  2149.         R.Left + 3, Y, S);
  2150.       DrawEdge(Canvas.Handle, R, BDR_RAISEDINNER, BF_TOPLEFT);
  2151.       DrawEdge(Canvas.Handle, R, BDR_RAISEDINNER, BF_BOTTOMRight);
  2152.     until R.Right = ClientWidth;
  2153.   end;
  2154. end;
  2155.  
  2156. procedure THeader.FreeSections;
  2157. begin
  2158.   if FSections <> nil then
  2159.     FSections.Clear;
  2160. end;
  2161.  
  2162. procedure THeader.SetBorderStyle(Value: TBorderStyle);
  2163. begin
  2164.   if Value <> FBorderStyle then
  2165.   begin
  2166.     FBorderStyle := Value;
  2167.     RecreateWnd;
  2168.   end;
  2169. end;
  2170.  
  2171. procedure THeader.SetSections(Strings: TStrings);
  2172. begin
  2173.   FSections.Assign(Strings);
  2174. end;
  2175.  
  2176. function THeader.GetWidth(X: Integer): Integer;
  2177. var
  2178.   I, W: Integer;
  2179. begin
  2180.   if X = FSections.Count - 1 then
  2181.   begin
  2182.     W := 0;
  2183.     for I := 0 to X - 1 do
  2184.       Inc(W, PHeaderSection(THeaderStrings(FSections).FList[I])^.Width);
  2185.     Result := ClientWidth - W;
  2186.   end
  2187.   else if (X >= 0) and (X < FSections.Count) then
  2188.     Result := PHeaderSection(THeaderStrings(FSections).FList[X])^.Width
  2189.   else
  2190.     Result := 0;
  2191. end;
  2192.  
  2193. procedure THeader.SetWidth(X: Integer; Value: Integer);
  2194. begin
  2195.   if X < 0 then Exit;
  2196.   PHeaderSection(THeaderStrings(FSections).FList[X])^.Width := Value;
  2197.   Invalidate;
  2198. end;
  2199.  
  2200. procedure THeader.WMNCHitTest(var Msg: TWMNCHitTest);
  2201. begin
  2202.   inherited;
  2203.   FHitTest := SmallPointToPoint(Msg.Pos);
  2204. end;
  2205.  
  2206. procedure THeader.WMSetCursor(var Msg: TWMSetCursor);
  2207. var
  2208.   Cur: HCURSOR;
  2209.   I: Integer;
  2210.   X: Integer;
  2211. begin
  2212.   Cur := 0;
  2213.   FResizeSection := 0;
  2214.   FHitTest := ScreenToClient(FHitTest);
  2215.   X := 2;
  2216.   with Msg do
  2217.     if HitTest = HTCLIENT then
  2218.       for I := 0 to FSections.Count - 2 do  { don't count last section }
  2219.       begin
  2220.         Inc(X, PHeaderSection(THeaderStrings(FSections).FList[I])^.Width);
  2221.         FMouseOffset := X - (FHitTest.X + 2);
  2222.         if Abs(FMouseOffset) < 4 then
  2223.         begin
  2224.           Cur := LoadCursor(0, IDC_SIZEWE);
  2225.           FResizeSection := I;
  2226.           Break;
  2227.         end;
  2228.       end;
  2229.   FCanResize := (FAllowResize or (csDesigning in ComponentState)) and (Cur <> 0);
  2230.   if FCanResize then SetCursor(Cur)
  2231.   else inherited;
  2232. end;
  2233.  
  2234. procedure THeader.MouseDown(Button: TMouseButton; Shift: TShiftState;
  2235.   X, Y: Integer);
  2236. begin
  2237.   inherited MouseDown(Button, Shift, X, Y);
  2238.   if ((csDesigning in ComponentState) and (Button = mbRight)) or (Button = mbLeft) then
  2239.     if FCanResize then SetCapture(Handle);
  2240. end;
  2241.  
  2242. procedure THeader.MouseMove(Shift: TShiftState; X, Y: Integer);
  2243. var
  2244.   I: Integer;
  2245.   AbsPos: Integer;
  2246.   MinPos: Integer;
  2247.   MaxPos: Integer;
  2248. begin
  2249.   inherited MouseMove(Shift, X, Y);
  2250.   if (GetCapture = Handle) and FCanResize then
  2251.   begin
  2252.     { absolute position of this item }
  2253.     AbsPos := 2;
  2254.     for I := 0 to FResizeSection do
  2255.       Inc(AbsPos, PHeaderSection(THeaderStrings(FSections).FList[I])^.Width);
  2256.  
  2257.     if FResizeSection > 0 then MinPos := AbsPos -
  2258.       PHeaderSection(THeaderStrings(FSections).FList[FResizeSection])^.Width + 2
  2259.     else MinPos := 2;
  2260.     MaxPos := ClientWidth - 2;
  2261.     if X < MinPos then X := MinPos;
  2262.     if X > MaxPos then X := MaxPos;
  2263.  
  2264.     Dec(PHeaderSection(THeaderStrings(FSections).FList[FResizeSection])^.Width,
  2265.       (AbsPos - X - 2) - FMouseOffset);
  2266.     Sizing(FResizeSection,
  2267.       PHeaderSection(THeaderStrings(FSections).FList[FResizeSection])^.Width);
  2268.     Refresh;
  2269.   end;
  2270. end;
  2271.  
  2272. procedure THeader.MouseUp(Button: TMouseButton; Shift: TShiftState;
  2273.   X, Y: Integer);
  2274. begin
  2275.   if FCanResize then
  2276.   begin
  2277.     ReleaseCapture;
  2278.     Sized(FResizeSection,
  2279.       PHeaderSection(THeaderStrings(FSections).FList[FResizeSection])^.Width);
  2280.     FCanResize := False;
  2281.   end;
  2282.   inherited MouseUp(Button, Shift, X, Y);
  2283. end;
  2284.  
  2285. procedure THeader.Sizing(ASection, AWidth: Integer);
  2286. begin
  2287.   if Assigned(FOnSizing) then FOnSizing(Self, ASection, AWidth);
  2288. end;
  2289.  
  2290. procedure THeader.Sized(ASection, AWidth: Integer);
  2291. var
  2292.   Form: TCustomForm;
  2293. begin
  2294.   if Assigned(FOnSized) then FOnSized(Self, ASection, AWidth);
  2295.   if csDesigning in ComponentState then
  2296.   begin
  2297.     Form := GetParentForm(Self);
  2298.     if Form <> nil then
  2299.       Form.Designer.Modified;
  2300.   end;
  2301. end;
  2302.  
  2303. procedure THeader.WMSize(var Msg: TWMSize);
  2304. begin
  2305.   inherited;
  2306.   Invalidate;
  2307. end;
  2308.  
  2309. { TGroupButton }
  2310.  
  2311. type
  2312.   TGroupButton = class(TRadioButton)
  2313.   private
  2314.     FInClick: Boolean;
  2315.     procedure CNCommand(var Message: TWMCommand); message CN_COMMAND;
  2316.   protected
  2317.     procedure KeyDown(var Key: Word; Shift: TShiftState); override;
  2318.     procedure KeyPress(var Key: Char); override;
  2319.   public
  2320.     constructor InternalCreate(RadioGroup: TCustomRadioGroup);
  2321.     destructor Destroy; override;
  2322.   end;
  2323.  
  2324. constructor TGroupButton.InternalCreate(RadioGroup: TCustomRadioGroup);
  2325. begin
  2326.   inherited Create(RadioGroup);
  2327.   RadioGroup.FButtons.Add(Self);
  2328.   Visible := False;
  2329.   Enabled := RadioGroup.Enabled;
  2330.   ParentShowHint := False;
  2331.   OnClick := RadioGroup.ButtonClick;
  2332.   Parent := RadioGroup;
  2333. end;
  2334.  
  2335. destructor TGroupButton.Destroy;
  2336. begin
  2337.   TCustomRadioGroup(Owner).FButtons.Remove(Self);
  2338.   inherited Destroy;
  2339. end;
  2340.  
  2341. procedure TGroupButton.CNCommand(var Message: TWMCommand);
  2342. begin
  2343.   if not FInClick then
  2344.   begin
  2345.     FInClick := True;
  2346.     try
  2347.       if ((Message.NotifyCode = BN_CLICKED) or
  2348.         (Message.NotifyCode = BN_DOUBLECLICKED)) and
  2349.         TCustomRadioGroup(Parent).CanModify then
  2350.         inherited;
  2351.     except
  2352.       Application.HandleException(Self);
  2353.     end;
  2354.     FInClick := False;
  2355.   end;
  2356. end;
  2357.  
  2358. procedure TGroupButton.KeyPress(var Key: Char);
  2359. begin
  2360.   inherited KeyPress(Key);
  2361.   TCustomRadioGroup(Parent).KeyPress(Key);
  2362.   if (Key = #8) or (Key = ' ') then
  2363.   begin
  2364.     if not TCustomRadioGroup(Parent).CanModify then Key := #0;
  2365.   end;
  2366. end;
  2367.  
  2368. procedure TGroupButton.KeyDown(var Key: Word; Shift: TShiftState);
  2369. begin
  2370.   inherited KeyDown(Key, Shift);
  2371.   TCustomRadioGroup(Parent).KeyDown(Key, Shift);
  2372. end;
  2373.  
  2374. { TCustomRadioGroup }
  2375.  
  2376. constructor TCustomRadioGroup.Create(AOwner: TComponent);
  2377. begin
  2378.   inherited Create(AOwner);
  2379.   ControlStyle := [csSetCaption, csDoubleClicks];
  2380.   FButtons := TList.Create;
  2381.   FItems := TStringList.Create;
  2382.   TStringList(FItems).OnChange := ItemsChange;
  2383.   FItemIndex := -1;
  2384.   FColumns := 1;
  2385. end;
  2386.  
  2387. destructor TCustomRadioGroup.Destroy;
  2388. begin
  2389.   SetButtonCount(0);
  2390.   TStringList(FItems).OnChange := nil;
  2391.   FItems.Free;
  2392.   FButtons.Free;
  2393.   inherited Destroy;
  2394. end;
  2395.  
  2396. procedure TCustomRadioGroup.FlipChildren(AllLevels: Boolean); 
  2397. begin
  2398.   { The radio buttons are flipped using BiDiMode }
  2399. end;
  2400.  
  2401. procedure TCustomRadioGroup.ArrangeButtons;
  2402. var
  2403.   ButtonsPerCol, ButtonWidth, ButtonHeight, TopMargin, I: Integer;
  2404.   DC: HDC;
  2405.   SaveFont: HFont;
  2406.   Metrics: TTextMetric;
  2407.   DeferHandle: THandle;
  2408.   ALeft: Integer;
  2409. begin
  2410.   if (FButtons.Count <> 0) and not FReading then
  2411.   begin
  2412.     DC := GetDC(0);
  2413.     SaveFont := SelectObject(DC, Font.Handle);
  2414.     GetTextMetrics(DC, Metrics);
  2415.     SelectObject(DC, SaveFont);
  2416.     ReleaseDC(0, DC);
  2417.     ButtonsPerCol := (FButtons.Count + FColumns - 1) div FColumns;
  2418.     ButtonWidth := (Width - 10) div FColumns;
  2419.     I := Height - Metrics.tmHeight - 5;
  2420.     ButtonHeight := I div ButtonsPerCol;
  2421.     TopMargin := Metrics.tmHeight + 1 + (I mod ButtonsPerCol) div 2;
  2422.     DeferHandle := BeginDeferWindowPos(FButtons.Count);
  2423.     try
  2424.       for I := 0 to FButtons.Count - 1 do
  2425.         with TGroupButton(FButtons[I]) do
  2426.         begin
  2427.           BiDiMode := Self.BiDiMode;
  2428.           ALeft := (I div ButtonsPerCol) * ButtonWidth + 8;
  2429.           if UseRightToLeftAlignment then
  2430.             ALeft := Self.ClientWidth - ALeft - ButtonWidth;
  2431.           DeferHandle := DeferWindowPos(DeferHandle, Handle, 0,
  2432.             ALeft,
  2433.             (I mod ButtonsPerCol) * ButtonHeight + TopMargin,
  2434.             ButtonWidth, ButtonHeight,
  2435.             SWP_NOZORDER or SWP_NOACTIVATE);
  2436.           Visible := True;
  2437.         end;
  2438.     finally
  2439.       EndDeferWindowPos(DeferHandle);
  2440.     end;
  2441.   end;
  2442. end;
  2443.  
  2444. procedure TCustomRadioGroup.ButtonClick(Sender: TObject);
  2445. begin
  2446.   if not FUpdating then
  2447.   begin
  2448.     FItemIndex := FButtons.IndexOf(Sender);
  2449.     Changed;
  2450.     Click;
  2451.   end;
  2452. end;
  2453.  
  2454. procedure TCustomRadioGroup.ItemsChange(Sender: TObject);
  2455. begin
  2456.   if not FReading then
  2457.   begin
  2458.     if FItemIndex >= FItems.Count then FItemIndex := FItems.Count - 1;
  2459.     UpdateButtons;
  2460.   end;
  2461. end;
  2462.  
  2463. procedure TCustomRadioGroup.Loaded;
  2464. begin
  2465.   inherited Loaded;
  2466.   ArrangeButtons;
  2467. end;
  2468.  
  2469. procedure TCustomRadioGroup.ReadState(Reader: TReader);
  2470. begin
  2471.   FReading := True;
  2472.   inherited ReadState(Reader);
  2473.   FReading := False;
  2474.   UpdateButtons;
  2475. end;
  2476.  
  2477. procedure TCustomRadioGroup.SetButtonCount(Value: Integer);
  2478. begin
  2479.   while FButtons.Count < Value do TGroupButton.InternalCreate(Self);
  2480.   while FButtons.Count > Value do TGroupButton(FButtons.Last).Free;
  2481. end;
  2482.  
  2483. procedure TCustomRadioGroup.SetColumns(Value: Integer);
  2484. begin
  2485.   if Value < 1 then Value := 1;
  2486.   if Value > 16 then Value := 16;
  2487.   if FColumns <> Value then
  2488.   begin
  2489.     FColumns := Value;
  2490.     ArrangeButtons;
  2491.     Invalidate;
  2492.   end;
  2493. end;
  2494.  
  2495. procedure TCustomRadioGroup.SetItemIndex(Value: Integer);
  2496. begin
  2497.   if FReading then FItemIndex := Value else
  2498.   begin
  2499.     if Value < -1 then Value := -1;
  2500.     if Value >= FButtons.Count then Value := FButtons.Count - 1;
  2501.     if FItemIndex <> Value then
  2502.     begin
  2503.       if FItemIndex >= 0 then
  2504.         TGroupButton(FButtons[FItemIndex]).Checked := False;
  2505.       FItemIndex := Value;
  2506.       if FItemIndex >= 0 then
  2507.         TGroupButton(FButtons[FItemIndex]).Checked := True;
  2508.     end;
  2509.   end;
  2510. end;
  2511.  
  2512. procedure TCustomRadioGroup.SetItems(Value: TStrings);
  2513. begin
  2514.   FItems.Assign(Value);
  2515. end;
  2516.  
  2517. procedure TCustomRadioGroup.UpdateButtons;
  2518. var
  2519.   I: Integer;
  2520. begin
  2521.   SetButtonCount(FItems.Count);
  2522.   for I := 0 to FButtons.Count - 1 do
  2523.     TGroupButton(FButtons[I]).Caption := FItems[I];
  2524.   if FItemIndex >= 0 then
  2525.   begin
  2526.     FUpdating := True;
  2527.     TGroupButton(FButtons[FItemIndex]).Checked := True;
  2528.     FUpdating := False;
  2529.   end;
  2530.   ArrangeButtons;
  2531.   Invalidate;
  2532. end;
  2533.  
  2534. procedure TCustomRadioGroup.CMEnabledChanged(var Message: TMessage);
  2535. var
  2536.   I: Integer;
  2537. begin
  2538.   inherited;
  2539.   for I := 0 to FButtons.Count - 1 do
  2540.     TGroupButton(FButtons[I]).Enabled := Enabled;
  2541. end;
  2542.  
  2543. procedure TCustomRadioGroup.CMFontChanged(var Message: TMessage);
  2544. begin
  2545.   inherited;
  2546.   ArrangeButtons;
  2547. end;
  2548.  
  2549. procedure TCustomRadioGroup.WMSize(var Message: TWMSize);
  2550. begin
  2551.   inherited;
  2552.   ArrangeButtons;
  2553. end;
  2554.  
  2555. function TCustomRadioGroup.CanModify: Boolean;
  2556. begin
  2557.   Result := True;
  2558. end;
  2559.  
  2560. procedure TCustomRadioGroup.GetChildren(Proc: TGetChildProc; Root: TComponent);
  2561. begin
  2562. end;
  2563.  
  2564. { TSplitter }
  2565.  
  2566. type
  2567.   TWinControlAccess = class(TWinControl);
  2568.  
  2569. constructor TSplitter.Create(AOwner: TComponent);
  2570. begin
  2571.   inherited Create(AOwner);
  2572.   FAutoSnap := True;
  2573.   Align := alLeft;
  2574.   Width := 3;
  2575.   Cursor := crHSplit;
  2576.   FMinSize := 30;
  2577.   FResizeStyle := rsPattern;
  2578.   FOldSize := -1;
  2579. end;
  2580.  
  2581. destructor TSplitter.Destroy;
  2582. begin
  2583.   FBrush.Free;
  2584.   inherited Destroy;
  2585. end;
  2586.  
  2587. procedure TSplitter.AllocateLineDC;
  2588. begin
  2589.   FLineDC := GetDCEx(Parent.Handle, 0, DCX_CACHE or DCX_CLIPSIBLINGS
  2590.     or DCX_LOCKWINDOWUPDATE);
  2591.   if ResizeStyle = rsPattern then
  2592.   begin
  2593.     if FBrush = nil then
  2594.     begin
  2595.       FBrush := TBrush.Create;
  2596.       FBrush.Bitmap := AllocPatternBitmap(clBlack, clWhite);
  2597.     end;
  2598.     FPrevBrush := SelectObject(FLineDC, FBrush.Handle);
  2599.   end;
  2600. end;
  2601.  
  2602. procedure TSplitter.DrawLine;
  2603. var
  2604.   P: TPoint;
  2605. begin
  2606.   FLineVisible := not FLineVisible;
  2607.   P := Point(Left, Top);
  2608.   if Align in [alLeft, alRight] then
  2609.     P.X := Left + FSplit else
  2610.     P.Y := Top + FSplit;
  2611.   with P do PatBlt(FLineDC, X, Y, Width, Height, PATINVERT);
  2612. end;
  2613.  
  2614. procedure TSplitter.ReleaseLineDC;
  2615. begin
  2616.   if FPrevBrush <> 0 then
  2617.     SelectObject(FLineDC, FPrevBrush);
  2618.   ReleaseDC(Parent.Handle, FLineDC);
  2619.   if FBrush <> nil then
  2620.   begin
  2621.     FBrush.Free;
  2622.     FBrush := nil;
  2623.   end;
  2624. end;
  2625.  
  2626. function TSplitter.FindControl: TControl;
  2627. var
  2628.   P: TPoint;
  2629.   I: Integer;
  2630.   R: TRect;
  2631. begin
  2632.   Result := nil;
  2633.   P := Point(Left, Top);
  2634.   case Align of
  2635.     alLeft: Dec(P.X);
  2636.     alRight: Inc(P.X, Width);
  2637.     alTop: Dec(P.Y);
  2638.     alBottom: Inc(P.Y, Height);
  2639.   else
  2640.     Exit;
  2641.   end;
  2642.   for I := 0 to Parent.ControlCount - 1 do
  2643.   begin
  2644.     Result := Parent.Controls[I];
  2645.     if Result.Visible and Result.Enabled then
  2646.     begin
  2647.       R := Result.BoundsRect;
  2648.       if (R.Right - R.Left) = 0 then
  2649.         if Align in [alTop, alLeft] then
  2650.           Dec(R.Left)
  2651.         else
  2652.           Inc(R.Right);
  2653.       if (R.Bottom - R.Top) = 0 then
  2654.         if Align in [alTop, alLeft] then
  2655.           Dec(R.Top)
  2656.         else
  2657.           Inc(R.Bottom);
  2658.       if PtInRect(R, P) then Exit;
  2659.     end;
  2660.   end;
  2661.   Result := nil;
  2662. end;
  2663.  
  2664. procedure TSplitter.RequestAlign;
  2665. begin
  2666.   inherited RequestAlign;
  2667.   if (Cursor <> crVSplit) and (Cursor <> crHSplit) then Exit;
  2668.   if Align in [alBottom, alTop] then
  2669.     Cursor := crVSplit
  2670.   else
  2671.     Cursor := crHSplit;
  2672. end;
  2673.  
  2674. procedure TSplitter.Paint;
  2675. const
  2676.   XorColor = $00FFD8CE;
  2677. var
  2678.   FrameBrush: HBRUSH;
  2679.   R: TRect;
  2680. begin
  2681.   R := ClientRect;
  2682.   Canvas.Brush.Color := Color;
  2683.   Canvas.FillRect(ClientRect);
  2684.   if Beveled then
  2685.   begin
  2686.     if Align in [alLeft, alRight] then
  2687.       InflateRect(R, -1, 2) else
  2688.       InflateRect(R, 2, -1);
  2689.     OffsetRect(R, 1, 1);
  2690.     FrameBrush := CreateSolidBrush(ColorToRGB(clBtnHighlight));
  2691.     FrameRect(Canvas.Handle, R, FrameBrush);
  2692.     DeleteObject(FrameBrush);
  2693.     OffsetRect(R, -2, -2);
  2694.     FrameBrush := CreateSolidBrush(ColorToRGB(clBtnShadow));
  2695.     FrameRect(Canvas.Handle, R, FrameBrush);
  2696.     DeleteObject(FrameBrush);
  2697.   end;
  2698.   if csDesigning in ComponentState then
  2699.     { Draw outline }
  2700.     with Canvas do
  2701.     begin
  2702.       Pen.Style := psDot;
  2703.       Pen.Mode := pmXor;
  2704.       Pen.Color := XorColor;
  2705.       Brush.Style := bsClear;
  2706.       Rectangle(0, 0, ClientWidth, ClientHeight);
  2707.     end;
  2708.   if Assigned(FOnPaint) then FOnPaint(Self);
  2709. end;
  2710.  
  2711. function TSplitter.DoCanResize(var NewSize: Integer): Boolean;
  2712. begin
  2713.   Result := CanResize(NewSize);
  2714.   if Result and (NewSize <= MinSize) and FAutoSnap then
  2715.     NewSize := 0;
  2716. end;
  2717.  
  2718. function TSplitter.CanResize(var NewSize: Integer): Boolean;
  2719. begin
  2720.   Result := True;
  2721.   if Assigned(FOnCanResize) then FOnCanResize(Self, NewSize, Result);
  2722. end;
  2723.  
  2724. procedure TSplitter.MouseDown(Button: TMouseButton; Shift: TShiftState;
  2725.   X, Y: Integer);
  2726. var
  2727.   I: Integer;
  2728. begin
  2729.   inherited MouseDown(Button, Shift, X, Y);
  2730.   if Button = mbLeft then
  2731.   begin
  2732.     FControl := FindControl;
  2733.     FDownPos := Point(X, Y);
  2734.     if Assigned(FControl) then
  2735.     begin
  2736.       if Align in [alLeft, alRight] then
  2737.       begin
  2738.         FMaxSize := Parent.ClientWidth - FMinSize;
  2739.         for I := 0 to Parent.ControlCount - 1 do
  2740.           with Parent.Controls[I] do
  2741.             if Align in [alLeft, alRight] then Dec(FMaxSize, Width);
  2742.         Inc(FMaxSize, FControl.Width);
  2743.       end
  2744.       else
  2745.       begin
  2746.         FMaxSize := Parent.ClientHeight - FMinSize;
  2747.         for I := 0 to Parent.ControlCount - 1 do
  2748.           with Parent.Controls[I] do
  2749.             if Align in [alTop, alBottom] then Dec(FMaxSize, Height);
  2750.         Inc(FMaxSize, FControl.Height);
  2751.       end;
  2752.       UpdateSize(X, Y);
  2753.       AllocateLineDC;
  2754.       with ValidParentForm(Self) do
  2755.         if ActiveControl <> nil then
  2756.         begin
  2757.           FActiveControl := ActiveControl;
  2758.           FOldKeyDown := TWinControlAccess(FActiveControl).OnKeyDown;
  2759.           TWinControlAccess(FActiveControl).OnKeyDown := FocusKeyDown;
  2760.         end;
  2761.       if ResizeStyle in [rsLine, rsPattern] then DrawLine;
  2762.     end;
  2763.   end;
  2764. end;
  2765.  
  2766. procedure TSplitter.UpdateControlSize;
  2767. begin
  2768.   if FNewSize <> FOldSize then
  2769.   begin
  2770.     case Align of
  2771.       alLeft: FControl.Width := FNewSize;
  2772.       alTop: FControl.Height := FNewSize;
  2773.       alRight:
  2774.         begin
  2775.           Parent.DisableAlign;
  2776.           try
  2777.             FControl.Left := FControl.Left + (FControl.Width - FNewSize);
  2778.             FControl.Width := FNewSize;
  2779.           finally
  2780.             Parent.EnableAlign;
  2781.           end;
  2782.         end;
  2783.       alBottom:
  2784.         begin
  2785.           Parent.DisableAlign;
  2786.           try
  2787.             FControl.Top := FControl.Top + (FControl.Height - FNewSize);
  2788.             FControl.Height := FNewSize;
  2789.           finally
  2790.             Parent.EnableAlign;
  2791.           end;
  2792.         end;
  2793.     end;
  2794.     Update;
  2795.     if Assigned(FOnMoved) then FOnMoved(Self);
  2796.     FOldSize := FNewSize;
  2797.   end;
  2798. end;
  2799.  
  2800. procedure TSplitter.CalcSplitSize(X, Y: Integer; var NewSize, Split: Integer);
  2801. var
  2802.   S: Integer;
  2803. begin
  2804.   if Align in [alLeft, alRight] then
  2805.     Split := X - FDownPos.X
  2806.   else
  2807.     Split := Y - FDownPos.Y;
  2808.   S := 0;
  2809.   case Align of
  2810.     alLeft: S := FControl.Width + Split;
  2811.     alRight: S := FControl.Width - Split;
  2812.     alTop: S := FControl.Height + Split;
  2813.     alBottom: S := FControl.Height - Split;
  2814.   end;
  2815.   NewSize := S;
  2816.   if S < FMinSize then
  2817.     NewSize := FMinSize
  2818.   else if S > FMaxSize then
  2819.     NewSize := FMaxSize;
  2820.   if S <> NewSize then
  2821.   begin
  2822.     if Align in [alRight, alBottom] then
  2823.       S := S - NewSize else
  2824.       S := NewSize - S;
  2825.     Inc(Split, S);
  2826.   end;
  2827. end;
  2828.  
  2829. procedure TSplitter.UpdateSize(X, Y: Integer);
  2830. begin
  2831.   CalcSplitSize(X, Y, FNewSize, FSplit);
  2832. end;
  2833.  
  2834. procedure TSplitter.MouseMove(Shift: TShiftState; X, Y: Integer);
  2835. var
  2836.   NewSize, Split: Integer;
  2837. begin
  2838.   inherited;
  2839.   if (ssLeft in Shift) and Assigned(FControl) then
  2840.   begin
  2841.     CalcSplitSize(X, Y, NewSize, Split);
  2842.     if DoCanResize(NewSize) then
  2843.     begin
  2844.       if ResizeStyle in [rsLine, rsPattern] then DrawLine;
  2845.       FNewSize := NewSize;
  2846.       FSplit := Split;
  2847.       if ResizeStyle = rsUpdate then UpdateControlSize;
  2848.       if ResizeStyle in [rsLine, rsPattern] then DrawLine;
  2849.     end;
  2850.   end;
  2851. end;
  2852.  
  2853. procedure TSplitter.MouseUp(Button: TMouseButton; Shift: TShiftState;
  2854.   X, Y: Integer);
  2855. begin
  2856.   inherited;
  2857.   if Assigned(FControl) then
  2858.   begin
  2859.     if ResizeStyle in [rsLine, rsPattern] then DrawLine;
  2860.     UpdateControlSize;
  2861.     StopSizing;
  2862.   end;
  2863. end;
  2864.  
  2865. procedure TSplitter.FocusKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
  2866. begin
  2867.   if Key = VK_ESCAPE then
  2868.     StopSizing
  2869.   else if Assigned(FOldKeyDown) then
  2870.     FOldKeyDown(Sender, Key, Shift);
  2871. end;
  2872.  
  2873. procedure TSplitter.SetBeveled(Value: Boolean);
  2874. begin
  2875.   FBeveled := Value;
  2876.   Repaint;
  2877. end;
  2878.  
  2879. procedure TSplitter.StopSizing;
  2880. begin
  2881.   if Assigned(FControl) then
  2882.   begin
  2883.     if FLineVisible then DrawLine;
  2884.     FControl := nil;
  2885.     ReleaseLineDC;
  2886.     if Assigned(FActiveControl) then
  2887.     begin
  2888.       TWinControlAccess(FActiveControl).OnKeyDown := FOldKeyDown;
  2889.       FActiveControl := nil;
  2890.     end;
  2891.   end;
  2892.   if Assigned(FOnMoved) then
  2893.     FOnMoved(Self);
  2894. end;
  2895.  
  2896. { TCustomControlBar }
  2897.  
  2898. type
  2899.   PDockPos = ^TDockPos;
  2900.   TDockPos = record
  2901.     Control: TControl;
  2902.     Insets: TRect;
  2903.     Visible: Boolean;
  2904.     Break: Boolean;
  2905.     Pos: TPoint;
  2906.     Width: Integer;
  2907.  
  2908.     Height: Integer;
  2909.     RowCount: Integer;
  2910.     TempRow: Integer;
  2911.     Parent: PDockPos;
  2912.     SubItem: PDockPos;
  2913.  
  2914.     TempBreak: Boolean;
  2915.     TempPos: TPoint;
  2916.     TempWidth: Integer;
  2917.   end;
  2918.  
  2919. function CreateDockPos(AControl: TControl; Break: Boolean; Visible: Boolean;
  2920.   const APos: TPoint; AWidth, AHeight: Integer; Parent: PDockPos;
  2921.   const Insets: TRect; RowCount: Integer): PDockPos;
  2922. begin
  2923.   GetMem(Result, SizeOf(TDockPos));
  2924.   Result.Control := AControl;
  2925.   Result.Insets := Insets;
  2926.   Result.Visible := Visible;
  2927.   Result.Break := Break;
  2928.   Result.Pos := APos;
  2929.   Result.Width := AWidth;
  2930.   Result.Height := AHeight;
  2931.   Result.RowCount := RowCount;
  2932.   Result.TempRow := 1;
  2933.   Result.TempBreak := Break;
  2934.   Result.TempPos := APos;
  2935.   Result.TempWidth := AWidth;
  2936.   Result.Parent := Parent;
  2937.   Result.SubItem := nil;
  2938. end;
  2939.  
  2940. procedure FreeDockPos(Items: TList; DockPos: PDockPos);
  2941. var
  2942.   Tmp: PDockPos;
  2943. begin
  2944.   { Remove all subitems }
  2945.   while DockPos <> nil do
  2946.   begin
  2947.     Tmp := DockPos;
  2948.     Items.Remove(DockPos);
  2949.     DockPos := DockPos.SubItem;
  2950.     FreeMem(Tmp, SizeOf(TDockPos));
  2951.   end;
  2952. end;
  2953.  
  2954. procedure AdjustControlRect(var ARect: TRect; const Insets: TRect);
  2955. begin
  2956.   with Insets do
  2957.   begin
  2958.     Dec(ARect.Left, Left);
  2959.     Dec(ARect.Top, Top);
  2960.     Inc(ARect.Right, Right);
  2961.     Inc(ARect.Bottom, Bottom);
  2962.   end;
  2963. end;
  2964.  
  2965. constructor TCustomControlBar.Create(AOwner: TComponent);
  2966. begin
  2967.   inherited Create(AOwner);
  2968.   ControlStyle := [csAcceptsControls, csCaptureMouse, csClickEvents,
  2969.     csDoubleClicks, csOpaque];
  2970.   Width := 100;
  2971.   Height := 50;
  2972.   FAutoDrag := True;
  2973.   FAutoDock := True;
  2974.   FItems := TList.Create;
  2975.   FPicture := TPicture.Create;
  2976.   FPicture.OnChange := PictureChanged;
  2977.   FRowSize := 26;
  2978.   FRowSnap := True;
  2979.   BevelKind := bkTile;
  2980.   DoubleBuffered := True;
  2981.   DockSite := True;
  2982. end;
  2983.  
  2984. destructor TCustomControlBar.Destroy;
  2985. var
  2986.   I: Integer;
  2987. begin
  2988.   for I := 0 to FItems.Count - 1 do
  2989.     if FItems[I] <> nil then
  2990.       FreeMem(PDockPos(FItems[I]), SizeOf(TDockPos));
  2991.   FItems.Free;
  2992.   FPicture.Free;
  2993.   inherited Destroy;
  2994. end;
  2995.  
  2996. procedure TCustomControlBar.CreateParams(var Params: TCreateParams);
  2997. begin
  2998.   inherited CreateParams(Params);
  2999.   with Params.WindowClass do
  3000.     style := style and not (CS_HREDRAW or CS_VREDRAW);
  3001. end;
  3002.  
  3003. procedure TCustomControlBar.AlignControls(AControl: TControl; var ARect: TRect);
  3004. var
  3005.   I, J, X: Integer;
  3006.   DockPos: PDockPos;
  3007.   TotalSize, RowSize, RowSpace, Shift: Integer;
  3008.   RowHeight, PrevRowHeight: Integer;
  3009.   MoveBy: Integer;
  3010.   Pos: TPoint;
  3011.   CX: Integer;
  3012.   Control: TControl;
  3013.   UseTemp: Boolean;
  3014.  
  3015.   Row: Integer;
  3016.   RowCount: Integer;
  3017.   FirstIndex, LastIndex: Integer;
  3018.   InsertingControl: Boolean;
  3019.   Dirty: Boolean;
  3020.   R: TRect;
  3021.  
  3022.   TempRowSize, TempRowSpace: Integer;
  3023.   AdjustX: Integer;
  3024.   DockRect: TRect;
  3025.   PreferredSize: Integer;
  3026.  
  3027.   TmpDockPos: PDockPos;
  3028.   Redo: PDockPos;
  3029.   RedoCount: Integer;
  3030.   SkipRedo: Boolean;
  3031.  
  3032.   function ShouldRedo(DockPos: PDockPos; const Pos: TPoint; Width: Integer): Boolean;
  3033.   begin
  3034.     { Determine whether this subitem has changed and will affect its
  3035.       parent(s). }
  3036.     if (DockPos^.Parent <> nil) and ((Pos.X <> DockPos^.Parent^.TempPos.X) or
  3037.       (Width <> DockPos^.Parent^.TempWidth)) then
  3038.     begin
  3039.       DockPos := DockPos^.Parent;
  3040.       { Update parents and re-perform align logic }
  3041.       repeat
  3042.         DockPos^.TempPos.X := Pos.X;
  3043.         DockPos^.TempWidth := Width;
  3044.         Redo := DockPos;
  3045.         DockPos := DockPos^.Parent;
  3046.       until DockPos = nil;
  3047.       Result := True;
  3048.     end
  3049.     else
  3050.       Result := False;
  3051.   end;
  3052.  
  3053. begin
  3054.   if FAligning then Exit;
  3055.   FAligning := True;
  3056.   try
  3057.     { Update items }
  3058.     InsertingControl := UpdateItems(AControl);
  3059.     if FItems.Count = 0 then Exit;
  3060.     RowCount := 0;
  3061.     FirstIndex := 0;
  3062.     LastIndex := FItems.Count - 1;
  3063.  
  3064.     { Find number of rows }
  3065.     for I := FirstIndex to LastIndex do
  3066.     begin
  3067.       DockPos := PDockPos(FItems[I]);
  3068.       { First item can't have Break set! }
  3069.       DockPos^.TempBreak := DockPos^.Break;
  3070.       if DockPos^.Break then
  3071.         Inc(RowCount);
  3072.     end;
  3073.  
  3074.     Redo := nil;
  3075.     SkipRedo := False;
  3076.     RedoCount := 2;
  3077.     repeat
  3078.  
  3079.       if Redo <> nil then
  3080.       begin
  3081.         SkipRedo := True;
  3082.         Dec(RedoCount);
  3083.       end;
  3084.       if RedoCount = 0 then Exit;
  3085.  
  3086.       RowHeight := 0;
  3087.       PrevRowHeight := 0;
  3088.       Row := 1;
  3089.  
  3090.       while Row <= RowCount do
  3091.       begin
  3092.  
  3093.         if Row = 1 then
  3094.           RowHeight := 0;
  3095.  
  3096.         { Find first and last index for current row }
  3097.         if Row = 1 then
  3098.           FirstIndex := 0
  3099.         else
  3100.           FirstIndex := LastIndex + 1;
  3101.         LastIndex := FItems.Count - 1;
  3102.         for I := FirstIndex to LastIndex - 1 do
  3103.         begin
  3104.           DockPos := PDockPos(FItems[I + 1]);
  3105.           { First item can't have Break set }
  3106.           if DockPos^.Break or DockPos^.TempBreak then
  3107.           begin
  3108.             LastIndex := I;
  3109.             Break;
  3110.           end;
  3111.         end;
  3112.  
  3113.         { Set temp values for all controls }
  3114.         TotalSize := ARect.Right - ARect.Left;
  3115.         RowSize := 0;
  3116.         RowSpace := 0;
  3117.  
  3118.         for I := FirstIndex to LastIndex do
  3119.         begin
  3120.           DockPos := PDockPos(FItems[I]);
  3121.  
  3122.           if DockPos^.Break or DockPos^.TempBreak then
  3123.           begin
  3124.             RowSize := 0;
  3125.             RowSpace := 0;
  3126.             UseTemp := False;
  3127.             if UseTemp then
  3128.               DockPos^.TempPos.Y := RowHeight else
  3129.               DockPos^.Pos.Y := RowHeight;
  3130.             PrevRowHeight := RowHeight;
  3131.           end
  3132.           else UseTemp := False;
  3133.  
  3134.           Control := DockPos^.Control;
  3135.           if (csDesigning in ComponentState) or Control.Visible then
  3136.           begin
  3137.             { If control was moved/resized, update our info }
  3138.             if DockPos^.Parent = nil then
  3139.             begin
  3140.               PreferredSize := DockPos^.Width;
  3141.               Dec(PreferredSize, DockPos^.Insets.Left + DockPos^.Insets.Right);
  3142.               GetControlInfo(Control, DockPos^.Insets, PreferredSize,
  3143.                 DockPos^.RowCount);
  3144.               DockPos^.Width := PreferredSize + DockPos^.Insets.Left +
  3145.                 DockPos^.Insets.Right;
  3146.               if not InsertingControl and (DockPos^.Parent = nil) and
  3147.                 (AControl = DockPos^.Control) then
  3148.               begin
  3149.                 if UseTemp then
  3150.                 begin
  3151.                   DockPos^.TempPos := Point(AControl.Left - ARect.Left -
  3152.                     DockPos^.Insets.Left, AControl.Top - ARect.Top - DockPos^.Insets.Top);
  3153.                   DockPos^.TempWidth := AControl.Width + DockPos^.Insets.Left +
  3154.                     DockPos^.Insets.Right;
  3155.                   DockRect := Bounds(DockPos^.TempPos.X, DockPos^.TempPos.Y,
  3156.                     DockPos^.TempWidth, DockPos^.Height);
  3157.                 end
  3158.                 else
  3159.                   DockRect := Bounds(DockPos^.Pos.X, DockPos^.Pos.Y,
  3160.                     DockPos^.Width, DockPos^.Height);
  3161.               end;
  3162.  
  3163.               { Let user adjust sizes }
  3164.               if DockPos = Redo then
  3165.                 DockRect := Bounds(DockPos^.TempPos.X, DockPos^.TempPos.Y,
  3166.                   DockPos^.TempWidth, DockPos^.Height)
  3167.               else
  3168.                 DockRect := Bounds(DockPos^.Pos.X, DockPos^.Pos.Y,
  3169.                   DockPos^.Width, DockPos^.Height);
  3170.               DoBandMove(Control, DockRect);
  3171.               DockPos^.TempWidth := DockRect.Right - DockRect.Left;
  3172.             end
  3173.             else
  3174.             begin
  3175.               { Use parent's position }
  3176.               with DockPos^.Parent^ do
  3177.               begin
  3178.                 DockPos^.Pos := Pos;
  3179.                 DockPos^.TempPos := TempPos;
  3180.                 Inc(DockPos^.Pos.Y, Height);
  3181.                 Inc(DockPos^.TempPos.Y, Height);
  3182.                 DockPos^.Width := Width;
  3183.                 DockPos^.TempWidth := TempWidth;
  3184.                 DockRect := Bounds(DockPos^.TempPos.X, DockPos^.TempPos.Y,
  3185.                   DockPos^.TempWidth, DockPos^.Height);
  3186.               end;
  3187.             end;
  3188.  
  3189.             if DockPos = Redo then
  3190.             begin
  3191.               with DockPos^ do
  3192.               begin
  3193.                 TempPos.X := DockRect.Left;
  3194.                 TempPos.Y := DockRect.Top;
  3195.                 TempWidth := DockRect.Right - DockRect.Left;
  3196.                 Redo := nil;
  3197.                 SkipRedo := False;
  3198.               end;
  3199.             end
  3200.             else
  3201.             begin
  3202.               with DockPos^ do
  3203.               begin
  3204.                 Pos.X := DockRect.Left;
  3205.                 Pos.Y := DockRect.Top;
  3206.               end;
  3207.             end;
  3208.  
  3209.             if UseTemp then
  3210.             begin
  3211.               Pos := DockPos^.TempPos;
  3212.               CX := DockPos^.TempWidth;
  3213.             end
  3214.             else
  3215.             begin
  3216.               Pos := DockRect.TopLeft;
  3217.               CX := DockRect.Right - DockRect.Left;
  3218.             end;
  3219.  
  3220.             { Make sure Pos is within bounds }
  3221.             if Pos.X < RowSize then
  3222.             begin
  3223.               { If a control is being resized/moved then adjust any controls to
  3224.                 its left }
  3225.               if (RowSpace > 0) then
  3226.               begin
  3227.                 TempRowSize := Pos.X;
  3228.                 AdjustX := Pos.X;
  3229.                 TempRowSpace := RowSpace;
  3230.                 for J := I - 1 downto FirstIndex do
  3231.                 begin
  3232.                   with PDockPos(FItems[J])^ do
  3233.                   begin
  3234.                     if (csDesigning in ComponentState) or Control.Visible then
  3235.                     begin
  3236.                       if TempPos.X + TempWidth > TempRowSize then
  3237.                       begin
  3238.                         X := TempPos.X + TempWidth - TempRowSize;
  3239.                         { Calculate adjusted rowspace }
  3240.                         if J < I - 1 then
  3241.                           Dec(TempRowSpace, AdjustX - (TempPos.X + TempWidth));
  3242.                         if X > TempRowSpace then
  3243.                           X := TempRowSpace;
  3244.                         AdjustX := TempPos.X;
  3245.                         Dec(TempPos.X, X);
  3246.                         Dec(TempRowSize, TempWidth);
  3247.  
  3248.                         TmpDockPos := PDockPos(FItems[J]);
  3249.                         if ShouldRedo(TmpDockPos, TmpDockPos^.TempPos,
  3250.                           TmpDockPos^.TempWidth) then
  3251.                           System.Break;
  3252.  
  3253.                         TmpDockPos := SubItem;
  3254.                         while TmpDockPos <> nil do
  3255.                           with TmpDockPos^ do
  3256.                           begin
  3257.                             Pos := PDockPos(FItems[J])^.Pos;
  3258.                             TempPos := PDockPos(FItems[J])^.TempPos;
  3259.                             Inc(Pos.Y, Parent.Height);
  3260.                             Inc(TempPos.Y, Parent.Height);
  3261.                             Width := PDockPos(FItems[J])^.Width;
  3262.                             TempWidth := PDockPos(FItems[J])^.TempWidth;
  3263.                             TmpDockPos := SubItem;
  3264.                           end;
  3265.  
  3266.                       end
  3267.                       else System.Break;
  3268.                     end;
  3269.                   end;
  3270.                 end;
  3271.                 AdjustX := RowSize - Pos.X;
  3272.                 if AdjustX > RowSpace then
  3273.                   AdjustX := RowSpace;
  3274.                 Dec(RowSpace, AdjustX);
  3275.                 Dec(RowSize, AdjustX);
  3276.               end;
  3277.               Pos.X := RowSize;
  3278.             end;
  3279.  
  3280.             if (Redo <> nil) and not SkipRedo then Break;
  3281.  
  3282.             if Pos.Y <> PrevRowHeight then
  3283.               Pos.Y := PrevRowHeight;
  3284.  
  3285.             if Pos.Y + DockPos^.Height > RowHeight then
  3286.               RowHeight := Pos.Y + DockPos^.Height;
  3287.  
  3288.             Inc(RowSpace, Pos.X - RowSize);
  3289.             Inc(RowSize, Pos.X - RowSize + CX);
  3290.  
  3291.             if DockPos^.Parent = nil then
  3292.             begin
  3293.               DockPos^.TempPos := Pos;
  3294.               DockPos^.TempWidth := CX;
  3295.             end
  3296.             else
  3297.             begin
  3298.               if ShouldRedo(DockPos, Pos, CX) then
  3299.                 System.Break
  3300.               else if not DockPos^.Break and (DockPos^.TempPos.X < Pos.X) then
  3301.               begin
  3302.                 DockPos^.TempPos := Pos;
  3303.                 DockPos^.TempWidth := CX;
  3304.               end;
  3305.             end;
  3306.  
  3307.             TmpDockPos := DockPos^.SubItem;
  3308.             while TmpDockPos <> nil do
  3309.               with TmpDockPos^ do
  3310.               begin
  3311.                 Pos := DockPos^.Pos;
  3312.                 TempPos := DockPos^.TempPos;
  3313.                 Inc(Pos.Y, Parent.Height);
  3314.                 Inc(TempPos.Y, Parent.Height);
  3315.                 Width := DockPos^.Width;
  3316.                 TempWidth := DockPos^.TempWidth;
  3317.                 TmpDockPos := SubItem;
  3318.               end;
  3319.           end;
  3320.         end;
  3321.  
  3322.         if (Redo <> nil) and not SkipRedo then Break;
  3323.  
  3324.         { Determine whether controls on this row can fit }
  3325.         Shift := TotalSize - RowSize;
  3326.         if Shift < 0 then
  3327.         begin
  3328.           TotalSize := ARect.Right - ARect.Left;
  3329.           { Try to move all controls to fill space }
  3330.           AdjustX := RowSize;
  3331.           TempRowSpace := RowSpace;
  3332.           for I := LastIndex downto FirstIndex do
  3333.           begin
  3334.             DockPos := PDockPos(FItems[I]);
  3335.             Control := DockPos^.Control;
  3336.             if (csDesigning in ComponentState) or Control.Visible then
  3337.             begin
  3338.               if (DockPos^.TempPos.X + DockPos^.TempWidth) > TotalSize then
  3339.               begin
  3340.                 MoveBy := (DockPos^.TempPos.X + DockPos^.TempWidth) - TotalSize;
  3341.                 if I < LastIndex then
  3342.                   Dec(TempRowSpace, AdjustX - (DockPos^.TempPos.X +
  3343.                     DockPos^.TempWidth));
  3344.                 if MoveBy <= TempRowSpace then
  3345.                   Shift := MoveBy else
  3346.                   Shift := TempRowSpace;
  3347.                 if Shift <= TempRowSpace then
  3348.                 begin
  3349.                   AdjustX := DockPos^.TempPos.X;
  3350.                   Dec(DockPos^.TempPos.X, Shift);
  3351.                   Dec(TotalSize, DockPos^.TempWidth);
  3352.  
  3353.                   if ShouldRedo(DockPos, DockPos^.TempPos, DockPos^.TempWidth) then
  3354.                     Break;
  3355.  
  3356.                   TmpDockPos := DockPos^.SubItem;
  3357.                   while TmpDockPos <> nil do
  3358.                     with TmpDockPos^ do
  3359.                     begin
  3360.                       TempPos := DockPos^.TempPos;
  3361.                       Inc(TempPos.Y, Parent.Height);
  3362.                       TmpDockPos := SubItem;
  3363.                     end;
  3364.                 end
  3365.                 else
  3366.                   Break;
  3367.               end;
  3368.             end;
  3369.           end;
  3370.  
  3371.           if (Redo <> nil) and not SkipRedo then Break;
  3372.  
  3373.           { Try to minimize all controls to fill space }
  3374.           if TotalSize < 0 then
  3375.           begin
  3376.             TotalSize := ARect.Right - ARect.Left;
  3377.             for I := LastIndex downto FirstIndex do
  3378.             begin
  3379.               DockPos := PDockPos(FItems[I]);
  3380.               Control := DockPos^.Control;
  3381.               if (csDesigning in ComponentState) or Control.Visible then
  3382.               begin
  3383.                 if DockPos^.TempPos.X + DockPos^.TempWidth > TotalSize then
  3384.                 begin
  3385.                   { Try to minimize control, move if it can't be resized }
  3386.                   DockPos^.TempWidth := DockPos^.TempWidth -
  3387.                     ((DockPos^.TempPos.X + DockPos^.TempWidth) - TotalSize);
  3388.                   if DockPos^.TempWidth < Control.Constraints.MinWidth +
  3389.                     DockPos^.Insets.Left + DockPos^.Insets.Right then
  3390.                     DockPos^.TempWidth := Control.Constraints.MinWidth +
  3391.                       DockPos^.Insets.Left + DockPos^.Insets.Right;
  3392.                   { Move control }
  3393.                   if DockPos^.TempPos.X + DockPos^.TempWidth > TotalSize then
  3394.                   begin
  3395.                     Dec(DockPos^.TempPos.X, (DockPos^.TempPos.X +
  3396.                       DockPos^.TempWidth) - TotalSize);
  3397.                     if DockPos^.TempPos.X < ARect.Left then
  3398.                       DockPos^.TempPos.X := ARect.Left;
  3399.                   end;
  3400.  
  3401.                   if ShouldRedo(DockPos, DockPos^.TempPos, DockPos^.TempWidth) then
  3402.                     Break;
  3403.  
  3404.                   TmpDockPos := DockPos^.SubItem;
  3405.                   while TmpDockPos <> nil do
  3406.                     with TmpDockPos^ do
  3407.                     begin
  3408.                       Pos := DockPos^.Pos;
  3409.                       TempPos := DockPos^.TempPos;
  3410.                       Inc(TempPos.Y, Parent.Height);
  3411.                       TempWidth := DockPos^.TempWidth;
  3412.                       TmpDockPos := SubItem;
  3413.                     end;
  3414.                 end;
  3415.                 Dec(TotalSize, DockPos^.TempWidth);
  3416.               end;
  3417.             end;
  3418.           end;
  3419.  
  3420.           if (Redo <> nil) and not SkipRedo then Break;
  3421.  
  3422.           { Done with first pass at minimizing. If we're still cramped for
  3423.             space then wrap last control if there are more than 1 controls on
  3424.             this row. }
  3425.           if (TotalSize < 0) and (FirstIndex <> LastIndex) then
  3426.           begin
  3427.             DockPos := PDockPos(FItems[LastIndex]);
  3428.             DockPos^.TempPos.X := 0;
  3429.             DockPos^.TempWidth := DockPos^.Width;
  3430.             DockPos^.TempBreak := True;
  3431.             Inc(RowCount);
  3432.  
  3433.             if ShouldRedo(DockPos, DockPos^.TempPos, DockPos^.TempWidth) then
  3434.               Break;
  3435.  
  3436.             TmpDockPos := DockPos^.SubItem;
  3437.             while TmpDockPos <> nil do
  3438.               with TmpDockPos^ do
  3439.               begin
  3440.                 TempPos := DockPos^.TempPos;
  3441.                 Inc(TempPos.Y, Parent.Height);
  3442.                 TempWidth := DockPos^.TempWidth;
  3443.                 TmpDockPos := SubItem;
  3444.               end;
  3445.           end
  3446.           else
  3447.             Inc(Row);
  3448.         end
  3449.         else
  3450.           Inc(Row);
  3451.  
  3452.       end;
  3453.  
  3454.     until Redo = nil;
  3455.  
  3456.     { Now position controls }
  3457.     for I := 0 to FItems.Count - 1 do
  3458.     begin
  3459.       DockPos := PDockPos(FItems[I]);
  3460.       with DockPos^ do
  3461.         if (Parent = nil) and ((csDesigning in ComponentState) or
  3462.           Control.Visible) then
  3463.         begin
  3464.           with Insets do
  3465.             R := Rect(Left + TempPos.X, Top + TempPos.Y,
  3466.               TempPos.X + TempWidth - Right,
  3467.               TempPos.Y + DockPos^.Height - Bottom);
  3468.           TmpDockPos := SubItem;
  3469.           while TmpDockPos <> nil do
  3470.           begin
  3471.             Inc(R.Bottom, TmpDockPos^.Height);
  3472.             TmpDockPos := TmpDockPos^.SubItem;
  3473.           end;
  3474.           if (R.Left <> Control.Left) or (R.Top <> Control.Top) or
  3475.             (R.Right - R.Left <> Control.Width) or
  3476.             (R.Bottom - R.Top <> Control.Height) then
  3477.           begin
  3478.             Dirty := True;
  3479.             Control.BoundsRect := R;
  3480.           end;
  3481.         end;
  3482.     end;
  3483.     if Dirty or (AControl <> nil) then Invalidate;
  3484.     { Apply any constraints }
  3485.     AdjustSize;
  3486.   finally
  3487.     FAligning := False;
  3488.   end;
  3489. end;
  3490.  
  3491. const
  3492.   DefaultInsets: TRect = (Left: 11; Top: 2; Right: 2; Bottom: 2);
  3493.  
  3494. function TCustomControlBar.UpdateItems(AControl: TControl): Boolean;
  3495. var
  3496.   I, J, Tmp, RepositionIndex: Integer;
  3497.   PrevBreak: Boolean;
  3498.   Control: TControl;
  3499.   Exists: Boolean;
  3500.   AddControls: TList;
  3501.   DockRect, R: TRect;
  3502.   Dirty: Boolean;
  3503.   IsVisible: Boolean;
  3504.   DockPos, TmpDockPos1, TmpDockPos2: PDockPos;
  3505.   BreakList: TList;
  3506.   IndexList: TList;
  3507.   SizeList: TList;
  3508.   ChangedPriorBreak: Boolean;
  3509.  
  3510.   procedure AddControl(List: TList; Control: TControl);
  3511.   var
  3512.      I: Integer;
  3513.   begin
  3514.     for I := 0 to List.Count - 1 do
  3515.       with TControl(List[I]) do
  3516.         if (Control.Top < Top) or (Control.Top = Top) and
  3517.           (Control.Left < Left) then
  3518.         begin
  3519.           List.Insert(I, Control);
  3520.           Exit;
  3521.         end;
  3522.     List.Add(Control);
  3523.   end;
  3524.  
  3525. begin
  3526.   Result := False;
  3527.   ChangedPriorBreak := False;
  3528.   AddControls := TList.Create;
  3529.   BreakList := TList.Create;
  3530.   IndexList := TList.Create;
  3531.   SizeList := TList.Create;
  3532.   try
  3533.     AddControls.Capacity := ControlCount;
  3534.     RepositionIndex := -1;
  3535.     Dirty := False;
  3536.     for I := 0 to ControlCount - 1 do
  3537.     begin
  3538.       Control := Controls[I];
  3539.       IsVisible := (csDesigning in ComponentState) or Control.Visible;
  3540.       Exists := False;
  3541.       for J := 0 to FItems.Count - 1 do
  3542.         if (PDockPos(FItems[J])^.Parent = nil) and
  3543.           (PDockPos(FItems[J])^.Control = Control) then
  3544.         begin
  3545.           Dirty := Dirty or PDockPos(FItems[J])^.Visible <> IsVisible;
  3546.           PDockPos(FItems[J])^.Visible := IsVisible;
  3547.           Exists := True;
  3548.           Break;
  3549.         end;
  3550.       if Exists and (Control = AControl) then
  3551.       begin
  3552.         RepositionIndex := J;
  3553.         DockPos := PDockPos(FItems[J]);
  3554.         with DockPos^ do
  3555.         begin
  3556.           SizeList.Add(TObject(Insets.Top + Insets.Bottom));
  3557.           if FDragControl <> nil then
  3558.             DockRect := Rect(Pos.X + Insets.Left, Pos.Y + Insets.Top,
  3559.               Pos.X + Width - Insets.Right, Pos.Y + Insets.Top + Control.Height)
  3560.           else
  3561.             DockRect := Control.BoundsRect;
  3562.           PrevBreak := Break;
  3563.         end;
  3564.         { If we were starting a row, then update any items to the right to
  3565.           begin starting the row. }
  3566.         if PrevBreak and (J + 1 < FItems.Count) then
  3567.         begin
  3568.           TmpDockPos1 := FItems[J + 1];
  3569.           if not TmpDockPos1.Break then
  3570.           begin
  3571.             TmpDockPos1.Break := True;
  3572.             TmpDockPos1.TempBreak := True;
  3573.             ChangedPriorBreak := True;
  3574.           end;
  3575.         end;
  3576.  
  3577.         { Remember the state of this item and its subitems }
  3578.         BreakList.Add(TObject(Ord(PrevBreak)));
  3579.         IndexList.Add(TObject(J));
  3580.         TmpDockPos1 := DockPos^.SubItem;
  3581.         while TmpDockPos1 <> nil do
  3582.         begin
  3583.           Tmp := FItems.IndexOf(TmpDockPos1);
  3584.           BreakList.Add(TObject(Ord(TmpDockPos1.Break)));
  3585.           IndexList.Add(TObject(Tmp));
  3586.           with TmpDockPos1^ do
  3587.             SizeList.Add(TObject(Insets.Top + Insets.Bottom));
  3588.           { If we were starting a row, then update any items to the right to
  3589.             begin starting the row. }
  3590.           if TmpDockPos1.Break then
  3591.           begin
  3592.             if Tmp + 1 < FItems.Count then
  3593.             begin
  3594.               TmpDockPos2 := FItems[Tmp + 1];
  3595.               if not TmpDockPos2.Break then
  3596.                 TmpDockPos2.Break := True;
  3597.             end;
  3598.           end;
  3599.           TmpDockPos1 := TmpDockPos1^.SubItem;
  3600.         end;
  3601.  
  3602.         { Remove this item from consideration in DockControl. It's as if we are
  3603.           adding a new control. }
  3604.         FreeDockPos(FItems, DockPos);
  3605.       end
  3606.       else if not Exists then
  3607.       begin
  3608.         if Control = AControl then Result := True;
  3609.         AddControl(AddControls, Control);
  3610.       end;
  3611.     end;
  3612.     for I := 0 to AddControls.Count - 1 do
  3613.     begin
  3614.       R := TControl(AddControls[I]).BoundsRect;
  3615.       DockControl(TControl(AddControls[I]), R, BreakList, IndexList, SizeList,
  3616.         nil, ChangedPriorBreak, DefaultInsets, -1, -1, False);
  3617.     end;
  3618.     if RepositionIndex >= 0 then
  3619.       DockControl(AControl, DockRect, BreakList, IndexList, SizeList, nil,
  3620.         ChangedPriorBreak, DefaultInsets, -1, -1, True);
  3621.     if Dirty then Invalidate;
  3622.   finally
  3623.     AddControls.Free;
  3624.     BreakList.Free;
  3625.     IndexList.Free;
  3626.     SizeList.Free;
  3627.   end;
  3628. end;
  3629.  
  3630. procedure TCustomControlBar.SetRowSize(Value: TRowSize);
  3631. begin
  3632.   if Value <> RowSize then
  3633.   begin
  3634.     FRowSize := Value;
  3635.   end;
  3636. end;
  3637.  
  3638. procedure TCustomControlBar.SetRowSnap(Value: Boolean);
  3639. begin
  3640.   if Value <> RowSnap then
  3641.   begin
  3642.     FRowSnap := Value;
  3643.   end;
  3644. end;
  3645.  
  3646. procedure TCustomControlBar.FlipChildren(AllLevels: Boolean);
  3647. begin
  3648.   { Do not flip controls }
  3649. end;
  3650.  
  3651. procedure TCustomControlBar.StickControls;
  3652. var
  3653.   I: Integer;
  3654. begin
  3655.   for I := 0 to FItems.Count - 1 do
  3656.     if FItems[I] <> nil then
  3657.       with PDockPos(FItems[I])^ do
  3658.       begin
  3659.         if Parent <> nil then
  3660.           Pos := Point(Parent^.Pos.X, Parent^.Pos.Y + Parent.Height)
  3661.         else
  3662.         begin
  3663.           Pos := Control.BoundsRect.TopLeft;
  3664.           Dec(Pos.X, Insets.Left);
  3665.           Dec(Pos.Y, Insets.Top);
  3666.         end;
  3667.         Width := Control.Width + Insets.Left + Insets.Right;
  3668.         Break := TempBreak;
  3669.       end;
  3670. end;
  3671.  
  3672. function TCustomControlBar.CanAutoSize(var NewWidth, NewHeight: Integer): Boolean;
  3673. var
  3674.   I: Integer;
  3675.   DockPos: PDockPos;
  3676. begin
  3677.   Result := True;
  3678.   if HandleAllocated and (not (csDesigning in ComponentState) or
  3679.     (ControlCount > 0)) then
  3680.   begin
  3681.     if Align in [alLeft, alRight] then
  3682.     begin
  3683.       NewWidth := 0;
  3684.       for I := 0 to FItems.Count - 1 do
  3685.       begin
  3686.         DockPos := PDockPos(FItems[I]);
  3687.         with DockPos^ do
  3688.         begin
  3689.           if (Parent = nil) and ((csDesigning in ComponentState) or Control.Visible) then
  3690.           begin
  3691.             if TempPos.X + Control.Width + Insets.Left + Insets.Right > NewWidth then
  3692.               NewWidth := TempPos.X + Control.Width + Insets.Left + Insets.Right;
  3693.           end;
  3694.         end;
  3695.       end;
  3696.       Inc(NewWidth, Width - ClientWidth);
  3697.     end
  3698.     else
  3699.     begin
  3700.       NewHeight := 0;
  3701.       for I := 0 to FItems.Count - 1 do
  3702.       begin
  3703.         DockPos := PDockPos(FItems[I]);
  3704.         with DockPos^ do
  3705.         begin
  3706.           if (Parent = nil) and ((csDesigning in ComponentState) or Control.Visible) then
  3707.           begin
  3708.             if TempPos.Y + Control.Height + Insets.Top + Insets.Bottom > NewHeight then
  3709.               NewHeight := TempPos.Y + Control.Height + Insets.Top + Insets.Bottom;
  3710.           end;
  3711.         end;
  3712.       end;
  3713.       Inc(NewHeight, Height - ClientHeight);
  3714.     end;
  3715.   end;
  3716. end;
  3717.  
  3718. procedure TCustomControlBar.DockControl(AControl: TControl;
  3719.   const ARect: TRect; BreakList, IndexList, SizeList: TList; Parent: Pointer;
  3720.   ChangedPriorBreak: Boolean; Insets: TRect; PreferredSize, RowCount: Integer;
  3721.   Existing: Boolean);
  3722. var
  3723.   I, InsPos, Size, TotalSize: Integer;
  3724.   DockPos: PDockPos;
  3725.   MidPoint: TPoint;
  3726.   NewControlRect, ControlRect: TRect;
  3727.   IsVisible, DockBreak: Boolean;
  3728.   PrevBreak: Boolean;
  3729.   PrevIndex: Integer;
  3730.   NewHeight, PrevInsetHeight: Integer;
  3731.   NewLine: Boolean;
  3732.  
  3733.   procedure AddItem;
  3734.   var
  3735.     DockPos: PDockPos;
  3736.     H: Integer;
  3737.   begin
  3738.     if InsPos = 0 then DockBreak := True;
  3739.     if (PrevIndex <> InsPos) or ChangedPriorBreak then
  3740.     begin
  3741.       if DockBreak and (InsPos < FItems.Count) then
  3742.       begin
  3743.         DockPos := FItems[InsPos];
  3744.         if not NewLine and DockPos^.Break then
  3745.         begin
  3746.           DockPos^.Break := False;
  3747.           DockPos^.TempBreak := False;
  3748.         end;
  3749.       end;
  3750.     end;
  3751.     if RowSnap then
  3752.       H := RowSize else
  3753.       H := NewControlRect.Bottom - NewControlRect.Top;
  3754.     DockPos := CreateDockPos(AControl, DockBreak, IsVisible,
  3755.       NewControlRect.TopLeft, NewControlRect.Right - NewControlRect.Left,
  3756.       H, Parent, Insets, RowCount);
  3757.     if Parent <> nil then
  3758.       PDockPos(Parent).SubItem := DockPos;
  3759.     FItems.Insert(InsPos, DockPos);
  3760.     { If we're adding an item that spans more than one row, we need to add
  3761.       pseudo items which are linked to this item. }
  3762.     if RowCount > 1 then
  3763.     begin
  3764.       Dec(RowCount);
  3765.       Inc(NewControlRect.Top, RowSize);
  3766.       DockControl(AControl, NewControlRect, BreakList, IndexList, SizeList,
  3767.         DockPos, False, Insets, PreferredSize, RowCount, False);
  3768.     end;
  3769.   end;
  3770.  
  3771. begin
  3772.   FDockingControl := AControl;
  3773.   if BreakList.Count > 0 then
  3774.   begin
  3775.     PrevBreak := Boolean(BreakList[0]);
  3776.     BreakList.Delete(0);
  3777.   end
  3778.   else
  3779.     PrevBreak := False;
  3780.   if IndexList.Count > 0 then
  3781.   begin
  3782.     PrevIndex := Integer(IndexList[0]);
  3783.     IndexList.Delete(0);
  3784.   end
  3785.   else
  3786.     PrevIndex := -1;
  3787.   if SizeList.Count > 0 then
  3788.   begin
  3789.     PrevInsetHeight := Integer(SizeList[0]);
  3790.     SizeList.Delete(0);
  3791.   end
  3792.   else
  3793.     PrevInsetHeight := -1;
  3794.  
  3795.   InsPos := 0;
  3796.   Size := -MaxInt;
  3797.   TotalSize := -MaxInt;
  3798.  
  3799.   NewControlRect := ARect;
  3800.   if RowCount < 0 then
  3801.     with AControl do
  3802.     begin
  3803.       PreferredSize := ARect.Right - ARect.Left;
  3804.       Insets := DefaultInsets;
  3805.       if PrevInsetHeight < 0 then
  3806.         PrevInsetHeight := Insets.Top + Insets.Bottom;
  3807.       { Try to fit control into row size }
  3808.       NewHeight := PrevInsetHeight + NewControlRect.Bottom - NewControlRect.Top;
  3809.       if RowSnap then
  3810.       begin
  3811.         RowCount := NewHeight div RowSize;
  3812.         if RowCount = 0 then
  3813.           Inc(RowCount);
  3814.         if Existing and (NewHeight > RowSize * RowCount) then
  3815.           Inc(RowCount);
  3816.       end
  3817.       else
  3818.         RowCount := 1;
  3819.       GetControlInfo(AControl, Insets, PreferredSize, RowCount);
  3820.       if RowCount = 0 then RowCount := 1;
  3821.       if RowSnap and Existing and (NewHeight > RowSize * RowCount) then
  3822.         RowCount := NewHeight div RowSize + 1;
  3823.       NewControlRect.Right := NewControlRect.Left + PreferredSize;
  3824.       AdjustControlRect(NewControlRect, Insets);
  3825.       if RowSnap then
  3826.         NewControlRect.Bottom := NewControlRect.Top + RowSize * RowCount;
  3827.     end;
  3828.  
  3829.   IsVisible := (csDesigning in Self.ComponentState) or AControl.Visible;
  3830.   MidPoint.Y := NewControlRect.Top + RowSize div 2;
  3831.   DockBreak := False;
  3832.   NewLine := False;
  3833.  
  3834.   for I := 0 to FItems.Count - 1 do
  3835.   begin
  3836.     DockPos := PDockPos(FItems[I]);
  3837.     ControlRect := Rect(DockPos^.Pos.X, DockPos^.Pos.Y, DockPos^.Pos.X +
  3838.       DockPos^.Width, DockPos^.Pos.Y + DockPos^.Height );
  3839.     with ControlRect do
  3840.     begin
  3841.       if Bottom - Top > Size then
  3842.         Size := Bottom - Top;
  3843.       if Bottom > TotalSize then
  3844.         TotalSize := Bottom;
  3845.  
  3846.       if (NewControlRect.Left > Left) and (MidPoint.Y > Top) then
  3847.       begin
  3848.         DockBreak := False;
  3849.         InsPos := I + 1;
  3850.       end;
  3851.     end;
  3852.  
  3853.     if (I = FItems.Count - 1) or ((I + 1 = PrevIndex) and (PrevBreak)) or
  3854.       PDockPos(FItems[I + 1])^.Break then
  3855.     begin
  3856.       if MidPoint.Y < TotalSize then
  3857.       begin
  3858.         NewLine := (InsPos = 0) and (MidPoint.Y < ControlRect.Top);
  3859.         AddItem;
  3860.         Exit;
  3861.       end
  3862.       else
  3863.       begin
  3864.         DockBreak := (ControlRect.Left > NewControlRect.Left) or
  3865.           ((DockPos^.SubItem = nil));
  3866.         InsPos := I + 1;
  3867.       end;
  3868.       if RowSnap then
  3869.         Size := RowSize else
  3870.         Size := 0;
  3871.     end;
  3872.   end;
  3873.   AddItem;
  3874. end;
  3875.  
  3876. procedure TCustomControlBar.UnDockControl(AControl: TControl);
  3877. var
  3878.   I: Integer;
  3879.   DockPos: PDockPos;
  3880. begin
  3881.   FDockingControl := AControl;
  3882.   for I := 0 to FItems.Count - 1 do
  3883.   begin
  3884.     DockPos := PDockPos(FItems[I]);
  3885.     if DockPos^.Control = AControl then
  3886.     begin
  3887.       if DockPos^.Break and (I < FItems.Count - 1) then
  3888.         PDockPos(FItems[I + 1])^.Break := True;
  3889.       FreeDockPos(FItems, DockPos);
  3890.       Break;
  3891.     end;
  3892.   end;
  3893. end;
  3894.  
  3895. procedure TCustomControlBar.GetControlInfo(AControl: TControl; var Insets: TRect;
  3896.   var PreferredSize, RowCount: Integer);
  3897. begin
  3898.   if RowCount = 0 then RowCount := 1;
  3899.   if Assigned(FOnBandInfo) then FOnBandInfo(Self, AControl, Insets,
  3900.     PreferredSize, RowCount);
  3901. end;
  3902.  
  3903. procedure TCustomControlBar.PaintControlFrame(Canvas: TCanvas; AControl: TControl;
  3904.   var ARect: TRect);
  3905. const
  3906.   Offset = 3;
  3907. var
  3908.   R: TRect;
  3909.   Options: TBandPaintOptions;
  3910.  
  3911.   procedure DrawGrabber;
  3912.   begin
  3913.     with Canvas, R do
  3914.     begin
  3915.       Pen.Color := clBtnHighlight;
  3916.       MoveTo(R.Left+2, R.Top);
  3917.       LineTo(R.Left, R.Top);
  3918.       LineTo(R.Left, R.Bottom+1);
  3919.       Pen.Color := clBtnShadow;
  3920.       MoveTo(R.Right, R.Top);
  3921.       LineTo(R.Right, R.Bottom);
  3922.       LineTo(R.Left, R.Bottom);
  3923.     end;
  3924.   end;
  3925.  
  3926. begin
  3927.   Options := [bpoGrabber, bpoFrame];
  3928.   DoBandPaint(AControl, Canvas, ARect, Options);
  3929.   with Canvas do
  3930.   begin
  3931.     if bpoFrame in Options then
  3932.       DrawEdge(Handle, ARect, BDR_RAISEDINNER, BF_RECT);
  3933.     if bpoGrabber in Options then
  3934.     begin
  3935.       R := Rect(ARect.Left + Offset, ARect.Top + 2, ARect.Left + Offset + 2,
  3936.         ARect.Bottom - 3);
  3937.       DrawGrabber;
  3938.       OffsetRect(R, 3, 0);
  3939.       DrawGrabber;
  3940.     end;
  3941.   end;
  3942. end;
  3943.  
  3944. procedure TCustomControlBar.Paint;
  3945. var
  3946.   I: Integer;
  3947.   DockPos: PDockPos;
  3948.   Control: TControl;
  3949.   R: TRect;
  3950. begin
  3951.   with Canvas do
  3952.   begin
  3953.     if Assigned(FOnPaint) then FOnPaint(Self);
  3954.     { Draw grabbers and frames for each control }
  3955.     for I := 0 to FItems.Count - 1 do
  3956.     begin
  3957.       DockPos := PDockPos(FItems[I]);
  3958.       Control := DockPos^.Control;
  3959.       if (DockPos^.Parent = nil) and ((csDesigning in ComponentState) or
  3960.         Control.Visible) then
  3961.       begin
  3962.         R := Control.BoundsRect;
  3963.         with DockPos^.Insets do
  3964.         begin
  3965.           Dec(R.Left, Left);
  3966.           Dec(R.Top, Top);
  3967.           Inc(R.Right, Right);
  3968.           Inc(R.Bottom, Bottom);
  3969.         end;
  3970.         PaintControlFrame(Canvas, Control, R);
  3971.       end;
  3972.     end;
  3973.   end;
  3974. end;
  3975.  
  3976. function TCustomControlBar.HitTest(X, Y: Integer): TControl;
  3977. var
  3978.   DockPos: PDockPos;
  3979. begin
  3980.   DockPos := HitTest2(X, Y);
  3981.   if DockPos <> nil then
  3982.     Result := DockPos^.Control else
  3983.     Result := nil;
  3984. end;
  3985.  
  3986. function TCustomControlBar.HitTest2(X, Y: Integer): Pointer;
  3987. var
  3988.   I: Integer;
  3989.   R: TRect;
  3990. begin
  3991.   for I := 0 to FItems.Count - 1 do
  3992.   begin
  3993.     Result := PDockPos(FItems[I]);
  3994.     with PDockPos(Result)^ do
  3995.       if (Parent = nil) and ((csDesigning in ComponentState) or
  3996.         Control.Visible) then
  3997.       begin
  3998.         R := Control.BoundsRect;
  3999.         with Insets do
  4000.         begin
  4001.           Dec(R.Left, Left);
  4002.           Dec(R.Top, Top);
  4003.           Inc(R.Right, Right);
  4004.           Inc(R.Bottom, Bottom);
  4005.         end;
  4006.         if PtInRect(R, Point(X, Y)) then Exit;
  4007.       end;
  4008.   end;
  4009.   Result := nil;
  4010. end;
  4011.  
  4012. procedure TCustomControlBar.DoAlignControl(AControl: TControl);
  4013. var
  4014.   Rect: TRect;
  4015. begin
  4016.   if not HandleAllocated or (csDestroying in ComponentState) then Exit;
  4017.   DisableAlign;
  4018.   try
  4019.     Rect := GetClientRect;
  4020.     AlignControls(AControl, Rect);
  4021.   finally
  4022.     ControlState := ControlState - [csAlignmentNeeded];
  4023.     EnableAlign;
  4024.   end;
  4025. end;
  4026.  
  4027. procedure TCustomControlBar.CNKeyDown(var Message: TWMKeyDown);
  4028. var
  4029.   DockPos: PDockPos;
  4030.   P: TPoint;
  4031. begin
  4032.   inherited;
  4033.   if (Message.CharCode = VK_CONTROL) and not (csDesigning in ComponentState) and
  4034.     AutoDrag and (FDragControl <> nil) then
  4035.   begin
  4036.     DockPos := FindPos(FDragControl);
  4037.     if (DockPos <> nil) and (DockPos^.Control <> nil) then
  4038.       with DockPos^ do
  4039.       begin
  4040.         GetCursorPos(P);
  4041.         MapWindowPoints(0, Handle, P, 1);
  4042.         DragControl(Control, P.X, P.Y, True);
  4043.         Exit;
  4044.       end;
  4045.   end;
  4046. end;
  4047.  
  4048. procedure TCustomControlBar.MouseDown(Button: TMouseButton; Shift: TShiftState;
  4049.   X, Y: Integer);
  4050. var
  4051.   DockPos: PDockPos;
  4052.  
  4053.   procedure ResetDockItems;
  4054.   var
  4055.     I: Integer;
  4056.   begin
  4057.     for I := FItems.Count - 1 downto 0 do
  4058.       FreeMem(PDockPos(FItems[I]), SizeOf(TDockPos));
  4059.     FItems.Clear;
  4060.     FDragControl := nil;
  4061.     FDockingControl := nil;
  4062.     DoAlignControl(nil);
  4063.   end;
  4064.  
  4065. begin
  4066.   inherited MouseDown(Button, Shift, X, Y);
  4067.   if MouseCapture then
  4068.   begin
  4069.     ResetDockItems;
  4070.     if FDragControl <> nil then
  4071.       DockPos := FindPos(FDragControl) else
  4072.       DockPos := HitTest2(X, Y);
  4073.     if (DockPos <> nil) and (not (ssDouble in Shift) or not (AutoDrag or
  4074.       (ssDouble in Shift)) or (csDesigning in ComponentState) or
  4075.       not DragControl(DockPos^.Control, X, Y, False)) then
  4076.     begin
  4077.       FDragControl := DockPos^.Control;
  4078.       if FDockingControl = FDragControl then
  4079.         FDockingControl := nil
  4080.       else
  4081.         StickControls;
  4082.       FDragOffset := Point(DockPos^.TempPos.X - X, DockPos^.TempPos.Y - Y);
  4083.     end;
  4084.   end;
  4085. end;
  4086.  
  4087. procedure TCustomControlBar.MouseMove(Shift: TShiftState; X, Y: Integer);
  4088. var
  4089.   DockPos: PDockPos;
  4090.   Delta: Integer;
  4091. begin
  4092.   inherited MouseMove(Shift, X, Y);
  4093.   if MouseCapture then
  4094.   begin
  4095.     if FDragControl <> nil then
  4096.     begin
  4097.       DockPos := FindPos(FDragControl);
  4098.       if DockPos <> nil then
  4099.         with DockPos^ do
  4100.         begin
  4101.           Pos.X := X + FDragOffset.X;
  4102.           Pos.Y := Y + FDragOffset.Y;
  4103.           TempPos := Pos;
  4104.           TempWidth := Control.Width + Insets.Left + Insets.Right;
  4105.           { Detect a float operation }
  4106.           if not (csDesigning in ComponentState) and AutoDrag then
  4107.           begin
  4108.             Delta := Control.Height;
  4109.             if (Pos.X < -Delta) or (Pos.Y < -Delta) or
  4110.               (Pos.X > ClientWidth + Delta) or (Pos.Y > ClientHeight + Delta) then
  4111.             begin
  4112.               if DragControl(Control, X, Y, True) then Exit;
  4113.             end;
  4114.           end;
  4115.           DoAlignControl(Control);
  4116.         end;
  4117.     end;
  4118.   end;
  4119. end;
  4120.  
  4121. procedure TCustomControlBar.MouseUp(Button: TMouseButton; Shift: TShiftState; X,
  4122.   Y: Integer);
  4123. var
  4124.   Control: TControl;
  4125. begin
  4126.   if FDragControl <> nil then
  4127.   begin
  4128.     Control := FDragControl;
  4129.     FDragControl := nil;
  4130.     if FDockingControl = Control then
  4131.       FDockingControl := nil
  4132.     else
  4133.       StickControls;
  4134.   end;
  4135.   inherited MouseUp(Button, Shift, X, Y);
  4136. end;
  4137.  
  4138. function TCustomControlBar.FindPos(AControl: TControl): Pointer;
  4139. var
  4140.   I: Integer;
  4141. begin
  4142.   for I := 0 to FItems.Count - 1 do
  4143.     with PDockPos(FItems[I])^ do
  4144.     begin
  4145.       if (Parent = nil) and (Control = AControl) then
  4146.       begin
  4147.         Result := FItems[I];
  4148.         Exit;
  4149.       end;
  4150.     end;
  4151.   Result := nil;
  4152. end;
  4153.  
  4154. function TCustomControlBar.DragControl(AControl: TControl; X, Y: Integer;
  4155.   KeepCapture: Boolean): Boolean;
  4156. begin
  4157.   Result := True;
  4158.   if (AControl <> nil) and Assigned(FOnBandDrag) then
  4159.     FOnBandDrag(Self, AControl, Result);
  4160.   if Result then
  4161.     AControl.BeginDrag(True);
  4162. end;
  4163.  
  4164. procedure TCustomControlBar.DockOver(Source: TDragDockObject; X, Y: Integer;
  4165.   State: TDragState; var Accept: Boolean);
  4166. begin
  4167.   inherited DockOver(Source, X, Y, State, Accept);
  4168.   if AutoDrag and Accept and ((State = dsDragEnter) and AutoDock)
  4169.   and Source.Control.Floating then
  4170.   begin
  4171.     FDragControl := Source.Control;
  4172.     FDragControl.EndDrag(True);
  4173.     PostMessage(Handle, WM_LBUTTONDOWN, MK_LBUTTON, MakeLong(FDragControl.Left,
  4174.       FDragControl.Top));
  4175.   end;
  4176. end;
  4177.  
  4178. procedure TCustomControlBar.GetSiteInfo(Client: TControl; var InfluenceRect: TRect;
  4179.   MousePos: TPoint; var CanDock: Boolean);
  4180. begin
  4181.   inherited GetSiteInfo(Client, InfluenceRect, MousePos, CanDock);
  4182.   CanDock := CanDock and not FFloating;
  4183. end;
  4184.  
  4185. procedure TCustomControlBar.DoBandMove(Control: TControl; var ARect: TRect);
  4186. begin
  4187.   if Assigned(FOnBandMove) then FOnBandMove(Self, Control, ARect);
  4188. end;
  4189.  
  4190. procedure TCustomControlBar.DoBandPaint(Control: TControl; Canvas: TCanvas;
  4191.   var ARect: TRect; var Options: TBandPaintOptions);
  4192. begin
  4193.   if Assigned(FOnBandPaint) then FOnBandPaint(Self, Control, Canvas, ARect, Options);
  4194. end;
  4195.  
  4196. function TCustomControlBar.GetPalette: HPALETTE;
  4197. begin
  4198.   Result := 0;
  4199.   if FPicture.Graphic <> nil then
  4200.     Result := FPicture.Graphic.Palette;
  4201. end;
  4202.  
  4203. procedure TCustomControlBar.SetPicture(const Value: TPicture);
  4204. begin
  4205.   FPicture.Assign(Value);
  4206. end;
  4207.  
  4208. function TCustomControlBar.DoPaletteChange: Boolean;
  4209. var
  4210.   ParentForm: TCustomForm;
  4211.   Tmp: TGraphic;
  4212. begin
  4213.   Result := False;
  4214.   Tmp := Picture.Graphic;
  4215.   if Visible and (not (csLoading in ComponentState)) and (Tmp <> nil) and
  4216.     (Tmp.PaletteModified) then
  4217.   begin
  4218.     if (Tmp.Palette = 0) then
  4219.       Tmp.PaletteModified := False
  4220.     else
  4221.     begin
  4222.       ParentForm := GetParentForm(Self);
  4223.       if Assigned(ParentForm) and ParentForm.Active and Parentform.HandleAllocated then
  4224.       begin
  4225.         if FDrawing then
  4226.           ParentForm.Perform(WM_QUERYNEWPALETTE, 0, 0)
  4227.         else
  4228.           PostMessage(ParentForm.Handle, WM_QUERYNEWPALETTE, 0, 0);
  4229.         Result := True;
  4230.         Tmp.PaletteModified := False;
  4231.       end;
  4232.     end;
  4233.   end;
  4234. end;
  4235.  
  4236. procedure TCustomControlBar.PictureChanged(Sender: TObject);
  4237. begin
  4238.   if Picture.Graphic <> nil then
  4239.     if DoPaletteChange and FDrawing then Update;
  4240.   if not FDrawing then Invalidate;
  4241. end;
  4242.  
  4243. procedure TCustomControlBar.CMControlListChange(var Message: TCMControlListChange);
  4244. begin
  4245.   inherited;
  4246.   if not Message.Inserting then
  4247.   begin
  4248.     if Message.Control = FDragControl then
  4249.       FDragControl := nil;
  4250.     UnDockControl(Message.Control);
  4251.     if AutoSize then AdjustSize;
  4252.     Invalidate;
  4253.   end;
  4254. end;
  4255.  
  4256. procedure TCustomControlBar.CMDesignHitTest(var Message: TCMDesignHitTest);
  4257. begin
  4258.   Message.Result := Ord((FDragControl <> nil) or
  4259.     (HitTest(Message.XPos, Message.YPos) <> nil));
  4260. end;
  4261.  
  4262. procedure TCustomControlBar.WMEraseBkgnd(var Message: TWmEraseBkgnd);
  4263. var
  4264.   R: TRect;
  4265.   I, J: Integer;
  4266.   Save: Boolean;
  4267. begin
  4268.   if Message.DC <> 0 then
  4269.     Canvas.Handle := Message.DC;
  4270.   if Picture.Graphic <> nil then
  4271.   begin
  4272.  
  4273.     try
  4274.       R := ClientRect;
  4275.       Save := FDrawing;
  4276.       FDrawing := True;
  4277.       try
  4278.         { Tile image across client area }
  4279.         for I := 0 to (R.Right - R.Left) div Picture.Width do
  4280.           for J := 0 to (R.Bottom - R.Top) div Picture.Height do
  4281.             Canvas.Draw(I * Picture.Width, J * Picture.Height, Picture.Graphic);
  4282.       finally
  4283.         FDrawing := Save;
  4284.       end
  4285.     finally
  4286.       if Message.DC <> 0 then
  4287.         Canvas.Handle := 0;
  4288.       Message.Result := 1;
  4289.     end;
  4290.   end
  4291.   else
  4292.   begin
  4293.     Canvas.Brush.Color := Color;
  4294.     Canvas.Brush.Style := bsSolid;
  4295.     Canvas.FillRect(ClientRect);
  4296.     inherited;
  4297.   end;
  4298. end;
  4299.  
  4300. end.
  4301.