home *** CD-ROM | disk | FTP | other *** search
/ PC Plus SuperCD (UK) 2000 March / pcp161b.iso / full / delphi / RUNIMAGE / DELPHI30 / SOURCE / VCL / EXTCTRLS.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1997-08-03  |  62.6 KB  |  2,443 lines

  1.  
  2. {*******************************************************}
  3. {                                                       }
  4. {       Delphi Visual Component Library                 }
  5. {                                                       }
  6. {       Copyright (c) 1995,97 Borland International     }
  7. {                                                       }
  8. {*******************************************************}
  9.  
  10. unit ExtCtrls;
  11.  
  12. {$S-,W-,R-}
  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 Brush: TBrush read FBrush write SetBrush;
  42.     property DragCursor;
  43.     property DragMode;
  44.     property Enabled;
  45.     property ParentShowHint;
  46.     property Pen: TPen read FPen write SetPen;
  47.     property Shape: TShapeType read FShape write SetShape default stRectangle;
  48.     property ShowHint;
  49.     property Visible;
  50.     property OnDragDrop;
  51.     property OnDragOver;
  52.     property OnEndDrag;
  53.     property OnMouseDown;
  54.     property OnMouseMove;
  55.     property OnMouseUp;
  56.     property OnStartDrag;
  57.   end;
  58.  
  59.   TPaintBox = class(TGraphicControl)
  60.   private
  61.     FOnPaint: TNotifyEvent;
  62.   protected
  63.     procedure Paint; override;
  64.   public
  65.     constructor Create(AOwner: TComponent); override;
  66.     property Canvas;
  67.   published
  68.     property Align;
  69.     property Color;
  70.     property DragCursor;
  71.     property DragMode;
  72.     property Enabled;
  73.     property Font;
  74.     property ParentColor;
  75.     property ParentFont;
  76.     property ParentShowHint;
  77.     property PopupMenu;
  78.     property ShowHint;
  79.     property Visible;
  80.     property OnClick;
  81.     property OnDblClick;
  82.     property OnDragDrop;
  83.     property OnDragOver;
  84.     property OnEndDrag;
  85.     property OnMouseDown;
  86.     property OnMouseMove;
  87.     property OnMouseUp;
  88.     property OnPaint: TNotifyEvent read FOnPaint write FOnPaint;
  89.     property OnStartDrag;
  90.   end;
  91.  
  92.   TImage = class(TGraphicControl)
  93.   private
  94.     FPicture: TPicture;
  95.     FOnProgress: TProgressEvent;
  96.     FAutoSize: Boolean;
  97.     FStretch: Boolean;
  98.     FCenter: Boolean;
  99.     FIncrementalDisplay: Boolean;
  100.     FTransparent: Boolean;
  101.     FDrawing: Boolean;
  102.     function GetCanvas: TCanvas;
  103.     procedure PictureChanged(Sender: TObject);
  104.     procedure SetAutoSize(Value: Boolean);
  105.     procedure SetCenter(Value: Boolean);
  106.     procedure SetPicture(Value: TPicture);
  107.     procedure SetStretch(Value: Boolean);
  108.     procedure SetTransparent(Value: Boolean);
  109.   protected
  110.     function DestRect: TRect;
  111.     function DoPaletteChange: Boolean;
  112.     function GetPalette: HPALETTE; override;
  113.     procedure Paint; override;
  114.     procedure Progress(Sender: TObject; Stage: TProgressStage;
  115.       PercentDone: Byte; RedrawNow: Boolean; const R: TRect; const Msg: string); dynamic;
  116.   public
  117.     constructor Create(AOwner: TComponent); override;
  118.     destructor Destroy; override;
  119.     property Canvas: TCanvas read GetCanvas;
  120.   published
  121.     property Align;
  122.     property AutoSize: Boolean read FAutoSize write SetAutoSize default False;
  123.     property Center: Boolean read FCenter write SetCenter default False;
  124.     property DragCursor;
  125.     property DragMode;
  126.     property Enabled;
  127.     property IncrementalDisplay: Boolean read FIncrementalDisplay write FIncrementalDisplay default False;
  128.     property ParentShowHint;
  129.     property Picture: TPicture read FPicture write SetPicture;
  130.     property PopupMenu;
  131.     property ShowHint;
  132.     property Stretch: Boolean read FStretch write SetStretch default False;
  133.     property Transparent: Boolean read FTransparent write SetTransparent default False;
  134.     property Visible;
  135.     property OnClick;
  136.     property OnDblClick;
  137.     property OnDragDrop;
  138.     property OnDragOver;
  139.     property OnEndDrag;
  140.     property OnMouseDown;
  141.     property OnMouseMove;
  142.     property OnMouseUp;
  143.     property OnProgress: TProgressEvent read FOnProgress write FOnProgress;
  144.     property OnStartDrag;
  145.   end;
  146.  
  147.   TBevelStyle = (bsLowered, bsRaised);
  148.   TBevelShape = (bsBox, bsFrame, bsTopLine, bsBottomLine, bsLeftLine,
  149.     bsRightLine);
  150.  
  151.   TBevel = class(TGraphicControl)
  152.   private
  153.     FStyle: TBevelStyle;
  154.     FShape: TBevelShape;
  155.     procedure SetStyle(Value: TBevelStyle);
  156.     procedure SetShape(Value: TBevelShape);
  157.   protected
  158.     procedure Paint; override;
  159.   public
  160.     constructor Create(AOwner: TComponent); override;
  161.   published
  162.     property Align;
  163.     property ParentShowHint;
  164.     property Shape: TBevelShape read FShape write SetShape default bsBox;
  165.     property ShowHint;
  166.     property Style: TBevelStyle read FStyle write SetStyle default bsLowered;
  167.     property Visible;
  168.   end;
  169.  
  170.   TTimer = class(TComponent)
  171.   private
  172.     FInterval: Cardinal;
  173.     FWindowHandle: HWND;
  174.     FOnTimer: TNotifyEvent;
  175.     FEnabled: Boolean;
  176.     procedure UpdateTimer;
  177.     procedure SetEnabled(Value: Boolean);
  178.     procedure SetInterval(Value: Cardinal);
  179.     procedure SetOnTimer(Value: TNotifyEvent);
  180.     procedure WndProc(var Msg: TMessage);
  181.   protected
  182.     procedure Timer; dynamic;
  183.   public
  184.     constructor Create(AOwner: TComponent); override;
  185.     destructor Destroy; override;
  186.   published
  187.     property Enabled: Boolean read FEnabled write SetEnabled default True;
  188.     property Interval: Cardinal read FInterval write SetInterval default 1000;
  189.     property OnTimer: TNotifyEvent read FOnTimer write SetOnTimer;
  190.   end;
  191.  
  192.   TPanelBevel = (bvNone, bvLowered, bvRaised);
  193.   TBevelWidth = 1..MaxInt;
  194.   TBorderWidth = 0..MaxInt;
  195.  
  196.   TCustomPanel = class(TCustomControl)
  197.   private
  198.     FBevelInner: TPanelBevel;
  199.     FBevelOuter: TPanelBevel;
  200.     FBevelWidth: TBevelWidth;
  201.     FBorderWidth: TBorderWidth;
  202.     FBorderStyle: TBorderStyle;
  203.     FFullRepaint: Boolean;
  204.     FLocked: Boolean;
  205.     FOnResize: TNotifyEvent;
  206.     FAlignment: TAlignment;
  207.     procedure CMTextChanged(var Message: TMessage); message CM_TEXTCHANGED;
  208.     procedure CMCtl3DChanged(var Message: TMessage); message CM_CTL3DCHANGED;
  209.     procedure CMIsToolControl(var Message: TMessage); message CM_ISTOOLCONTROL;
  210.     procedure WMWindowPosChanged(var Message: TWMWindowPosChanged); message WM_WINDOWPOSCHANGED;
  211.     procedure SetAlignment(Value: TAlignment);
  212.     procedure SetBevelInner(Value: TPanelBevel);
  213.     procedure SetBevelOuter(Value: TPanelBevel);
  214.     procedure SetBevelWidth(Value: TBevelWidth);
  215.     procedure SetBorderWidth(Value: TBorderWidth);
  216.     procedure SetBorderStyle(Value: TBorderStyle);
  217.   protected
  218.     procedure CreateParams(var Params: TCreateParams); override;
  219.     procedure AlignControls(AControl: TControl; var Rect: TRect); override;
  220.     procedure Paint; override;
  221.     procedure Resize; dynamic;
  222.     property Alignment: TAlignment read FAlignment write SetAlignment default taCenter;
  223.     property BevelInner: TPanelBevel read FBevelInner write SetBevelInner default bvNone;
  224.     property BevelOuter: TPanelBevel read FBevelOuter write SetBevelOuter default bvRaised;
  225.     property BevelWidth: TBevelWidth read FBevelWidth write SetBevelWidth default 1;
  226.     property BorderWidth: TBorderWidth read FBorderWidth write SetBorderWidth default 0;
  227.     property BorderStyle: TBorderStyle read FBorderStyle write SetBorderStyle default bsNone;
  228.     property Color default clBtnFace;
  229.     property FullRepaint: Boolean read FFullRepaint write FFullRepaint default True;
  230.     property Locked: Boolean read FLocked write FLocked default False;
  231.     property ParentColor default False;
  232.     property OnResize: TNotifyEvent read FOnResize write FOnResize;
  233.   public
  234.     constructor Create(AOwner: TComponent); override;
  235.   end;
  236.  
  237.   TPanel = class(TCustomPanel)
  238.   published
  239.     property Align;
  240.     property Alignment;
  241.     property BevelInner;
  242.     property BevelOuter;
  243.     property BevelWidth;
  244.     property BorderWidth;
  245.     property BorderStyle;
  246.     property DragCursor;
  247.     property DragMode;
  248.     property Enabled;
  249.     property FullRepaint;
  250.     property Caption;
  251.     property Color;
  252.     property Ctl3D;
  253.     property Font;
  254.     property Locked;
  255.     property ParentColor;
  256.     property ParentCtl3D;
  257.     property ParentFont;
  258.     property ParentShowHint;
  259.     property PopupMenu;
  260.     property ShowHint;
  261.     property TabOrder;
  262.     property TabStop;
  263.     property Visible;
  264.     property OnClick;
  265.     property OnDblClick;
  266.     property OnDragDrop;
  267.     property OnDragOver;
  268.     property OnEndDrag;
  269.     property OnEnter;
  270.     property OnExit;
  271.     property OnMouseDown;
  272.     property OnMouseMove;
  273.     property OnMouseUp;
  274.     property OnResize;
  275.     property OnStartDrag;
  276.   end;
  277.  
  278.   TPage = class(TCustomControl)
  279.   private
  280.     procedure WMNCHitTest(var Message: TWMNCHitTest); message WM_NCHITTEST;
  281.   protected
  282.     procedure ReadState(Reader: TReader); override;
  283.     procedure Paint; override;
  284.   public
  285.     constructor Create(AOwner: TComponent); override;
  286.   published
  287.     property Caption;
  288.     property Height stored False;
  289.     property TabOrder stored False;
  290.     property Visible stored False;
  291.     property Width stored False;
  292.   end;
  293.  
  294.   TNotebook = class(TCustomControl)
  295.   private
  296.     FPageList: TList;
  297.     FAccess: TStrings;
  298.     FPageIndex: Integer;
  299.     FOnPageChanged: TNotifyEvent;
  300.     procedure SetPages(Value: TStrings);
  301.     procedure SetActivePage(const Value: string);
  302.     function GetActivePage: string;
  303.     procedure SetPageIndex(Value: Integer);
  304.   protected
  305.     procedure CreateParams(var Params: TCreateParams); override;
  306.     function GetChildOwner: TComponent; override;
  307.     procedure GetChildren(Proc: TGetChildProc; Root: TComponent); override;
  308.     procedure ReadState(Reader: TReader); override;
  309.     procedure ShowControl(AControl: TControl); override;
  310.   public
  311.     constructor Create(AOwner: TComponent); override;
  312.     destructor Destroy; override;
  313.   published
  314.     property ActivePage: string read GetActivePage write SetActivePage stored False;
  315.     property Align;
  316.     property Color;
  317.     property Ctl3D;
  318.     property DragCursor;
  319.     property DragMode;
  320.     property Font;
  321.     property Enabled;
  322.     property PageIndex: Integer read FPageIndex write SetPageIndex default 0;
  323.     property Pages: TStrings read FAccess write SetPages stored False;
  324.     property ParentColor;
  325.     property ParentCtl3D;
  326.     property ParentFont;
  327.     property ParentShowHint;
  328.     property PopupMenu;
  329.     property ShowHint;
  330.     property TabOrder;
  331.     property TabStop;
  332.     property Visible;
  333.     property OnClick;
  334.     property OnDblClick;
  335.     property OnDragDrop;
  336.     property OnDragOver;
  337.     property OnEndDrag;
  338.     property OnEnter;
  339.     property OnExit;
  340.     property OnMouseDown;
  341.     property OnMouseMove;
  342.     property OnMouseUp;
  343.     property OnPageChanged: TNotifyEvent read FOnPageChanged write FOnPageChanged;
  344.     property OnStartDrag;
  345.   end;
  346.  
  347. { THeader
  348.   Purpose  - Creates sectioned visual header that allows each section to be
  349.              resized with the mouse.
  350.   Features - This is a design-interactive control.  In design mode, the
  351.              sections are named using the string-list editor.  Each section
  352.              can now be manually resized using the right mouse button the grab
  353.              the divider and drag to the new size.  Changing the section list
  354.              at design (or even run-time), will attempt to maintain the
  355.              section widths for sections that have not been changed.
  356.   Properties:
  357.     Align - Standard property.
  358.     AllowResize - If True, the control allows run-time mouse resizing of the
  359.                   sections.
  360.     BorderStyle - Turns the border on and off.
  361.     Font - Standard property.
  362.     Sections - A special string-list that contains the section text.
  363.     ParentFont - Standard property.
  364.     OnSizing - Event called for each mouse move during a section resize
  365.                operation.
  366.     OnSized - Event called once the size operation is complete.
  367.  
  368.     SectionWidth - Array property allowing run-time getting and setting of
  369.                    each section's width. }
  370.  
  371.   TSectionEvent = procedure(Sender: TObject;
  372.     ASection, AWidth: Integer) of object;
  373.  
  374.   THeader = class(TCustomControl)
  375.   private
  376.     FSections: TStrings;
  377.     FHitTest: TPoint;
  378.     FCanResize: Boolean;
  379.     FAllowResize: Boolean;
  380.     FBorderStyle: TBorderStyle;
  381.     FResizeSection: Integer;
  382.     FMouseOffset: Integer;
  383.     FOnSizing: TSectionEvent;
  384.     FOnSized: TSectionEvent;
  385.     procedure SetBorderStyle(Value: TBorderStyle);
  386.     procedure FreeSections;
  387.     procedure SetSections(Strings: TStrings);
  388.     function GetWidth(X: Integer): Integer;
  389.     procedure SetWidth(X: Integer; Value: Integer);
  390.     procedure WMSetCursor(var Msg: TWMSetCursor); message WM_SETCURSOR;
  391.     procedure WMNCHitTest(var Msg: TWMNCHitTest); message WM_NCHITTEST;
  392.     procedure WMSize(var Msg: TWMSize); message WM_SIZE;
  393.     procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
  394.       X, Y: Integer); override;
  395.     procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
  396.     procedure MouseUp(Button: TMouseButton; Shift: TShiftState;
  397.       X, Y: Integer); override;
  398.   protected
  399.     procedure Paint; override;
  400.     procedure CreateParams(var Params: TCreateParams); override;
  401.     procedure Sizing(ASection, AWidth: Integer); dynamic;
  402.     procedure Sized(ASection, AWidth: Integer); dynamic;
  403.   public
  404.     constructor Create(AOwner: TComponent); override;
  405.     destructor Destroy; override;
  406.     property SectionWidth[X: Integer]: Integer read GetWidth write SetWidth;
  407.   published
  408.     property Align;
  409.     property AllowResize: Boolean read FAllowResize write FAllowResize default True;
  410.     property BorderStyle: TBorderStyle read FBorderStyle write SetBorderStyle default bsSingle;
  411.     property Enabled;
  412.     property Font;
  413.     property ParentFont;
  414.     property ParentShowHint;
  415.     property PopupMenu;
  416.     property Sections: TStrings read FSections write SetSections;
  417.     property ShowHint;
  418.     property TabOrder;
  419.     property TabStop;
  420.     property Visible;
  421.     property OnSizing: TSectionEvent read FOnSizing write FOnSizing;
  422.     property OnSized: TSectionEvent read FOnSized write FOnSized;
  423.   end;
  424.  
  425.   TCustomRadioGroup = class(TCustomGroupBox)
  426.   private
  427.     FButtons: TList;
  428.     FItems: TStrings;
  429.     FItemIndex: Integer;
  430.     FColumns: Integer;
  431.     FReading: Boolean;
  432.     FUpdating: Boolean;
  433.     procedure ArrangeButtons;
  434.     procedure ButtonClick(Sender: TObject);
  435.     procedure ItemsChange(Sender: TObject);
  436.     procedure SetButtonCount(Value: Integer);
  437.     procedure SetColumns(Value: Integer);
  438.     procedure SetItemIndex(Value: Integer);
  439.     procedure SetItems(Value: TStrings);
  440.     procedure UpdateButtons;
  441.     procedure CMEnabledChanged(var Message: TMessage); message CM_ENABLEDCHANGED;
  442.     procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
  443.     procedure WMSize(var Message: TWMSize); message WM_SIZE;
  444.   protected
  445.     procedure ReadState(Reader: TReader); override;
  446.     function CanModify: Boolean; virtual;
  447.     procedure GetChildren(Proc: TGetChildProc; Root: TComponent); override;
  448.     property Columns: Integer read FColumns write SetColumns default 1;
  449.     property ItemIndex: Integer read FItemIndex write SetItemIndex default -1;
  450.     property Items: TStrings read FItems write SetItems;
  451.   public
  452.     constructor Create(AOwner: TComponent); override;
  453.     destructor Destroy; override;
  454.   end;
  455.  
  456.   TRadioGroup = class(TCustomRadioGroup)
  457.   published
  458.     property Align;
  459.     property Caption;
  460.     property Color;
  461.     property Columns;
  462.     property Ctl3D;
  463.     property DragCursor;
  464.     property DragMode;
  465.     property Enabled;
  466.     property Font;
  467.     property ItemIndex;
  468.     property Items;
  469.     property ParentColor;
  470.     property ParentCtl3D;
  471.     property ParentFont;
  472.     property ParentShowHint;
  473.     property PopupMenu;
  474.     property ShowHint;
  475.     property TabOrder;
  476.     property TabStop;
  477.     property Visible;
  478.     property OnClick;
  479.     property OnDragDrop;
  480.     property OnDragOver;
  481.     property OnEndDrag;
  482.     property OnEnter;
  483.     property OnExit;
  484.     property OnStartDrag;
  485.   end;
  486.  
  487.   NaturalNumber = 1..High(Integer);
  488.  
  489.   TSplitter = class(TGraphicControl)
  490.   private
  491.     FLineDC: HDC;
  492.     FDownPos: TPoint;
  493.     FSplit: Integer;
  494.     FMinSize: NaturalNumber;
  495.     FMaxSize: Integer;
  496.     FControl: TControl;
  497.     FNewSize: Integer;
  498.     FActiveControl: TWinControl;
  499.     FOldKeyDown: TKeyEvent;
  500.     FBeveled: Boolean;
  501.     FLineVisible: Boolean;
  502.     FOnMoved: TNotifyEvent;
  503.     procedure AllocateLineDC;
  504.     procedure DrawLine;
  505.     procedure ReleaseLineDC;
  506.     procedure UpdateSize(X, Y: Integer);
  507.     procedure FocusKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
  508.     procedure SetBeveled(Value: Boolean);
  509.   protected
  510.     procedure Paint; override;
  511.     procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
  512.       X, Y: Integer); override;
  513.     procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
  514.     procedure MouseUp(Button: TMouseButton; Shift: TShiftState;
  515.       X, Y: Integer); override;
  516.     procedure StopSizing;
  517.   public
  518.     constructor Create(AOwner: TComponent); override;
  519.   published
  520.     property Align default alLeft;
  521.     property Beveled: Boolean read FBeveled write SetBeveled default True;
  522.     property Color;
  523.     property MinSize: NaturalNumber read FMinSize write FMinSize default 30;
  524.     property ParentColor;
  525.     property OnMoved: TNotifyEvent read FOnMoved write FOnMoved;
  526.   end;
  527.  
  528. procedure Frame3D(Canvas: TCanvas; var Rect: TRect;
  529.   TopColor, BottomColor: TColor; Width: Integer);
  530.  
  531. implementation
  532.  
  533. uses Consts;
  534.  
  535. { Utility routines }
  536.  
  537. procedure Frame3D(Canvas: TCanvas; var Rect: TRect; TopColor, BottomColor: TColor;
  538.   Width: Integer);
  539.  
  540.   procedure DoRect;
  541.   var
  542.     TopRight, BottomLeft: TPoint;
  543.   begin
  544.     with Canvas, Rect do
  545.     begin
  546.       TopRight.X := Right;
  547.       TopRight.Y := Top;
  548.       BottomLeft.X := Left;
  549.       BottomLeft.Y := Bottom;
  550.       Pen.Color := TopColor;
  551.       PolyLine([BottomLeft, TopLeft, TopRight]);
  552.       Pen.Color := BottomColor;
  553.       Dec(BottomLeft.X);
  554.       PolyLine([TopRight, BottomRight, BottomLeft]);
  555.     end;
  556.   end;
  557.  
  558. begin
  559.   Canvas.Pen.Width := 1;
  560.   Dec(Rect.Bottom); Dec(Rect.Right);
  561.   while Width > 0 do
  562.   begin
  563.     Dec(Width);
  564.     DoRect;
  565.     InflateRect(Rect, -1, -1);
  566.   end;
  567.   Inc(Rect.Bottom); Inc(Rect.Right);
  568. end;
  569.  
  570. { TShape }
  571.  
  572. constructor TShape.Create(AOwner: TComponent);
  573. begin
  574.   inherited Create(AOwner);
  575.   ControlStyle := ControlStyle + [csReplicatable];
  576.   Width := 65;
  577.   Height := 65;
  578.   FPen := TPen.Create;
  579.   FPen.OnChange := StyleChanged;
  580.   FBrush := TBrush.Create;
  581.   FBrush.OnChange := StyleChanged;
  582. end;
  583.  
  584. destructor TShape.Destroy;
  585. begin
  586.   FPen.Free;
  587.   FBrush.Free;
  588.   inherited Destroy;
  589. end;
  590.  
  591. procedure TShape.Paint;
  592. var
  593.   X, Y, W, H, S: Integer;
  594. begin
  595.   with Canvas do
  596.   begin
  597.     Pen := FPen;
  598.     Brush := FBrush;
  599.     X := Pen.Width div 2;
  600.     Y := X;
  601.     W := Width - Pen.Width + 1;
  602.     H := Height - Pen.Width + 1;
  603.     if Pen.Width = 0 then
  604.     begin
  605.       Dec(W);
  606.       Dec(H);
  607.     end;
  608.     if W < H then S := W else S := H;
  609.     if FShape in [stSquare, stRoundSquare, stCircle] then
  610.     begin
  611.       Inc(X, (W - S) div 2);
  612.       Inc(Y, (H - S) div 2);
  613.       W := S;
  614.       H := S;
  615.     end;
  616.     case FShape of
  617.       stRectangle, stSquare:
  618.         Rectangle(X, Y, X + W, Y + H);
  619.       stRoundRect, stRoundSquare:
  620.         RoundRect(X, Y, X + W, Y + H, S div 4, S div 4);
  621.       stCircle, stEllipse:
  622.         Ellipse(X, Y, X + W, Y + H);
  623.     end;
  624.   end;
  625. end;
  626.  
  627. procedure TShape.StyleChanged(Sender: TObject);
  628. begin
  629.   Invalidate;
  630. end;
  631.  
  632. procedure TShape.SetBrush(Value: TBrush);
  633. begin
  634.   FBrush.Assign(Value);
  635. end;
  636.  
  637. procedure TShape.SetPen(Value: TPen);
  638. begin
  639.   FPen.Assign(Value);
  640. end;
  641.  
  642. procedure TShape.SetShape(Value: TShapeType);
  643. begin
  644.   if FShape <> Value then
  645.   begin
  646.     FShape := Value;
  647.     Invalidate;
  648.   end;
  649. end;
  650.  
  651. { TPaintBox }
  652.  
  653. constructor TPaintBox.Create(AOwner: TComponent);
  654. begin
  655.   inherited Create(AOwner);
  656.   ControlStyle := ControlStyle + [csReplicatable];
  657.   Width := 105;
  658.   Height := 105;
  659. end;
  660.  
  661. procedure TPaintBox.Paint;
  662. begin
  663.   Canvas.Font := Font;
  664.   Canvas.Brush.Color := Color;
  665.   if csDesigning in ComponentState then
  666.     with Canvas do
  667.     begin
  668.       Pen.Style := psDash;
  669.       Brush.Style := bsClear;
  670.       Rectangle(0, 0, Width, Height);
  671.     end;
  672.   if Assigned(FOnPaint) then FOnPaint(Self);
  673. end;
  674.  
  675. { TImage }
  676.  
  677. constructor TImage.Create(AOwner: TComponent);
  678. begin
  679.   inherited Create(AOwner);
  680.   ControlStyle := ControlStyle + [csReplicatable];
  681.   FPicture := TPicture.Create;
  682.   FPicture.OnChange := PictureChanged;
  683.   FPicture.OnProgress := Progress;
  684.   Height := 105;
  685.   Width := 105;
  686. end;
  687.  
  688. destructor TImage.Destroy;
  689. begin
  690.   FPicture.Free;
  691.   inherited Destroy;
  692. end;
  693.  
  694. function TImage.GetPalette: HPALETTE;
  695. begin
  696.   Result := 0;
  697.   if FPicture.Graphic <> nil then
  698.     Result := FPicture.Graphic.Palette;
  699. end;
  700.  
  701. function TImage.DestRect: TRect;
  702. begin
  703.   if Stretch then
  704.     Result := ClientRect
  705.   else if Center then
  706.     Result := Bounds((Width - Picture.Width) div 2, (Height - Picture.Height) div 2,
  707.       Picture.Width, Picture.Height)
  708.   else
  709.     Result := Rect(0, 0, Picture.Width, Picture.Height);
  710. end;
  711.  
  712. procedure TImage.Paint;
  713. var
  714.   Save: Boolean;
  715. begin
  716.   if csDesigning in ComponentState then
  717.     with inherited Canvas do
  718.     begin
  719.       Pen.Style := psDash;
  720.       Brush.Style := bsClear;
  721.       Rectangle(0, 0, Width, Height);
  722.     end;
  723.   Save := FDrawing;
  724.   FDrawing := True;
  725.   try
  726.     with inherited Canvas do
  727.       StretchDraw(DestRect, Picture.Graphic);
  728.   finally
  729.     FDrawing := Save;
  730.   end;
  731. end;
  732.  
  733. function TImage.DoPaletteChange: Boolean;
  734. var
  735.   ParentForm: TCustomForm;
  736.   Tmp: TGraphic;
  737. begin
  738.   Result := False;
  739.   Tmp := Picture.Graphic;
  740.   if Visible and (not (csLoading in ComponentState)) and (Tmp <> nil) and
  741.     (Tmp.PaletteModified) then
  742.   begin
  743.     if (Tmp.Palette = 0) then
  744.       Tmp.PaletteModified := False
  745.     else
  746.     begin
  747.       ParentForm := GetParentForm(Self);
  748.       if Assigned(ParentForm) and ParentForm.Active and Parentform.HandleAllocated then
  749.       begin
  750.         if FDrawing then
  751.           ParentForm.Perform(wm_QueryNewPalette, 0, 0)
  752.         else
  753.           PostMessage(ParentForm.Handle, wm_QueryNewPalette, 0, 0);
  754.         Result := True;
  755.         Tmp.PaletteModified := False;
  756.       end;
  757.     end;
  758.   end;
  759. end;
  760.  
  761. procedure TImage.Progress(Sender: TObject; Stage: TProgressStage;
  762.   PercentDone: Byte; RedrawNow: Boolean; const R: TRect; const Msg: string);
  763. begin
  764.   if FIncrementalDisplay and RedrawNow then
  765.   begin
  766.     if DoPaletteChange then Update
  767.     else Paint;
  768.   end;
  769.   if Assigned(FOnProgress) then FOnProgress(Sender, Stage, PercentDone, RedrawNow, R, Msg);
  770. end;
  771.  
  772. function TImage.GetCanvas: TCanvas;
  773. var
  774.   Bitmap: TBitmap;
  775. begin
  776.   if Picture.Graphic = nil then
  777.   begin
  778.     Bitmap := TBitmap.Create;
  779.     try
  780.       Bitmap.Width := Width;
  781.       Bitmap.Height := Height;
  782.       Picture.Graphic := Bitmap;
  783.     finally
  784.       Bitmap.Free;
  785.     end;
  786.   end;
  787.   if Picture.Graphic is TBitmap then
  788.     Result := TBitmap(Picture.Graphic).Canvas
  789.   else
  790.     raise EInvalidOperation.Create(SImageCanvasNeedsBitmap);
  791. end;
  792.  
  793. procedure TImage.SetAutoSize(Value: Boolean);
  794. begin
  795.   FAutoSize := Value;
  796.   PictureChanged(Self);
  797. end;
  798.  
  799. procedure TImage.SetCenter(Value: Boolean);
  800. begin
  801.   if FCenter <> Value then
  802.   begin
  803.     FCenter := Value;
  804.     PictureChanged(Self);
  805.   end;
  806. end;
  807.  
  808. procedure TImage.SetPicture(Value: TPicture);
  809. begin
  810.   FPicture.Assign(Value);
  811. end;
  812.  
  813. procedure TImage.SetStretch(Value: Boolean);
  814. begin
  815.   if Value <> FStretch then
  816.   begin
  817.     FStretch := Value;
  818.     PictureChanged(Self);
  819.   end;
  820. end;
  821.  
  822. procedure TImage.SetTransparent(Value: Boolean);
  823. begin
  824.   if Value <> FTransparent then
  825.   begin
  826.     FTransparent := Value;
  827.     PictureChanged(Self);
  828.   end;
  829. end;
  830.  
  831. procedure TImage.PictureChanged(Sender: TObject);
  832. var
  833.   G: TGraphic;
  834. begin
  835.   if AutoSize and (Picture.Width > 0) and (Picture.Height > 0) then
  836.     SetBounds(Left, Top, Picture.Width, Picture.Height);
  837.   G := Picture.Graphic;
  838.   if G <> nil then
  839.   begin
  840.     if not ((G is TMetaFile) or (G is TIcon)) then
  841.       G.Transparent := FTransparent;
  842.     if (not G.Transparent) and (Stretch or (G.Width >= Width)
  843.       and (G.Height >= Height)) then
  844.       ControlStyle := ControlStyle + [csOpaque]
  845.     else
  846.       ControlStyle := ControlStyle - [csOpaque];
  847.     if DoPaletteChange and FDrawing then Update;
  848.   end
  849.   else ControlStyle := ControlStyle - [csOpaque];
  850.   if not FDrawing then Invalidate;
  851. end;
  852.  
  853. { TBevel }
  854.  
  855. constructor TBevel.Create(AOwner: TComponent);
  856. begin
  857.   inherited Create(AOwner);
  858.   ControlStyle := ControlStyle + [csReplicatable];
  859.   FStyle := bsLowered;
  860.   FShape := bsBox;
  861.   Width := 50;
  862.   Height := 50;
  863. end;
  864.  
  865. procedure TBevel.SetStyle(Value: TBevelStyle);
  866. begin
  867.   if Value <> FStyle then
  868.   begin
  869.     FStyle := Value;
  870.     Invalidate;
  871.   end;
  872. end;
  873.  
  874. procedure TBevel.SetShape(Value: TBevelShape);
  875. begin
  876.   if Value <> FShape then
  877.   begin
  878.     FShape := Value;
  879.     Invalidate;
  880.   end;
  881. end;
  882.  
  883. procedure TBevel.Paint;
  884. var
  885.   Color1, Color2: TColor;
  886.   Temp: TColor;
  887.  
  888.   procedure BevelRect(const R: TRect);
  889.   begin
  890.     with Canvas do
  891.     begin
  892.       Pen.Color := Color1;
  893.       PolyLine([Point(R.Left, R.Bottom), Point(R.Left, R.Top),
  894.         Point(R.Right, R.Top)]);
  895.       Pen.Color := Color2;
  896.       PolyLine([Point(R.Right, R.Top), Point(R.Right, R.Bottom),
  897.         Point(R.Left, R.Bottom)]);
  898.     end;
  899.   end;
  900.  
  901.   procedure BevelLine(C: TColor; X1, Y1, X2, Y2: Integer);
  902.   begin
  903.     with Canvas do
  904.     begin
  905.       Pen.Color := C;
  906.       MoveTo(X1, Y1);
  907.       LineTo(X2, Y2);
  908.     end;
  909.   end;
  910.  
  911. begin
  912.   with Canvas do
  913.   begin
  914.     Pen.Width := 1;
  915.  
  916.     if FStyle = bsLowered then
  917.     begin
  918.       Color1 := clBtnShadow;
  919.       Color2 := clBtnHighlight;
  920.     end
  921.     else
  922.     begin
  923.       Color1 := clBtnHighlight;
  924.       Color2 := clBtnShadow;
  925.     end;
  926.  
  927.     case FShape of
  928.       bsBox: BevelRect(Rect(0, 0, Width - 1, Height - 1));
  929.       bsFrame:
  930.         begin
  931.           Temp := Color1;
  932.           Color1 := Color2;
  933.           BevelRect(Rect(1, 1, Width - 1, Height - 1));
  934.           Color2 := Temp;
  935.           Color1 := Temp;
  936.           BevelRect(Rect(0, 0, Width - 2, Height - 2));
  937.         end;
  938.       bsTopLine:
  939.         begin
  940.           BevelLine(Color1, 0, 0, Width, 0);
  941.           BevelLine(Color2, 0, 1, Width, 1);
  942.         end;
  943.       bsBottomLine:
  944.         begin
  945.           BevelLine(Color1, 0, Height - 2, Width, Height - 2);
  946.           BevelLine(Color2, 0, Height - 1, Width, Height - 1);
  947.         end;
  948.       bsLeftLine:
  949.         begin
  950.           BevelLine(Color1, 0, 0, 0, Height);
  951.           BevelLine(Color2, 1, 0, 1, Height);
  952.         end;
  953.       bsRightLine:
  954.         begin
  955.           BevelLine(Color1, Width - 2, 0, Width - 2, Height);
  956.           BevelLine(Color2, Width - 1, 0, Width - 1, Height);
  957.         end;
  958.     end;
  959.   end;
  960. end;
  961.  
  962. { TTimer }
  963.  
  964. constructor TTimer.Create(AOwner: TComponent);
  965. begin
  966.   inherited Create(AOwner);
  967.   FEnabled := True;
  968.   FInterval := 1000;
  969.   FWindowHandle := AllocateHWnd(WndProc);
  970. end;
  971.  
  972. destructor TTimer.Destroy;
  973. begin
  974.   FEnabled := False;
  975.   UpdateTimer;
  976.   DeallocateHWnd(FWindowHandle);
  977.   inherited Destroy;
  978. end;
  979.  
  980. procedure TTimer.WndProc(var Msg: TMessage);
  981. begin
  982.   with Msg do
  983.     if Msg = WM_TIMER then
  984.       try
  985.         Timer;
  986.       except
  987.         Application.HandleException(Self);
  988.       end
  989.     else
  990.       Result := DefWindowProc(FWindowHandle, Msg, wParam, lParam);
  991. end;
  992.  
  993. procedure TTimer.UpdateTimer;
  994. begin
  995.   KillTimer(FWindowHandle, 1);
  996.   if (FInterval <> 0) and FEnabled and Assigned(FOnTimer) then
  997.     if SetTimer(FWindowHandle, 1, FInterval, nil) = 0 then
  998.       raise EOutOfResources.Create(SNoTimers);
  999. end;
  1000.  
  1001. procedure TTimer.SetEnabled(Value: Boolean);
  1002. begin
  1003.   if Value <> FEnabled then
  1004.   begin
  1005.     FEnabled := Value;
  1006.     UpdateTimer;
  1007.   end;
  1008. end;
  1009.  
  1010. procedure TTimer.SetInterval(Value: Cardinal);
  1011. begin
  1012.   if Value <> FInterval then
  1013.   begin
  1014.     FInterval := Value;
  1015.     UpdateTimer;
  1016.   end;
  1017. end;
  1018.  
  1019. procedure TTimer.SetOnTimer(Value: TNotifyEvent);
  1020. begin
  1021.   FOnTimer := Value;
  1022.   UpdateTimer;
  1023. end;
  1024.  
  1025. procedure TTimer.Timer;
  1026. begin
  1027.   if Assigned(FOnTimer) then FOnTimer(Self);
  1028. end;
  1029.  
  1030. { TCustomPanel }
  1031.  
  1032. constructor TCustomPanel.Create(AOwner: TComponent);
  1033. begin
  1034.   inherited Create(AOwner);
  1035.   ControlStyle := [csAcceptsControls, csCaptureMouse, csClickEvents,
  1036.     csSetCaption, csOpaque, csDoubleClicks, csReplicatable];
  1037.   Width := 185;
  1038.   Height := 41;
  1039.   FAlignment := taCenter;
  1040.   BevelOuter := bvRaised;
  1041.   BevelWidth := 1;
  1042.   FBorderStyle := bsNone;
  1043.   Color := clBtnFace;
  1044.   FFullRepaint := True;
  1045. end;
  1046.  
  1047. procedure TCustomPanel.CreateParams(var Params: TCreateParams);
  1048. const
  1049.   BorderStyles: array[TBorderStyle] of Longint = (0, WS_BORDER);
  1050. begin
  1051.   inherited CreateParams(Params);
  1052.   with Params do
  1053.   begin
  1054.     Style := Style or BorderStyles[FBorderStyle];
  1055.     if NewStyleControls and Ctl3D and (FBorderStyle = bsSingle) then
  1056.     begin
  1057.       Style := Style and not WS_BORDER;
  1058.       ExStyle := ExStyle or WS_EX_CLIENTEDGE;
  1059.     end;
  1060.     WindowClass.style := WindowClass.style and not (CS_HREDRAW or CS_VREDRAW);
  1061.   end;
  1062. end;
  1063.  
  1064. procedure TCustomPanel.CMTextChanged(var Message: TMessage);
  1065. begin
  1066.   Invalidate;
  1067. end;
  1068.  
  1069. procedure TCustomPanel.CMCtl3DChanged(var Message: TMessage);
  1070. begin
  1071.   if NewStyleControls and (FBorderStyle = bsSingle) then RecreateWnd;
  1072.   inherited;
  1073. end;
  1074.  
  1075. procedure TCustomPanel.CMIsToolControl(var Message: TMessage);
  1076. begin
  1077.   if not FLocked then Message.Result := 1;
  1078. end;
  1079.  
  1080. procedure TCustomPanel.Resize;
  1081. begin
  1082.   if Assigned(FOnResize) then FOnResize(Self);
  1083. end;
  1084.  
  1085. procedure TCustomPanel.WMWindowPosChanged(var Message: TWMWindowPosChanged);
  1086. var
  1087.   BevelPixels: Integer;
  1088.   Rect: TRect;
  1089. begin
  1090.   if FullRepaint or (Caption <> '') then
  1091.     Invalidate
  1092.   else
  1093.   begin
  1094.     BevelPixels := BorderWidth;
  1095.     if BevelInner <> bvNone then Inc(BevelPixels, BevelWidth);
  1096.     if BevelOuter <> bvNone then Inc(BevelPixels, BevelWidth);
  1097.     if BevelPixels > 0 then
  1098.     begin
  1099.       Rect.Right := Width;
  1100.       Rect.Bottom := Height;
  1101.       if Message.WindowPos^.cx <> Rect.Right then
  1102.       begin
  1103.         Rect.Top := 0;
  1104.         Rect.Left := Rect.Right - BevelPixels - 1;
  1105.         InvalidateRect(Handle, @Rect, True);
  1106.       end;
  1107.       if Message.WindowPos^.cy <> Rect.Bottom then
  1108.       begin
  1109.         Rect.Left := 0;
  1110.         Rect.Top := Rect.Bottom - BevelPixels - 1;
  1111.         InvalidateRect(Handle, @Rect, True);
  1112.       end;
  1113.     end;
  1114.   end;
  1115.   inherited;
  1116.   if not (csLoading in ComponentState) then Resize;
  1117. end;
  1118.  
  1119. procedure TCustomPanel.AlignControls(AControl: TControl; var Rect: TRect);
  1120. var
  1121.   BevelSize: Integer;
  1122. begin
  1123.   BevelSize := BorderWidth;
  1124.   if BevelOuter <> bvNone then Inc(BevelSize, BevelWidth);
  1125.   if BevelInner <> bvNone then Inc(BevelSize, BevelWidth);
  1126.   InflateRect(Rect, -BevelSize, -BevelSize);
  1127.   inherited AlignControls(AControl, Rect);
  1128. end;
  1129.  
  1130. procedure TCustomPanel.Paint;
  1131. var
  1132.   Rect: TRect;
  1133.   TopColor, BottomColor: TColor;
  1134.   FontHeight: Integer;
  1135. const
  1136.   Alignments: array[TAlignment] of Word = (DT_LEFT, DT_RIGHT, DT_CENTER);
  1137.  
  1138.   procedure AdjustColors(Bevel: TPanelBevel);
  1139.   begin
  1140.     TopColor := clBtnHighlight;
  1141.     if Bevel = bvLowered then TopColor := clBtnShadow;
  1142.     BottomColor := clBtnShadow;
  1143.     if Bevel = bvLowered then BottomColor := clBtnHighlight;
  1144.   end;
  1145.  
  1146. begin
  1147.   Rect := GetClientRect;
  1148.   if BevelOuter <> bvNone then
  1149.   begin
  1150.     AdjustColors(BevelOuter);
  1151.     Frame3D(Canvas, Rect, TopColor, BottomColor, BevelWidth);
  1152.   end;
  1153.   Frame3D(Canvas, Rect, Color, Color, BorderWidth);
  1154.   if BevelInner <> bvNone then
  1155.   begin
  1156.     AdjustColors(BevelInner);
  1157.     Frame3D(Canvas, Rect, TopColor, BottomColor, BevelWidth);
  1158.   end;
  1159.   with Canvas do
  1160.   begin
  1161.     Brush.Color := Color;
  1162.     FillRect(Rect);
  1163.     Brush.Style := bsClear;
  1164.     Font := Self.Font;
  1165.     FontHeight := TextHeight('W');
  1166.     with Rect do
  1167.     begin
  1168.       Top := ((Bottom + Top) - FontHeight) div 2;
  1169.       Bottom := Top + FontHeight;
  1170.     end;
  1171.     DrawText(Handle, PChar(Caption), -1, Rect, (DT_EXPANDTABS or
  1172.       DT_VCENTER) or Alignments[FAlignment]);
  1173.   end;
  1174. end;
  1175.  
  1176. procedure TCustomPanel.SetAlignment(Value: TAlignment);
  1177. begin
  1178.   FAlignment := Value;
  1179.   Invalidate;
  1180. end;
  1181.  
  1182. procedure TCustomPanel.SetBevelInner(Value: TPanelBevel);
  1183. begin
  1184.   FBevelInner := Value;
  1185.   Realign;
  1186.   Invalidate;
  1187. end;
  1188.  
  1189. procedure TCustomPanel.SetBevelOuter(Value: TPanelBevel);
  1190. begin
  1191.   FBevelOuter := Value;
  1192.   Realign;
  1193.   Invalidate;
  1194. end;
  1195.  
  1196. procedure TCustomPanel.SetBevelWidth(Value: TBevelWidth);
  1197. begin
  1198.   FBevelWidth := Value;
  1199.   Realign;
  1200.   Invalidate;
  1201. end;
  1202.  
  1203. procedure TCustomPanel.SetBorderWidth(Value: TBorderWidth);
  1204. begin
  1205.   FBorderWidth := Value;
  1206.   Realign;
  1207.   Invalidate;
  1208. end;
  1209.  
  1210. procedure TCustomPanel.SetBorderStyle(Value: TBorderStyle);
  1211. begin
  1212.   if FBorderStyle <> Value then
  1213.   begin
  1214.     FBorderStyle := Value;
  1215.     RecreateWnd;
  1216.   end;
  1217. end;
  1218.  
  1219. { TPageAccess }
  1220.  
  1221. type
  1222.   TPageAccess = class(TStrings)
  1223.   private
  1224.     PageList: TList;
  1225.     Notebook: TNotebook;
  1226.   protected
  1227.     function GetCount: Integer; override;
  1228.     function Get(Index: Integer): string; override;
  1229.     procedure Put(Index: Integer; const S: string); override;
  1230.     function GetObject(Index: Integer): TObject; override;
  1231.     procedure SetUpdateState(Updating: Boolean); override;
  1232.   public
  1233.     constructor Create(APageList: TList; ANotebook: TNotebook);
  1234.     procedure Clear; override;
  1235.     procedure Delete(Index: Integer); override;
  1236.     procedure Insert(Index: Integer; const S: string); override;
  1237.     procedure Move(CurIndex, NewIndex: Integer); override;
  1238.   end;
  1239.  
  1240. constructor TPageAccess.Create(APageList: TList; ANotebook: TNotebook);
  1241. begin
  1242.   inherited Create;
  1243.   PageList := APageList;
  1244.   Notebook := ANotebook;
  1245. end;
  1246.  
  1247. function TPageAccess.GetCount: Integer;
  1248. begin
  1249.   Result := PageList.Count;
  1250. end;
  1251.  
  1252. function TPageAccess.Get(Index: Integer): string;
  1253. begin
  1254.   Result := TPage(PageList[Index]).Caption;
  1255. end;
  1256.  
  1257. procedure TPageAccess.Put(Index: Integer; const S: string);
  1258. begin
  1259.   TPage(PageList[Index]).Caption := S;
  1260. end;
  1261.  
  1262. function TPageAccess.GetObject(Index: Integer): TObject;
  1263. begin
  1264.   Result := PageList[Index];
  1265. end;
  1266.  
  1267. procedure TPageAccess.SetUpdateState(Updating: Boolean);
  1268. begin
  1269.   { do nothing }
  1270. end;
  1271.  
  1272. procedure TPageAccess.Clear;
  1273. var
  1274.   I: Integer;
  1275. begin
  1276.   for I := 0 to PageList.Count - 1 do
  1277.     TPage(PageList[I]).Free;
  1278.   PageList.Clear;
  1279. end;
  1280.  
  1281. procedure TPageAccess.Delete(Index: Integer);
  1282. var
  1283.   Form: TCustomForm;
  1284. begin
  1285.   TPage(PageList[Index]).Free;
  1286.   PageList.Delete(Index);
  1287.   NoteBook.PageIndex := 0;
  1288.  
  1289.   if csDesigning in NoteBook.ComponentState then
  1290.   begin
  1291.     Form := GetParentForm(NoteBook);
  1292.     if (Form <> nil) and (Form.Designer <> nil) then
  1293.       Form.Designer.Modified;
  1294.   end;
  1295. end;
  1296.  
  1297. procedure TPageAccess.Insert(Index: Integer; const S: string);
  1298. var
  1299.   Page: TPage;
  1300.   Form: TCustomForm;
  1301. begin
  1302.   Page := TPage.Create(Notebook);
  1303.   with Page do
  1304.   begin
  1305.     Parent := Notebook;
  1306.     Caption := S;
  1307.   end;
  1308.   PageList.Insert(Index, Page);
  1309.  
  1310.   NoteBook.PageIndex := Index;
  1311.  
  1312.   if csDesigning in NoteBook.ComponentState then
  1313.   begin
  1314.     Form := GetParentForm(NoteBook);
  1315.     if (Form <> nil) and (Form.Designer <> nil) then
  1316.       Form.Designer.Modified;
  1317.   end;
  1318. end;
  1319.  
  1320. procedure TPageAccess.Move(CurIndex, NewIndex: Integer);
  1321. var
  1322.   AObject: TObject;
  1323. begin
  1324.   if CurIndex <> NewIndex then
  1325.   begin
  1326.     AObject := PageList[CurIndex];
  1327.     PageList[CurIndex] := PageList[NewIndex];
  1328.     PageList[NewIndex] := AObject;
  1329.   end;
  1330. end;
  1331.  
  1332. { TPage }
  1333.  
  1334. constructor TPage.Create(AOwner: TComponent);
  1335. begin
  1336.   inherited Create(AOwner);
  1337.   Visible := False;
  1338.   ControlStyle := ControlStyle + [csAcceptsControls];
  1339.   Align := alClient;
  1340. end;
  1341.  
  1342. procedure TPage.Paint;
  1343. begin
  1344.   inherited Paint;
  1345.   if csDesigning in ComponentState then
  1346.     with Canvas do
  1347.     begin
  1348.       Pen.Style := psDash;
  1349.       Brush.Style := bsClear;
  1350.       Rectangle(0, 0, Width, Height);
  1351.     end;
  1352. end;
  1353.  
  1354. procedure TPage.ReadState(Reader: TReader);
  1355. begin
  1356.   if Reader.Parent is TNotebook then
  1357.     TNotebook(Reader.Parent).FPageList.Add(Self);
  1358.   inherited ReadState(Reader);
  1359. end;
  1360.  
  1361. procedure TPage.WMNCHitTest(var Message: TWMNCHitTest);
  1362. begin
  1363.   if not (csDesigning in ComponentState) then
  1364.     Message.Result := HTTRANSPARENT
  1365.   else
  1366.     inherited;
  1367. end;
  1368.  
  1369. { TNotebook }
  1370.  
  1371. var
  1372.   Registered: Boolean = False;
  1373.  
  1374. constructor TNotebook.Create(AOwner: TComponent);
  1375. begin
  1376.   inherited Create(AOwner);
  1377.   Width := 150;
  1378.   Height := 150;
  1379.   FPageList := TList.Create;
  1380.   FAccess := TPageAccess.Create(FPageList, Self);
  1381.   FPageIndex := -1;
  1382.   FAccess.Add(SDefault);
  1383.   PageIndex := 0;
  1384.   Exclude(FComponentStyle, csInheritable);
  1385.   if not Registered then
  1386.   begin
  1387.     Classes.RegisterClasses([TPage]);
  1388.     Registered := True;
  1389.   end;
  1390. end;
  1391.  
  1392. destructor TNotebook.Destroy;
  1393. begin
  1394.   FAccess.Free;
  1395.   FPageList.Free;
  1396.   inherited Destroy;
  1397. end;
  1398.  
  1399. procedure TNotebook.CreateParams(var Params: TCreateParams);
  1400. begin
  1401.   inherited CreateParams(Params);
  1402.   with Params do
  1403.   begin
  1404.     Style := Style or WS_CLIPCHILDREN;
  1405.     WindowClass.style := WindowClass.style and not (CS_HREDRAW or CS_VREDRAW);
  1406.   end;
  1407. end;
  1408.  
  1409. function TNotebook.GetChildOwner: TComponent;
  1410. begin
  1411.   Result := Self;
  1412. end;
  1413.  
  1414. procedure TNotebook.GetChildren(Proc: TGetChildProc; Root: TComponent);
  1415. var
  1416.   I: Integer;
  1417. begin
  1418.   for I := 0 to FPageList.Count - 1 do Proc(TControl(FPageList[I]));
  1419. end;
  1420.  
  1421. procedure TNotebook.ReadState(Reader: TReader);
  1422. begin
  1423.   Pages.Clear;
  1424.   inherited ReadState(Reader);
  1425.   if (FPageIndex <> -1) and (FPageIndex >= 0) and (FPageIndex < FPageList.Count) then
  1426.     with TPage(FPageList[FPageIndex]) do
  1427.     begin
  1428.       BringToFront;
  1429.       Visible := True;
  1430.       Align := alClient;
  1431.     end
  1432.   else FPageIndex := -1;
  1433. end;
  1434.  
  1435. procedure TNotebook.ShowControl(AControl: TControl);
  1436. var
  1437.   I: Integer;
  1438. begin
  1439.   for I := 0 to FPageList.Count - 1 do
  1440.     if FPageList[I] = AControl then
  1441.     begin
  1442.       SetPageIndex(I);
  1443.       Exit;
  1444.     end;
  1445.   inherited ShowControl(AControl);
  1446. end;
  1447.  
  1448. procedure TNotebook.SetPages(Value: TStrings);
  1449. begin
  1450.   FAccess.Assign(Value);
  1451. end;
  1452.  
  1453. procedure TNotebook.SetPageIndex(Value: Integer);
  1454. var
  1455.   ParentForm: TCustomForm;
  1456. begin
  1457.   if csLoading in ComponentState then
  1458.   begin
  1459.     FPageIndex := Value;
  1460.     Exit;
  1461.   end;
  1462.   if (Value <> FPageIndex) and (Value >= 0) and (Value < FPageList.Count) then
  1463.   begin
  1464.     ParentForm := GetParentForm(Self);
  1465.     if ParentForm <> nil then
  1466.       if ContainsControl(ParentForm.ActiveControl) then
  1467.         ParentForm.ActiveControl := Self;
  1468.     with TPage(FPageList[Value]) do
  1469.     begin
  1470.       BringToFront;
  1471.       Visible := True;
  1472.       Align := alClient;
  1473.     end;
  1474.     if (FPageIndex >= 0) and (FPageIndex < FPageList.Count) then
  1475.       TPage(FPageList[FPageIndex]).Visible := False;
  1476.     FPageIndex := Value;
  1477.     if ParentForm <> nil then
  1478.       if ParentForm.ActiveControl = Self then SelectFirst;
  1479.     if Assigned(FOnPageChanged) then
  1480.       FOnPageChanged(Self);
  1481.   end;
  1482. end;
  1483.  
  1484. procedure TNotebook.SetActivePage(const Value: string);
  1485. begin
  1486.   SetPageIndex(FAccess.IndexOf(Value));
  1487. end;
  1488.  
  1489. function TNotebook.GetActivePage: string;
  1490. begin
  1491.   Result := FAccess[FPageIndex];
  1492. end;
  1493.  
  1494. { THeaderStrings }
  1495.  
  1496. const
  1497.   DefaultSectionWidth = 75;
  1498.  
  1499. type
  1500.   PHeaderSection = ^THeaderSection;
  1501.   THeaderSection = record
  1502.     FObject: TObject;
  1503.     Width: Integer;
  1504.     Title: string;
  1505.   end;
  1506.  
  1507. type
  1508.   THeaderStrings = class(TStrings)
  1509.   private
  1510.     FHeader: THeader;
  1511.     FList: TList;
  1512.     procedure ReadData(Reader: TReader);
  1513.     procedure WriteData(Writer: TWriter);
  1514.   protected
  1515.     procedure DefineProperties(Filer: TFiler); override;
  1516.     function Get(Index: Integer): string; override;
  1517.     function GetCount: Integer; override;
  1518.     function GetObject(Index: Integer): TObject; override;
  1519.     procedure Put(Index: Integer; const S: string); override;
  1520.     procedure PutObject(Index: Integer; AObject: TObject); override;
  1521.     procedure SetUpdateState(Updating: Boolean); override;
  1522.   public
  1523.     constructor Create;
  1524.     destructor Destroy; override;
  1525.     procedure Assign(Source: TPersistent); override;
  1526.     procedure Delete(Index: Integer); override;
  1527.     procedure Insert(Index: Integer; const S: string); override;
  1528.     procedure Clear; override;
  1529.   end;
  1530.  
  1531. procedure FreeSection(Section: PHeaderSection);
  1532. begin
  1533.   if Section <> nil then Dispose(Section);
  1534. end;
  1535.  
  1536. function NewSection(const ATitle: string; AWidth: Integer; AObject: TObject): PHeaderSection;
  1537. begin
  1538.   New(Result);
  1539.   with Result^ do
  1540.   begin
  1541.     Title := ATitle;
  1542.     Width := AWidth;
  1543.     FObject := AObject;
  1544.   end;
  1545. end;
  1546.  
  1547. constructor THeaderStrings.Create;
  1548. begin
  1549.   inherited Create;
  1550.   FList := TList.Create;
  1551. end;
  1552.  
  1553. destructor THeaderStrings.Destroy;
  1554. begin
  1555.   if FList <> nil then
  1556.   begin
  1557.     Clear;
  1558.     FList.Destroy;
  1559.   end;
  1560.   inherited Destroy;
  1561. end;
  1562.  
  1563. procedure THeaderStrings.Assign(Source: TPersistent);
  1564. var
  1565.   I, J: Integer;
  1566.   Strings: TStrings;
  1567.   NewList: TList;
  1568.   Section: PHeaderSection;
  1569.   TempStr: string;
  1570.   Found: Boolean;
  1571. begin
  1572.   if Source is TStrings then
  1573.   begin
  1574.     Strings := TStrings(Source);
  1575.     BeginUpdate;
  1576.     try
  1577.       NewList := TList.Create;
  1578.       try
  1579.         { Delete any sections not in the new list }
  1580.         I := FList.Count - 1;
  1581.         Found := False;
  1582.         while I >= 0 do
  1583.         begin
  1584.           TempStr := Get(I);
  1585.           for J := 0 to Strings.Count - 1 do
  1586.           begin
  1587.             Found := CompareStr(Strings[J], TempStr) = 0;
  1588.             if Found then Break;
  1589.           end;
  1590.           if not Found then Delete(I);
  1591.           Dec(I);
  1592.         end;
  1593.  
  1594.         { Now iterate over the lists and maintain section widths of sections in
  1595.           the new list }
  1596.         I := 0;
  1597.         for J := 0 to Strings.Count - 1 do
  1598.         begin
  1599.           if (I < FList.Count) and (CompareStr(Strings[J], Get(I)) = 0) then
  1600.           begin
  1601.             Section := NewSection(Get(I), PHeaderSection(FList[I])^.Width, GetObject(I));
  1602.             Inc(I);
  1603.           end else
  1604.             Section := NewSection(Strings[J],
  1605.               FHeader.Canvas.TextWidth(Strings[J]) + 8, Strings.Objects[J]);
  1606.           NewList.Add(Section);
  1607.         end;
  1608.         Clear;
  1609.         FList.Destroy;
  1610.         FList := NewList;
  1611.         FHeader.Invalidate;
  1612.       except
  1613.         for I := 0 to NewList.Count - 1 do
  1614.           FreeSection(NewList[I]);
  1615.         NewList.Destroy;
  1616.         raise;
  1617.       end;
  1618.     finally
  1619.       EndUpdate;
  1620.     end;
  1621.     Exit;
  1622.   end;
  1623.   inherited Assign(Source);
  1624. end;
  1625.  
  1626. procedure THeaderStrings.DefineProperties(Filer: TFiler);
  1627. begin
  1628.   { This will allow the old file image read in }
  1629.   if Filer is TReader then inherited DefineProperties(Filer);
  1630.   Filer.DefineProperty('Sections', ReadData, WriteData, Count > 0);
  1631. end;
  1632.  
  1633. procedure THeaderStrings.Clear;
  1634. var
  1635.   I: Integer;
  1636. begin
  1637.   for I := 0 to FList.Count - 1 do
  1638.     FreeSection(FList[I]);
  1639.   FList.Clear;
  1640. end;
  1641.  
  1642. procedure THeaderStrings.Delete(Index: Integer);
  1643. begin
  1644.   FreeSection(FList[Index]);
  1645.   FList.Delete(Index);
  1646.   if FHeader <> nil then FHeader.Invalidate;
  1647. end;
  1648.  
  1649. function THeaderStrings.Get(Index: Integer): string;
  1650. begin
  1651.   Result := PHeaderSection(FList[Index])^.Title;
  1652. end;
  1653.  
  1654. function THeaderStrings.GetCount: Integer;
  1655. begin
  1656.   Result := FList.Count;
  1657. end;
  1658.  
  1659. function THeaderStrings.GetObject(Index: Integer): TObject;
  1660. begin
  1661.   Result := PHeaderSection(FList[Index])^.FObject;
  1662. end;
  1663.  
  1664. procedure THeaderStrings.Insert(Index: Integer; const S: string);
  1665. var
  1666.   Width: Integer;
  1667. begin
  1668.   if FHeader <> nil then
  1669.     Width := FHeader.Canvas.TextWidth(S) + 8
  1670.   else Width := DefaultSectionWidth;
  1671.   FList.Expand.Insert(Index, NewSection(S, Width, nil));
  1672.   if FHeader <> nil then FHeader.Invalidate;
  1673. end;
  1674.  
  1675. procedure THeaderStrings.Put(Index: Integer; const S: string);
  1676. var
  1677.   P: PHeaderSection;
  1678.   Width: Integer;
  1679. begin
  1680.   P := FList[Index];
  1681.   if FHeader <> nil then
  1682.     Width := FHeader.Canvas.TextWidth(S) + 8
  1683.   else Width := DefaultSectionWidth;
  1684.   FList[Index] := NewSection(S, Width, P^.FObject);
  1685.   FreeSection(P);
  1686.   if FHeader <> nil then FHeader.Invalidate;
  1687. end;
  1688.  
  1689. procedure THeaderStrings.PutObject(Index: Integer; AObject: TObject);
  1690. begin
  1691.   PHeaderSection(FList[Index])^.FObject := AObject;
  1692.   if FHeader <> nil then FHeader.Invalidate;
  1693. end;
  1694.  
  1695. procedure THeaderStrings.ReadData(Reader: TReader);
  1696. var
  1697.   Width, I: Integer;
  1698.   Str: string;
  1699. begin
  1700.   Reader.ReadListBegin;
  1701.   Clear;
  1702.   while not Reader.EndOfList do
  1703.   begin
  1704.     Str := Reader.ReadString;
  1705.     Width := DefaultSectionWidth;
  1706.     I := 1;
  1707.     if Str[1] = #0 then
  1708.     begin
  1709.       repeat
  1710.         Inc(I);
  1711.       until (I > Length(Str)) or (Str[I] = #0);
  1712.       Width := StrToIntDef(Copy(Str, 2, I - 2), DefaultSectionWidth);
  1713.       System.Delete(Str, 1, I);
  1714.     end;
  1715.     FList.Expand.Insert(FList.Count, NewSection(Str, Width, nil));
  1716.   end;
  1717.   Reader.ReadListEnd;
  1718. end;
  1719.  
  1720. procedure THeaderStrings.SetUpdateState(Updating: Boolean);
  1721. begin
  1722.   if FHeader <> nil then
  1723.   begin
  1724.     SendMessage(FHeader.Handle, WM_SETREDRAW, Ord(not Updating), 0);
  1725.     if not Updating then FHeader.Refresh;
  1726.   end;
  1727. end;
  1728.  
  1729. procedure THeaderStrings.WriteData(Writer: TWriter);
  1730. var
  1731.   I: Integer;
  1732.   HeaderSection: PHeaderSection;
  1733. begin
  1734.   Writer.WriteListBegin;
  1735.   for I := 0 to Count - 1 do
  1736.   begin
  1737.     HeaderSection := FList[I];
  1738.     with HeaderSection^ do
  1739.       Writer.WriteString(Format(#0'%d'#0'%s', [Width, Title]));
  1740.   end;
  1741.   Writer.WriteListEnd;
  1742. end;
  1743.  
  1744. { THeader }
  1745.  
  1746. constructor THeader.Create(AOwner: TComponent);
  1747. begin
  1748.   inherited Create(AOwner);
  1749.   ControlStyle := ControlStyle + [csDesignInteractive, csOpaque];
  1750.   Width := 250;
  1751.   Height := 25;
  1752.   FSections := THeaderStrings.Create;
  1753.   THeaderStrings(FSections).FHeader := Self;
  1754.   FAllowResize := True;
  1755.   FBorderStyle := bsSingle;
  1756. end;
  1757.  
  1758. destructor THeader.Destroy;
  1759. begin
  1760.   FreeSections;
  1761.   FSections.Free;
  1762.   inherited Destroy;
  1763. end;
  1764.  
  1765. procedure THeader.CreateParams(var Params: TCreateParams);
  1766. const
  1767.   BorderStyles: array[TBorderStyle] of Longint = (0, WS_BORDER);
  1768. begin
  1769.   inherited CreateParams(Params);
  1770.   with Params do
  1771.   begin
  1772.     Style := Style or BorderStyles[FBorderStyle];
  1773.     WindowClass.style := WindowClass.style and not (CS_HREDRAW or CS_VREDRAW);
  1774.   end;
  1775. end;
  1776.  
  1777. procedure THeader.Paint;
  1778. var
  1779.   I, Y, W: Integer;
  1780.   S: string;
  1781.   R: TRect;
  1782. begin
  1783.   with Canvas do
  1784.   begin
  1785.     Font := Self.Font;
  1786.     Brush.Color := clBtnFace;
  1787.     I := 0;
  1788.     Y := (ClientHeight - Canvas.TextHeight('T')) div 2;
  1789.     R := Rect(0, 0, 0, ClientHeight);
  1790.     W := 0;
  1791.     S := '';
  1792.     repeat
  1793.       if I < FSections.Count then
  1794.       begin
  1795.         with PHeaderSection(THeaderStrings(FSections).FList[I])^ do
  1796.         begin
  1797.           W := Width;
  1798.           S := Title;
  1799.         end;
  1800.         Inc(I);
  1801.       end;
  1802.       R.Left := R.Right;
  1803.       Inc(R.Right, W);
  1804.       if (ClientWidth - R.Right < 2) or (I = FSections.Count) then
  1805.         R.Right := ClientWidth;
  1806.       TextRect(Rect(R.Left + 1, R.Top + 1, R.Right - 1, R.Bottom - 1),
  1807.         R.Left + 3, Y, S);
  1808.       DrawEdge(Canvas.Handle, R, BDR_RAISEDINNER, BF_TOPLEFT);
  1809.       DrawEdge(Canvas.Handle, R, BDR_RAISEDINNER, BF_BOTTOMRight);
  1810.     until R.Right = ClientWidth;
  1811.   end;
  1812. end;
  1813.  
  1814. procedure THeader.FreeSections;
  1815. begin
  1816.   if FSections <> nil then
  1817.     FSections.Clear;
  1818. end;
  1819.  
  1820. procedure THeader.SetBorderStyle(Value: TBorderStyle);
  1821. begin
  1822.   if Value <> FBorderStyle then
  1823.   begin
  1824.     FBorderStyle := Value;
  1825.     RecreateWnd;
  1826.   end;
  1827. end;
  1828.  
  1829. procedure THeader.SetSections(Strings: TStrings);
  1830. begin
  1831.   FSections.Assign(Strings);
  1832. end;
  1833.  
  1834. function THeader.GetWidth(X: Integer): Integer;
  1835. var
  1836.   I, W: Integer;
  1837. begin
  1838.   if X = FSections.Count - 1 then
  1839.   begin
  1840.     W := 0;
  1841.     for I := 0 to X - 1 do
  1842.       Inc(W, PHeaderSection(THeaderStrings(FSections).FList[I])^.Width);
  1843.     Result := ClientWidth - W;
  1844.   end
  1845.   else if (X >= 0) and (X < FSections.Count) then
  1846.     Result := PHeaderSection(THeaderStrings(FSections).FList[X])^.Width
  1847.   else
  1848.     Result := 0;
  1849. end;
  1850.  
  1851. procedure THeader.SetWidth(X: Integer; Value: Integer);
  1852. begin
  1853.   if X < 0 then Exit;
  1854.   PHeaderSection(THeaderStrings(FSections).FList[X])^.Width := Value;
  1855.   Invalidate;
  1856. end;
  1857.  
  1858. procedure THeader.WMNCHitTest(var Msg: TWMNCHitTest);
  1859. begin
  1860.   inherited;
  1861.   FHitTest := SmallPointToPoint(Msg.Pos);
  1862. end;
  1863.  
  1864. procedure THeader.WMSetCursor(var Msg: TWMSetCursor);
  1865. var
  1866.   Cur: HCURSOR;
  1867.   I: Integer;
  1868.   X: Integer;
  1869. begin
  1870.   Cur := 0;
  1871.   FResizeSection := 0;
  1872.   FHitTest := ScreenToClient(FHitTest);
  1873.   X := 2;
  1874.   with Msg do
  1875.     if HitTest = HTCLIENT then
  1876.       for I := 0 to FSections.Count - 2 do  { don't count last section }
  1877.       begin
  1878.         Inc(X, PHeaderSection(THeaderStrings(FSections).FList[I])^.Width);
  1879.         FMouseOffset := X - (FHitTest.X + 2);
  1880.         if Abs(FMouseOffset) < 4 then
  1881.         begin
  1882.           Cur := LoadCursor(0, IDC_SIZEWE);
  1883.           FResizeSection := I;
  1884.           Break;
  1885.         end;
  1886.       end;
  1887.   FCanResize := (FAllowResize or (csDesigning in ComponentState)) and (Cur <> 0);
  1888.   if FCanResize then SetCursor(Cur)
  1889.   else inherited;
  1890. end;
  1891.  
  1892. procedure THeader.MouseDown(Button: TMouseButton; Shift: TShiftState;
  1893.   X, Y: Integer);
  1894. begin
  1895.   inherited MouseDown(Button, Shift, X, Y);
  1896.   if ((csDesigning in ComponentState) and (Button = mbRight)) or (Button = mbLeft) then
  1897.     if FCanResize then SetCapture(Handle);
  1898. end;
  1899.  
  1900. procedure THeader.MouseMove(Shift: TShiftState; X, Y: Integer);
  1901. var
  1902.   I: Integer;
  1903.   AbsPos: Integer;
  1904.   MinPos: Integer;
  1905.   MaxPos: Integer;
  1906. begin
  1907.   inherited MouseMove(Shift, X, Y);
  1908.   if (GetCapture = Handle) and FCanResize then
  1909.   begin
  1910.     { absolute position of this item }
  1911.     AbsPos := 2;
  1912.     for I := 0 to FResizeSection do
  1913.       Inc(AbsPos, PHeaderSection(THeaderStrings(FSections).FList[I])^.Width);
  1914.  
  1915.     if FResizeSection > 0 then MinPos := AbsPos -
  1916.       PHeaderSection(THeaderStrings(FSections).FList[FResizeSection])^.Width + 2
  1917.     else MinPos := 2;
  1918.     MaxPos := ClientWidth - 2;
  1919.     if X < MinPos then X := MinPos;
  1920.     if X > MaxPos then X := MaxPos;
  1921.  
  1922.     Dec(PHeaderSection(THeaderStrings(FSections).FList[FResizeSection])^.Width,
  1923.       (AbsPos - X - 2) - FMouseOffset);
  1924.     Sizing(FResizeSection,
  1925.       PHeaderSection(THeaderStrings(FSections).FList[FResizeSection])^.Width);
  1926.     Refresh;
  1927.   end;
  1928. end;
  1929.  
  1930. procedure THeader.MouseUp(Button: TMouseButton; Shift: TShiftState;
  1931.   X, Y: Integer);
  1932. begin
  1933.   if FCanResize then
  1934.   begin
  1935.     ReleaseCapture;
  1936.     Sized(FResizeSection,
  1937.       PHeaderSection(THeaderStrings(FSections).FList[FResizeSection])^.Width);
  1938.     FCanResize := False;
  1939.   end;
  1940.   inherited MouseUp(Button, Shift, X, Y);
  1941. end;
  1942.  
  1943. procedure THeader.Sizing(ASection, AWidth: Integer);
  1944. begin
  1945.   if Assigned(FOnSizing) then FOnSizing(Self, ASection, AWidth);
  1946. end;
  1947.  
  1948. procedure THeader.Sized(ASection, AWidth: Integer);
  1949. var
  1950.   Form: TCustomForm;
  1951. begin
  1952.   if Assigned(FOnSized) then FOnSized(Self, ASection, AWidth);
  1953.   if csDesigning in ComponentState then
  1954.   begin
  1955.     Form := GetParentForm(Self);
  1956.     if Form <> nil then
  1957.       Form.Designer.Modified;
  1958.   end;
  1959. end;
  1960.  
  1961. procedure THeader.WMSize(var Msg: TWMSize);
  1962. begin
  1963.   inherited;
  1964.   Invalidate;
  1965. end;
  1966.  
  1967. { TGroupButton }
  1968.  
  1969. type
  1970.   TGroupButton = class(TRadioButton)
  1971.   private
  1972.     FInClick: Boolean;
  1973.     procedure CNCommand(var Message: TWMCommand); message CN_COMMAND;
  1974.   protected
  1975.     procedure ChangeScale(M, D: Integer); override;
  1976.     procedure KeyDown(var Key: Word; Shift: TShiftState); override;
  1977.     procedure KeyPress(var Key: Char); override;
  1978.   public
  1979.     constructor InternalCreate(RadioGroup: TCustomRadioGroup);
  1980.     destructor Destroy; override;
  1981.   end;
  1982.  
  1983. constructor TGroupButton.InternalCreate(RadioGroup: TCustomRadioGroup);
  1984. begin
  1985.   inherited Create(RadioGroup);
  1986.   RadioGroup.FButtons.Add(Self);
  1987.   Visible := False;
  1988.   Enabled := RadioGroup.Enabled;
  1989.   ParentShowHint := False;
  1990.   OnClick := RadioGroup.ButtonClick;
  1991.   Parent := RadioGroup;
  1992. end;
  1993.  
  1994. destructor TGroupButton.Destroy;
  1995. begin
  1996.   TCustomRadioGroup(Owner).FButtons.Remove(Self);
  1997.   inherited Destroy;
  1998. end;
  1999.  
  2000. procedure TGroupButton.CNCommand(var Message: TWMCommand);
  2001. begin
  2002.   if not FInClick then
  2003.   begin
  2004.     FInClick := True;
  2005.     try
  2006.       if ((Message.NotifyCode = BN_CLICKED) or
  2007.         (Message.NotifyCode = BN_DOUBLECLICKED)) and
  2008.         TCustomRadioGroup(Parent).CanModify then
  2009.         inherited;
  2010.     except
  2011.       Application.HandleException(Self);
  2012.     end;
  2013.     FInClick := False;
  2014.   end;
  2015. end;
  2016.  
  2017. procedure TGroupButton.ChangeScale(M, D: Integer);
  2018. begin
  2019. end;
  2020.  
  2021. procedure TGroupButton.KeyPress(var Key: Char);
  2022. begin
  2023.   inherited KeyPress(Key);
  2024.   TCustomRadioGroup(Parent).KeyPress(Key);
  2025.   if (Key = #8) or (Key = ' ') then
  2026.   begin
  2027.     if not TCustomRadioGroup(Parent).CanModify then Key := #0;
  2028.   end;
  2029. end;
  2030.  
  2031. procedure TGroupButton.KeyDown(var Key: Word; Shift: TShiftState);
  2032. begin
  2033.   inherited KeyDown(Key, Shift);
  2034.   TCustomRadioGroup(Parent).KeyDown(Key, Shift);
  2035. end;
  2036.  
  2037. { TCustomRadioGroup }
  2038.  
  2039. constructor TCustomRadioGroup.Create(AOwner: TComponent);
  2040. begin
  2041.   inherited Create(AOwner);
  2042.   ControlStyle := [csSetCaption, csDoubleClicks];
  2043.   FButtons := TList.Create;
  2044.   FItems := TStringList.Create;
  2045.   TStringList(FItems).OnChange := ItemsChange;
  2046.   FItemIndex := -1;
  2047.   FColumns := 1;
  2048. end;
  2049.  
  2050. destructor TCustomRadioGroup.Destroy;
  2051. begin
  2052.   SetButtonCount(0);
  2053.   TStringList(FItems).OnChange := nil;
  2054.   FItems.Free;
  2055.   FButtons.Free;
  2056.   inherited Destroy;
  2057. end;
  2058.  
  2059. procedure TCustomRadioGroup.ArrangeButtons;
  2060. var
  2061.   ButtonsPerCol, ButtonWidth, ButtonHeight, TopMargin, I: Integer;
  2062.   DC: HDC;
  2063.   SaveFont: HFont;
  2064.   Metrics: TTextMetric;
  2065.   DeferHandle: THandle;
  2066. begin
  2067.   if (FButtons.Count <> 0) and not FReading then
  2068.   begin
  2069.     DC := GetDC(0);
  2070.     SaveFont := SelectObject(DC, Font.Handle);
  2071.     GetTextMetrics(DC, Metrics);
  2072.     SelectObject(DC, SaveFont);
  2073.     ReleaseDC(0, DC);
  2074.     ButtonsPerCol := (FButtons.Count + FColumns - 1) div FColumns;
  2075.     ButtonWidth := (Width - 10) div FColumns;
  2076.     I := Height - Metrics.tmHeight - 5;
  2077.     ButtonHeight := I div ButtonsPerCol;
  2078.     TopMargin := Metrics.tmHeight + 1 + (I mod ButtonsPerCol) div 2;
  2079.     DeferHandle := BeginDeferWindowPos(FButtons.Count);
  2080.     for I := 0 to FButtons.Count - 1 do
  2081.       with TGroupButton(FButtons[I]) do
  2082.       begin
  2083.         DeferHandle := DeferWindowPos(DeferHandle, Handle, 0,
  2084.           (I div ButtonsPerCol) * ButtonWidth + 8,
  2085.           (I mod ButtonsPerCol) * ButtonHeight + TopMargin,
  2086.           ButtonWidth, ButtonHeight,
  2087.           SWP_NOZORDER or SWP_NOACTIVATE);
  2088.         Visible := True;
  2089.       end;
  2090.     EndDeferWindowPos(DeferHandle);
  2091.   end;
  2092. end;
  2093.  
  2094. procedure TCustomRadioGroup.ButtonClick(Sender: TObject);
  2095. begin
  2096.   if not FUpdating then
  2097.   begin
  2098.     FItemIndex := FButtons.IndexOf(Sender);
  2099.     Changed;
  2100.     Click;
  2101.   end;
  2102. end;
  2103.  
  2104. procedure TCustomRadioGroup.ItemsChange(Sender: TObject);
  2105. begin
  2106.   if not FReading then
  2107.   begin
  2108.     if FItemIndex >= FItems.Count then FItemIndex := FItems.Count - 1;
  2109.     UpdateButtons;
  2110.   end;
  2111. end;
  2112.  
  2113. procedure TCustomRadioGroup.ReadState(Reader: TReader);
  2114. begin
  2115.   FReading := True;
  2116.   inherited ReadState(Reader);
  2117.   FReading := False;
  2118.   UpdateButtons;
  2119. end;
  2120.  
  2121. procedure TCustomRadioGroup.SetButtonCount(Value: Integer);
  2122. begin
  2123.   while FButtons.Count < Value do TGroupButton.InternalCreate(Self);
  2124.   while FButtons.Count > Value do TGroupButton(FButtons.Last).Free;
  2125. end;
  2126.  
  2127. procedure TCustomRadioGroup.SetColumns(Value: Integer);
  2128. begin
  2129.   if Value < 1 then Value := 1;
  2130.   if Value > 16 then Value := 16;
  2131.   if FColumns <> Value then
  2132.   begin
  2133.     FColumns := Value;
  2134.     ArrangeButtons;
  2135.     Invalidate;
  2136.   end;
  2137. end;
  2138.  
  2139. procedure TCustomRadioGroup.SetItemIndex(Value: Integer);
  2140. begin
  2141.   if FReading then FItemIndex := Value else
  2142.   begin
  2143.     if Value < -1 then Value := -1;
  2144.     if Value >= FButtons.Count then Value := FButtons.Count - 1;
  2145.     if FItemIndex <> Value then
  2146.     begin
  2147.       if FItemIndex >= 0 then
  2148.         TGroupButton(FButtons[FItemIndex]).Checked := False;
  2149.       FItemIndex := Value;
  2150.       if FItemIndex >= 0 then
  2151.         TGroupButton(FButtons[FItemIndex]).Checked := True;
  2152.     end;
  2153.   end;
  2154. end;
  2155.  
  2156. procedure TCustomRadioGroup.SetItems(Value: TStrings);
  2157. begin
  2158.   FItems.Assign(Value);
  2159. end;
  2160.  
  2161. procedure TCustomRadioGroup.UpdateButtons;
  2162. var
  2163.   I: Integer;
  2164. begin
  2165.   SetButtonCount(FItems.Count);
  2166.   for I := 0 to FButtons.Count - 1 do
  2167.     TGroupButton(FButtons[I]).Caption := FItems[I];
  2168.   if FItemIndex >= 0 then
  2169.   begin
  2170.     FUpdating := True;
  2171.     TGroupButton(FButtons[FItemIndex]).Checked := True;
  2172.     FUpdating := False;
  2173.   end;
  2174.   ArrangeButtons;
  2175.   Invalidate;
  2176. end;
  2177.  
  2178. procedure TCustomRadioGroup.CMEnabledChanged(var Message: TMessage);
  2179. var
  2180.   I: Integer;
  2181. begin
  2182.   inherited;
  2183.   for I := 0 to FButtons.Count - 1 do
  2184.     TGroupButton(FButtons[I]).Enabled := Enabled;
  2185. end;
  2186.  
  2187. procedure TCustomRadioGroup.CMFontChanged(var Message: TMessage);
  2188. begin
  2189.   inherited;
  2190.   ArrangeButtons;
  2191. end;
  2192.  
  2193. procedure TCustomRadioGroup.WMSize(var Message: TWMSize);
  2194. begin
  2195.   inherited;
  2196.   ArrangeButtons;
  2197. end;
  2198.  
  2199. function TCustomRadioGroup.CanModify: Boolean;
  2200. begin
  2201.   Result := True;
  2202. end;
  2203.  
  2204. procedure TCustomRadioGroup.GetChildren(Proc: TGetChildProc; Root: TComponent);
  2205. begin
  2206. end;
  2207.  
  2208. type
  2209.   THack = class(TWinControl);
  2210.  
  2211. { TSplitter }  
  2212.  
  2213. constructor TSplitter.Create(AOwner: TComponent);
  2214. begin
  2215.   inherited Create(AOwner);
  2216.   Align := alLeft;
  2217.   Width := 3;
  2218.   Cursor := crHSplit;
  2219.   FMinSize := 30;
  2220.   FBeveled := True;
  2221. end;
  2222.  
  2223. procedure TSplitter.AllocateLineDC;
  2224. begin
  2225.   FLineDC := GetDCEx(Parent.Handle, 0, DCX_CACHE or DCX_CLIPSIBLINGS
  2226.     or DCX_LOCKWINDOWUPDATE);
  2227. end;
  2228.  
  2229. procedure TSplitter.DrawLine;
  2230. var
  2231.   P: TPoint;
  2232. begin
  2233.   FLineVisible := not FLineVisible;
  2234.   P := Point(Left, Top);
  2235.   if Align in [alLeft, alRight] then
  2236.     P.X := Left + FSplit else
  2237.     P.Y := Top + FSplit;
  2238.   with P do PatBlt(FLineDC, X, Y, Width, Height, PATINVERT);
  2239. end;
  2240.  
  2241. procedure TSplitter.ReleaseLineDC;
  2242. begin
  2243.   ReleaseDC(Parent.Handle, FLineDC);
  2244. end;
  2245.  
  2246. procedure TSplitter.Paint;
  2247. var
  2248.   FrameBrush: HBRUSH;
  2249.   R: TRect;
  2250. begin
  2251.   R := ClientRect;
  2252.   Canvas.Brush.Color := Color;
  2253.   Canvas.FillRect(ClientRect);
  2254.   if Beveled then
  2255.   begin
  2256.     if Align in [alLeft, alRight] then
  2257.       InflateRect(R, -1, 2) else
  2258.       InflateRect(R, 2, -1);
  2259.     OffsetRect(R, 1, 1);
  2260.     FrameBrush := CreateSolidBrush(ColorToRGB(clBtnHighlight));
  2261.     FrameRect(Canvas.Handle, R, FrameBrush);
  2262.     DeleteObject(FrameBrush);
  2263.     OffsetRect(R, -2, -2);
  2264.     FrameBrush := CreateSolidBrush(ColorToRGB(clBtnShadow));
  2265.     FrameRect(Canvas.Handle, R, FrameBrush);
  2266.     DeleteObject(FrameBrush);
  2267.   end;
  2268. end;
  2269.  
  2270. procedure TSplitter.MouseDown(Button: TMouseButton; Shift: TShiftState;
  2271.   X, Y: Integer);
  2272.  
  2273.   function FindControl: TControl;
  2274.   var
  2275.     P: TPoint;
  2276.     I: Integer;
  2277.   begin
  2278.     Result := nil;
  2279.     P := Point(Left, Top);
  2280.     case Align of
  2281.       alLeft: Dec(P.X);
  2282.       alRight: Inc(P.X, Width);
  2283.       alTop: Dec(P.Y);
  2284.       alBottom: Inc(P.Y, Height);
  2285.     else
  2286.       Exit;
  2287.     end;
  2288.     for I := 0 to Parent.ControlCount - 1 do
  2289.     begin
  2290.       Result := Parent.Controls[I];
  2291.       if PtInRect(Result.BoundsRect, P) then Exit;
  2292.     end;
  2293.     Result := nil;
  2294.   end;
  2295.  
  2296. var
  2297.   I: Integer;
  2298. begin
  2299.   inherited;
  2300.   if Button = mbLeft then
  2301.   begin
  2302.     FControl := FindControl;
  2303.     FDownPos := Point(X, Y);
  2304.     if Assigned(FControl) then
  2305.     begin
  2306.       if Align in [alLeft, alRight] then
  2307.       begin
  2308.         FMaxSize := Parent.ClientWidth - FMinSize;
  2309.         for I := 0 to Parent.ControlCount - 1 do
  2310.           with Parent.Controls[I] do
  2311.             if Align in [alLeft, alRight] then Dec(FMaxSize, Width);
  2312.         Inc(FMaxSize, FControl.Width);
  2313.       end
  2314.       else
  2315.       begin
  2316.         FMaxSize := Parent.ClientHeight - FMinSize;
  2317.         for I := 0 to Parent.ControlCount - 1 do
  2318.           with Parent.Controls[I] do
  2319.             if Align in [alTop, alBottom] then Dec(FMaxSize, Height);
  2320.         Inc(FMaxSize, FControl.Height);
  2321.       end;
  2322.       UpdateSize(X, Y);
  2323.       AllocateLineDC;
  2324.       with ValidParentForm(Self) do
  2325.         if ActiveControl <> nil then
  2326.         begin
  2327.           FActiveControl := ActiveControl;
  2328.           FOldKeyDown := THack(FActiveControl).OnKeyDown;
  2329.           THack(FActiveControl).OnKeyDown := FocusKeyDown;
  2330.         end;
  2331.       DrawLine;
  2332.     end;
  2333.   end;
  2334. end;
  2335.  
  2336. procedure TSplitter.UpdateSize(X, Y: Integer);
  2337. var
  2338.   S: Integer;
  2339. begin
  2340.   if Align in [alLeft, alRight] then
  2341.     FSplit := X - FDownPos.X
  2342.   else
  2343.     FSplit := Y - FDownPos.Y;
  2344.   S := 0;
  2345.   case Align of
  2346.     alLeft: S := FControl.Width + FSplit;
  2347.     alRight: S := FControl.Width - FSplit;
  2348.     alTop: S := FControl.Height + FSplit;
  2349.     alBottom: S := FControl.Height - FSplit;
  2350.   end;
  2351.   FNewSize := S;
  2352.   if S < FMinSize then
  2353.     FNewSize := FMinSize
  2354.   else if S > FMaxSize then
  2355.     FNewSize := FMaxSize;
  2356.   if S <> FNewSize then
  2357.   begin
  2358.     if Align in [alRight, alBottom] then
  2359.       S := S - FNewSize else
  2360.       S := FNewSize - S;
  2361.     Inc(FSplit, S);
  2362.   end;
  2363. end;
  2364.  
  2365. procedure TSplitter.MouseMove(Shift: TShiftState; X, Y: Integer);
  2366. begin
  2367.   inherited;
  2368.   if Assigned(FControl) then
  2369.   begin
  2370.     DrawLine;
  2371.     UpdateSize(X, Y);
  2372.     DrawLine;
  2373.   end;
  2374. end;
  2375.  
  2376. procedure TSplitter.MouseUp(Button: TMouseButton; Shift: TShiftState;
  2377.   X, Y: Integer);
  2378. begin
  2379.   inherited;
  2380.   if Assigned(FControl) then
  2381.   begin
  2382.     DrawLine;
  2383.     case Align of
  2384.       alLeft: FControl.Width := FNewSize;
  2385.       alTop: FControl.Height := FNewSize;
  2386.       alRight:
  2387.         begin
  2388.           Parent.DisableAlign;
  2389.           try
  2390.             FControl.Left := FControl.Left + (FControl.Width - FNewSize);
  2391.             FControl.Width := FNewSize;
  2392.           finally
  2393.             Parent.EnableAlign;
  2394.           end;
  2395.         end;
  2396.       alBottom:
  2397.         begin
  2398.           Parent.DisableAlign;
  2399.           try
  2400.             FControl.Top := FControl.Top + (FControl.Height - FNewSize);
  2401.             FControl.Height := FNewSize;
  2402.           finally
  2403.             Parent.EnableAlign;
  2404.           end;
  2405.         end;
  2406.     end;
  2407.     StopSizing;
  2408.   end;
  2409. end;
  2410.  
  2411. procedure TSplitter.FocusKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
  2412. begin
  2413.   if Key = VK_ESCAPE then
  2414.     StopSizing
  2415.   else if Assigned(FOldKeyDown) then
  2416.     FOldKeyDown(Sender, Key, Shift);
  2417. end;
  2418.  
  2419. procedure TSplitter.SetBeveled(Value: Boolean);
  2420. begin
  2421.   FBeveled := Value;
  2422.   Repaint;
  2423. end;
  2424.  
  2425. procedure TSplitter.StopSizing;
  2426. begin
  2427.   if Assigned(FControl) then
  2428.   begin
  2429.     if FLineVisible then DrawLine;
  2430.     FControl := nil;
  2431.     ReleaseLineDC;
  2432.     if Assigned(FActiveControl) then
  2433.     begin
  2434.       THack(FActiveControl).OnKeyDown := FOldKeyDown;
  2435.       FActiveControl := nil;
  2436.     end;
  2437.   end;
  2438.   if Assigned(FOnMoved) then
  2439.     FOnMoved(Self);
  2440. end;
  2441.  
  2442. end.
  2443.