home *** CD-ROM | disk | FTP | other *** search
/ Chip 2001 September / Chip_2001-09_cd1.bin / zkuste / delphi / kolekce / d56 / RMCTL.ZIP / rmCCTabs.pas < prev    next >
Pascal/Delphi Source File  |  2001-06-22  |  68KB  |  2,237 lines
  1. {================================================================================
  2. Copyright (C) 1997-2001 Mills Enterprise
  3.  
  4. Unit      : rmCCTabs
  5. Purpose   : This is some of the best features from the depricated ComCtrls95
  6.             component set, that I also authored.  Floating Tabsheets and Tabhints.
  7. Date      : 02-01-2000
  8. Author    : Ryan J. Mills
  9. Version   : 1.80
  10. ================================================================================}
  11.  
  12. unit rmCCTabs;
  13.  
  14. interface
  15.  
  16. {$I CompilerDefines.INC}
  17.  
  18. uses Messages, Windows, SysUtils, CommCtrl, Classes, Controls, Graphics,
  19.      ImgList, Forms;
  20.  
  21. const                                 
  22.      CM_rmCCTabsBase            = CM_BASE+333;
  23.      CM_rmCCTabSheetDraggedON   = CM_rmCCTabsBase+1;
  24.      CM_rmCCTabSheetDraggedOFF  = CM_rmCCTabsBase+2;
  25.  
  26. type
  27.   ECCTabError = Exception;
  28.  
  29.   TrmCustomCCTabControl = class;
  30.  
  31.   TTabChangingEvent = procedure(Sender: TObject; var AllowChange: Boolean) of object;
  32.  
  33.   TTabPosition = (tpTop, tpBottom, tpLeft, tpRight);
  34.   TTabStyle = (tsTabs, tsButtons, tsFlatButtons);
  35.   TGripAlign = (gaLeft, gaRight, gaTop, gaBottom);
  36.   TFloatState = (fsFloating, fsDocked);
  37.   TTabFloatEvent = procedure(Sender: TObject; FloatState: TFloatState) of object;
  38.   TTabTrackEvent = procedure(sender:TObject; TabIndex: integer) of object;
  39.  
  40.   TDrawTabEvent = procedure(Control: TrmCustomCCTabControl; TabIndex: Integer;
  41.     const Rect: TRect; Active: Boolean) of object;
  42.   TTabGetImageEvent = procedure(Sender: TObject; TabIndex: Integer;
  43.     var ImageIndex: Integer) of object;
  44.  
  45.   TrmCustomCCTabControl = class(TWinControl)
  46.   private
  47.     FCanvas: TCanvas;
  48.     FHotTrack: Boolean;
  49.     FImageChangeLink: TChangeLink;
  50.     FImages: TCustomImageList;
  51.     FMouseDragTab: integer;
  52.     FMouseOverTab: integer;
  53.     FMultiLine: Boolean;
  54.     FMultiSelect: Boolean;
  55.     FOwnerDraw: Boolean;
  56.     FRaggedRight: Boolean;
  57.     FSaveTabIndex: Integer;
  58.     FSaveTabs: TStringList;
  59.     FScrollOpposite: Boolean;
  60.     FStyle: TTabStyle;
  61.     FTabPosition: TTabPosition;
  62.     FTabs: TStrings;
  63.     FTabShifting:boolean;
  64.     FTabSize: TSmallPoint;
  65.     FUpdating: Boolean;
  66.     FOnChange: TNotifyEvent;
  67.     FOnChanging: TTabChangingEvent;
  68.     FOnDrawTab: TDrawTabEvent;
  69.     FOnGetImageIndex: TTabGetImageEvent;
  70.     FOnTabTrack: TTabTrackEvent;
  71.     FOnTabShift: TNotifyEvent;
  72.     function GetDisplayRect: TRect;
  73.     function GetTabIndex: Integer;
  74.     procedure ImageListChange(Sender: TObject);
  75.     function InternalSetMultiLine(Value: Boolean): Boolean;
  76.     procedure SetHotTrack(Value: Boolean);
  77.     procedure SetImages(Value: TCustomImageList);
  78.     procedure SetMultiLine(Value: Boolean);
  79.     procedure SetMultiSelect(Value: Boolean);
  80.     procedure SetOwnerDraw(Value: Boolean);
  81.     procedure SetRaggedRight(Value: Boolean);
  82.     procedure SetScrollOpposite(Value: Boolean);
  83.     procedure SetStyle(Value: TTabStyle);
  84.     procedure SetTabHeight(Value: Smallint);
  85.     procedure SetTabIndex(Value: Integer);
  86.     procedure SetTabPosition(Value: TTabPosition);
  87.     procedure SetTabs(Value: TStrings);
  88.     procedure SetTabWidth(Value: Smallint);
  89.     procedure TabsChanged;
  90.     procedure UpdateTabSize;
  91.     procedure CMFontChanged(var Message); message CM_FONTCHANGED;
  92.     procedure CMSysColorChange(var Message: TMessage); message CM_SYSCOLORCHANGE;
  93.     procedure CMTabStopChanged(var Message: TMessage); message CM_TABSTOPCHANGED;
  94.     procedure CMMouseLeave(var message:tmessage); message CM_MOUSELEAVE;
  95.     procedure CNNotify(var Message: TWMNotify); message CN_NOTIFY;
  96.     procedure CMDialogChar(var Message: TCMDialogChar); message CM_DIALOGCHAR;
  97.     procedure CNDrawItem(var Message: TWMDrawItem); message CN_DRAWITEM;
  98.     procedure WMDestroy(var Message: TWMDestroy); message WM_DESTROY;
  99.     procedure WMNotifyFormat(var Message: TMessage); message WM_NOTIFYFORMAT;
  100.     procedure WMNCHitTest(var message:TWMNCHitTest); message WM_NCHITTEST;
  101.     procedure WMSize(var Message: TMessage); message WM_SIZE;
  102.   protected
  103.     procedure AdjustClientRect(var Rect: TRect); override;
  104.     function CanChange: Boolean; dynamic;
  105.     function CanShowTab(TabIndex: Integer): Boolean; virtual;
  106.     procedure Change; dynamic;
  107.     procedure CreateParams(var Params: TCreateParams); override;
  108.     procedure CreateWnd; override;
  109.     procedure DestroyWnd; override;
  110.     procedure DisplayTabHint(TabIndex:integer); virtual; abstract;
  111.     procedure DrawTab(TabIndex: Integer; const Rect: TRect; Active: Boolean); virtual;
  112.     function GetImageIndex(TabIndex: Integer): Integer; virtual;
  113.     procedure Loaded; override;
  114.     procedure UpdateTabImages;
  115.     property AllowTabShifting:boolean read fTabShifting write fTabShifting default false;
  116.     property DisplayRect: TRect read GetDisplayRect;
  117.     property HotTrack: Boolean read FHotTrack write SetHotTrack default False;
  118.     property Images: TCustomImageList read FImages write SetImages;
  119.     property MultiLine: Boolean read FMultiLine write SetMultiLine default False;
  120.     property MultiSelect: Boolean read FMultiSelect write SetMultiSelect default False;
  121.     procedure Notification(AComponent: TComponent; Operation: TOperation); override;
  122.     property OwnerDraw: Boolean read FOwnerDraw write SetOwnerDraw default False;
  123.     property RaggedRight: Boolean read FRaggedRight write SetRaggedRight default False;
  124.     property ScrollOpposite: Boolean read FScrollOpposite
  125.       write SetScrollOpposite default False;
  126.     property Style: TTabStyle read FStyle write SetStyle default tsTabs;
  127.     property TabHeight: Smallint read FTabSize.Y write SetTabHeight default 0;
  128.     property TabIndex: Integer read GetTabIndex write SetTabIndex default -1;
  129.     property TabPosition: TTabPosition read FTabPosition write SetTabPosition
  130.       default tpTop;
  131.     property Tabs: TStrings read FTabs write SetTabs;
  132.     property TabWidth: Smallint read FTabSize.X write SetTabWidth default 0;
  133.     property OnChange: TNotifyEvent read FOnChange write FOnChange;
  134.     property OnChanging: TTabChangingEvent read FOnChanging write FOnChanging;
  135.     property OnDrawTab: TDrawTabEvent read FOnDrawTab write FOnDrawTab;
  136.     property OnGetImageIndex: TTabGetImageEvent read FOnGetImageIndex write FOnGetImageIndex;
  137.     property OnTabTrack:TTabTrackEvent read fontabtrack write fontabtrack;
  138.     property OnTabShift:TNotifyEvent read FOnTabShift write FOnTabShift;
  139.   public
  140.     constructor Create(AOwner: TComponent); override;
  141.     destructor Destroy; override;
  142.     function GetTabAt(x,y:integer):integer;
  143.     property Canvas: TCanvas read FCanvas;
  144.     property TabStop default True;
  145.   end;
  146.  
  147.   TrmCCTabControl = class(TrmCustomCCTabControl)
  148.   private
  149.     FTabHints:TStrings;
  150.     procedure SetTabHints(value:TStrings);
  151.   protected
  152.     procedure DisplayTabHint(TabIndex:integer); override;
  153.     procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
  154.     procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
  155.     procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
  156.   public
  157.     property DisplayRect;
  158.   published
  159.     property AllowTabShifting;
  160.     property Align;
  161.     property Anchors;
  162.     property BiDiMode;
  163.     property Constraints;
  164.     property DockSite;
  165.     property DragCursor;
  166.     property DragKind;
  167.     property DragMode;
  168.     property Enabled;
  169.     property Font;
  170.     property HotTrack;
  171.     property Images;
  172.     property MultiLine;
  173.     property MultiSelect;
  174.     property OwnerDraw;
  175.     property ParentBiDiMode;
  176.     property ParentFont;
  177.     property ParentShowHint;
  178.     property PopupMenu;
  179.     property RaggedRight;
  180.     property ScrollOpposite;
  181.     property ShowHint;
  182.     property Style;
  183.     property TabHeight;
  184.     property TabHints:tstrings read ftabHints write SetTabHints;
  185.     property TabOrder;
  186.     property TabPosition;
  187.     property Tabs;
  188.     property TabIndex;  // must be after Tabs
  189.     property TabStop;
  190.     property TabWidth;
  191.     property Visible;
  192.     property OnChange;
  193.     property OnChanging;
  194.     property OnDockDrop;
  195.     property OnDockOver;
  196.     property OnDragDrop;
  197.     property OnDragOver;
  198.     property OnDrawTab;
  199.     property OnEndDock;
  200.     property OnEndDrag;
  201.     property OnEnter;
  202.     property OnExit;
  203.     property OnGetImageIndex;
  204.     property OnGetSiteInfo;
  205.     property OnMouseDown;
  206.     property OnMouseMove;
  207.     property OnMouseUp;
  208.     property OnResize;
  209.     property OnStartDock;
  210.     property OnStartDrag;
  211.     property OnTabTrack;
  212.     property OnTabShift;
  213.     property OnUnDock;
  214.   end;
  215.  
  216.   TrmCCPageControl = class;
  217.   TrmCCTabSheet = class;
  218.  
  219.   TrmCCTabsFloatingForm = class(TForm)
  220.   private
  221.     { Private declarations }
  222.     FSheet : TrmCCTabSheet;
  223.     fMoveSize: TNotifyEvent;
  224.     procedure DoCloseWindow(Sender: TObject; var Action: TCloseAction);
  225.     procedure DoDestroyWindow(Sender: TObject);
  226.     procedure wmExitSizeMove(var msg: TMessage); message WM_ExitSizeMove;
  227.   public
  228.     { Public declarations }
  229.     constructor CreateNew(AOwner: TComponent); reintroduce;
  230.     property TabSheet: TrmCCTabSheet read FSheet write FSheet;
  231.     property OnMoveSize: TNotifyEvent read fMoveSize write fMoveSize;
  232.   end;
  233.  
  234.   TrmCCTabSheet = class(TWinControl)
  235.   private
  236.     FImageIndex: Integer;
  237.     FPageControl: TrmCCPageControl;
  238.     FTabHint : string;
  239.     FTabVisible: Boolean;
  240.     FTabShowing: Boolean;
  241.     FOnHide: TNotifyEvent;
  242.     FOnShow: TNotifyEvent;
  243.  
  244.     //Floating Vars...
  245.     fOldMousePos: TPoint;    { previous mouse position                      }
  246.     fMouseOffset: TPoint;    { Mouse coordinates in relation to client rect }
  247.     fDragStart: boolean;
  248.     fDragging: boolean;   { true when dragging                           }
  249.     fDragRect: TRect;     { position of rectangle while dragging         }
  250.     fDragable: boolean;   { true to make this dragable                   }
  251.     fWidth,
  252.     fHeight: integer;   { width and height of client area at dragstart }
  253.     fOldPageControl: TrmCCPageControl; { saves the page control so that it can be reset }
  254.     ffloating: boolean;
  255.     FOnFloatChange: TTabFloatEvent;
  256.  
  257.     { fields for the form }
  258.     fFloatingForm                : TrmCCTabsFloatingForm; { form to use when floating           }
  259.     fFloatOnTop                  : Boolean;
  260.     fcanvas : tcanvas;
  261.     fGripAlign : TGripAlign;
  262.     FPageIndex : integer;
  263.     fMoveSize: TNotifyEvent;
  264.  
  265.     function GetPageIndex: Integer;
  266.     function GetTabIndex: Integer;
  267.     procedure SetImageIndex(Value: Integer);
  268.     procedure SetPageControl(APageControl: TrmCCPageControl);
  269.     procedure SetPageIndex(Value: Integer);
  270.     procedure SetTabShowing(Value: Boolean);
  271.     procedure SetTabVisible(Value: Boolean);
  272.     procedure UpdateTabShowing;
  273.     procedure CMTextChanged(var Message: TMessage); message CM_TEXTCHANGED;
  274.     procedure CMShowingChanged(var Message: TMessage); message CM_SHOWINGCHANGED;
  275.  
  276.     //Floating Tabsheet Procedures and Functions
  277.     procedure WMLButtonDown(var Msg : TWMLButtonDown); message WM_LBUTTONDOWN;
  278.     procedure WMMouseMove(var Msg : TWMMouseMove); message WM_MOUSEMOVE;
  279.     procedure WMLButtonUp(var Msg : TWMLButtonUp); message WM_LBUTTONUP;
  280.     procedure WMPaint(var msg:TWMPaint); message WM_Paint;
  281.  
  282.     procedure DrawDraggingRect(MousePos : TPoint); { Draws the focus rectangle at appropriate place}
  283.     procedure setDragOption(value:boolean);
  284.     procedure setGripAlign(value:TGripAlign);
  285.     function GetGripRect:TRect;
  286.     function GetGripperRect:TRect;
  287.     procedure SetFloatOnTop(const Value: boolean);
  288.     procedure DoMoveSize(Sender: TObject);
  289.   protected
  290.     procedure CreateParams(var Params: TCreateParams); override;
  291.     procedure DoHide; dynamic;
  292.     procedure DoShow; dynamic;
  293.     procedure ReadState(Reader: TReader); override;
  294.   public
  295.     constructor Create(AOwner: TComponent); override;
  296.     destructor Destroy; override;
  297.     property PageControl: TrmCCPageControl read FPageControl write SetPageControl;
  298.     property TabIndex: Integer read GetTabIndex;
  299.  
  300.     //Floating Tabsheet Procedures and Functions
  301.     procedure FloatTabSheet;
  302.     procedure FloatTabSheetBounds(aLeft, aTop, aWidth, aHeight: integer);
  303.     procedure DockTabSheet;
  304.     function GetClientRect:TRect; override;
  305.     property FloatingForm: TrmCCTabsFloatingForm read fFloatingForm;
  306.     property GripRect: TRect read GetGripperRect;
  307.     property Floating: Boolean read fFloating;
  308.   published
  309.     property BorderWidth;
  310.     property Caption;
  311.     property DragMode;
  312.     property Dragable : boolean read fDragable write SetDragOption default false; //Floating
  313.     property Enabled;
  314.     property FloatOnTop : boolean read FFloatOnTop write SetFloatOnTop default false;
  315.     property Font;
  316.     property GripAlign : TGripAlign read FGripAlign write SetGripAlign;
  317.     property Height stored False;
  318.     property ImageIndex: Integer read FImageIndex write SetImageIndex default 0;
  319.     property Left stored False;
  320.     property Constraints;
  321.     property PageIndex: Integer read GetPageIndex write SetPageIndex stored False;
  322.     property ParentFont;
  323.     property ParentShowHint;
  324.     property PopupMenu;
  325.     property ShowHint;
  326.     property StaticPageIndex : integer read fpageindex write fpageindex;
  327.     property TabHint:string read FTabHint write FTabHint;
  328.     property TabVisible: Boolean read FTabVisible write SetTabVisible default True;
  329.     property Top stored False;
  330.     property Visible stored False;
  331.     property Width stored False;
  332.     property OnDragDrop;
  333.     property OnDragOver;
  334.     property OnEndDrag;
  335.     property OnEnter;
  336.     property OnExit;
  337.     property OnFloatChange: TTabFloatEvent read FOnFloatChange write FOnFloatChange;
  338.     property OnHide: TNotifyEvent read FOnHide write FOnHide;
  339.     property OnMouseDown;
  340.     property OnMouseMove;
  341.     property OnMouseUp;
  342.     property OnResize;
  343.     property OnShow: TNotifyEvent read FOnShow write FOnShow;
  344.     property OnStartDrag;
  345.     property OnFloatFormMoveSize: TNotifyEvent read fMoveSize write fMoveSize;
  346.   end;
  347.  
  348.   TrmCCPageControl = class(TrmCustomCCTabControl)
  349.   private
  350.     FPages: TList;
  351.     FActivePage: TrmCCTabSheet;
  352.     FNewDockSheet: TrmCCTabSheet;
  353.     FUndockingPage: TrmCCTabSheet;
  354.  
  355.     FFloatingPages: TList;
  356.     FOnFloatChange: TTabFloatEvent;
  357.  
  358.     procedure ChangeActivePage(Page: TrmCCTabSheet);
  359.     procedure DeleteTab(Page: TrmCCTabSheet; Index: Integer);
  360.     function GetDockClientFromMousePos(MousePos: TPoint): TControl;
  361.  
  362.     function GetPage(Index: Integer): TrmCCTabSheet;
  363.     function GetPageCount: Integer;
  364.  
  365.     function GetFloatingPage(Index: Integer): TrmCCTabSheet;
  366.     function GetFloatingPageCount: Integer;
  367.  
  368.     procedure InsertPage(Page: TrmCCTabSheet);
  369.     procedure InsertTab(Page: TrmCCTabSheet);
  370.     procedure MoveTab(CurIndex, NewIndex: Integer);
  371.     procedure RemovePage(Page: TrmCCTabSheet);
  372.     procedure SetActivePage(Page: TrmCCTabSheet);
  373.     procedure UpdateTab(Page: TrmCCTabSheet);
  374.     procedure UpdateActivePage;
  375.  
  376.     procedure AddToFloatList(Page: TrmCCTabSheet);
  377.     procedure RemoveFromFloatList(Page: TrmCCTabSheet);
  378.  
  379.     procedure CMTabDraggedOff(var Message:TMessage); message CM_rmCCTabSheetDraggedOFF;
  380.     procedure CMTabDraggedOn(var Message:TMessage); message CM_rmCCTabSheetDraggedON;
  381.  
  382.     procedure CMDesignHitTest(var Message: TCMDesignHitTest); message CM_DESIGNHITTEST;
  383.     procedure CMDialogKey(var Message: TCMDialogKey); message CM_DIALOGKEY;
  384.     procedure CMDockClient(var Message: TCMDockClient); message CM_DOCKCLIENT;
  385.     procedure CMDockNotification(var Message: TCMDockNotification); message CM_DOCKNOTIFICATION;
  386.     procedure CMUnDockClient(var Message: TCMUnDockClient); message CM_UNDOCKCLIENT;
  387.     procedure WMLButtonDown(var Message: TWMLButtonDown); message WM_LBUTTONDOWN;
  388.     procedure WMLButtonDblClk(var Message: TWMLButtonDblClk); message WM_LBUTTONDBLCLK;
  389.   protected
  390.     function CanShowTab(TabIndex: Integer): Boolean; override;
  391.     procedure Change; override;
  392.     procedure DisplayTabHint(TabIndex:integer); override;
  393.     procedure DoAddDockClient(Client: TControl; const ARect: TRect); override;
  394.     procedure DockOver(Source: TDragDockObject; X, Y: Integer;
  395.       State: TDragState; var Accept: Boolean); override;
  396.     procedure DoRemoveDockClient(Client: TControl); override;
  397.     procedure GetChildren(Proc: TGetChildProc; Root: TComponent); override;
  398.     function GetImageIndex(TabIndex: Integer): Integer; override;
  399.     function GetPageFromDockClient(Client: TControl): TrmCCTabSheet;
  400.     procedure GetSiteInfo(Client: TControl; var InfluenceRect: TRect;
  401.       MousePos: TPoint; var CanDock: Boolean); override;
  402.     procedure SetChildOrder(Child: TComponent; Order: Integer); override;
  403.     procedure ShowControl(AControl: TControl); override;
  404.  
  405.     procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
  406.     procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
  407.     procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
  408.   public
  409.     constructor Create(AOwner: TComponent); override;
  410.     destructor Destroy; override;
  411.     function FindNextPage(CurPage: TrmCCTabSheet;
  412.       GoForward, CheckTabVisible: Boolean): TrmCCTabSheet;
  413.     procedure SelectNextPage(GoForward: Boolean);
  414.  
  415.     procedure HideFloatingPages;
  416.     procedure ShowFloatingPages;
  417.  
  418.     property PageCount: Integer read GetPageCount;
  419.     property Pages[Index: Integer]: TrmCCTabSheet read GetPage;
  420.  
  421.     property FloatingPageCount: Integer read GetFloatingPageCount;
  422.     property FloatingPages[Index: Integer]: TrmCCTabSheet read GetFloatingPage;
  423.   published
  424.     property ActivePage: TrmCCTabSheet read FActivePage write SetActivePage;
  425.     property AllowTabShifting;
  426.     property Align;
  427.     property Anchors;
  428.     property BiDiMode;
  429.     property Constraints;
  430.     property DockSite;
  431.     property DragCursor;
  432.     property DragKind;
  433.     property DragMode;
  434.     property Enabled;
  435.     property Font;
  436.     property HotTrack;
  437.     property Images;
  438.     property MultiLine;
  439.     property OwnerDraw;
  440.     property ParentBiDiMode;
  441.     property ParentFont;
  442.     property ParentShowHint;
  443.     property PopupMenu;
  444.     property RaggedRight;
  445.     property ScrollOpposite;
  446.     property ShowHint;
  447.     property Style;
  448.     property TabHeight;
  449.     property TabOrder;
  450.     property TabPosition;
  451.     property TabStop;
  452.     property TabWidth;
  453.     property Visible;
  454.     property OnChange;
  455.     property OnChanging;
  456.     property OnDockDrop;
  457.     property OnDockOver;
  458.     property OnDragDrop;
  459.     property OnDragOver;
  460.     property OnDrawTab;
  461.     property OnEndDock;
  462.     property OnEndDrag;
  463.     property OnEnter;
  464.     property OnExit;
  465.     property OnFloatChange: TTabFloatEvent read FOnFloatChange write FOnFloatChange;
  466.     property OnGetImageIndex;
  467.     property OnGetSiteInfo;
  468.     property OnMouseDown;
  469.     property OnMouseMove;
  470.     property OnMouseUp;
  471.     property OnResize;
  472.     property OnStartDock;
  473.     property OnStartDrag;
  474.     property OnTabTrack;
  475.     property OnTabShift;
  476.     property OnUnDock;
  477.   end;
  478.  
  479. function InitCommonControl(CC: Integer): Boolean;
  480. procedure CheckCommonControl(CC: Integer);
  481.  
  482. const
  483.   ComCtlVersionIE3 = $00040046;
  484.   ComCtlVersionIE4 = $00040047;
  485.   ComCtlVersionIE401 = $00040048;
  486.  
  487. function GetComCtlVersion: Integer;
  488.  
  489. implementation
  490.  
  491. uses Consts, ComStrs;
  492.  
  493. const
  494.   ComCtlDllName = 'comctl32.dll';
  495.   GripSize = 7;
  496.  
  497. var
  498.   ComCtlVersion: Integer;
  499.  
  500. function InitCommonControl(CC: Integer): Boolean;
  501. var
  502.   ICC: TInitCommonControlsEx;
  503. begin
  504.   ICC.dwSize := SizeOf(TInitCommonControlsEx);
  505.   ICC.dwICC := CC;
  506.   Result := InitCommonControlsEx(ICC);
  507.   if not Result then InitCommonControls;
  508. end;
  509.  
  510. procedure CheckCommonControl(CC: Integer);
  511. begin
  512.   if not InitCommonControl(CC) then
  513.     raise EComponentError.Create(SInvalidComCtl32);
  514. end;
  515.  
  516. function GetComCtlVersion: Integer;
  517. var
  518.   FileName: string;
  519.   InfoSize, Wnd: DWORD;
  520.   VerBuf: Pointer;
  521.   FI: PVSFixedFileInfo;
  522.   VerSize: DWORD;
  523. begin
  524.   if ComCtlVersion = 0 then
  525.   begin
  526.     FileName := ComCtlDllName;
  527.     InfoSize := GetFileVersionInfoSize(PChar(FileName), Wnd);
  528.     if InfoSize <> 0 then
  529.     begin
  530.       GetMem(VerBuf, InfoSize);
  531.       try
  532.         if GetFileVersionInfo(PChar(FileName), Wnd, InfoSize, VerBuf) then
  533.           if VerQueryValue(VerBuf, '\', Pointer(FI), VerSize) then
  534.             ComCtlVersion := FI.dwFileVersionMS;
  535.       finally
  536.         FreeMem(VerBuf);
  537.       end;
  538.     end;
  539.   end;
  540.   Result := ComCtlVersion;
  541. end;
  542.  
  543. procedure SetComCtlStyle(Ctl: TWinControl; Value: Integer; UseStyle: Boolean);
  544. var
  545.   Style: Integer;
  546. begin
  547.   if Ctl.HandleAllocated then
  548.   begin
  549.     Style := GetWindowLong(Ctl.Handle, GWL_STYLE);
  550.     if not UseStyle then Style := Style and not Value
  551.     else Style := Style or Value;
  552.     SetWindowLong(Ctl.Handle, GWL_STYLE, Style);
  553.   end;
  554. end;
  555.  
  556. { TTabStrings }
  557.  
  558. type
  559.   TTabStrings = class(TStrings)
  560.   private
  561.     FTabControl: TrmCustomCCTabControl;
  562.   protected
  563.     function Get(Index: Integer): string; override;
  564.     function GetCount: Integer; override;
  565.     function GetObject(Index: Integer): TObject; override;
  566.     procedure Put(Index: Integer; const S: string); override;
  567.     procedure PutObject(Index: Integer; AObject: TObject); override;
  568.     procedure SetUpdateState(Updating: Boolean); override;
  569.   public
  570.     procedure Clear; override;
  571.     procedure Delete(Index: Integer); override;
  572.     procedure Insert(Index: Integer; const S: string); override;
  573.   end;
  574.  
  575. procedure TabControlError(const S: string);
  576. begin
  577.   raise EListError.Create(S);
  578. end;
  579.  
  580. procedure TTabStrings.Clear;
  581. begin
  582.   if SendMessage(FTabControl.Handle, TCM_DELETEALLITEMS, 0, 0) = 0 then
  583.     TabControlError(sTabFailClear);
  584.   FTabControl.TabsChanged;
  585. end;
  586.  
  587. procedure TTabStrings.Delete(Index: Integer);
  588. begin
  589.   if SendMessage(FTabControl.Handle, TCM_DELETEITEM, Index, 0) = 0 then
  590.     TabControlError(Format(sTabFailDelete, [Index]));
  591.   FTabControl.TabsChanged;
  592. end;
  593.  
  594. function TTabStrings.Get(Index: Integer): string;
  595. const
  596.   RTL: array[Boolean] of LongInt = (0, TCIF_RTLREADING); 
  597. var
  598.   TCItem: TTCItem;
  599.   Buffer: array[0..4095] of Char;
  600. begin
  601.   TCItem.mask := TCIF_TEXT or RTL[FTabControl.UseRightToLeftReading];
  602.   TCItem.pszText := Buffer;
  603.   TCItem.cchTextMax := SizeOf(Buffer);
  604.   if SendMessage(FTabControl.Handle, TCM_GETITEM, Index,
  605.     Longint(@TCItem)) = 0 then
  606.     TabControlError(Format(sTabFailRetrieve, [Index]));
  607.   Result := Buffer;
  608. end;
  609.  
  610. function TTabStrings.GetCount: Integer;
  611. begin
  612.   Result := SendMessage(FTabControl.Handle, TCM_GETITEMCOUNT, 0, 0);
  613. end;
  614.  
  615. function TTabStrings.GetObject(Index: Integer): TObject;
  616. var
  617.   TCItem: TTCItem;
  618. begin
  619.   TCItem.mask := TCIF_PARAM;
  620.   if SendMessage(FTabControl.Handle, TCM_GETITEM, Index,
  621.     Longint(@TCItem)) = 0 then
  622.     TabControlError(Format(sTabFailGetObject, [Index]));
  623.   Result := TObject(TCItem.lParam);
  624. end;
  625.  
  626. procedure TTabStrings.Put(Index: Integer; const S: string);
  627. const
  628.   RTL: array[Boolean] of LongInt = (0, TCIF_RTLREADING);
  629. var
  630.   TCItem: TTCItem;
  631. begin
  632.   TCItem.mask := TCIF_TEXT or RTL[FTabControl.UseRightToLeftReading] or
  633.     TCIF_IMAGE;
  634.   TCItem.pszText := PChar(S);
  635.   TCItem.iImage := FTabControl.GetImageIndex(Index);
  636.   if SendMessage(FTabControl.Handle, TCM_SETITEM, Index,
  637.     Longint(@TCItem)) = 0 then
  638.     TabControlError(Format(sTabFailSet, [S, Index]));
  639.   FTabControl.TabsChanged;
  640. end;
  641.  
  642. procedure TTabStrings.PutObject(Index: Integer; AObject: TObject);
  643. var
  644.   TCItem: TTCItem;
  645. begin
  646.   TCItem.mask := TCIF_PARAM;
  647.   TCItem.lParam := Longint(AObject);
  648.   if SendMessage(FTabControl.Handle, TCM_SETITEM, Index,
  649.     Longint(@TCItem)) = 0 then
  650.     TabControlError(Format(sTabFailSetObject, [Index]));
  651. end;
  652.  
  653. procedure TTabStrings.Insert(Index: Integer; const S: string);
  654. const
  655.   RTL: array[Boolean] of LongInt = (0, TCIF_RTLREADING);
  656. var
  657.   TCItem: TTCItem;
  658. begin
  659.   TCItem.mask := TCIF_TEXT or RTL[FTabControl.UseRightToLeftReading] or
  660.     TCIF_IMAGE;
  661.   TCItem.pszText := PChar(S);
  662.   TCItem.iImage := FTabControl.GetImageIndex(Index);
  663.   if SendMessage(FTabControl.Handle, TCM_INSERTITEM, Index,
  664.     Longint(@TCItem)) < 0 then
  665.     TabControlError(Format(sTabFailSet, [S, Index]));
  666.   FTabControl.TabsChanged;
  667. end;
  668.  
  669. procedure TTabStrings.SetUpdateState(Updating: Boolean);
  670. begin
  671.   FTabControl.FUpdating := Updating;
  672.   SendMessage(FTabControl.Handle, WM_SETREDRAW, Ord(not Updating), 0);
  673.   if not Updating then
  674.   begin
  675.     FTabControl.Invalidate;
  676.     FTabControl.TabsChanged;
  677.   end;
  678. end;
  679.  
  680. { TrmCustomCCTabControl }
  681.  
  682. constructor TrmCustomCCTabControl.Create(AOwner: TComponent);
  683. begin
  684.   inherited Create(AOwner);
  685.   Width := 289;
  686.   Height := 193;
  687.   TabStop := True;
  688.   ControlStyle := [csAcceptsControls, csDoubleClicks];
  689.   FTabs := TTabStrings.Create;
  690.   TTabStrings(FTabs).FTabControl := Self;
  691.   FCanvas := TControlCanvas.Create;
  692.   TControlCanvas(FCanvas).Control := Self;
  693.   FImageChangeLink := TChangeLink.Create;
  694.   FImageChangeLink.OnChange := ImageListChange;
  695.   fmouseovertab := -1;
  696.   fTabShifting := false;
  697. end;
  698.  
  699. destructor TrmCustomCCTabControl.Destroy;
  700. begin
  701.   FCanvas.Free;
  702.   FTabs.Free;
  703.   FSaveTabs.Free;
  704.   FImageChangeLink.Free;
  705.   inherited Destroy;
  706. end;
  707.  
  708. function TrmCustomCCTabControl.CanChange: Boolean;
  709. begin
  710.   Result := True;
  711.   if Assigned(FOnChanging) then FOnChanging(Self, Result);
  712. end;
  713.  
  714. function TrmCustomCCTabControl.CanShowTab(TabIndex: Integer): Boolean;
  715. begin
  716.   Result := True;
  717. end;
  718.  
  719. procedure TrmCustomCCTabControl.Change;
  720. begin
  721.   if Assigned(FOnChange) then FOnChange(Self);
  722. end;
  723.  
  724. procedure TrmCustomCCTabControl.CreateParams(var Params: TCreateParams);
  725. const
  726.   AlignStyles: array[Boolean, TTabPosition] of DWORD =
  727.     ((0, TCS_BOTTOM, TCS_VERTICAL, TCS_VERTICAL or TCS_RIGHT),
  728.      (0, TCS_BOTTOM, TCS_VERTICAL or TCS_RIGHT, TCS_VERTICAL));
  729.   TabStyles: array[TTabStyle] of DWORD = (TCS_TABS, TCS_BUTTONS,
  730.     TCS_BUTTONS or TCS_FLATBUTTONS);
  731.    RRStyles: array[Boolean] of DWORD = (0, TCS_RAGGEDRIGHT);
  732. begin
  733.   InitCommonControl(ICC_TAB_CLASSES);
  734.   inherited CreateParams(Params);
  735.   CreateSubClass(Params, WC_TABCONTROL);
  736.   with Params do
  737.   begin
  738.     Style := Style or WS_CLIPCHILDREN or
  739.       AlignStyles[UseRightToLeftAlignment, FTabPosition] or
  740.       TabStyles[FStyle] or RRStyles[FRaggedRight];
  741.     if not TabStop then Style := Style or TCS_FOCUSNEVER;
  742.     if FMultiLine then Style := Style or TCS_MULTILINE;
  743.     if FMultiSelect then Style := Style or TCS_MULTISELECT;
  744.     if FOwnerDraw then Style := Style or TCS_OWNERDRAWFIXED;
  745.     if FTabSize.X <> 0 then Style := Style or TCS_FIXEDWIDTH;
  746.     if FHotTrack and (not (csDesigning in ComponentState)) then
  747.       Style := Style or TCS_HOTTRACK;
  748.     if FScrollOpposite then Style := Style or TCS_SCROLLOPPOSITE;
  749.     WindowClass.style := WindowClass.style and not (CS_HREDRAW or CS_VREDRAW) or
  750.       CS_DBLCLKS;
  751.   end;
  752. end;
  753.  
  754. procedure TrmCustomCCTabControl.CreateWnd;
  755. begin
  756.   inherited CreateWnd;
  757.   if (Images <> nil) and Images.HandleAllocated then
  758.     Perform(TCM_SETIMAGELIST, 0, Images.Handle);
  759.   if Integer(FTabSize) <> 0 then UpdateTabSize;
  760.   if FSaveTabs <> nil then
  761.   begin
  762.     FTabs.Assign(FSaveTabs);
  763.     SetTabIndex(FSaveTabIndex);
  764.     FSaveTabs.Free;
  765.     FSaveTabs := nil;
  766.   end;
  767. end;
  768.  
  769. procedure TrmCustomCCTabControl.DestroyWnd;
  770. begin
  771.   if FTabs.Count > 0 then
  772.   begin
  773.     FSaveTabs := TStringList.Create;
  774.     FSaveTabs.Assign(FTabs);
  775.     FSaveTabIndex := GetTabIndex;
  776.   end;
  777.   inherited DestroyWnd;
  778. end;
  779.  
  780. procedure TrmCustomCCTabControl.DrawTab(TabIndex: Integer; const Rect: TRect;
  781.   Active: Boolean);
  782. begin
  783.   if Assigned(FOnDrawTab) then
  784.     FOnDrawTab(Self, TabIndex, Rect, Active) else
  785.     FCanvas.FillRect(Rect);
  786. end;
  787.  
  788. function TrmCustomCCTabControl.GetDisplayRect: TRect;
  789. begin
  790.   Result := ClientRect;
  791.   SendMessage(Handle, TCM_ADJUSTRECT, 0, Integer(@Result));
  792.   Inc(Result.Top, 2);
  793. end;
  794.  
  795. function TrmCustomCCTabControl.GetImageIndex(TabIndex: Integer): Integer;
  796. begin
  797.   Result := TabIndex;
  798.   if Assigned(FOnGetImageIndex) then FOnGetImageIndex(Self, TabIndex, Result);
  799. end;
  800.  
  801. function TrmCustomCCTabControl.GetTabIndex: Integer;
  802. begin
  803.   Result := SendMessage(Handle, TCM_GETCURSEL, 0, 0);
  804. end;
  805.  
  806. procedure TrmCustomCCTabControl.Loaded;
  807. begin
  808.   inherited Loaded;
  809.   if Images <> nil then UpdateTabImages;
  810. end;
  811.  
  812. procedure TrmCustomCCTabControl.SetHotTrack(Value: Boolean);
  813. begin                                 
  814.   if FHotTrack <> Value then
  815.   begin
  816.     FHotTrack := Value;
  817.     RecreateWnd;
  818.   end;
  819. end;
  820.  
  821. procedure TrmCustomCCTabControl.Notification(AComponent: TComponent;
  822.   Operation: TOperation);
  823. begin
  824.   inherited Notification(AComponent, Operation);
  825.   if (Operation = opRemove) and (AComponent = Images) then
  826.     Images := nil;
  827. end;
  828.  
  829. procedure TrmCustomCCTabControl.SetImages(Value: TCustomImageList);
  830. begin
  831.   if Images <> nil then
  832.     Images.UnRegisterChanges(FImageChangeLink);
  833.   FImages := Value;
  834.   if Images <> nil then
  835.   begin
  836.     Images.RegisterChanges(FImageChangeLink);
  837.     Images.FreeNotification(Self);
  838.     Perform(TCM_SETIMAGELIST, 0, Images.Handle);
  839.   end
  840.   else Perform(TCM_SETIMAGELIST, 0, 0);
  841. end;
  842.  
  843. procedure TrmCustomCCTabControl.ImageListChange(Sender: TObject);
  844. begin
  845.   Perform(TCM_SETIMAGELIST, 0, TCustomImageList(Sender).Handle);
  846. end;
  847.  
  848. function TrmCustomCCTabControl.InternalSetMultiLine(Value: Boolean): Boolean;
  849. begin
  850.   Result := FMultiLine <> Value;
  851.   if Result then
  852.   begin
  853.     if not Value and ((TabPosition = tpLeft) or (TabPosition = tpRight)) then
  854.       TabControlError(sTabMustBeMultiLine);
  855.     FMultiLine := Value;
  856.     if not Value then FScrollOpposite := False;
  857.   end;
  858. end;
  859.  
  860. procedure TrmCustomCCTabControl.SetMultiLine(Value: Boolean);
  861. begin
  862.   if InternalSetMultiLine(Value) then RecreateWnd;
  863. end;
  864.  
  865. procedure TrmCustomCCTabControl.SetMultiSelect(Value: Boolean);
  866. begin
  867.   if FMultiSelect <> Value then
  868.   begin
  869.     FMultiSelect := Value;
  870.     RecreateWnd;
  871.   end;
  872. end;
  873.  
  874. procedure TrmCustomCCTabControl.SetOwnerDraw(Value: Boolean);
  875. begin
  876.   if FOwnerDraw <> Value then
  877.   begin
  878.     FOwnerDraw := Value;
  879.     RecreateWnd;
  880.   end;
  881. end;
  882.  
  883. procedure TrmCustomCCTabControl.SetRaggedRight(Value: Boolean);
  884. begin
  885.   if FRaggedRight <> Value then
  886.   begin
  887.     FRaggedRight := Value;
  888.     SetComCtlStyle(Self, TCS_RAGGEDRIGHT, Value);
  889.   end;
  890. end;
  891.  
  892. procedure TrmCustomCCTabControl.SetScrollOpposite(Value: Boolean);
  893. begin
  894.   if FScrollOpposite <> Value then
  895.   begin
  896.     FScrollOpposite := Value;
  897.     if Value then FMultiLine := Value;
  898.     RecreateWnd;
  899.   end;
  900. end;
  901.  
  902. procedure TrmCustomCCTabControl.SetStyle(Value: TTabStyle);
  903. begin
  904.   if FStyle <> Value then
  905.   begin
  906.     if (Value <> tsTabs) and (TabPosition <> tpTop) then
  907.       raise EInvalidOperation.Create(SInvalidTabStyle);
  908.     FStyle := Value;
  909.     RecreateWnd;
  910.   end;
  911. end;
  912.  
  913. procedure TrmCustomCCTabControl.SetTabHeight(Value: Smallint);
  914. begin
  915.   if FTabSize.Y <> Value then
  916.   begin
  917.     if Value < 0 then
  918.       raise EInvalidOperation.CreateFmt(SPropertyOutOfRange, [Self.Classname]);
  919.     FTabSize.Y := Value;
  920.     UpdateTabSize;
  921.   end;
  922. end;
  923.  
  924. procedure TrmCustomCCTabControl.SetTabIndex(Value: Integer);
  925. begin
  926.   SendMessage(Handle, TCM_SETCURSEL, Value, 0);
  927. end;
  928.  
  929. procedure TrmCustomCCTabControl.SetTabPosition(Value: TTabPosition);
  930. const
  931.   AlignStyles: array[TTabPosition] of Integer =
  932.     (0, TCS_BOTTOM, TCS_VERTICAL, TCS_VERTICAL or TCS_RIGHT);
  933. begin
  934.   if FTabPosition <> Value then
  935.   begin
  936.     if (Value <> tpTop) and (Style <> tsTabs) then
  937.       raise EInvalidOperation.Create(SInvalidTabPosition);
  938.     FTabPosition := Value;
  939.     if not MultiLine and ((Value = tpLeft) or (Value = tpRight)) then
  940.       InternalSetMultiLine(True);
  941.     RecreateWnd;
  942.   end;
  943. end;
  944.  
  945. procedure TrmCustomCCTabControl.SetTabs(Value: TStrings);
  946. begin
  947.   FTabs.Assign(Value);
  948. end;
  949.  
  950. procedure TrmCustomCCTabControl.SetTabWidth(Value: Smallint);
  951. var
  952.   OldValue: Smallint;
  953. begin
  954.   if FTabSize.X <> Value then
  955.   begin
  956.     if Value < 0 then
  957.       raise EInvalidOperation.CreateFmt(SPropertyOutOfRange, [Self.Classname]);
  958.     OldValue := FTabSize.X;
  959.     FTabSize.X := Value;
  960.     if (OldValue = 0) or (Value = 0) then RecreateWnd
  961.     else UpdateTabSize;
  962.   end;
  963. end;
  964.  
  965. procedure TrmCustomCCTabControl.TabsChanged;
  966. begin
  967.   if not FUpdating then
  968.   begin
  969.     if HandleAllocated then
  970.       SendMessage(Handle, WM_SIZE, SIZE_RESTORED,
  971.         Word(Width) or Word(Height) shl 16);
  972.     Realign;
  973.   end;
  974. end;
  975.  
  976. procedure TrmCustomCCTabControl.UpdateTabSize;
  977. begin
  978.   SendMessage(Handle, TCM_SETITEMSIZE, 0, Integer(FTabSize));
  979.   TabsChanged;
  980. end;
  981.  
  982. procedure TrmCustomCCTabControl.UpdateTabImages;
  983. var
  984.   I: Integer;
  985.   TCItem: TTCItem;
  986. begin
  987.   TCItem.mask := TCIF_IMAGE;
  988.   for I := 0 to FTabs.Count - 1 do
  989.   begin
  990.     TCItem.iImage := GetImageIndex(I);
  991.     if SendMessage(Handle, TCM_SETITEM, I,
  992.       Longint(@TCItem)) = 0 then
  993.       TabControlError(Format(sTabFailSet, [FTabs[I], I]));
  994.   end;
  995.   TabsChanged;
  996. end;
  997.  
  998. procedure TrmCustomCCTabControl.CNDrawItem(var Message: TWMDrawItem);
  999. var
  1000.   SaveIndex: Integer;
  1001. begin
  1002.   with Message.DrawItemStruct^ do
  1003.   begin
  1004.     SaveIndex := SaveDC(hDC);
  1005.     FCanvas.Handle := hDC;
  1006.     FCanvas.Font := Font;
  1007.     FCanvas.Brush := Brush;
  1008.     DrawTab(itemID, rcItem, itemState and ODS_SELECTED <> 0);
  1009.     FCanvas.Handle := 0;
  1010.     RestoreDC(hDC, SaveIndex);
  1011.   end;
  1012.   Message.Result := 1;
  1013. end;
  1014.  
  1015. procedure TrmCustomCCTabControl.WMDestroy(var Message: TWMDestroy);
  1016. var
  1017.   FocusHandle: HWnd;
  1018. begin
  1019.   FocusHandle := GetFocus;
  1020.   if (FocusHandle <> 0) and ((FocusHandle = Handle) or
  1021.     IsChild(Handle, FocusHandle)) then
  1022.     Windows.SetFocus(0);
  1023.   inherited;
  1024. end;
  1025.  
  1026. procedure TrmCustomCCTabControl.WMNotifyFormat(var Message: TMessage);
  1027. begin
  1028.   with Message do
  1029.     Result := DefWindowProc(Handle, Msg, WParam, LParam);
  1030. end;
  1031.  
  1032. procedure TrmCustomCCTabControl.WMSize(var Message: TMessage);
  1033. begin
  1034.   inherited;
  1035.   RedrawWindow(Handle, nil, 0, RDW_INVALIDATE or RDW_ERASE);
  1036. end;
  1037.  
  1038. procedure TrmCustomCCTabControl.CMFontChanged(var Message);
  1039. begin
  1040.   inherited;
  1041.   if HandleAllocated then Perform(WM_SIZE, 0, 0);
  1042. end;
  1043.  
  1044. procedure TrmCustomCCTabControl.CMSysColorChange(var Message: TMessage);
  1045. begin
  1046.   inherited;
  1047.   if not (csLoading in ComponentState) then
  1048.   begin
  1049.     Message.Msg := WM_SYSCOLORCHANGE;
  1050.     DefaultHandler(Message);
  1051.   end;
  1052. end;
  1053.  
  1054. procedure TrmCustomCCTabControl.CMTabStopChanged(var Message: TMessage);
  1055. begin
  1056.   if not (csDesigning in ComponentState) then RecreateWnd;
  1057. end;
  1058.  
  1059. procedure TrmCustomCCTabControl.CNNotify(var Message: TWMNotify);
  1060. begin
  1061.   with Message do
  1062.     case NMHdr^.code of
  1063.       TCN_SELCHANGE:
  1064.         Change;
  1065.       TCN_SELCHANGING:
  1066.         begin
  1067.           Result := 1;
  1068.           if CanChange then Result := 0;
  1069.         end;
  1070.     end;
  1071. end;
  1072.  
  1073. procedure TrmCustomCCTabControl.CMDialogChar(var Message: TCMDialogChar);
  1074. var
  1075.   I: Integer;
  1076. begin
  1077.   for I := 0 to FTabs.Count - 1 do
  1078.     if IsAccel(Message.CharCode, FTabs[I]) and CanShowTab(I) and CanFocus then
  1079.     begin
  1080.       TabIndex := I;
  1081.       Message.Result := 1;
  1082.       Change;
  1083.       Exit;
  1084.     end;
  1085.   inherited;
  1086. end;
  1087.  
  1088. procedure TrmCustomCCTabControl.AdjustClientRect(var Rect: TRect);
  1089. begin
  1090.   Rect := DisplayRect;
  1091.   inherited AdjustClientRect(Rect);
  1092. end;
  1093.  
  1094. procedure TrmCustomCCTabControl.CMMouseLeave(var message: tmessage);
  1095. var
  1096.    oldtab:trect;
  1097. begin
  1098.      inherited;
  1099.      if (hottrack) and not (csdesigning in componentstate) then
  1100.      begin
  1101.           sendmessage(handle,TCM_GetItemRect, fmouseovertab, longint(@OldTab));
  1102.           InvalidateRect(handle,@OldTab,false);
  1103.           fmouseovertab := -1;
  1104.      end;
  1105. end;
  1106.  
  1107. procedure TrmCustomCCTabControl.WMNCHitTest(var message: TWMNCHitTest);
  1108. var
  1109.    HitTest : TTCHitTestInfo;
  1110.    result : integer;
  1111.    OldTab, NewTab : trect;
  1112. begin
  1113.      inherited;
  1114.      if not (csdesigning in componentstate) then
  1115.      begin
  1116.           HitTest.pt := screentoclient(point(message.XPos,message.ypos));
  1117.           HitTest.flags := TCHT_ONITEM;
  1118.           result :=  sendmessage(handle,TCM_HITTEST,0,longint(@HitTest));
  1119.           if (result <> fmouseovertab) then
  1120.           begin
  1121.                if assigned(fontabtrack) then
  1122.                   fontabtrack(self,result);
  1123.                DisplayTabHint(result);
  1124.                if (hottrack) then
  1125.                begin
  1126.                     sendmessage(handle,TCM_GetItemRect, fmouseovertab, longint(@OldTab));
  1127.                     sendmessage(handle,TCM_GetItemRect, result, longint(@NewTab));
  1128.                     InvalidateRect(handle,@OldTab,false);
  1129.                     InvalidateRect(handle,@NewTab,false);
  1130.                end;
  1131.                fmouseovertab := result;
  1132.           end;
  1133.      end
  1134.      else
  1135.      fmouseovertab := -1;
  1136. end;
  1137.  
  1138. function TrmCustomCCTabControl.GetTabAt(x,y:integer):integer;
  1139. var
  1140.    HitTest : TTCHitTestInfo;
  1141. begin
  1142.      HitTest.pt := point(x,y);
  1143.      HitTest.flags := TCHT_ONITEM;
  1144.      result :=  sendmessage(handle,TCM_HITTEST,0,longint(@HitTest));
  1145. end;
  1146.  
  1147. { TrmCCTabControl }
  1148.  
  1149. procedure TrmCCTabControl.DisplayTabHint(TabIndex: integer);
  1150. begin
  1151.      application.CancelHint;
  1152.      if (tabindex > -1) and (tabindex < tabhints.Count)  then
  1153.         hint := trim(tabhints.strings[tabindex]);
  1154. end;
  1155.  
  1156. procedure TrmCCTabControl.MouseDown(Button: TMouseButton; Shift: TShiftState;
  1157.   X, Y: Integer);
  1158. begin
  1159.      if (ftabshifting) and (button = mbleft) and (fMouseOverTab = TabIndex) then
  1160.         fMouseDragTab := fMouseOverTab;
  1161.      Inherited;
  1162. end;
  1163.  
  1164. procedure TrmCCTabControl.MouseMove(Shift: TShiftState; X, Y: Integer);
  1165. begin
  1166.      if (ftabshifting) then
  1167.      begin
  1168.           if (ssLeft in Shift) then
  1169.           begin
  1170.                if (fMouseOverTab = -1) then
  1171.                   Cursor := crNo
  1172.                else
  1173.                if (fMouseDragTab <> fMouseOverTab) then
  1174.                   Cursor := crDrag
  1175.                else
  1176.                   Cursor := crDefault;
  1177.           end
  1178.           else
  1179.           Cursor := crDefault;
  1180.      end;
  1181.      inherited;
  1182. end;
  1183.  
  1184. procedure TrmCCTabControl.MouseUp(Button: TMouseButton; Shift: TShiftState;
  1185.   X, Y: Integer);
  1186. begin
  1187.      if (ftabshifting) and (button = mbleft) and (fMouseDragTab <> fMouseOverTab) and (fMouseOverTab <> -1) then
  1188.      begin
  1189.           Tabs.Move(fMouseDragTab,fMouseOverTab);
  1190.           Cursor := crDefault;
  1191.           if assigned(fOnTabShift) then fOnTabShift(self);
  1192.      end;
  1193.      inherited;
  1194. end;
  1195.  
  1196. procedure TrmCCTabControl.SetTabHints(value: TStrings);
  1197. begin
  1198.      ftabhints.assign(value);
  1199. end;
  1200.  
  1201. { TrmCCTabsFloatingForm }
  1202.  
  1203. constructor TrmCCTabsFloatingForm.CreateNew(AOwner: TComponent);
  1204. begin
  1205.    inherited CreateNew(AOwner);
  1206.    OnClose := DoCloseWindow;
  1207.    OnDestroy := DoDestroyWindow;     
  1208. end;
  1209.  
  1210. procedure TrmCCTabsFloatingForm.DoCloseWindow(Sender: TObject; var Action: TCloseAction);
  1211. begin
  1212.      if assigned(fsheet) then fsheet.docktabsheet;
  1213.      action := cafree;
  1214. end;
  1215.  
  1216. procedure TrmCCTabsFloatingForm.DoDestroyWindow(Sender: TObject);
  1217. begin
  1218.      fsheet.ffloatingform := nil;
  1219. end;
  1220.  
  1221. { TTabSheet }
  1222.  
  1223. constructor TrmCCTabSheet.Create(AOwner: TComponent);
  1224. begin
  1225.   inherited Create(AOwner);
  1226.   Align := alClient;
  1227.   ControlStyle := ControlStyle + [csAcceptsControls, csNoDesignVisible];
  1228.   Visible := False;
  1229.   FTabVisible := True;
  1230.   FCanvas := TControlCanvas.Create;
  1231.   TControlCanvas(FCanvas).Control := Self;
  1232.   fpageindex := -1;
  1233.   fdragstart := false;
  1234.   fDragging := false;
  1235.   GripAlign := gaLeft;
  1236. end;
  1237.  
  1238. destructor TrmCCTabSheet.Destroy;
  1239. begin
  1240.   fcanvas.free;
  1241.   if FPageControl <> nil then
  1242.   begin
  1243.     if FPageControl.FUndockingPage = Self then FPageControl.FUndockingPage := nil;
  1244.     FPageControl.RemovePage(Self);
  1245.   end;
  1246.   inherited Destroy;
  1247. end;
  1248.  
  1249. procedure TrmCCTabSheet.DoHide;
  1250. begin
  1251.   if Assigned(FOnHide) then FOnHide(Self);
  1252. end;
  1253.  
  1254. procedure TrmCCTabSheet.DoShow;
  1255. begin
  1256.   if Assigned(FOnShow) then FOnShow(Self);
  1257. end;
  1258.  
  1259. function TrmCCTabSheet.GetPageIndex: Integer;
  1260. begin
  1261.   if FPageControl <> nil then
  1262.     Result := FPageControl.FPages.IndexOf(Self) else
  1263.     Result := -1;
  1264. end;
  1265.  
  1266. function TrmCCTabSheet.GetTabIndex: Integer;
  1267. var
  1268.   I: Integer;
  1269. begin
  1270.   Result := 0;
  1271.   if not FTabShowing then Dec(Result) else
  1272.     for I := 0 to PageIndex - 1 do
  1273.       if TrmCCTabSheet(FPageControl.FPages[I]).FTabShowing then
  1274.         Inc(Result);
  1275. end;
  1276.  
  1277. procedure TrmCCTabSheet.CreateParams(var Params: TCreateParams);
  1278. begin
  1279.   inherited CreateParams(Params);
  1280.   with Params.WindowClass do
  1281.     style := style and not (CS_HREDRAW or CS_VREDRAW);
  1282. end;
  1283.  
  1284. procedure TrmCCTabSheet.ReadState(Reader: TReader);
  1285. begin
  1286.   inherited ReadState(Reader);
  1287.   if Reader.Parent is TrmCCPageControl then
  1288.     PageControl := TrmCCPageControl(Reader.Parent);
  1289. end;
  1290.  
  1291. procedure TrmCCTabSheet.SetImageIndex(Value: Integer);
  1292. begin
  1293.   if FImageIndex <> Value then
  1294.   begin
  1295.     FImageIndex := Value;
  1296.     if FTabShowing then FPageControl.UpdateTab(Self);
  1297.   end;
  1298. end;
  1299.  
  1300. procedure TrmCCTabSheet.SetPageControl(APageControl: TrmCCPageControl);
  1301. begin
  1302.   if FPageControl <> APageControl then
  1303.   begin
  1304.     if FPageControl <> nil then FPageControl.RemovePage(Self);
  1305.     Parent := APageControl;
  1306.     if APageControl <> nil then APageControl.InsertPage(Self);
  1307.   end;
  1308. end;
  1309.  
  1310. procedure TrmCCTabSheet.SetPageIndex(Value: Integer);
  1311. var
  1312.   I, MaxPageIndex: Integer;
  1313. begin
  1314.   if FPageControl <> nil then
  1315.   begin
  1316.     MaxPageIndex := FPageControl.FPages.Count - 1;
  1317.     if Value > MaxPageIndex then
  1318.       raise EListError.CreateFmt(SPageIndexError, [Value, MaxPageIndex]);
  1319.     I := TabIndex;
  1320.     FPageControl.FPages.Move(PageIndex, Value);
  1321.     if I >= 0 then FPageControl.MoveTab(I, TabIndex);
  1322.   end;
  1323. end;
  1324.  
  1325. procedure TrmCCTabSheet.SetTabShowing(Value: Boolean);
  1326. var
  1327.   Index: Integer;
  1328. begin
  1329.   if FTabShowing <> Value then
  1330.     if Value then
  1331.     begin
  1332.       FTabShowing := True;
  1333.       FPageControl.InsertTab(Self);
  1334.     end else
  1335.     begin
  1336.       Index := TabIndex;
  1337.       FTabShowing := False;
  1338.       FPageControl.DeleteTab(Self, Index);
  1339.     end;
  1340. end;
  1341.  
  1342. procedure TrmCCTabSheet.SetTabVisible(Value: Boolean);
  1343. begin
  1344.   if FTabVisible <> Value then
  1345.   begin
  1346.     FTabVisible := Value;
  1347.     UpdateTabShowing;
  1348.   end;
  1349. end;
  1350.  
  1351. procedure TrmCCTabSheet.UpdateTabShowing;
  1352. begin
  1353.   SetTabShowing((FPageControl <> nil) and
  1354.     (FTabVisible or (csDesigning in ComponentState)));
  1355. end;
  1356.  
  1357. procedure TrmCCTabSheet.CMTextChanged(var Message: TMessage);
  1358. begin
  1359.   if FTabShowing then FPageControl.UpdateTab(Self);
  1360. end;
  1361.  
  1362. procedure TrmCCTabSheet.CMShowingChanged(var Message: TMessage);
  1363. begin
  1364.   inherited;
  1365.   if Showing then
  1366.   begin
  1367.     try
  1368.       DoShow
  1369.     except
  1370.       Application.HandleException(Self);
  1371.     end;
  1372.   end else if not Showing then
  1373.   begin
  1374.     try
  1375.       DoHide;
  1376.     except
  1377.       Application.HandleException(Self);
  1378.     end;
  1379.   end;
  1380. end;
  1381.  
  1382. procedure TrmCCTabSheet.DrawDraggingRect(MousePos : TPoint);
  1383. var
  1384.   DC             : hDC;      { device context for the window       }
  1385.   Canvas         : TCanvas;  { canvas to draw dragging rect        }
  1386.   AdjustedRect   : TRect;    { fDragRect adjusted for MousePos     }
  1387.   ScreenPos      : TPoint;   { screen-relative version of MousePos }
  1388.  
  1389. begin
  1390.   DC := GetWindowDc(GetDesktopWindow);
  1391.   if DC <> 0 then begin
  1392.     ScreenPos := ClientToScreen(MousePos);
  1393.     with AdjustedRect do begin
  1394.       Left := ScreenPos.X-fMouseOffset.X;
  1395.       Top := ScreenPos.Y-fMouseOffset.Y;
  1396.       Right := Left+fWidth;
  1397.       Bottom := Top+fHeight;
  1398.     end; { with AdjustedRect do }
  1399.     fDragRect := AdjustedRect;
  1400.     Canvas := TCanvas.Create;
  1401.     Canvas.Handle := DC;
  1402.     Canvas.DrawFocusRect(AdjustedRect);
  1403.     Canvas.Free;
  1404.   end else
  1405.     Raise ECCTabError.Create('Error retreiving DC(0)');
  1406. end;
  1407.  
  1408. procedure TrmCCTabSheet.WMLBUTTONDOWN(var Msg : TWMLButtonDown);
  1409. begin
  1410.      inherited;
  1411.  
  1412.      if ffloating then exit;
  1413.  
  1414.      if (fDragable) and (ptinrect(GripRect, point(msg.pos.x,msg.pos.y))) then
  1415.      begin
  1416.           fDragStart := TRUE;
  1417.  
  1418.           fWidth := width;
  1419.           fHeight := height;
  1420.  
  1421.           fOldMousePos := Point(Msg.Pos.x,Msg.Pos.y);
  1422.           fMouseOffset := fOldMousePos;
  1423.      end;
  1424. end;
  1425.  
  1426. procedure TrmCCTabSheet.WMMOUSEMOVE(var Msg : TWMMouseMove);
  1427. begin
  1428.      inherited;
  1429.      if (fDragStart) and ((abs(foldmousepos.x - msg.pos.x) > 3) or (abs(foldmousepos.y - msg.pos.y) > 3)) then
  1430.      begin
  1431.           fdragging := true;
  1432.           fDragStart := false;
  1433.           DrawDraggingRect(fOldMousePos);
  1434.      end;
  1435.      if fDragging then
  1436.      begin
  1437.           DrawDraggingRect(fOldMousePos);
  1438.           fOldMousePos := Point(Msg.Pos.x,Msg.Pos.y);
  1439.           DrawDraggingRect(fOldMousePos);
  1440.      end;
  1441. end;
  1442.  
  1443. procedure TrmCCTabSheet.WMLBUTTONUP(var Msg : TWMLButtonDown);
  1444. begin
  1445.      inherited;
  1446.      if fDragging then
  1447.      begin
  1448.           DrawDraggingRect(fOldMousePos);
  1449.           FloatTabSheet;
  1450.           fDragging := FALSE;
  1451.      end; { if dragging }
  1452.      if fDragStart then
  1453.      begin
  1454.           fDragStart := false;
  1455.           invalidate;
  1456.      end;
  1457. end;
  1458.  
  1459. procedure TrmCCTabSheet.FloatTabSheet;
  1460. var
  1461.    ScreenPos: TPoint;
  1462. begin
  1463.      if (not FFloating) then
  1464.      begin
  1465.         if not fDragging then
  1466.         begin
  1467.            ScreenPos := ClientToScreen(Point(Left, Top));
  1468.            with fDragRect do begin
  1469.               Left := ScreenPos.X;
  1470.               Top := ScreenPos.Y;
  1471.               fWidth := ClientRect.Right;
  1472.               fHeight := ClientRect.Bottom;
  1473.               Right := Left + fWidth;
  1474.               Bottom := Top + fHeight;
  1475.            end;
  1476.         end;
  1477.  
  1478.         fOldPageControl := PageControl;
  1479.         PageControl := nil;
  1480.  
  1481.         FFloating := true;
  1482.  
  1483.         fOldPageControl.SelectNextPage(True);
  1484.  
  1485.         fOldPageControl.AddToFloatList(self);
  1486.  
  1487.         fOldPageControl.Perform(CM_rmCCTabSheetDraggedOFF,0,0);
  1488.  
  1489.         if not assigned(fFloatingForm) then
  1490.         begin
  1491.            fFloatingForm := TrmCCTabsFloatingForm.CreateNew(self.owner);
  1492.            if (fFloatOnTop) and (Application.mainform <> nil) and (Application.mainform is tform) then
  1493.               setwindowlong(ffloatingform.handle,gwl_hwndparent,Application.mainform.handle);
  1494.            if assigned(fOldPageControl.images) and (imageindex <> -1) then
  1495.               fOldPageControl.Images.GetIcon(imageindex,ffloatingform.Icon);
  1496.  
  1497.            fFloatingForm.OnMoveSize := DoMoveSize;
  1498.            
  1499.            fFloatingForm.Caption := Caption;
  1500.            fFloatingForm.ClientWidth := fWidth;
  1501.            fFloatingForm.ClientHeight := fHeight;
  1502.            fFloatingForm.TabSheet := self;
  1503.         end;
  1504.  
  1505.         fFloatingForm.Left := fDragRect.Left;
  1506.         fFloatingForm.Top := fDragRect.Top;
  1507.  
  1508.         if assigned(FOnFloatChange) then
  1509.            FOnFloatChange(Self, fsFloating);
  1510.  
  1511.         Parent := fFloatingForm;
  1512.         fFloatingForm.Show;
  1513.         Show;
  1514.    end;
  1515. end;
  1516.  
  1517. procedure TrmCCTabSheet.DockTabSheet;
  1518. begin
  1519.    if FFloating then
  1520.    begin
  1521.       fFloatingForm.Hide;
  1522.       FFloating := false;
  1523.  
  1524.       PageControl:= fOldPageControl;
  1525.  
  1526.       PageControl.RemoveFromFloatList(self);
  1527.  
  1528.       PageControl.Perform(CM_rmCCTabSheetDraggedON,0,Integer(@Self));
  1529.       PageControl.ActivePage := Self;
  1530.       foldPageControl := nil;
  1531.  
  1532.       if assigned(FOnFloatChange) then
  1533.          FOnFloatChange(Self, fsDocked);
  1534.    end;
  1535. end;
  1536.  
  1537. function TrmCCTabSheet.GetClientRect:TRect;
  1538. var
  1539.    clientrect : trect;
  1540. begin
  1541.      clientrect := inherited GetClientRect;
  1542.      if (not dragable) or (ffloating) then
  1543.         result := clientrect
  1544.      else
  1545.      begin
  1546.           case gripalign of
  1547.                gaLeft: clientrect.Left := clientrect.Left + GripSize;
  1548.                gaRight: clientrect.right := clientrect.right - GripSize;
  1549.                gaTop: clientrect.Top := clientrect.top + GripSize;
  1550.                gaBottom: clientrect.bottom := clientrect.bottom - GripSize;
  1551.           end;
  1552.           result := clientrect;
  1553.      end;
  1554. end;
  1555.  
  1556. procedure TrmCCTabSheet.setDragOption(value:boolean);
  1557. begin
  1558.      if value <> fdragable then
  1559.      begin
  1560.           fDragable := value;
  1561.           realign;
  1562.           invalidate;
  1563.      end;
  1564. end;
  1565.  
  1566. procedure TrmCCTabSheet.setGripAlign(value:TGripAlign);
  1567. begin
  1568.      fGripAlign := value;
  1569.      realign;
  1570.      invalidate;
  1571. end;
  1572.  
  1573. function TrmCCTabSheet.GetGripRect:TRect;
  1574. begin
  1575.      result := Rect(0,0,0,0);
  1576.      if (dragable) and (not fFloating) then
  1577.      case GripAlign of
  1578.           gaLeft: result := rect(0,0,GripSize,height);
  1579.           gaRight: result := rect(width-GripSize,0,width,height);
  1580.           gaTop: result := rect(0,0,width,GripSize);
  1581.           gaBottom: result := rect(0,height-gripsize,width,height);
  1582.      end;
  1583. end;
  1584.  
  1585. function TrmCCTabSheet.GetGripperRect:TRect;
  1586. begin
  1587.      result := Rect(0,0,0,0);
  1588.      if (dragable) and (not fFloating) then
  1589.      case GripAlign of
  1590.           gaLeft: result := rect(0,0,GripSize,20);
  1591.           gaRight: result := rect(width-GripSize,height-20,width,height);
  1592.           gaTop: result := rect(width-20,0,width,GripSize);
  1593.           gaBottom: result := rect(0,height-gripsize,20,height);
  1594.      end;
  1595. end;
  1596.  
  1597. procedure TrmCCTabSheet.WMPaint(var msg:TWMPaint);
  1598. const
  1599.      xpos = 4;
  1600. var
  1601.    loop : integer;
  1602.    workcolor : tcolor;
  1603.    position : integer;
  1604.    ypos : integer;
  1605. begin
  1606.      inherited;
  1607.      if (dragable) and not (FFloating) then
  1608.      with fcanvas do
  1609.      begin
  1610.           brush.color := clbtnface;
  1611.           brush.style := bsSolid;
  1612.           fillrect(GetGripRect);
  1613.           if enabled then
  1614.             workcolor := clactivecaption
  1615.           else
  1616.             workcolor := clinactivecaption;
  1617.  
  1618.           ypos := 0;
  1619.           if gripalign = gabottom then ypos := (height-gripsize)+2;
  1620.           if gripalign = garight then ypos := (width-gripsize)+2;
  1621.           if (gripalign in [gabottom, gaTop]) then
  1622.           for loop := 0 to 4 do
  1623.           begin
  1624.                if gripalign = gaTop then position := (width - (xpos * loop))-4
  1625.                else
  1626.                position := xpos * loop;
  1627.  
  1628.                pixels[position,ypos] := clbtnhighlight;
  1629.                pixels[1+position,ypos] := workcolor;
  1630.                pixels[position,ypos+1] := workcolor;
  1631.                pixels[1+position,ypos+1] := workcolor;
  1632.  
  1633.                pixels[2+position,ypos+3] := clbtnhighlight;
  1634.                pixels[3+position,ypos+3] := workcolor;
  1635.                pixels[2+position,ypos+4] := workcolor;
  1636.                pixels[3+position,ypos+4] := workcolor;
  1637.           end;
  1638.  
  1639.           if (gripalign = gaLeft) or (gripalign = gaRight)  then
  1640.           for loop := 0 to 4 do
  1641.           begin
  1642.                if gripalign = gaRight then position := (height - (xpos * loop))-4
  1643.                else
  1644.                position := xpos*loop;
  1645.  
  1646.                pixels[ypos,position] := clbtnhighlight;
  1647.                pixels[ypos,1+position] := workcolor;
  1648.                pixels[ypos+1,position] := workcolor;
  1649.                pixels[ypos+1,1+position] := workcolor;
  1650.  
  1651.                pixels[ypos+3,2+position] := clbtnhighlight;
  1652.                pixels[ypos+3,3+position] := workcolor;
  1653.                pixels[ypos+4,2+position] := workcolor;
  1654.                pixels[ypos+4,3+position] := workcolor;
  1655.           end;
  1656.      end;
  1657. end;
  1658.  
  1659. procedure TrmCCTabSheet.SetFloatOnTop(const Value: boolean);
  1660. begin
  1661.      if FFloatOnTop <> Value then
  1662.      begin
  1663.           FFloatOnTop := Value;
  1664.           if Floating then
  1665.           begin
  1666.                if Value then
  1667.                if (Application.MainForm <> nil) and (Application.MainForm is TForm) then
  1668.                   setwindowlong(FFloatingForm.Handle,gwl_hwndparent,Application.MainForm.Handle)
  1669.                else
  1670.                   setwindowlong(FFloatingForm.Handle,gwl_hwndparent,0);
  1671.           end
  1672.      end;
  1673. end;
  1674.  
  1675. procedure TrmCCTabsFloatingForm.wmExitSizeMove(var msg: TMessage);
  1676. begin
  1677.    inherited;  
  1678.    if assigned(fMoveSize) then
  1679.       fMoveSize(self);
  1680. end;
  1681.  
  1682. { TrmCCPageControl }
  1683.  
  1684. constructor TrmCCPageControl.Create(AOwner: TComponent);
  1685. begin
  1686.   inherited Create(AOwner);
  1687.   ControlStyle := [csDoubleClicks, csOpaque];
  1688.   FPages := TList.Create;
  1689.   FFloatingPages := TList.create;
  1690. end;
  1691.  
  1692. destructor TrmCCPageControl.Destroy;
  1693. var
  1694.   I: Integer;
  1695. begin
  1696.   for I := 0 to FPages.Count - 1 do TrmCCTabSheet(FPages[I]).FPageControl := nil;
  1697.   FPages.Free;
  1698.  
  1699.   for I := 0 to FFloatingPages.Count - 1 do TrmCCTabSheet(FFloatingPages[I]).FPageControl := nil;
  1700.   FFloatingPages.free;
  1701.   inherited Destroy;
  1702. end;
  1703.  
  1704. function TrmCCPageControl.CanShowTab(TabIndex: Integer): Boolean;
  1705. begin
  1706.   Result := TrmCCTabSheet(FPages[TabIndex]).Enabled;
  1707. end;
  1708.  
  1709. procedure TrmCCPageControl.Change;
  1710. var
  1711.   Form: TCustomForm;
  1712. begin
  1713.   UpdateActivePage;
  1714.   if csDesigning in ComponentState then
  1715.   begin
  1716.     Form := GetParentForm(Self);
  1717.     if (Form <> nil) and (Form.Designer <> nil) then Form.Designer.Modified;
  1718.   end;
  1719.   inherited Change;
  1720. end;
  1721.  
  1722. procedure TrmCCPageControl.ChangeActivePage(Page: TrmCCTabSheet);
  1723. var
  1724.   ParentForm: TCustomForm;
  1725. begin
  1726.   if FActivePage <> Page then
  1727.   begin
  1728.     ParentForm := GetParentForm(Self);
  1729.     if (ParentForm <> nil) and (FActivePage <> nil) and
  1730.       FActivePage.ContainsControl(ParentForm.ActiveControl) then
  1731.     begin
  1732.       ParentForm.ActiveControl := FActivePage;
  1733.       if ParentForm.ActiveControl <> FActivePage then
  1734.       begin
  1735.         TabIndex := FActivePage.TabIndex;
  1736.         Exit;
  1737.       end;
  1738.     end;
  1739.     if Page <> nil then
  1740.     begin
  1741.       Page.BringToFront;
  1742.       Page.Visible := True;
  1743.       if (ParentForm <> nil) and (FActivePage <> nil) and
  1744.         (ParentForm.ActiveControl = FActivePage) then
  1745.         if Page.CanFocus then
  1746.           ParentForm.ActiveControl := Page else
  1747.           ParentForm.ActiveControl := Self;
  1748.     end;
  1749.     if FActivePage <> nil then FActivePage.Visible := False;
  1750.     FActivePage := Page;
  1751.     if (ParentForm <> nil) and (FActivePage <> nil) and
  1752.       (ParentForm.ActiveControl = FActivePage) then
  1753.       FActivePage.SelectFirst;
  1754.   end;
  1755. end;
  1756.  
  1757. procedure TrmCCPageControl.DeleteTab(Page: TrmCCTabSheet; Index: Integer);
  1758. var
  1759.   UpdateIndex: Boolean;
  1760. begin
  1761.   UpdateIndex := Page = ActivePage;
  1762.   Tabs.Delete(Index);
  1763.   if UpdateIndex then
  1764.   begin
  1765.     if Index >= Tabs.Count then
  1766.       Index := Tabs.Count - 1;
  1767.     TabIndex := Index;
  1768.   end;
  1769.   UpdateActivePage;
  1770. end;
  1771.  
  1772. procedure TrmCCPageControl.DoAddDockClient(Client: TControl; const ARect: TRect);
  1773. begin
  1774.   if FNewDockSheet <> nil then Client.Parent := FNewDockSheet;
  1775. end;
  1776.  
  1777. procedure TrmCCPageControl.DockOver(Source: TDragDockObject; X, Y: Integer;
  1778.   State: TDragState; var Accept: Boolean);
  1779. var
  1780.   R: TRect;
  1781. begin
  1782.   GetWindowRect(Handle, R);
  1783.   Source.DockRect := R;
  1784.   DoDockOver(Source, X, Y, State, Accept);
  1785. end;
  1786.  
  1787. procedure TrmCCPageControl.DoRemoveDockClient(Client: TControl);
  1788. begin
  1789.   if (FUndockingPage <> nil) and not (csDestroying in ComponentState) then
  1790.   begin
  1791.     SelectNextPage(True);
  1792.     FUndockingPage.Free;
  1793.     FUndockingPage := nil;
  1794.   end;
  1795. end;
  1796.  
  1797. function TrmCCPageControl.FindNextPage(CurPage: TrmCCTabSheet;
  1798.   GoForward, CheckTabVisible: Boolean): TrmCCTabSheet;
  1799. var
  1800.   I, StartIndex: Integer;
  1801. begin
  1802.   if FPages.Count <> 0 then
  1803.   begin
  1804.     StartIndex := FPages.IndexOf(CurPage);
  1805.     if StartIndex = -1 then
  1806.       if GoForward then StartIndex := FPages.Count - 1 else StartIndex := 0;
  1807.     I := StartIndex;
  1808.     repeat
  1809.       if GoForward then
  1810.       begin
  1811.         Inc(I);
  1812.         if I = FPages.Count then I := 0;
  1813.       end else
  1814.       begin
  1815.         if I = 0 then I := FPages.Count;
  1816.         Dec(I);
  1817.       end;
  1818.       Result := FPages[I];
  1819.       if not CheckTabVisible or Result.TabVisible then Exit;
  1820.     until I = StartIndex;
  1821.   end;
  1822.   Result := nil;
  1823. end;
  1824.  
  1825. procedure TrmCCPageControl.GetChildren(Proc: TGetChildProc; Root: TComponent);
  1826. var
  1827.   I: Integer;
  1828. begin
  1829.   for I := 0 to FPages.Count - 1 do Proc(TComponent(FPages[I]));
  1830. end;
  1831.  
  1832. function TrmCCPageControl.GetImageIndex(TabIndex: Integer): Integer;
  1833. begin
  1834.   if Assigned(FOnGetImageIndex) then
  1835.     Result := inherited GetImageIndex(TabIndex) else
  1836.     Result := GetPage(TabIndex).ImageIndex;
  1837. end;
  1838.  
  1839. function TrmCCPageControl.GetPageFromDockClient(Client: TControl): TrmCCTabSheet;
  1840. var
  1841.   I: Integer;
  1842. begin
  1843.   Result := nil;
  1844.   for I := 0 to PageCount - 1 do
  1845.   begin
  1846.     if (Client.Parent = Pages[I]) and (Client.HostDockSite = Self) then
  1847.     begin
  1848.       Result := Pages[I];
  1849.       Exit;
  1850.     end;
  1851.   end;
  1852. end;
  1853.  
  1854. function TrmCCPageControl.GetPage(Index: Integer): TrmCCTabSheet;
  1855. begin
  1856.   Result := FPages[Index];
  1857. end;
  1858.  
  1859. function TrmCCPageControl.GetPageCount: Integer;
  1860. begin
  1861.   Result := FPages.Count;
  1862. end;
  1863.  
  1864. procedure TrmCCPageControl.GetSiteInfo(Client: TControl; var InfluenceRect: TRect;
  1865.   MousePos: TPoint; var CanDock: Boolean);
  1866. begin
  1867.   CanDock := GetPageFromDockClient(Client) = nil;
  1868.   inherited GetSiteInfo(Client, InfluenceRect, MousePos, CanDock);
  1869. end;
  1870.  
  1871. procedure TrmCCPageControl.InsertPage(Page: TrmCCTabSheet);
  1872. begin
  1873.   FPages.Add(Page);
  1874.   Page.FPageControl := Self;
  1875.   Page.UpdateTabShowing;
  1876. end;
  1877.  
  1878. procedure TrmCCPageControl.InsertTab(Page: TrmCCTabSheet);
  1879. begin
  1880.   Tabs.InsertObject(Page.TabIndex, Page.Caption, Page);
  1881.   UpdateActivePage;
  1882. end;
  1883.  
  1884. procedure TrmCCPageControl.MoveTab(CurIndex, NewIndex: Integer);
  1885. begin
  1886.   Tabs.Move(CurIndex, NewIndex);
  1887. end;
  1888.  
  1889. procedure TrmCCPageControl.RemovePage(Page: TrmCCTabSheet);
  1890. begin
  1891.   Page.SetTabShowing(False);
  1892.   Page.FPageControl := nil;
  1893.   FPages.Remove(Page);
  1894. end;
  1895.  
  1896. procedure TrmCCPageControl.SelectNextPage(GoForward: Boolean);
  1897. var
  1898.   Page: TrmCCTabSheet;
  1899. begin
  1900.   Page := FindNextPage(ActivePage, GoForward, True);
  1901.   if (Page <> nil) and (Page <> ActivePage) and CanChange then
  1902.   begin
  1903.     TabIndex := Page.TabIndex;
  1904.     Change;
  1905.   end;
  1906. end;
  1907.  
  1908. procedure TrmCCPageControl.SetActivePage(Page: TrmCCTabSheet);
  1909. begin
  1910.   if (Page <> nil) and (Page.PageControl <> Self) then Exit;
  1911.   ChangeActivePage(Page);
  1912.   if Page = nil then
  1913.     TabIndex := -1
  1914.   else if Page = FActivePage then
  1915.     TabIndex := Page.TabIndex;
  1916. end;
  1917.  
  1918. procedure TrmCCPageControl.SetChildOrder(Child: TComponent; Order: Integer);
  1919. begin
  1920.   TrmCCTabSheet(Child).PageIndex := Order;
  1921. end;
  1922.  
  1923. procedure TrmCCPageControl.ShowControl(AControl: TControl);
  1924. begin
  1925.   if (AControl is TrmCCTabSheet) and (TrmCCTabSheet(AControl).PageControl = Self) then
  1926.     SetActivePage(TrmCCTabSheet(AControl));
  1927.   inherited ShowControl(AControl);
  1928. end;
  1929.  
  1930. procedure TrmCCPageControl.UpdateTab(Page: TrmCCTabSheet);
  1931. begin
  1932.   Tabs[Page.TabIndex] := Page.Caption;
  1933. end;
  1934.  
  1935. procedure TrmCCPageControl.UpdateActivePage;
  1936. begin
  1937.   if TabIndex >= 0 then
  1938.     SetActivePage(TrmCCTabSheet(Tabs.Objects[TabIndex]))
  1939.   else
  1940.     SetActivePage(nil);
  1941. end;
  1942.  
  1943. procedure TrmCCPageControl.CMDesignHitTest(var Message: TCMDesignHitTest);
  1944. var
  1945.   HitIndex: Integer;
  1946.   HitTestInfo: TTCHitTestInfo;
  1947. begin
  1948.   HitTestInfo.pt := SmallPointToPoint(Message.Pos);
  1949.   HitIndex := SendMessage(Handle, TCM_HITTEST, 0, Longint(@HitTestInfo));
  1950.   if (HitIndex >= 0) and (HitIndex <> TabIndex) then Message.Result := 1;
  1951. end;
  1952.  
  1953. procedure TrmCCPageControl.CMDialogKey(var Message: TCMDialogKey);
  1954. begin
  1955.   if (Message.CharCode = VK_TAB) and (GetKeyState(VK_CONTROL) < 0) then
  1956.   begin
  1957.     SelectNextPage(GetKeyState(VK_SHIFT) >= 0);
  1958.     Message.Result := 1;
  1959.   end else
  1960.     inherited;
  1961. end;
  1962.  
  1963. procedure TrmCCPageControl.CMDockClient(var Message: TCMDockClient);
  1964. var
  1965.   IsVisible: Boolean;
  1966.   DockCtl: TControl;
  1967. begin
  1968.   Message.Result := 0;
  1969.   FNewDockSheet := TrmCCTabSheet.Create(Self);
  1970.   try
  1971.     try
  1972.       DockCtl := Message.DockSource.Control;
  1973.       if DockCtl is TCustomForm then
  1974.         FNewDockSheet.Caption := TCustomForm(DockCtl).Caption;
  1975.       FNewDockSheet.PageControl := Self;
  1976.       DockCtl.Dock(Self, Message.DockSource.DockRect);
  1977.     except
  1978.       FNewDockSheet.Free;
  1979.       raise;
  1980.     end;
  1981.     IsVisible := DockCtl.Visible;
  1982.     FNewDockSheet.TabVisible := IsVisible;
  1983.     if IsVisible then ActivePage := FNewDockSheet;
  1984.     DockCtl.Align := alClient;
  1985.   finally
  1986.     FNewDockSheet := nil;
  1987.   end;
  1988. end;
  1989.  
  1990. procedure TrmCCPageControl.CMDockNotification(var Message: TCMDockNotification);
  1991. var
  1992.   Page: TrmCCTabSheet;
  1993. begin
  1994.   Page := GetPageFromDockClient(Message.Client);
  1995.   if Page <> nil then
  1996.     case Message.NotifyRec.ClientMsg of
  1997.       WM_SETTEXT:
  1998.         Page.Caption := PChar(Message.NotifyRec.MsgLParam);
  1999.       CM_VISIBLECHANGED:
  2000.         with Page do
  2001.         begin
  2002.           Visible := Boolean(Message.NotifyRec.MsgWParam);
  2003.           TabVisible := Boolean(Message.NotifyRec.MsgWParam);;
  2004.         end;
  2005.     end;
  2006.   inherited;
  2007. end;
  2008.  
  2009. procedure TrmCCPageControl.CMUnDockClient(var Message: TCMUnDockClient);
  2010. var
  2011.   Page: TrmCCTabSheet;
  2012. begin
  2013.   Message.Result := 0;
  2014.   Page := GetPageFromDockClient(Message.Client);
  2015.   if Page <> nil then
  2016.   begin
  2017.     FUndockingPage := Page;
  2018.     Message.Client.Align := alNone;
  2019.   end;
  2020. end;
  2021.  
  2022. function TrmCCPageControl.GetDockClientFromMousePos(MousePos: TPoint): TControl;
  2023. var
  2024.   HitIndex: Integer;
  2025.   HitTestInfo: TTCHitTestInfo;
  2026.   Page: TrmCCTabSheet;
  2027. begin
  2028.   Result := nil;
  2029.   if DockSite then
  2030.   begin
  2031.     HitTestInfo.pt := MousePos;
  2032.     HitIndex := SendMessage(Handle, TCM_HITTEST, 0, Longint(@HitTestInfo));
  2033.     if HitIndex >= 0 then
  2034.     begin
  2035.       Page := Pages[HitIndex];
  2036.       if not Page.TabVisible then Page := FindNextPage(Page, True, True);
  2037.       if (Page <> nil) and (Page.ControlCount > 0) then
  2038.       begin
  2039.         Result := Page.Controls[0];
  2040.         if Result.HostDockSite <> Self then Result := nil;
  2041.       end;
  2042.     end;
  2043.   end;
  2044. end;
  2045.  
  2046. procedure TrmCCPageControl.WMLButtonDown(var Message: TWMLButtonDown);
  2047. var
  2048.   DockCtl: TControl;
  2049. begin
  2050.   inherited;
  2051.   DockCtl := GetDockClientFromMousePos(SmallPointToPoint(Message.Pos));
  2052.   if DockCtl <> nil then DockCtl.BeginDrag(False);
  2053. end;
  2054.  
  2055. procedure TrmCCPageControl.WMLButtonDblClk(var Message: TWMLButtonDblClk);
  2056. var
  2057.   DockCtl: TControl;
  2058. begin
  2059.   inherited;
  2060.   DockCtl := GetDockClientFromMousePos(SmallPointToPoint(Message.Pos));
  2061.   if DockCtl <> nil then DockCtl.ManualDock(nil, nil, alNone);
  2062. end;
  2063.  
  2064. procedure TrmCCPageControl.CMTabDraggedOff(var Message: TMessage);
  2065. begin
  2066.      if assigned(FOnFloatChange) then
  2067.         FOnFloatChange(Self, fsFloating);
  2068. end;
  2069.  
  2070. procedure TrmCCPageControl.CMTabDraggedOn(var Message: TMessage);
  2071. var
  2072.    loop, loop1 : integer;
  2073.    worksheet : TrmCCTabSheet;
  2074. begin
  2075.      for loop :=  0 to fpages.count-1 do
  2076.      begin
  2077.           worksheet := TrmCCTabSheet(fpages[loop]);
  2078.           loop1 := 0;
  2079.           while (loop1 < fpages.count - 1) and (worksheet.StaticPageIndex > TrmCCTabSheet(fpages[loop1]).staticpageindex) do
  2080.                 inc(loop1);
  2081.           worksheet.pageindex := loop1;
  2082.           if worksheet.TabVisible then
  2083.              worksheet.imageindex := worksheet.imageindex; 
  2084.      end;
  2085.      if assigned(FOnFloatChange) then
  2086.         FOnFloatChange(Self, fsDocked);
  2087. end;
  2088.  
  2089. procedure TrmCCPageControl.DisplayTabHint(TabIndex: integer);
  2090. begin
  2091.      application.CancelHint;
  2092.      if tabindex <> -1 then
  2093.         hint := trim(TrmCCTabSheet(fpages.items[tabindex]).tabhint)
  2094.      else
  2095.      begin
  2096.         if assigned(activepage) then
  2097.            hint := trim(TrmCCTabSheet(activepage).hint);
  2098.      end;
  2099. end;
  2100.  
  2101. procedure TrmCCPageControl.MouseDown(Button: TMouseButton;
  2102.   Shift: TShiftState; X, Y: Integer);
  2103. begin
  2104.      if (ftabshifting) and (button = mbleft) and (fMouseOverTab = ActivePage.PageIndex) then
  2105.         fMouseDragTab := fMouseOverTab;
  2106.      Inherited;
  2107. end;
  2108.  
  2109. procedure TrmCCPageControl.MouseMove(Shift: TShiftState; X, Y: Integer);
  2110. begin
  2111.      if (ftabshifting) then
  2112.      begin
  2113.           if (ssLeft in Shift) then
  2114.           begin
  2115.                if (fMouseOverTab = -1) then
  2116.                   Cursor := crNo
  2117.                else
  2118.                if (fMouseDragTab <> fMouseOverTab) then
  2119.                   Cursor := crDrag
  2120.                else
  2121.                   Cursor := crDefault;
  2122.           end
  2123.           else
  2124.           Cursor := crDefault;
  2125.      end;
  2126.      inherited;
  2127. end;
  2128.  
  2129. procedure TrmCCPageControl.MouseUp(Button: TMouseButton; Shift: TShiftState;
  2130.   X, Y: Integer);
  2131. var
  2132.    tabsheet1 : TrmCCTabSheet;
  2133. begin
  2134.      if (ftabshifting) and (button = mbleft) and (fMouseDragTab <> fMouseOverTab) and (fMouseOverTab <> -1) then
  2135.      begin
  2136.           TabSheet1 := Pages[fMouseDragTab];
  2137.           TabSheet1.PageIndex := fMouseOverTab;
  2138.           Cursor := crDefault;
  2139.           if assigned(fOnTabShift) then fOnTabShift(self);
  2140.      end;
  2141.      inherited;
  2142. end;
  2143.  
  2144. function TrmCCPageControl.GetFloatingPage(Index: Integer): TrmCCTabSheet;
  2145. begin
  2146.    Result := FFloatingPages[Index];
  2147. end;
  2148.  
  2149. function TrmCCPageControl.GetFloatingPageCount: Integer;
  2150. begin
  2151.    result := FFloatingPages.Count;
  2152. end;
  2153.  
  2154. procedure TrmCCPageControl.AddToFloatList(Page: TrmCCTabSheet);
  2155. begin
  2156.    if fFloatingPages.IndexOf(page) = -1 then
  2157.       fFloatingPages.add(Page);
  2158. end;
  2159.  
  2160. procedure TrmCCPageControl.RemoveFromFloatList(Page: TrmCCTabSheet);
  2161. var
  2162.    index : integer;
  2163. begin
  2164.    index := fFloatingPages.IndexOf(page);
  2165.    if index <> -1 then
  2166.       fFloatingPages.delete(index);
  2167. end;
  2168.  
  2169. procedure TrmCCTabSheet.FloatTabSheetBounds(aLeft, aTop, aWidth, aHeight: integer);
  2170. begin
  2171.      if (not FFloating) then
  2172.      begin
  2173.         fOldPageControl := PageControl;
  2174.         PageControl := nil;
  2175.  
  2176.         FFloating := true;
  2177.  
  2178.         fOldPageControl.SelectNextPage(True);
  2179.  
  2180.         fOldPageControl.AddToFloatList(self);
  2181.  
  2182.         fOldPageControl.Perform(CM_rmCCTabSheetDraggedOFF,0,0);
  2183.  
  2184.         if not assigned(fFloatingForm) then
  2185.         begin
  2186.            fFloatingForm := TrmCCTabsFloatingForm.CreateNew(self.owner);
  2187.            if (fFloatOnTop) and (Application.mainform <> nil) and (Application.mainform is tform) then
  2188.               setwindowlong(ffloatingform.handle,gwl_hwndparent,Application.mainform.handle);
  2189.            if assigned(fOldPageControl.images) and (imageindex <> -1) then
  2190.               fOldPageControl.Images.GetIcon(imageindex,ffloatingform.Icon);
  2191.            fFloatingForm.OnMoveSize := DoMoveSize;
  2192.            fFloatingForm.Caption := Caption;
  2193.            fFloatingForm.SetBounds(aleft, atop, awidth, aheight);
  2194.            fFloatingForm.TabSheet := self;
  2195.         end;
  2196.  
  2197.         if assigned(FOnFloatChange) then
  2198.            FOnFloatChange(Self, fsFloating);
  2199.  
  2200.         Parent := fFloatingForm;
  2201.         fFloatingForm.Show;
  2202.         Show;
  2203.    end;
  2204. end;
  2205.  
  2206. procedure TrmCCTabSheet.DoMoveSize(Sender: TObject);
  2207. begin
  2208.    if assigned(fMoveSize) then
  2209.       fMoveSize(self);
  2210. end;
  2211.  
  2212. procedure TrmCCPageControl.HideFloatingPages;
  2213. var
  2214.    loop : integer;
  2215. begin
  2216.    loop := GetFloatingPageCount;
  2217.    while loop > 0 do
  2218.    begin
  2219.       dec(loop);
  2220.       GetFloatingPage(loop).FloatingForm.Hide;
  2221.    end;
  2222. end;
  2223.  
  2224. procedure TrmCCPageControl.ShowFloatingPages;
  2225. var
  2226.    loop : integer;
  2227. begin
  2228.    loop := GetFloatingPageCount;
  2229.    while loop > 0 do
  2230.    begin
  2231.       dec(loop);
  2232.       GetFloatingPage(loop).FloatingForm.show;
  2233.    end;
  2234. end;
  2235.  
  2236. end.
  2237.