home *** CD-ROM | disk | FTP | other *** search
/ QBasic & Borland Pascal & C / Delphi5.iso / Runimage / Delphi50 / Source / Vcl / COMCTRLS.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1999-08-11  |  573.3 KB  |  19,842 lines
  1. {*******************************************************}
  2. {                                                       }
  3. {       Borland Delphi Visual Component Library         }
  4. {                                                       }
  5. {       Copyright (c) 1996,99 Inprise Corporation       }
  6. {                                                       }
  7. {*******************************************************}
  8.  
  9. unit ComCtrls;
  10.  
  11. {$R-,T-,H+,X+}
  12.  
  13. interface
  14.  
  15. uses Messages, Windows, SysUtils, CommCtrl, Classes, Controls, Forms,
  16.   Menus, Graphics, StdCtrls, RichEdit, ToolWin, ImgList, ExtCtrls;
  17.  
  18. type
  19.   THitTest = (htAbove, htBelow, htNowhere, htOnItem, htOnButton, htOnIcon,
  20.     htOnIndent, htOnLabel, htOnRight, htOnStateIcon, htToLeft, htToRight);
  21.   THitTests = set of THitTest;
  22.   
  23.   TCustomTabControl = class;
  24.  
  25.   TTabChangingEvent = procedure(Sender: TObject;
  26.     var AllowChange: Boolean) of object;
  27.  
  28.   TTabPosition = (tpTop, tpBottom, tpLeft, tpRight);
  29.  
  30.   TTabStyle = (tsTabs, tsButtons, tsFlatButtons);
  31.  
  32.   TDrawTabEvent = procedure(Control: TCustomTabControl; TabIndex: Integer;
  33.     const Rect: TRect; Active: Boolean) of object;
  34.   TTabGetImageEvent = procedure(Sender: TObject; TabIndex: Integer;
  35.     var ImageIndex: Integer) of object;
  36.  
  37.   TCustomTabControl = class(TWinControl)
  38.   private
  39.     FCanvas: TCanvas;
  40.     FHotTrack: Boolean;
  41.     FImageChangeLink: TChangeLink;
  42.     FImages: TCustomImageList;
  43.     FMultiLine: Boolean;
  44.     FMultiSelect: Boolean;
  45.     FOwnerDraw: Boolean;
  46.     FRaggedRight: Boolean;
  47.     FSaveTabIndex: Integer;
  48.     FSaveTabs: TStringList;
  49.     FScrollOpposite: Boolean;
  50.     FStyle: TTabStyle;
  51.     FTabPosition: TTabPosition;
  52.     FTabs: TStrings;
  53.     FTabSize: TSmallPoint;
  54.     FUpdating: Boolean;
  55.     FOnChange: TNotifyEvent;
  56.     FOnChanging: TTabChangingEvent;
  57.     FOnDrawTab: TDrawTabEvent;
  58.     FOnGetImageIndex: TTabGetImageEvent;
  59.     function GetDisplayRect: TRect;
  60.     function GetTabIndex: Integer;
  61.     procedure ImageListChange(Sender: TObject);
  62.     function InternalSetMultiLine(Value: Boolean): Boolean;
  63.     procedure SetHotTrack(Value: Boolean);
  64.     procedure SetImages(Value: TCustomImageList);
  65.     procedure SetMultiLine(Value: Boolean);
  66.     procedure SetMultiSelect(Value: Boolean);
  67.     procedure SetOwnerDraw(Value: Boolean);
  68.     procedure SetRaggedRight(Value: Boolean);
  69.     procedure SetScrollOpposite(Value: Boolean);
  70.     procedure SetStyle(Value: TTabStyle);
  71.     procedure SetTabHeight(Value: Smallint);
  72.     procedure SetTabIndex(Value: Integer);
  73.     procedure SetTabPosition(Value: TTabPosition);
  74.     procedure SetTabs(Value: TStrings);
  75.     procedure SetTabWidth(Value: Smallint);
  76.     procedure TabsChanged;
  77.     procedure UpdateTabSize;
  78.     procedure CMFontChanged(var Message); message CM_FONTCHANGED;
  79.     procedure CMSysColorChange(var Message: TMessage); message CM_SYSCOLORCHANGE;
  80.     procedure CMTabStopChanged(var Message: TMessage); message CM_TABSTOPCHANGED;
  81.     procedure CNNotify(var Message: TWMNotify); message CN_NOTIFY;
  82.     procedure CMDialogChar(var Message: TCMDialogChar); message CM_DIALOGCHAR;
  83.     procedure CNDrawItem(var Message: TWMDrawItem); message CN_DRAWITEM;
  84.     procedure WMDestroy(var Message: TWMDestroy); message WM_DESTROY;
  85.     procedure WMNotifyFormat(var Message: TMessage); message WM_NOTIFYFORMAT;
  86.     procedure WMSize(var Message: TMessage); message WM_SIZE;
  87.   protected
  88.     procedure AdjustClientRect(var Rect: TRect); override;
  89.     function CanChange: Boolean; dynamic;
  90.     function CanShowTab(TabIndex: Integer): Boolean; virtual;
  91.     procedure Change; dynamic;
  92.     procedure CreateParams(var Params: TCreateParams); override;
  93.     procedure CreateWnd; override;
  94.     procedure DrawTab(TabIndex: Integer; const Rect: TRect; Active: Boolean); virtual;
  95.     function GetImageIndex(TabIndex: Integer): Integer; virtual;
  96.     procedure Loaded; override;
  97.     procedure UpdateTabImages;
  98.     property DisplayRect: TRect read GetDisplayRect;
  99.     property HotTrack: Boolean read FHotTrack write SetHotTrack default False;
  100.     property Images: TCustomImageList read FImages write SetImages;
  101.     property MultiLine: Boolean read FMultiLine write SetMultiLine default False;
  102.     property MultiSelect: Boolean read FMultiSelect write SetMultiSelect default False;
  103.     procedure Notification(AComponent: TComponent; Operation: TOperation); override;
  104.     property OwnerDraw: Boolean read FOwnerDraw write SetOwnerDraw default False;
  105.     property RaggedRight: Boolean read FRaggedRight write SetRaggedRight default False;
  106.     property ScrollOpposite: Boolean read FScrollOpposite
  107.       write SetScrollOpposite default False;
  108.     property Style: TTabStyle read FStyle write SetStyle default tsTabs;
  109.     property TabHeight: Smallint read FTabSize.Y write SetTabHeight default 0;
  110.     property TabIndex: Integer read GetTabIndex write SetTabIndex default -1;
  111.     property TabPosition: TTabPosition read FTabPosition write SetTabPosition
  112.       default tpTop;
  113.     property Tabs: TStrings read FTabs write SetTabs;
  114.     property TabWidth: Smallint read FTabSize.X write SetTabWidth default 0;
  115.     property OnChange: TNotifyEvent read FOnChange write FOnChange;
  116.     property OnChanging: TTabChangingEvent read FOnChanging write FOnChanging;
  117.     property OnDrawTab: TDrawTabEvent read FOnDrawTab write FOnDrawTab;
  118.     property OnGetImageIndex: TTabGetImageEvent read FOnGetImageIndex write FOnGetImageIndex;
  119.   public
  120.     constructor Create(AOwner: TComponent); override;
  121.     destructor Destroy; override;
  122.     function IndexOfTabAt(X, Y: Integer): Integer;
  123.     function GetHitTestInfoAt(X, Y: Integer): THitTests;
  124.     function TabRect(Index: Integer): TRect;
  125.     function RowCount: Integer;
  126.     procedure ScrollTabs(Delta: Integer);
  127.     property Canvas: TCanvas read FCanvas;
  128.     property TabStop default True;
  129.   end;
  130.  
  131.   TTabControl = class(TCustomTabControl)
  132.   public
  133.     property DisplayRect;
  134.   published
  135.     property Align;
  136.     property Anchors;
  137.     property BiDiMode;
  138.     property Constraints;
  139.     property DockSite;
  140.     property DragCursor;
  141.     property DragKind;
  142.     property DragMode;
  143.     property Enabled;
  144.     property Font;
  145.     property HotTrack;
  146.     property Images;
  147.     property MultiLine;
  148.     property MultiSelect;
  149.     property OwnerDraw;
  150.     property ParentBiDiMode;
  151.     property ParentFont;
  152.     property ParentShowHint;
  153.     property PopupMenu;
  154.     property RaggedRight;
  155.     property ScrollOpposite;
  156.     property ShowHint;
  157.     property Style;
  158.     property TabHeight;
  159.     property TabOrder;
  160.     property TabPosition;
  161.     property Tabs;
  162.     property TabIndex;  // must be after Tabs
  163.     property TabStop;
  164.     property TabWidth;
  165.     property Visible;
  166.     property OnChange;
  167.     property OnChanging;
  168.     property OnContextPopup;
  169.     property OnDockDrop;
  170.     property OnDockOver;
  171.     property OnDragDrop;
  172.     property OnDragOver;
  173.     property OnDrawTab;
  174.     property OnEndDock;
  175.     property OnEndDrag;
  176.     property OnEnter;
  177.     property OnExit;
  178.     property OnGetImageIndex;
  179.     property OnGetSiteInfo;
  180.     property OnMouseDown;
  181.     property OnMouseMove;
  182.     property OnMouseUp;
  183.     property OnResize;
  184.     property OnStartDock;
  185.     property OnStartDrag;
  186.     property OnUnDock;
  187.   end;
  188.  
  189.   TPageControl = class;
  190.  
  191.   TTabSheet = class(TWinControl)
  192.   private
  193.     FImageIndex: TImageIndex;
  194.     FPageControl: TPageControl;
  195.     FTabVisible: Boolean;
  196.     FTabShowing: Boolean;
  197.     FHighlighted: Boolean;
  198.     FOnHide: TNotifyEvent;
  199.     FOnShow: TNotifyEvent;
  200.     function GetPageIndex: Integer;
  201.     function GetTabIndex: Integer;
  202.     procedure SetHighlighted(Value: Boolean);
  203.     procedure SetImageIndex(Value: TImageIndex);
  204.     procedure SetPageControl(APageControl: TPageControl);
  205.     procedure SetPageIndex(Value: Integer);
  206.     procedure SetTabShowing(Value: Boolean);
  207.     procedure SetTabVisible(Value: Boolean);
  208.     procedure UpdateTabShowing;
  209.     procedure CMTextChanged(var Message: TMessage); message CM_TEXTCHANGED;
  210.     procedure CMShowingChanged(var Message: TMessage); message CM_SHOWINGCHANGED;
  211.   protected
  212.     procedure CreateParams(var Params: TCreateParams); override;
  213.     procedure DoHide; dynamic;
  214.     procedure DoShow; dynamic;
  215.     procedure ReadState(Reader: TReader); override;
  216.   public
  217.     constructor Create(AOwner: TComponent); override;
  218.     destructor Destroy; override;
  219.     property PageControl: TPageControl read FPageControl write SetPageControl;
  220.     property TabIndex: Integer read GetTabIndex;
  221.   published
  222.     property BorderWidth;
  223.     property Caption;
  224.     property DragMode;
  225.     property Enabled;
  226.     property Font;
  227.     property Height stored False;
  228.     property Highlighted: Boolean read FHighlighted write SetHighlighted default False;
  229.     property ImageIndex: TImageIndex read FImageIndex write SetImageIndex default 0;
  230.     property Left stored False;
  231.     property Constraints;
  232.     property PageIndex: Integer read GetPageIndex write SetPageIndex stored False;
  233.     property ParentFont;
  234.     property ParentShowHint;
  235.     property PopupMenu;
  236.     property ShowHint;
  237.     property TabVisible: Boolean read FTabVisible write SetTabVisible default True;
  238.     property Top stored False;
  239.     property Visible stored False;
  240.     property Width stored False;
  241.     property OnContextPopup;
  242.     property OnDragDrop;
  243.     property OnDragOver;
  244.     property OnEndDrag;
  245.     property OnEnter;
  246.     property OnExit;
  247.     property OnHide: TNotifyEvent read FOnHide write FOnHide;
  248.     property OnMouseDown;
  249.     property OnMouseMove;
  250.     property OnMouseUp;
  251.     property OnResize;
  252.     property OnShow: TNotifyEvent read FOnShow write FOnShow;
  253.     property OnStartDrag;
  254.   end;
  255.  
  256.   TPageControl = class(TCustomTabControl)
  257.   private
  258.     FPages: TList;
  259.     FActivePage: TTabSheet;
  260.     FNewDockSheet: TTabSheet;
  261.     FUndockingPage: TTabSheet;
  262.     procedure ChangeActivePage(Page: TTabSheet);
  263.     procedure DeleteTab(Page: TTabSheet; Index: Integer);
  264.     function GetActivePageIndex: Integer;
  265.     function GetDockClientFromMousePos(MousePos: TPoint): TControl;
  266.     function GetPage(Index: Integer): TTabSheet;
  267.     function GetPageCount: Integer;
  268.     procedure InsertPage(Page: TTabSheet);
  269.     procedure InsertTab(Page: TTabSheet);
  270.     procedure MoveTab(CurIndex, NewIndex: Integer);
  271.     procedure RemovePage(Page: TTabSheet);
  272.     procedure SetActivePage(Page: TTabSheet);
  273.     procedure SetActivePageIndex(const Value: Integer);
  274.     procedure UpdateTab(Page: TTabSheet);
  275.     procedure UpdateTabHighlights;
  276.     procedure CMDesignHitTest(var Message: TCMDesignHitTest); message CM_DESIGNHITTEST;
  277.     procedure CMDialogKey(var Message: TCMDialogKey); message CM_DIALOGKEY;
  278.     procedure CMDockClient(var Message: TCMDockClient); message CM_DOCKCLIENT;
  279.     procedure CMDockNotification(var Message: TCMDockNotification); message CM_DOCKNOTIFICATION;
  280.     procedure CMUnDockClient(var Message: TCMUnDockClient); message CM_UNDOCKCLIENT;
  281.     procedure WMLButtonDown(var Message: TWMLButtonDown); message WM_LBUTTONDOWN;
  282.     procedure WMLButtonDblClk(var Message: TWMLButtonDblClk); message WM_LBUTTONDBLCLK;
  283.   protected
  284.     function CanShowTab(TabIndex: Integer): Boolean; override;
  285.     procedure Change; override;
  286.     procedure DoAddDockClient(Client: TControl; const ARect: TRect); override;
  287.     procedure DockOver(Source: TDragDockObject; X, Y: Integer;
  288.       State: TDragState; var Accept: Boolean); override;
  289.     procedure DoRemoveDockClient(Client: TControl); override;
  290.     procedure GetChildren(Proc: TGetChildProc; Root: TComponent); override;
  291.     function GetImageIndex(TabIndex: Integer): Integer; override;
  292.     function GetPageFromDockClient(Client: TControl): TTabSheet;
  293.     procedure GetSiteInfo(Client: TControl; var InfluenceRect: TRect;
  294.       MousePos: TPoint; var CanDock: Boolean); override;
  295.     procedure Loaded; override;
  296.     procedure SetChildOrder(Child: TComponent; Order: Integer); override;
  297.     procedure ShowControl(AControl: TControl); override;
  298.     procedure UpdateActivePage; virtual;
  299.   public
  300.     constructor Create(AOwner: TComponent); override;
  301.     destructor Destroy; override;
  302.     function FindNextPage(CurPage: TTabSheet;
  303.       GoForward, CheckTabVisible: Boolean): TTabSheet;
  304.     procedure SelectNextPage(GoForward: Boolean);
  305.     property ActivePageIndex: Integer read GetActivePageIndex
  306.       write SetActivePageIndex;
  307.     property PageCount: Integer read GetPageCount;
  308.     property Pages[Index: Integer]: TTabSheet read GetPage;
  309.   published
  310.     property ActivePage: TTabSheet read FActivePage write SetActivePage;
  311.     property Align;
  312.     property Anchors;
  313.     property BiDiMode;
  314.     property Constraints;
  315.     property DockSite;
  316.     property DragCursor;
  317.     property DragKind;
  318.     property DragMode;
  319.     property Enabled;
  320.     property Font;
  321.     property HotTrack;
  322.     property Images;
  323.     property MultiLine;
  324.     property OwnerDraw;
  325.     property ParentBiDiMode;
  326.     property ParentFont;
  327.     property ParentShowHint;
  328.     property PopupMenu;
  329.     property RaggedRight;
  330.     property ScrollOpposite;
  331.     property ShowHint;
  332.     property Style;
  333.     property TabHeight;
  334.     property TabOrder;
  335.     property TabPosition;
  336.     property TabStop;
  337.     property TabWidth;
  338.     property Visible;
  339.     property OnChange;
  340.     property OnChanging;
  341.     property OnContextPopup;
  342.     property OnDockDrop;
  343.     property OnDockOver;
  344.     property OnDragDrop;
  345.     property OnDragOver;
  346.     property OnDrawTab;
  347.     property OnEndDock;
  348.     property OnEndDrag;
  349.     property OnEnter;
  350.     property OnExit;
  351.     property OnGetImageIndex;
  352.     property OnGetSiteInfo;
  353.     property OnMouseDown;
  354.     property OnMouseMove;
  355.     property OnMouseUp;
  356.     property OnResize;
  357.     property OnStartDock;
  358.     property OnStartDrag;
  359.     property OnUnDock;
  360.   end;
  361.  
  362. { TStatusBar }
  363.  
  364.   TStatusBar = class;
  365.  
  366.   TStatusPanelStyle = (psText, psOwnerDraw);
  367.   TStatusPanelBevel = (pbNone, pbLowered, pbRaised);
  368.  
  369.   TStatusPanel = class(TCollectionItem)
  370.   private
  371.     FText: string;
  372.     FWidth: Integer;
  373.     FAlignment: TAlignment;
  374.     FBevel: TStatusPanelBevel;
  375.     FBiDiMode: TBiDiMode;
  376.     FParentBiDiMode: Boolean;
  377.     FStyle: TStatusPanelStyle;
  378.     FUpdateNeeded: Boolean;
  379.     procedure SetAlignment(Value: TAlignment);
  380.     procedure SetBevel(Value: TStatusPanelBevel);
  381.     procedure SetBiDiMode(Value: TBiDiMode);
  382.     procedure SetParentBiDiMode(Value: Boolean);
  383.     procedure SetStyle(Value: TStatusPanelStyle);
  384.     procedure SetText(const Value: string);
  385.     procedure SetWidth(Value: Integer);
  386.     function IsBiDiModeStored: Boolean;
  387.   protected
  388.     function GetDisplayName: string; override;
  389.   public
  390.     constructor Create(Collection: TCollection); override;
  391.     procedure Assign(Source: TPersistent); override;
  392.     procedure ParentBiDiModeChanged;
  393.     function UseRightToLeftAlignment: Boolean;
  394.     function UseRightToLeftReading: Boolean;
  395.   published
  396.     property Alignment: TAlignment read FAlignment write SetAlignment default taLeftJustify;
  397.     property Bevel: TStatusPanelBevel read FBevel write SetBevel default pbLowered;
  398.     property BiDiMode: TBiDiMode read FBiDiMode write SetBiDiMode stored IsBiDiModeStored;
  399.     property ParentBiDiMode: Boolean read FParentBiDiMode write SetParentBiDiMode default True;
  400.     property Style: TStatusPanelStyle read FStyle write SetStyle default psText;
  401.     property Text: string read FText write SetText;
  402.     property Width: Integer read FWidth write SetWidth;
  403.   end;
  404.  
  405.   TStatusPanels = class(TCollection)
  406.   private
  407.     FStatusBar: TStatusBar;
  408.     function GetItem(Index: Integer): TStatusPanel;
  409.     procedure SetItem(Index: Integer; Value: TStatusPanel);
  410.   protected
  411.     function GetOwner: TPersistent; override;
  412.     procedure Update(Item: TCollectionItem); override;
  413.   public
  414.     constructor Create(StatusBar: TStatusBar);
  415.     function Add: TStatusPanel;
  416.     property Items[Index: Integer]: TStatusPanel read GetItem write SetItem; default;
  417.   end;
  418.  
  419.   TDrawPanelEvent = procedure(StatusBar: TStatusBar; Panel: TStatusPanel;
  420.     const Rect: TRect) of object;
  421.  
  422.   TStatusBar = class(TWinControl)
  423.   private
  424.     FPanels: TStatusPanels;
  425.     FCanvas: TCanvas;
  426.     FSimpleText: string;
  427.     FSimplePanel: Boolean;
  428.     FSizeGrip: Boolean;
  429.     FUseSystemFont: Boolean;
  430.     FAutoHint: Boolean;
  431.     FOnDrawPanel: TDrawPanelEvent;
  432.     FOnHint: TNotifyEvent;
  433.     procedure DoRightToLeftAlignment(var Str: string; AAlignment: TAlignment;
  434.       ARTLAlignment: Boolean);
  435.     function IsFontStored: Boolean;
  436.     procedure SetPanels(Value: TStatusPanels);
  437.     procedure SetSimplePanel(Value: Boolean);
  438.     procedure UpdateSimpleText;
  439.     procedure SetSimpleText(const Value: string);
  440.     procedure SetSizeGrip(Value: Boolean);
  441.     procedure SyncToSystemFont;
  442.     procedure UpdatePanel(Index: Integer; Repaint: Boolean);
  443.     procedure UpdatePanels(UpdateRects, UpdateText: Boolean);
  444.     procedure CMBiDiModeChanged(var Message: TMessage); message CM_BIDIMODECHANGED;
  445.     procedure CMColorChanged(var Message: TMessage); message CM_COLORCHANGED;
  446.     procedure CMParentFontChanged(var Message: TMessage); message CM_PARENTFONTCHANGED;
  447.     procedure CMSysColorChange(var Message: TMessage); message CM_SYSCOLORCHANGE;
  448.     procedure CMWinIniChange(var Message: TMessage); message CM_WININICHANGE;
  449.     procedure CMSysFontChanged(var Message: TMessage); message CM_SYSFONTCHANGED;
  450.     procedure CNDrawItem(var Message: TWMDrawItem); message CN_DRAWITEM;
  451.     procedure WMGetTextLength(var Message: TWMGetTextLength); message WM_GETTEXTLENGTH;
  452.     procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
  453.     procedure WMSize(var Message: TWMSize); message WM_SIZE;
  454.     procedure SetUseSystemFont(const Value: Boolean);
  455.   protected
  456.     procedure ChangeScale(M, D: Integer); override;
  457.     procedure CreateParams(var Params: TCreateParams); override;
  458.     procedure CreateWnd; override;
  459.     function DoHint: Boolean; virtual;
  460.     procedure DrawPanel(Panel: TStatusPanel; const Rect: TRect); dynamic;
  461.   public
  462.     constructor Create(AOwner: TComponent); override;
  463.     destructor Destroy; override;
  464.     function ExecuteAction(Action: TBasicAction): Boolean; override;
  465.     procedure FlipChildren(AllLevels: Boolean); override;
  466.     property Canvas: TCanvas read FCanvas;
  467.   published
  468.     property Action;
  469.     property AutoHint: Boolean read FAutoHint write FAutoHint default False;
  470.     property Align default alBottom;
  471.     property Anchors;
  472.     property BiDiMode;
  473.     property BorderWidth;
  474.     property Color default clBtnFace;
  475.     property DragCursor;
  476.     property DragKind;
  477.     property DragMode;
  478.     property Enabled;
  479.     property Font stored IsFontStored;
  480.     property Constraints;
  481.     property Panels: TStatusPanels read FPanels write SetPanels;
  482.     property ParentBiDiMode;
  483.     property ParentColor default False;
  484.     property ParentFont default False;
  485.     property ParentShowHint;
  486.     property PopupMenu;
  487.     property ShowHint;
  488.     property SimplePanel: Boolean read FSimplePanel write SetSimplePanel;
  489.     property SimpleText: string read FSimpleText write SetSimpleText;
  490.     property SizeGrip: Boolean read FSizeGrip write SetSizeGrip default True;
  491.     property UseSystemFont: Boolean read FUseSystemFont write SetUseSystemFont default True;
  492.     property Visible;
  493.     property OnClick;
  494.     property OnContextPopup;
  495.     property OnDblClick;
  496.     property OnDragDrop;
  497.     property OnDragOver;
  498.     property OnEndDock;
  499.     property OnEndDrag;
  500.     property OnHint: TNotifyEvent read FOnHint write FOnHint;
  501.     property OnMouseDown;
  502.     property OnMouseMove;
  503.     property OnMouseUp;
  504.     property OnDrawPanel: TDrawPanelEvent read FOnDrawPanel write FOnDrawPanel;
  505.     property OnResize;
  506.     property OnStartDock;
  507.     property OnStartDrag;
  508.   end;
  509.  
  510. { Custom draw }
  511.  
  512.   TCustomDrawTarget = (dtControl, dtItem, dtSubItem);
  513.   TCustomDrawStage = (cdPrePaint, cdPostPaint, cdPreErase, cdPostErase);
  514.   TCustomDrawState = set of (cdsSelected, cdsGrayed, cdsDisabled, cdsChecked,
  515.     cdsFocused, cdsDefault, cdsHot, cdsMarked, cdsIndeterminate);
  516.  
  517. { THeaderControl }
  518.  
  519.   THeaderControl = class;
  520.  
  521.   THeaderSectionStyle = (hsText, hsOwnerDraw);
  522.  
  523.   THeaderSection = class(TCollectionItem)
  524.   private
  525.     FText: string;
  526.     FWidth: Integer;
  527.     FMinWidth: Integer;
  528.     FMaxWidth: Integer;
  529.     FAlignment: TAlignment;
  530.     FStyle: THeaderSectionStyle;
  531.     FAllowClick: Boolean;
  532.     FAutoSize: Boolean;
  533.     FImageIndex: TImageIndex;
  534.     FBiDiMode: TBiDiMode;
  535.     FParentBiDiMode: Boolean;
  536.     function GetLeft: Integer;
  537.     function GetRight: Integer;
  538.     function IsBiDiModeStored: Boolean;
  539.     procedure SetAlignment(Value: TAlignment);
  540.     procedure SetAutoSize(Value: Boolean);
  541.     procedure SetBiDiMode(Value: TBiDiMode);
  542.     procedure SetMaxWidth(Value: Integer);
  543.     procedure SetMinWidth(Value: Integer);
  544.     procedure SetParentBiDiMode(Value: Boolean);
  545.     procedure SetStyle(Value: THeaderSectionStyle);
  546.     procedure SetText(const Value: string);
  547.     procedure SetWidth(Value: Integer);
  548.     procedure SetImageIndex(const Value: TImageIndex);
  549.   protected
  550.     function GetDisplayName: string; override;
  551.   public
  552.     constructor Create(Collection: TCollection); override;
  553.     procedure Assign(Source: TPersistent); override;
  554.     procedure ParentBiDiModeChanged;
  555.     function UseRightToLeftAlignment: Boolean;
  556.     function UseRightToLeftReading: Boolean;
  557.     property Left: Integer read GetLeft;
  558.     property Right: Integer read GetRight;
  559.   published
  560.     property Alignment: TAlignment read FAlignment write SetAlignment default taLeftJustify;
  561.     property AllowClick: Boolean read FAllowClick write FAllowClick default True;
  562.     property AutoSize: Boolean read FAutoSize write SetAutoSize default False;
  563.     property BiDiMode: TBiDiMode read FBiDiMode write SetBiDiMode stored IsBiDiModeStored;
  564.     property ImageIndex: TImageIndex read FImageIndex write SetImageIndex;
  565.     property MaxWidth: Integer read FMaxWidth write SetMaxWidth default 10000;
  566.     property MinWidth: Integer read FMinWidth write SetMinWidth default 0;
  567.     property ParentBiDiMode: Boolean read FParentBiDiMode write SetParentBiDiMode default True;
  568.     property Style: THeaderSectionStyle read FStyle write SetStyle default hsText;
  569.     property Text: string read FText write SetText;
  570.     property Width: Integer read FWidth write SetWidth;
  571.   end;
  572.  
  573.   THeaderSections = class(TCollection)
  574.   private
  575.     FHeaderControl: THeaderControl;
  576.     function GetItem(Index: Integer): THeaderSection;
  577.     procedure SetItem(Index: Integer; Value: THeaderSection);
  578.   protected
  579.     function GetOwner: TPersistent; override;
  580.     procedure Update(Item: TCollectionItem); override;
  581.   public
  582.     constructor Create(HeaderControl: THeaderControl);
  583.     function Add: THeaderSection;
  584.     property Items[Index: Integer]: THeaderSection read GetItem write SetItem; default;
  585.   end;
  586.  
  587.   TSectionTrackState = (tsTrackBegin, tsTrackMove, tsTrackEnd);
  588.  
  589.   TDrawSectionEvent = procedure(HeaderControl: THeaderControl;
  590.     Section: THeaderSection; const Rect: TRect; Pressed: Boolean) of object;
  591.   TSectionNotifyEvent = procedure(HeaderControl: THeaderControl;
  592.     Section: THeaderSection) of object;
  593.   TSectionTrackEvent = procedure(HeaderControl: THeaderControl;
  594.     Section: THeaderSection; Width: Integer;
  595.     State: TSectionTrackState) of object;
  596.   TSectionDragEvent = procedure (Sender: TObject; FromSection, ToSection: THeaderSection;
  597.     var AllowDrag: Boolean) of object;
  598.  
  599.   THeaderStyle = (hsButtons, hsFlat);
  600.  
  601.   THeaderControl = class(TWinControl)
  602.   private
  603.     FSections: THeaderSections;
  604.     FSectionStream: TMemoryStream;
  605.     FUpdatingSectionOrder,
  606.     FSectionDragged: Boolean;
  607.     FCanvas: TCanvas;
  608.     FFromIndex,
  609.     FToIndex: Integer;
  610.     FFullDrag: Boolean;
  611.     FHotTrack: Boolean;
  612.     FDragReorder: Boolean;
  613.     FImageChangeLink: TChangeLink;
  614.     FImages: TCustomImageList;
  615.     FStyle: THeaderStyle;
  616.     FTrackSection: THeaderSection;
  617.     FTrackWidth: Integer;
  618.     FTrackPos: TPoint;
  619.     FOnDrawSection: TDrawSectionEvent;
  620.     FOnSectionClick: TSectionNotifyEvent;
  621.     FOnSectionResize: TSectionNotifyEvent;
  622.     FOnSectionTrack: TSectionTrackEvent;
  623.     FOnSectionDrag: TSectionDragEvent;
  624.     FOnSectionEndDrag: TNotifyEvent;
  625.     function  DoSectionDrag(FromSection, ToSection: THeaderSection): Boolean;
  626.     procedure DoSectionEndDrag;
  627.     procedure ImageListChange(Sender: TObject);
  628.     procedure SetDragReorder(const Value: Boolean);
  629.     procedure SetFullDrag(Value: Boolean);
  630.     procedure SetHotTrack(Value: Boolean);
  631.     procedure SetSections(Value: THeaderSections);
  632.     procedure SetStyle(Value: THeaderStyle);
  633.     procedure UpdateItem(Message, Index: Integer);
  634.     procedure UpdateSection(Index: Integer);
  635.     procedure UpdateSections;
  636.     procedure CMBiDiModeChanged(var Message: TMessage); message CM_BIDIMODECHANGED;
  637.     procedure CNDrawItem(var Message: TWMDrawItem); message CN_DRAWITEM;
  638.     procedure CNNotify(var Message: TWMNotify); message CN_NOTIFY;
  639.     procedure WMLButtonDown(var Message: TWMLButtonDown); message WM_LBUTTONDOWN;
  640.     procedure WMSize(var Message: TWMSize); message WM_SIZE;
  641.     procedure WMWindowPosChanged(var Message: TWMWindowPosChanged); message WM_WINDOWPOSCHANGED;
  642.   protected
  643.     procedure CreateParams(var Params: TCreateParams); override;
  644.     procedure CreateWnd; override;
  645.     procedure DestroyWnd; override;
  646.     procedure DrawSection(Section: THeaderSection; const Rect: TRect;
  647.       Pressed: Boolean); dynamic;
  648.     procedure Notification(AComponent: TComponent; Operation: TOperation); override;
  649.     procedure SectionClick(Section: THeaderSection); dynamic;
  650.     procedure SectionDrag(FromSection, ToSection: THeaderSection; var AllowDrag: Boolean); dynamic;
  651.     procedure SectionEndDrag; dynamic;
  652.     procedure SectionResize(Section: THeaderSection); dynamic;
  653.     procedure SectionTrack(Section: THeaderSection; Width: Integer;
  654.       State: TSectionTrackState); dynamic;
  655.     procedure SetImages(Value: TCustomImageList); virtual;
  656.     procedure WndProc(var Message: TMessage); override;
  657.   public
  658.     constructor Create(AOwner: TComponent); override;
  659.     destructor Destroy; override;
  660.     property Canvas: TCanvas read FCanvas;
  661.     procedure FlipChildren(AllLevels: Boolean); override;
  662.   published
  663.     property Align default alTop;
  664.     property Anchors;
  665.     property BiDiMode;
  666.     property BorderWidth;
  667.     property DragCursor;
  668.     property DragKind;
  669.     property DragMode;
  670.     property DragReorder: Boolean read FDragReorder write SetDragReorder;
  671.     property Enabled;
  672.     property Font;
  673.     property FullDrag: Boolean read FFullDrag write SetFullDrag default True;
  674.     property HotTrack: Boolean read FHotTrack write SetHotTrack default False;
  675.     property Images: TCustomImageList read FImages write SetImages;
  676.     property Constraints;
  677.     property Sections: THeaderSections read FSections write SetSections;
  678.     property ShowHint;
  679.     property Style: THeaderStyle read FStyle write SetStyle default hsButtons;
  680.     property ParentBiDiMode;
  681.     property ParentFont;
  682.     property ParentShowHint;
  683.     property PopupMenu;
  684.     property Visible;
  685.     property OnContextPopup;
  686.     property OnDragDrop;
  687.     property OnDragOver;
  688.     property OnEndDock;
  689.     property OnEndDrag;
  690.     property OnMouseDown;
  691.     property OnMouseMove;
  692.     property OnMouseUp;
  693.     property OnDrawSection: TDrawSectionEvent read FOnDrawSection write FOnDrawSection;
  694.     property OnResize;
  695.     property OnSectionClick: TSectionNotifyEvent read FOnSectionClick
  696.       write FOnSectionClick;
  697.     property OnSectionDrag: TSectionDragEvent read FOnSectionDrag
  698.       write FOnSectionDrag;
  699.     property OnSectionEndDrag: TNotifyEvent read FOnSectionEndDrag
  700.       write FOnSectionEndDrag;
  701.     property OnSectionResize: TSectionNotifyEvent read FOnSectionResize
  702.       write FOnSectionResize;
  703.     property OnSectionTrack: TSectionTrackEvent read FOnSectionTrack
  704.       write FOnSectionTrack;
  705.     property OnStartDock;
  706.     property OnStartDrag;
  707.   end;
  708.  
  709. { TTreeNode }
  710.  
  711.   TCustomTreeView = class;
  712.   TTreeNodes = class;
  713.  
  714.   TNodeState = (nsCut, nsDropHilited, nsFocused, nsSelected, nsExpanded);
  715.   TNodeAttachMode = (naAdd, naAddFirst, naAddChild, naAddChildFirst, naInsert);
  716.   TAddMode = (taAddFirst, taAdd, taInsert);
  717.  
  718.   PNodeInfo = ^TNodeInfo;
  719.   TNodeInfo = packed record
  720.     ImageIndex: Integer;
  721.     SelectedIndex: Integer;
  722.     StateIndex: Integer;
  723.     OverlayIndex: Integer;
  724.     Data: Pointer;
  725.     Count: Integer;
  726.     Text: string[255];
  727.   end;
  728.  
  729.   TTreeNode = class(TPersistent)
  730.   private
  731.     FOwner: TTreeNodes;
  732.     FText: string;
  733.     FData: Pointer;
  734.     FItemId: HTreeItem;
  735.     FImageIndex: TImageIndex;
  736.     FSelectedIndex: Integer;
  737.     FOverlayIndex: Integer;
  738.     FStateIndex: Integer;
  739.     FDeleting: Boolean;
  740.     FInTree: Boolean;
  741.     function CompareCount(CompareMe: Integer): Boolean;
  742.     function DoCanExpand(Expand: Boolean): Boolean;
  743.     procedure DoExpand(Expand: Boolean);
  744.     procedure ExpandItem(Expand: Boolean; Recurse: Boolean);
  745.     function GetAbsoluteIndex: Integer;
  746.     function GetExpanded: Boolean;
  747.     function GetLevel: Integer;
  748.     function GetParent: TTreeNode;
  749.     function GetChildren: Boolean;
  750.     function GetCut: Boolean;
  751.     function GetDropTarget: Boolean;
  752.     function GetFocused: Boolean;
  753.     function GetIndex: Integer;
  754.     function GetItem(Index: Integer): TTreeNode;
  755.     function GetSelected: Boolean;
  756.     function GetState(NodeState: TNodeState): Boolean;
  757.     function GetCount: Integer;
  758.     function GetTreeView: TCustomTreeView;
  759.     procedure InternalMove(ParentNode, Node: TTreeNode; HItem: HTreeItem;
  760.       AddMode: TAddMode);
  761.     function IsEqual(Node: TTreeNode): Boolean;
  762.     function IsNodeVisible: Boolean;
  763.     procedure ReadData(Stream: TStream; Info: PNodeInfo);
  764.     procedure SetChildren(Value: Boolean);
  765.     procedure SetCut(Value: Boolean);
  766.     procedure SetData(Value: Pointer);
  767.     procedure SetDropTarget(Value: Boolean);
  768.     procedure SetItem(Index: Integer; Value: TTreeNode);
  769.     procedure SetExpanded(Value: Boolean);
  770.     procedure SetFocused(Value: Boolean);
  771.     procedure SetImageIndex(Value: TImageIndex);
  772.     procedure SetOverlayIndex(Value: Integer);
  773.     procedure SetSelectedIndex(Value: Integer);
  774.     procedure SetSelected(Value: Boolean);
  775.     procedure SetStateIndex(Value: Integer);
  776.     procedure SetText(const S: string);
  777.     procedure WriteData(Stream: TStream; Info: PNodeInfo);
  778.   public
  779.     constructor Create(AOwner: TTreeNodes);
  780.     destructor Destroy; override;
  781.     function AlphaSort: Boolean;
  782.     procedure Assign(Source: TPersistent); override;
  783.     procedure Collapse(Recurse: Boolean);
  784.     function CustomSort(SortProc: TTVCompare; Data: Longint): Boolean;
  785.     procedure Delete;
  786.     procedure DeleteChildren;
  787.     function DisplayRect(TextOnly: Boolean): TRect;
  788.     function EditText: Boolean;
  789.     procedure EndEdit(Cancel: Boolean);
  790.     procedure Expand(Recurse: Boolean);
  791.     function getFirstChild: TTreeNode; {GetFirstChild conflicts with C++ macro}
  792.     function GetHandle: HWND;
  793.     function GetLastChild: TTreeNode;
  794.     function GetNext: TTreeNode;
  795.     function GetNextChild(Value: TTreeNode): TTreeNode;
  796.     function getNextSibling: TTreeNode; {GetNextSibling conflicts with C++ macro}
  797.     function GetNextVisible: TTreeNode;
  798.     function GetPrev: TTreeNode;
  799.     function GetPrevChild(Value: TTreeNode): TTreeNode;
  800.     function getPrevSibling: TTreeNode; {GetPrevSibling conflicts with a C++ macro}
  801.     function GetPrevVisible: TTreeNode;
  802.     function HasAsParent(Value: TTreeNode): Boolean;
  803.     function IndexOf(Value: TTreeNode): Integer;
  804.     procedure MakeVisible;
  805.     procedure MoveTo(Destination: TTreeNode; Mode: TNodeAttachMode); virtual;
  806.     property AbsoluteIndex: Integer read GetAbsoluteIndex;
  807.     property Count: Integer read GetCount;
  808.     property Cut: Boolean read GetCut write SetCut;
  809.     property Data: Pointer read FData write SetData;
  810.     property Deleting: Boolean read FDeleting;
  811.     property Focused: Boolean read GetFocused write SetFocused;
  812.     property DropTarget: Boolean read GetDropTarget write SetDropTarget;
  813.     property Selected: Boolean read GetSelected write SetSelected;
  814.     property Expanded: Boolean read GetExpanded write SetExpanded;
  815.     property Handle: HWND read GetHandle;
  816.     property HasChildren: Boolean read GetChildren write SetChildren;
  817.     property ImageIndex: TImageIndex read FImageIndex write SetImageIndex;
  818.     property Index: Integer read GetIndex;
  819.     property IsVisible: Boolean read IsNodeVisible;
  820.     property Item[Index: Integer]: TTreeNode read GetItem write SetItem; default;
  821.     property ItemId: HTreeItem read FItemId;
  822.     property Level: Integer read GetLevel;
  823.     property OverlayIndex: Integer read FOverlayIndex write SetOverlayIndex;
  824.     property Owner: TTreeNodes read FOwner;
  825.     property Parent: TTreeNode read GetParent;
  826.     property SelectedIndex: Integer read FSelectedIndex write SetSelectedIndex;
  827.     property StateIndex: Integer read FStateIndex write SetStateIndex;
  828.     property Text: string read FText write SetText;
  829.     property TreeView: TCustomTreeView read GetTreeView;
  830.   end;
  831.  
  832. { TTreeNodes }
  833.  
  834.   PNodeCache = ^TNodeCache;
  835.   TNodeCache = record
  836.     CacheNode: TTreeNode;
  837.     CacheIndex: Integer;
  838.   end;
  839.  
  840.   TTreeNodes = class(TPersistent)
  841.   private
  842.     FOwner: TCustomTreeView;
  843.     FUpdateCount: Integer;
  844.     FNodeCache: TNodeCache;
  845.     procedure AddedNode(Value: TTreeNode);
  846.     function GetHandle: HWND;
  847.     function GetNodeFromIndex(Index: Integer): TTreeNode;
  848.     procedure ReadData(Stream: TStream);
  849.     procedure Repaint(Node: TTreeNode);
  850.     procedure WriteData(Stream: TStream);
  851.     procedure ClearCache;
  852.     procedure WriteExpandedState(Stream: TStream);
  853.     procedure ReadExpandedState(Stream: TStream);
  854.   protected
  855.     function AddItem(Parent, Target: HTreeItem; const Item: TTVItem;
  856.       AddMode: TAddMode): HTreeItem;
  857.     function InternalAddObject(Node: TTreeNode; const S: string;
  858.       Ptr: Pointer; AddMode: TAddMode): TTreeNode;
  859.     procedure DefineProperties(Filer: TFiler); override;
  860.     function CreateItem(Node: TTreeNode): TTVItem;
  861.     function GetCount: Integer;
  862.     procedure SetItem(Index: Integer; Value: TTreeNode);
  863.     procedure SetUpdateState(Updating: Boolean);
  864.   public
  865.     constructor Create(AOwner: TCustomTreeView);
  866.     destructor Destroy; override;
  867.     function AddChildFirst(Node: TTreeNode; const S: string): TTreeNode;
  868.     function AddChild(Node: TTreeNode; const S: string): TTreeNode;
  869.     function AddChildObjectFirst(Node: TTreeNode; const S: string;
  870.       Ptr: Pointer): TTreeNode;
  871.     function AddChildObject(Node: TTreeNode; const S: string;
  872.       Ptr: Pointer): TTreeNode;
  873.     function AddFirst(Node: TTreeNode; const S: string): TTreeNode;
  874.     function Add(Node: TTreeNode; const S: string): TTreeNode;
  875.     function AddObjectFirst(Node: TTreeNode; const S: string;
  876.       Ptr: Pointer): TTreeNode;
  877.     function AddObject(Node: TTreeNode; const S: string;
  878.       Ptr: Pointer): TTreeNode;
  879.     procedure Assign(Source: TPersistent); override;
  880.     procedure BeginUpdate;
  881.     procedure Clear;
  882.     procedure Delete(Node: TTreeNode);
  883.     procedure EndUpdate;
  884.     function GetFirstNode: TTreeNode;
  885.     function GetNode(ItemId: HTreeItem): TTreeNode;
  886.     function Insert(Node: TTreeNode; const S: string): TTreeNode;
  887.     function InsertObject(Node: TTreeNode; const S: string;
  888.       Ptr: Pointer): TTreeNode;
  889.     property Count: Integer read GetCount;
  890.     property Handle: HWND read GetHandle;
  891.     property Item[Index: Integer]: TTreeNode read GetNodeFromIndex; default;
  892.     property Owner: TCustomTreeView read FOwner;
  893.   end;
  894.  
  895. { TCustomTreeView }
  896.  
  897.   TSortType = (stNone, stData, stText, stBoth);
  898.   ETreeViewError = class(Exception);
  899.  
  900.   TTVChangingEvent = procedure(Sender: TObject; Node: TTreeNode;
  901.     var AllowChange: Boolean) of object;
  902.   TTVChangedEvent = procedure(Sender: TObject; Node: TTreeNode) of object;
  903.   TTVEditingEvent = procedure(Sender: TObject; Node: TTreeNode;
  904.     var AllowEdit: Boolean) of object;
  905.   TTVEditedEvent = procedure(Sender: TObject; Node: TTreeNode; var S: string) of object;
  906.   TTVExpandingEvent = procedure(Sender: TObject; Node: TTreeNode;
  907.     var AllowExpansion: Boolean) of object;
  908.   TTVCollapsingEvent = procedure(Sender: TObject; Node: TTreeNode;
  909.     var AllowCollapse: Boolean) of object;
  910.   TTVExpandedEvent = procedure(Sender: TObject; Node: TTreeNode) of object;
  911.   TTVCompareEvent = procedure(Sender: TObject; Node1, Node2: TTreeNode;
  912.     Data: Integer; var Compare: Integer) of object;
  913.   TTVCustomDrawEvent = procedure(Sender: TCustomTreeView; const ARect: TRect;
  914.     var DefaultDraw: Boolean) of object;
  915.   TTVCustomDrawItemEvent = procedure(Sender: TCustomTreeView; Node: TTreeNode;
  916.     State: TCustomDrawState; var DefaultDraw: Boolean) of object;
  917.   TTVAdvancedCustomDrawEvent = procedure(Sender: TCustomTreeView; const ARect: TRect;
  918.     Stage: TCustomDrawStage; var DefaultDraw: Boolean) of object;
  919.   TTVAdvancedCustomDrawItemEvent = procedure(Sender: TCustomTreeView; Node: TTreeNode;
  920.     State: TCustomDrawState; Stage: TCustomDrawStage; var PaintImages, DefaultDraw: Boolean) of object;
  921.  
  922.   TCustomTreeView = class(TWinControl)
  923.   private
  924.     FAutoExpand: Boolean;
  925.     FBorderStyle: TBorderStyle;
  926.     FCanvas: TCanvas;
  927.     FCanvasChanged: Boolean;
  928.     FDefEditProc: Pointer;
  929.     FDragged: Boolean;
  930.     FDragImage: TDragImageList;
  931.     FDragNode: TTreeNode;
  932.     FEditHandle: HWND;
  933.     FEditInstance: Pointer;
  934.     FHideSelection: Boolean;
  935.     FHotTrack: Boolean;
  936.     FImageChangeLink: TChangeLink;
  937.     FImages: TCustomImageList;
  938.     FLastDropTarget: TTreeNode;
  939.     FMemStream: TMemoryStream;
  940.     FRClickNode: TTreeNode;
  941.     FRightClickSelect: Boolean;
  942.     FManualNotify: Boolean;
  943.     FReadOnly: Boolean;
  944.     FRowSelect: Boolean;
  945.     FSaveIndex: Integer;
  946.     FSaveIndent: Integer;
  947.     FSaveItems: TStringList;
  948.     FSaveTopIndex: Integer;
  949.     FShowButtons: Boolean;
  950.     FShowLines: Boolean;
  951.     FShowRoot: Boolean;
  952.     FSortType: TSortType;
  953.     FStateChanging: Boolean;
  954.     FStateImages: TCustomImageList;
  955.     FStateChangeLink: TChangeLink;
  956.     FToolTips: Boolean;
  957.     FTreeNodes: TTreeNodes;
  958.     FWideText: WideString;
  959.     FOnAdvancedCustomDraw: TTVAdvancedCustomDrawEvent;
  960.     FOnAdvancedCustomDrawItem: TTVAdvancedCustomDrawItemEvent;
  961.     FOnChange: TTVChangedEvent;
  962.     FOnChanging: TTVChangingEvent;
  963.     FOnCollapsed: TTVExpandedEvent;
  964.     FOnCollapsing: TTVCollapsingEvent;
  965.     FOnCompare: TTVCompareEvent;
  966.     FOnCustomDraw: TTVCustomDrawEvent;
  967.     FOnCustomDrawItem: TTVCustomDrawItemEvent;
  968.     FOnDeletion: TTVExpandedEvent;
  969.     FOnEditing: TTVEditingEvent;
  970.     FOnEdited: TTVEditedEvent;
  971.     FOnExpanded: TTVExpandedEvent;
  972.     FOnExpanding: TTVExpandingEvent;
  973.     FOnGetImageIndex: TTVExpandedEvent;
  974.     FOnGetSelectedIndex: TTVExpandedEvent;
  975.     procedure CanvasChanged(Sender: TObject);
  976.     procedure CMColorChanged(var Message: TMessage); message CM_COLORCHANGED;
  977.     procedure CMCtl3DChanged(var Message: TMessage); message CM_CTL3DCHANGED;
  978.     procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
  979.     procedure CMDrag(var Message: TCMDrag); message CM_DRAG;
  980.     procedure CNNotify(var Message: TWMNotify); message CN_NOTIFY;
  981.     procedure EditWndProc(var Message: TMessage);
  982.     procedure DoDragOver(Source: TDragObject; X, Y: Integer; CanDrop: Boolean);
  983.     function GetChangeDelay: Integer;
  984.     function GetDropTarget: TTreeNode;
  985.     function GetIndent: Integer;
  986.     function GetNodeFromItem(const Item: TTVItem): TTreeNode;
  987.     function GetSelection: TTreeNode;
  988.     function GetTopItem: TTreeNode;
  989.     procedure ImageListChange(Sender: TObject);
  990.     procedure SetAutoExpand(Value: Boolean);
  991.     procedure SetBorderStyle(Value: TBorderStyle);
  992.     procedure SetButtonStyle(Value: Boolean);
  993.     procedure SetChangeDelay(Value: Integer);
  994.     procedure SetDropTarget(Value: TTreeNode);
  995.     procedure SetHideSelection(Value: Boolean);
  996.     procedure SetHotTrack(Value: Boolean);
  997.     procedure SetImageList(Value: HImageList; Flags: Integer);
  998.     procedure SetIndent(Value: Integer);
  999.     procedure SetImages(Value: TCustomImageList);
  1000.     procedure SetLineStyle(Value: Boolean);
  1001.     procedure SetReadOnly(Value: Boolean);
  1002.     procedure SetRootStyle(Value: Boolean);
  1003.     procedure SetRowSelect(Value: Boolean);
  1004.     procedure SetSelection(Value: TTreeNode);
  1005.     procedure SetSortType(Value: TSortType);
  1006.     procedure SetStateImages(Value: TCustomImageList);
  1007.     procedure SetToolTips(Value: Boolean);
  1008.     procedure SetTreeNodes(Value: TTreeNodes);
  1009.     procedure SetTopItem(Value: TTreeNode);
  1010.     procedure OnChangeTimer(Sender: TObject);
  1011.     procedure WMLButtonDown(var Message: TWMLButtonDown); message WM_LBUTTONDOWN;
  1012.     procedure WMNotify(var Message: TWMNotify); message WM_NOTIFY;
  1013.     procedure WMContextMenu(var Message: TWMContextMenu); message WM_CONTEXTMENU;
  1014.     procedure CMSysColorChange(var Message: TMessage); message CM_SYSCOLORCHANGE;
  1015.   protected
  1016.     FChangeTimer: TTimer;
  1017.     function CanEdit(Node: TTreeNode): Boolean; dynamic;
  1018.     function CanChange(Node: TTreeNode): Boolean; dynamic;
  1019.     function CanCollapse(Node: TTreeNode): Boolean; dynamic;
  1020.     function CanExpand(Node: TTreeNode): Boolean; dynamic;
  1021.     procedure Change(Node: TTreeNode); dynamic;
  1022.     procedure Collapse(Node: TTreeNode); dynamic;
  1023.     function CreateNode: TTreeNode; virtual;
  1024.     procedure CreateParams(var Params: TCreateParams); override;
  1025.     procedure CreateWnd; override;
  1026.     function CustomDraw(const ARect: TRect; Stage: TCustomDrawStage): Boolean; virtual;
  1027.     function CustomDrawItem(Node: TTreeNode; State: TCustomDrawState;
  1028.       Stage: TCustomDrawStage; var PaintImages: Boolean): Boolean; virtual;
  1029.     procedure Delete(Node: TTreeNode); dynamic;
  1030.     procedure DestroyWnd; override;
  1031.     procedure DoEndDrag(Target: TObject; X, Y: Integer); override;
  1032.     procedure DoStartDrag(var DragObject: TDragObject); override;
  1033.     procedure Edit(const Item: TTVItem); dynamic;
  1034.     procedure Expand(Node: TTreeNode); dynamic;
  1035.     function GetDragImages: TDragImageList; override;
  1036.     procedure GetImageIndex(Node: TTreeNode); virtual;
  1037.     procedure GetSelectedIndex(Node: TTreeNode); virtual;
  1038.     function IsCustomDrawn(Target: TCustomDrawTarget; Stage: TCustomDrawStage): Boolean;
  1039.     procedure Loaded; override;
  1040.     procedure Notification(AComponent: TComponent;
  1041.       Operation: TOperation); override;
  1042.     procedure SetDragMode(Value: TDragMode); override;
  1043.     procedure WndProc(var Message: TMessage); override;
  1044.     property AutoExpand: Boolean read FAutoExpand write SetAutoExpand default False;
  1045.     property BorderStyle: TBorderStyle read FBorderStyle write SetBorderStyle default bsSingle;
  1046.     property ChangeDelay: Integer read GetChangeDelay write SetChangeDelay default 0;
  1047.     property HideSelection: Boolean read FHideSelection write SetHideSelection default True;
  1048.     property HotTrack: Boolean read FHotTrack write SetHotTrack default False;
  1049.     property Images: TCustomImageList read FImages write SetImages;
  1050.     property Indent: Integer read GetIndent write SetIndent;
  1051.     property Items: TTreeNodes read FTreeNodes write SetTreeNodes;
  1052.     property ReadOnly: Boolean read FReadOnly write SetReadOnly default False;
  1053.     property RightClickSelect: Boolean read FRightClickSelect write FRightClickSelect default False;
  1054.     property RowSelect: Boolean read FRowSelect write SetRowSelect default False;
  1055.     property ShowButtons: Boolean read FShowButtons write SetButtonStyle default True;
  1056.     property ShowLines: Boolean read FShowLines write SetLineStyle default True;
  1057.     property ShowRoot: Boolean read FShowRoot write SetRootStyle default True;
  1058.     property SortType: TSortType read FSortType write SetSortType default stNone;
  1059.     property StateImages: TCustomImageList read FStateImages write SetStateImages;
  1060.     property ToolTips: Boolean read FToolTips write SetToolTips default True;
  1061.     property OnAdvancedCustomDraw: TTVAdvancedCustomDrawEvent read FOnAdvancedCustomDraw write FOnAdvancedCustomDraw;
  1062.     property OnAdvancedCustomDrawItem: TTVAdvancedCustomDrawItemEvent read FOnAdvancedCustomDrawItem write FOnAdvancedCustomDrawItem;
  1063.     property OnChange: TTVChangedEvent read FOnChange write FOnChange;
  1064.     property OnChanging: TTVChangingEvent read FOnChanging write FOnChanging;
  1065.     property OnCollapsed: TTVExpandedEvent read FOnCollapsed write FOnCollapsed;
  1066.     property OnCollapsing: TTVCollapsingEvent read FOnCollapsing write FOnCollapsing;
  1067.     property OnCompare: TTVCompareEvent read FOnCompare write FOnCompare;
  1068.     property OnCustomDraw: TTVCustomDrawEvent read FOnCustomDraw write FOnCustomDraw;
  1069.     property OnCustomDrawItem: TTVCustomDrawItemEvent read FOnCustomDrawItem write FOnCustomDrawItem;
  1070.     property OnDeletion: TTVExpandedEvent read FOnDeletion write FOnDeletion;
  1071.     property OnEditing: TTVEditingEvent read FOnEditing write FOnEditing;
  1072.     property OnEdited: TTVEditedEvent read FOnEdited write FOnEdited;
  1073.     property OnExpanding: TTVExpandingEvent read FOnExpanding write FOnExpanding;
  1074.     property OnExpanded: TTVExpandedEvent read FOnExpanded write FOnExpanded;
  1075.     property OnGetImageIndex: TTVExpandedEvent read FOnGetImageIndex write FOnGetImageIndex;
  1076.     property OnGetSelectedIndex: TTVExpandedEvent read FOnGetSelectedIndex write FOnGetSelectedIndex;
  1077.   public
  1078.     constructor Create(AOwner: TComponent); override;
  1079.     destructor Destroy; override;
  1080.     function AlphaSort: Boolean;
  1081.     function CustomSort(SortProc: TTVCompare; Data: Longint): Boolean;
  1082.     procedure FullCollapse;
  1083.     procedure FullExpand;
  1084.     function GetHitTestInfoAt(X, Y: Integer): THitTests;
  1085.     function GetNodeAt(X, Y: Integer): TTreeNode;
  1086.     function IsEditing: Boolean;
  1087.     procedure LoadFromFile(const FileName: string);
  1088.     procedure LoadFromStream(Stream: TStream);
  1089.     procedure SaveToFile(const FileName: string);
  1090.     procedure SaveToStream(Stream: TStream);
  1091.     property Canvas: TCanvas read FCanvas;
  1092.     property DropTarget: TTreeNode read GetDropTarget write SetDropTarget;
  1093.     property Selected: TTreeNode read GetSelection write SetSelection;
  1094.     property TopItem: TTreeNode read GetTopItem write SetTopItem;
  1095.   end;
  1096.  
  1097.   TTreeView = class(TCustomTreeView)
  1098.   published
  1099.     property Align;
  1100.     property Anchors;
  1101.     property AutoExpand;
  1102.     property BiDiMode;
  1103.     property BorderStyle;
  1104.     property BorderWidth;
  1105.     property ChangeDelay;
  1106.     property Color;
  1107.     property Ctl3D;
  1108.     property Constraints;
  1109.     property DragKind;
  1110.     property DragCursor;
  1111.     property DragMode;
  1112.     property Enabled;
  1113.     property Font;
  1114.     property HideSelection;
  1115.     property HotTrack;
  1116.     property Images;
  1117.     property Indent;
  1118.     property ParentBiDiMode;
  1119.     property ParentColor default False;
  1120.     property ParentCtl3D;
  1121.     property ParentFont;
  1122.     property ParentShowHint;
  1123.     property PopupMenu;
  1124.     property ReadOnly;
  1125.     property RightClickSelect;
  1126.     property RowSelect;
  1127.     property ShowButtons;
  1128.     property ShowHint;
  1129.     property ShowLines;
  1130.     property ShowRoot;
  1131.     property SortType;
  1132.     property StateImages;
  1133.     property TabOrder;
  1134.     property TabStop default True;
  1135.     property ToolTips;
  1136.     property Visible;
  1137.     property OnAdvancedCustomDraw;
  1138.     property OnAdvancedCustomDrawItem;
  1139.     property OnChange;
  1140.     property OnChanging;
  1141.     property OnClick;
  1142.     property OnCollapsed;
  1143.     property OnCollapsing;
  1144.     property OnCompare;
  1145.     property OnContextPopup;
  1146.     property OnCustomDraw;
  1147.     property OnCustomDrawItem;
  1148.     property OnDblClick;
  1149.     property OnDeletion;
  1150.     property OnDragDrop;
  1151.     property OnDragOver;
  1152.     property OnEdited;
  1153.     property OnEditing;
  1154.     property OnEndDock;
  1155.     property OnEndDrag;
  1156.     property OnEnter;
  1157.     property OnExit;
  1158.     property OnExpanding;
  1159.     property OnExpanded;
  1160.     property OnGetImageIndex;
  1161.     property OnGetSelectedIndex;
  1162.     property OnKeyDown;
  1163.     property OnKeyPress;
  1164.     property OnKeyUp;
  1165.     property OnMouseDown;
  1166.     property OnMouseMove;
  1167.     property OnMouseUp;
  1168.     property OnStartDock;
  1169.     property OnStartDrag;
  1170.     { Items must be published after OnGetImageIndex and OnGetSelectedIndex }
  1171.     property Items;
  1172.   end;
  1173.  
  1174. { TTrackBar }
  1175.  
  1176.   TTrackBarOrientation = (trHorizontal, trVertical);
  1177.   TTickMark = (tmBottomRight, tmTopLeft, tmBoth);
  1178.   TTickStyle = (tsNone, tsAuto, tsManual);
  1179.  
  1180.   TTrackBar = class(TWinControl)
  1181.   private
  1182.     FOrientation: TTrackBarOrientation;
  1183.     FTickMarks: TTickMark;
  1184.     FTickStyle: TTickStyle;
  1185.     FLineSize: Integer;
  1186.     FPageSize: Integer;
  1187.     FThumbLength: Integer;
  1188.     FSliderVisible: Boolean;
  1189.     FMin: Integer;
  1190.     FMax: Integer;
  1191.     FFrequency: Integer;
  1192.     FPosition: Integer;
  1193.     FSelStart: Integer;
  1194.     FSelEnd: Integer;
  1195.     FOnChange: TNotifyEvent;
  1196.     function GetThumbLength: Integer;
  1197.     procedure SetOrientation(Value: TTrackBarOrientation);
  1198.     procedure SetParams(APosition, AMin, AMax: Integer);
  1199.     procedure SetPosition(Value: Integer);
  1200.     procedure SetMin(Value: Integer);
  1201.     procedure SetMax(Value: Integer);
  1202.     procedure SetFrequency(Value: Integer);
  1203.     procedure SetTickStyle(Value: TTickStyle);
  1204.     procedure SetTickMarks(Value: TTickMark);
  1205.     procedure SetLineSize(Value: Integer);
  1206.     procedure SetPageSize(Value: Integer);
  1207.     procedure SetThumbLength(Value: Integer);
  1208.     procedure SetSliderVisible(Value: Boolean);
  1209.     procedure SetSelStart(Value: Integer);
  1210.     procedure SetSelEnd(Value: Integer);
  1211.     procedure UpdateSelection;
  1212.     procedure CNHScroll(var Message: TWMHScroll); message CN_HSCROLL;
  1213.     procedure CNVScroll(var Message: TWMVScroll); message CN_VSCROLL;
  1214.   protected
  1215.     procedure CreateParams(var Params: TCreateParams); override;
  1216.     procedure CreateWnd; override;
  1217.     procedure DestroyWnd; override;
  1218.     procedure Changed; dynamic;
  1219.   public
  1220.     constructor Create(AOwner: TComponent); override;
  1221.     procedure SetTick(Value: Integer);
  1222.   published
  1223.     property Align;
  1224.     property Anchors;
  1225.     property BorderWidth;
  1226.     property Ctl3D;
  1227.     property DragCursor;
  1228.     property DragKind;
  1229.     property DragMode;
  1230.     property Enabled;
  1231.     property Constraints;
  1232.     property LineSize: Integer read FLineSize write SetLineSize default 1;
  1233.     property Max: Integer read FMax write SetMax default 10;
  1234.     property Min: Integer read FMin write SetMin default 0;
  1235.     property Orientation: TTrackBarOrientation read FOrientation write SetOrientation;
  1236.     property ParentCtl3D;
  1237.     property ParentShowHint;
  1238.     property PageSize: Integer read FPageSize write SetPageSize default 2;
  1239.     property PopupMenu;
  1240.     property Frequency: Integer read FFrequency write SetFrequency;
  1241.     property Position: Integer read FPosition write SetPosition;
  1242.     property SliderVisible: Boolean read FSliderVisible write SetSliderVisible default True;
  1243.     property SelEnd: Integer read FSelEnd write SetSelEnd;
  1244.     property SelStart: Integer read FSelStart write SetSelStart;
  1245.     property ShowHint;
  1246.     property TabOrder;
  1247.     property TabStop default True;
  1248.     property ThumbLength: Integer read GetThumbLength write SetThumbLength default 20;
  1249.     property TickMarks: TTickMark read FTickMarks write SetTickMarks;
  1250.     property TickStyle: TTickStyle read FTickStyle write SetTickStyle;
  1251.     property Visible;
  1252.     property OnContextPopup;
  1253.     property OnChange: TNotifyEvent read FOnChange write FOnChange;
  1254.     property OnDragDrop;
  1255.     property OnDragOver;
  1256.     property OnEndDock;
  1257.     property OnEndDrag;
  1258.     property OnEnter;
  1259.     property OnExit;
  1260.     property OnKeyDown;
  1261.     property OnKeyPress;
  1262.     property OnKeyUp;
  1263.     property OnStartDock;
  1264.     property OnStartDrag;
  1265.   end;
  1266.  
  1267. { TProgressBar }
  1268.  
  1269.   TProgressRange = Integer; // for backward compatibility
  1270.  
  1271.   TProgressBarOrientation = (pbHorizontal, pbVertical);
  1272.  
  1273.   TProgressBar = class(TWinControl)
  1274.   private
  1275.     F32BitMode: Boolean;
  1276.     FMin: Integer;
  1277.     FMax: Integer;
  1278.     FPosition: Integer;
  1279.     FStep: Integer;
  1280.     FOrientation: TProgressBarOrientation;
  1281.     FSmooth: Boolean;
  1282.     function GetMin: Integer;
  1283.     function GetMax: Integer;
  1284.     function GetPosition: Integer;
  1285.     procedure SetParams(AMin, AMax: Integer);
  1286.     procedure SetMin(Value: Integer);
  1287.     procedure SetMax(Value: Integer);
  1288.     procedure SetPosition(Value: Integer);
  1289.     procedure SetStep(Value: Integer);
  1290.     procedure SetOrientation(Value: TProgressBarOrientation);
  1291.     procedure SetSmooth(Value: Boolean);
  1292.   protected
  1293.     procedure CreateParams(var Params: TCreateParams); override;
  1294.     procedure CreateWnd; override;
  1295.     procedure DestroyWnd; override;
  1296.   public
  1297.     constructor Create(AOwner: TComponent); override;
  1298.     procedure StepIt;
  1299.     procedure StepBy(Delta: Integer);
  1300.   published
  1301.     property Align;
  1302.     property Anchors;
  1303.     property BorderWidth;
  1304.     property DragCursor;
  1305.     property DragKind;
  1306.     property DragMode;
  1307.     property Enabled;
  1308.     property Hint;
  1309.     property Constraints;
  1310.     property Min: Integer read GetMin write SetMin;
  1311.     property Max: Integer read GetMax write SetMax;
  1312.     property Orientation: TProgressBarOrientation read FOrientation
  1313.       write SetOrientation default pbHorizontal;
  1314.     property ParentShowHint;
  1315.     property PopupMenu;
  1316.     property Position: Integer read GetPosition write SetPosition default 0;
  1317.     property Smooth: Boolean read FSmooth write SetSmooth default False;
  1318.     property Step: Integer read FStep write SetStep default 10;
  1319.     property ShowHint;
  1320.     property TabOrder;
  1321.     property TabStop;
  1322.     property Visible;
  1323.     property OnContextPopup;
  1324.     property OnDragDrop;
  1325.     property OnDragOver;
  1326.     property OnEndDock;
  1327.     property OnEndDrag;
  1328.     property OnEnter;
  1329.     property OnExit;
  1330.     property OnMouseDown;
  1331.     property OnMouseMove;
  1332.     property OnMouseUp;
  1333.     property OnStartDock;
  1334.     property OnStartDrag;
  1335.   end;
  1336.  
  1337. { TTextAttributes }
  1338.  
  1339.   TCustomRichEdit = class;
  1340.  
  1341.   TAttributeType = (atSelected, atDefaultText);
  1342.   TConsistentAttribute = (caBold, caColor, caFace, caItalic,
  1343.     caSize, caStrikeOut, caUnderline, caProtected);
  1344.   TConsistentAttributes = set of TConsistentAttribute;
  1345.  
  1346.   TTextAttributes = class(TPersistent)
  1347.   private
  1348.     RichEdit: TCustomRichEdit;
  1349.     FType: TAttributeType;
  1350.     procedure GetAttributes(var Format: TCharFormat);
  1351.     function GetCharset: TFontCharset;
  1352.     function GetColor: TColor;
  1353.     function GetConsistentAttributes: TConsistentAttributes;
  1354.     function GetHeight: Integer;
  1355.     function GetName: TFontName;
  1356.     function GetPitch: TFontPitch;
  1357.     function GetProtected: Boolean;
  1358.     function GetSize: Integer;
  1359.     function GetStyle: TFontStyles;
  1360.     procedure SetAttributes(var Format: TCharFormat);
  1361.     procedure SetCharset(Value: TFontCharset);
  1362.     procedure SetColor(Value: TColor);
  1363.     procedure SetHeight(Value: Integer);
  1364.     procedure SetName(Value: TFontName);
  1365.     procedure SetPitch(Value: TFontPitch);
  1366.     procedure SetProtected(Value: Boolean);
  1367.     procedure SetSize(Value: Integer);
  1368.     procedure SetStyle(Value: TFontStyles);
  1369.   protected
  1370.     procedure InitFormat(var Format: TCharFormat);
  1371.     procedure AssignTo(Dest: TPersistent); override;
  1372.   public
  1373.     constructor Create(AOwner: TCustomRichEdit; AttributeType: TAttributeType);
  1374.     procedure Assign(Source: TPersistent); override;
  1375.     property Charset: TFontCharset read GetCharset write SetCharset;
  1376.     property Color: TColor read GetColor write SetColor;
  1377.     property ConsistentAttributes: TConsistentAttributes read GetConsistentAttributes;
  1378.     property Name: TFontName read GetName write SetName;
  1379.     property Pitch: TFontPitch read GetPitch write SetPitch;
  1380.     property Protected: Boolean read GetProtected write SetProtected;
  1381.     property Size: Integer read GetSize write SetSize;
  1382.     property Style: TFontStyles read GetStyle write SetStyle;
  1383.     property Height: Integer read GetHeight write SetHeight;
  1384.   end;
  1385.  
  1386. { TParaAttributes }
  1387.  
  1388.   TNumberingStyle = (nsNone, nsBullet);
  1389.  
  1390.   TParaAttributes = class(TPersistent)
  1391.   private
  1392.     RichEdit: TCustomRichEdit;
  1393.     procedure GetAttributes(var Paragraph: TParaFormat);
  1394.     function GetAlignment: TAlignment;
  1395.     function GetFirstIndent: Longint;
  1396.     function GetLeftIndent: Longint;
  1397.     function GetRightIndent: Longint;
  1398.     function GetNumbering: TNumberingStyle;
  1399.     function GetTab(Index: Byte): Longint;
  1400.     function GetTabCount: Integer;
  1401.     procedure InitPara(var Paragraph: TParaFormat);
  1402.     procedure SetAlignment(Value: TAlignment);
  1403.     procedure SetAttributes(var Paragraph: TParaFormat);
  1404.     procedure SetFirstIndent(Value: Longint);
  1405.     procedure SetLeftIndent(Value: Longint);
  1406.     procedure SetRightIndent(Value: Longint);
  1407.     procedure SetNumbering(Value: TNumberingStyle);
  1408.     procedure SetTab(Index: Byte; Value: Longint);
  1409.     procedure SetTabCount(Value: Integer);
  1410.   public
  1411.     constructor Create(AOwner: TCustomRichEdit);
  1412.     procedure Assign(Source: TPersistent); override;
  1413.     property Alignment: TAlignment read GetAlignment write SetAlignment;
  1414.     property FirstIndent: Longint read GetFirstIndent write SetFirstIndent;
  1415.     property LeftIndent: Longint read GetLeftIndent write SetLeftIndent;
  1416.     property Numbering: TNumberingStyle read GetNumbering write SetNumbering;
  1417.     property RightIndent: Longint read GetRightIndent write SetRightIndent;
  1418.     property Tab[Index: Byte]: Longint read GetTab write SetTab;
  1419.     property TabCount: Integer read GetTabCount write SetTabCount;
  1420.   end;
  1421.  
  1422. { TCustomRichEdit }
  1423.  
  1424.   TRichEditResizeEvent = procedure(Sender: TObject; Rect: TRect) of object;
  1425.   TRichEditProtectChange = procedure(Sender: TObject;
  1426.     StartPos, EndPos: Integer; var AllowChange: Boolean) of object;
  1427.   TRichEditSaveClipboard = procedure(Sender: TObject;
  1428.     NumObjects, NumChars: Integer; var SaveClipboard: Boolean) of object;
  1429.   TSearchType = (stWholeWord, stMatchCase);
  1430.   TSearchTypes = set of TSearchType;
  1431.  
  1432.   TConversion = class(TObject)
  1433.   public
  1434.     function ConvertReadStream(Stream: TStream; Buffer: PChar; BufSize: Integer): Integer; virtual;
  1435.     function ConvertWriteStream(Stream: TStream; Buffer: PChar; BufSize: Integer): Integer; virtual;
  1436.   end;
  1437.  
  1438.   TConversionClass = class of TConversion;
  1439.  
  1440.   PConversionFormat = ^TConversionFormat;
  1441.   TConversionFormat = record
  1442.     ConversionClass: TConversionClass;
  1443.     Extension: string;
  1444.     Next: PConversionFormat;
  1445.   end;
  1446.  
  1447.   PRichEditStreamInfo = ^TRichEditStreamInfo;
  1448.   TRichEditStreamInfo = record
  1449.     Converter: TConversion;
  1450.     Stream: TStream;
  1451.   end;
  1452.  
  1453.   TCustomRichEdit = class(TCustomMemo)
  1454.   private
  1455.     FHideScrollBars: Boolean;
  1456.     FSelAttributes: TTextAttributes;
  1457.     FDefAttributes: TTextAttributes;
  1458.     FParagraph: TParaAttributes;
  1459.     FOldParaAlignment: TAlignment;
  1460.     FScreenLogPixels: Integer;
  1461.     FRichEditStrings: TStrings;
  1462.     FMemStream: TMemoryStream;
  1463.     FOnSelChange: TNotifyEvent;
  1464.     FHideSelection: Boolean;
  1465.     FModified: Boolean;
  1466.     FDefaultConverter: TConversionClass;
  1467.     FOnResizeRequest: TRichEditResizeEvent;
  1468.     FOnProtectChange: TRichEditProtectChange;
  1469.     FOnSaveClipboard: TRichEditSaveClipboard;
  1470.     FPageRect: TRect;
  1471.     procedure CMBiDiModeChanged(var Message: TMessage); message CM_BIDIMODECHANGED;
  1472.     procedure CMColorChanged(var Message: TMessage); message CM_COLORCHANGED;
  1473.     procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
  1474.     procedure CNNotify(var Message: TWMNotify); message CN_NOTIFY;
  1475.     function GetPlainText: Boolean;
  1476.     function ProtectChange(StartPos, EndPos: Integer): Boolean;
  1477.     function SaveClipboard(NumObj, NumChars: Integer): Boolean;
  1478.     procedure SetHideScrollBars(Value: Boolean);
  1479.     procedure SetHideSelection(Value: Boolean);
  1480.     procedure SetPlainText(Value: Boolean);
  1481.     procedure SetRichEditStrings(Value: TStrings);
  1482.     procedure SetDefAttributes(Value: TTextAttributes);
  1483.     procedure SetSelAttributes(Value: TTextAttributes);
  1484.     procedure WMNCDestroy(var Message: TWMNCDestroy); message WM_NCDESTROY;
  1485.     procedure WMSetCursor(var Message: TWMSetCursor); message WM_SETCURSOR;
  1486.     procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
  1487.     procedure WMSetFont(var Message: TWMSetFont); message WM_SETFONT;
  1488.     procedure WMRButtonUp(var Message: TWMRButtonUp); message WM_RBUTTONUP;
  1489.   protected
  1490.     procedure CreateParams(var Params: TCreateParams); override;
  1491.     procedure CreateWnd; override;
  1492.     procedure DestroyWnd; override;
  1493.     procedure RequestSize(const Rect: TRect); virtual;
  1494.     procedure SelectionChange; dynamic;
  1495.     procedure DoSetMaxLength(Value: Integer); override;
  1496.     function GetCaretPos: TPoint; override;
  1497.     function GetSelLength: Integer; override;
  1498.     function GetSelStart: Integer; override;
  1499.     function GetSelText: string; override;
  1500.     procedure SetSelLength(Value: Integer); override;
  1501.     procedure SetSelStart(Value: Integer); override;
  1502.     property HideSelection: Boolean read FHideSelection write SetHideSelection default True;
  1503.     property HideScrollBars: Boolean read FHideScrollBars
  1504.       write SetHideScrollBars default True;
  1505.     property Lines: TStrings read FRichEditStrings write SetRichEditStrings;
  1506.     property OnSaveClipboard: TRichEditSaveClipboard read FOnSaveClipboard
  1507.       write FOnSaveClipboard;
  1508.     property OnSelectionChange: TNotifyEvent read FOnSelChange write FOnSelChange;
  1509.     property OnProtectChange: TRichEditProtectChange read FOnProtectChange
  1510.       write FOnProtectChange;
  1511.     property OnResizeRequest: TRichEditResizeEvent read FOnResizeRequest
  1512.       write FOnResizeRequest;
  1513.     property PlainText: Boolean read GetPlainText write SetPlainText default False;
  1514.   public
  1515.     constructor Create(AOwner: TComponent); override;
  1516.     destructor Destroy; override;
  1517.     procedure Clear; override;
  1518.     function FindText(const SearchStr: string;
  1519.       StartPos, Length: Integer; Options: TSearchTypes): Integer;
  1520.     function GetSelTextBuf(Buffer: PChar; BufSize: Integer): Integer; override;
  1521.     procedure Print(const Caption: string); virtual;
  1522.     class procedure RegisterConversionFormat(const AExtension: string;
  1523.       AConversionClass: TConversionClass);
  1524.     property DefaultConverter: TConversionClass
  1525.       read FDefaultConverter write FDefaultConverter;
  1526.     property DefAttributes: TTextAttributes read FDefAttributes write SetDefAttributes;
  1527.     property SelAttributes: TTextAttributes read FSelAttributes write SetSelAttributes;
  1528.     property PageRect: TRect read FPageRect write FPageRect;
  1529.     property Paragraph: TParaAttributes read FParagraph;
  1530.   end;
  1531.  
  1532.   TRichEdit = class(TCustomRichEdit)
  1533.   published
  1534.     property Align;
  1535.     property Alignment;
  1536.     property Anchors;
  1537.     property BiDiMode;
  1538.     property BorderStyle;
  1539.     property BorderWidth;
  1540.     property Color;
  1541.     property Ctl3D;
  1542.     property DragCursor;
  1543.     property DragKind;
  1544.     property DragMode;
  1545.     property Enabled;
  1546.     property Font;
  1547.     property HideSelection;
  1548.     property HideScrollBars;
  1549.     property ImeMode;
  1550.     property ImeName;
  1551.     property Constraints;
  1552.     property Lines;
  1553.     property MaxLength;
  1554.     property ParentBiDiMode;
  1555.     property ParentColor;
  1556.     property ParentCtl3D;
  1557.     property ParentFont;
  1558.     property ParentShowHint;
  1559.     property PlainText;
  1560.     property PopupMenu;
  1561.     property ReadOnly;
  1562.     property ScrollBars;
  1563.     property ShowHint;
  1564.     property TabOrder;
  1565.     property TabStop default True;
  1566.     property Visible;
  1567.     property WantTabs;
  1568.     property WantReturns;
  1569.     property WordWrap;
  1570.     property OnChange;
  1571.     property OnContextPopup;
  1572.     property OnDragDrop;
  1573.     property OnDragOver;
  1574.     property OnEndDock;
  1575.     property OnEndDrag;
  1576.     property OnEnter;
  1577.     property OnExit;
  1578.     property OnKeyDown;
  1579.     property OnKeyPress;
  1580.     property OnKeyUp;
  1581.     property OnMouseDown;
  1582.     property OnMouseMove;
  1583.     property OnMouseUp;
  1584.     property OnMouseWheel;
  1585.     property OnMouseWheelDown;
  1586.     property OnMouseWheelUp;
  1587.     property OnProtectChange;
  1588.     property OnResizeRequest;
  1589.     property OnSaveClipboard;
  1590.     property OnSelectionChange;
  1591.     property OnStartDock;
  1592.     property OnStartDrag;
  1593.   end;
  1594.  
  1595. { TUpDown }
  1596.  
  1597.   TUDAlignButton = (udLeft, udRight);
  1598.   TUDOrientation = (udHorizontal, udVertical);
  1599.   TUDBtnType = (btNext, btPrev);
  1600.   TUpDownDirection = (updNone, updUp, updDown);
  1601.   TUDClickEvent = procedure (Sender: TObject; Button: TUDBtnType) of object;
  1602.   TUDChangingEvent = procedure (Sender: TObject; var AllowChange: Boolean) of object;
  1603.   TUDChangingEventEx = procedure (Sender: TObject; var AllowChange: Boolean; NewValue: SmallInt; Direction: TUpDownDirection) of object;
  1604.  
  1605.   TCustomUpDown = class(TWinControl)
  1606.   private
  1607.     FArrowKeys: Boolean;
  1608.     FAssociate: TWinControl;
  1609.     FMin: SmallInt;
  1610.     FMax: SmallInt;
  1611.     FIncrement: Integer;
  1612.     FNewValue: SmallInt;
  1613.     FNewValueDelta: SmallInt;
  1614.     FPosition: SmallInt;
  1615.     FThousands: Boolean;
  1616.     FWrap: Boolean;
  1617.     FOnClick: TUDClickEvent;
  1618.     FAlignButton: TUDAlignButton;
  1619.     FOrientation: TUDOrientation;
  1620.     FOnChanging: TUDChangingEvent;
  1621.     FOnChangingEx: TUDChangingEventEx;
  1622.     procedure UndoAutoResizing(Value: TWinControl);
  1623.     procedure SetAssociate(Value: TWinControl);
  1624.     function GetPosition: SmallInt;
  1625.     procedure SetMin(Value: SmallInt);
  1626.     procedure SetMax(Value: SmallInt);
  1627.     procedure SetIncrement(Value: Integer);
  1628.     procedure SetPosition(Value: SmallInt);
  1629.     procedure SetAlignButton(Value: TUDAlignButton);
  1630.     procedure SetOrientation(Value: TUDOrientation);
  1631.     procedure SetArrowKeys(Value: Boolean);
  1632.     procedure SetThousands(Value: Boolean);
  1633.     procedure SetWrap(Value: Boolean);
  1634.     procedure CMAllChildrenFlipped(var Message: TMessage); message CM_ALLCHILDRENFLIPPED;
  1635.     procedure CNNotify(var Message: TWMNotify); message CN_NOTIFY;
  1636.     procedure WMHScroll(var Message: TWMHScroll); message CN_HSCROLL;
  1637.     procedure WMSize(var Message: TWMSize); message WM_SIZE;
  1638.     procedure WMVScroll(var Message: TWMVScroll); message CN_VSCROLL;
  1639.   protected
  1640.     function DoCanChange(NewVal: SmallInt; Delta: SmallInt): Boolean;
  1641.     function CanChange: Boolean; dynamic;
  1642.     procedure CreateParams(var Params: TCreateParams); override;
  1643.     procedure CreateWnd; override;
  1644.     procedure Notification(AComponent: TComponent; Operation: TOperation); override;
  1645.     procedure Click(Button: TUDBtnType); reintroduce; dynamic;
  1646.     property AlignButton: TUDAlignButton read FAlignButton write SetAlignButton default udRight;
  1647.     property ArrowKeys: Boolean read FArrowKeys write SetArrowKeys default True;
  1648.     property Associate: TWinControl read FAssociate write SetAssociate;
  1649.     property Min: SmallInt read FMin write SetMin;
  1650.     property Max: SmallInt read FMax write SetMax default 100;
  1651.     property Increment: Integer read FIncrement write SetIncrement default 1;
  1652.     property Orientation: TUDOrientation read FOrientation write SetOrientation default udVertical;
  1653.     property Position: SmallInt read GetPosition write SetPosition;
  1654.     property Thousands: Boolean read FThousands write SetThousands default True;
  1655.     property Wrap: Boolean read FWrap write SetWrap;
  1656.     property OnChanging: TUDChangingEvent read FOnChanging write FOnChanging;
  1657.     property OnChangingEx: TUDChangingEventEx read FOnChangingEx write FOnChangingEx;    
  1658.     property OnClick: TUDClickEvent read FOnClick write FOnClick;
  1659.   public
  1660.     constructor Create(AOwner: TComponent); override;
  1661.   end;
  1662.  
  1663.   TUpDown = class(TCustomUpDown)
  1664.   published
  1665.     property AlignButton;
  1666.     property Anchors;
  1667.     property Associate;
  1668.     property ArrowKeys;
  1669.     property Enabled;
  1670.     property Hint;
  1671.     property Min;
  1672.     property Max;
  1673.     property Increment;
  1674.     property Constraints;
  1675.     property Orientation;
  1676.     property ParentShowHint;
  1677.     property PopupMenu;
  1678.     property Position;
  1679.     property ShowHint;
  1680.     property TabOrder;
  1681.     property TabStop;
  1682.     property Thousands;
  1683.     property Visible;
  1684.     property Wrap;
  1685.     property OnChanging;
  1686.     property OnChangingEx;
  1687.     property OnContextPopup;
  1688.     property OnClick;
  1689.     property OnEnter;
  1690.     property OnExit;
  1691.     property OnMouseDown;
  1692.     property OnMouseMove;
  1693.     property OnMouseUp;
  1694.   end;
  1695.  
  1696. { THotKey }
  1697.  
  1698.   THKModifier = (hkShift, hkCtrl, hkAlt, hkExt);
  1699.   THKModifiers = set of THKModifier;
  1700.   THKInvalidKey = (hcNone, hcShift, hcCtrl, hcAlt, hcShiftCtrl,
  1701.     hcShiftAlt, hcCtrlAlt, hcShiftCtrlAlt);
  1702.   THKInvalidKeys = set of THKInvalidKey;
  1703.  
  1704.   TCustomHotKey = class(TWinControl)
  1705.   private
  1706.     FAutoSize: Boolean;
  1707.     FModifiers: THKModifiers;
  1708.     FInvalidKeys: THKInvalidKeys;
  1709.     FHotKey: Word;
  1710.     procedure AdjustHeight;
  1711.     procedure SetAutoSize(Value: Boolean);
  1712.     procedure SetInvalidKeys(Value: THKInvalidKeys);
  1713.     procedure SetModifiers(Value: THKModifiers);
  1714.     procedure UpdateHeight;
  1715.     function GetHotKey: TShortCut;
  1716.     procedure SetHotKey(Value: TShortCut);
  1717.     procedure ShortCutToHotKey(Value: TShortCut);
  1718.     function HotKeyToShortCut(Value: Longint): TShortCut;
  1719.   protected
  1720.     procedure CreateParams(var Params: TCreateParams); override;
  1721.     procedure CreateWnd; override;
  1722.     property AutoSize: Boolean read FAutoSize write SetAutoSize default True;
  1723.     property InvalidKeys: THKInvalidKeys read FInvalidKeys write SetInvalidKeys;
  1724.     property Modifiers: THKModifiers read FModifiers write SetModifiers;
  1725.     property HotKey: TShortCut read GetHotKey write SetHotKey;
  1726.     property TabStop default True;
  1727.   public
  1728.     constructor Create(AOwner: TComponent); override;
  1729.   end;
  1730.  
  1731.   THotKey = class(TCustomHotKey)
  1732.   published
  1733.     property Anchors;
  1734.     property AutoSize;
  1735.     property BiDiMode;
  1736.     property Constraints;
  1737.     property Enabled;
  1738.     property Hint;
  1739.     property HotKey;
  1740.     property InvalidKeys;
  1741.     property Modifiers;
  1742.     property ParentBiDiMode;
  1743.     property ParentShowHint;
  1744.     property PopupMenu;
  1745.     property ShowHint;
  1746.     property TabOrder;
  1747.     property TabStop;
  1748.     property Visible;
  1749.     property OnContextPopup;
  1750.     property OnEnter;
  1751.     property OnExit;
  1752.     property OnMouseDown;
  1753.     property OnMouseMove;
  1754.     property OnMouseUp;
  1755.   end;
  1756.  
  1757. const
  1758.   ColumnHeaderWidth = LVSCW_AUTOSIZE_USEHEADER;
  1759.   ColumnTextWidth = LVSCW_AUTOSIZE;
  1760.  
  1761. type
  1762.   TListColumns = class;
  1763.   TListItems = class;
  1764.   TCustomListView = class;
  1765.   TWidth = ColumnHeaderWidth..MaxInt;
  1766.  
  1767.   TListColumn = class(TCollectionItem)
  1768.   private
  1769.     FAlignment: TAlignment;
  1770.     FAutoSize: Boolean;
  1771.     FCaption: string;
  1772.     FMaxWidth: TWidth;
  1773.     FMinWidth: TWidth;
  1774.     FImageIndex: TImageIndex;
  1775.     FPrivateWidth: TWidth;
  1776.     FWidth: TWidth;
  1777.     FOrderTag,
  1778.     FTag: Integer;
  1779.     procedure DoChange;
  1780.     function GetWidth: TWidth;
  1781.     function IsWidthStored: Boolean;
  1782.     procedure ReadData(Reader: TReader);
  1783.     procedure SetAlignment(Value: TAlignment);
  1784.     procedure SetAutoSize(Value: Boolean);
  1785.     procedure SetCaption(const Value: string);
  1786.     procedure SetImageIndex(Value: TImageIndex);
  1787.     procedure SetMaxWidth(Value: TWidth);
  1788.     procedure SetMinWidth(Value: TWidth);
  1789.     procedure SetWidth(Value: TWidth);
  1790.     procedure WriteData(Writer: TWriter);
  1791.   protected
  1792.     procedure DefineProperties(Filer: TFiler); override;
  1793.     function GetDisplayName: string; override;
  1794.     procedure SetIndex(Value: Integer); override;
  1795.   public
  1796.     constructor Create(Collection: TCollection); override;
  1797.     destructor Destroy; override;
  1798.     procedure Assign(Source: TPersistent); override;
  1799.     property WidthType: TWidth read FWidth;
  1800.   published
  1801.     property Alignment: TAlignment read FAlignment write SetAlignment default taLeftJustify;
  1802.     property AutoSize: Boolean read FAutoSize write SetAutoSize default False;
  1803.     property Caption: string read FCaption write SetCaption;
  1804.     property ImageIndex: TImageIndex read FImageIndex write SetImageIndex default -1;
  1805.     property MaxWidth: TWidth read FMaxWidth write SetMaxWidth default 0;
  1806.     property MinWidth: TWidth read FMinWidth write SetMinWidth default 0;
  1807.     property Tag: Integer read FTag write FTag default 0;
  1808.     property Width: TWidth read GetWidth write SetWidth stored IsWidthStored default 50;
  1809.   end;
  1810.  
  1811.   TListColumns = class(TCollection)
  1812.   private
  1813.     FOwner: TCustomListView;
  1814.     function GetItem(Index: Integer): TListColumn;
  1815.     procedure SetItem(Index: Integer; Value: TListColumn);
  1816.     procedure UpdateCols;
  1817.   protected
  1818.     function GetOwner: TPersistent; override;
  1819.     procedure Update(Item: TCollectionItem); override;
  1820.   public
  1821.     constructor Create(AOwner: TCustomListView);
  1822.     function Add: TListColumn;
  1823.     property Owner: TCustomListView read FOwner;
  1824.     property Items[Index: Integer]: TListColumn read GetItem write SetItem; default;
  1825.   end;
  1826.  
  1827.   TDisplayCode = (drBounds, drIcon, drLabel, drSelectBounds);
  1828.  
  1829.   { TListItem }
  1830.  
  1831.   TListItem = class(TPersistent)
  1832.   private
  1833.     FOwner: TListItems;
  1834.     FSubItems: TStrings;
  1835.     FData: Pointer;
  1836.     FImageIndex: TImageIndex;
  1837.     FIndent: Integer;
  1838.     FIndex: Integer;
  1839.     FOverlayIndex: TImageIndex;
  1840.     FStateIndex: TImageIndex;
  1841.     FCaption: string;
  1842.     FDeleting: Boolean;
  1843.     FProcessedDeleting: Boolean;
  1844.     FChecked: Boolean;
  1845.     function GetChecked: Boolean;
  1846.     function GetHandle: HWND;
  1847.     function GetIndex: Integer;
  1848.     function GetListView: TCustomListView;
  1849.     function GetLeft: Integer;
  1850.     function GetState(Index: Integer): Boolean;
  1851.     function GetTop: Integer;
  1852.     function IsEqual(Item: TListItem): Boolean;
  1853.     procedure SetChecked(Value: Boolean);
  1854.     procedure SetCaption(const Value: string);
  1855.     procedure SetData(Value: Pointer);
  1856.     procedure SetImage(Index: Integer; Value: TImageIndex);
  1857.     procedure SetIndent(Value: Integer);
  1858.     procedure SetLeft(Value: Integer);
  1859.     procedure SetState(Index: Integer; State: Boolean);
  1860.     procedure SetSubItems(Value: TStrings);
  1861.     procedure SetTop(Value: Integer);
  1862.     function GetSubItemImage(Index: Integer): Integer;
  1863.     procedure SetSubItemImage(Index: Integer; const Value: Integer);
  1864.   public
  1865.     constructor Create(AOwner: TListItems);
  1866.     destructor Destroy; override;
  1867.     procedure Assign(Source: TPersistent); override;
  1868.     procedure CancelEdit;
  1869.     procedure Delete;
  1870.     function DisplayRect(Code: TDisplayCode): TRect;
  1871.     function EditCaption: Boolean;
  1872.     function GetPosition: TPoint;
  1873.     procedure MakeVisible(PartialOK: Boolean);
  1874.     procedure Update;
  1875.     procedure SetPosition(const Value: TPoint);
  1876.     function WorkArea: Integer;
  1877.     property Caption: string read FCaption write SetCaption;
  1878.     property Checked: Boolean read GetChecked write SetChecked;
  1879.     property Cut: Boolean index 0 read GetState write SetState;
  1880.     property Data: Pointer read FData write SetData;
  1881.     property DropTarget: Boolean index 1 read GetState write SetState;
  1882.     property Focused: Boolean index 2 read GetState write SetState;
  1883.     property Handle: HWND read GetHandle;
  1884.     property ImageIndex: TImageIndex index 0 read FImageIndex write SetImage;
  1885.     property Indent: Integer read FIndent write SetIndent default 0;
  1886.     property Index: Integer read GetIndex;
  1887.     property Left: Integer read GetLeft write SetLeft;
  1888.     property ListView: TCustomListView read GetListView;
  1889.     property Owner: TListItems read FOwner;
  1890.     property OverlayIndex: TImageIndex index 1 read FOverlayIndex write SetImage;
  1891.     property Position: TPoint read GetPosition write SetPosition;
  1892.     property Selected: Boolean index 3 read GetState write SetState;
  1893.     property StateIndex: TImageIndex index 2 read FStateIndex write SetImage;
  1894.     property SubItems: TStrings read FSubItems write SetSubItems;
  1895.     property SubItemImages[Index: Integer]: Integer read GetSubItemImage write SetSubItemImage; 
  1896.     property Top: Integer read GetTop write SetTop;
  1897.   end;
  1898.  
  1899. { TListItems }
  1900.  
  1901.   TListItems = class(TPersistent)
  1902.   private
  1903.     FOwner: TCustomListView;
  1904.     FUpdateCount: Integer;
  1905.     FNoRedraw: Boolean;
  1906.     procedure ReadData(Stream: TStream);
  1907.     procedure WriteData(Stream: TStream);
  1908.   protected
  1909.     procedure DefineProperties(Filer: TFiler); override;
  1910.     function CreateItem(Index: Integer; ListItem: TListItem): TLVItem;
  1911.     function GetCount: Integer;
  1912.     function GetHandle: HWND;
  1913.     function GetItem(Index: Integer): TListItem;
  1914.     procedure SetCount(Value: Integer);
  1915.     procedure SetItem(Index: Integer; Value: TListItem);
  1916.     procedure SetUpdateState(Updating: Boolean);
  1917.   public
  1918.     constructor Create(AOwner: TCustomListView);
  1919.     destructor Destroy; override;
  1920.     function Add: TListItem;
  1921.     procedure Assign(Source: TPersistent); override;
  1922.     procedure BeginUpdate;
  1923.     procedure Clear;
  1924.     procedure Delete(Index: Integer);
  1925.     procedure EndUpdate;
  1926.     function IndexOf(Value: TListItem): Integer;
  1927.     function Insert(Index: Integer): TListItem;
  1928.     property Count: Integer read GetCount write SetCount;
  1929.     property Handle: HWND read GetHandle;
  1930.     property Item[Index: Integer]: TListItem read GetItem write SetItem; default;
  1931.     property Owner: TCustomListView read FOwner;
  1932.   end;
  1933.  
  1934. { TWorkArea }
  1935.  
  1936.   TWorkArea = class(TCollectionItem)
  1937.   private
  1938.     FRect: TRect;
  1939.     FDisplayName: string;
  1940.     FColor: TColor;
  1941.     procedure SetRect(const Value: TRect);
  1942.     procedure SetColor(const Value: TColor);
  1943.   public
  1944.     constructor Create(Collection: TCollection); override;
  1945.     procedure SetDisplayName(const Value: string); override;
  1946.     function  GetDisplayName: string; override;
  1947.     property Rect: TRect read FRect write SetRect;
  1948.     property Color: TColor read FColor write SetColor;
  1949.   end;
  1950.  
  1951. { TWorkAreas }
  1952.  
  1953.   TWorkAreas = class(TOwnedCollection)
  1954.   private
  1955.     function  GetItem(Index: Integer): TWorkArea;
  1956.     procedure SetItem(Index: Integer; const Value: TWorkArea);
  1957.   protected
  1958.     procedure Changed;
  1959.     procedure Update(Item: TCollectionItem); override;
  1960.   public
  1961.     function  Add: TWorkArea;
  1962.     procedure Delete(Index: Integer);
  1963.     function  Insert(Index: Integer): TWorkArea;
  1964.     property  Items[Index: Integer]: TWorkArea read GetItem write SetItem; default;
  1965.   end;
  1966.  
  1967. { TIconOptions }
  1968.  
  1969.   TIconArrangement = (iaTop, iaLeft);
  1970.  
  1971.   TIconOptions = class(TPersistent)
  1972.   private
  1973.     FListView: TCustomListView;
  1974.     FArrangement: TIconArrangement;
  1975.     FAutoArrange: Boolean;
  1976.     FWrapText: Boolean;
  1977.     procedure SetArrangement(Value: TIconArrangement);
  1978.     procedure SetAutoArrange(Value: Boolean);
  1979.     procedure SetWrapText(Value: Boolean);
  1980.   public
  1981.     constructor Create(AOwner: TCustomListView);
  1982.   published
  1983.     property Arrangement: TIconArrangement read FArrangement write SetArrangement default iaTop;
  1984.     property AutoArrange: Boolean read FAutoArrange write SetAutoArrange default False;
  1985.     property WrapText: Boolean read FWrapText write SetWrapText default True;
  1986.   end;
  1987.  
  1988.   TOwnerDrawState = Windows.TOwnerDrawState;
  1989.  
  1990.     (*$NODEFINE TOwnerDrawState*)
  1991.  
  1992.   TListArrangement = (arAlignBottom, arAlignLeft, arAlignRight,
  1993.     arAlignTop, arDefault, arSnapToGrid);
  1994.   TViewStyle = (vsIcon, vsSmallIcon, vsList, vsReport);
  1995.   TItemState = (isNone, isCut, isDropHilited, isFocused, isSelected, isActivating);
  1996.   TItemStates = set of TItemState;
  1997.   TItemChange = (ctText, ctImage, ctState);
  1998.   TItemFind = (ifData, ifPartialString, ifExactString, ifNearest);
  1999.   TSearchDirection = (sdLeft, sdRight, sdAbove, sdBelow, sdAll);
  2000.   TListHotTrackStyle = (htHandPoint, htUnderlineCold, htUnderlineHot);
  2001.   TListHotTrackStyles = set of TListHotTrackStyle;
  2002.   TItemRequests = (irText, irImage, irParam, irState, irIndent);
  2003.   TItemRequest = set of TItemRequests;
  2004.  
  2005.   TLVDeletedEvent = procedure(Sender: TObject; Item: TListItem) of object;
  2006.   TLVEditingEvent = procedure(Sender: TObject; Item: TListItem;
  2007.     var AllowEdit: Boolean) of object;
  2008.   TLVEditedEvent = procedure(Sender: TObject; Item: TListItem; var S: string) of object;
  2009.   TLVChangeEvent = procedure(Sender: TObject; Item: TListItem;
  2010.     Change: TItemChange) of object;
  2011.   TLVChangingEvent = procedure(Sender: TObject; Item: TListItem;
  2012.     Change: TItemChange; var AllowChange: Boolean) of object;
  2013.   TLVColumnClickEvent = procedure(Sender: TObject; Column: TListColumn) of object;
  2014.   TLVColumnRClickEvent = procedure(Sender: TObject; Column: TListColumn;
  2015.     Point: TPoint) of object;
  2016.   TLVCompareEvent = procedure(Sender: TObject; Item1, Item2: TListItem;
  2017.     Data: Integer; var Compare: Integer) of object;
  2018.   TLVNotifyEvent = procedure(Sender: TObject; Item: TListItem) of object;
  2019.   TLVSelectItemEvent = procedure(Sender: TObject; Item: TListItem;
  2020.     Selected: Boolean) of object;
  2021.   TLVDrawItemEvent = procedure(Sender: TCustomListView; Item: TListItem;
  2022.     Rect: TRect; State: TOwnerDrawState) of object;
  2023.   TLVCustomDrawEvent = procedure(Sender: TCustomListView; const ARect: TRect;
  2024.     var DefaultDraw: Boolean) of object;
  2025.   TLVCustomDrawItemEvent = procedure(Sender: TCustomListView; Item: TListItem;
  2026.     State: TCustomDrawState; var DefaultDraw: Boolean) of object;
  2027.   TLVCustomDrawSubItemEvent = procedure(Sender: TCustomListView; Item: TListItem;
  2028.     SubItem: Integer; State: TCustomDrawState; var DefaultDraw: Boolean) of object;
  2029.   TLVAdvancedCustomDrawEvent = procedure(Sender: TCustomListView; const ARect: TRect;
  2030.     Stage: TCustomDrawStage; var DefaultDraw: Boolean) of object;
  2031.   TLVAdvancedCustomDrawItemEvent = procedure(Sender: TCustomListView; Item: TListItem;
  2032.     State: TCustomDrawState; Stage: TCustomDrawStage; var DefaultDraw: Boolean) of object;
  2033.   TLVAdvancedCustomDrawSubItemEvent = procedure(Sender: TCustomListView; Item: TListItem;
  2034.     SubItem: Integer; State: TCustomDrawState; Stage: TCustomDrawStage;
  2035.     var DefaultDraw: Boolean) of object;
  2036.   TLVOwnerDataEvent = procedure(Sender: TObject; Item: TListItem) of object;
  2037.   TLVOwnerDataFindEvent = procedure(Sender: TObject; Find: TItemFind;
  2038.     const FindString: string; const FindPosition: TPoint; FindData: Pointer;
  2039.     StartIndex: Integer; Direction: TSearchDirection; Wrap: Boolean;
  2040.     var Index: Integer) of object;
  2041.   TLVOwnerDataHintEvent = procedure(Sender: TObject; StartIndex, EndIndex: Integer) of object;
  2042.   TLVOwnerDataStateChangeEvent = procedure(Sender: TObject; StartIndex,
  2043.     EndIndex: Integer; OldState, NewState: TItemStates) of object;
  2044.   TLVSubItemImageEvent = procedure(Sender: TObject; Item: TListItem; SubItem: Integer;
  2045.     var ImageIndex: Integer) of object;
  2046.   TLVInfoTipEvent = procedure(Sender: TObject; Item: TListItem; var InfoTip: string) of object;
  2047.  
  2048. { TCustomListView }
  2049.  
  2050.   TCustomListView = class(TWinControl)
  2051.   private
  2052.     FCanvas: TCanvas;
  2053.     FBorderStyle: TBorderStyle;
  2054.     FViewStyle: TViewStyle;
  2055.     FReadOnly: Boolean;
  2056.     FLargeImages: TCustomImageList;
  2057.     FSmallImages: TCustomImageList;
  2058.     FStateImages: TCustomImageList;
  2059.     FDragImage: TDragImageList;
  2060.     FMultiSelect: Boolean;
  2061.     FSortType: TSortType;
  2062.     FColumnClick: Boolean;
  2063.     FShowColumnHeaders: Boolean;
  2064.     FListItems: TListItems;
  2065.     FClicked: Boolean;
  2066.     FRClicked: Boolean;
  2067.     FIconOptions: TIconOptions;
  2068.     FHideSelection: Boolean;
  2069.     FListColumns: TListColumns;
  2070.     FMemStream: TMemoryStream;
  2071.     FOwnerData: Boolean;
  2072.     FOwnerDraw: Boolean;
  2073.     FColStream: TMemoryStream;
  2074.     FCheckStream: TMemoryStream;
  2075.     FEditInstance: Pointer;
  2076.     FDefEditProc: Pointer;
  2077.     FEditHandle: HWND;
  2078.     FHeaderInstance: Pointer;
  2079.     FDefHeaderProc: Pointer;
  2080.     FHeaderHandle: HWND;
  2081.     FAllocBy: Integer;
  2082.     FDragIndex: Integer;
  2083.     FLastDropTarget: TListItem;
  2084.     FCheckboxes: Boolean;
  2085.     FFlatScrollBars: Boolean;
  2086.     FFullDrag: Boolean;
  2087.     FGridLines: Boolean;
  2088.     FHotTrack: Boolean;
  2089.     FHotTrackStyles: TListHotTrackStyles;
  2090.     FRowSelect: Boolean;
  2091.     FLargeChangeLink: TChangeLink;
  2092.     FSmallChangeLink: TChangeLink;
  2093.     FStateChangeLink: TChangeLink;
  2094.     FSavedSort: TSortType;
  2095.     FReading: Boolean;
  2096.     FCanvasChanged: Boolean;
  2097.     FTempItem: TListItem;
  2098.     FWorkAreas: TWorkAreas;
  2099.     FShowWorkAreas: Boolean;
  2100.     FUpdatingColumnOrder: Boolean;
  2101.     FOwnerDataCount: Integer;
  2102.     FOnAdvancedCustomDraw: TLVAdvancedCustomDrawEvent;
  2103.     FOnAdvancedCustomDrawItem: TLVAdvancedCustomDrawItemEvent;
  2104.     FOnAdvancedCustomDrawSubItem: TLVAdvancedCustomDrawSubItemEvent;
  2105.     FOnChange: TLVChangeEvent;
  2106.     FOnChanging: TLVChangingEvent;
  2107.     FOnColumnClick: TLVColumnClickEvent;
  2108.     FOnColumnDragged: TNotifyEvent;
  2109.     FOnColumnRightClick: TLVColumnRClickEvent;
  2110.     FOnCompare: TLVCompareEvent;
  2111.     FOnCustomDraw: TLVCustomDrawEvent;
  2112.     FOnCustomDrawItem: TLVCustomDrawItemEvent;
  2113.     FOnCustomDrawSubItem: TLVCustomDrawSubItemEvent;
  2114.     FOnData: TLVOwnerDataEvent;
  2115.     FOnDataFind: TLVOwnerDataFindEvent;
  2116.     FOnDataHint: TLVOwnerDataHintEvent;
  2117.     FOnDataStateChange: TLVOwnerDataStateChangeEvent;
  2118.     FOnDeletion: TLVDeletedEvent;
  2119.     FOnDrawItem: TLVDrawItemEvent;
  2120.     FOnEdited: TLVEditedEvent;
  2121.     FOnEditing: TLVEditingEvent;
  2122.     FOnGetImageIndex: TLVNotifyEvent;
  2123.     FOnGetSubItemImage: TLVSubItemImageEvent;
  2124.     FOnInfoTip: TLVInfoTipEvent;
  2125.     FOnInsert: TLVDeletedEvent;
  2126.     FOnSelectItem: TLVSelectItemEvent;
  2127.     function AreItemsStored: Boolean;
  2128.     procedure CanvasChanged(Sender: TObject);
  2129.     procedure CMColorChanged(var Message: TMessage); message CM_COLORCHANGED;
  2130.     procedure CMCtl3DChanged(var Message: TMessage); message CM_CTL3DCHANGED;
  2131.     procedure CMDrag(var Message: TCMDrag); message CM_DRAG;
  2132.     procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
  2133.     procedure CNNotify(var Message: TWMNotify); message CN_NOTIFY;
  2134.     procedure DoAutoSize;
  2135.     procedure DoDragOver(Source: TDragObject; X, Y: Integer; CanDrop: Boolean);
  2136.     procedure DrawWorkAreas;
  2137.     procedure EditWndProc(var Message: TMessage);
  2138.     function GetBoundingRect: TRect;
  2139.     function GetColumnFromIndex(Index: Integer): TListColumn;
  2140.     function GetColumnFromTag(Tag: Integer): TListColumn;
  2141.     function GetDropTarget: TListItem;
  2142.     function GetFocused: TListItem;
  2143.     procedure GetImageIndex(Item: TListItem);
  2144.     procedure GetSubItemImage(Item: TListItem; SubItem: Integer; var ImageIndex: Integer);
  2145.     function GetItem(Value: TLVItem): TListItem;
  2146.     function GetSelCount: Integer;
  2147.     function GetSelection: TListItem;
  2148.     function GetTopItem: TListItem;
  2149.     function GetViewOrigin: TPoint;
  2150.     function GetVisibleRowCount: Integer;
  2151.     function GetHoverTime: Integer;
  2152.     procedure HeaderWndProc(var Message: TMessage);
  2153.     procedure ImageListChange(Sender: TObject);
  2154.     procedure RestoreChecks;
  2155.     procedure SaveChecks;
  2156.     procedure SetBorderStyle(Value: TBorderStyle);
  2157.     procedure SetColumnClick(Value: Boolean);
  2158.     procedure SetColumnHeaders(Value: Boolean);
  2159.     procedure SetDropTarget(Value: TListItem);
  2160.     procedure SetFocused(Value: TListItem);
  2161.     procedure SetHideSelection(Value: Boolean);
  2162.     procedure SetIconOptions(Value: TIconOptions);
  2163.     procedure SetImageList(Value: HImageList; Flags: Integer);
  2164.     procedure SetLargeImages(Value: TCustomImageList);
  2165.     procedure SetAllocBy(Value: Integer);
  2166.     procedure SetItems(Value: TListItems);
  2167.     procedure SetListColumns(Value: TListColumns);
  2168.     procedure SetMultiSelect(Value: Boolean);
  2169.     procedure SetOwnerData(Value: Boolean);
  2170.     procedure SetOwnerDraw(Value: Boolean);
  2171.     procedure SetReadOnly(Value: Boolean);
  2172.     procedure SetShowWorkAreas(const Value: Boolean);
  2173.     procedure SetSmallImages(Value: TCustomImageList);
  2174.     procedure SetSortType(Value: TSortType);
  2175.     procedure SetSelection(Value: TListItem);
  2176.     procedure SetStateImages(Value: TCustomImageList);
  2177.     procedure SetTextBkColor(Value: TColor);
  2178.     procedure SetTextColor(Value: TColor);
  2179.     procedure SetViewStyle(Value: TViewStyle);
  2180.     procedure SetCheckboxes(Value: Boolean);
  2181.     procedure SetFlatScrollBars(Value: Boolean);
  2182.     procedure SetFullDrag(Value: Boolean);
  2183.     procedure SetGridLines(Value: Boolean);
  2184.     procedure SetHotTrack(Value: Boolean);
  2185.     procedure SetHotTrackStyles(Value: TListHotTrackStyles);
  2186.     procedure SetRowSelect(Value: Boolean);
  2187.     procedure SetHoverTime(Value: Integer);
  2188.     procedure ResetExStyles;
  2189.     function ValidHeaderHandle: Boolean;
  2190.     procedure WMLButtonDown(var Message: TWMLButtonDown); message WM_LBUTTONDOWN;
  2191.     procedure WMNotify(var Message: TWMNotify); message WM_NOTIFY;
  2192.     procedure WMParentNotify(var Message: TWMParentNotify); message WM_PARENTNOTIFY;
  2193.     procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
  2194.     procedure WMWindowPosChanged(var Message: TWMWindowPosChanged); message WM_WINDOWPOSCHANGED;
  2195.     procedure CNDrawItem(var Message: TWMDrawItem); message CN_DRAWITEM;
  2196.     procedure CMHintShow(var Message: TMessage); message CM_HINTSHOW;
  2197.     procedure WMContextMenu(var Message: TWMContextMenu); message WM_CONTEXTMENU;
  2198.   protected
  2199.     function CanChange(Item: TListItem; Change: Integer): Boolean; dynamic;
  2200.     function CanEdit(Item: TListItem): Boolean; dynamic;
  2201.     procedure Change(Item: TListItem; Change: Integer); dynamic;
  2202.     procedure ChangeScale(M, D: Integer); override;
  2203.     procedure ColClick(Column: TListColumn); dynamic;
  2204.     procedure ColRightClick(Column: TListColumn; Point: TPoint); dynamic;
  2205.     function ColumnsShowing: Boolean;
  2206.     function CreateListItem: TListItem; virtual;
  2207.     procedure CreateParams(var Params: TCreateParams); override;
  2208.     procedure CreateWnd; override;
  2209.     function CustomDraw(const ARect: TRect; Stage: TCustomDrawStage): Boolean; virtual;
  2210.     function CustomDrawItem(Item: TListItem; State: TCustomDrawState;
  2211.       Stage: TCustomDrawStage): Boolean; virtual;
  2212.     function CustomDrawSubItem(Item: TListItem; SubItem: Integer;
  2213.       State: TCustomDrawState; Stage: TCustomDrawStage): Boolean; virtual;
  2214.     procedure Delete(Item: TListItem); dynamic;
  2215.     procedure DestroyWnd; override;
  2216.     procedure DoEndDrag(Target: TObject; X, Y: Integer); override;
  2217.     procedure DoStartDrag(var DragObject: TDragObject); override;
  2218.     procedure DoInfoTip(Item: TListItem; var InfoTip: string); virtual;
  2219.     procedure DrawItem(Item: TListItem; Rect: TRect; State: TOwnerDrawState); virtual;
  2220.     procedure Edit(const Item: TLVItem); dynamic;
  2221.     procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
  2222.     function OwnerDataFetch(Item: TListItem; Request: TItemRequest): Boolean; virtual;
  2223.     function OwnerDataFind(Find: TItemFind; const FindString: string;
  2224.       const FindPosition: TPoint; FindData: Pointer; StartIndex: Integer;
  2225.       Direction: TSearchDirection; Wrap: Boolean): Integer; virtual;
  2226.     function OwnerDataHint(StartIndex, EndIndex: Integer): Boolean; virtual;
  2227.     function OwnerDataStateChange(StartIndex, EndIndex: Integer; OldState,
  2228.       NewState: TItemStates): Boolean; virtual;
  2229.     function GetDragImages: TDragImageList; override;
  2230.     function GetItemIndex(Value: TListItem): Integer;
  2231.     procedure InsertItem(Item: TListItem); dynamic;
  2232.     function IsCustomDrawn(Target: TCustomDrawTarget; Stage: TCustomDrawStage): Boolean;
  2233.     procedure Notification(AComponent: TComponent; Operation: TOperation); override;
  2234.     procedure UpdateColumn(AnIndex: Integer);
  2235.     procedure UpdateColumns;
  2236.     procedure WndProc(var Message: TMessage); override;
  2237.     property BorderStyle: TBorderStyle read FBorderStyle write SetBorderStyle default bsSingle;
  2238.     property Columns: TListColumns read FListColumns write SetListColumns;
  2239.     property ColumnClick: Boolean read FColumnClick write SetColumnClick default True;
  2240.     property ReadOnly: Boolean read FReadOnly write SetReadOnly;
  2241.     property HideSelection: Boolean read FHideSelection write SetHideSelection default True;
  2242.     property IconOptions: TIconOptions read FIconOptions write SetIconOptions;
  2243.     property Items: TListItems read FListItems write SetItems stored AreItemsStored;
  2244.     property AllocBy: Integer read FAllocBy write SetAllocBy default 0;
  2245.     property HoverTime: Integer read GetHoverTime write SetHoverTime default -1;
  2246.     property LargeImages: TCustomImageList read FLargeImages write SetLargeImages;
  2247.     property MultiSelect: Boolean read FMultiSelect write SetMultiSelect default False;
  2248.     property OwnerData: Boolean read FOwnerData write SetOwnerData default False;
  2249.     property OwnerDraw: Boolean read FOwnerDraw write SetOwnerDraw default False;
  2250.     property OnAdvancedCustomDraw: TLVAdvancedCustomDrawEvent read FOnAdvancedCustomDraw write FOnAdvancedCustomDraw;
  2251.     property OnAdvancedCustomDrawItem: TLVAdvancedCustomDrawItemEvent read FOnAdvancedCustomDrawItem write FOnAdvancedCustomDrawItem;
  2252.     property OnAdvancedCustomDrawSubItem: TLVAdvancedCustomDrawSubItemEvent read FOnAdvancedCustomDrawSubItem write FOnAdvancedCustomDrawSubItem;
  2253.     property OnChange: TLVChangeEvent read FOnChange write FOnChange;
  2254.     property OnChanging: TLVChangingEvent read FOnChanging write FOnChanging;
  2255.     property OnColumnClick: TLVColumnClickEvent read FOnColumnClick
  2256.       write FOnColumnClick;
  2257.     property OnColumnDragged: TNotifyEvent read FOnColumnDragged write FOnColumnDragged;
  2258.     property OnColumnRightClick: TLVColumnRClickEvent read FOnColumnRightClick
  2259.       write FOnColumnRightClick;
  2260.     property OnCompare: TLVCompareEvent read FOnCompare write FOnCompare;
  2261.     property OnCustomDraw: TLVCustomDrawEvent read FOnCustomDraw write FOnCustomDraw;
  2262.     property OnCustomDrawItem: TLVCustomDrawItemEvent read FOnCustomDrawItem write FOnCustomDrawItem;
  2263.     property OnCustomDrawSubItem: TLVCustomDrawSubItemEvent read FOnCustomDrawSubItem write FOnCustomDrawSubItem;
  2264.     property OnData: TLVOwnerDataEvent read FOnData write FOnData;
  2265.     property OnDataFind: TLVOwnerDataFindEvent read FOnDataFind write FOnDataFind;
  2266.     property OnDataHint: TLVOwnerDataHintEvent read FOnDataHint write FOnDataHint;
  2267.     property OnDataStateChange: TLVOwnerDataStateChangeEvent read FOnDataStateChange write FOnDataStateChange;
  2268.     property OnDeletion: TLVDeletedEvent read FOnDeletion write FOnDeletion;
  2269.     property OnDrawItem: TLVDrawItemEvent read FOnDrawItem write FOnDrawItem;
  2270.     property OnEdited: TLVEditedEvent read FOnEdited write FOnEdited;
  2271.     property OnEditing: TLVEditingEvent read FOnEditing write FOnEditing;
  2272.     property OnInfoTip: TLVInfoTipEvent read FOnInfoTip write FOnInfoTip;
  2273.     property OnInsert: TLVDeletedEvent read FOnInsert write FOnInsert;
  2274.     property OnGetImageIndex: TLVNotifyEvent read FOnGetImageIndex write FOnGetImageIndex;
  2275.     property OnGetSubItemImage: TLVSubItemImageEvent read FOnGetSubItemImage write FOnGetSubItemImage;
  2276.     property OnSelectItem: TLVSelectItemEvent read FOnSelectItem write FOnSelectItem;
  2277.     property ShowColumnHeaders: Boolean read FShowColumnHeaders write
  2278.       SetColumnHeaders default True;
  2279.     property ShowWorkAreas: Boolean read FShowWorkAreas write SetShowWorkAreas default False;
  2280.     property SmallImages: TCustomImageList read FSmallImages write SetSmallImages;
  2281.     property SortType: TSortType read FSortType write SetSortType default stNone;
  2282.     property StateImages: TCustomImageList read FStateImages write SetStateImages;
  2283.     property ViewStyle: TViewStyle read FViewStyle write SetViewStyle default vsIcon;
  2284.   public
  2285.     constructor Create(AOwner: TComponent); override;
  2286.     destructor Destroy; override;
  2287.     function AlphaSort: Boolean;
  2288.     procedure Arrange(Code: TListArrangement);
  2289.     function FindCaption(StartIndex: Integer; Value: string;
  2290.       Partial, Inclusive, Wrap: Boolean): TListItem;
  2291.     function FindData(StartIndex: Integer; Value: Pointer;
  2292.       Inclusive, Wrap: Boolean): TListItem;
  2293.     function GetHitTestInfoAt(X, Y: Integer): THitTests;
  2294.     function GetItemAt(X, Y: Integer): TListItem;
  2295.     function GetNearestItem(Point: TPoint;
  2296.       Direction: TSearchDirection): TListItem;
  2297.     function GetNextItem(StartItem: TListItem;
  2298.       Direction: TSearchDirection; States: TItemStates): TListItem;
  2299.     function GetSearchString: string;
  2300.     function IsEditing: Boolean;
  2301.     procedure Scroll(DX, DY: Integer);
  2302.     property Canvas: TCanvas read FCanvas;
  2303.     property Checkboxes: Boolean read FCheckboxes write SetCheckboxes default False;
  2304.     property Column[Index: Integer]: TListColumn read GetColumnFromIndex;
  2305.     property DropTarget: TListItem read GetDropTarget write SetDropTarget;
  2306.     property FlatScrollBars: Boolean read FFlatScrollBars write SetFlatScrollBars default False;
  2307.     property FullDrag: Boolean read FFullDrag write SetFullDrag default False;
  2308.     property GridLines: Boolean read FGridLines write SetGridLines default False;
  2309.     property HotTrack: Boolean read FHotTrack write SetHotTrack default False;
  2310.     property HotTrackStyles: TListHotTrackStyles read FHotTrackStyles write SetHotTrackStyles default [];
  2311.     property ItemFocused: TListItem read GetFocused write SetFocused;
  2312.     property RowSelect: Boolean read FRowSelect write SetRowSelect default False;
  2313.     property SelCount: Integer read GetSelCount;
  2314.     property Selected: TListItem read GetSelection write SetSelection;
  2315.     function CustomSort(SortProc: TLVCompare; lParam: Longint): Boolean;
  2316.     function StringWidth(S: string): Integer;
  2317.     procedure UpdateItems(FirstIndex, LastIndex: Integer);
  2318.     property TopItem: TListItem read GetTopItem;
  2319.     property ViewOrigin: TPoint read GetViewOrigin;
  2320.     property VisibleRowCount: Integer read GetVisibleRowCount;
  2321.     property BoundingRect: TRect read GetBoundingRect;
  2322.     property WorkAreas: TWorkAreas read FWorkAreas;
  2323.   end;
  2324.  
  2325. { TListView }
  2326.  
  2327.   TListView = class(TCustomListView)
  2328.   published
  2329.     property Align;
  2330.     property AllocBy;
  2331.     property Anchors;
  2332.     property BiDiMode;
  2333.     property BorderStyle;
  2334.     property BorderWidth;
  2335.     property Checkboxes;
  2336.     property Color;
  2337.     property Columns;
  2338.     property ColumnClick;
  2339.     property Constraints;
  2340.     property Ctl3D;
  2341.     property DragCursor;
  2342.     property DragKind;
  2343.     property DragMode;
  2344.     property Enabled;
  2345.     property Font;
  2346.     property FlatScrollBars;
  2347.     property FullDrag;
  2348.     property GridLines;
  2349.     property HideSelection;
  2350.     property HotTrack;
  2351.     property HotTrackStyles;
  2352.     property HoverTime;
  2353.     property IconOptions;
  2354.     property Items;
  2355.     property LargeImages;
  2356.     property MultiSelect;
  2357.     property OwnerData;
  2358.     property OwnerDraw;
  2359.     property ReadOnly default False;
  2360.     property RowSelect;
  2361.     property ParentBiDiMode;
  2362.     property ParentColor default False;
  2363.     property ParentFont;
  2364.     property ParentShowHint;
  2365.     property PopupMenu;
  2366.     property ShowColumnHeaders;
  2367.     property ShowWorkAreas;
  2368.     property ShowHint;
  2369.     property SmallImages;
  2370.     property SortType;
  2371.     property StateImages;
  2372.     property TabOrder;
  2373.     property TabStop default True;
  2374.     property ViewStyle;
  2375.     property Visible;
  2376.     property OnAdvancedCustomDraw;
  2377.     property OnAdvancedCustomDrawItem;
  2378.     property OnAdvancedCustomDrawSubItem;
  2379.     property OnChange;
  2380.     property OnChanging;
  2381.     property OnClick;
  2382.     property OnColumnClick;
  2383.     property OnColumnDragged;
  2384.     property OnColumnRightClick;
  2385.     property OnCompare;
  2386.     property OnContextPopup;
  2387.     property OnCustomDraw;
  2388.     property OnCustomDrawItem;
  2389.     property OnCustomDrawSubItem;
  2390.     property OnData;
  2391.     property OnDataFind;
  2392.     property OnDataHint;
  2393.     property OnDataStateChange;
  2394.     property OnDblClick;
  2395.     property OnDeletion;
  2396.     property OnDrawItem;
  2397.     property OnEdited;
  2398.     property OnEditing;
  2399.     property OnEndDock;
  2400.     property OnEndDrag;
  2401.     property OnEnter;
  2402.     property OnExit;
  2403.     property OnGetImageIndex;
  2404.     property OnGetSubItemImage;
  2405.     property OnDragDrop;
  2406.     property OnDragOver;
  2407.     property OnInfoTip;
  2408.     property OnInsert;
  2409.     property OnKeyDown;
  2410.     property OnKeyPress;
  2411.     property OnKeyUp;
  2412.     property OnMouseDown;
  2413.     property OnMouseMove;
  2414.     property OnMouseUp;
  2415.     property OnResize;
  2416.     property OnSelectItem;
  2417.     property OnStartDock;
  2418.     property OnStartDrag;
  2419.   end;
  2420.  
  2421. { TAnimate }
  2422.  
  2423.   TCommonAVI = (aviNone, aviFindFolder, aviFindFile, aviFindComputer, aviCopyFiles,
  2424.     aviCopyFile, aviRecycleFile, aviEmptyRecycle, aviDeleteFile);
  2425.  
  2426.   TAnimate = class(TWinControl)
  2427.   private
  2428.     FActive: Boolean;
  2429.     FFileName: string;
  2430.     FCenter: Boolean;
  2431.     FCommonAVI: TCommonAVI;
  2432.     FFrameCount: Integer;
  2433.     FFrameHeight: Integer;
  2434.     FFrameWidth: Integer;
  2435.     FOpen: Boolean;
  2436.     FRecreateNeeded: Boolean;
  2437.     FRepetitions: Integer;
  2438.     FResHandle: THandle;
  2439.     FResId: Integer;
  2440.     FResName: string;
  2441.     FStreamedActive: Boolean;
  2442.     FTimers: Boolean;
  2443.     FTransparent: Boolean;
  2444.     FStartFrame: Smallint;
  2445.     FStopFrame: Smallint;
  2446.     FStopCount: Integer;
  2447.     FOnOpen: TNotifyEvent;
  2448.     FOnClose: TNotifyEvent;
  2449.     FOnStart: TNotifyEvent;
  2450.     FOnStop: TNotifyEvent;
  2451.     procedure CheckOpen;
  2452.     function InternalClose: Boolean;
  2453.     function InternalOpen: Boolean;
  2454.     procedure GetAnimateParams(var Params);
  2455.     function GetActualResHandle: THandle;
  2456.     function GetActualResId: Integer;
  2457.     procedure GetFrameInfo;
  2458.     procedure SetAnimateParams(const Params);
  2459.     procedure SetActive(Value: Boolean);
  2460.     procedure SetFileName(Value: string);
  2461.     procedure SetCenter(Value: Boolean);
  2462.     procedure SetCommonAVI(Value: TCommonAVI);
  2463.     procedure SetOpen(Value: Boolean);
  2464.     procedure SetRepetitions(Value: Integer);
  2465.     procedure SetResHandle(Value: THandle);
  2466.     procedure SetResId(Value: Integer);
  2467.     procedure SetResName(Value: string);
  2468.     procedure SetTimers(Value: Boolean);
  2469.     procedure SetTransparent(Value: Boolean);
  2470.     procedure SetStartFrame(Value: Smallint);
  2471.     procedure SetStopFrame(Value: Smallint);
  2472.     procedure UpdateActiveState;
  2473.     procedure WMNCCalcSize(var Message: TWMNCCalcSize); message WM_NCCALCSIZE;
  2474.     procedure WMNCHitTest(var Message: TWMNCHitTest); message WM_NCHITTEST;
  2475.     procedure WMNCPaint(var Message: TMessage); message WM_NCPAINT;
  2476.     procedure WMSize(var Message: TWMSize); message WM_SIZE;
  2477.     procedure WMWindowPosChanged(var Message: TWMWindowPosChanged); message WM_WINDOWPOSCHANGED;
  2478.     procedure CMColorChanged(var Message: TMessage); message CM_COLORCHANGED;
  2479.     procedure CNCommand(var Message: TWMCommand); message CN_COMMAND;
  2480.   protected
  2481.     function CanAutoSize(var NewWidth, NewHeight: Integer): Boolean; override;
  2482.     procedure CreateParams(var Params: TCreateParams); override;
  2483.     procedure CreateWnd; override;
  2484.     procedure DestroyWnd; override;
  2485.     procedure DoOpen; virtual;
  2486.     procedure DoClose; virtual;
  2487.     procedure DoStart; virtual;
  2488.     procedure DoStop; virtual;
  2489.     procedure Loaded; override;
  2490.   public
  2491.     constructor Create(AOwner: TComponent); override;
  2492.     property FrameCount: Integer read FFrameCount;
  2493.     property FrameHeight: Integer read FFrameHeight;
  2494.     property FrameWidth: Integer read FFrameWidth;
  2495.     property Open: Boolean read FOpen write SetOpen;
  2496.     procedure Play(FromFrame, ToFrame: Word; Count: Integer);
  2497.     procedure Reset;
  2498.     procedure Seek(Frame: Smallint);
  2499.     procedure Stop;
  2500.     property ResHandle: THandle read FResHandle write SetResHandle;
  2501.     property ResId: Integer read FResId write SetResId;
  2502.     property ResName: string read FResName write SetResName;
  2503.   published
  2504.     property Align;
  2505.     property Active: Boolean read FActive write SetActive;
  2506.     property Anchors;
  2507.     property AutoSize default True;
  2508.     property BorderWidth;
  2509.     property Center: Boolean read FCenter write SetCenter default True;
  2510.     property Color;
  2511.     property CommonAVI: TCommonAVI read FCommonAVI write SetCommonAVI default aviNone;
  2512.     property Constraints;
  2513.     property FileName: string read FFileName write SetFileName;
  2514.     property ParentColor;
  2515.     property ParentShowHint;
  2516.     property Repetitions: Integer read FRepetitions write SetRepetitions default 0;
  2517.     property ShowHint;
  2518.     property StartFrame: Smallint read FStartFrame write SetStartFrame default 1;
  2519.     property StopFrame: Smallint read FStopFrame write SetStopFrame default 0;
  2520.     property Timers: Boolean read FTimers write SetTimers default False;
  2521.     property Transparent: Boolean read FTransparent write SetTransparent default True;
  2522.     property Visible;
  2523.     property OnOpen: TNotifyEvent read FOnOpen write FOnOpen;
  2524.     property OnClose: TNotifyEvent read FOnClose write FOnClose;
  2525.     property OnStart: TNotifyEvent read FOnStart write FOnStart;
  2526.     property OnStop: TNotifyEvent read FOnStop write FOnStop;
  2527.   end;
  2528.  
  2529. { TToolBar }
  2530.  
  2531. const
  2532.   CN_DROPDOWNCLOSED = WM_USER + $1000;
  2533.  
  2534. type
  2535.   TToolButtonStyle = (tbsButton, tbsCheck, tbsDropDown, tbsSeparator, tbsDivider);
  2536.  
  2537.   TToolButtonState = (tbsChecked, tbsPressed, tbsEnabled, tbsHidden,
  2538.     tbsIndeterminate, tbsWrap, tbsEllipses, tbsMarked);
  2539.  
  2540.   TToolBar = class;
  2541.   TToolButton = class;
  2542.  
  2543. { TToolButtonActionLink }
  2544.  
  2545.   TToolButtonActionLink = class(TControlActionLink)
  2546.   protected
  2547.     FClient: TToolButton;
  2548.     procedure AssignClient(AClient: TObject); override;
  2549.     function IsCheckedLinked: Boolean; override;
  2550.     function IsImageIndexLinked: Boolean; override;
  2551.     procedure SetChecked(Value: Boolean); override;
  2552.     procedure SetImageIndex(Value: Integer); override;
  2553.   end;
  2554.  
  2555.   TToolButtonActionLinkClass = class of TToolButtonActionLink;
  2556.  
  2557.   TToolButton = class(TGraphicControl)
  2558.   private
  2559.     FAllowAllUp: Boolean;
  2560.     FAutoSize: Boolean;
  2561.     FDown: Boolean;
  2562.     FGrouped: Boolean;
  2563.     FImageIndex: TImageIndex;
  2564.     FIndeterminate: Boolean;
  2565.     FMarked: Boolean;
  2566.     FMenuItem: TMenuItem;
  2567.     FDropdownMenu: TPopupMenu;
  2568.     FWrap: Boolean;
  2569.     FStyle: TToolButtonStyle;
  2570.     FUpdateCount: Integer;
  2571.     function GetButtonState: Byte;
  2572.     function GetIndex: Integer;
  2573.     function IsCheckedStored: Boolean;
  2574.     function IsImageIndexStored: Boolean;
  2575.     function IsWidthStored: Boolean;
  2576.     procedure SetAutoSize(Value: Boolean);
  2577.     procedure SetButtonState(State: Byte);
  2578.     procedure SetDown(Value: Boolean);
  2579.     procedure SetDropdownMenu(Value: TPopupMenu);
  2580.     procedure SetGrouped(Value: Boolean);
  2581.     procedure SetImageIndex(Value: TImageIndex);
  2582.     procedure SetIndeterminate(Value: Boolean);
  2583.     procedure SetMarked(Value: Boolean);
  2584.     procedure SetMenuItem(Value: TMenuItem);
  2585.     procedure SetStyle(Value: TToolButtonStyle);
  2586.     procedure SetWrap(Value: Boolean);
  2587.     procedure CMEnabledChanged(var Message: TMessage); message CM_ENABLEDCHANGED;
  2588.     procedure CMHitTest(var Message: TCMHitTest); message CM_HITTEST;
  2589.     procedure CMTextChanged(var Message: TMessage); message CM_TEXTCHANGED;
  2590.     procedure CMVisibleChanged(var Message: TMessage); message CM_VISIBLECHANGED;
  2591.   protected
  2592.     FToolBar: TToolBar;
  2593.     procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override;
  2594.     procedure AssignTo(Dest: TPersistent); override;
  2595.     procedure BeginUpdate; virtual;
  2596.     procedure EndUpdate; virtual;
  2597.     function GetActionLinkClass: TControlActionLinkClass; override;
  2598.     procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
  2599.     procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
  2600.     procedure MouseUp(Button: TMouseButton; Shift: TShiftState;
  2601.       X, Y: Integer); override;
  2602.     procedure Notification(AComponent: TComponent; Operation: TOperation); override;
  2603.     procedure Paint; override;
  2604.     procedure RefreshControl; virtual;
  2605.     procedure SetToolBar(AToolBar: TToolBar);
  2606.     procedure UpdateControl; virtual;
  2607.     procedure ValidateContainer(AComponent: TComponent); override;
  2608.   public
  2609.     constructor Create(AOwner: TComponent); override;
  2610.     function CheckMenuDropdown: Boolean; dynamic;
  2611.     procedure Click; override;
  2612.     procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override;
  2613.     property Index: Integer read GetIndex;
  2614.   published
  2615.     property Action;
  2616.     property AllowAllUp: Boolean read FAllowAllUp write FAllowAllUp default False;
  2617.     property AutoSize: Boolean read FAutoSize write SetAutoSize default False;
  2618.     property Caption;
  2619.     property Down: Boolean read FDown write SetDown stored IsCheckedStored default False;
  2620.     property DragCursor;
  2621.     property DragKind;
  2622.     property DragMode;
  2623.     property DropdownMenu: TPopupMenu read FDropdownMenu write SetDropdownMenu;
  2624.     property Enabled;
  2625.     property Grouped: Boolean read FGrouped write SetGrouped default False;
  2626.     property Height stored False;
  2627.     property ImageIndex: TImageIndex read FImageIndex write SetImageIndex stored IsImageIndexStored default -1;
  2628.     property Indeterminate: Boolean read FIndeterminate write SetIndeterminate default False;
  2629.     property Marked: Boolean read FMarked write SetMarked default False;
  2630.     property MenuItem: TMenuItem read FMenuItem write SetMenuItem;
  2631.     property ParentShowHint;
  2632.     property PopupMenu;
  2633.     property Wrap: Boolean read FWrap write SetWrap default False;
  2634.     property ShowHint;
  2635.     property Style: TToolButtonStyle read FStyle write SetStyle default tbsButton;
  2636.     property Visible;
  2637.     property Width stored IsWidthStored;
  2638.     property OnClick;
  2639.     property OnContextPopup;
  2640.     property OnDragDrop;
  2641.     property OnDragOver;
  2642.     property OnEndDock;
  2643.     property OnEndDrag;
  2644.     property OnMouseDown;
  2645.     property OnMouseMove;
  2646.     property OnMouseUp;
  2647.     property OnStartDock;
  2648.     property OnStartDrag;
  2649.   end;
  2650.  
  2651.   TTBCustomDrawFlags = set of (tbNoEdges, tbHiliteHotTrack, tbNoOffset,
  2652.     tbNoMark, tbNoEtchedEffect);
  2653.  
  2654.   TTBCustomDrawEvent = procedure(Sender: TToolBar; const ARect: TRect;
  2655.     var DefaultDraw: Boolean) of object;
  2656.   TTBCustomDrawBtnEvent = procedure(Sender: TToolBar; Button: TToolButton;
  2657.     State: TCustomDrawState; var DefaultDraw: Boolean) of object;
  2658.   TTBAdvancedCustomDrawEvent = procedure(Sender: TToolBar; const ARect: TRect;
  2659.     Stage: TCustomDrawStage; var DefaultDraw: Boolean) of object;
  2660.   TTBAdvancedCustomDrawBtnEvent = procedure(Sender: TToolBar; Button: TToolButton;
  2661.     State: TCustomDrawState; Stage: TCustomDrawStage;
  2662.     var Flags: TTBCustomDrawFlags; var DefaultDraw: Boolean) of object;
  2663.  
  2664.   TToolBar = class(TToolWindow)
  2665.   private
  2666.     FButtonWidth: Integer;
  2667.     FButtonHeight: Integer;
  2668.     FButtons: TList;
  2669.     FCaption: string;
  2670.     FCanvas: TCanvas;
  2671.     FCanvasChanged: Boolean;
  2672.     FShowCaptions: Boolean;
  2673.     FList: Boolean;
  2674.     FFlat: Boolean;
  2675.     FTransparent: Boolean;
  2676.     FWrapable: Boolean;
  2677.     FImages: TCustomImageList;
  2678.     FImageChangeLink: TChangeLink;
  2679.     FDisabledImages: TCustomImageList;
  2680.     FDisabledImageChangeLink: TChangeLink;
  2681.     FHotImages: TCustomImageList;
  2682.     FHotImageChangeLink: TChangeLink;
  2683.     FIndent: Integer;
  2684.     FNewStyle: Boolean;
  2685.     FNullBitmap: TBitmap;
  2686.     FOldHandle: HBitmap;
  2687.     FUpdateCount: Integer;
  2688.     FHeightMargin: Integer;
  2689.     FOnAdvancedCustomDraw: TTBAdvancedCustomDrawEvent;
  2690.     FOnAdvancedCustomDrawButton: TTBAdvancedCustomDrawBtnEvent;
  2691.     FOnCustomDraw: TTBCustomDrawEvent;
  2692.     FOnCustomDrawButton: TTBCustomDrawBtnEvent;
  2693.     { Toolbar menu support }
  2694.     FCaptureChangeCancels: Boolean;
  2695.     FInMenuLoop: Boolean;
  2696.     FTempMenu: TPopupMenu;
  2697.     FButtonMenu: TMenuItem;
  2698.     FMenuButton: TToolButton;
  2699.     FMenuResult: Boolean;
  2700.     FMenuDropped: Boolean;
  2701.     function ButtonIndex(OldIndex, ALeft, ATop: Integer): Integer;
  2702.     procedure CanvasChanged(Sender: TObject);
  2703.     procedure LoadImages(AImages: TCustomImageList);
  2704.     function GetButton(Index: Integer): TToolButton;
  2705.     function GetButtonCount: Integer;
  2706.     procedure GetButtonSize(var AWidth, AHeight: Integer);
  2707.     function GetRowCount: Integer;
  2708.     procedure SetList(Value: Boolean);
  2709.     procedure SetShowCaptions(Value: Boolean);
  2710.     procedure SetFlat(Value: Boolean);
  2711.     procedure SetTransparent(Value: Boolean);
  2712.     procedure SetWrapable(Value: Boolean);
  2713.     procedure InsertButton(Control: TControl);
  2714.     procedure RemoveButton(Control: TControl);
  2715.     function RefreshButton(Index: Integer): Boolean;
  2716.     procedure UpdateButton(Index: Integer);
  2717.     procedure UpdateButtons;
  2718.     procedure UpdateButtonState(Index: Integer);
  2719.     procedure UpdateButtonStates;
  2720.     function UpdateItem(Message, FromIndex, ToIndex: Integer): Boolean;
  2721.     function UpdateItem2(Message, FromIndex, ToIndex: Integer): Boolean;
  2722.     procedure ClearTempMenu;
  2723.     procedure CreateButtons(NewWidth, NewHeight: Integer);
  2724.     procedure SetButtonWidth(Value: Integer);
  2725.     procedure SetButtonHeight(Value: Integer);
  2726.     procedure UpdateImages;
  2727.     procedure ImageListChange(Sender: TObject);
  2728.     procedure SetImageList(Value: HImageList);
  2729.     procedure SetImages(Value: TCustomImageList);
  2730.     procedure DisabledImageListChange(Sender: TObject);
  2731.     procedure SetDisabledImageList(Value: HImageList);
  2732.     procedure SetDisabledImages(Value: TCustomImageList);
  2733.     procedure HotImageListChange(Sender: TObject);
  2734.     procedure SetHotImageList(Value: HImageList);
  2735.     procedure SetHotImages(Value: TCustomImageList);
  2736.     procedure SetIndent(Value: Integer);
  2737.     procedure AdjustControl(Control: TControl);
  2738.     procedure RecreateButtons;
  2739.     procedure BeginUpdate;
  2740.     procedure EndUpdate;
  2741.     procedure ResizeButtons;
  2742.     function InternalButtonCount: Integer;
  2743.     function ReorderButton(OldIndex, ALeft, ATop: Integer): Integer;
  2744.     procedure WMCaptureChanged(var Message: TMessage); message WM_CAPTURECHANGED;
  2745.     procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND;
  2746.     procedure WMGetDlgCode(var Message: TMessage); message WM_GETDLGCODE;
  2747.     procedure WMGetText(var Message: TWMGetText); message WM_GETTEXT;
  2748.     procedure WMGetTextLength(var Message: TWMGetTextLength); message WM_GETTEXTLENGTH;
  2749.     procedure WMKeyDown(var Message: TWMKeyDown); message WM_KEYDOWN;
  2750.     procedure WMNotifyFormat(var Message: TMessage); message WM_NOTIFYFORMAT;
  2751.     procedure WMSetText(var Message: TWMSetText); message WM_SETTEXT;
  2752.     procedure WMSize(var Message: TWMSize); message WM_SIZE;
  2753.     procedure WMSysChar(var Message: TWMSysChar); message WM_SYSCHAR;
  2754.     procedure WMSysCommand(var Message: TWMSysCommand); message WM_SYSCOMMAND;
  2755.     procedure WMWindowPosChanged(var Message: TWMWindowPosChanged); message WM_WINDOWPOSCHANGED;
  2756.     procedure WMWindowPosChanging(var Message: TWMWindowPosChanging); message WM_WINDOWPOSCHANGING;
  2757.     procedure CMColorChanged(var Message: TMessage); message CM_COLORCHANGED;
  2758.     procedure CMControlChange(var Message: TCMControlChange); message CM_CONTROLCHANGE;
  2759.     procedure CMDialogChar(var Message: TCMDialogChar); message CM_DIALOGCHAR;
  2760.     procedure CMEnabledChanged(var Message: TMessage); message CM_ENABLEDCHANGED;
  2761.     procedure CMFontChanged(var Message); message CM_FONTCHANGED;
  2762.     procedure CMParentColorChanged(var Message: TMessage); message CM_PARENTCOLORCHANGED;
  2763.     procedure CNChar(var Message: TWMChar); message CN_CHAR;
  2764.     procedure CNSysKeyDown(var Message: TWMSysKeyDown); message CN_SYSKEYDOWN;
  2765.     procedure CMSysFontChanged(var Message: TMessage); message CM_SYSFONTCHANGED;
  2766.     procedure CNDropDownClosed(var Message: TMessage); message CN_DROPDOWNCLOSED;
  2767.     procedure CNNotify(var Message: TWMNotify); message CN_NOTIFY;
  2768.   protected
  2769.     procedure AlignControls(AControl: TControl; var Rect: TRect); override;
  2770.     function CanAutoSize(var NewWidth, NewHeight: Integer): Boolean; override;
  2771.     procedure CancelMenu; dynamic;
  2772.     procedure ChangeScale(M, D: Integer); override;
  2773.     function CheckMenuDropdown(Button: TToolButton): Boolean; dynamic;
  2774.     procedure ClickButton(Button: TToolButton); dynamic;
  2775.     procedure CreateParams(var Params: TCreateParams); override;
  2776.     procedure CreateWnd; override;
  2777.     function  CustomDraw(const ARect: TRect; Stage: TCustomDrawStage): Boolean; virtual;
  2778.     function CustomDrawButton(Button: TToolButton; State: TCustomDrawState;
  2779.       Stage: TCustomDrawStage; var Flags: TTBCustomDrawFlags): Boolean; virtual;
  2780.     function FindButtonFromAccel(Accel: Word): TToolButton;
  2781.     procedure GetChildren(Proc: TGetChildProc; Root: TComponent); override;
  2782.     procedure InitMenu(Button: TToolButton); dynamic;
  2783.     function IsCustomDrawn(Target: TCustomDrawTarget; Stage: TCustomDrawStage): Boolean;
  2784.     procedure Loaded; override;
  2785.     procedure Notification(AComponent: TComponent;
  2786.       Operation: TOperation); override;
  2787.     procedure RepositionButton(Index: Integer);
  2788.     procedure RepositionButtons(Index: Integer);
  2789.     procedure WndProc(var Message: TMessage); override;
  2790.     function WrapButtons(var NewWidth, NewHeight: Integer): Boolean;
  2791.   public
  2792.     constructor Create(AOwner: TComponent); override;
  2793.     destructor Destroy; override;
  2794.     procedure FlipChildren(AllLevels: Boolean); override;
  2795.     function TrackMenu(Button: TToolButton): Boolean; dynamic;
  2796.     property ButtonCount: Integer read GetButtonCount;
  2797.     property Buttons[Index: Integer]: TToolButton read GetButton;
  2798.     property Canvas: TCanvas read FCanvas;
  2799.     property RowCount: Integer read GetRowCount;
  2800.   published
  2801.     property Align default alTop;
  2802.     property Anchors;
  2803.     property AutoSize;
  2804.     property BorderWidth;
  2805.     property ButtonHeight: Integer read FButtonHeight write SetButtonHeight default 22;
  2806.     property ButtonWidth: Integer read FButtonWidth write SetButtonWidth default 23;
  2807.     property Caption;
  2808.     property Color;
  2809.     property Constraints;
  2810.     property Ctl3D;
  2811.     property DisabledImages: TCustomImageList read FDisabledImages write SetDisabledImages;
  2812.     property DockSite;
  2813.     property DragCursor;
  2814.     property DragKind;
  2815.     property DragMode;
  2816.     property EdgeBorders default [ebTop];
  2817.     property EdgeInner;
  2818.     property EdgeOuter;
  2819.     property Enabled;
  2820.     property Flat: Boolean read FFlat write SetFlat default False;
  2821.     property Font;
  2822.     property Height default 32;
  2823.     property HotImages: TCustomImageList read FHotImages write SetHotImages;
  2824.     property Images: TCustomImageList read FImages write SetImages;
  2825.     property Indent: Integer read FIndent write SetIndent default 0;
  2826.     property List: Boolean read FList write SetList default False;
  2827.     property ParentColor;
  2828.     property ParentFont;
  2829.     property ParentShowHint;
  2830.     property PopupMenu;
  2831.     property ShowCaptions: Boolean read FShowCaptions write SetShowCaptions default False;
  2832.     property ShowHint;
  2833.     property TabOrder;
  2834.     property TabStop;
  2835.     property Transparent: Boolean read FTransparent write SetTransparent default False;
  2836.     property Visible;
  2837.     property Wrapable: Boolean read FWrapable write SetWrapable default True;
  2838.     property OnAdvancedCustomDraw: TTBAdvancedCustomDrawEvent
  2839.       read FOnAdvancedCustomDraw write FOnAdvancedCustomDraw;
  2840.     property OnAdvancedCustomDrawButton: TTBAdvancedCustomDrawBtnEvent
  2841.       read FOnAdvancedCustomDrawButton write FOnAdvancedCustomDrawButton;
  2842.     property OnClick;
  2843.     property OnContextPopup;
  2844.     property OnCustomDraw: TTBCustomDrawEvent read FOnCustomDraw write FOnCustomDraw;
  2845.     property OnCustomDrawButton: TTBCustomDrawBtnEvent read FOnCustomDrawButton
  2846.       write FOnCustomDrawButton;
  2847.     property OnDblClick;
  2848.     property OnDockDrop;
  2849.     property OnDockOver;
  2850.     property OnDragDrop;
  2851.     property OnDragOver;
  2852.     property OnEndDock;
  2853.     property OnEndDrag;
  2854.     property OnEnter;
  2855.     property OnExit;
  2856.     property OnGetSiteInfo;
  2857.     property OnMouseDown;
  2858.     property OnMouseMove;
  2859.     property OnMouseUp;
  2860.     property OnResize;
  2861.     property OnStartDock;
  2862.     property OnStartDrag;
  2863.     property OnUnDock;
  2864.   end;
  2865.  
  2866.   TToolBarDockObject = class(TDragDockObject)
  2867.   private
  2868.     FEraseDockRect: TRect;
  2869.     FErase: Boolean;
  2870.   protected
  2871.     procedure AdjustDockRect(ARect: TRect); override;
  2872.     procedure DrawDragDockImage; override;
  2873.     procedure EraseDragDockImage; override;
  2874.     function GetDragCursor(Accepted: Boolean; X, Y: Integer): TCursor; override;
  2875.     function ToolDockImage(Erase: Boolean): Boolean; virtual;
  2876.   end;
  2877.  
  2878. { TCoolBar }
  2879.  
  2880. const
  2881.   CN_BANDCHANGE = WM_USER + $1000;
  2882.  
  2883. type
  2884.   TCoolBar = class;
  2885.  
  2886.   TCoolBand = class(TCollectionItem)
  2887.   private
  2888.     FBorderStyle: TBorderStyle;
  2889.     FBreak: Boolean;
  2890.     FFixedSize: Boolean;
  2891.     FVisible: Boolean;
  2892.     FHorizontalOnly: Boolean;
  2893.     FImageIndex: TImageIndex;
  2894.     FFixedBackground: Boolean;
  2895.     FMinHeight: Integer;
  2896.     FMinWidth: Integer;
  2897.     FColor: TColor;
  2898.     FControl: TWinControl;
  2899.     FParentColor: Boolean;
  2900.     FParentBitmap: Boolean;
  2901.     FBitmap: TBitmap;
  2902.     FText: string;
  2903.     FWidth: Integer;
  2904.     FDDB: TBitmap;
  2905.     FID: Integer;
  2906.     function CoolBar: TCoolBar;
  2907.     function IsColorStored: Boolean;
  2908.     function IsBitmapStored: Boolean;
  2909.     procedure BitmapChanged(Sender: TObject);
  2910.     function GetHeight: Integer;
  2911.     function GetVisible: Boolean;
  2912.     procedure SetBorderStyle(Value: TBorderStyle);
  2913.     procedure SetBreak(Value: Boolean);
  2914.     procedure SetFixedSize(Value: Boolean);
  2915.     procedure SetMinHeight(Value: Integer);
  2916.     procedure SetMinWidth(Value: Integer);
  2917.     procedure SetVisible(Value: Boolean);
  2918.     procedure SetHorizontalOnly(Value: Boolean);
  2919.     procedure SetImageIndex(Value: TImageIndex);
  2920.     procedure SetFixedBackground(Value: Boolean);
  2921.     procedure SetColor(Value: TColor);
  2922.     procedure SetControl(Value: TWinControl);
  2923.     procedure SetParentColor(Value: Boolean);
  2924.     procedure SetParentBitmap(Value: Boolean);
  2925.     procedure SetBitmap(Value: TBitmap);
  2926.     procedure SetText(const Value: string);
  2927.     procedure SetWidth(Value: Integer);
  2928.   protected
  2929.     function GetDisplayName: string; override;
  2930.     procedure ParentColorChanged; dynamic;
  2931.     procedure ParentBitmapChanged; dynamic;
  2932.   public
  2933.     constructor Create(Collection: TCollection); override;
  2934.     destructor Destroy; override;
  2935.     procedure Assign(Source: TPersistent); override;
  2936.     property Height: Integer read GetHeight;
  2937.   published
  2938.     property Bitmap: TBitmap read FBitmap write SetBitmap stored IsBitmapStored;
  2939.     property BorderStyle: TBorderStyle read FBorderStyle write SetBorderStyle default bsNone;
  2940.     property Break: Boolean read FBreak write SetBreak default True;
  2941.     property Color: TColor read FColor write SetColor stored IsColorStored default clBtnFace;
  2942.     property Control: TWinControl read FControl write SetControl;
  2943.     property FixedBackground: Boolean read FFixedBackground write SetFixedBackground default True;
  2944.     property FixedSize: Boolean read FFixedSize write SetFixedSize default False;
  2945.     property HorizontalOnly: Boolean read FHorizontalOnly write SetHorizontalOnly default False;
  2946.     property ImageIndex: TImageIndex read FImageIndex write SetImageIndex;
  2947.     property MinHeight: Integer read FMinHeight write SetMinHeight default 25;
  2948.     property MinWidth: Integer read FMinWidth write SetMinWidth default 0;
  2949.     property ParentColor: Boolean read FParentColor write SetParentColor default True;
  2950.     property ParentBitmap: Boolean read FParentBitmap write SetParentBitmap default True;
  2951.     property Text: string read FText write SetText;
  2952.     property Visible: Boolean read GetVisible write SetVisible default True;
  2953.     property Width: Integer read FWidth write SetWidth;
  2954.   end;
  2955.  
  2956.   TCoolBands = class(TCollection)
  2957.   private
  2958.     FCoolBar: TCoolBar;
  2959.     FVisibleCount: Longword;
  2960.     function GetItem(Index: Integer): TCoolBand;
  2961.     procedure SetItem(Index: Integer; Value: TCoolBand);
  2962.   protected
  2963.     function GetOwner: TPersistent; override;
  2964.     procedure Update(Item: TCollectionItem); override;
  2965.     function HaveGraphic: Boolean;
  2966.   public
  2967.     constructor Create(CoolBar: TCoolBar);
  2968.     function Add: TCoolBand;
  2969.     function FindBand(AControl: TControl): TCoolBand;
  2970.     property CoolBar: TCoolBar read FCoolBar;
  2971.     property Items[Index: Integer]: TCoolBand read GetItem write SetItem; default;
  2972.   end;
  2973.  
  2974.   TCoolBandMaximize = (bmNone, bmClick, bmDblClick);
  2975.  
  2976.   TCoolBar = class(TToolWindow)
  2977.   private
  2978.     FBands: TCoolBands;
  2979.     FBandBorderStyle: TBorderStyle;
  2980.     FBandMaximize: TCoolBandMaximize;
  2981.     FBitmap: TBitmap;
  2982.     FCaptionFont: TFont;
  2983.     FCaptionFontHeight: Integer;
  2984.     FDDB: TBitmap;
  2985.     FFixedSize: Boolean;
  2986.     FFixedOrder: Boolean;
  2987.     FImages: TCustomImageList;
  2988.     FImageChangeLink: TChangeLink;
  2989.     FShowText: Boolean;
  2990.     FVertical: Boolean;
  2991.     FTrackDrag: TSmallPoint;
  2992.     FUpdateCount: Integer;
  2993.     FOnChange: TNotifyEvent;
  2994.     procedure BeginUpdate;
  2995.     procedure BitmapChanged(Sender: TObject);
  2996.     procedure EndUpdate;
  2997.     function IsAutoSized: Boolean;
  2998.     function IsBackgroundDirty: Boolean;
  2999.     function GetAlign: TAlign;
  3000.     function GetCaptionFont: HFONT;
  3001.     function GetCaptionFontHeight: Integer;
  3002.     function GetCaptionSize(Band: TCoolBand): Integer;
  3003.     function GetRowHeight(Index: Integer): Integer;
  3004.     procedure RefreshControl(Band: TCoolBand);
  3005.     procedure SetAlign(Value: TAlign);
  3006.     procedure SetBands(Value: TCoolBands);
  3007.     procedure SetBandBorderStyle(Value: TBorderStyle);
  3008.     procedure SetBandMaximize(Value: TCoolBandMaximize);
  3009.     procedure SetBitmap(Value: TBitmap);
  3010.     procedure SetFixedSize(Value: Boolean);
  3011.     procedure SetFixedOrder(Value: Boolean);
  3012.     procedure SetImageList(Value: HImageList);
  3013.     procedure SetImages(Value: TCustomImageList);
  3014.     procedure SetShowText(Value: Boolean);
  3015.     procedure SetVertical(Value: Boolean);
  3016.     procedure ImageListChange(Sender: TObject);
  3017.     function PtInGripRect(const Pos: TPoint; var Band: TCoolBand): Integer;
  3018.     function ReadBands: Boolean;
  3019.     function UpdateItem(Message, FromIndex, ToIndex: Integer): Boolean;
  3020.     procedure UpdateBand(Index: Integer);
  3021.     procedure UpdateBands;
  3022.     procedure WMCaptureChanged(var Message: TMessage); message WM_CAPTURECHANGED;
  3023.     procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND;
  3024.     procedure WMLButtonDown(var Message: TWMLButtonDown); message WM_LBUTTONDOWN;
  3025.     procedure WMLButtonUp(var Message: TWMLButtonUp); message WM_LBUTTONUP;
  3026.     procedure WMNotifyFormat(var Message: TMessage); message WM_NOTIFYFORMAT;
  3027.     procedure WMSetCursor(var Message: TWMSetCursor); message WM_SETCURSOR;
  3028.     procedure WMSize(var Message: TWMSize); message WM_SIZE;
  3029.     procedure CMColorChanged(var Message: TMessage); message CM_COLORCHANGED;
  3030.     procedure CMControlChange(var Message: TCMControlChange); message CM_CONTROLCHANGE;
  3031.     procedure CMDesignHitTest(var Message: TCMDesignHitTest); message CM_DESIGNHITTEST;
  3032.     procedure CNBandChange(var Message: TMessage); message CN_BANDCHANGE;
  3033.     procedure CNNotify(var Message: TWMNotify); message CN_NOTIFY;
  3034.     procedure CMSysColorChange(var Message: TMessage); message CM_SYSCOLORCHANGE;
  3035.     procedure CMSysFontChanged(var Message: TMessage); message CM_SYSFONTCHANGED;
  3036.     procedure CMWinIniChange(var Message: TWMWinIniChange); message CM_WININICHANGE;
  3037.   protected
  3038.     procedure AlignControls(AControl: TControl; var Rect: TRect); override;
  3039.     function CanAutoSize(var NewWidth, NewHeight: Integer): Boolean; override;
  3040.     procedure Change; dynamic;
  3041.     procedure CreateParams(var Params: TCreateParams); override;
  3042.     procedure CreateWnd; override;
  3043.     function GetPalette: HPALETTE; override;
  3044.     function HitTest(const Pos: TPoint): TCoolBand;
  3045.     procedure Loaded; override;
  3046.     procedure Notification(AComponent: TComponent; Operation: TOperation); override;
  3047.     procedure WndProc(var Message: TMessage); override;
  3048.     procedure PaintWindow(DC: HDC); override;
  3049.   public
  3050.     constructor Create(AOwner: TComponent); override;
  3051.     destructor Destroy; override;
  3052.     procedure FlipChildren(AllLevels: Boolean); override;
  3053.   published
  3054.     property Align read GetAlign write SetAlign default alTop;
  3055.     property Anchors;
  3056.     property AutoSize;
  3057.     property BandBorderStyle: TBorderStyle read FBandBorderStyle write SetBandBorderStyle default bsSingle;
  3058.     property BandMaximize: TCoolBandMaximize read FBandMaximize write SetBandMaximize default bmClick;
  3059.     property Bands: TCoolBands read FBands write SetBands;
  3060.     property BorderWidth;
  3061.     property Color;
  3062.     property Constraints;
  3063.     property Ctl3D;
  3064.     property DockSite;
  3065.     property DragCursor;
  3066.     property DragKind;
  3067.     property DragMode;
  3068.     property EdgeBorders;
  3069.     property EdgeInner;
  3070.     property EdgeOuter;
  3071.     property Enabled;
  3072.     property FixedSize: Boolean read FFixedSize write SetFixedSize default False;
  3073.     property FixedOrder: Boolean read FFixedOrder write SetFixedOrder default False;
  3074.     property Font;
  3075.     property Images: TCustomImageList read FImages write SetImages;
  3076.     property ParentColor;
  3077.     property ParentFont;
  3078.     property ParentShowHint;
  3079.     property Bitmap: TBitmap read FBitmap write SetBitmap;
  3080.     property PopupMenu;
  3081.     property ShowHint;
  3082.     property ShowText: Boolean read FShowText write SetShowText default True;
  3083.     property Vertical: Boolean read FVertical write SetVertical default False;
  3084.     property Visible;
  3085.     property OnChange: TNotifyEvent read FOnChange write FOnChange;
  3086.     property OnClick;
  3087.     property OnContextPopup;
  3088.     property OnDblClick;
  3089.     property OnDockDrop;
  3090.     property OnDockOver;
  3091.     property OnDragDrop;
  3092.     property OnDragOver;
  3093.     property OnEndDock;
  3094.     property OnEndDrag;
  3095.     property OnGetSiteInfo;
  3096.     property OnMouseDown;
  3097.     property OnMouseMove;
  3098.     property OnMouseUp;
  3099.     property OnResize;
  3100.     property OnStartDock;
  3101.     property OnStartDrag;
  3102.     property OnUnDock;
  3103.   end;
  3104.  
  3105. { Calendar common control support }
  3106.  
  3107.   TCommonCalendar = class;
  3108.  
  3109.   ECommonCalendarError = class(Exception);
  3110.  
  3111.   TMonthCalColors = class(TPersistent)
  3112.   private
  3113.     Owner: TCommonCalendar;
  3114.     FBackColor: TColor;
  3115.     FTextColor: TColor;
  3116.     FTitleBackColor: TColor;
  3117.     FTitleTextColor: TColor;
  3118.     FMonthBackColor: TColor;
  3119.     FTrailingTextColor: TColor;
  3120.     procedure SetColor(Index: Integer; Value: TColor);
  3121.     procedure SetAllColors;
  3122.   public
  3123.     constructor Create(AOwner: TCommonCalendar);
  3124.     procedure Assign(Source: TPersistent); override;
  3125.   published
  3126.     property BackColor: TColor index 0 read FBackColor write SetColor default clWindow;
  3127.     property TextColor: TColor index 1 read FTextColor write SetColor default clWindowText;
  3128.     property TitleBackColor: TColor index 2 read FTitleBackColor write SetColor default clActiveCaption;
  3129.     property TitleTextColor: TColor index 3 read FTitleTextColor write SetColor default clWhite;
  3130.     property MonthBackColor: TColor index 4 read FMonthBackColor write SetColor default clWhite;
  3131.     property TrailingTextColor: TColor index 5 read FTrailingTextColor
  3132.       write SetColor default clInactiveCaptionText;
  3133.   end;
  3134.  
  3135.   TCalDayOfWeek = (dowMonday, dowTuesday, dowWednesday, dowThursday,
  3136.     dowFriday, dowSaturday, dowSunday, dowLocaleDefault);
  3137.  
  3138.   TOnGetMonthInfoEvent = procedure(Sender: TObject; Month: LongWord;
  3139.     var MonthBoldInfo: LongWord) of object;
  3140.  
  3141.   TCommonCalendar = class(TWinControl)
  3142.   private
  3143.     FCalColors: TMonthCalColors;
  3144.     FCalExceptionClass: ExceptClass;
  3145.     FDateTime: TDateTime;
  3146.     FEndDate: TDate;
  3147.     FFirstDayOfWeek: TCalDayOfWeek;
  3148.     FMaxDate: TDate;
  3149.     FMaxSelectRange: Integer;
  3150.     FMinDate: TDate;
  3151.     FMonthDelta: Integer;
  3152.     FMultiSelect: Boolean;
  3153.     FShowToday: Boolean;
  3154.     FShowTodayCircle: Boolean;
  3155.     FWeekNumbers: Boolean;
  3156.     FOnGetMonthInfo: TOnGetMonthInfoEvent;
  3157.     function DoStoreEndDate: Boolean;
  3158.     function DoStoreMaxDate: Boolean;
  3159.     function DoStoreMinDate: Boolean;
  3160.     function GetDate: TDate;
  3161.     procedure SetCalColors(Value: TMonthCalColors);
  3162.     procedure SetDate(Value: TDate);
  3163.     procedure SetDateTime(Value: TDateTime);
  3164.     procedure SetEndDate(Value: TDate);
  3165.     procedure SetFirstDayOfWeek(Value: TCalDayOfWeek);
  3166.     procedure SetMaxDate(Value: TDate);
  3167.     procedure SetMaxSelectRange(Value: Integer);
  3168.     procedure SetMinDate(Value: TDate);
  3169.     procedure SetMonthDelta(Value: Integer);
  3170.     procedure SetMultiSelect(Value: Boolean);
  3171.     procedure SetRange(MinVal, MaxVal: TDate);
  3172.     procedure SetSelectedRange(Date, EndDate: TDate);
  3173.     procedure SetShowToday(Value: Boolean);
  3174.     procedure SetShowTodayCircle(Value: Boolean);
  3175.     procedure SetWeekNumbers(Value: Boolean);
  3176.   protected
  3177.     procedure CheckEmptyDate; virtual;
  3178.     procedure CheckValidDate(Value: TDate); virtual;
  3179.     procedure CreateWnd; override;
  3180.     function GetCalendarHandle: HWND; virtual; abstract;
  3181.     function GetCalStyles: DWORD; virtual;
  3182.     function MsgSetCalColors(ColorIndex: Integer; ColorValue: TColor): Boolean; virtual; abstract;
  3183.     function MsgSetDateTime(Value: TSystemTime): Boolean; virtual; abstract;
  3184.     function MsgSetRange(Flags: Integer; SysTime: PSystemTime): Boolean; virtual; abstract;
  3185.     property CalColors: TMonthCalColors read FCalColors write SetCalColors;
  3186.     property CalendarHandle: HWND read GetCalendarHandle;
  3187.     property CalExceptionClass: ExceptClass read FCalExceptionClass write FCalExceptionClass;
  3188.     property Date: TDate read GetDate write SetDate;
  3189.     property DateTime: TDateTime read FDateTime write SetDateTime;
  3190.     property EndDate: TDate read FEndDate write SetEndDate stored DoStoreEndDate;
  3191.     property FirstDayOfWeek: TCalDayOfWeek read FFirstDayOfWeek write SetFirstDayOfWeek
  3192.       default dowLocaleDefault;
  3193.     property MaxDate: TDate read FMaxDate write SetMaxDate stored DoStoreMaxDate;
  3194.     property MaxSelectRange: Integer read FMaxSelectRange write SetMaxSelectRange default 31;
  3195.     property MinDate: TDate read FMinDate write SetMinDate stored DoStoreMinDate;
  3196.     property MonthDelta: Integer read FMonthDelta write SetMonthDelta default 1;
  3197.     property MultiSelect: Boolean read FMultiSelect write SetMultiSelect default False;
  3198.     property ShowToday: Boolean read FShowToday write SetShowToday default True;
  3199.     property ShowTodayCircle: Boolean read FShowTodayCircle write
  3200.       SetShowTodayCircle default True;
  3201.     property WeekNumbers: Boolean read FWeekNumbers write SetWeekNumbers default False;
  3202.     property OnGetMonthInfo: TOnGetMonthInfoEvent read FOnGetMonthInfo write FOnGetMonthInfo;
  3203.   public
  3204.     constructor Create(AOwner: TComponent); override;
  3205.     destructor Destroy; override;
  3206.     procedure BoldDays(Days: array of LongWord; var MonthBoldInfo: LongWord);
  3207.   end;
  3208.  
  3209. { TMonthCalendar }
  3210.  
  3211.   EMonthCalError = class(ECommonCalendarError);
  3212.  
  3213.   TMonthCalendar = class(TCommonCalendar)
  3214.   private
  3215.     procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
  3216.     procedure CNNotify(var Message: TWMNotify); message CN_NOTIFY;
  3217.   protected
  3218.     function CanAutoSize(var NewWidth, NewHeight: Integer): Boolean; override;
  3219.     procedure ConstrainedResize(var MinWidth, MinHeight, MaxWidth,
  3220.       MaxHeight: Integer); override;
  3221.     procedure CreateParams(var Params: TCreateParams); override;
  3222.     function GetCalendarHandle: HWND; override;
  3223.     function MsgSetCalColors(ColorIndex: Integer; ColorValue: TColor): Boolean; override;
  3224.     function MsgSetDateTime(Value: TSystemTime): Boolean; override;
  3225.     function MsgSetRange(Flags: Integer; SysTime: PSystemTime): Boolean; override;
  3226.   public
  3227.     constructor Create(AOwner: TComponent); override;
  3228.   published
  3229.     property Align;
  3230.     property Anchors;
  3231.     property AutoSize;
  3232.     property BorderWidth;
  3233.     property BiDiMode;
  3234.     property CalColors;
  3235.     property Constraints;
  3236.     property MultiSelect;  // must be before date stuff
  3237.     property Date;
  3238.     property DragCursor;
  3239.     property DragKind;
  3240.     property DragMode;
  3241.     property Enabled;
  3242.     property EndDate;
  3243.     property FirstDayOfWeek;
  3244.     property Font;
  3245.     property ImeMode;
  3246.     property ImeName;
  3247.     property MaxDate;
  3248.     property MaxSelectRange;
  3249.     property MinDate;
  3250.     property ParentBiDiMode;
  3251.     property ParentFont;
  3252.     property ParentShowHint;
  3253.     property PopupMenu;
  3254.     property ShowHint;
  3255.     property ShowToday;
  3256.     property ShowTodayCircle;
  3257.     property TabOrder;
  3258.     property TabStop;
  3259.     property Visible;
  3260.     property WeekNumbers;
  3261.     property OnClick;
  3262.     property OnContextPopup;
  3263.     property OnDblClick;
  3264.     property OnDragDrop;
  3265.     property OnDragOver;
  3266.     property OnEndDock;
  3267.     property OnEndDrag;
  3268.     property OnEnter;
  3269.     property OnExit;
  3270.     property OnGetMonthInfo;
  3271.     property OnKeyDown;
  3272.     property OnKeyPress;
  3273.     property OnKeyUp;
  3274.     property OnStartDock;
  3275.     property OnStartDrag;
  3276.   end;
  3277.  
  3278. { TDateTimePicker }
  3279.  
  3280.   EDateTimeError = class(ECommonCalendarError);
  3281.  
  3282.   TDateTimeKind = (dtkDate, dtkTime);
  3283.   TDTDateMode = (dmComboBox, dmUpDown);
  3284.   TDTDateFormat = (dfShort, dfLong);
  3285.   TDTCalAlignment = (dtaLeft, dtaRight);
  3286.  
  3287.   TDTParseInputEvent = procedure(Sender: TObject; const UserString: string;
  3288.     var DateAndTime: TDateTime; var AllowChange: Boolean) of object;
  3289.  
  3290.   TDateTimeColors = TMonthCalColors;  // for backward compatibility
  3291.  
  3292.   TDateTimePicker = class(TCommonCalendar)
  3293.   private
  3294.     FCalAlignment: TDTCalAlignment;
  3295.     FChanging: Boolean;
  3296.     FChecked: Boolean;
  3297.     FDateFormat: TDTDateFormat;
  3298.     FDateMode: TDTDateMode;
  3299.     FDroppedDown: Boolean;
  3300.     FKind: TDateTimeKind;
  3301.     FLastChange: TSystemTime;
  3302.     FParseInput: Boolean;
  3303.     FShowCheckbox: Boolean;
  3304.     FOnUserInput: TDTParseInputEvent;
  3305.     FOnCloseUp: TNotifyEvent;
  3306.     FOnChange: TNotifyEvent;
  3307.     FOnDropDown: TNotifyEvent;
  3308.     procedure AdjustHeight;
  3309.     function GetTime: TTime;
  3310.     procedure SetCalAlignment(Value: TDTCalAlignment);
  3311.     procedure SetChecked(Value: Boolean);
  3312.     procedure SetDateMode(Value: TDTDateMode);
  3313.     procedure SetDateFormat(Value: TDTDateFormat);
  3314.     procedure SetKind(Value: TDateTimeKind);
  3315.     procedure SetParseInput(Value: Boolean);
  3316.     procedure SetShowCheckbox(Value: Boolean);
  3317.     procedure SetTime(Value: TTime);
  3318.     procedure CMColorChanged(var Message: TMessage); message CM_COLORCHANGED;
  3319.     procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
  3320.     procedure CNNotify(var Message: TWMNotify); message CN_NOTIFY;
  3321.   protected
  3322.     procedure CheckEmptyDate; override;
  3323.     procedure CreateParams(var Params: TCreateParams); override;
  3324.     procedure CreateWnd; override;
  3325.     procedure Change; dynamic;
  3326.     function GetCalendarHandle: HWND; override;
  3327.     function MsgSetCalColors(ColorIndex: Integer; ColorValue: TColor): Boolean; override;
  3328.     function MsgSetDateTime(Value: TSystemTime): Boolean; override;
  3329.     function MsgSetRange(Flags: Integer; SysTime: PSystemTime): Boolean; override;
  3330.   public
  3331.     constructor Create(AOwner: TComponent); override;
  3332.     property DateTime;
  3333.     property DroppedDown: Boolean read FDroppedDown;
  3334.   published
  3335.     property Anchors;
  3336.     property BiDiMode;
  3337.     property CalAlignment: TDTCalAlignment read FCalAlignment write SetCalAlignment;
  3338.     property CalColors;
  3339.     property Constraints;
  3340.     // The Date, Time, ShowCheckbox, and Checked properties must be in this order:
  3341.     property Date;
  3342.     property Time: TTime read GetTime write SetTime;
  3343.     property ShowCheckbox: Boolean read FShowCheckbox write SetShowCheckbox default False;
  3344.     property Checked: Boolean read FChecked write SetChecked default True;
  3345.     property Color stored True default clWindow;
  3346.     property DateFormat: TDTDateFormat read FDateFormat write SetDateFormat;
  3347.     property DateMode: TDTDateMode read FDateMode write SetDateMode;
  3348.     property DragCursor;
  3349.     property DragKind;
  3350.     property DragMode;
  3351.     property Enabled;
  3352.     property Font;
  3353.     property ImeMode;
  3354.     property ImeName;
  3355.     property Kind: TDateTimeKind read FKind write SetKind;
  3356.     property MaxDate;
  3357.     property MinDate;
  3358.     property ParseInput: Boolean read FParseInput write SetParseInput;
  3359.     property ParentBiDiMode;
  3360.     property ParentColor default False;
  3361.     property ParentFont;
  3362.     property ParentShowHint;
  3363.     property PopupMenu;
  3364.     property ShowHint;
  3365.     property TabOrder;
  3366.     property TabStop default True;
  3367.     property Visible;
  3368.     property OnClick;
  3369.     property OnCloseUp: TNotifyEvent read FOnCloseUp write FOnCloseUp;
  3370.     property OnChange: TNotifyEvent read FOnChange write FOnChange;
  3371.     property OnContextPopup;
  3372.     property OnDropDown: TNotifyEvent read FOnDropDown write FOnDropDown;
  3373.     property OnDblClick;
  3374.     property OnDragDrop;
  3375.     property OnDragOver;
  3376.     property OnEndDock;
  3377.     property OnEndDrag;
  3378.     property OnEnter;
  3379.     property OnExit;
  3380.     property OnKeyDown;
  3381.     property OnKeyPress;
  3382.     property OnKeyUp;
  3383.     property OnStartDock;
  3384.     property OnStartDrag;
  3385.     property OnUserInput: TDTParseInputEvent read FOnUserInput write FOnUserInput;
  3386.   end;
  3387.  
  3388. { TPageScroller }
  3389.  
  3390.   TPageScrollerOrientation = (soHorizontal, soVertical);
  3391.   TPageScrollerButton = (sbFirst, sbLast);
  3392.   TPageScrollerButtonState = (bsNormal, bsInvisible, bsGrayed, bsDepressed, bsHot);
  3393.  
  3394.   TPageScrollEvent = procedure (Sender: TObject; Shift: TShiftState; X, Y: Integer;
  3395.     Orientation: TPageScrollerOrientation; var Delta: Integer) of object;
  3396.  
  3397.   TPageScroller = class(TWinControl)
  3398.   private
  3399.     FAutoScroll: Boolean;
  3400.     FButtonSize: Integer;
  3401.     FControl: TWinControl;
  3402.     FDragScroll: Boolean;
  3403.     FMargin: Integer;
  3404.     FOrientation: TPageScrollerOrientation;
  3405.     FPosition: Integer;
  3406.     FPreferredSize: Integer;
  3407.     FOnScroll: TPageScrollEvent;
  3408.     procedure CNNotify(var Message: TWMNotify); message CN_NOTIFY;
  3409.     procedure DoSetControl(Value: TWinControl);
  3410.     procedure SetAutoScroll(Value: Boolean);
  3411.     procedure SetButtonSize(Value: Integer);
  3412.     procedure SetControl(Value: TWinControl);
  3413.     procedure SetDragScroll(Value: Boolean);
  3414.     procedure SetMargin(Value: Integer);
  3415.     procedure SetOrientation(Value: TPageScrollerOrientation);
  3416.     procedure SetPosition(Value: Integer);
  3417.     procedure UpdatePreferredSize;
  3418.     procedure WMNCHitTest(var Message: TWMNCHitTest); message WM_NCHITTEST;
  3419.     procedure CMControlChange(var Message: TCMControlChange); message CM_CONTROLCHANGE;
  3420.     procedure CMColorChanged(var Message: TMessage); message CM_COLORCHANGED;
  3421.   protected
  3422.     procedure AlignControls(AControl: TControl; var Rect: TRect); override;
  3423.     procedure CreateParams(var Params: TCreateParams); override;
  3424.     procedure CreateWnd; override;
  3425.     procedure Notification(AComponent: TComponent; Operation: TOperation); override;
  3426.     procedure Scroll(Shift: TShiftState; X, Y: Integer;
  3427.       Orientation: TPageScrollerOrientation; var Delta: Integer); dynamic;
  3428.   public
  3429.     constructor Create(AOwner: TComponent); override;
  3430.     function GetButtonState(Button: TPageScrollerButton): TPageScrollerButtonState;
  3431.   published
  3432.     property Align;
  3433.     property Anchors;
  3434.     property AutoScroll: Boolean read FAutoScroll write SetAutoScroll;
  3435.     property BorderWidth;
  3436.     property ButtonSize: Integer read FButtonSize write SetButtonSize default 12;
  3437.     property Color;
  3438.     property Constraints;
  3439.     property Control: TWinControl read FControl write SetControl;
  3440.     property DockSite;
  3441.     property DragCursor;
  3442.     property DragKind;
  3443.     property DragMode;
  3444.     property DragScroll: Boolean read FDragScroll write SetDragScroll default True;
  3445.     property Enabled;
  3446.     property Font;
  3447.     property Margin: Integer read FMargin write SetMargin default 0;
  3448.     property Orientation: TPageScrollerOrientation read FOrientation write SetOrientation default soHorizontal;
  3449.     property ParentColor;
  3450.     property ParentFont;
  3451.     property ParentShowHint;
  3452.     property PopupMenu;
  3453.     property Position: Integer read FPosition write SetPosition default 0;
  3454.     property ShowHint;
  3455.     property TabOrder;
  3456.     property TabStop default True;
  3457.     property Visible;
  3458.     property OnClick;
  3459.     property OnContextPopup;
  3460.     property OnDblClick;
  3461.     property OnDragDrop;
  3462.     property OnDragOver;
  3463.     property OnEndDock;
  3464.     property OnEndDrag;
  3465.     property OnEnter;
  3466.     property OnExit;
  3467.     property OnKeyDown;
  3468.     property OnKeyPress;
  3469.     property OnKeyUp;
  3470.     property OnMouseWheel;
  3471.     property OnResize;
  3472.     property OnScroll: TPageScrollEvent read FOnScroll write FOnScroll;
  3473.     property OnStartDock;
  3474.     property OnStartDrag;
  3475.   end;
  3476.  
  3477. function InitCommonControl(CC: Integer): Boolean;
  3478. procedure CheckCommonControl(CC: Integer);
  3479.  
  3480. const
  3481.   ComCtlVersionIE3 = $00040046;
  3482.   ComCtlVersionIE4 = $00040047;
  3483.   ComCtlVersionIE401 = $00040048;
  3484.   ComCtlVersionIE5 = $00050050;
  3485.  
  3486. function GetComCtlVersion: Integer;
  3487. procedure CheckToolMenuDropdown(ToolButton: TToolButton);
  3488.  
  3489. implementation
  3490.  
  3491. uses Printers, Consts, ComStrs, ActnList, StdActns;
  3492.  
  3493. const
  3494.   SectionSizeArea = 8;
  3495.   RTFConversionFormat: TConversionFormat = (
  3496.     ConversionClass: TConversion;
  3497.     Extension: 'rtf';
  3498.     Next: nil);
  3499.   TextConversionFormat: TConversionFormat = (
  3500.     ConversionClass: TConversion;
  3501.     Extension: 'txt';
  3502.     Next: @RTFConversionFormat);
  3503.   ShellDllName = 'shell32.dll';
  3504.   ComCtlDllName = 'comctl32.dll';
  3505.  
  3506. var
  3507.   ConversionFormatList: PConversionFormat = @TextConversionFormat;
  3508.   ShellModule: THandle;
  3509.   FRichEditModule: THandle;
  3510.   ComCtlVersion: Integer;
  3511.  
  3512. function InitCommonControl(CC: Integer): Boolean;
  3513. var
  3514.   ICC: TInitCommonControlsEx;
  3515. begin
  3516.   ICC.dwSize := SizeOf(TInitCommonControlsEx);
  3517.   ICC.dwICC := CC;
  3518.   Result := InitCommonControlsEx(ICC);
  3519.   if not Result then InitCommonControls;
  3520. end;
  3521.  
  3522. procedure CheckCommonControl(CC: Integer);
  3523. begin
  3524.   if not InitCommonControl(CC) then
  3525.     raise EComponentError.CreateRes(@SInvalidComCtl32);
  3526. end;
  3527.  
  3528. function GetShellModule: THandle;
  3529. begin
  3530.   if ShellModule = 0 then
  3531.   begin
  3532.     ShellModule := SafeLoadLibrary(ShellDllName);
  3533.     if ShellModule <= HINSTANCE_ERROR then
  3534.       ShellModule := 0;
  3535.   end;
  3536.   Result := ShellModule;
  3537. end;
  3538.  
  3539. function GetComCtlVersion: Integer;
  3540. var
  3541.   FileName: string;
  3542.   InfoSize, Wnd: DWORD;
  3543.   VerBuf: Pointer;
  3544.   FI: PVSFixedFileInfo;
  3545.   VerSize: DWORD;
  3546. begin
  3547.   if ComCtlVersion = 0 then
  3548.   begin
  3549.     // GetFileVersionInfo modifies the filename parameter data while parsing.
  3550.     // Copy the string const into a local variable to create a writeable copy.
  3551.     FileName := ComCtlDllName;
  3552.     InfoSize := GetFileVersionInfoSize(PChar(FileName), Wnd);
  3553.     if InfoSize <> 0 then
  3554.     begin
  3555.       GetMem(VerBuf, InfoSize);
  3556.       try
  3557.         if GetFileVersionInfo(PChar(FileName), Wnd, InfoSize, VerBuf) then
  3558.           if VerQueryValue(VerBuf, '\', Pointer(FI), VerSize) then
  3559.             ComCtlVersion := FI.dwFileVersionMS;
  3560.       finally
  3561.         FreeMem(VerBuf);
  3562.       end;
  3563.     end;
  3564.   end;
  3565.   Result := ComCtlVersion;
  3566. end;
  3567.  
  3568. // Deprecated - use TToolButton.CheckMenuDropDown
  3569. procedure CheckToolMenuDropdown(ToolButton: TToolButton);
  3570. begin
  3571.   if ToolButton <> nil then ToolButton.CheckMenuDropdown;
  3572. end;
  3573.  
  3574. procedure SetComCtlStyle(Ctl: TWinControl; Value: Integer; UseStyle: Boolean);
  3575. var
  3576.   Style: Integer;
  3577. begin
  3578.   if Ctl.HandleAllocated then
  3579.   begin
  3580.     Style := GetWindowLong(Ctl.Handle, GWL_STYLE);
  3581.     if not UseStyle then Style := Style and not Value
  3582.     else Style := Style or Value;
  3583.     SetWindowLong(Ctl.Handle, GWL_STYLE, Style);
  3584.   end;
  3585. end;
  3586.  
  3587. { TTabStrings }
  3588.  
  3589. type
  3590.   TTabStrings = class(TStrings)
  3591.   private
  3592.     FTabControl: TCustomTabControl;
  3593.   protected
  3594.     function Get(Index: Integer): string; override;
  3595.     function GetCount: Integer; override;
  3596.     function GetObject(Index: Integer): TObject; override;
  3597.     procedure Put(Index: Integer; const S: string); override;
  3598.     procedure PutObject(Index: Integer; AObject: TObject); override;
  3599.     procedure SetUpdateState(Updating: Boolean); override;
  3600.   public
  3601.     procedure Clear; override;
  3602.     procedure Delete(Index: Integer); override;
  3603.     procedure Insert(Index: Integer; const S: string); override;
  3604.   end;
  3605.  
  3606. procedure TabControlError(const S: string);
  3607. begin
  3608.   raise EListError.Create(S);
  3609. end;
  3610.  
  3611. procedure TTabStrings.Clear;
  3612. begin
  3613.   if SendMessage(FTabControl.Handle, TCM_DELETEALLITEMS, 0, 0) = 0 then
  3614.     TabControlError(sTabFailClear);
  3615.   FTabControl.TabsChanged;
  3616. end;
  3617.  
  3618. procedure TTabStrings.Delete(Index: Integer);
  3619. begin
  3620.   if SendMessage(FTabControl.Handle, TCM_DELETEITEM, Index, 0) = 0 then
  3621.     TabControlError(Format(sTabFailDelete, [Index]));
  3622.   FTabControl.TabsChanged;
  3623. end;
  3624.  
  3625. function TTabStrings.Get(Index: Integer): string;
  3626. const
  3627.   RTL: array[Boolean] of LongInt = (0, TCIF_RTLREADING);
  3628. var
  3629.   TCItem: TTCItem;
  3630.   Buffer: array[0..4095] of Char;
  3631. begin
  3632.   TCItem.mask := TCIF_TEXT or RTL[FTabControl.UseRightToLeftReading];
  3633.   TCItem.pszText := Buffer;
  3634.   TCItem.cchTextMax := SizeOf(Buffer);
  3635.   if SendMessage(FTabControl.Handle, TCM_GETITEM, Index,
  3636.     Longint(@TCItem)) = 0 then
  3637.     TabControlError(Format(sTabFailRetrieve, [Index]));
  3638.   Result := Buffer;
  3639. end;
  3640.  
  3641. function TTabStrings.GetCount: Integer;
  3642. begin
  3643.   Result := SendMessage(FTabControl.Handle, TCM_GETITEMCOUNT, 0, 0);
  3644. end;
  3645.  
  3646. function TTabStrings.GetObject(Index: Integer): TObject;
  3647. var
  3648.   TCItem: TTCItem;
  3649. begin
  3650.   TCItem.mask := TCIF_PARAM;
  3651.   if SendMessage(FTabControl.Handle, TCM_GETITEM, Index,
  3652.     Longint(@TCItem)) = 0 then
  3653.     TabControlError(Format(sTabFailGetObject, [Index]));
  3654.   Result := TObject(TCItem.lParam);
  3655. end;
  3656.  
  3657. procedure TTabStrings.Put(Index: Integer; const S: string);
  3658. const
  3659.   RTL: array[Boolean] of LongInt = (0, TCIF_RTLREADING);
  3660. var
  3661.   TCItem: TTCItem;
  3662. begin
  3663.   TCItem.mask := TCIF_TEXT or RTL[FTabControl.UseRightToLeftReading] or
  3664.     TCIF_IMAGE;
  3665.   TCItem.pszText := PChar(S);
  3666.   TCItem.iImage := FTabControl.GetImageIndex(Index);
  3667.   if SendMessage(FTabControl.Handle, TCM_SETITEM, Index,
  3668.     Longint(@TCItem)) = 0 then
  3669.     TabControlError(Format(sTabFailSet, [S, Index]));
  3670.   FTabControl.TabsChanged;
  3671. end;
  3672.  
  3673. procedure TTabStrings.PutObject(Index: Integer; AObject: TObject);
  3674. var
  3675.   TCItem: TTCItem;
  3676. begin
  3677.   TCItem.mask := TCIF_PARAM;
  3678.   TCItem.lParam := Longint(AObject);
  3679.   if SendMessage(FTabControl.Handle, TCM_SETITEM, Index,
  3680.     Longint(@TCItem)) = 0 then
  3681.     TabControlError(Format(sTabFailSetObject, [Index]));
  3682. end;
  3683.  
  3684. procedure TTabStrings.Insert(Index: Integer; const S: string);
  3685. const
  3686.   RTL: array[Boolean] of LongInt = (0, TCIF_RTLREADING);
  3687. var
  3688.   TCItem: TTCItem;
  3689. begin
  3690.   TCItem.mask := TCIF_TEXT or RTL[FTabControl.UseRightToLeftReading] or
  3691.     TCIF_IMAGE;
  3692.   TCItem.pszText := PChar(S);
  3693.   TCItem.iImage := FTabControl.GetImageIndex(Index);
  3694.   if SendMessage(FTabControl.Handle, TCM_INSERTITEM, Index,
  3695.     Longint(@TCItem)) < 0 then
  3696.     TabControlError(Format(sTabFailSet, [S, Index]));
  3697.   FTabControl.TabsChanged;
  3698. end;
  3699.  
  3700. procedure TTabStrings.SetUpdateState(Updating: Boolean);
  3701. begin
  3702.   FTabControl.FUpdating := Updating;
  3703.   SendMessage(FTabControl.Handle, WM_SETREDRAW, Ord(not Updating), 0);
  3704.   if not Updating then
  3705.   begin
  3706.     FTabControl.Invalidate;
  3707.     FTabControl.TabsChanged;
  3708.   end;
  3709. end;
  3710.  
  3711. { TCustomTabControl }
  3712.  
  3713. constructor TCustomTabControl.Create(AOwner: TComponent);
  3714. begin
  3715.   inherited Create(AOwner);
  3716.   Width := 289;
  3717.   Height := 193;
  3718.   TabStop := True;
  3719.   ControlStyle := [csAcceptsControls, csDoubleClicks];
  3720.   FTabs := TTabStrings.Create;
  3721.   TTabStrings(FTabs).FTabControl := Self;
  3722.   FCanvas := TControlCanvas.Create;
  3723.   TControlCanvas(FCanvas).Control := Self;
  3724.   FImageChangeLink := TChangeLink.Create;
  3725.   FImageChangeLink.OnChange := ImageListChange;
  3726. end;
  3727.  
  3728. destructor TCustomTabControl.Destroy;
  3729. begin
  3730.   FreeAndNil(FCanvas);
  3731.   FreeAndNil(FTabs);
  3732.   FreeAndNil(FSaveTabs);
  3733.   FreeAndNil(FImageChangeLink);
  3734.   inherited Destroy;
  3735. end;
  3736.  
  3737. function TCustomTabControl.CanChange: Boolean;
  3738. begin
  3739.   Result := True;
  3740.   if Assigned(FOnChanging) then FOnChanging(Self, Result);
  3741. end;
  3742.  
  3743. function TCustomTabControl.CanShowTab(TabIndex: Integer): Boolean;
  3744. begin
  3745.   Result := True;
  3746. end;
  3747.  
  3748. procedure TCustomTabControl.Change;
  3749. begin
  3750.   if Assigned(FOnChange) then FOnChange(Self);
  3751. end;
  3752.  
  3753. procedure TCustomTabControl.CreateParams(var Params: TCreateParams);
  3754. const
  3755.   AlignStyles: array[Boolean, TTabPosition] of DWORD =
  3756.     ((0, TCS_BOTTOM, TCS_VERTICAL, TCS_VERTICAL or TCS_RIGHT),
  3757.      (0, TCS_BOTTOM, TCS_VERTICAL or TCS_RIGHT, TCS_VERTICAL));
  3758.   TabStyles: array[TTabStyle] of DWORD = (TCS_TABS, TCS_BUTTONS,
  3759.     TCS_BUTTONS or TCS_FLATBUTTONS);
  3760.    RRStyles: array[Boolean] of DWORD = (0, TCS_RAGGEDRIGHT);
  3761. begin
  3762.   InitCommonControl(ICC_TAB_CLASSES);
  3763.   inherited CreateParams(Params);
  3764.   CreateSubClass(Params, WC_TABCONTROL);
  3765.   with Params do
  3766.   begin
  3767.     Style := Style or WS_CLIPCHILDREN or
  3768.       AlignStyles[UseRightToLeftAlignment, FTabPosition] or
  3769.       TabStyles[FStyle] or RRStyles[FRaggedRight];
  3770.     if not TabStop then Style := Style or TCS_FOCUSNEVER;
  3771.     if FMultiLine then Style := Style or TCS_MULTILINE;
  3772.     if FMultiSelect then Style := Style or TCS_MULTISELECT;
  3773.     if FOwnerDraw then Style := Style or TCS_OWNERDRAWFIXED;
  3774.     if FTabSize.X <> 0 then Style := Style or TCS_FIXEDWIDTH;
  3775.     if FHotTrack and (not (csDesigning in ComponentState)) then
  3776.       Style := Style or TCS_HOTTRACK;
  3777.     if FScrollOpposite then Style := Style or TCS_SCROLLOPPOSITE;
  3778.     WindowClass.style := WindowClass.style and not (CS_HREDRAW or CS_VREDRAW) or
  3779.       CS_DBLCLKS;
  3780.   end;
  3781. end;
  3782.  
  3783. procedure TCustomTabControl.CreateWnd;
  3784. begin
  3785.   inherited CreateWnd;
  3786.   if (Images <> nil) and Images.HandleAllocated then
  3787.     Perform(TCM_SETIMAGELIST, 0, Images.Handle);
  3788.   if Integer(FTabSize) <> 0 then UpdateTabSize;
  3789.   if FSaveTabs <> nil then
  3790.   begin
  3791.     FTabs.Assign(FSaveTabs);
  3792.     SetTabIndex(FSaveTabIndex);
  3793.     FSaveTabs.Free;
  3794.     FSaveTabs := nil;
  3795.   end;
  3796. end;
  3797.  
  3798. procedure TCustomTabControl.DrawTab(TabIndex: Integer; const Rect: TRect;
  3799.   Active: Boolean);
  3800. begin
  3801.   if Assigned(FOnDrawTab) then
  3802.     FOnDrawTab(Self, TabIndex, Rect, Active) else
  3803.     FCanvas.FillRect(Rect);
  3804. end;
  3805.  
  3806. function TCustomTabControl.GetDisplayRect: TRect;
  3807. begin
  3808.   Result := ClientRect;
  3809.   SendMessage(Handle, TCM_ADJUSTRECT, 0, Integer(@Result));
  3810.   Inc(Result.Top, 2);
  3811. end;
  3812.  
  3813. function TCustomTabControl.GetImageIndex(TabIndex: Integer): Integer;
  3814. begin
  3815.   Result := TabIndex;
  3816.   if Assigned(FOnGetImageIndex) then FOnGetImageIndex(Self, TabIndex, Result);
  3817. end;
  3818.  
  3819. function TCustomTabControl.GetTabIndex: Integer;
  3820. begin
  3821.   Result := SendMessage(Handle, TCM_GETCURSEL, 0, 0);
  3822. end;
  3823.  
  3824. procedure TCustomTabControl.Loaded;
  3825. begin
  3826.   inherited Loaded;
  3827.   if Images <> nil then UpdateTabImages;
  3828. end;
  3829.  
  3830. procedure TCustomTabControl.SetHotTrack(Value: Boolean);
  3831. begin
  3832.   if FHotTrack <> Value then
  3833.   begin
  3834.     FHotTrack := Value;
  3835.     RecreateWnd;
  3836.   end;
  3837. end;
  3838.  
  3839. procedure TCustomTabControl.Notification(AComponent: TComponent;
  3840.   Operation: TOperation);
  3841. begin
  3842.   inherited Notification(AComponent, Operation);
  3843.   if (Operation = opRemove) and (AComponent = Images) then
  3844.     Images := nil;
  3845. end;
  3846.  
  3847. procedure TCustomTabControl.SetImages(Value: TCustomImageList);
  3848. begin
  3849.   if Images <> nil then
  3850.     Images.UnRegisterChanges(FImageChangeLink);
  3851.   FImages := Value;
  3852.   if Images <> nil then
  3853.   begin
  3854.     Images.RegisterChanges(FImageChangeLink);
  3855.     Images.FreeNotification(Self);
  3856.     Perform(TCM_SETIMAGELIST, 0, Images.Handle);
  3857.   end
  3858.   else Perform(TCM_SETIMAGELIST, 0, 0);
  3859. end;
  3860.  
  3861. procedure TCustomTabControl.ImageListChange(Sender: TObject);
  3862. begin
  3863.   Perform(TCM_SETIMAGELIST, 0, TCustomImageList(Sender).Handle);
  3864. end;
  3865.  
  3866. function TCustomTabControl.InternalSetMultiLine(Value: Boolean): Boolean;
  3867. begin
  3868.   Result := FMultiLine <> Value;
  3869.   if Result then
  3870.   begin
  3871.     if not Value and ((TabPosition = tpLeft) or (TabPosition = tpRight)) then
  3872.       TabControlError(sTabMustBeMultiLine);
  3873.     FMultiLine := Value;
  3874.     if not Value then FScrollOpposite := False;
  3875.   end;
  3876. end;
  3877.  
  3878. procedure TCustomTabControl.SetMultiLine(Value: Boolean);
  3879. begin
  3880.   if InternalSetMultiLine(Value) then RecreateWnd;
  3881. end;
  3882.  
  3883. procedure TCustomTabControl.SetMultiSelect(Value: Boolean);
  3884. begin
  3885.   if FMultiSelect <> Value then
  3886.   begin
  3887.     FMultiSelect := Value;
  3888.     RecreateWnd;
  3889.   end;
  3890. end;
  3891.  
  3892. procedure TCustomTabControl.SetOwnerDraw(Value: Boolean);
  3893. begin
  3894.   if FOwnerDraw <> Value then
  3895.   begin
  3896.     FOwnerDraw := Value;
  3897.     RecreateWnd;
  3898.   end;
  3899. end;
  3900.  
  3901. procedure TCustomTabControl.SetRaggedRight(Value: Boolean);
  3902. begin
  3903.   if FRaggedRight <> Value then
  3904.   begin
  3905.     FRaggedRight := Value;
  3906.     SetComCtlStyle(Self, TCS_RAGGEDRIGHT, Value);
  3907.   end;
  3908. end;
  3909.  
  3910. procedure TCustomTabControl.SetScrollOpposite(Value: Boolean);
  3911. begin
  3912.   if FScrollOpposite <> Value then
  3913.   begin
  3914.     FScrollOpposite := Value;
  3915.     if Value then FMultiLine := Value;
  3916.     RecreateWnd;
  3917.   end;
  3918. end;
  3919.  
  3920. procedure TCustomTabControl.SetStyle(Value: TTabStyle);
  3921. begin
  3922.   if FStyle <> Value then
  3923.   begin
  3924.     if (Value <> tsTabs) and (TabPosition <> tpTop) then
  3925.       raise EInvalidOperation.Create(SInvalidTabStyle);
  3926.     FStyle := Value;
  3927.     RecreateWnd;
  3928.   end;
  3929. end;
  3930.  
  3931. procedure TCustomTabControl.SetTabHeight(Value: Smallint);
  3932. begin
  3933.   if FTabSize.Y <> Value then
  3934.   begin
  3935.     if Value < 0 then
  3936.       raise EInvalidOperation.CreateFmt(SPropertyOutOfRange, [Self.Classname]);
  3937.     FTabSize.Y := Value;
  3938.     UpdateTabSize;
  3939.   end;
  3940. end;
  3941.  
  3942. procedure TCustomTabControl.SetTabIndex(Value: Integer);
  3943. begin
  3944.   SendMessage(Handle, TCM_SETCURSEL, Value, 0);
  3945. end;
  3946.  
  3947. procedure TCustomTabControl.SetTabPosition(Value: TTabPosition);
  3948. begin
  3949.   if FTabPosition <> Value then
  3950.   begin
  3951.     if (Value <> tpTop) and (Style <> tsTabs) then
  3952.       raise EInvalidOperation.Create(SInvalidTabPosition);
  3953.     FTabPosition := Value;
  3954.     if not MultiLine and ((Value = tpLeft) or (Value = tpRight)) then
  3955.       InternalSetMultiLine(True);
  3956.     RecreateWnd;
  3957.   end;
  3958. end;
  3959.  
  3960. procedure TCustomTabControl.SetTabs(Value: TStrings);
  3961. begin
  3962.   FTabs.Assign(Value);
  3963. end;
  3964.  
  3965. procedure TCustomTabControl.SetTabWidth(Value: Smallint);
  3966. var
  3967.   OldValue: Smallint;
  3968. begin
  3969.   if FTabSize.X <> Value then
  3970.   begin
  3971.     if Value < 0 then
  3972.       raise EInvalidOperation.CreateFmt(SPropertyOutOfRange, [Self.Classname]);
  3973.     OldValue := FTabSize.X;
  3974.     FTabSize.X := Value;
  3975.     if (OldValue = 0) or (Value = 0) then RecreateWnd
  3976.     else UpdateTabSize;
  3977.   end;
  3978. end;
  3979.  
  3980. procedure TCustomTabControl.TabsChanged;
  3981. begin
  3982.   if not FUpdating then
  3983.   begin
  3984.     if HandleAllocated then
  3985.       SendMessage(Handle, WM_SIZE, SIZE_RESTORED,
  3986.         Word(Width) or Word(Height) shl 16);
  3987.     Realign;
  3988.   end;
  3989. end;
  3990.  
  3991. procedure TCustomTabControl.UpdateTabSize;
  3992. begin
  3993.   SendMessage(Handle, TCM_SETITEMSIZE, 0, Integer(FTabSize));
  3994.   TabsChanged;
  3995. end;
  3996.  
  3997. procedure TCustomTabControl.UpdateTabImages;
  3998. var
  3999.   I: Integer;
  4000.   TCItem: TTCItem;
  4001. begin
  4002.   TCItem.mask := TCIF_IMAGE;
  4003.   for I := 0 to FTabs.Count - 1 do
  4004.   begin
  4005.     TCItem.iImage := GetImageIndex(I);
  4006.     if SendMessage(Handle, TCM_SETITEM, I,
  4007.       Longint(@TCItem)) = 0 then
  4008.       TabControlError(Format(sTabFailSet, [FTabs[I], I]));
  4009.   end;
  4010.   TabsChanged;
  4011. end;
  4012.  
  4013. procedure TCustomTabControl.CNDrawItem(var Message: TWMDrawItem);
  4014. var
  4015.   SaveIndex: Integer;
  4016. begin
  4017.   with Message.DrawItemStruct^ do
  4018.   begin
  4019.     SaveIndex := SaveDC(hDC);
  4020.     FCanvas.Lock;
  4021.     try
  4022.       FCanvas.Handle := hDC;
  4023.       FCanvas.Font := Font;
  4024.       FCanvas.Brush := Brush;
  4025.       DrawTab(itemID, rcItem, itemState and ODS_SELECTED <> 0);
  4026.     finally
  4027.       FCanvas.Handle := 0;
  4028.       FCanvas.Unlock;
  4029.       RestoreDC(hDC, SaveIndex);
  4030.     end;
  4031.   end;
  4032.   Message.Result := 1;
  4033. end;
  4034.  
  4035. procedure TCustomTabControl.WMDestroy(var Message: TWMDestroy);
  4036. var
  4037.   FocusHandle: HWnd;
  4038. begin
  4039.   if (FTabs <> nil) and (FTabs.Count > 0) then
  4040.   begin
  4041.     FSaveTabs := TStringList.Create;
  4042.     FSaveTabs.Assign(FTabs);
  4043.     FSaveTabIndex := GetTabIndex;
  4044.   end;
  4045.   FocusHandle := GetFocus;
  4046.   if (FocusHandle <> 0) and ((FocusHandle = Handle) or
  4047.     IsChild(Handle, FocusHandle)) then
  4048.     Windows.SetFocus(0);
  4049.   inherited;
  4050.   WindowHandle := 0;
  4051. end;
  4052.  
  4053. procedure TCustomTabControl.WMNotifyFormat(var Message: TMessage);
  4054. begin
  4055.   with Message do
  4056.     Result := DefWindowProc(Handle, Msg, WParam, LParam);
  4057. end;
  4058.  
  4059. procedure TCustomTabControl.WMSize(var Message: TMessage);
  4060. begin
  4061.   inherited;
  4062.   RedrawWindow(Handle, nil, 0, RDW_INVALIDATE or RDW_ERASE);
  4063. end;
  4064.  
  4065. procedure TCustomTabControl.CMFontChanged(var Message);
  4066. begin
  4067.   inherited;
  4068.   if HandleAllocated then Perform(WM_SIZE, 0, 0);
  4069. end;
  4070.  
  4071. procedure TCustomTabControl.CMSysColorChange(var Message: TMessage);
  4072. begin
  4073.   inherited;
  4074.   if not (csLoading in ComponentState) then
  4075.   begin
  4076.     Message.Msg := WM_SYSCOLORCHANGE;
  4077.     DefaultHandler(Message);
  4078.   end;
  4079. end;
  4080.  
  4081. procedure TCustomTabControl.CMTabStopChanged(var Message: TMessage);
  4082. begin
  4083.   if not (csDesigning in ComponentState) then RecreateWnd;
  4084. end;
  4085.  
  4086. procedure TCustomTabControl.CNNotify(var Message: TWMNotify);
  4087. begin
  4088.   with Message do
  4089.     case NMHdr^.code of
  4090.       TCN_SELCHANGE:
  4091.         Change;
  4092.       TCN_SELCHANGING:
  4093.         begin
  4094.           Result := 1;
  4095.           if CanChange then Result := 0;
  4096.         end;
  4097.     end;
  4098. end;
  4099.  
  4100. procedure TCustomTabControl.CMDialogChar(var Message: TCMDialogChar);
  4101. var
  4102.   I: Integer;
  4103. begin
  4104.   for I := 0 to FTabs.Count - 1 do
  4105.     if IsAccel(Message.CharCode, FTabs[I]) and CanShowTab(I) and CanFocus then
  4106.     begin
  4107.       Message.Result := 1;
  4108.       if CanChange then
  4109.       begin
  4110.         TabIndex := I;
  4111.         Change;
  4112.       end;
  4113.       Exit;
  4114.     end;
  4115.   inherited;
  4116. end;
  4117.  
  4118. procedure TCustomTabControl.AdjustClientRect(var Rect: TRect);
  4119. begin
  4120.   Rect := DisplayRect;
  4121.   inherited AdjustClientRect(Rect);
  4122. end;
  4123.  
  4124. function TCustomTabControl.IndexOfTabAt(X, Y: Integer): Integer;
  4125. var
  4126.   HitTest: TTCHitTestInfo;
  4127. begin
  4128.   Result := -1;
  4129.   if PtInRect(ClientRect, Point(X, Y)) then
  4130.     with HitTest do
  4131.     begin
  4132.       pt.X := X;
  4133.       pt.Y := Y;
  4134.       Result := TabCtrl_HitTest(Handle, @HitTest);
  4135.     end;
  4136. end;
  4137.  
  4138. function TCustomTabControl.GetHitTestInfoAt(X, Y: Integer): THitTests;
  4139. var
  4140.   HitTest: TTCHitTestInfo;
  4141. begin
  4142.   Result := [];
  4143.   if PtInRect(ClientRect, Point(X, Y)) then
  4144.     with HitTest do
  4145.     begin
  4146.       pt.X := X;
  4147.       pt.Y := Y;
  4148.       if TabCtrl_HitTest(Handle, @HitTest) <> -1 then
  4149.       begin
  4150.         if (flags and TCHT_NOWHERE) <> 0 then
  4151.           Include(Result, htNowhere);
  4152.         if (flags and TCHT_ONITEM) = TCHT_ONITEM then
  4153.           Include(Result, htOnItem)
  4154.         else
  4155.         begin
  4156.           if (flags and TCHT_ONITEM) <> 0 then
  4157.             Include(Result, htOnItem);
  4158.           if (flags and TCHT_ONITEMICON) <> 0 then
  4159.             Include(Result, htOnIcon);
  4160.           if (flags and TCHT_ONITEMLABEL) <> 0 then
  4161.             Include(Result, htOnLabel);
  4162.         end;
  4163.       end
  4164.       else
  4165.         Result := [htNowhere];
  4166.     end;
  4167. end;
  4168.  
  4169. function TCustomTabControl.TabRect(Index: Integer): TRect;
  4170. begin
  4171.   TabCtrl_GetItemRect(Handle, Index, Result);
  4172. end;
  4173.  
  4174. function TCustomTabControl.RowCount: Integer;
  4175. begin
  4176.   Result := TabCtrl_GetRowCount(Handle);
  4177. end;
  4178.  
  4179. procedure TCustomTabControl.ScrollTabs(Delta: Integer);
  4180. var
  4181.   Wnd: HWND;
  4182.   P: TPoint;
  4183.   Rect: TRect;
  4184.   I: Integer;
  4185. begin
  4186.   Wnd := FindWindowEx(Handle, 0, 'msctls_updown32', nil);
  4187.   if Wnd <> 0 then
  4188.   begin
  4189.     Windows.GetClientRect(Wnd, Rect);
  4190.     if Delta < 0 then
  4191.       P.X := Rect.Left + 2
  4192.     else
  4193.       P.X := Rect.Right - 2;
  4194.     P.Y := Rect.Top + 2;
  4195.     for I := 0 to Abs(Delta) - 1 do
  4196.     begin
  4197.       SendMessage(Wnd, WM_LBUTTONDOWN, 0, MakeLParam(P.X, P.Y));
  4198.       SendMessage(Wnd, WM_LBUTTONUP, 0, MakeLParam(P.X, P.Y));
  4199.     end;
  4200.   end;
  4201. end;
  4202.  
  4203. { TTabSheet }
  4204.  
  4205. constructor TTabSheet.Create(AOwner: TComponent);
  4206. begin
  4207.   inherited Create(AOwner);
  4208.   Align := alClient;
  4209.   ControlStyle := ControlStyle + [csAcceptsControls, csNoDesignVisible];
  4210.   Visible := False;
  4211.   FTabVisible := True;
  4212.   FHighlighted := False;
  4213. end;
  4214.  
  4215. destructor TTabSheet.Destroy;
  4216. begin
  4217.   if FPageControl <> nil then
  4218.   begin
  4219.     if FPageControl.FUndockingPage = Self then FPageControl.FUndockingPage := nil;
  4220.     FPageControl.RemovePage(Self);
  4221.   end;
  4222.   inherited Destroy;
  4223. end;
  4224.  
  4225. procedure TTabSheet.DoHide;
  4226. begin
  4227.   if Assigned(FOnHide) then FOnHide(Self);
  4228. end;
  4229.  
  4230. procedure TTabSheet.DoShow;
  4231. begin
  4232.   if Assigned(FOnShow) then FOnShow(Self);
  4233. end;
  4234.  
  4235. function TTabSheet.GetPageIndex: Integer;
  4236. begin
  4237.   if FPageControl <> nil then
  4238.     Result := FPageControl.FPages.IndexOf(Self) else
  4239.     Result := -1;
  4240. end;
  4241.  
  4242. function TTabSheet.GetTabIndex: Integer;
  4243. var
  4244.   I: Integer;
  4245. begin
  4246.   Result := 0;
  4247.   if not FTabShowing then Dec(Result) else
  4248.     for I := 0 to PageIndex - 1 do
  4249.       if TTabSheet(FPageControl.FPages[I]).FTabShowing then
  4250.         Inc(Result);
  4251. end;
  4252.  
  4253. procedure TTabSheet.CreateParams(var Params: TCreateParams);
  4254. begin
  4255.   inherited CreateParams(Params);
  4256.   with Params.WindowClass do
  4257.     style := style and not (CS_HREDRAW or CS_VREDRAW);
  4258. end;
  4259.  
  4260. procedure TTabSheet.ReadState(Reader: TReader);
  4261. begin
  4262.   inherited ReadState(Reader);
  4263.   if Reader.Parent is TPageControl then
  4264.     PageControl := TPageControl(Reader.Parent);
  4265. end;
  4266.  
  4267. procedure TTabSheet.SetImageIndex(Value: TImageIndex);
  4268. begin
  4269.   if FImageIndex <> Value then
  4270.   begin
  4271.     FImageIndex := Value;
  4272.     if FTabShowing then FPageControl.UpdateTab(Self);
  4273.   end;
  4274. end;
  4275.  
  4276. procedure TTabSheet.SetPageControl(APageControl: TPageControl);
  4277. begin
  4278.   if FPageControl <> APageControl then
  4279.   begin
  4280.     if FPageControl <> nil then FPageControl.RemovePage(Self);
  4281.     Parent := APageControl;
  4282.     if APageControl <> nil then APageControl.InsertPage(Self);
  4283.   end;
  4284. end;
  4285.  
  4286. procedure TTabSheet.SetPageIndex(Value: Integer);
  4287. var
  4288.   I, MaxPageIndex: Integer;
  4289. begin
  4290.   if FPageControl <> nil then
  4291.   begin
  4292.     MaxPageIndex := FPageControl.FPages.Count - 1;
  4293.     if Value > MaxPageIndex then
  4294.       raise EListError.CreateResFmt(@SPageIndexError, [Value, MaxPageIndex]);
  4295.     I := TabIndex;
  4296.     FPageControl.FPages.Move(PageIndex, Value);
  4297.     if I >= 0 then FPageControl.MoveTab(I, TabIndex);
  4298.   end;
  4299. end;
  4300.  
  4301. procedure TTabSheet.SetTabShowing(Value: Boolean);
  4302. var
  4303.   Index: Integer;
  4304. begin
  4305.   if FTabShowing <> Value then
  4306.     if Value then
  4307.     begin
  4308.       FTabShowing := True;
  4309.       FPageControl.InsertTab(Self);
  4310.     end else
  4311.     begin
  4312.       Index := TabIndex;
  4313.       FTabShowing := False;
  4314.       FPageControl.DeleteTab(Self, Index);
  4315.     end;
  4316. end;
  4317.  
  4318. procedure TTabSheet.SetTabVisible(Value: Boolean);
  4319. begin
  4320.   if FTabVisible <> Value then
  4321.   begin
  4322.     FTabVisible := Value;
  4323.     UpdateTabShowing;
  4324.   end;
  4325. end;
  4326.  
  4327. procedure TTabSheet.UpdateTabShowing;
  4328. begin
  4329.   SetTabShowing((FPageControl <> nil) and FTabVisible);
  4330. end;
  4331.  
  4332. procedure TTabSheet.CMTextChanged(var Message: TMessage);
  4333. begin
  4334.   if FTabShowing then FPageControl.UpdateTab(Self);
  4335. end;
  4336.  
  4337. procedure TTabSheet.CMShowingChanged(var Message: TMessage);
  4338. begin
  4339.   inherited;
  4340.   if Showing then
  4341.   begin
  4342.     try
  4343.       DoShow
  4344.     except
  4345.       Application.HandleException(Self);
  4346.     end;
  4347.   end else if not Showing then
  4348.   begin
  4349.     try
  4350.       DoHide;
  4351.     except
  4352.       Application.HandleException(Self);
  4353.     end;
  4354.   end;
  4355. end;
  4356.  
  4357. procedure TTabSheet.SetHighlighted(Value: Boolean);
  4358. begin
  4359.   if not (csReading in ComponentState) then
  4360.     SendMessage(PageControl.Handle, TCM_HIGHLIGHTITEM, TabIndex,
  4361.       MakeLong(Word(Value), 0));
  4362.   FHighlighted := Value;
  4363. end;
  4364.  
  4365.  
  4366. { TPageControl }
  4367.  
  4368. constructor TPageControl.Create(AOwner: TComponent);
  4369. begin
  4370.   inherited Create(AOwner);
  4371.   ControlStyle := [csDoubleClicks, csOpaque];
  4372.   FPages := TList.Create;
  4373. end;
  4374.  
  4375. destructor TPageControl.Destroy;
  4376. var
  4377.   I: Integer;
  4378. begin
  4379.   for I := 0 to FPages.Count - 1 do TTabSheet(FPages[I]).FPageControl := nil;
  4380.   FPages.Free;
  4381.   inherited Destroy;
  4382. end;
  4383.  
  4384. procedure TPageControl.UpdateTabHighlights;
  4385. var
  4386.   I: Integer;
  4387. begin
  4388.   for I := 0 to PageCount - 1 do
  4389.     Pages[I].SetHighlighted(Pages[I].FHighlighted);
  4390. end;
  4391.  
  4392. procedure TPageControl.Loaded;
  4393. begin
  4394.   inherited Loaded;
  4395.   UpdateTabHighlights;
  4396. end;
  4397.  
  4398.  
  4399. function TPageControl.CanShowTab(TabIndex: Integer): Boolean;
  4400. begin
  4401.   Result := TTabSheet(FPages[TabIndex]).Enabled;
  4402. end;
  4403.  
  4404. procedure TPageControl.Change;
  4405. var
  4406.   Form: TCustomForm;
  4407. begin
  4408.   UpdateActivePage;
  4409.   if csDesigning in ComponentState then
  4410.   begin
  4411.     Form := GetParentForm(Self);
  4412.     if (Form <> nil) and (Form.Designer <> nil) then Form.Designer.Modified;
  4413.   end;
  4414.   inherited Change;
  4415. end;
  4416.  
  4417. procedure TPageControl.ChangeActivePage(Page: TTabSheet);
  4418. var
  4419.   ParentForm: TCustomForm;
  4420. begin
  4421.   if FActivePage <> Page then
  4422.   begin
  4423.     ParentForm := GetParentForm(Self);
  4424.     if (ParentForm <> nil) and (FActivePage <> nil) and
  4425.       FActivePage.ContainsControl(ParentForm.ActiveControl) then
  4426.     begin
  4427.       ParentForm.ActiveControl := FActivePage;
  4428.       if ParentForm.ActiveControl <> FActivePage then
  4429.       begin
  4430.         TabIndex := FActivePage.TabIndex;
  4431.         Exit;
  4432.       end;
  4433.     end;
  4434.     if Page <> nil then
  4435.     begin
  4436.       Page.BringToFront;
  4437.       Page.Visible := True;
  4438.       if (ParentForm <> nil) and (FActivePage <> nil) and
  4439.         (ParentForm.ActiveControl = FActivePage) then
  4440.         if Page.CanFocus then
  4441.           ParentForm.ActiveControl := Page else
  4442.           ParentForm.ActiveControl := Self;
  4443.     end;
  4444.     if FActivePage <> nil then FActivePage.Visible := False;
  4445.     FActivePage := Page;
  4446.     if (ParentForm <> nil) and (FActivePage <> nil) and
  4447.       (ParentForm.ActiveControl = FActivePage) then
  4448.       FActivePage.SelectFirst;
  4449.   end;
  4450. end;
  4451.  
  4452. procedure TPageControl.DeleteTab(Page: TTabSheet; Index: Integer);
  4453. var
  4454.   UpdateIndex: Boolean;
  4455. begin
  4456.   UpdateIndex := Page = ActivePage;
  4457.   Tabs.Delete(Index);
  4458.   if UpdateIndex then
  4459.   begin
  4460.     if Index >= Tabs.Count then
  4461.       Index := Tabs.Count - 1;
  4462.     TabIndex := Index;
  4463.   end;
  4464.   UpdateActivePage;
  4465. end;
  4466.  
  4467. procedure TPageControl.DoAddDockClient(Client: TControl; const ARect: TRect);
  4468. begin
  4469.   if FNewDockSheet <> nil then Client.Parent := FNewDockSheet;
  4470. end;
  4471.  
  4472. procedure TPageControl.DockOver(Source: TDragDockObject; X, Y: Integer;
  4473.   State: TDragState; var Accept: Boolean);
  4474. var
  4475.   R: TRect;
  4476. begin
  4477.   GetWindowRect(Handle, R);
  4478.   Source.DockRect := R;
  4479.   DoDockOver(Source, X, Y, State, Accept);
  4480. end;
  4481.  
  4482. procedure TPageControl.DoRemoveDockClient(Client: TControl);
  4483. begin
  4484.   if (FUndockingPage <> nil) and not (csDestroying in ComponentState) then
  4485.   begin
  4486.     SelectNextPage(True);
  4487.     FUndockingPage.Free;
  4488.     FUndockingPage := nil;
  4489.   end;
  4490. end;
  4491.  
  4492. function TPageControl.FindNextPage(CurPage: TTabSheet;
  4493.   GoForward, CheckTabVisible: Boolean): TTabSheet;
  4494. var
  4495.   I, StartIndex: Integer;
  4496. begin
  4497.   if FPages.Count <> 0 then
  4498.   begin
  4499.     StartIndex := FPages.IndexOf(CurPage);
  4500.     if StartIndex = -1 then
  4501.       if GoForward then StartIndex := FPages.Count - 1 else StartIndex := 0;
  4502.     I := StartIndex;
  4503.     repeat
  4504.       if GoForward then
  4505.       begin
  4506.         Inc(I);
  4507.         if I = FPages.Count then I := 0;
  4508.       end else
  4509.       begin
  4510.         if I = 0 then I := FPages.Count;
  4511.         Dec(I);
  4512.       end;
  4513.       Result := FPages[I];
  4514.       if not CheckTabVisible or Result.TabVisible then Exit;
  4515.     until I = StartIndex;
  4516.   end;
  4517.   Result := nil;
  4518. end;
  4519.  
  4520. procedure TPageControl.GetChildren(Proc: TGetChildProc; Root: TComponent);
  4521. var
  4522.   I: Integer;
  4523. begin
  4524.   for I := 0 to FPages.Count - 1 do Proc(TComponent(FPages[I]));
  4525. end;
  4526.  
  4527. function TPageControl.GetImageIndex(TabIndex: Integer): Integer;
  4528. var
  4529.   I,
  4530.   Visible,
  4531.   NotVisible: Integer;
  4532. begin
  4533.   if Assigned(FOnGetImageIndex) then
  4534.     Result := inherited GetImageIndex(TabIndex) else
  4535.     begin
  4536.      { For a PageControl, TabIndex refers to visible tabs only. The control
  4537.      doesn't store }
  4538.       Visible := 0;
  4539.       NotVisible := 0;
  4540.       for I := 0 to FPages.Count - 1 do
  4541.       begin
  4542.         if not GetPage(I).TabVisible then Inc(NotVisible)
  4543.         else Inc(Visible);
  4544.         if Visible = TabIndex + 1 then Break;
  4545.       end;
  4546.       Result := GetPage(TabIndex + NotVisible).ImageIndex;
  4547.     end;
  4548. end;
  4549.  
  4550. function TPageControl.GetPageFromDockClient(Client: TControl): TTabSheet;
  4551. var
  4552.   I: Integer;
  4553. begin
  4554.   Result := nil;
  4555.   for I := 0 to PageCount - 1 do
  4556.   begin
  4557.     if (Client.Parent = Pages[I]) and (Client.HostDockSite = Self) then
  4558.     begin
  4559.       Result := Pages[I];
  4560.       Exit;
  4561.     end;
  4562.   end;
  4563. end;
  4564.  
  4565. function TPageControl.GetPage(Index: Integer): TTabSheet;
  4566. begin
  4567.   Result := FPages[Index];
  4568. end;
  4569.  
  4570. function TPageControl.GetPageCount: Integer;
  4571. begin
  4572.   Result := FPages.Count;
  4573. end;
  4574.  
  4575. procedure TPageControl.GetSiteInfo(Client: TControl; var InfluenceRect: TRect;
  4576.   MousePos: TPoint; var CanDock: Boolean);
  4577. begin
  4578.   CanDock := GetPageFromDockClient(Client) = nil;
  4579.   inherited GetSiteInfo(Client, InfluenceRect, MousePos, CanDock);
  4580. end;
  4581.  
  4582. procedure TPageControl.InsertPage(Page: TTabSheet);
  4583. begin
  4584.   FPages.Add(Page);
  4585.   Page.FPageControl := Self;
  4586.   Page.UpdateTabShowing;
  4587. end;
  4588.  
  4589. procedure TPageControl.InsertTab(Page: TTabSheet);
  4590. begin
  4591.   Tabs.InsertObject(Page.TabIndex, Page.Caption, Page);
  4592.   UpdateActivePage;
  4593. end;
  4594.  
  4595. procedure TPageControl.MoveTab(CurIndex, NewIndex: Integer);
  4596. begin
  4597.   Tabs.Move(CurIndex, NewIndex);
  4598. end;
  4599.  
  4600. procedure TPageControl.RemovePage(Page: TTabSheet);
  4601. var
  4602.   NextSheet: TTabSheet;
  4603. begin
  4604.   NextSheet := FindNextPage(Page, True, not (csDesigning in ComponentState));
  4605.   if NextSheet = Page then NextSheet := nil;
  4606.   Page.SetTabShowing(False);
  4607.   Page.FPageControl := nil;
  4608.   FPages.Remove(Page);
  4609.   SetActivePage(NextSheet);
  4610. end;
  4611.  
  4612. procedure TPageControl.SelectNextPage(GoForward: Boolean);
  4613. var
  4614.   Page: TTabSheet;
  4615. begin
  4616.   Page := FindNextPage(ActivePage, GoForward, True);
  4617.   if (Page <> nil) and (Page <> ActivePage) and CanChange then
  4618.   begin
  4619.     TabIndex := Page.TabIndex;
  4620.     Change;
  4621.   end;
  4622. end;
  4623.  
  4624. procedure TPageControl.SetActivePage(Page: TTabSheet);
  4625. begin
  4626.   if (Page <> nil) and (Page.PageControl <> Self) then Exit;
  4627.   ChangeActivePage(Page);
  4628.   if Page = nil then
  4629.     TabIndex := -1
  4630.   else if Page = FActivePage then
  4631.     TabIndex := Page.TabIndex;
  4632. end;
  4633.  
  4634. procedure TPageControl.SetChildOrder(Child: TComponent; Order: Integer);
  4635. begin
  4636.   TTabSheet(Child).PageIndex := Order;
  4637. end;
  4638.  
  4639. procedure TPageControl.ShowControl(AControl: TControl);
  4640. begin
  4641.   if (AControl is TTabSheet) and (TTabSheet(AControl).PageControl = Self) then
  4642.     SetActivePage(TTabSheet(AControl));
  4643.   inherited ShowControl(AControl);
  4644. end;
  4645.  
  4646. procedure TPageControl.UpdateTab(Page: TTabSheet);
  4647. begin
  4648.   Tabs[Page.TabIndex] := Page.Caption;
  4649. end;
  4650.  
  4651. procedure TPageControl.UpdateActivePage;
  4652. begin
  4653.   if TabIndex >= 0 then
  4654.     SetActivePage(TTabSheet(Tabs.Objects[TabIndex]))
  4655.   else
  4656.     SetActivePage(nil);
  4657. end;
  4658.  
  4659. procedure TPageControl.CMDesignHitTest(var Message: TCMDesignHitTest);
  4660. var
  4661.   HitIndex: Integer;
  4662.   HitTestInfo: TTCHitTestInfo;
  4663. begin
  4664.   HitTestInfo.pt := SmallPointToPoint(Message.Pos);
  4665.   HitIndex := SendMessage(Handle, TCM_HITTEST, 0, Longint(@HitTestInfo));
  4666.   if (HitIndex >= 0) and (HitIndex <> TabIndex) then Message.Result := 1;
  4667. end;
  4668.  
  4669. procedure TPageControl.CMDialogKey(var Message: TCMDialogKey);
  4670. begin
  4671.   if (Focused or Windows.IsChild(Handle, Windows.GetFocus)) and
  4672.     (Message.CharCode = VK_TAB) and (GetKeyState(VK_CONTROL) < 0) then
  4673.   begin
  4674.     SelectNextPage(GetKeyState(VK_SHIFT) >= 0);
  4675.     Message.Result := 1;
  4676.   end else
  4677.     inherited;
  4678. end;
  4679.  
  4680. procedure TPageControl.CMDockClient(var Message: TCMDockClient);
  4681. var
  4682.   IsVisible: Boolean;
  4683.   DockCtl: TControl;
  4684. begin
  4685.   Message.Result := 0;
  4686.   FNewDockSheet := TTabSheet.Create(Self);
  4687.   try
  4688.     try
  4689.       DockCtl := Message.DockSource.Control;
  4690.       if DockCtl is TCustomForm then
  4691.         FNewDockSheet.Caption := TCustomForm(DockCtl).Caption;
  4692.       FNewDockSheet.PageControl := Self;
  4693.       DockCtl.Dock(Self, Message.DockSource.DockRect);
  4694.     except
  4695.       FNewDockSheet.Free;
  4696.       raise;
  4697.     end;
  4698.     IsVisible := DockCtl.Visible;
  4699.     FNewDockSheet.TabVisible := IsVisible;
  4700.     if IsVisible then ActivePage := FNewDockSheet;
  4701.     DockCtl.Align := alClient;
  4702.   finally
  4703.     FNewDockSheet := nil;
  4704.   end;
  4705. end;
  4706.  
  4707. procedure TPageControl.CMDockNotification(var Message: TCMDockNotification);
  4708. var
  4709.   I: Integer;
  4710.   S: string;
  4711.   Page: TTabSheet;
  4712. begin
  4713.   Page := GetPageFromDockClient(Message.Client);
  4714.   if Page <> nil then
  4715.     case Message.NotifyRec.ClientMsg of
  4716.       WM_SETTEXT:
  4717.         begin
  4718.           S := PChar(Message.NotifyRec.MsgLParam);
  4719.           { Search for first CR/LF and end string there }
  4720.           for I := 1 to Length(S) do
  4721.             if S[I] in [#13, #10] then
  4722.             begin
  4723.               SetLength(S, I - 1);
  4724.               Break;
  4725.             end;
  4726.           Page.Caption := S;
  4727.         end;
  4728.       CM_VISIBLECHANGED:
  4729.         Page.TabVisible := Boolean(Message.NotifyRec.MsgWParam);
  4730.     end;
  4731.   inherited;
  4732. end;
  4733.  
  4734. procedure TPageControl.CMUnDockClient(var Message: TCMUnDockClient);
  4735. var
  4736.   Page: TTabSheet;
  4737. begin
  4738.   Message.Result := 0;
  4739.   Page := GetPageFromDockClient(Message.Client);
  4740.   if Page <> nil then
  4741.   begin
  4742.     FUndockingPage := Page;
  4743.     Message.Client.Align := alNone;
  4744.   end;
  4745. end;
  4746.  
  4747. function TPageControl.GetDockClientFromMousePos(MousePos: TPoint): TControl;
  4748. var
  4749.   i, HitIndex: Integer;
  4750.   HitTestInfo: TTCHitTestInfo;
  4751.   Page: TTabSheet;
  4752. begin
  4753.   Result := nil;
  4754.   if DockSite then
  4755.   begin
  4756.     HitTestInfo.pt := MousePos;
  4757.     HitIndex := SendMessage(Handle, TCM_HITTEST, 0, Longint(@HitTestInfo));
  4758.     if HitIndex >= 0 then
  4759.     begin
  4760.       Page := nil;
  4761.       for i := 0 to HitIndex do
  4762.         Page := FindNextPage(Page, True, True);
  4763.       if (Page <> nil) and (Page.ControlCount > 0) then
  4764.       begin
  4765.         Result := Page.Controls[0];
  4766.         if Result.HostDockSite <> Self then Result := nil;
  4767.       end;
  4768.     end;
  4769.   end;
  4770. end;
  4771.  
  4772. procedure TPageControl.WMLButtonDown(var Message: TWMLButtonDown);
  4773. var
  4774.   DockCtl: TControl;
  4775. begin
  4776.   inherited;
  4777.   DockCtl := GetDockClientFromMousePos(SmallPointToPoint(Message.Pos));
  4778.   if (DockCtl <> nil) and (Style = tsTabs) then DockCtl.BeginDrag(False);
  4779. end;
  4780.  
  4781. procedure TPageControl.WMLButtonDblClk(var Message: TWMLButtonDblClk);
  4782. var
  4783.   DockCtl: TControl;
  4784. begin
  4785.   inherited;
  4786.   DockCtl := GetDockClientFromMousePos(SmallPointToPoint(Message.Pos));
  4787.   if DockCtl <> nil then DockCtl.ManualDock(nil, nil, alNone);
  4788. end;
  4789.  
  4790. function TPageControl.GetActivePageIndex: Integer;
  4791. begin
  4792.   if ActivePage <> nil then
  4793.     Result := ActivePage.GetPageIndex
  4794.   else
  4795.     Result := -1;
  4796. end;
  4797.  
  4798. procedure TPageControl.SetActivePageIndex(const Value: Integer);
  4799. begin
  4800.   if (Value > -1) and (Value < PageCount) then
  4801.     ActivePage := Pages[Value]
  4802.   else
  4803.     ActivePage := nil;
  4804. end;
  4805.  
  4806. { TStatusPanel }
  4807.  
  4808. constructor TStatusPanel.Create(Collection: TCollection);
  4809. begin
  4810.   FWidth := 50;
  4811.   FBevel := pbLowered;
  4812.   FParentBiDiMode := True;
  4813.   inherited Create(Collection);
  4814.   ParentBiDiModeChanged;
  4815. end;
  4816.  
  4817. procedure TStatusPanel.Assign(Source: TPersistent);
  4818. begin
  4819.   if Source is TStatusPanel then
  4820.   begin
  4821.     Text := TStatusPanel(Source).Text;
  4822.     Width := TStatusPanel(Source).Width;
  4823.     Alignment := TStatusPanel(Source).Alignment;
  4824.     Bevel := TStatusPanel(Source).Bevel;
  4825.     Style := TStatusPanel(Source).Style;
  4826.   end
  4827.   else inherited Assign(Source);
  4828. end;
  4829.  
  4830. procedure TStatusPanel.SetBiDiMode(Value: TBiDiMode);
  4831. begin
  4832.   if Value <> FBiDiMode then
  4833.   begin
  4834.     FBiDiMode := Value;
  4835.     FParentBiDiMode := False;
  4836.     Changed(False);
  4837.   end;
  4838. end;
  4839.  
  4840. function TStatusPanel.IsBiDiModeStored: Boolean;
  4841. begin
  4842.   Result := not FParentBiDiMode;
  4843. end;
  4844.  
  4845. procedure TStatusPanel.SetParentBiDiMode(Value: Boolean);
  4846. begin
  4847.   if FParentBiDiMode <> Value then
  4848.   begin
  4849.     FParentBiDiMode := Value;
  4850.     ParentBiDiModeChanged;
  4851.   end;
  4852. end;
  4853.  
  4854. procedure TStatusPanel.ParentBiDiModeChanged;
  4855. begin
  4856.   if FParentBiDiMode then
  4857.   begin
  4858.     if GetOwner <> nil then
  4859.     begin
  4860.       BiDiMode := TStatusPanels(GetOwner).FStatusBar.BiDiMode;
  4861.       FParentBiDiMode := True;
  4862.     end;
  4863.   end;
  4864. end;
  4865.  
  4866. function TStatusPanel.UseRightToLeftReading: Boolean;
  4867. begin
  4868.   Result := SysLocale.MiddleEast and (BiDiMode <> bdLeftToRight);
  4869. end;
  4870.  
  4871. function TStatusPanel.UseRightToLeftAlignment: Boolean;
  4872. begin
  4873.   Result := SysLocale.MiddleEast and (BiDiMode = bdRightToLeft);
  4874. end;
  4875.  
  4876. function TStatusPanel.GetDisplayName: string;
  4877. begin
  4878.   Result := Text;
  4879.   if Result = '' then Result := inherited GetDisplayName;
  4880. end;
  4881.  
  4882. procedure TStatusPanel.SetAlignment(Value: TAlignment);
  4883. begin
  4884.   if FAlignment <> Value then
  4885.   begin
  4886.     FAlignment := Value;
  4887.     Changed(False);
  4888.   end;
  4889. end;
  4890.  
  4891. procedure TStatusPanel.SetBevel(Value: TStatusPanelBevel);
  4892. begin
  4893.   if FBevel <> Value then
  4894.   begin
  4895.     FBevel := Value;
  4896.     Changed(False);
  4897.   end;
  4898. end;
  4899.  
  4900. procedure TStatusPanel.SetStyle(Value: TStatusPanelStyle);
  4901. begin
  4902.   if FStyle <> Value then
  4903.   begin
  4904.     FStyle := Value;
  4905.     Changed(False);
  4906.   end;
  4907. end;
  4908.  
  4909. procedure TStatusPanel.SetText(const Value: string);
  4910. begin
  4911.   if FText <> Value then
  4912.   begin
  4913.     FText := Value;
  4914.     Changed(False);
  4915.   end;
  4916. end;
  4917.  
  4918. procedure TStatusPanel.SetWidth(Value: Integer);
  4919. begin
  4920.   if FWidth <> Value then
  4921.   begin
  4922.     FWidth := Value;
  4923.     Changed(True);
  4924.   end;
  4925. end;
  4926.  
  4927. { TStatusPanels }
  4928.  
  4929. constructor TStatusPanels.Create(StatusBar: TStatusBar);
  4930. begin
  4931.   inherited Create(TStatusPanel);
  4932.   FStatusBar := StatusBar;
  4933. end;
  4934.  
  4935. function TStatusPanels.Add: TStatusPanel;
  4936. begin
  4937.   Result := TStatusPanel(inherited Add);
  4938. end;
  4939.  
  4940. function TStatusPanels.GetItem(Index: Integer): TStatusPanel;
  4941. begin
  4942.   Result := TStatusPanel(inherited GetItem(Index));
  4943. end;
  4944.  
  4945. function TStatusPanels.GetOwner: TPersistent;
  4946. begin
  4947.   Result := FStatusBar;
  4948. end;
  4949.  
  4950. procedure TStatusPanels.SetItem(Index: Integer; Value: TStatusPanel);
  4951. begin
  4952.   inherited SetItem(Index, Value);
  4953. end;
  4954.  
  4955. procedure TStatusPanels.Update(Item: TCollectionItem);
  4956. begin
  4957.   if Item <> nil then
  4958.     FStatusBar.UpdatePanel(Item.Index, False) else
  4959.     FStatusBar.UpdatePanels(True, False);
  4960. end;
  4961.  
  4962. { TStatusBar }
  4963.  
  4964. constructor TStatusBar.Create(AOwner: TComponent);
  4965. begin
  4966.   inherited Create(AOwner);
  4967.   ControlStyle := [csCaptureMouse, csClickEvents, csDoubleClicks, csOpaque];
  4968.   Color := clBtnFace;
  4969.   Height := 19;
  4970.   Align := alBottom;
  4971.   FPanels := TStatusPanels.Create(Self);
  4972.   FCanvas := TControlCanvas.Create;
  4973.   TControlCanvas(FCanvas).Control := Self;
  4974.   FSizeGrip := True;
  4975.   ParentFont := False;
  4976.   FUseSystemFont := True;
  4977.   SyncToSystemFont;
  4978. end;
  4979.  
  4980. destructor TStatusBar.Destroy;
  4981. begin
  4982.   FCanvas.Free;
  4983.   FPanels.Free;
  4984.   inherited Destroy;
  4985. end;
  4986.  
  4987. procedure TStatusBar.CreateParams(var Params: TCreateParams);
  4988. const
  4989.   GripStyles: array[Boolean] of DWORD = (CCS_TOP, SBARS_SIZEGRIP);
  4990. begin
  4991.   InitCommonControl(ICC_BAR_CLASSES);
  4992.   inherited CreateParams(Params);
  4993.   CreateSubClass(Params, STATUSCLASSNAME);
  4994.   with Params do
  4995.   begin
  4996.     Style := Style or GripStyles[FSizeGrip and (Parent is TCustomForm) and
  4997.       (TCustomForm(Parent).BorderStyle in [bsSizeable, bsSizeToolWin])];
  4998.     WindowClass.style := WindowClass.style and not CS_HREDRAW;
  4999.   end;
  5000. end;
  5001.  
  5002. procedure TStatusBar.CreateWnd;
  5003. begin
  5004.   inherited CreateWnd;
  5005.   SendMessage(Handle, SB_SETBKCOLOR, 0, ColorToRGB(Color));
  5006.   UpdatePanels(True, False);
  5007.   if FSimpleText <> '' then
  5008.     SendMessage(Handle, SB_SETTEXT, 255, Integer(PChar(FSimpleText)));
  5009.   if FSimplePanel then
  5010.     SendMessage(Handle, SB_SIMPLE, 1, 0);
  5011. end;
  5012.  
  5013. function TStatusBar.DoHint: Boolean;
  5014. begin
  5015.   if Assigned(FOnHint) then
  5016.   begin
  5017.     FOnHint(Self);
  5018.     Result := True;
  5019.   end
  5020.   else Result := False;
  5021. end;
  5022.  
  5023. procedure TStatusBar.DrawPanel(Panel: TStatusPanel; const Rect: TRect);
  5024. begin
  5025.   if Assigned(FOnDrawPanel) then
  5026.     FOnDrawPanel(Self, Panel, Rect) else
  5027.     FCanvas.FillRect(Rect);
  5028. end;
  5029.  
  5030. procedure TStatusBar.SetPanels(Value: TStatusPanels);
  5031. begin
  5032.   FPanels.Assign(Value);
  5033. end;
  5034.  
  5035. procedure TStatusBar.SetSimplePanel(Value: Boolean);
  5036. begin
  5037.   if FSimplePanel <> Value then
  5038.   begin
  5039.     FSimplePanel := Value;
  5040.     if HandleAllocated then
  5041.       SendMessage(Handle, SB_SIMPLE, Ord(FSimplePanel), 0);
  5042.   end;
  5043. end;
  5044.  
  5045. procedure TStatusBar.DoRightToLeftAlignment(var Str: string;
  5046.   AAlignment: TAlignment; ARTLAlignment: Boolean);
  5047. begin
  5048.   if ARTLAlignment then ChangeBiDiModeAlignment(AAlignment);
  5049.  
  5050.   case AAlignment of
  5051.     taCenter: Insert(#9, Str, 1);
  5052.     taRightJustify: Insert(#9#9, Str, 1);
  5053.   end;
  5054. end;
  5055.  
  5056. procedure TStatusBar.UpdateSimpleText;
  5057. const
  5058.   RTLReading: array[Boolean] of Longint = (0, SBT_RTLREADING);
  5059. begin
  5060.   DoRightToLeftAlignment(FSimpleText, taLeftJustify, UseRightToLeftAlignment);
  5061.   if HandleAllocated then
  5062.     SendMessage(Handle, SB_SETTEXT, 255 or RTLREADING[UseRightToLeftReading],
  5063.       Integer(PChar(FSimpleText)));
  5064. end;
  5065.  
  5066. procedure TStatusBar.SetSimpleText(const Value: string);
  5067. begin
  5068.   if FSimpleText <> Value then
  5069.   begin
  5070.     FSimpleText := Value;
  5071.     UpdateSimpleText;
  5072.   end;
  5073. end;
  5074.  
  5075. procedure TStatusBar.CMBiDiModeChanged(var Message: TMessage);
  5076. var
  5077.   Loop: Integer;
  5078. begin
  5079.   inherited;
  5080.   if HandleAllocated then
  5081.     if not SimplePanel then
  5082.     begin
  5083.       for Loop := 0 to Panels.Count - 1 do
  5084.         if Panels[Loop].ParentBiDiMode then
  5085.           Panels[Loop].ParentBiDiModeChanged;
  5086.       UpdatePanels(True, True);
  5087.     end
  5088.     else
  5089.       UpdateSimpleText;
  5090. end;
  5091.  
  5092. procedure TStatusBar.FlipChildren(AllLevels: Boolean);
  5093. var
  5094.   Loop, FirstWidth, LastWidth: Integer;
  5095.   APanels: TStatusPanels;
  5096. begin
  5097.   if HandleAllocated and
  5098.      (not SimplePanel) and (Panels.Count > 0) then
  5099.   begin
  5100.     { Get the true width of the last panel }
  5101.     LastWidth := ClientWidth;
  5102.     FirstWidth := Panels[0].Width;
  5103.     for Loop := 0 to Panels.Count - 2 do Dec(LastWidth, Panels[Loop].Width);
  5104.     { Flip 'em }
  5105.     APanels := TStatusPanels.Create(Self);
  5106.     try
  5107.       for Loop := 0 to Panels.Count - 1 do with APanels.Add do
  5108.         Assign(Self.Panels[Loop]);
  5109.       for Loop := 0 to Panels.Count - 1 do
  5110.         Panels[Loop].Assign(APanels[Panels.Count - Loop - 1]);
  5111.     finally
  5112.       APanels.Free;
  5113.     end;
  5114.     { Set the width of the last panel }
  5115.     if Panels.Count > 1 then
  5116.     begin
  5117.       Panels[Panels.Count-1].Width := FirstWidth;
  5118.       Panels[0].Width := LastWidth;
  5119.     end;
  5120.     UpdatePanels(True, True);
  5121.   end;
  5122. end;
  5123.  
  5124. procedure TStatusBar.SetSizeGrip(Value: Boolean);
  5125. begin
  5126.   if FSizeGrip <> Value then
  5127.   begin
  5128.     FSizeGrip := Value;
  5129.     RecreateWnd;
  5130.   end;
  5131. end;
  5132.  
  5133. procedure TStatusBar.SyncToSystemFont;
  5134. begin
  5135.   if FUseSystemFont then
  5136.     Font := Screen.HintFont;
  5137. end;
  5138.  
  5139. procedure TStatusBar.UpdatePanel(Index: Integer; Repaint: Boolean);
  5140. var
  5141.   Flags: Integer;
  5142.   S: string;
  5143.   PanelRect: TRect;
  5144. begin
  5145.   if HandleAllocated then
  5146.     with Panels[Index] do
  5147.     begin
  5148.       if not Repaint then
  5149.       begin
  5150.         FUpdateNeeded := True;
  5151.         SendMessage(Handle, SB_GETRECT, Index, Integer(@PanelRect));
  5152.         InvalidateRect(Handle, @PanelRect, True);
  5153.         Exit;
  5154.       end
  5155.       else if not FUpdateNeeded then Exit;
  5156.       FUpdateNeeded := False;
  5157.       Flags := 0;
  5158.       case Bevel of
  5159.         pbNone: Flags := SBT_NOBORDERS;
  5160.         pbRaised: Flags := SBT_POPOUT;
  5161.       end;
  5162.       if UseRightToLeftReading then Flags := Flags or SBT_RTLREADING;
  5163.       if Style = psOwnerDraw then Flags := Flags or SBT_OWNERDRAW;
  5164.       S := Text;
  5165.       if UseRightToLeftAlignment then
  5166.         DoRightToLeftAlignment(S, Alignment, UseRightToLeftAlignment)
  5167.       else
  5168.         case Alignment of
  5169.           taCenter: Insert(#9, S, 1);
  5170.           taRightJustify: Insert(#9#9, S, 1);
  5171.         end;
  5172.       SendMessage(Handle, SB_SETTEXT, Index or Flags, Integer(PChar(S)));
  5173.     end;
  5174. end;
  5175.  
  5176. procedure TStatusBar.UpdatePanels(UpdateRects, UpdateText: Boolean);
  5177. const
  5178.   MaxPanelCount = 128;
  5179. var
  5180.   I, Count, PanelPos: Integer;
  5181.   PanelEdges: array[0..MaxPanelCount - 1] of Integer;
  5182. begin
  5183.   if HandleAllocated then
  5184.   begin
  5185.     Count := Panels.Count;
  5186.     if UpdateRects then
  5187.     begin
  5188.       if Count > MaxPanelCount then Count := MaxPanelCount;
  5189.       if Count = 0 then
  5190.       begin
  5191.         PanelEdges[0] := -1;
  5192.         SendMessage(Handle, SB_SETPARTS, 1, Integer(@PanelEdges));
  5193.         SendMessage(Handle, SB_SETTEXT, 0, Integer(PChar('')));
  5194.       end else
  5195.       begin
  5196.         PanelPos := 0;
  5197.         for I := 0 to Count - 2 do
  5198.         begin
  5199.           Inc(PanelPos, Panels[I].Width);
  5200.           PanelEdges[I] := PanelPos;
  5201.         end;
  5202.         PanelEdges[Count - 1] := -1;
  5203.         SendMessage(Handle, SB_SETPARTS, Count, Integer(@PanelEdges));
  5204.       end;
  5205.     end;
  5206.     for I := 0 to Count - 1 do
  5207.       UpdatePanel(I, UpdateText);
  5208.   end;
  5209. end;
  5210.  
  5211. procedure TStatusBar.CMWinIniChange(var Message: TMessage);
  5212. begin
  5213.   inherited;
  5214.   if (Message.WParam = 0) or (Message.WParam = SPI_SETNONCLIENTMETRICS) then
  5215.     SyncToSystemFont;
  5216. end;
  5217.  
  5218. procedure TStatusBar.CNDrawItem(var Message: TWMDrawItem);
  5219. var
  5220.   SaveIndex: Integer;
  5221. begin
  5222.   with Message.DrawItemStruct^ do
  5223.   begin
  5224.     SaveIndex := SaveDC(hDC);
  5225.     FCanvas.Lock;
  5226.     try
  5227.       FCanvas.Handle := hDC;
  5228.       FCanvas.Font := Font;
  5229.       FCanvas.Brush.Color := clBtnFace;
  5230.       FCanvas.Brush.Style := bsSolid;
  5231.       DrawPanel(Panels[itemID], rcItem);
  5232.     finally
  5233.       FCanvas.Handle := 0;
  5234.       FCanvas.Unlock;
  5235.       RestoreDC(hDC, SaveIndex);
  5236.     end;
  5237.   end;
  5238.   Message.Result := 1;
  5239. end;
  5240.  
  5241. procedure TStatusBar.WMGetTextLength(var Message: TWMGetTextLength);
  5242. begin
  5243.   Message.Result := Length(FSimpleText);
  5244. end;
  5245.  
  5246. procedure TStatusBar.WMPaint(var Message: TWMPaint);
  5247. begin
  5248.   UpdatePanels(False, True);
  5249.   inherited;
  5250. end;
  5251.  
  5252. procedure TStatusBar.WMSize(var Message: TWMSize);
  5253. begin
  5254.   { Eat WM_SIZE message to prevent control from doing alignment }
  5255.   if not (csLoading in ComponentState) then Resize;
  5256.   Repaint;
  5257. end;
  5258.  
  5259. function TStatusBar.IsFontStored: Boolean;
  5260. begin
  5261.   Result := not FUseSystemFont and not ParentFont and not DesktopFont;
  5262. end;
  5263.  
  5264. procedure TStatusBar.SetUseSystemFont(const Value: Boolean);
  5265. begin
  5266.   if FUseSystemFont <> Value then
  5267.   begin
  5268.     FUseSystemFont := Value;
  5269.     if Value then
  5270.     begin
  5271.       if ParentFont then ParentFont := False;
  5272.       SyncToSystemFont;
  5273.     end;
  5274.   end;
  5275. end;
  5276.  
  5277. procedure TStatusBar.CMColorChanged(var Message: TMessage);
  5278. begin
  5279.   inherited;
  5280.   RecreateWnd;
  5281. end;
  5282.  
  5283. procedure TStatusBar.CMParentFontChanged(var Message: TMessage);
  5284. begin
  5285.   inherited;
  5286.   if FUseSystemFont and ParentFont then FUseSystemFont := False;
  5287. end;
  5288.  
  5289. function TStatusBar.ExecuteAction(Action: TBasicAction): Boolean;
  5290. begin
  5291.   if AutoHint and (Action is THintAction) and not DoHint then
  5292.   begin
  5293.     if SimplePanel or (Panels.Count = 0) then
  5294.       SimpleText := THintAction(Action).Hint else
  5295.       Panels[0].Text := THintAction(Action).Hint;
  5296.     Result := True;
  5297.   end
  5298.   else Result := inherited ExecuteAction(Action);
  5299. end;
  5300.  
  5301. procedure TStatusBar.CMSysColorChange(var Message: TMessage);
  5302. begin
  5303.   inherited;
  5304.   RecreateWnd;
  5305. end;
  5306.  
  5307. procedure TStatusBar.CMSysFontChanged(var Message: TMessage);
  5308. begin
  5309.   inherited;
  5310.   SyncToSystemFont;
  5311. end;
  5312.  
  5313. procedure TStatusBar.ChangeScale(M, D: Integer);
  5314. begin
  5315.   if UseSystemFont then  // status bar size based on system font size
  5316.     ScalingFlags := [sfTop];
  5317.   inherited;
  5318. end;
  5319.  
  5320. { THeaderSection }
  5321.  
  5322. constructor THeaderSection.Create(Collection: TCollection);
  5323. begin
  5324.   FWidth := 50;
  5325.   FMaxWidth := 10000;
  5326.   FAllowClick := True;
  5327.   FImageIndex := -1;
  5328.   FParentBiDiMode := True;
  5329.   inherited Create(Collection);
  5330.   ParentBiDiModeChanged;
  5331. end;
  5332.  
  5333. procedure THeaderSection.Assign(Source: TPersistent);
  5334. begin
  5335.   if Source is THeaderSection then
  5336.   begin
  5337.     Text := THeaderSection(Source).Text;
  5338.     Width := THeaderSection(Source).Width;
  5339.     MinWidth := THeaderSection(Source).MinWidth;
  5340.     MaxWidth := THeaderSection(Source).MaxWidth;
  5341.     Alignment := THeaderSection(Source).Alignment;
  5342.     Style := THeaderSection(Source).Style;
  5343.     AllowClick := THeaderSection(Source).AllowClick;
  5344.     ImageIndex := THeaderSection(Source).ImageIndex;
  5345.   end
  5346.   else inherited Assign(Source);
  5347. end;
  5348.  
  5349. procedure THeaderSection.SetBiDiMode(Value: TBiDiMode);
  5350. begin
  5351.   if Value <> FBiDiMode then
  5352.   begin
  5353.     FBiDiMode := Value;
  5354.     FParentBiDiMode := False;
  5355.     Changed(False);
  5356.   end;
  5357. end;
  5358.  
  5359. function THeaderSection.IsBiDiModeStored: Boolean;
  5360. begin
  5361.   Result := not FParentBiDiMode;
  5362. end;
  5363.  
  5364. procedure THeaderSection.SetParentBiDiMode(Value: Boolean);
  5365. begin
  5366.   if FParentBiDiMode <> Value then
  5367.   begin
  5368.     FParentBiDiMode := Value;
  5369.     ParentBiDiModeChanged;
  5370.   end;
  5371. end;
  5372.  
  5373. procedure THeaderSection.ParentBiDiModeChanged;
  5374. begin
  5375.   if FParentBiDiMode then
  5376.   begin
  5377.     if GetOwner <> nil then
  5378.     begin
  5379.       BiDiMode := THeaderSections(GetOwner).FHeaderControl.BiDiMode;
  5380.       FParentBiDiMode := True;
  5381.     end;
  5382.   end;
  5383. end;
  5384.  
  5385. function THeaderSection.UseRightToLeftReading: Boolean;
  5386. begin
  5387.   Result := SysLocale.MiddleEast and (BiDiMode <> bdLeftToRight);
  5388. end;
  5389.  
  5390. function THeaderSection.UseRightToLeftAlignment: Boolean;
  5391. begin
  5392.   Result := SysLocale.MiddleEast and (BiDiMode = bdRightToLeft);
  5393. end;
  5394.  
  5395. function THeaderSection.GetDisplayName: string;
  5396. begin
  5397.   Result := Text;
  5398.   if Result = '' then Result := inherited GetDisplayName;
  5399. end;
  5400.  
  5401. function THeaderSection.GetLeft: Integer;
  5402. var
  5403.   I: Integer;
  5404. begin
  5405.   Result := 0;
  5406.   for I := 0 to Index - 1 do
  5407.     Inc(Result, THeaderSections(Collection)[I].Width);
  5408. end;
  5409.  
  5410. function THeaderSection.GetRight: Integer;
  5411. begin
  5412.   Result := Left + Width;
  5413. end;
  5414.  
  5415. procedure THeaderSection.SetAlignment(Value: TAlignment);
  5416. begin
  5417.   if FAlignment <> Value then
  5418.   begin
  5419.     FAlignment := Value;
  5420.     Changed(False);
  5421.   end;
  5422. end;
  5423.  
  5424. procedure THeaderSection.SetAutoSize(Value: Boolean);
  5425. begin
  5426.   if Value <> FAutoSize then
  5427.   begin
  5428.     FAutoSize := Value;
  5429.     if THeaderSections(Collection).FHeaderControl <> nil then
  5430.       THeaderSections(Collection).FHeaderControl.AdjustSize;
  5431.   end;
  5432. end;
  5433.  
  5434. procedure THeaderSection.SetMaxWidth(Value: Integer);
  5435. begin
  5436.   if Value < FMinWidth then Value := FMinWidth;
  5437.   if Value > 10000 then Value := 10000;
  5438.   FMaxWidth := Value;
  5439.   SetWidth(FWidth);
  5440. end;
  5441.  
  5442. procedure THeaderSection.SetMinWidth(Value: Integer);
  5443. begin
  5444.   if Value < 0 then Value := 0;
  5445.   if Value > FMaxWidth then Value := FMaxWidth;
  5446.   FMinWidth := Value;
  5447.   SetWidth(FWidth);
  5448. end;
  5449.  
  5450. procedure THeaderSection.SetStyle(Value: THeaderSectionStyle);
  5451. begin
  5452.   if FStyle <> Value then
  5453.   begin
  5454.     FStyle := Value;
  5455.     Changed(False);
  5456.   end;
  5457. end;
  5458.  
  5459. procedure THeaderSection.SetText(const Value: string);
  5460. begin
  5461.   if FText <> Value then
  5462.   begin
  5463.     FText := Value;
  5464.     Changed(False);
  5465.   end;
  5466. end;
  5467.  
  5468. procedure THeaderSection.SetWidth(Value: Integer);
  5469. begin
  5470.   if Value < FMinWidth then Value := FMinWidth;
  5471.   if Value > FMaxWidth then Value := FMaxWidth;
  5472.   if FWidth <> Value then
  5473.   begin
  5474.     FWidth := Value;
  5475.     if Collection <> nil then
  5476.       Changed(Index < Collection.Count - 1);
  5477.   end;
  5478. end;
  5479.  
  5480. procedure THeaderSection.SetImageIndex(const Value: TImageIndex);
  5481. begin
  5482.   if Value <> FImageIndex then
  5483.   begin
  5484.     FImageIndex := Value;
  5485.     Changed(False);
  5486.   end;
  5487. end;
  5488.  
  5489. { THeaderSections }
  5490.  
  5491. constructor THeaderSections.Create(HeaderControl: THeaderControl);
  5492. begin
  5493.   inherited Create(THeaderSection);
  5494.   FHeaderControl := HeaderControl;
  5495. end;
  5496.  
  5497. function THeaderSections.Add: THeaderSection;
  5498. begin
  5499.   Result := THeaderSection(inherited Add);
  5500. end;
  5501.  
  5502. function THeaderSections.GetItem(Index: Integer): THeaderSection;
  5503. begin
  5504.   Result := THeaderSection(inherited GetItem(Index));
  5505. end;
  5506.  
  5507. function THeaderSections.GetOwner: TPersistent;
  5508. begin
  5509.   Result := FHeaderControl;
  5510. end;
  5511.  
  5512. procedure THeaderSections.SetItem(Index: Integer; Value: THeaderSection);
  5513. begin
  5514.   inherited SetItem(Index, Value);
  5515. end;
  5516.  
  5517. procedure THeaderSections.Update(Item: TCollectionItem);
  5518. begin
  5519.   if Item <> nil then
  5520.     FHeaderControl.UpdateSection(Item.Index) else
  5521.     FHeaderControl.UpdateSections;
  5522. end;
  5523.  
  5524. { THeaderControl }
  5525.  
  5526. constructor THeaderControl.Create(AOwner: TComponent);
  5527. begin
  5528.   inherited Create(AOwner);
  5529.   ControlStyle := [];
  5530.   Align := alTop;
  5531.   Height := 17;
  5532.   FSections := THeaderSections.Create(Self);
  5533.   FCanvas := TControlCanvas.Create;
  5534.   TControlCanvas(FCanvas).Control := Self;
  5535.   FImageChangeLink := TChangeLink.Create;
  5536.   FImageChangeLink.OnChange := ImageListChange;
  5537.   FFullDrag := True;
  5538.   FDragReorder := False;
  5539.   FSectionDragged := False;
  5540.   FUpdatingSectionOrder := False;
  5541.   FSectionStream := nil;
  5542. end;
  5543.  
  5544. destructor THeaderControl.Destroy;
  5545. begin
  5546.   FCanvas.Free;
  5547.   FSections.Free;
  5548.   if Assigned(FSectionStream) then FSectionStream.Free;
  5549.   inherited Destroy;
  5550. end;
  5551.  
  5552. procedure THeaderControl.CreateParams(var Params: TCreateParams);
  5553. const
  5554.   HeaderStyles: array[THeaderStyle] of DWORD = (HDS_BUTTONS, 0);
  5555. begin
  5556.   InitCommonControl(ICC_LISTVIEW_CLASSES);
  5557.   inherited CreateParams(Params);
  5558.   CreateSubClass(Params, WC_HEADER);
  5559.   with Params do
  5560.   begin
  5561.     Style := Style or HeaderStyles[FStyle];
  5562.     if FFullDrag then Style := Style or HDS_FULLDRAG;
  5563.     if FHotTrack then Style := Style or HDS_HOTTRACK;
  5564.     if FDragReorder then Style := Style or HDS_DRAGDROP;
  5565.     WindowClass.style := WindowClass.style and not (CS_HREDRAW or CS_VREDRAW);
  5566.   end;
  5567. end;
  5568.  
  5569. procedure THeaderControl.CreateWnd;
  5570.  
  5571.   procedure ReadSections;
  5572.   var
  5573.     Reader: TReader;
  5574.   begin
  5575.     if FSectionStream = nil then Exit;
  5576.     Sections.Clear;
  5577.     Reader := TReader.Create(FSectionStream, 1024);
  5578.     try
  5579.       Reader.ReadValue;
  5580.       Reader.ReadCollection(Sections);
  5581.     finally
  5582.       Reader.Free;
  5583.     end;
  5584.     FSectionStream.Free;
  5585.     FSectionStream := nil;
  5586.   end;
  5587.  
  5588. begin
  5589.   inherited CreateWnd;
  5590.   if (Images <> nil) and Images.HandleAllocated then
  5591.     Header_SetImageList(Handle, Images.Handle);
  5592.   if FSectionStream <> nil then
  5593.     ReadSections
  5594.   else
  5595.     UpdateSections;
  5596. end;
  5597.  
  5598. procedure THeaderControl.DestroyWnd;
  5599. var
  5600.   Writer: TWriter;
  5601. begin
  5602.   if FSectionStream = nil then
  5603.     FSectionStream := TMemoryStream.Create;
  5604.   Writer := TWriter.Create(FSectionStream, 1024);
  5605.   try
  5606.     Writer.WriteCollection(FSections);
  5607.   finally
  5608.     Writer.Free;
  5609.     FSectionStream.Position := 0;
  5610.   end;
  5611.   inherited DestroyWnd;
  5612. end;
  5613.  
  5614. procedure THeaderControl.CMBiDiModeChanged(var Message: TMessage);
  5615. var
  5616.   Loop: Integer;
  5617. begin
  5618.   inherited;
  5619.   if HandleAllocated then
  5620.     for Loop := 0 to Sections.Count - 1 do
  5621.       if Sections[Loop].ParentBiDiMode then
  5622.         Sections[Loop].ParentBiDiModeChanged;
  5623. end;
  5624.  
  5625. procedure THeaderControl.FlipChildren(AllLevels: Boolean);
  5626. var
  5627.   Loop, FirstWidth, LastWidth: Integer;
  5628.   ASectionsList: THeaderSections;
  5629. begin
  5630.   if HandleAllocated and
  5631.      (Sections.Count > 0) then
  5632.   begin
  5633.     { Get the true width of the last section }
  5634.     LastWidth := ClientWidth;
  5635.     FirstWidth := Sections[0].Width;
  5636.     for Loop := 0 to Sections.Count - 2 do Dec(LastWidth, Sections[Loop].Width);
  5637.     { Flip 'em }
  5638.     ASectionsList := THeaderSections.Create(Self);
  5639.     try
  5640.       for Loop := 0 to Sections.Count - 1 do with ASectionsList.Add do
  5641.         Assign(Self.Sections[Loop]);
  5642.       for Loop := 0 to Sections.Count - 1 do
  5643.         Sections[Loop].Assign(ASectionsList[Sections.Count - Loop - 1]);
  5644.     finally
  5645.       ASectionsList.Free;
  5646.     end;
  5647.     { Set the width of the last Section }
  5648.     if Sections.Count > 1 then
  5649.     begin
  5650.       Sections[Sections.Count-1].Width := FirstWidth;
  5651.       Sections[0].Width := LastWidth;
  5652.     end;
  5653.     UpdateSections;
  5654.   end;
  5655. end;
  5656.  
  5657. procedure THeaderControl.DrawSection(Section: THeaderSection;
  5658.   const Rect: TRect; Pressed: Boolean);
  5659. begin
  5660.   if Assigned(FOnDrawSection) then
  5661.     FOnDrawSection(Self, Section, Rect, Pressed) else
  5662.     FCanvas.FillRect(Rect);
  5663. end;
  5664.  
  5665. procedure THeaderControl.SectionClick(Section: THeaderSection);
  5666. begin
  5667.   if Assigned(FOnSectionClick) then FOnSectionClick(Self, Section);
  5668. end;
  5669.  
  5670. procedure THeaderControl.SectionResize(Section: THeaderSection);
  5671. begin
  5672.   if Assigned(FOnSectionResize) then FOnSectionResize(Self, Section);
  5673. end;
  5674.  
  5675. procedure THeaderControl.SectionTrack(Section: THeaderSection;
  5676.   Width: Integer; State: TSectionTrackState);
  5677. begin
  5678.   if Assigned(FOnSectionTrack) then FOnSectionTrack(Self, Section, Width, State);
  5679. end;
  5680.  
  5681. procedure THeaderControl.SetFullDrag(Value: Boolean);
  5682. begin
  5683.   if FFullDrag <> Value then
  5684.   begin
  5685.     FFullDrag := Value;
  5686.     RecreateWnd;
  5687.   end;
  5688. end;
  5689.  
  5690. procedure THeaderControl.SetHotTrack(Value: Boolean);
  5691. begin
  5692.   if FHotTrack <> Value then
  5693.   begin
  5694.     FHotTrack := Value;
  5695.     RecreateWnd;
  5696.   end;
  5697. end;
  5698.  
  5699. procedure THeaderControl.SetStyle(Value: THeaderStyle);
  5700. begin
  5701.   if FStyle <> Value then
  5702.   begin
  5703.     FStyle := Value;
  5704.     RecreateWnd;
  5705.   end;
  5706. end;
  5707.  
  5708. procedure THeaderControl.SetDragReorder(const Value: Boolean);
  5709. begin
  5710.   if FDragReorder <> Value then
  5711.   begin
  5712.     FDragReorder := Value;
  5713.     RecreateWnd;
  5714.   end;
  5715. end;
  5716.  
  5717. procedure THeaderControl.SetSections(Value: THeaderSections);
  5718. begin
  5719.   FSections.Assign(Value);
  5720. end;
  5721.  
  5722. procedure THeaderControl.UpdateItem(Message, Index: Integer);
  5723. var
  5724.   Item: THDItem;
  5725.   AAlignment: TAlignment;
  5726. begin
  5727.   with Sections[Index] do
  5728.   begin
  5729.     FillChar(Item, SizeOf(Item), 0);
  5730.     Item.mask := HDI_WIDTH or HDI_TEXT or HDI_FORMAT;
  5731.     Item.cxy := Width;
  5732.     Item.pszText := PChar(Text);
  5733.     Item.cchTextMax := Length(Text);
  5734.     AAlignment := Alignment;
  5735.     if UseRightToLeftAlignment then ChangeBiDiModeAlignment(AAlignment);
  5736.     case AAlignment of
  5737.       taLeftJustify: Item.fmt := HDF_LEFT;
  5738.       taRightJustify: Item.fmt := HDF_RIGHT;
  5739.     else
  5740.       Item.fmt := HDF_CENTER;
  5741.     end;
  5742.     if Style = hsOwnerDraw then
  5743.       Item.fmt := Item.fmt or HDF_OWNERDRAW else
  5744.       Item.fmt := Item.fmt or HDF_STRING;
  5745.     if UseRightToLeftReading then Item.fmt := Item.fmt or HDF_RTLREADING;
  5746.     if Assigned(Images) and (FImageIndex >= 0) then
  5747.     begin
  5748.       Item.mask := Item.mask or HDI_IMAGE;
  5749.       Item.fmt := Item.fmt or HDF_IMAGE;
  5750.       Item.iImage := FImageIndex;
  5751.     end;
  5752.     SendMessage(Handle, Message, Index, Integer(@Item));
  5753.   end;
  5754. end;
  5755.  
  5756. procedure THeaderControl.UpdateSection(Index: Integer);
  5757. begin
  5758.   if HandleAllocated then UpdateItem(HDM_SETITEM, Index);
  5759. end;
  5760.  
  5761. procedure THeaderControl.UpdateSections;
  5762. var
  5763.   I: Integer;
  5764. begin
  5765.   if HandleAllocated and not FUpdatingSectionOrder then
  5766.   begin
  5767.     for I := 0 to SendMessage(Handle, HDM_GETITEMCOUNT, 0, 0) - 1 do
  5768.       SendMessage(Handle, HDM_DELETEITEM, 0, 0);
  5769.     for I := 0 to Sections.Count - 1 do UpdateItem(HDM_INSERTITEM, I);
  5770.   end;
  5771. end;
  5772.  
  5773. procedure THeaderControl.CNDrawItem(var Message: TWMDrawItem);
  5774. var
  5775.   SaveIndex: Integer;
  5776. begin
  5777.   with Message.DrawItemStruct^ do
  5778.   begin
  5779.     SaveIndex := SaveDC(hDC);
  5780.     FCanvas.Lock;
  5781.     try
  5782.       FCanvas.Handle := hDC;
  5783.       FCanvas.Font := Font;
  5784.       FCanvas.Brush.Color := clBtnFace;
  5785.       FCanvas.Brush.Style := bsSolid;
  5786.       DrawSection(Sections[itemID], rcItem, itemState and ODS_SELECTED <> 0);
  5787.     finally
  5788.       FCanvas.Handle := 0;
  5789.       FCanvas.Unlock;
  5790.       RestoreDC(hDC, SaveIndex);
  5791.     end;
  5792.   end;
  5793.   Message.Result := 1;
  5794. end;
  5795.  
  5796. procedure THeaderControl.CNNotify(var Message: TWMNotify);
  5797. var
  5798.   Section: THeaderSection;
  5799.   TrackState: TSectionTrackState;
  5800.   MsgPos: Longint;
  5801.   hdhti: THDHitTestInfo;
  5802.   hdi: THDItem;
  5803. begin
  5804.   with PHDNotify(Message.NMHdr)^ do
  5805.     case Hdr.code of
  5806.       HDN_ITEMCLICK:
  5807.         SectionClick(Sections[Item]);
  5808.       HDN_ITEMCHANGED:
  5809.         if PItem^.mask and HDI_WIDTH <> 0 then
  5810.         begin
  5811.           Section := Sections[Item];
  5812.           if Section.FWidth <> PItem^.cxy then
  5813.           begin
  5814.             Section.FWidth := PItem^.cxy;
  5815.             SectionResize(Section);
  5816.           end;
  5817.         end;
  5818.       HDN_BEGINTRACK, HDN_TRACK, HDN_ENDTRACK:
  5819.         begin
  5820.           Section := Sections[Item];
  5821.           case Hdr.code of
  5822.             HDN_BEGINTRACK: TrackState := tsTrackBegin;
  5823.             HDN_ENDTRACK: TrackState := tsTrackEnd;
  5824.           else
  5825.             TrackState := tsTrackMove;
  5826.           end;
  5827.           try
  5828.             if TrackState <> tsTrackEnd then
  5829.             begin
  5830.               FTrackSection := Section;
  5831.               FTrackWidth := Section.Width;
  5832.               MsgPos := GetMessagePos;
  5833.               FTrackPos.X := MsgPos and $FFFF;
  5834.               FTrackPos.Y := MsgPos shr 16;
  5835.               Windows.ScreenToClient(Handle, FTrackPos);
  5836.             end;
  5837.             with PItem^ do
  5838.             begin
  5839.               if cxy < Section.FMinWidth then cxy := Section.FMinWidth;
  5840.               if cxy > Section.FMaxWidth then cxy := Section.FMaxWidth;
  5841.               SectionTrack(Section, cxy, TrackState);
  5842.             end;
  5843.           finally
  5844.             if TrackState = tsTrackEnd then FTrackSection := nil;
  5845.           end;
  5846.         end;
  5847.       HDN_ENDDRAG:
  5848.         begin
  5849.           Message.Result := 0;
  5850.           MsgPos := GetMessagePos;
  5851.           hdhti.Point.X := MsgPos and $FFFF;
  5852.           Windows.ScreenToClient(Handle, hdhti.Point);
  5853.           hdhti.Point.Y := ClientHeight div 2;
  5854.           SendMessage(Handle, HDM_HITTEST, 0, Integer(@hdhti));
  5855.           hdi.Mask := HDI_ORDER;
  5856.           if hdhti.Item < 0 then
  5857.             if (HHT_TOLEFT and hdhti.Flags) <> 0 then
  5858.               FToIndex := 0
  5859.             else begin
  5860.               if ((HHT_TORIGHT and hdhti.Flags) <> 0)
  5861.               or ((HHT_NOWHERE and hdhti.Flags) <> 0) then
  5862.                 FToIndex := Sections.Count - 1
  5863.             end
  5864.           else begin
  5865.             Header_GetItem(Handle, hdhti.Item, hdi);
  5866.             FToIndex := hdi.iOrder;
  5867.           end;
  5868.           Header_GetItem(Handle, Item, hdi);
  5869.           FFromIndex := hdi.iOrder;
  5870.           FSectionDragged := DoSectionDrag(Sections[FFromIndex], Sections[FToIndex]);
  5871.         end;
  5872.       NM_RELEASEDCAPTURE:
  5873.         if FSectionDragged then DoSectionEndDrag;
  5874.     end;
  5875. end;
  5876.  
  5877. procedure THeaderControl.WndProc(var Message: TMessage);
  5878. var
  5879.   cxy: Integer;
  5880.   ShortCircuit: Boolean;
  5881.  
  5882.   function FullWindowUpdate: Boolean;
  5883.   var
  5884.     DragWindows: Bool;
  5885.   begin
  5886.     Result := FullDrag and SystemParametersInfo(SPI_GETDRAGFULLWINDOWS, 0,
  5887.       @DragWindows, 0) and DragWindows;
  5888.   end;
  5889.  
  5890. begin
  5891.   if (Message.Msg = WM_MOUSEMOVE) and FullWindowUpdate and
  5892.     (FTrackSection <> nil) and MouseCapture then
  5893.   begin
  5894.     cxy := FTrackWidth + (TWMMouse(Message).XPos - FTrackPos.X);
  5895.     ShortCircuit := False;
  5896.     if cxy < FTrackSection.FMinWidth then
  5897.     begin
  5898.       Dec(cxy, FTrackSection.FMinWidth);
  5899.       ShortCircuit := True;
  5900.     end;
  5901.     if cxy > FTrackSection.FMaxWidth then
  5902.     begin
  5903.       Dec(cxy, FTrackSection.FMaxWidth);
  5904.       ShortCircuit := True;
  5905.     end;
  5906.     SectionTrack(FTrackSection, cxy, tsTrackMove);
  5907.     if ShortCircuit then
  5908.       Dec(TWMMouse(Message).XPos, cxy);
  5909.   end;
  5910.   inherited WndProc(Message);
  5911. end;
  5912.  
  5913. procedure THeaderControl.WMLButtonDown(var Message: TWMLButtonDown);
  5914. var
  5915.   Index: Integer;
  5916.   Info: THDHitTestInfo;
  5917. begin
  5918.   Info.Point.X := Message.Pos.X;
  5919.   Info.Point.Y := Message.Pos.Y;
  5920.   Index := SendMessage(Handle, HDM_HITTEST, 0, Integer(@Info));
  5921.   if (Index < 0) or (Info.Flags and HHT_ONHEADER = 0) or
  5922.     Sections[Index].AllowClick then inherited;
  5923. end;
  5924.  
  5925. procedure THeaderControl.WMSize(var Message: TWMSize);
  5926. var
  5927.   I, Count, WorkWidth, TmpWidth, Remain: Integer;
  5928.   List: TList;
  5929.   Section: THeaderSection;
  5930. begin
  5931.   inherited;
  5932.   if HandleAllocated and not (csReading in ComponentState) then
  5933.   begin
  5934.     { Try to fit all sections within client width }
  5935.     List := TList.Create;
  5936.     try
  5937.       WorkWidth := ClientWidth;
  5938.       for I := 0 to Sections.Count - 1 do
  5939.       begin
  5940.         Section := Sections[I];
  5941.         if Section.AutoSize then
  5942.           List.Add(Section)
  5943.         else
  5944.           Dec(WorkWidth, Section.Width);
  5945.       end;
  5946.       if List.Count > 0 then
  5947.       begin
  5948.         Sections.BeginUpdate;
  5949.         try
  5950.           repeat
  5951.             Count := List.Count;
  5952.             Remain := WorkWidth mod Count;
  5953.             { Try to redistribute sizes to those sections which can take it }
  5954.             TmpWidth := WorkWidth div Count;
  5955.             for I := Count - 1 downto 0 do
  5956.             begin
  5957.               Section := THeaderSection(List[I]);
  5958.               if I = 0 then
  5959.                 Inc(TmpWidth, Remain);
  5960.               Section.Width := TmpWidth;
  5961.             end;
  5962.  
  5963.             { Verify new sizes don't conflict with min/max section widths and
  5964.               adjust if necessary. }
  5965.             TmpWidth := WorkWidth div Count;
  5966.             for I := Count - 1 downto 0 do
  5967.             begin
  5968.               Section := THeaderSection(List[I]);
  5969.               if I = 0 then
  5970.                 Inc(TmpWidth, Remain);
  5971.               if Section.Width <> TmpWidth then
  5972.               begin
  5973.                 List.Delete(I);
  5974.                 Dec(WorkWidth, Section.Width);
  5975.               end;
  5976.             end;
  5977.           until (List.Count = 0) or (List.Count = Count);
  5978.         finally
  5979.           Sections.EndUpdate;
  5980.         end;
  5981.       end;
  5982.     finally
  5983.       List.Free;
  5984.     end;
  5985.   end;
  5986. end;
  5987.  
  5988. procedure THeaderControl.WMWindowPosChanged(var Message: TWMWindowPosChanged);
  5989. begin
  5990.   inherited;
  5991.   Invalidate;
  5992. end;
  5993.  
  5994. function THeaderControl.DoSectionDrag(FromSection, ToSection: THeaderSection): Boolean;
  5995. begin
  5996.   Result := True;
  5997.   SectionDrag(FromSection, ToSection, Result);
  5998. end;
  5999.  
  6000. procedure THeaderControl.Notification(AComponent: TComponent;
  6001.   Operation: TOperation);
  6002. begin
  6003.   inherited Notification(AComponent, Operation);
  6004.   if (Operation = opRemove) and (AComponent = Images) then
  6005.     Images := nil;
  6006. end;
  6007.  
  6008. procedure THeaderControl.SetImages(Value: TCustomImageList);
  6009. begin
  6010.   if Images <> nil then
  6011.     Images.UnRegisterChanges(FImageChangeLink);
  6012.   FImages := Value;
  6013.   if Images <> nil then
  6014.   begin
  6015.     Images.RegisterChanges(FImageChangeLink);
  6016.     Images.FreeNotification(Self);
  6017.     Header_SetImageList(Handle, Images.Handle);
  6018.   end
  6019.   else Header_SetImageList(Handle, 0);
  6020.   UpdateSections;
  6021. end;
  6022.  
  6023. procedure THeaderControl.ImageListChange(Sender: TObject);
  6024. begin
  6025.   Header_SetImageList(Handle, TCustomImageList(Sender).Handle);
  6026.   UpdateSections;
  6027. end;
  6028.  
  6029. procedure THeaderControl.SectionDrag(FromSection, ToSection: THeaderSection;
  6030.   var AllowDrag: Boolean);
  6031. begin
  6032.   if Assigned(FOnSectionDrag) then FOnSectionDrag(Self, FromSection, ToSection,
  6033.     AllowDrag);
  6034. end;
  6035.  
  6036. procedure THeaderControl.DoSectionEndDrag;
  6037.  
  6038.   procedure UpdateSectionOrder(FromSection, ToSection: THeaderSection);
  6039.   var
  6040.     I: Integer;
  6041.     SectionOrder: array of Integer;
  6042.   begin
  6043.     FUpdatingSectionOrder := True;
  6044.     try
  6045.       Sections.FindItemID(FromSection.ID).Index := ToSection.Index;
  6046.       SetLength(SectionOrder, Sections.Count);
  6047.       for I := 0 to Sections.Count - 1 do SectionOrder[I] := Sections[I].ID;
  6048.       Header_SetOrderArray(Handle, Sections.Count, PInteger(SectionOrder));
  6049.     finally
  6050.       FUpdatingSectionOrder := False;
  6051.     end;
  6052.   end;
  6053.  
  6054. begin
  6055.   FSectionDragged := False;
  6056.   UpdateSectionOrder(Sections[FFromIndex], Sections[FToIndex]);
  6057.   SectionEndDrag;
  6058. end;
  6059.  
  6060. procedure THeaderControl.SectionEndDrag;
  6061. begin
  6062.   if Assigned(FOnSectionEndDrag) then FOnSectionEndDrag(Self);
  6063. end;
  6064.  
  6065. { TTreeNode }
  6066.  
  6067. function DefaultTreeViewSort(Node1, Node2: TTreeNode; lParam: Integer): Integer; stdcall;
  6068. begin
  6069.   with Node1 do
  6070.     if Assigned(TreeView.OnCompare) then
  6071.       TreeView.OnCompare(TreeView, Node1, Node2, lParam, Result)
  6072.     else Result := lstrcmp(PChar(Node1.Text), PChar(Node2.Text));
  6073. end;
  6074.  
  6075. procedure TreeViewError(const Msg: string);
  6076. begin
  6077.   raise ETreeViewError.Create(Msg);
  6078. end;
  6079.  
  6080. procedure TreeViewErrorFmt(const Msg: string; Format: array of const);
  6081. begin
  6082.   raise ETreeViewError.CreateFmt(Msg, Format);
  6083. end;
  6084.  
  6085. constructor TTreeNode.Create(AOwner: TTreeNodes);
  6086. begin
  6087.   inherited Create;
  6088.   FOverlayIndex := -1;
  6089.   FStateIndex := -1;
  6090.   FOwner := AOwner;
  6091. end;
  6092.  
  6093. destructor TTreeNode.Destroy;
  6094. var
  6095.   Node: TTreeNode;
  6096.   CheckValue: Integer;
  6097. begin
  6098.   Owner.ClearCache;
  6099.   FDeleting := True;
  6100.   if Owner.Owner.FLastDropTarget = Self then
  6101.     Owner.Owner.FLastDropTarget := nil;
  6102.   Node := Parent;
  6103.   if (Node <> nil) and (not Node.Deleting) then
  6104.   begin
  6105.     if Node.IndexOf(Self) <> -1 then CheckValue := 1
  6106.     else CheckValue := 0;
  6107.     if Node.CompareCount(CheckValue) then
  6108.     begin
  6109.       Expanded := False;
  6110.       Node.HasChildren := False;
  6111.     end;
  6112.   end;
  6113.   if ItemId <> nil then TreeView_DeleteItem(Handle, ItemId);
  6114.   Data := nil;
  6115.   inherited Destroy;
  6116. end;
  6117.  
  6118. function TTreeNode.GetHandle: HWND;
  6119. begin
  6120.   Result := TreeView.Handle;
  6121. end;
  6122.  
  6123. function TTreeNode.GetTreeView: TCustomTreeView;
  6124. begin
  6125.   Result := Owner.Owner;
  6126. end;
  6127.  
  6128. function TTreeNode.HasAsParent(Value: TTreeNode): Boolean;
  6129. begin
  6130.   if Value <> Nil then
  6131.   begin
  6132.     if Parent = nil then Result := False
  6133.     else if Parent = Value then Result := True
  6134.     else Result := Parent.HasAsParent(Value);
  6135.   end
  6136.   else Result := True;
  6137. end;
  6138.  
  6139. procedure TTreeNode.SetText(const S: string);
  6140. var
  6141.   Item: TTVItem;
  6142. begin
  6143.   FText := S;
  6144.   with Item do
  6145.   begin
  6146.     mask := TVIF_TEXT;
  6147.     hItem := ItemId;
  6148.     pszText := LPSTR_TEXTCALLBACK;
  6149.   end;
  6150.   TreeView_SetItem(Handle, Item);
  6151.   if (TreeView.SortType in [stText, stBoth]) and FInTree then
  6152.   begin
  6153.     if (Parent <> nil) then Parent.AlphaSort
  6154.     else TreeView.AlphaSort;
  6155.   end;
  6156. end;
  6157.  
  6158. procedure TTreeNode.SetData(Value: Pointer);
  6159. begin
  6160.   FData := Value;
  6161.   if (TreeView.SortType in [stData, stBoth]) and Assigned(TreeView.OnCompare)
  6162.     and (not Deleting) and FInTree then
  6163.   begin
  6164.     if Parent <> nil then Parent.AlphaSort
  6165.     else TreeView.AlphaSort;
  6166.   end;
  6167. end;
  6168.  
  6169. function TTreeNode.GetState(NodeState: TNodeState): Boolean;
  6170. var
  6171.   Item: TTVItem;
  6172. begin
  6173.   Result := False;
  6174.   with Item do
  6175.   begin
  6176.     mask := TVIF_STATE;
  6177.     hItem := ItemId;
  6178.     if TreeView_GetItem(Handle, Item) then
  6179.       case NodeState of
  6180.         nsCut: Result := (state and TVIS_CUT) <> 0;
  6181.         nsFocused: Result := (state and TVIS_FOCUSED) <> 0;
  6182.         nsSelected: Result := (state and TVIS_SELECTED) <> 0;
  6183.         nsExpanded: Result := (state and TVIS_EXPANDED) <> 0;
  6184.         nsDropHilited: Result := (state and TVIS_DROPHILITED) <> 0;
  6185.       end;
  6186.   end;
  6187. end;
  6188.  
  6189. procedure TTreeNode.SetImageIndex(Value: TImageIndex);
  6190. var
  6191.   Item: TTVItem;
  6192. begin
  6193.   FImageIndex := Value;
  6194.   with Item do
  6195.   begin
  6196.     mask := TVIF_IMAGE or TVIF_HANDLE;
  6197.     hItem := ItemId;
  6198.     if Assigned(TCustomTreeView(Owner.Owner).OnGetImageIndex) then
  6199.       iImage := I_IMAGECALLBACK
  6200.     else
  6201.       iImage := FImageIndex;
  6202.   end;
  6203.   TreeView_SetItem(Handle, Item);
  6204. end;
  6205.  
  6206. procedure TTreeNode.SetSelectedIndex(Value: Integer);
  6207. var
  6208.   Item: TTVItem;
  6209. begin
  6210.   FSelectedIndex := Value;
  6211.   with Item do
  6212.   begin
  6213.     mask := TVIF_SELECTEDIMAGE or TVIF_HANDLE;
  6214.     hItem := ItemId;
  6215.     if Assigned(TCustomTreeView(Owner.Owner).OnGetSelectedIndex) then
  6216.       iSelectedImage := I_IMAGECALLBACK
  6217.     else
  6218.       iSelectedImage := FSelectedIndex;
  6219.   end;
  6220.   TreeView_SetItem(Handle, Item);
  6221. end;
  6222.  
  6223. procedure TTreeNode.SetOverlayIndex(Value: Integer);
  6224. var
  6225.   Item: TTVItem;
  6226. begin
  6227.   FOverlayIndex := Value;
  6228.   with Item do
  6229.   begin
  6230.     mask := TVIF_STATE or TVIF_HANDLE;
  6231.     stateMask := TVIS_OVERLAYMASK;
  6232.     hItem := ItemId;
  6233.     state := IndexToOverlayMask(FOverlayIndex + 1);
  6234.   end;
  6235.   TreeView_SetItem(Handle, Item);
  6236. end;
  6237.  
  6238. procedure TTreeNode.SetStateIndex(Value: Integer);
  6239. var
  6240.   Item: TTVItem;
  6241. begin
  6242.   FStateIndex := Value;
  6243.   if Value >= 0 then Dec(Value);
  6244.   with Item do
  6245.   begin
  6246.     mask := TVIF_STATE or TVIF_HANDLE;
  6247.     stateMask := TVIS_STATEIMAGEMASK;
  6248.     hItem := ItemId;
  6249.     state := IndexToStateImageMask(Value + 1);
  6250.   end;
  6251.   TreeView_SetItem(Handle, Item);
  6252. end;
  6253.  
  6254. function TTreeNode.CompareCount(CompareMe: Integer): Boolean;
  6255. var
  6256.   Count: integer;
  6257.   Node: TTreeNode;
  6258. Begin
  6259.   Count := 0;
  6260.   Result := False;
  6261.   Node := GetFirstChild;
  6262.   while Node <> nil do
  6263.   begin
  6264.     Inc(Count);
  6265.     Node := Node.GetNextChild(Node);
  6266.     if Count > CompareMe then Exit;
  6267.   end;
  6268.   if Count = CompareMe then Result := True;
  6269. end;
  6270.  
  6271. function TTreeNode.DoCanExpand(Expand: Boolean): Boolean;
  6272. begin
  6273.   Result := False;
  6274.   if HasChildren then
  6275.   begin
  6276.     if Expand then Result := TreeView.CanExpand(Self)
  6277.     else Result := TreeView.CanCollapse(Self);
  6278.   end;
  6279. end;
  6280.  
  6281. procedure TTreeNode.DoExpand(Expand: Boolean);
  6282. begin
  6283.   if HasChildren then
  6284.   begin
  6285.     if Expand then TreeView.Expand(Self)
  6286.     else TreeView.Collapse(Self);
  6287.   end;
  6288. end;
  6289.  
  6290. procedure TTreeNode.ExpandItem(Expand: Boolean; Recurse: Boolean);
  6291. var
  6292.   Flag: Integer;
  6293.   Node: TTreeNode;
  6294. begin
  6295.   if Recurse then
  6296.   begin
  6297.     Node := Self;
  6298.     repeat
  6299.       Node.ExpandItem(Expand, False);
  6300.       Node := Node.GetNext;
  6301.     until (Node = nil) or (not Node.HasAsParent(Self));
  6302.   end
  6303.   else begin
  6304.     TreeView.FManualNotify := True;
  6305.     try
  6306.       Flag := 0;
  6307.       if Expand then
  6308.       begin
  6309.         if DoCanExpand(True) then
  6310.         begin
  6311.           Flag := TVE_EXPAND;
  6312.           DoExpand(True);
  6313.         end;
  6314.       end
  6315.       else begin
  6316.         if DoCanExpand(False) then
  6317.         begin
  6318.           Flag := TVE_COLLAPSE;
  6319.           DoExpand(False);
  6320.         end;
  6321.       end;
  6322.       if Flag <> 0 then TreeView_Expand(Handle, ItemId, Flag);
  6323.     finally
  6324.       TreeView.FManualNotify := False;
  6325.     end;
  6326.   end;
  6327. end;
  6328.  
  6329. procedure TTreeNode.Expand(Recurse: Boolean);
  6330. begin
  6331.   ExpandItem(True, Recurse);
  6332. end;
  6333.  
  6334. procedure TTreeNode.Collapse(Recurse: Boolean);
  6335. begin
  6336.   ExpandItem(False, Recurse);
  6337. end;
  6338.  
  6339. function TTreeNode.GetExpanded: Boolean;
  6340. begin
  6341.   Result := GetState(nsExpanded);
  6342. end;
  6343.  
  6344. procedure TTreeNode.SetExpanded(Value: Boolean);
  6345. begin
  6346.   if Value then Expand(False)
  6347.   else Collapse(False);
  6348. end;
  6349.  
  6350. function TTreeNode.GetSelected: Boolean;
  6351. begin
  6352.   Result := GetState(nsSelected);
  6353. end;
  6354.  
  6355. procedure TTreeNode.SetSelected(Value: Boolean);
  6356. begin
  6357.   if Value then TreeView_SelectItem(Handle, ItemId)
  6358.   else if Selected then TreeView_SelectItem(Handle, nil);
  6359. end;
  6360.  
  6361. function TTreeNode.GetCut: Boolean;
  6362. begin
  6363.   Result := GetState(nsCut);
  6364. end;
  6365.  
  6366. procedure TTreeNode.SetCut(Value: Boolean);
  6367. var
  6368.   Item: TTVItem;
  6369.   Template: DWORD;
  6370. begin
  6371.   if Value then Template := DWORD(-1)
  6372.   else Template := 0;
  6373.   with Item do
  6374.   begin
  6375.     mask := TVIF_STATE;
  6376.     hItem := ItemId;
  6377.     stateMask := TVIS_CUT;
  6378.     state := stateMask and Template;
  6379.   end;
  6380.   TreeView_SetItem(Handle, Item);
  6381. end;
  6382.  
  6383. function TTreeNode.GetDropTarget: Boolean;
  6384. begin
  6385.   Result := GetState(nsDropHilited);
  6386. end;
  6387.  
  6388. procedure TTreeNode.SetDropTarget(Value: Boolean);
  6389. begin
  6390.   if Value then TreeView_SelectDropTarget(Handle, ItemId)
  6391.   else if DropTarget then TreeView_SelectDropTarget(Handle, nil);
  6392. end;
  6393.  
  6394. function TTreeNode.GetChildren: Boolean;
  6395. var
  6396.   Item: TTVItem;
  6397. begin
  6398.   Item.mask := TVIF_CHILDREN;
  6399.   Item.hItem := ItemId;
  6400.   if TreeView_GetItem(Handle, Item) then Result := Item.cChildren > 0
  6401.   else Result := False;
  6402. end;
  6403.  
  6404. procedure TTreeNode.SetFocused(Value: Boolean);
  6405. var
  6406.   Item: TTVItem;
  6407.   Template: DWORD;
  6408. begin
  6409.   if Value then Template := DWORD(-1)
  6410.   else Template := 0;
  6411.   with Item do
  6412.   begin
  6413.     mask := TVIF_STATE;
  6414.     hItem := ItemId;
  6415.     stateMask := TVIS_FOCUSED;
  6416.     state := stateMask and Template;
  6417.   end;
  6418.   TreeView_SetItem(Handle, Item);
  6419. end;
  6420.  
  6421. function TTreeNode.GetFocused: Boolean;
  6422. begin
  6423.   Result := GetState(nsFocused);
  6424. end;
  6425.  
  6426. procedure TTreeNode.SetChildren(Value: Boolean);
  6427. var
  6428.   Item: TTVItem;
  6429. begin
  6430.   with Item do
  6431.   begin
  6432.     mask := TVIF_CHILDREN;
  6433.     hItem := ItemId;
  6434.     cChildren := Ord(Value);
  6435.   end;
  6436.   TreeView_SetItem(Handle, Item);
  6437. end;
  6438.  
  6439. function TTreeNode.GetParent: TTreeNode;
  6440. begin
  6441.   with FOwner do
  6442.     Result := GetNode(TreeView_GetParent(Handle, ItemId));
  6443. end;
  6444.  
  6445. function TTreeNode.GetNextSibling: TTreeNode;
  6446. begin
  6447.   with FOwner do
  6448.     Result := GetNode(TreeView_GetNextSibling(Handle, ItemId));
  6449. end;
  6450.  
  6451. function TTreeNode.GetPrevSibling: TTreeNode;
  6452. begin
  6453.   with FOwner do
  6454.     Result := GetNode(TreeView_GetPrevSibling(Handle, ItemId));
  6455. end;
  6456.  
  6457. function TTreeNode.GetNextVisible: TTreeNode;
  6458. begin
  6459.   if IsVisible then
  6460.     with FOwner do
  6461.       Result := GetNode(TreeView_GetNextVisible(Handle, ItemId))
  6462.   else Result := nil;
  6463. end;
  6464.  
  6465. function TTreeNode.GetPrevVisible: TTreeNode;
  6466. begin
  6467.   with FOwner do
  6468.     Result := GetNode(TreeView_GetPrevVisible(Handle, ItemId));
  6469. end;
  6470.  
  6471. function TTreeNode.GetNextChild(Value: TTreeNode): TTreeNode;
  6472. begin
  6473.   if Value <> nil then Result := Value.GetNextSibling
  6474.   else Result := nil;
  6475. end;
  6476.  
  6477. function TTreeNode.GetPrevChild(Value: TTreeNode): TTreeNode;
  6478. begin
  6479.   if Value <> nil then Result := Value.GetPrevSibling
  6480.   else Result := nil;
  6481. end;
  6482.  
  6483. function TTreeNode.GetFirstChild: TTreeNode;
  6484. begin
  6485.   with FOwner do
  6486.     Result := GetNode(TreeView_GetChild(Handle, ItemId));
  6487. end;
  6488.  
  6489. function TTreeNode.GetLastChild: TTreeNode;
  6490. var
  6491.   Node: TTreeNode;
  6492. begin
  6493.   Result := GetFirstChild;
  6494.   if Result <> nil then
  6495.   begin
  6496.     Node := Result;
  6497.     repeat
  6498.       Result := Node;
  6499.       Node := Result.GetNextSibling;
  6500.     until Node = nil;
  6501.   end;
  6502. end;
  6503.  
  6504. function TTreeNode.GetNext: TTreeNode;
  6505. var
  6506.   NodeID, ParentID: HTreeItem;
  6507.   Handle: HWND;
  6508. begin
  6509.   Handle := FOwner.Handle;
  6510.   NodeID := TreeView_GetChild(Handle, ItemId);
  6511.   if NodeID = nil then NodeID := TreeView_GetNextSibling(Handle, ItemId);
  6512.   ParentID := ItemId;
  6513.   while (NodeID = nil) and (ParentID <> nil) do
  6514.   begin
  6515.     ParentID := TreeView_GetParent(Handle, ParentID);
  6516.     NodeID := TreeView_GetNextSibling(Handle, ParentID);
  6517.   end;
  6518.   Result := FOwner.GetNode(NodeID);
  6519. end;
  6520.  
  6521. function TTreeNode.GetPrev: TTreeNode;
  6522. var
  6523.   Node: TTreeNode;
  6524. begin
  6525.   Result := GetPrevSibling;
  6526.   if Result <> nil then
  6527.   begin
  6528.     Node := Result;
  6529.     repeat
  6530.       Result := Node;
  6531.       Node := Result.GetLastChild;
  6532.     until Node = nil;
  6533.   end else
  6534.     Result := Parent;
  6535. end;
  6536.  
  6537. function TTreeNode.GetAbsoluteIndex: Integer;
  6538. var
  6539.   Node: TTreeNode;
  6540. begin
  6541.   if Owner.FNodeCache.CacheNode = Self then
  6542.     Result := Owner.FNodeCache.CacheIndex
  6543.   else begin
  6544.     Result := -1;
  6545.     Node := Self;
  6546.     while Node <> nil do
  6547.     begin
  6548.       Inc(Result);
  6549.       Node := Node.GetPrev;
  6550.     end;
  6551.   end;
  6552. end;
  6553.  
  6554. function TTreeNode.GetIndex: Integer;
  6555. var
  6556.   Node: TTreeNode;
  6557. begin
  6558.   Result := -1;
  6559.   Node := Self;
  6560.   while Node <> nil do
  6561.   begin
  6562.     Inc(Result);
  6563.     Node := Node.GetPrevSibling;
  6564.   end;
  6565. end;
  6566.  
  6567. function TTreeNode.GetItem(Index: Integer): TTreeNode;
  6568. begin
  6569.   Result := GetFirstChild;
  6570.   while (Result <> nil) and (Index > 0) do
  6571.   begin
  6572.     Result := GetNextChild(Result);
  6573.     Dec(Index);
  6574.   end;
  6575.   if Result = nil then TreeViewError(SListIndexError);
  6576. end;
  6577.  
  6578. procedure TTreeNode.SetItem(Index: Integer; Value: TTreeNode);
  6579. begin
  6580.   item[Index].Assign(Value);
  6581. end;
  6582.  
  6583. function TTreeNode.IndexOf(Value: TTreeNode): Integer;
  6584. var
  6585.   Node: TTreeNode;
  6586. begin
  6587.   Result := -1;
  6588.   Node := GetFirstChild;
  6589.   while (Node <> nil) do
  6590.   begin
  6591.     Inc(Result);
  6592.     if Node = Value then Break;
  6593.     Node := GetNextChild(Node);
  6594.   end;
  6595.   if Node = nil then Result := -1;
  6596. end;
  6597.  
  6598. function TTreeNode.GetCount: Integer;
  6599. var
  6600.   Node: TTreeNode;
  6601. begin
  6602.   Result := 0;
  6603.   Node := GetFirstChild;
  6604.   while Node <> nil do
  6605.   begin
  6606.     Inc(Result);
  6607.     Node := Node.GetNextChild(Node);
  6608.   end;
  6609. end;
  6610.  
  6611. procedure TTreeNode.EndEdit(Cancel: Boolean);
  6612. begin
  6613.   TreeView_EndEditLabelNow(Handle, Cancel);
  6614. end;
  6615.  
  6616. procedure TTreeNode.InternalMove(ParentNode, Node: TTreeNode;
  6617.   HItem: HTreeItem; AddMode: TAddMode);
  6618. var
  6619.   I: Integer;
  6620.   NodeId: HTreeItem;
  6621.   TreeViewItem: TTVItem;
  6622.   Children: Boolean;
  6623.   IsSelected: Boolean;
  6624. begin
  6625.   Owner.ClearCache;
  6626.   if (AddMode = taInsert) and (Node <> nil) then
  6627.     NodeId := Node.ItemId else
  6628.     NodeId := nil;
  6629.   Children := HasChildren;
  6630.   IsSelected := Selected;
  6631.   if (Parent <> nil) and (Parent.CompareCount(1)) then
  6632.   begin
  6633.     Parent.Expanded := False;
  6634.     Parent.HasChildren := False;
  6635.   end;
  6636.   with TreeViewItem do
  6637.   begin
  6638.     mask := TVIF_PARAM;
  6639.     hItem := ItemId;
  6640.     lParam := 0;
  6641.   end;
  6642.   TreeView_SetItem(Handle, TreeViewItem);
  6643.   with Owner do
  6644.     HItem := AddItem(HItem, NodeId, CreateItem(Self), AddMode);
  6645.   if HItem = nil then
  6646.     raise EOutOfResources.Create(sInsertError);
  6647.   for I := Count - 1 downto 0 do
  6648.     Item[I].InternalMove(Self, nil, HItem, taAddFirst);
  6649.   TreeView_DeleteItem(Handle, ItemId);
  6650.   FItemId := HItem;
  6651.   Assign(Self);
  6652.   HasChildren := Children;
  6653.   Selected := IsSelected;
  6654. end;
  6655.  
  6656. procedure TTreeNode.MoveTo(Destination: TTreeNode; Mode: TNodeAttachMode);
  6657. var
  6658.   AddMode: TAddMode;
  6659.   Node: TTreeNode;
  6660.   HItem: HTreeItem;
  6661.   OldOnChanging: TTVChangingEvent;
  6662.   OldOnChange: TTVChangedEvent;
  6663. begin
  6664.   OldOnChanging := TreeView.OnChanging;
  6665.   OldOnChange := TreeView.OnChange;
  6666.   TreeView.OnChanging := nil;
  6667.   TreeView.OnChange := nil;
  6668.   try
  6669.     if (Destination = nil) or not Destination.HasAsParent(Self) then
  6670.     begin
  6671.       AddMode := taAdd;
  6672.       if (Destination <> nil) and not (Mode in [naAddChild, naAddChildFirst]) then
  6673.         Node := Destination.Parent else
  6674.         Node := Destination;
  6675.       case Mode of
  6676.         naAdd,
  6677.         naAddChild: AddMode := taAdd;
  6678.         naAddFirst,
  6679.         naAddChildFirst: AddMode := taAddFirst;
  6680.         naInsert:
  6681.           begin
  6682.             Destination := Destination.GetPrevSibling;
  6683.             if Destination = nil then AddMode := taAddFirst
  6684.             else AddMode := taInsert;
  6685.           end;
  6686.       end;
  6687.       if Node <> nil then
  6688.         HItem := Node.ItemId else
  6689.         HItem := nil;
  6690.       if (Destination <> Self) then
  6691.         InternalMove(Node, Destination, HItem, AddMode);
  6692.       Node := Parent;
  6693.       if Node <> nil then
  6694.       begin
  6695.         Node.HasChildren := True;
  6696.         Node.Expanded := True;
  6697.       end;
  6698.     end;
  6699.   finally
  6700.     TreeView.OnChanging := OldOnChanging;
  6701.     TreeView.OnChange := OldOnChange;
  6702.   end;
  6703. end;
  6704.  
  6705. procedure TTreeNode.MakeVisible;
  6706. begin
  6707.   TreeView_EnsureVisible(Handle, ItemId);
  6708. end;
  6709.  
  6710. function TTreeNode.GetLevel: Integer;
  6711. var
  6712.   Node: TTreeNode;
  6713. begin
  6714.   Result := 0;
  6715.   Node := Parent;
  6716.   while Node <> nil do
  6717.   begin
  6718.     Inc(Result);
  6719.     Node := Node.Parent;
  6720.   end;
  6721. end;
  6722.  
  6723. function TTreeNode.IsNodeVisible: Boolean;
  6724. var
  6725.   Rect: TRect;
  6726. begin
  6727.   Result := TreeView_GetItemRect(Handle, ItemId, Rect, True);
  6728. end;
  6729.  
  6730. function TTreeNode.EditText: Boolean;
  6731. begin
  6732.   Result := TreeView_EditLabel(Handle, ItemId) <> 0;
  6733. end;
  6734.  
  6735. function TTreeNode.DisplayRect(TextOnly: Boolean): TRect;
  6736. begin
  6737.   FillChar(Result, SizeOf(Result), 0);
  6738.   TreeView_GetItemRect(Handle, ItemId, Result, TextOnly);
  6739. end;
  6740.  
  6741. function TTreeNode.AlphaSort: Boolean;
  6742. begin
  6743.   Result := CustomSort(nil, 0);
  6744. end;
  6745.  
  6746. function TTreeNode.CustomSort(SortProc: TTVCompare; Data: Longint): Boolean;
  6747. var
  6748.   SortCB: TTVSortCB;
  6749. begin
  6750.   Owner.ClearCache;
  6751.   with SortCB do
  6752.   begin
  6753.     if not Assigned(SortProc) then lpfnCompare := @DefaultTreeViewSort
  6754.     else lpfnCompare := SortProc;
  6755.     hParent := ItemId;
  6756.     lParam := Data;
  6757.   end;
  6758.   Result := TreeView_SortChildrenCB(Handle, SortCB, 0);
  6759. end;
  6760.  
  6761. procedure TTreeNode.Delete;
  6762. begin
  6763.   if not Deleting then Free;
  6764. end;
  6765.  
  6766. procedure TTreeNode.DeleteChildren;
  6767. begin
  6768.   Owner.ClearCache;
  6769.   TreeView_Expand(TreeView.Handle, ItemID, TVE_COLLAPSE or TVE_COLLAPSERESET);
  6770.   HasChildren := False;
  6771. end;
  6772.  
  6773. procedure TTreeNode.Assign(Source: TPersistent);
  6774. var
  6775.   Node: TTreeNode;
  6776. begin
  6777.   Owner.ClearCache;
  6778.   if Source is TTreeNode then
  6779.   begin
  6780.     Node := TTreeNode(Source);
  6781.     Text := Node.Text;
  6782.     Data := Node.Data;
  6783.     ImageIndex := Node.ImageIndex;
  6784.     SelectedIndex := Node.SelectedIndex;
  6785.     StateIndex := Node.StateIndex;
  6786.     OverlayIndex := Node.OverlayIndex;
  6787.     Focused := Node.Focused;
  6788.     DropTarget := Node.DropTarget;
  6789.     Cut := Node.Cut;
  6790.     HasChildren := Node.HasChildren;
  6791.   end
  6792.   else inherited Assign(Source);
  6793. end;
  6794.  
  6795. function TTreeNode.IsEqual(Node: TTreeNode): Boolean;
  6796. begin
  6797.   Result := (Text = Node.Text) and (Data = Node.Data);
  6798. end;
  6799.  
  6800. procedure TTreeNode.ReadData(Stream: TStream; Info: PNodeInfo);
  6801. var
  6802.   I, Size, ItemCount: Integer;
  6803. begin
  6804.   Owner.ClearCache;
  6805.   Stream.ReadBuffer(Size, SizeOf(Size));
  6806.   Stream.ReadBuffer(Info^, Size);
  6807.   Text := Info^.Text;
  6808.   ImageIndex := Info^.ImageIndex;
  6809.   SelectedIndex := Info^.SelectedIndex;
  6810.   StateIndex := Info^.StateIndex;
  6811.   OverlayIndex := Info^.OverlayIndex;
  6812.   Data := Info^.Data;
  6813.   ItemCount := Info^.Count;
  6814.   for I := 0 to ItemCount - 1 do
  6815.     Owner.AddChild(Self, '').ReadData(Stream, Info);
  6816. end;
  6817.  
  6818. procedure TTreeNode.WriteData(Stream: TStream; Info: PNodeInfo);
  6819. var
  6820.   I, Size, L, ItemCount: Integer;
  6821. begin
  6822.   L := Length(Text);
  6823.   if L > 255 then L := 255;
  6824.   Size := SizeOf(TNodeInfo) + L - 255;
  6825.   Info^.Text := Text;
  6826.   Info^.ImageIndex := ImageIndex;
  6827.   Info^.SelectedIndex := SelectedIndex;
  6828.   Info^.OverlayIndex := OverlayIndex;
  6829.   Info^.StateIndex := StateIndex;
  6830.   Info^.Data := Data;
  6831.   ItemCount := Count;
  6832.   Info^.Count := ItemCount;
  6833.   Stream.WriteBuffer(Size, SizeOf(Size));
  6834.   Stream.WriteBuffer(Info^, Size);
  6835.   for I := 0 to ItemCount - 1 do Item[I].WriteData(Stream, Info);
  6836. end;
  6837.  
  6838. { TTreeNodes }
  6839.  
  6840. constructor TTreeNodes.Create(AOwner: TCustomTreeView);
  6841. begin
  6842.   inherited Create;
  6843.   FOwner := AOwner;
  6844. end;
  6845.  
  6846. destructor TTreeNodes.Destroy;
  6847. begin
  6848.   Clear;
  6849.   inherited Destroy;
  6850. end;
  6851.  
  6852. function TTreeNodes.GetCount: Integer;
  6853. begin
  6854.   if Owner.HandleAllocated then Result := TreeView_GetCount(Handle)
  6855.   else Result := 0;
  6856. end;
  6857.  
  6858. function TTreeNodes.GetHandle: HWND;
  6859. begin
  6860.   Result := Owner.Handle;
  6861. end;
  6862.  
  6863. procedure TTreeNodes.Delete(Node: TTreeNode);
  6864. begin
  6865.   if (Node.ItemId = nil) then
  6866.     Owner.Delete(Node);
  6867.   Node.Delete;
  6868. end;
  6869.  
  6870. procedure TTreeNodes.Clear;
  6871. begin
  6872.   ClearCache;
  6873.   if not (csDestroying in Owner.ComponentState) and Owner.HandleAllocated then
  6874.     TreeView_DeleteAllItems(Owner.Handle);
  6875. end;
  6876.  
  6877. function TTreeNodes.AddChildFirst(Node: TTreeNode; const S: string): TTreeNode;
  6878. begin
  6879.   Result := AddChildObjectFirst(Node, S, nil);
  6880. end;
  6881.  
  6882. function TTreeNodes.AddChildObjectFirst(Node: TTreeNode; const S: string;
  6883.   Ptr: Pointer): TTreeNode;
  6884. begin
  6885.   Result := InternalAddObject(Node, S, Ptr, taAddFirst);
  6886. end;
  6887.  
  6888. function TTreeNodes.AddChild(Node: TTreeNode; const S: string): TTreeNode;
  6889. begin
  6890.   Result := AddChildObject(Node, S, nil);
  6891. end;
  6892.  
  6893. function TTreeNodes.AddChildObject(Node: TTreeNode; const S: string;
  6894.   Ptr: Pointer): TTreeNode;
  6895. begin
  6896.   Result := InternalAddObject(Node, S, Ptr, taAdd);
  6897. end;
  6898.  
  6899. function TTreeNodes.AddFirst(Node: TTreeNode; const S: string): TTreeNode;
  6900. begin
  6901.   Result := AddObjectFirst(Node, S, nil);
  6902. end;
  6903.  
  6904. function TTreeNodes.AddObjectFirst(Node: TTreeNode; const S: string;
  6905.   Ptr: Pointer): TTreeNode;
  6906. begin
  6907.   if Node <> nil then Node := Node.Parent;
  6908.   Result := InternalAddObject(Node, S, Ptr, taAddFirst);
  6909. end;
  6910.  
  6911. function TTreeNodes.Add(Node: TTreeNode; const S: string): TTreeNode;
  6912. begin
  6913.   Result := AddObject(Node, S, nil);
  6914. end;
  6915.  
  6916. procedure TTreeNodes.Repaint(Node: TTreeNode);
  6917. var
  6918.   R: TRect;
  6919. begin
  6920.   if FUpdateCount < 1 then
  6921.   begin
  6922.     while (Node <> nil) and not Node.IsVisible do Node := Node.Parent;
  6923.     if Node <> nil then
  6924.     begin
  6925.       R := Node.DisplayRect(False);
  6926.       InvalidateRect(Owner.Handle, @R, True);
  6927.     end;
  6928.   end;
  6929. end;
  6930.  
  6931. function TTreeNodes.AddObject(Node: TTreeNode; const S: string;
  6932.   Ptr: Pointer): TTreeNode;
  6933. begin
  6934.   if Node <> nil then Node := Node.Parent;
  6935.   Result := InternalAddObject(Node, S, Ptr, taAdd);
  6936. end;
  6937.  
  6938. function TTreeNodes.Insert(Node: TTreeNode; const S: string): TTreeNode;
  6939. begin
  6940.   Result := InsertObject(Node, S, nil);
  6941. end;
  6942.  
  6943. procedure TTreeNodes.AddedNode(Value: TTreeNode);
  6944. begin
  6945.   if Value <> nil then
  6946.   begin
  6947.     Value.HasChildren := True;
  6948.     Repaint(Value);
  6949.   end;
  6950. end;
  6951.  
  6952. function TTreeNodes.InsertObject(Node: TTreeNode; const S: string;
  6953.   Ptr: Pointer): TTreeNode;
  6954. var
  6955.   Item, ItemId: HTreeItem;
  6956.   Parent: TTreeNode;
  6957.   AddMode: TAddMode;
  6958. begin
  6959.   Result := Owner.CreateNode;
  6960.   try
  6961.     Item := nil;
  6962.     ItemId := nil;
  6963.     Parent := nil;
  6964.     AddMode := taInsert;
  6965.     if Node <> nil then
  6966.     begin
  6967.       Parent := Node.Parent;
  6968.       if Parent <> nil then Item := Parent.ItemId;
  6969.       Node := Node.GetPrevSibling;
  6970.       if Node <> nil then ItemId := Node.ItemId
  6971.       else AddMode := taAddFirst;
  6972.     end;
  6973.     Result.Data := Ptr;
  6974.     Result.Text := S;
  6975.     Item := AddItem(Item, ItemId, CreateItem(Result), AddMode);
  6976.     if Item = nil then
  6977.       raise EOutOfResources.Create(sInsertError);
  6978.     Result.FItemId := Item;
  6979.     AddedNode(Parent);
  6980.   except
  6981.     Result.Free;
  6982.     raise;
  6983.   end;
  6984. end;
  6985.  
  6986. function TTreeNodes.InternalAddObject(Node: TTreeNode; const S: string;
  6987.   Ptr: Pointer; AddMode: TAddMode): TTreeNode;
  6988. var
  6989.   Item: HTreeItem;
  6990. begin
  6991.   Result := Owner.CreateNode;
  6992.   try
  6993.     if Node <> nil then Item := Node.ItemId
  6994.     else Item := nil;
  6995.     Result.Data := Ptr;
  6996.     Result.Text := S;
  6997.     Item := AddItem(Item, nil, CreateItem(Result), AddMode);
  6998.     if Item = nil then
  6999.       raise EOutOfResources.Create(sInsertError);
  7000.     Result.FItemId := Item;
  7001.     if (FUpdateCount = 0) and (Result.AbsoluteIndex = 0) then
  7002.       SendMessage(Handle, WM_SETREDRAW, 1, 0);
  7003.     AddedNode(Node);
  7004.   except
  7005.     Result.Free;
  7006.     raise;
  7007.   end;
  7008. end;
  7009.  
  7010. function TTreeNodes.CreateItem(Node: TTreeNode): TTVItem;
  7011. begin
  7012.   Node.FInTree := True;
  7013.   with Result do
  7014.   begin
  7015.     mask := TVIF_TEXT or TVIF_PARAM or TVIF_IMAGE or TVIF_SELECTEDIMAGE;
  7016.     lParam := Longint(Node);
  7017.     pszText := LPSTR_TEXTCALLBACK;
  7018.     iImage := I_IMAGECALLBACK;
  7019.     iSelectedImage := I_IMAGECALLBACK;
  7020.   end;
  7021. end;
  7022.  
  7023. function TTreeNodes.AddItem(Parent, Target: HTreeItem;
  7024.   const Item: TTVItem; AddMode: TAddMode): HTreeItem;
  7025. var
  7026.   InsertStruct: TTVInsertStruct;
  7027. begin
  7028.   ClearCache;
  7029.   with InsertStruct do
  7030.   begin
  7031.     hParent := Parent;
  7032.     case AddMode of
  7033.       taAddFirst:
  7034.         hInsertAfter := TVI_FIRST;
  7035.       taAdd:
  7036.         hInsertAfter := TVI_LAST;
  7037.       taInsert:
  7038.         hInsertAfter := Target;
  7039.     end;
  7040.   end;
  7041.   InsertStruct.item := Item;
  7042.   FOwner.FChangeTimer.Enabled := False;
  7043.   Result := TreeView_InsertItem(Handle, InsertStruct);
  7044. end;
  7045.  
  7046. function TTreeNodes.GetFirstNode: TTreeNode;
  7047. begin
  7048.   Result := GetNode(TreeView_GetRoot(Handle));
  7049. end;
  7050.  
  7051. function TTreeNodes.GetNodeFromIndex(Index: Integer): TTreeNode;
  7052. var
  7053.   I: Integer;
  7054. begin
  7055.   if Index < 0 then TreeViewError(sInvalidIndex);
  7056.   if (FNodeCache.CacheNode <> nil) and (Abs(FNodeCache.CacheIndex - Index) <= 1) then
  7057.   begin
  7058.     with FNodeCache do
  7059.     begin
  7060.       if Index = CacheIndex then Result := CacheNode
  7061.       else if Index < CacheIndex then Result := CacheNode.GetPrev
  7062.       else Result := CacheNode.GetNext;
  7063.     end;
  7064.   end
  7065.   else begin
  7066.     Result := GetFirstNode;
  7067.     I := Index;
  7068.     while (I <> 0) and (Result <> nil) do
  7069.     begin
  7070.       Result := Result.GetNext;
  7071.       Dec(I);
  7072.     end;
  7073.   end;
  7074.   if Result = nil then TreeViewError(sInvalidIndex);
  7075.   FNodeCache.CacheNode := Result;
  7076.   FNodeCache.CacheIndex := Index;
  7077. end;
  7078.  
  7079. function TTreeNodes.GetNode(ItemId: HTreeItem): TTreeNode;
  7080. var
  7081.   Item: TTVItem;
  7082. begin
  7083.   with Item do
  7084.   begin
  7085.     hItem := ItemId;
  7086.     mask := TVIF_PARAM;
  7087.   end;
  7088.   if TreeView_GetItem(Handle, Item) then Result := TTreeNode(Item.lParam)
  7089.   else Result := nil;
  7090. end;
  7091.  
  7092. procedure TTreeNodes.SetItem(Index: Integer; Value: TTreeNode);
  7093. begin
  7094.   GetNodeFromIndex(Index).Assign(Value);
  7095. end;
  7096.  
  7097. procedure TTreeNodes.BeginUpdate;
  7098. begin
  7099.   if FUpdateCount = 0 then SetUpdateState(True);
  7100.   Inc(FUpdateCount);
  7101. end;          
  7102.  
  7103. procedure TTreeNodes.SetUpdateState(Updating: Boolean);
  7104. begin
  7105.   SendMessage(Handle, WM_SETREDRAW, Ord(not Updating), 0);
  7106.   if not Updating then Owner.Refresh;
  7107. end;
  7108.  
  7109. procedure TTreeNodes.EndUpdate;
  7110. begin
  7111.   Dec(FUpdateCount);
  7112.   if FUpdateCount = 0 then SetUpdateState(False);
  7113. end;
  7114.  
  7115. procedure TTreeNodes.Assign(Source: TPersistent);
  7116. var
  7117.   TreeNodes: TTreeNodes;
  7118.   MemStream: TMemoryStream;
  7119. begin
  7120.   ClearCache;
  7121.   if Source is TTreeNodes then
  7122.   begin
  7123.     TreeNodes := TTreeNodes(Source);
  7124.     Clear;
  7125.     MemStream := TMemoryStream.Create;
  7126.     try
  7127.       TreeNodes.WriteData(MemStream);
  7128.       MemStream.Position := 0;
  7129.       ReadData(MemStream);
  7130.     finally
  7131.       MemStream.Free;
  7132.     end;
  7133.   end
  7134.   else inherited Assign(Source);
  7135. end;
  7136.  
  7137. procedure TTreeNodes.DefineProperties(Filer: TFiler);
  7138.  
  7139.   function WriteNodes: Boolean;
  7140.   var
  7141.     I: Integer;
  7142.     Nodes: TTreeNodes;
  7143.   begin
  7144.     Nodes := TTreeNodes(Filer.Ancestor);
  7145.     if Nodes = nil then
  7146.       Result := Count > 0
  7147.     else if Nodes.Count <> Count then
  7148.       Result := True
  7149.     else
  7150.     begin
  7151.       Result := False;
  7152.       for I := 0 to Count - 1 do
  7153.       begin
  7154.         Result := not Item[I].IsEqual(Nodes[I]);
  7155.         if Result then Break;
  7156.       end
  7157.     end;
  7158.   end;
  7159.  
  7160. begin
  7161.   inherited DefineProperties(Filer);
  7162.   Filer.DefineBinaryProperty('Data', ReadData, WriteData, WriteNodes);
  7163. end;
  7164.  
  7165. procedure TTreeNodes.ReadData(Stream: TStream);
  7166. var
  7167.   I, Count: Integer;
  7168.   NodeInfo: TNodeInfo;
  7169. begin
  7170.   Clear;
  7171.   Stream.ReadBuffer(Count, SizeOf(Count));
  7172.   for I := 0 to Count - 1 do
  7173.     Add(nil, '').ReadData(Stream, @NodeInfo);
  7174. end;
  7175.  
  7176. procedure TTreeNodes.WriteData(Stream: TStream);
  7177. var
  7178.   I: Integer;
  7179.   Node: TTreeNode;
  7180.   NodeInfo: TNodeInfo;
  7181. begin
  7182.   I := 0;
  7183.   Node := GetFirstNode;
  7184.   while Node <> nil do
  7185.   begin
  7186.     Inc(I);
  7187.     Node := Node.GetNextSibling;
  7188.   end;
  7189.   Stream.WriteBuffer(I, SizeOf(I));
  7190.   Node := GetFirstNode;
  7191.   while Node <> nil do
  7192.   begin
  7193.     Node.WriteData(Stream, @NodeInfo);
  7194.     Node := Node.GetNextSibling;
  7195.   end;
  7196. end;
  7197.  
  7198. procedure TTreeNodes.ReadExpandedState(Stream: TStream);
  7199. var
  7200.   ItemCount,
  7201.   Index: Integer;
  7202.   Node: TTreeNode;
  7203.   NodeExpanded: Boolean;
  7204. begin
  7205.   if Stream.Position < Stream.Size then
  7206.     Stream.ReadBuffer(ItemCount, SizeOf(ItemCount))
  7207.   else Exit;
  7208.   Index := 0;
  7209.   Node := GetFirstNode;
  7210.   while (Index < ItemCount) and (Node <> nil) do
  7211.   begin
  7212.     Stream.ReadBuffer(NodeExpanded, SizeOf(NodeExpanded));
  7213.     Node.Expanded := NodeExpanded;
  7214.     Inc(Index);
  7215.     Node := Node.GetNext;
  7216.   end;
  7217. end;
  7218.  
  7219. procedure TTreeNodes.WriteExpandedState(Stream: TStream);
  7220. var
  7221.   Size: Integer;
  7222.   Node: TTreeNode;
  7223.   NodeExpanded: Boolean;
  7224. begin
  7225.   Size := SizeOf(Boolean) * Count;
  7226.   Stream.WriteBuffer(Size, SizeOf(Size));
  7227.   Node := GetFirstNode;
  7228.   while (Node <> nil) do
  7229.   begin
  7230.     NodeExpanded := Node.Expanded;
  7231.     Stream.WriteBuffer(NodeExpanded, SizeOf(Boolean));
  7232.     Node := Node.GetNext;
  7233.   end;
  7234. end;
  7235.  
  7236. procedure TTreeNodes.ClearCache;
  7237. begin
  7238.   FNodeCache.CacheNode := nil;
  7239. end;
  7240.  
  7241. type
  7242.   TTreeStrings = class(TStrings)
  7243.   private
  7244.     FOwner: TTreeNodes;
  7245.   protected
  7246.     function Get(Index: Integer): string; override;
  7247.     function GetBufStart(Buffer: PChar; var Level: Integer): PChar;
  7248.     function GetCount: Integer; override;
  7249.     function GetObject(Index: Integer): TObject; override;
  7250.     procedure PutObject(Index: Integer; AObject: TObject); override;
  7251.     procedure SetUpdateState(Updating: Boolean); override;
  7252.   public
  7253.     constructor Create(AOwner: TTreeNodes);
  7254.     function Add(const S: string): Integer; override;
  7255.     procedure Clear; override;
  7256.     procedure Delete(Index: Integer); override;
  7257.     procedure Insert(Index: Integer; const S: string); override;
  7258.     procedure LoadTreeFromStream(Stream: TStream);
  7259.     procedure SaveTreeToStream(Stream: TStream);
  7260.     property Owner: TTreeNodes read FOwner;
  7261.   end;
  7262.  
  7263. constructor TTreeStrings.Create(AOwner: TTreeNodes);
  7264. begin
  7265.   inherited Create;
  7266.   FOwner := AOwner;
  7267. end;
  7268.  
  7269. function TTreeStrings.Get(Index: Integer): string;
  7270. const
  7271.   TabChar = #9;
  7272. var
  7273.   Level, I: Integer;
  7274.   Node: TTreeNode;
  7275. begin
  7276.   Result := '';
  7277.   Node := Owner.GetNodeFromIndex(Index);
  7278.   Level := Node.Level;
  7279.   for I := 0 to Level - 1 do Result := Result + TabChar;
  7280.   Result := Result + Node.Text;
  7281. end;
  7282.  
  7283. function TTreeStrings.GetBufStart(Buffer: PChar; var Level: Integer): PChar;
  7284. begin
  7285.   Level := 0;
  7286.   while Buffer^ in [' ', #9] do
  7287.   begin
  7288.     Inc(Buffer);
  7289.     Inc(Level);
  7290.   end;
  7291.   Result := Buffer;
  7292. end;
  7293.  
  7294. function TTreeStrings.GetObject(Index: Integer): TObject;
  7295. begin
  7296.   Result := Owner.GetNodeFromIndex(Index).Data;
  7297. end;
  7298.  
  7299. procedure TTreeStrings.PutObject(Index: Integer; AObject: TObject);
  7300. begin
  7301.   Owner.GetNodeFromIndex(Index).Data := AObject;
  7302. end;
  7303.  
  7304. function TTreeStrings.GetCount: Integer;
  7305. begin
  7306.   Result := Owner.Count;
  7307. end;
  7308.  
  7309. procedure TTreeStrings.Clear;
  7310. begin
  7311.   Owner.Clear;
  7312. end;
  7313.  
  7314. procedure TTreeStrings.Delete(Index: Integer);
  7315. begin
  7316.   Owner.GetNodeFromIndex(Index).Delete;
  7317. end;
  7318.  
  7319. procedure TTreeStrings.SetUpdateState(Updating: Boolean);
  7320. begin
  7321.   SendMessage(Owner.Handle, WM_SETREDRAW, Ord(not Updating), 0);
  7322.   if not Updating then Owner.Owner.Refresh;
  7323. end;
  7324.  
  7325. function TTreeStrings.Add(const S: string): Integer;
  7326. var
  7327.   Level, OldLevel, I: Integer;
  7328.   NewStr: string;
  7329.   Node: TTreeNode;
  7330. begin
  7331.   Result := GetCount;
  7332.   if (Length(S) = 1) and (S[1] = Chr($1A)) then Exit;
  7333.   Node := nil;
  7334.   OldLevel := 0;
  7335.   NewStr := GetBufStart(PChar(S), Level);
  7336.   if Result > 0 then
  7337.   begin
  7338.     Node := Owner.GetNodeFromIndex(Result - 1);
  7339.     OldLevel := Node.Level;
  7340.   end;
  7341.   if (Level > OldLevel) or (Node = nil) then
  7342.   begin
  7343.     if Level - OldLevel > 1 then TreeViewError(sInvalidLevel);
  7344.   end
  7345.   else begin
  7346.     for I := OldLevel downto Level do
  7347.     begin
  7348.       Node := Node.Parent;
  7349.       if (Node = nil) and (I - Level > 0) then
  7350.         TreeViewError(sInvalidLevel);
  7351.     end;
  7352.   end;
  7353.   Owner.AddChild(Node, NewStr);
  7354. end;
  7355.  
  7356. procedure TTreeStrings.Insert(Index: Integer; const S: string);
  7357. begin
  7358.   with Owner do
  7359.     Insert(GetNodeFromIndex(Index), S);
  7360. end;
  7361.  
  7362. procedure TTreeStrings.LoadTreeFromStream(Stream: TStream);
  7363. var
  7364.   List: TStringList;
  7365.   ANode, NextNode: TTreeNode;
  7366.   ALevel, i: Integer;
  7367.   CurrStr: string;
  7368. begin
  7369.   List := TStringList.Create;
  7370.   Owner.BeginUpdate;
  7371.   try
  7372.     try
  7373.       Clear;
  7374.       List.LoadFromStream(Stream);
  7375.       ANode := nil;
  7376.       for i := 0 to List.Count - 1 do
  7377.       begin
  7378.         CurrStr := GetBufStart(PChar(List[i]), ALevel);
  7379.         if ANode = nil then
  7380.           ANode := Owner.AddChild(nil, CurrStr)
  7381.         else if ANode.Level = ALevel then
  7382.           ANode := Owner.AddChild(ANode.Parent, CurrStr)
  7383.         else if ANode.Level = (ALevel - 1) then
  7384.           ANode := Owner.AddChild(ANode, CurrStr)
  7385.         else if ANode.Level > ALevel then
  7386.         begin
  7387.           NextNode := ANode.Parent;
  7388.           while NextNode.Level > ALevel do
  7389.             NextNode := NextNode.Parent;
  7390.           ANode := Owner.AddChild(NextNode.Parent, CurrStr);
  7391.         end
  7392.         else TreeViewErrorFmt(sInvalidLevelEx, [ALevel, CurrStr]);
  7393.       end;
  7394.     finally
  7395.       Owner.EndUpdate;
  7396.       List.Free;
  7397.     end;
  7398.   except
  7399.     Owner.Owner.Invalidate;  // force repaint on exception
  7400.     raise;
  7401.   end;
  7402. end;
  7403.  
  7404. procedure TTreeStrings.SaveTreeToStream(Stream: TStream);
  7405. const
  7406.   TabChar = #9;
  7407.   EndOfLine = #13#10;
  7408. var
  7409.   i: Integer;
  7410.   ANode: TTreeNode;
  7411.   NodeStr: string;
  7412. begin
  7413.   if Count > 0 then
  7414.   begin
  7415.     ANode := Owner[0];
  7416.     while ANode <> nil do
  7417.     begin
  7418.       NodeStr := '';
  7419.       for i := 0 to ANode.Level - 1 do NodeStr := NodeStr + TabChar;
  7420.       NodeStr := NodeStr + ANode.Text + EndOfLine;
  7421.       Stream.Write(Pointer(NodeStr)^, Length(NodeStr));
  7422.       ANode := ANode.GetNext;
  7423.     end;
  7424.   end;
  7425. end;
  7426.  
  7427. { TCustomTreeView }
  7428.  
  7429. constructor TCustomTreeView.Create(AOwner: TComponent);
  7430. begin
  7431.   inherited Create(AOwner);
  7432.   ControlStyle := ControlStyle - [csCaptureMouse] + [csDisplayDragImage, csReflector];
  7433.   Width := 121;
  7434.   Height := 97;
  7435.   TabStop := True;
  7436.   ParentColor := False;
  7437.   FCanvas := TControlCanvas.Create;
  7438.   TControlCanvas(FCanvas).Control := Self;
  7439.   FTreeNodes := TTreeNodes.Create(Self);
  7440.   FBorderStyle := bsSingle;
  7441.   FShowButtons := True;
  7442.   FShowRoot := True;
  7443.   FShowLines := True;
  7444.   FHideSelection := True;
  7445.   FDragImage := TDragImageList.CreateSize(32, 32);
  7446.   FSaveIndent := -1;
  7447.   FChangeTimer := TTimer.Create(Self);
  7448.   FChangeTimer.Enabled := False;
  7449.   FChangeTimer.Interval := 0;
  7450.   FChangeTimer.OnTimer := OnChangeTimer;
  7451.   FToolTips := True;
  7452.   FEditInstance := MakeObjectInstance(EditWndProc);
  7453.   FImageChangeLink := TChangeLink.Create;
  7454.   FImageChangeLink.OnChange := ImageListChange;
  7455.   FStateChangeLink := TChangeLink.Create;
  7456.   FStateChangeLink.OnChange := ImageListChange;
  7457. end;
  7458.  
  7459. destructor TCustomTreeView.Destroy;
  7460. begin
  7461.   FreeAndNil(FTreeNodes);
  7462.   FChangeTimer.Free;
  7463.   FSaveItems.Free;
  7464.   FDragImage.Free;
  7465.   FMemStream.Free;
  7466.   FreeObjectInstance(FEditInstance);
  7467.   FImageChangeLink.Free;
  7468.   FStateChangeLink.Free;
  7469.   FCanvas.Free;
  7470.   inherited Destroy;
  7471. end;
  7472.  
  7473. procedure TCustomTreeView.CreateParams(var Params: TCreateParams);
  7474. const
  7475.   BorderStyles: array[TBorderStyle] of DWORD = (0, WS_BORDER);
  7476.   LineStyles: array[Boolean] of DWORD = (0, TVS_HASLINES);
  7477.   RootStyles: array[Boolean] of DWORD = (0, TVS_LINESATROOT);
  7478.   ButtonStyles: array[Boolean] of DWORD = (0, TVS_HASBUTTONS);
  7479.   EditStyles: array[Boolean] of DWORD = (TVS_EDITLABELS, 0);
  7480.   HideSelections: array[Boolean] of DWORD = (TVS_SHOWSELALWAYS, 0);
  7481.   DragStyles: array[TDragMode] of DWORD = (TVS_DISABLEDRAGDROP, 0);
  7482.   RTLStyles: array[Boolean] of DWORD = (0, TVS_RTLREADING);
  7483.   ToolTipStyles: array[Boolean] of DWORD = (TVS_NOTOOLTIPS, 0);
  7484.   AutoExpandStyles: array[Boolean] of DWORD = (0, TVS_SINGLEEXPAND);
  7485.   HotTrackStyles: array[Boolean] of DWORD = (0, TVS_TRACKSELECT);
  7486.   RowSelectStyles: array[Boolean] of DWORD = (0, TVS_FULLROWSELECT);
  7487. begin
  7488.   InitCommonControl(ICC_TREEVIEW_CLASSES);
  7489.   inherited CreateParams(Params);
  7490.   CreateSubClass(Params, WC_TREEVIEW);
  7491.   with Params do
  7492.   begin
  7493.     Style := Style or LineStyles[FShowLines] or BorderStyles[FBorderStyle] or
  7494.       RootStyles[FShowRoot] or ButtonStyles[FShowButtons] or
  7495.       EditStyles[FReadOnly] or HideSelections[FHideSelection] or
  7496.       DragStyles[DragMode] or RTLStyles[UseRightToLeftReading] or
  7497.       ToolTipStyles[FToolTips] or AutoExpandStyles[FAutoExpand] or
  7498.       HotTrackStyles[FHotTrack] or RowSelectStyles[FRowSelect];
  7499.     if Ctl3D and NewStyleControls and (FBorderStyle = bsSingle) then
  7500.     begin
  7501.       Style := Style and not WS_BORDER;
  7502.       ExStyle := Params.ExStyle or WS_EX_CLIENTEDGE;
  7503.     end;
  7504.     WindowClass.style := WindowClass.style and not (CS_HREDRAW or CS_VREDRAW);
  7505.   end;
  7506. end;
  7507.  
  7508. procedure TCustomTreeView.CreateWnd;
  7509. begin
  7510.   FStateChanging := False;
  7511.   inherited CreateWnd;
  7512.   TreeView_SetBkColor(Handle, ColorToRGB(Color));
  7513.   TreeView_SetTextColor(Handle, ColorToRGB(Font.Color));
  7514.   if FMemStream <> nil then
  7515.   begin
  7516.     Items.ReadData(FMemStream);
  7517.     Items.ReadExpandedState(FMemStream);
  7518.     FMemStream.Destroy;
  7519.     FMemStream := nil;
  7520.     SetTopItem(Items.GetNodeFromIndex(FSaveTopIndex));
  7521.     FSaveTopIndex := 0;
  7522.     SetSelection(Items.GetNodeFromIndex(FSaveIndex));
  7523.     FSaveIndex := 0;
  7524.   end;
  7525.   if FSaveIndent <> -1 then Indent := FSaveIndent;
  7526.   if (Images <> nil) and Images.HandleAllocated then
  7527.     SetImageList(Images.Handle, TVSIL_NORMAL);
  7528.   if (StateImages <> nil) and StateImages.HandleAllocated then
  7529.     SetImageList(StateImages.Handle, TVSIL_STATE);
  7530. end;
  7531.  
  7532. procedure TCustomTreeView.DestroyWnd;
  7533. var
  7534.   Node: TTreeNode;
  7535. begin
  7536.   FStateChanging := True;
  7537.   if Items.Count > 0 then
  7538.   begin
  7539.     FMemStream := TMemoryStream.Create;
  7540.     Items.WriteData(FMemStream);
  7541.     Items.WriteExpandedState(FMemStream);
  7542.     FMemStream.Position := 0;
  7543.     Node := GetTopItem;
  7544.     if Node <> nil then FSaveTopIndex := Node.AbsoluteIndex;
  7545.     Node := Selected;
  7546.     if Node <> nil then FSaveIndex := Node.AbsoluteIndex;
  7547.   end;
  7548.   FSaveIndent := Indent;
  7549.   inherited DestroyWnd;
  7550. end;
  7551.  
  7552. procedure TCustomTreeView.EditWndProc(var Message: TMessage);
  7553. begin
  7554.   try
  7555.     with Message do
  7556.     begin
  7557.       case Msg of
  7558.         WM_KEYDOWN,
  7559.         WM_SYSKEYDOWN: if DoKeyDown(TWMKey(Message)) then Exit;
  7560.         WM_CHAR: if DoKeyPress(TWMKey(Message)) then Exit;
  7561.         WM_KEYUP,
  7562.         WM_SYSKEYUP: if DoKeyUp(TWMKey(Message)) then Exit;
  7563.         CN_KEYDOWN,
  7564.         CN_CHAR, CN_SYSKEYDOWN,
  7565.         CN_SYSCHAR:
  7566.           begin
  7567.             WndProc(Message);
  7568.             Exit;
  7569.           end;
  7570.       end;
  7571.       Result := CallWindowProc(FDefEditProc, FEditHandle, Msg, WParam, LParam);
  7572.     end;
  7573.   except
  7574.     Application.HandleException(Self);
  7575.   end;
  7576. end;
  7577.  
  7578. procedure TCustomTreeView.CMColorChanged(var Message: TMessage);
  7579. begin
  7580.   inherited;
  7581.   RecreateWnd;
  7582. end;
  7583.  
  7584. procedure TCustomTreeView.CMCtl3DChanged(var Message: TMessage);
  7585. begin
  7586.   inherited;
  7587.   if FBorderStyle = bsSingle then RecreateWnd;
  7588. end;
  7589.  
  7590. procedure TCustomTreeView.CMFontChanged(var Message: TMessage);
  7591. begin
  7592.   inherited;
  7593.   TreeView_SetTextColor(Handle, ColorToRGB(Font.Color));
  7594. end;
  7595.  
  7596. procedure TCustomTreeView.CMSysColorChange(var Message: TMessage);
  7597. begin
  7598.   inherited;
  7599.   if not (csLoading in ComponentState) then
  7600.   begin
  7601.     Message.Msg := WM_SYSCOLORCHANGE;
  7602.     DefaultHandler(Message);
  7603.   end;
  7604. end;
  7605.  
  7606. function TCustomTreeView.AlphaSort: Boolean;
  7607. var
  7608.   Node: TTreeNode;
  7609. begin
  7610.   if HandleAllocated then
  7611.   begin
  7612.     Result := CustomSort(nil, 0);
  7613.     Node := FTreeNodes.GetFirstNode;
  7614.     while Node <> nil do
  7615.     begin
  7616.       if Node.HasChildren then Node.AlphaSort;
  7617.       Node := Node.GetNext;
  7618.     end;
  7619.   end
  7620.   else
  7621.     Result := False;
  7622. end;
  7623.  
  7624. function TCustomTreeView.CustomSort(SortProc: TTVCompare; Data: Longint): Boolean;
  7625. var
  7626.   SortCB: TTVSortCB;
  7627.   Node: TTreeNode;
  7628. begin
  7629.   Result := False;
  7630.   if HandleAllocated then
  7631.   begin
  7632.     with SortCB do
  7633.     begin
  7634.       if not Assigned(SortProc) then lpfnCompare := @DefaultTreeViewSort
  7635.       else lpfnCompare := SortProc;
  7636.       hParent := TVI_ROOT;
  7637.       lParam := Data;
  7638.       Result := TreeView_SortChildrenCB(Handle, SortCB, 0);
  7639.     end;
  7640.     Node := FTreeNodes.GetFirstNode;
  7641.     while Node <> nil do
  7642.     begin
  7643.       if Node.HasChildren then Node.CustomSort(SortProc, Data);
  7644.       Node := Node.GetNext;
  7645.     end;
  7646.     Items.ClearCache;
  7647.   end;
  7648. end;
  7649.  
  7650. procedure TCustomTreeView.SetAutoExpand(Value: Boolean);
  7651. begin
  7652.   if FAutoExpand <> Value then
  7653.   begin
  7654.     FAutoExpand := Value;
  7655.     SetComCtlStyle(Self, TVS_SINGLEEXPAND, Value);
  7656.   end;
  7657. end;
  7658.  
  7659. procedure TCustomTreeView.SetHotTrack(Value: Boolean);
  7660. begin
  7661.   if FHotTrack <> Value then
  7662.   begin
  7663.     FHotTrack := Value;
  7664.     SetComCtlStyle(Self, TVS_TRACKSELECT, Value);
  7665.   end;
  7666. end;
  7667.  
  7668. procedure TCustomTreeView.SetRowSelect(Value: Boolean);
  7669. begin
  7670.   if FRowSelect <> Value then
  7671.   begin
  7672.     FRowSelect := Value;
  7673.     SetComCtlStyle(Self, TVS_FULLROWSELECT, Value);
  7674.   end;
  7675. end;
  7676.  
  7677. procedure TCustomTreeView.SetToolTips(Value: Boolean);
  7678. begin
  7679.   if FToolTips <> Value then
  7680.   begin
  7681.     FToolTips := Value;
  7682.     SetComCtlStyle(Self, TVS_NOTOOLTIPS, not Value);
  7683.   end;
  7684. end;
  7685.  
  7686. procedure TCustomTreeView.SetSortType(Value: TSortType);
  7687. begin
  7688.   if SortType <> Value then
  7689.   begin
  7690.     FSortType := Value;
  7691.     if ((SortType in [stData, stBoth]) and Assigned(OnCompare)) or
  7692.       (SortType in [stText, stBoth]) then
  7693.       AlphaSort;
  7694.   end;
  7695. end;
  7696.  
  7697. procedure TCustomTreeView.SetBorderStyle(Value: TBorderStyle);
  7698. begin
  7699.   if BorderStyle <> Value then
  7700.   begin
  7701.     FBorderStyle := Value;
  7702.     RecreateWnd;
  7703.   end;
  7704. end;
  7705.  
  7706. procedure TCustomTreeView.SetDragMode(Value: TDragMode);
  7707. begin
  7708.   if Value <> DragMode then
  7709.     SetComCtlStyle(Self, TVS_DISABLEDRAGDROP, Value = dmManual);
  7710.   inherited;
  7711. end;
  7712.  
  7713. procedure TCustomTreeView.SetButtonStyle(Value: Boolean);
  7714. begin
  7715.   if ShowButtons <> Value then
  7716.   begin
  7717.     FShowButtons := Value;
  7718.     SetComCtlStyle(Self, TVS_HASBUTTONS, Value);
  7719.   end;
  7720. end;
  7721.  
  7722. procedure TCustomTreeView.SetLineStyle(Value: Boolean);
  7723. begin
  7724.   if ShowLines <> Value then
  7725.   begin
  7726.     FShowLines := Value;
  7727.     SetComCtlStyle(Self, TVS_HASLINES, Value);
  7728.   end;
  7729. end;
  7730.  
  7731. procedure TCustomTreeView.SetRootStyle(Value: Boolean);
  7732. begin
  7733.   if ShowRoot <> Value then
  7734.   begin
  7735.     FShowRoot := Value;
  7736.     SetComCtlStyle(Self, TVS_LINESATROOT, Value);
  7737.   end;
  7738. end;
  7739.  
  7740. procedure TCustomTreeView.SetReadOnly(Value: Boolean);
  7741. begin
  7742.   if ReadOnly <> Value then
  7743.   begin
  7744.     FReadOnly := Value;
  7745.     SetComCtlStyle(Self, TVS_EDITLABELS, not Value);
  7746.   end;
  7747. end;
  7748.  
  7749. procedure TCustomTreeView.SetHideSelection(Value: Boolean);
  7750. begin
  7751.   if HideSelection <> Value then
  7752.   begin
  7753.     FHideSelection := Value;
  7754.     SetComCtlStyle(Self, TVS_SHOWSELALWAYS, not Value);
  7755.     Invalidate;
  7756.   end;
  7757. end;
  7758.  
  7759. function TCustomTreeView.GetNodeAt(X, Y: Integer): TTreeNode;
  7760. var
  7761.   HitTest: TTVHitTestInfo;
  7762. begin
  7763.   with HitTest do
  7764.   begin
  7765.     pt.X := X;
  7766.     pt.Y := Y;
  7767.     if TreeView_HitTest(Handle, HitTest) <> nil then
  7768.       Result := Items.GetNode(HitTest.hItem)
  7769.     else Result := nil;
  7770.   end;
  7771. end;
  7772.  
  7773. function TCustomTreeView.GetHitTestInfoAt(X, Y: Integer): THitTests;
  7774. var
  7775.   HitTest: TTVHitTestInfo;
  7776. begin
  7777.   Result := [];
  7778.   with HitTest do
  7779.   begin
  7780.     pt.X := X;
  7781.     pt.Y := Y;
  7782.     TreeView_HitTest(Handle, HitTest);
  7783.     if (flags and TVHT_ABOVE) <> 0 then Include(Result, htAbove);
  7784.     if (flags and TVHT_BELOW) <> 0 then Include(Result, htBelow);
  7785.     if (flags and TVHT_NOWHERE) <> 0 then Include(Result, htNowhere);
  7786.     if (flags and TVHT_ONITEM) = TVHT_ONITEM then
  7787.       Include(Result, htOnItem)
  7788.     else
  7789.     begin
  7790.       if (flags and TVHT_ONITEM) <> 0 then Include(Result, htOnItem);
  7791.       if (flags and TVHT_ONITEMICON) <> 0 then Include(Result, htOnIcon);
  7792.       if (flags and TVHT_ONITEMLABEL) <> 0 then Include(Result, htOnLabel);
  7793.       if (flags and TVHT_ONITEMSTATEICON) <> 0 then Include(Result, htOnStateIcon);
  7794.     end;
  7795.     if (flags and TVHT_ONITEMBUTTON) <> 0 then Include(Result, htOnButton);
  7796.     if (flags and TVHT_ONITEMINDENT) <> 0 then Include(Result, htOnIndent);
  7797.     if (flags and TVHT_ONITEMRIGHT) <> 0 then Include(Result, htOnRight);
  7798.     if (flags and TVHT_TOLEFT) <> 0 then Include(Result, htToLeft);
  7799.     if (flags and TVHT_TORIGHT) <> 0 then Include(Result, htToRight);
  7800.   end;
  7801. end;
  7802.  
  7803. procedure TCustomTreeView.SetTreeNodes(Value: TTreeNodes);
  7804. begin
  7805.   Items.Assign(Value);
  7806. end;
  7807.  
  7808. procedure TCustomTreeView.SetIndent(Value: Integer);
  7809. begin
  7810.   if Value <> Indent then TreeView_SetIndent(Handle, Value);
  7811. end;
  7812.  
  7813. function TCustomTreeView.GetIndent: Integer;
  7814. begin
  7815.   Result := TreeView_GetIndent(Handle)
  7816. end;
  7817.  
  7818. procedure TCustomTreeView.FullExpand;
  7819. var
  7820.   Node: TTreeNode;
  7821. begin
  7822.   Node := Items.GetFirstNode;
  7823.   while Node <> nil do
  7824.   begin
  7825.     Node.Expand(True);
  7826.     Node := Node.GetNextSibling;
  7827.   end;
  7828. end;
  7829.  
  7830. procedure TCustomTreeView.FullCollapse;
  7831. var
  7832.   Node: TTreeNode;
  7833. begin
  7834.   Node := Items.GetFirstNode;
  7835.   while Node <> nil do
  7836.   begin
  7837.     Node.Collapse(True);
  7838.     Node := Node.GetNextSibling;
  7839.   end;
  7840. end;
  7841.  
  7842. procedure TCustomTreeView.Loaded;
  7843. begin
  7844.   inherited Loaded;
  7845.   if csDesigning in ComponentState then FullExpand;
  7846. end;
  7847.  
  7848. function TCustomTreeView.GetTopItem: TTreeNode;
  7849. begin
  7850.   if HandleAllocated then
  7851.     Result := Items.GetNode(TreeView_GetFirstVisible(Handle))
  7852.   else Result := nil;
  7853. end;
  7854.  
  7855. procedure TCustomTreeView.SetTopItem(Value: TTreeNode);
  7856. begin
  7857.   if HandleAllocated and (Value <> nil) then
  7858.     TreeView_SelectSetFirstVisible(Handle, Value.ItemId);
  7859. end;
  7860.  
  7861. procedure TCustomTreeView.OnChangeTimer(Sender: TObject);
  7862. begin
  7863.   FChangeTimer.Enabled := False;
  7864.   Change(TTreeNode(FChangeTimer.Tag));
  7865. end;
  7866.  
  7867. function TCustomTreeView.GetSelection: TTreeNode;
  7868. begin
  7869.   if HandleAllocated then
  7870.   begin
  7871.     if FRightClickSelect and Assigned(FRClickNode) then
  7872.       Result := FRClickNode
  7873.     else
  7874.       Result := Items.GetNode(TreeView_GetSelection(Handle));
  7875.   end
  7876.   else Result := nil;
  7877. end;
  7878.  
  7879. procedure TCustomTreeView.SetSelection(Value: TTreeNode);
  7880. begin
  7881.   if Value <> nil then Value.Selected := True
  7882.   else TreeView_SelectItem(Handle, nil);
  7883. end;
  7884.  
  7885. procedure TCustomTreeView.SetChangeDelay(Value: Integer);
  7886. begin
  7887.   FChangeTimer.Interval := Value;
  7888. end;
  7889.  
  7890. function TCustomTreeView.GetChangeDelay: Integer;
  7891. begin
  7892.   Result := FChangeTimer.Interval;
  7893. end;
  7894.  
  7895. function TCustomTreeView.GetDropTarget: TTreeNode;
  7896. begin
  7897.   if HandleAllocated then
  7898.   begin
  7899.     Result := Items.GetNode(TreeView_GetDropHilite(Handle));
  7900.     if Result = nil then Result := FLastDropTarget;
  7901.   end
  7902.   else Result := nil;
  7903. end;
  7904.  
  7905. procedure TCustomTreeView.SetDropTarget(Value: TTreeNode);
  7906. begin
  7907.   if HandleAllocated then
  7908.     if Value <> nil then Value.DropTarget := True
  7909.     else TreeView_SelectDropTarget(Handle, nil);
  7910. end;
  7911.  
  7912. function TCustomTreeView.GetNodeFromItem(const Item: TTVItem): TTreeNode;
  7913. begin
  7914.   Result := nil;
  7915.   if Items <> nil then
  7916.     with Item do
  7917.       if (state and TVIF_PARAM) <> 0 then Result := Pointer(lParam)
  7918.       else Result := Items.GetNode(hItem);
  7919. end;
  7920.  
  7921. function TCustomTreeView.IsEditing: Boolean;
  7922. var
  7923.   ControlHand: HWnd;
  7924. begin
  7925.   ControlHand := TreeView_GetEditControl(Handle);
  7926.   Result := (ControlHand <> 0) and IsWindowVisible(ControlHand);
  7927. end;
  7928.  
  7929. procedure TCustomTreeView.CNNotify(var Message: TWMNotify);
  7930. var
  7931.   Node: TTreeNode;
  7932.   MousePos: TPoint;
  7933.   R: TRect;
  7934.   DefaultDraw, PaintImages: Boolean;
  7935.   TmpItem: TTVItem;
  7936.   LogFont: TLogFont;
  7937. begin
  7938.   with Message do
  7939.     case NMHdr^.code of
  7940.       NM_CUSTOMDRAW:
  7941.         with PNMCustomDraw(NMHdr)^ do
  7942.         begin
  7943.           FCanvas.Lock;
  7944.           try
  7945.             Result := CDRF_DODEFAULT;
  7946.             if (dwDrawStage and CDDS_ITEM) = 0 then
  7947.             begin
  7948.               R := ClientRect;
  7949.               case dwDrawStage of
  7950.                 CDDS_PREPAINT:
  7951.                 begin
  7952.                   if IsCustomDrawn(dtControl, cdPrePaint) then
  7953.                   begin
  7954.                     try
  7955.                       FCanvas.Handle := hdc;
  7956.                       FCanvas.Font := Font;
  7957.                       FCanvas.Brush := Brush;
  7958.                       DefaultDraw := CustomDraw(R, cdPrePaint);
  7959.                     finally
  7960.                       FCanvas.Handle := 0;
  7961.                     end;
  7962.                     if not DefaultDraw then
  7963.                     begin
  7964.                       Result := CDRF_SKIPDEFAULT;
  7965.                       Exit;
  7966.                     end;
  7967.                   end;
  7968.                   if IsCustomDrawn(dtItem, cdPrePaint) or IsCustomDrawn(dtItem, cdPreErase) then
  7969.                     Result := Result or CDRF_NOTIFYITEMDRAW;
  7970.                   if IsCustomDrawn(dtItem, cdPostPaint) then
  7971.                     Result := Result or CDRF_NOTIFYPOSTPAINT;
  7972.                   if IsCustomDrawn(dtItem, cdPostErase) then
  7973.                     Result := Result or CDRF_NOTIFYPOSTERASE;
  7974.                 end;
  7975.                 CDDS_POSTPAINT:
  7976.                   if IsCustomDrawn(dtControl, cdPostPaint) then
  7977.                     CustomDraw(R, cdPostPaint);
  7978.                 CDDS_PREERASE:
  7979.                   if IsCustomDrawn(dtControl, cdPreErase) then
  7980.                     CustomDraw(R, cdPreErase);
  7981.                 CDDS_POSTERASE:
  7982.                   if IsCustomDrawn(dtControl, cdPostErase) then
  7983.                     CustomDraw(R, cdPostErase);
  7984.               end;
  7985.             end else
  7986.             begin
  7987.               FillChar(TmpItem, SizeOf(TmpItem), 0);
  7988.               TmpItem.hItem := HTREEITEM(dwItemSpec);
  7989.               Node := GetNodeFromItem(TmpItem);
  7990.               if Node = nil then Exit;
  7991.               case dwDrawStage of
  7992.                 CDDS_ITEMPREPAINT:
  7993.                   try
  7994.                     FCanvas.Handle := hdc;
  7995.                     FCanvas.Font := Font;
  7996.                     FCanvas.Brush := Brush;
  7997.                     { Unlike the list view, the tree view doesn't override the text
  7998.                       foreground and background colors of selected items. }
  7999.                     if uItemState and CDIS_SELECTED <> 0 then
  8000.                     begin
  8001.                       FCanvas.Font.Color := clHighlightText;
  8002.                       FCanvas.Brush.Color := clHighlight;
  8003.                     end;
  8004.                     FCanvas.Font.OnChange := CanvasChanged;
  8005.                     FCanvas.Brush.OnChange := CanvasChanged;
  8006.                     FCanvasChanged := False;
  8007.                     DefaultDraw := CustomDrawItem(Node,
  8008.                       TCustomDrawState(Word(uItemState)), cdPrePaint, PaintImages);
  8009.                     if not PaintImages then
  8010.                       Result := Result or TVCDRF_NOIMAGES;
  8011.                     if not DefaultDraw then
  8012.                       Result := Result or CDRF_SKIPDEFAULT
  8013.                     else if FCanvasChanged then
  8014.                     begin
  8015.                       FCanvasChanged := False;
  8016.                       FCanvas.Font.OnChange := nil;
  8017.                       FCanvas.Brush.OnChange := nil;
  8018.                       with PNMTVCustomDraw(NMHdr)^ do
  8019.                       begin
  8020.                         clrText := ColorToRGB(FCanvas.Font.Color);
  8021.                         clrTextBk := ColorToRGB(FCanvas.Brush.Color);
  8022.                         if GetObject(FCanvas.Font.Handle, SizeOf(LogFont), @LogFont) <> 0 then
  8023.                         begin
  8024.                           FCanvas.Handle := 0;  // disconnect from hdc
  8025.                           // don't delete the stock font
  8026.                           SelectObject(hdc, CreateFontIndirect(LogFont));
  8027.                           Result := Result or CDRF_NEWFONT;
  8028.                         end;
  8029.                       end;
  8030.                     end;
  8031.                     if IsCustomDrawn(dtItem, cdPostPaint) then
  8032.                       Result := Result or CDRF_NOTIFYPOSTPAINT;
  8033.                   finally
  8034.                     FCanvas.Handle := 0;
  8035.                   end;
  8036.                 CDDS_ITEMPOSTPAINT:
  8037.                     if IsCustomDrawn(dtItem, cdPostPaint) then
  8038.                       CustomDrawItem(Node, TCustomDrawState(Word(uItemState)), cdPostPaint, PaintImages);
  8039.                 CDDS_ITEMPREERASE:
  8040.                     if IsCustomDrawn(dtItem, cdPreErase) then
  8041.                       CustomDrawItem(Node, TCustomDrawState(Word(uItemState)), cdPreErase, PaintImages);
  8042.                 CDDS_ITEMPOSTERASE:
  8043.                     if IsCustomDrawn(dtItem, cdPostErase) then
  8044.                       CustomDrawItem(Node, TCustomDrawState(Word(uItemState)), cdPostErase, PaintImages);
  8045.               end;
  8046.             end;
  8047.           finally
  8048.             FCanvas.Unlock;
  8049.           end;
  8050.         end;
  8051.       TVN_BEGINDRAG:
  8052.         begin
  8053.           FDragged := True;
  8054.           with PNMTreeView(NMHdr)^ do
  8055.             FDragNode := GetNodeFromItem(ItemNew);
  8056.         end;
  8057.       TVN_BEGINLABELEDIT:
  8058.         begin
  8059.           with PTVDispInfo(NMHdr)^ do
  8060.             if Dragging or not CanEdit(GetNodeFromItem(item)) then
  8061.               Result := 1;
  8062.           if Result = 0 then
  8063.           begin
  8064.             FEditHandle := TreeView_GetEditControl(Handle);
  8065.             FDefEditProc := Pointer(GetWindowLong(FEditHandle, GWL_WNDPROC));
  8066.             SetWindowLong(FEditHandle, GWL_WNDPROC, LongInt(FEditInstance));
  8067.           end;
  8068.         end;
  8069.       TVN_ENDLABELEDIT: Edit(PTVDispInfo(NMHdr)^.item);
  8070.       TVN_ITEMEXPANDING:
  8071.         if not FManualNotify then
  8072.         begin
  8073.           with PNMTreeView(NMHdr)^ do
  8074.           begin
  8075.             Node := GetNodeFromItem(ItemNew);
  8076.             if (action = TVE_EXPAND) and not CanExpand(Node) then
  8077.               Result := 1
  8078.             else if (action = TVE_COLLAPSE) and
  8079.               not CanCollapse(Node) then Result := 1;
  8080.           end;
  8081.         end;
  8082.       TVN_ITEMEXPANDED:
  8083.         if not FManualNotify then
  8084.         begin
  8085.           with PNMTreeView(NMHdr)^ do
  8086.           begin
  8087.             Node := GetNodeFromItem(itemNew);
  8088.             if (action = TVE_EXPAND) then Expand(Node)
  8089.             else if (action = TVE_COLLAPSE) then Collapse(Node);
  8090.           end;
  8091.         end;
  8092.       TVN_SELCHANGINGA, TVN_SELCHANGINGW:
  8093.         if not CanChange(GetNodeFromItem(PNMTreeView(NMHdr)^.itemNew)) then
  8094.           Result := 1;
  8095.       TVN_SELCHANGEDA, TVN_SELCHANGEDW:
  8096.         with PNMTreeView(NMHdr)^ do
  8097.           if FChangeTimer.Interval > 0 then
  8098.           with FChangeTimer do
  8099.           begin
  8100.             Enabled := False;
  8101.             Tag := Integer(GetNodeFromItem(itemNew));
  8102.             Enabled := True;
  8103.           end
  8104.           else
  8105.             Change(GetNodeFromItem(itemNew));
  8106.       TVN_DELETEITEM:
  8107.         begin
  8108.           Node := GetNodeFromItem(PNMTreeView(NMHdr)^.itemOld);
  8109.           if Node <> nil then
  8110.           begin
  8111.             Node.FItemId := nil;
  8112.             FChangeTimer.Enabled := False;
  8113.             if FStateChanging then Node.Delete
  8114.             else Items.Delete(Node);
  8115.           end;
  8116.         end;
  8117.       TVN_SETDISPINFO:
  8118.         with PTVDispInfo(NMHdr)^ do
  8119.         begin
  8120.           Node := GetNodeFromItem(item);
  8121.           if (Node <> nil) and ((item.mask and TVIF_TEXT) <> 0) then
  8122.             Node.Text := item.pszText;
  8123.         end;
  8124.       TVN_GETDISPINFO:
  8125.         with PTVDispInfo(NMHdr)^ do
  8126.         begin
  8127.           Node := GetNodeFromItem(item);
  8128.           if Node <> nil then
  8129.           begin
  8130.             if (item.mask and TVIF_TEXT) <> 0 then
  8131.               StrLCopy(item.pszText, PChar(Node.Text), item.cchTextMax);
  8132.             if (item.mask and TVIF_IMAGE) <> 0 then
  8133.             begin
  8134.               GetImageIndex(Node);
  8135.               item.iImage := Node.ImageIndex;
  8136.             end;
  8137.             if (item.mask and TVIF_SELECTEDIMAGE) <> 0 then
  8138.             begin
  8139.               GetSelectedIndex(Node);
  8140.               item.iSelectedImage := Node.SelectedIndex;
  8141.             end;
  8142.           end;
  8143.         end;
  8144.       NM_RCLICK:
  8145.         begin
  8146.           FRClickNode := nil;
  8147.           GetCursorPos(MousePos);
  8148.           if RightClickSelect then
  8149.             with PointToSmallPoint(ScreenToClient(MousePos)) do
  8150.             begin
  8151.               FRClickNode := GetNodeAt(X, Y);
  8152.               Perform(WM_CONTEXTMENU, Handle, Integer(PointToSmallPoint(MousePos)));
  8153.               FRClickNode := nil;
  8154.             end
  8155.           else
  8156.             // Win95/98 eat WM_CONTEXTMENU when posted to the message queue  
  8157.             PostMessage(Handle, CN_BASE+WM_CONTEXTMENU, Handle, Integer(PointToSmallPoint(MousePos)));
  8158.           Message.Result := 1;  // tell treeview not to perform default response
  8159.         end;
  8160.     end;
  8161. end;
  8162.  
  8163. function TCustomTreeView.GetDragImages: TDragImageList;
  8164. begin
  8165.   if FDragImage.Count > 0 then
  8166.     Result := FDragImage else
  8167.     Result := nil;
  8168. end;
  8169.  
  8170. procedure TCustomTreeView.WndProc(var Message: TMessage);
  8171. begin
  8172.   if not (csDesigning in ComponentState) and ((Message.Msg = WM_LBUTTONDOWN) or
  8173.     (Message.Msg = WM_LBUTTONDBLCLK)) and not Dragging and
  8174.     (DragMode = dmAutomatic) and (DragKind = dkDrag) then
  8175.   begin
  8176.     if not IsControlMouseMsg(TWMMouse(Message)) then
  8177.     begin
  8178.       ControlState := ControlState + [csLButtonDown];
  8179.       Dispatch(Message);
  8180.     end;
  8181.   end
  8182.   else if Message.Msg = CN_BASE+WM_CONTEXTMENU then
  8183.     Message.Result := Perform(WM_CONTEXTMENU, Message.WParam, Message.LParam)
  8184.   else inherited WndProc(Message);
  8185. end;
  8186.  
  8187. procedure TCustomTreeView.DoStartDrag(var DragObject: TDragObject);
  8188. var
  8189.   ImageHandle: HImageList;
  8190.   DragNode: TTreeNode;
  8191.   P: TPoint;
  8192. begin
  8193.   inherited DoStartDrag(DragObject);
  8194.   DragNode := FDragNode;
  8195.   FLastDropTarget := nil;
  8196.   FDragNode := nil;
  8197.   if DragNode = nil then
  8198.   begin
  8199.     GetCursorPos(P);
  8200.     with ScreenToClient(P) do DragNode := GetNodeAt(X, Y);
  8201.   end;
  8202.   if DragNode <> nil then
  8203.   begin
  8204.     ImageHandle := TreeView_CreateDragImage(Handle, DragNode.ItemId);
  8205.     if ImageHandle <> 0 then
  8206.       with FDragImage do
  8207.       begin
  8208.         Handle := ImageHandle;
  8209.         SetDragImage(0, 2, 2);
  8210.       end;
  8211.   end;
  8212. end;
  8213.  
  8214. procedure TCustomTreeView.DoEndDrag(Target: TObject; X, Y: Integer);
  8215. begin
  8216.   inherited DoEndDrag(Target, X, Y);
  8217.   FLastDropTarget := nil;
  8218. end;
  8219.  
  8220. procedure TCustomTreeView.CMDrag(var Message: TCMDrag);
  8221. begin
  8222.   inherited;
  8223.   with Message, DragRec^ do
  8224.     case DragMessage of
  8225.       dmDragMove:
  8226.         with ScreenToClient(Pos) do
  8227.           DoDragOver(Source, X, Y, Message.Result <> 0);
  8228.       dmDragLeave:
  8229.         begin
  8230.           TDragObject(Source).HideDragImage;
  8231.           FLastDropTarget := DropTarget;
  8232.           DropTarget := nil;
  8233.           TDragObject(Source).ShowDragImage;
  8234.         end;
  8235.       dmDragDrop: FLastDropTarget := nil;
  8236.     end;
  8237. end;
  8238.  
  8239. procedure TCustomTreeView.DoDragOver(Source: TDragObject; X, Y: Integer; CanDrop: Boolean);
  8240. var
  8241.   Node: TTreeNode;
  8242. begin
  8243.   Node := GetNodeAt(X, Y);
  8244.   if (Node <> nil) and
  8245.     ((Node <> DropTarget) or (Node = FLastDropTarget)) then
  8246.   begin
  8247.     FLastDropTarget := nil;
  8248.     TDragObject(Source).HideDragImage;
  8249.     Node.DropTarget := True;
  8250.     TDragObject(Source).ShowDragImage;
  8251.   end;
  8252. end;
  8253.  
  8254. procedure TCustomTreeView.GetImageIndex(Node: TTreeNode);
  8255. begin
  8256.   if Assigned(FOnGetImageIndex) then FOnGetImageIndex(Self, Node);
  8257. end;
  8258.  
  8259. procedure TCustomTreeView.GetSelectedIndex(Node: TTreeNode);
  8260. begin
  8261.   if Assigned(FOnGetSelectedIndex) then FOnGetSelectedIndex(Self, Node);
  8262. end;
  8263.  
  8264. function TCustomTreeView.CanChange(Node: TTreeNode): Boolean;
  8265. begin
  8266.   Result := True;
  8267.   if Assigned(FOnChanging) then FOnChanging(Self, Node, Result);
  8268. end;
  8269.  
  8270. procedure TCustomTreeView.Change(Node: TTreeNode);
  8271. begin
  8272.   if Assigned(FOnChange) then FOnChange(Self, Node);
  8273. end;
  8274.  
  8275. procedure TCustomTreeView.Delete(Node: TTreeNode);
  8276. begin
  8277.   if Assigned(FOnDeletion) then FOnDeletion(Self, Node);
  8278. end;
  8279.  
  8280. procedure TCustomTreeView.Expand(Node: TTreeNode);
  8281. begin
  8282.   if Assigned(FOnExpanded) then FOnExpanded(Self, Node);
  8283. end;
  8284.  
  8285. function TCustomTreeView.CanExpand(Node: TTreeNode): Boolean;
  8286. begin
  8287.   Result := True;
  8288.   if Assigned(FOnExpanding) then FOnExpanding(Self, Node, Result);
  8289. end;
  8290.  
  8291. procedure TCustomTreeView.Collapse(Node: TTreeNode);
  8292. begin
  8293.   if Assigned(FOnCollapsed) then FOnCollapsed(Self, Node);
  8294. end;
  8295.  
  8296. function TCustomTreeView.CanCollapse(Node: TTreeNode): Boolean;
  8297. begin
  8298.   Result := True;
  8299.   if Assigned(FOnCollapsing) then FOnCollapsing(Self, Node, Result);
  8300. end;
  8301.  
  8302. function TCustomTreeView.CanEdit(Node: TTreeNode): Boolean;
  8303. begin
  8304.   Result := True;
  8305.   if Assigned(FOnEditing) then FOnEditing(Self, Node, Result);
  8306. end;
  8307.  
  8308. procedure TCustomTreeView.Edit(const Item: TTVItem);
  8309. var
  8310.   S: string;
  8311.   Node: TTreeNode;
  8312. begin
  8313.   with Item do
  8314.     if pszText <> nil then
  8315.     begin
  8316.       S := pszText;
  8317.       Node := GetNodeFromItem(Item);
  8318.       if Assigned(FOnEdited) then FOnEdited(Self, Node, S);
  8319.       if Node <> nil then Node.Text := S;
  8320.     end;
  8321. end;
  8322.  
  8323. function TCustomTreeView.CreateNode: TTreeNode;
  8324. begin
  8325.   Result := TTreeNode.Create(Items);
  8326. end;
  8327.  
  8328. procedure TCustomTreeView.SetImageList(Value: HImageList; Flags: Integer);
  8329. begin
  8330.   if HandleAllocated then TreeView_SetImageList(Handle, Value, Flags);
  8331. end;
  8332.  
  8333. procedure TCustomTreeView.ImageListChange(Sender: TObject);
  8334. var
  8335.   ImageHandle: HImageList;
  8336. begin
  8337.   if HandleAllocated then
  8338.   begin
  8339.     if TCustomImageList(Sender).HandleAllocated then
  8340.       ImageHandle := TCustomImageList(Sender).Handle
  8341.     else
  8342.       ImageHandle := 0;
  8343.     if Sender = Images then
  8344.       SetImageList(ImageHandle, TVSIL_NORMAL)
  8345.     else if Sender = StateImages then
  8346.       SetImageList(ImageHandle, TVSIL_STATE);
  8347.   end;
  8348. end;
  8349.  
  8350. procedure TCustomTreeView.Notification(AComponent: TComponent;
  8351.   Operation: TOperation);
  8352. begin
  8353.   inherited Notification(AComponent, Operation);
  8354.   if Operation = opRemove then
  8355.   begin
  8356.     if AComponent = Images then Images := nil;
  8357.     if AComponent = StateImages then StateImages := nil;
  8358.   end;
  8359. end;
  8360.  
  8361. procedure TCustomTreeView.SetImages(Value: TCustomImageList);
  8362. begin
  8363.   if Images <> nil then
  8364.     Images.UnRegisterChanges(FImageChangeLink);
  8365.   FImages := Value;
  8366.   if Images <> nil then
  8367.   begin
  8368.     Images.RegisterChanges(FImageChangeLink);
  8369.     Images.FreeNotification(Self);
  8370.     SetImageList(Images.Handle, TVSIL_NORMAL)
  8371.   end
  8372.   else SetImageList(0, TVSIL_NORMAL);
  8373. end;
  8374.  
  8375. procedure TCustomTreeView.SetStateImages(Value: TCustomImageList);
  8376. begin
  8377.   if StateImages <> nil then
  8378.     StateImages.UnRegisterChanges(FStateChangeLink);
  8379.   FStateImages := Value;
  8380.   if StateImages <> nil then
  8381.   begin
  8382.     StateImages.RegisterChanges(FStateChangeLink);
  8383.     StateImages.FreeNotification(Self);
  8384.     SetImageList(StateImages.Handle, TVSIL_STATE)
  8385.   end
  8386.   else SetImageList(0, TVSIL_STATE);
  8387. end;
  8388.  
  8389. procedure TCustomTreeView.LoadFromFile(const FileName: string);
  8390. var
  8391.   Stream: TStream;
  8392. begin
  8393.   Stream := TFileStream.Create(FileName, fmOpenRead);
  8394.   try
  8395.     LoadFromStream(Stream);
  8396.   finally
  8397.     Stream.Free;
  8398.   end;
  8399. end;
  8400.  
  8401. procedure TCustomTreeView.LoadFromStream(Stream: TStream);
  8402. begin
  8403.   with TTreeStrings.Create(Items) do
  8404.     try
  8405.       LoadTreeFromStream(Stream);
  8406.     finally
  8407.       Free;
  8408.   end;
  8409. end;
  8410.  
  8411. procedure TCustomTreeView.SaveToFile(const FileName: string);
  8412. var
  8413.   Stream: TStream;
  8414. begin
  8415.   Stream := TFileStream.Create(FileName, fmCreate);
  8416.   try
  8417.     SaveToStream(Stream);
  8418.   finally
  8419.     Stream.Free;
  8420.   end;
  8421. end;
  8422.  
  8423. procedure TCustomTreeView.SaveToStream(Stream: TStream);
  8424. begin
  8425.   with TTreeStrings.Create(Items) do
  8426.     try
  8427.       SaveTreeToStream(Stream);
  8428.     finally
  8429.       Free;
  8430.   end;
  8431. end;
  8432.  
  8433. procedure TCustomTreeView.WMContextMenu(var Message: TWMContextMenu);
  8434. var
  8435.   R: TRect;
  8436. begin
  8437.   if (Message.XPos < 0) and (Selected <> nil) then
  8438.   begin
  8439.     R := Selected.DisplayRect(True);
  8440.     Message.Pos := PointToSmallPoint(ClientToScreen(Point(R.Left, R.Bottom)));
  8441.   end;
  8442.   inherited;
  8443. end;
  8444.  
  8445. procedure TCustomTreeView.WMLButtonDown(var Message: TWMLButtonDown);
  8446. var
  8447.   Node: TTreeNode;
  8448.   MousePos: TPoint;
  8449. begin
  8450.   FDragged := False;
  8451.   FDragNode := nil;
  8452.   try
  8453.     inherited;
  8454.     if (DragMode = dmAutomatic) and (DragKind = dkDrag) then
  8455.     begin
  8456.       SetFocus;
  8457.       if not FDragged then
  8458.       begin
  8459.         GetCursorPos(MousePos);
  8460.         with PointToSmallPoint(ScreenToClient(MousePos)) do
  8461.           Perform(WM_LBUTTONUP, 0, MakeLong(X, Y));
  8462.       end
  8463.       else begin
  8464.         Node := GetNodeAt(Message.XPos, Message.YPos);
  8465.         if Node <> nil then
  8466.         begin
  8467.           Node.Focused := True;
  8468.           Node.Selected := True;
  8469.           BeginDrag(False);
  8470.         end;
  8471.       end;
  8472.     end;
  8473.   finally
  8474.     FDragNode := nil;
  8475.   end;
  8476. end;
  8477.  
  8478. procedure TCustomTreeView.WMNotify(var Message: TWMNotify);
  8479. var
  8480.   Node: TTreeNode;
  8481.   MaxTextLen: Integer;
  8482.   Pt: TPoint;
  8483. begin
  8484.   with Message do
  8485.     if NMHdr^.code = TTN_NEEDTEXTW then
  8486.     begin
  8487.       // Work around NT COMCTL32 problem with tool tips >= 80 characters
  8488.       GetCursorPos(Pt);
  8489.       Pt := ScreenToClient(Pt);
  8490.       Node := GetNodeAt(Pt.X, Pt.Y);
  8491.       if (Node = nil) or (Node.Text = '') or
  8492.         (PToolTipTextW(NMHdr)^.uFlags and TTF_IDISHWND = 0) then Exit;
  8493.       if (GetComCtlVersion >= ComCtlVersionIE4) and (Length(Node.Text) < 80) then
  8494.       begin
  8495.         inherited;
  8496.         Exit;
  8497.       end;
  8498.       FWideText := Node.Text;
  8499.       MaxTextLen := SizeOf(PToolTipTextW(NMHdr)^.szText) div SizeOf(WideChar);
  8500.       if Length(FWideText) >= MaxTextLen then
  8501.         SetLength(FWideText, MaxTextLen - 1);
  8502.       PToolTipTextW(NMHdr)^.lpszText := PWideChar(FWideText);
  8503.       FillChar(PToolTipTextW(NMHdr)^.szText, MaxTextLen, 0);
  8504.       Move(Pointer(FWideText)^, PToolTipTextW(NMHdr)^.szText, Length(FWideText) * SizeOf(WideChar));
  8505.       PToolTipTextW(NMHdr)^.hInst := 0;
  8506.       SetWindowPos(NMHdr^.hwndFrom, HWND_TOP, 0, 0, 0, 0, SWP_NOACTIVATE or
  8507.         SWP_NOSIZE or SWP_NOMOVE or SWP_NOOWNERZORDER);
  8508.       Result := 1;
  8509.     end
  8510.     else inherited;
  8511. end;
  8512.  
  8513. { CustomDraw support }
  8514.  
  8515. procedure TCustomTreeView.CanvasChanged;
  8516. begin
  8517.   FCanvasChanged := True;
  8518. end;
  8519.  
  8520. function TCustomTreeView.IsCustomDrawn(Target: TCustomDrawTarget;
  8521.   Stage: TCustomDrawStage): Boolean;
  8522. begin
  8523.   { Tree view doesn't support erase notifications }
  8524.   if Stage = cdPrePaint then
  8525.   begin
  8526.     if Target = dtItem then
  8527.       Result := Assigned(FOnCustomDrawItem) or Assigned(FOnAdvancedCustomDrawItem)
  8528.     else if Target = dtControl then
  8529.       Result := Assigned(FOnCustomDraw) or Assigned(FOnAdvancedCustomDraw) or
  8530.         Assigned(FOnCustomDrawItem) or Assigned(FOnAdvancedCustomDrawItem)
  8531.     else
  8532.       Result := False;
  8533.   end
  8534.   else
  8535.   begin
  8536.     if Target = dtItem then
  8537.       Result := Assigned(FOnAdvancedCustomDrawItem)
  8538.     else if Target = dtControl then
  8539.       Result := Assigned(FOnAdvancedCustomDraw) or Assigned(FOnAdvancedCustomDrawItem)
  8540.     else
  8541.       Result := False;
  8542.   end;
  8543. end;
  8544.  
  8545. function TCustomTreeView.CustomDraw(const ARect: TRect; Stage: TCustomDrawStage): Boolean;
  8546. begin
  8547.   Result := True;
  8548.   if (Stage = cdPrePaint) and Assigned(FOnCustomDraw) then FOnCustomDraw(Self, ARect, Result);
  8549.   if Assigned(FOnAdvancedCustomDraw) then FOnAdvancedCustomDraw(Self, ARect, Stage, Result);
  8550. end;
  8551.  
  8552. function TCustomTreeView.CustomDrawItem(Node: TTreeNode; State: TCustomDrawState;
  8553.   Stage: TCustomDrawStage; var PaintImages: Boolean): Boolean;
  8554. begin
  8555.   Result := True;
  8556.   PaintImages := True;
  8557.   if (Stage = cdPrePaint) and Assigned(FOnCustomDrawItem) then FOnCustomDrawItem(Self, Node, State, Result);
  8558.   if Assigned(FOnAdvancedCustomDrawItem) then FOnAdvancedCustomDrawItem(Self, Node, State, Stage, PaintImages, Result);
  8559. end;
  8560.  
  8561. { TTrackBar }
  8562.  
  8563. constructor TTrackBar.Create(AOwner: TComponent);
  8564. begin
  8565.   inherited Create(AOwner);
  8566.   Width := 150;
  8567.   Height := 45;
  8568.   TabStop := True;
  8569.   FMin := 0;
  8570.   FMax := 10;
  8571.   FLineSize := 1;
  8572.   FPageSize := 2;
  8573.   FFrequency := 1;
  8574.   FThumbLength := 20;
  8575.   FTickMarks := tmBottomRight;
  8576.   FTickStyle := tsAuto;
  8577.   FOrientation := trHorizontal;
  8578.   ControlStyle := ControlStyle - [csDoubleClicks];
  8579.   FSliderVisible := True;
  8580. end;
  8581.  
  8582. procedure TTrackBar.CreateParams(var Params: TCreateParams);
  8583. const
  8584.   OrientationStyle: array[TTrackbarOrientation] of DWORD = (TBS_HORZ, TBS_VERT);
  8585.   TickStyles: array[TTickStyle] of DWORD = (TBS_NOTICKS, TBS_AUTOTICKS, 0);
  8586.   ATickMarks: array[TTickMark] of DWORD = (TBS_BOTTOM, TBS_TOP, TBS_BOTH);
  8587. begin
  8588.   InitCommonControl(ICC_BAR_CLASSES);
  8589.   inherited CreateParams(Params);
  8590.   CreateSubClass(Params, TRACKBAR_CLASS);
  8591.   with Params do
  8592.   begin
  8593.     Style := Style or OrientationStyle[FOrientation] or
  8594.       TickStyles[FTickStyle] or ATickMarks[FTickMarks] or TBS_FIXEDLENGTH or
  8595.       TBS_ENABLESELRANGE;
  8596.     WindowClass.style := WindowClass.style and not (CS_HREDRAW or CS_VREDRAW) or
  8597.       CS_DBLCLKS;
  8598.     if not FSliderVisible then
  8599.       Style := Style or TBS_NOTHUMB;
  8600.   end;
  8601. end;
  8602.  
  8603. procedure TTrackBar.CreateWnd;
  8604. begin
  8605.   inherited CreateWnd;
  8606.   if HandleAllocated then
  8607.   begin
  8608.     SendMessage(Handle, TBM_SETTHUMBLENGTH, FThumbLength, 0);
  8609.     SendMessage(Handle, TBM_SETLINESIZE, 0, FLineSize);
  8610.     SendMessage(Handle, TBM_SETPAGESIZE, 0, FPageSize);
  8611.     SendMessage(Handle, TBM_SETRANGEMIN, 0, FMin);
  8612.     SendMessage(Handle, TBM_SETRANGEMAX, 0, FMax);
  8613.     UpdateSelection;
  8614.     SendMessage(Handle, TBM_SETPOS, 1, FPosition);
  8615.     SendMessage(Handle, TBM_SETTICFREQ, FFrequency, 1);
  8616.   end;
  8617. end;
  8618.  
  8619. procedure TTrackBar.DestroyWnd;
  8620. begin
  8621.   inherited DestroyWnd;
  8622. end;
  8623.  
  8624. procedure TTrackBar.CNHScroll(var Message: TWMHScroll);
  8625. begin
  8626.   inherited;
  8627.   FPosition := SendMessage(Handle, TBM_GETPOS, 0, 0);
  8628.   Changed;
  8629.   Message.Result := 0;
  8630. end;
  8631.  
  8632. procedure TTrackBar.CNVScroll(var Message: TWMVScroll);
  8633. begin
  8634.   inherited;
  8635.   FPosition := SendMessage(Handle, TBM_GETPOS, 0, 0);
  8636.   Changed;
  8637.   Message.Result := 0;
  8638. end;
  8639.  
  8640. function TTrackBar.GetThumbLength: Integer;
  8641. begin
  8642.   if HandleAllocated then
  8643.     Result := SendMessage(Handle, TBM_GETTHUMBLENGTH, 0, 0)
  8644.   else
  8645.     Result := FThumbLength;
  8646. end;
  8647.  
  8648. procedure TTrackBar.SetOrientation(Value: TTrackBarOrientation);
  8649. begin
  8650.   if Value <> FOrientation then
  8651.   begin
  8652.     FOrientation := Value;
  8653.     if ComponentState * [csLoading, csUpdating] = [] then
  8654.       SetBounds(Left, Top, Height, Width);
  8655.     RecreateWnd;
  8656.   end;
  8657. end;
  8658.  
  8659. procedure TTrackBar.SetParams(APosition, AMin, AMax: Integer);
  8660. begin
  8661.   if AMax < AMin then
  8662.     raise EInvalidOperation.CreateFmt(SPropertyOutOfRange, [Self.Classname]);
  8663.   if APosition < AMin then APosition := AMin;
  8664.   if APosition > AMax then APosition := AMax;
  8665.   if (FMin <> AMin) then
  8666.   begin
  8667.     FMin := AMin;
  8668.     if HandleAllocated then
  8669.       SendMessage(Handle, TBM_SETRANGEMIN, 1, AMin);
  8670.   end;
  8671.   if (FMax <> AMax) then
  8672.   begin
  8673.     FMax := AMax;
  8674.     if HandleAllocated then
  8675.       SendMessage(Handle, TBM_SETRANGEMAX, 1, AMax);
  8676.   end;
  8677.   if FPosition <> APosition then
  8678.   begin
  8679.     FPosition := APosition;
  8680.     if HandleAllocated then
  8681.       SendMessage(Handle, TBM_SETPOS, 1, APosition);
  8682.     Changed;
  8683.   end;
  8684. end;
  8685.  
  8686. procedure TTrackBar.SetPosition(Value: Integer);
  8687. begin
  8688.   SetParams(Value, FMin, FMax);
  8689. end;
  8690.  
  8691. procedure TTrackBar.SetMin(Value: Integer);
  8692. begin
  8693.   if Value <= FMax then
  8694.     SetParams(FPosition, Value, FMax);
  8695. end;
  8696.  
  8697. procedure TTrackBar.SetMax(Value: Integer);
  8698. begin
  8699.   if Value >= FMin then
  8700.     SetParams(FPosition, FMin, Value);
  8701. end;
  8702.  
  8703. procedure TTrackBar.SetFrequency(Value: Integer);
  8704. begin
  8705.   if Value <> FFrequency then
  8706.   begin
  8707.     FFrequency := Value;
  8708.     if HandleAllocated then
  8709.       SendMessage(Handle, TBM_SETTICFREQ, FFrequency, 1);
  8710.   end;
  8711. end;
  8712.  
  8713. procedure TTrackBar.SetTick(Value: Integer);
  8714. begin
  8715.   if HandleAllocated then
  8716.     SendMessage(Handle, TBM_SETTIC, 0, Value);
  8717. end;
  8718.  
  8719. procedure TTrackBar.SetTickStyle(Value: TTickStyle);
  8720. begin
  8721.   if Value <> FTickStyle then
  8722.   begin
  8723.     FTickStyle := Value;
  8724.     RecreateWnd;
  8725.   end;
  8726. end;
  8727.  
  8728. procedure TTrackBar.SetTickMarks(Value: TTickMark);
  8729. begin
  8730.   if Value <> FTickMarks then
  8731.   begin
  8732.     FTickMarks := Value;
  8733.     RecreateWnd;
  8734.   end;
  8735. end;
  8736.  
  8737. procedure TTrackBar.SetLineSize(Value: Integer);
  8738. begin
  8739.   if Value <> FLineSize then
  8740.   begin
  8741.     FLineSize := Value;
  8742.     if HandleAllocated then
  8743.       SendMessage(Handle, TBM_SETLINESIZE, 0, FLineSize);
  8744.   end;
  8745. end;
  8746.  
  8747. procedure TTrackBar.SetPageSize(Value: Integer);
  8748. begin
  8749.   if Value <> FPageSize then
  8750.   begin
  8751.     FPageSize := Value;
  8752.     if HandleAllocated then
  8753.       SendMessage(Handle, TBM_SETPAGESIZE, 0, FPageSize);
  8754.   end;
  8755. end;
  8756.  
  8757. procedure TTrackBar.SetThumbLength(Value: Integer);
  8758. begin
  8759.   if Value <> FThumbLength then
  8760.   begin
  8761.     FThumbLength := Value;
  8762.     if HandleAllocated then
  8763.       SendMessage(Handle, TBM_SETTHUMBLENGTH, Value, 0);
  8764.   end;
  8765. end;
  8766.  
  8767. procedure TTrackBar.SetSliderVisible(Value: Boolean);
  8768. begin
  8769.   if FSliderVisible <> Value then
  8770.   begin
  8771.     FSliderVisible := Value;
  8772.     RecreateWnd;
  8773.   end;
  8774. end;
  8775.  
  8776. procedure TTrackBar.UpdateSelection;
  8777. begin
  8778.   if HandleAllocated then
  8779.   begin
  8780.     if (FSelStart = 0) and (FSelEnd = 0) then
  8781.       SendMessage(Handle, TBM_CLEARSEL, 1, 0)
  8782.     else
  8783.       SendMessage(Handle, TBM_SETSEL, Integer(True), MakeLong(FSelStart, FSelEnd));
  8784.   end;
  8785. end;
  8786.  
  8787. procedure TTrackBar.SetSelStart(Value: Integer);
  8788. begin
  8789.   if Value <> FSelStart then
  8790.   begin
  8791.     FSelStart := Value;
  8792.     UpdateSelection;
  8793.   end;
  8794. end;
  8795.  
  8796. procedure TTrackBar.SetSelEnd(Value: Integer);
  8797. begin
  8798.   if Value <> FSelEnd then
  8799.   begin
  8800.     FSelEnd := Value;
  8801.     UpdateSelection;
  8802.   end;
  8803. end;
  8804.  
  8805. procedure TTrackBar.Changed;
  8806. begin
  8807.   if Assigned(FOnChange) then FOnChange(Self);
  8808. end;
  8809.  
  8810. { TProgressBar }
  8811.  
  8812. const
  8813.   Limit16 = 65535;
  8814.  
  8815. procedure ProgressLimitError;
  8816. begin
  8817.   raise Exception.CreateResFmt(@SOutOfRange, [0, Limit16]);
  8818. end;
  8819.  
  8820. constructor TProgressBar.Create(AOwner: TComponent);
  8821. begin
  8822.   F32BitMode := InitCommonControl(ICC_PROGRESS_CLASS);
  8823.   inherited Create(AOwner);
  8824.   Width := 150;
  8825.   Height := GetSystemMetrics(SM_CYVSCROLL);
  8826.   FMin := 0;
  8827.   FMax := 100;
  8828.   FStep := 10;
  8829.   FOrientation := pbHorizontal;
  8830. end;
  8831.  
  8832. procedure TProgressBar.CreateParams(var Params: TCreateParams);
  8833. begin
  8834.   if not F32BitMode then InitCommonControls;
  8835.   inherited CreateParams(Params);
  8836.   CreateSubClass(Params, PROGRESS_CLASS);
  8837.   with Params do
  8838.   begin
  8839.     if FOrientation = pbVertical then Style := Style or PBS_VERTICAL;
  8840.     if FSmooth then Style := Style or PBS_SMOOTH;
  8841.   end;
  8842. end;
  8843.  
  8844. procedure TProgressBar.CreateWnd;
  8845. begin
  8846.   inherited CreateWnd;
  8847.   if F32BitMode then SendMessage(Handle, PBM_SETRANGE32, FMin, FMax)
  8848.   else SendMessage(Handle, PBM_SETRANGE, 0, MakeLong(FMin, FMax));
  8849.   SendMessage(Handle, PBM_SETSTEP, FStep, 0);
  8850.   Position := FPosition;
  8851. end;
  8852.  
  8853. procedure TProgressBar.DestroyWnd;
  8854. begin
  8855.   FPosition := Position;
  8856.   inherited DestroyWnd;
  8857. end;
  8858.  
  8859. function TProgressBar.GetMin: Integer;
  8860. begin
  8861.   if HandleAllocated and F32BitMode then
  8862.     Result := SendMessage(Handle, PBM_GetRange, 1, 0)
  8863.   else
  8864.     Result := FMin;
  8865. end;
  8866.  
  8867. function TProgressBar.GetMax: Integer;
  8868. begin
  8869.   if HandleAllocated and F32BitMode then
  8870.     Result := SendMessage(Handle, PBM_GetRange, 0, 0)
  8871.   else
  8872.     Result := FMax;
  8873. end;
  8874.  
  8875. function TProgressBar.GetPosition: Integer;
  8876. begin
  8877.   if HandleAllocated then
  8878.   begin
  8879.     if F32BitMode then Result := SendMessage(Handle, PBM_GETPOS, 0, 0)
  8880.     else Result := SendMessage(Handle, PBM_DELTAPOS, 0, 0)
  8881.   end
  8882.   else Result := FPosition;
  8883. end;
  8884.  
  8885. procedure TProgressBar.SetParams(AMin, AMax: Integer);
  8886. begin
  8887.   if AMax < AMin then
  8888.     raise EInvalidOperation.CreateFmt(SPropertyOutOfRange, [Self.Classname]);
  8889.   if not F32BitMode and ((AMin < 0) or (AMin > Limit16) or (AMax < 0) or
  8890.     (AMax > Limit16)) then ProgressLimitError;
  8891.   if (FMin <> AMin) or (FMax <> AMax) then
  8892.   begin
  8893.     if HandleAllocated then
  8894.     begin
  8895.       if F32BitMode then SendMessage(Handle, PBM_SETRANGE32, AMin, AMax)
  8896.       else SendMessage(Handle, PBM_SETRANGE, 0, MakeLong(AMin, AMax));
  8897.       if FMin > AMin then // since Windows sets Position when increase Min..
  8898.         SendMessage(Handle, PBM_SETPOS, AMin, 0); // set it back if decrease
  8899.     end;
  8900.     FMin := AMin;
  8901.     FMax := AMax;
  8902.   end;
  8903. end;
  8904.  
  8905. procedure TProgressBar.SetMin(Value: Integer);
  8906. begin
  8907.   SetParams(Value, FMax);
  8908. end;
  8909.  
  8910. procedure TProgressBar.SetMax(Value: Integer);
  8911. begin
  8912.   SetParams(FMin, Value);
  8913. end;
  8914.  
  8915. procedure TProgressBar.SetPosition(Value: Integer);
  8916. begin
  8917.   if not F32BitMode and ((Value < 0) or (Value > Limit16)) then
  8918.     ProgressLimitError;
  8919.   if HandleAllocated then SendMessage(Handle, PBM_SETPOS, Value, 0)
  8920.   else FPosition := Value;
  8921. end;
  8922.  
  8923. procedure TProgressBar.SetStep(Value: Integer);
  8924. begin
  8925.   if Value <> FStep then
  8926.   begin
  8927.     FStep := Value;
  8928.     if HandleAllocated then
  8929.       SendMessage(Handle, PBM_SETSTEP, FStep, 0);
  8930.   end;
  8931. end;
  8932.  
  8933. procedure TProgressBar.StepIt;
  8934. begin
  8935.   if HandleAllocated then
  8936.     SendMessage(Handle, PBM_STEPIT, 0, 0);
  8937. end;
  8938.  
  8939. procedure TProgressBar.StepBy(Delta: Integer);
  8940. begin
  8941.   if HandleAllocated then
  8942.     SendMessage(Handle, PBM_DELTAPOS, Delta, 0);
  8943. end;
  8944.  
  8945. procedure TProgressBar.SetOrientation(Value: TProgressBarOrientation);
  8946. begin
  8947.   if FOrientation <> Value then
  8948.   begin
  8949.     FOrientation := Value;
  8950.     RecreateWnd;
  8951.   end;
  8952. end;
  8953.  
  8954. procedure TProgressBar.SetSmooth(Value: Boolean);
  8955. begin
  8956.   if FSmooth <> Value then
  8957.   begin
  8958.     FSmooth := Value;
  8959.     RecreateWnd;
  8960.   end;
  8961. end;
  8962.  
  8963. { TTextAttributes }
  8964.  
  8965. constructor TTextAttributes.Create(AOwner: TCustomRichEdit;
  8966.   AttributeType: TAttributeType);
  8967. begin
  8968.   inherited Create;
  8969.   RichEdit := AOwner;
  8970.   FType := AttributeType;
  8971. end;
  8972.  
  8973. procedure TTextAttributes.InitFormat(var Format: TCharFormat);
  8974. begin
  8975.   FillChar(Format, SizeOf(TCharFormat), 0);
  8976.   Format.cbSize := SizeOf(TCharFormat);
  8977. end;
  8978.  
  8979. function TTextAttributes.GetConsistentAttributes: TConsistentAttributes;
  8980. var
  8981.   Format: TCharFormat;
  8982. begin
  8983.   Result := [];
  8984.   if RichEdit.HandleAllocated and (FType = atSelected) then
  8985.   begin
  8986.     InitFormat(Format);
  8987.     SendMessage(RichEdit.Handle, EM_GETCHARFORMAT,
  8988.       WPARAM(FType = atSelected), LPARAM(@Format));
  8989.     with Format do
  8990.     begin
  8991.       if (dwMask and CFM_BOLD) <> 0 then Include(Result, caBold);
  8992.       if (dwMask and CFM_COLOR) <> 0 then Include(Result, caColor);
  8993.       if (dwMask and CFM_FACE) <> 0 then Include(Result, caFace);
  8994.       if (dwMask and CFM_ITALIC) <> 0 then Include(Result, caItalic);
  8995.       if (dwMask and CFM_SIZE) <> 0 then Include(Result, caSize);
  8996.       if (dwMask and CFM_STRIKEOUT) <> 0 then Include(Result, caStrikeOut);
  8997.       if (dwMask and CFM_UNDERLINE) <> 0 then Include(Result, caUnderline);
  8998.       if (dwMask and CFM_PROTECTED) <> 0 then Include(Result, caProtected);
  8999.     end;
  9000.   end;
  9001. end;
  9002.  
  9003. procedure TTextAttributes.GetAttributes(var Format: TCharFormat);
  9004. begin
  9005.   InitFormat(Format);
  9006.   if RichEdit.HandleAllocated then
  9007.     SendMessage(RichEdit.Handle, EM_GETCHARFORMAT,
  9008.       WPARAM(FType = atSelected), LPARAM(@Format));
  9009. end;
  9010.  
  9011. procedure TTextAttributes.SetAttributes(var Format: TCharFormat);
  9012. var
  9013.   Flag: Longint;
  9014. begin
  9015.   if FType = atSelected then Flag := SCF_SELECTION
  9016.   else Flag := 0;
  9017.   if RichEdit.HandleAllocated then
  9018.     SendMessage(RichEdit.Handle, EM_SETCHARFORMAT, Flag, LPARAM(@Format))
  9019. end;
  9020.  
  9021. function TTextAttributes.GetCharset: TFontCharset;
  9022. var
  9023.   Format: TCharFormat;
  9024. begin
  9025.   GetAttributes(Format);
  9026.   Result := Format.bCharset;
  9027. end;
  9028.  
  9029. procedure TTextAttributes.SetCharset(Value: TFontCharset);
  9030. var
  9031.   Format: TCharFormat;
  9032. begin
  9033.   InitFormat(Format);
  9034.   with Format do
  9035.   begin
  9036.     dwMask := CFM_CHARSET;
  9037.     bCharSet := Value;
  9038.   end;
  9039.   SetAttributes(Format);
  9040. end;
  9041.  
  9042. function TTextAttributes.GetProtected: Boolean;
  9043. var
  9044.   Format: TCharFormat;
  9045. begin
  9046.   GetAttributes(Format);
  9047.   with Format do
  9048.     if (dwEffects and CFE_PROTECTED) <> 0 then
  9049.       Result := True else
  9050.       Result := False;
  9051. end;
  9052.  
  9053. procedure TTextAttributes.SetProtected(Value: Boolean);
  9054. var
  9055.   Format: TCharFormat;
  9056. begin
  9057.   InitFormat(Format);
  9058.   with Format do
  9059.   begin
  9060.     dwMask := CFM_PROTECTED;
  9061.     if Value then dwEffects := CFE_PROTECTED;
  9062.   end;
  9063.   SetAttributes(Format);
  9064. end;
  9065.  
  9066. function TTextAttributes.GetColor: TColor;
  9067. var
  9068.   Format: TCharFormat;
  9069. begin
  9070.   GetAttributes(Format);
  9071.   with Format do
  9072.     if (dwEffects and CFE_AUTOCOLOR) <> 0 then
  9073.       Result := clWindowText else
  9074.       Result := crTextColor;
  9075. end;
  9076.  
  9077. procedure TTextAttributes.SetColor(Value: TColor);
  9078. var
  9079.   Format: TCharFormat;
  9080. begin
  9081.   InitFormat(Format);
  9082.   with Format do
  9083.   begin
  9084.     dwMask := CFM_COLOR;
  9085.     if Value = clWindowText then
  9086.       dwEffects := CFE_AUTOCOLOR else
  9087.       crTextColor := ColorToRGB(Value);
  9088.   end;
  9089.   SetAttributes(Format);
  9090. end;
  9091.  
  9092. function TTextAttributes.GetName: TFontName;
  9093. var
  9094.   Format: TCharFormat;
  9095. begin
  9096.   GetAttributes(Format);
  9097.   Result := Format.szFaceName;
  9098. end;
  9099.  
  9100. procedure TTextAttributes.SetName(Value: TFontName);
  9101. var
  9102.   Format: TCharFormat;
  9103. begin
  9104.   InitFormat(Format);
  9105.   with Format do
  9106.   begin
  9107.     dwMask := CFM_FACE;
  9108.     StrPLCopy(szFaceName, Value, SizeOf(szFaceName));
  9109.   end;
  9110.   SetAttributes(Format);
  9111. end;
  9112.  
  9113. function TTextAttributes.GetStyle: TFontStyles;
  9114. var
  9115.   Format: TCharFormat;
  9116. begin
  9117.   Result := [];
  9118.   GetAttributes(Format);
  9119.   with Format do
  9120.   begin
  9121.     if (dwEffects and CFE_BOLD) <> 0 then Include(Result, fsBold);
  9122.     if (dwEffects and CFE_ITALIC) <> 0 then Include(Result, fsItalic);
  9123.     if (dwEffects and CFE_UNDERLINE) <> 0 then Include(Result, fsUnderline);
  9124.     if (dwEffects and CFE_STRIKEOUT) <> 0 then Include(Result, fsStrikeOut);
  9125.   end;
  9126. end;
  9127.  
  9128. procedure TTextAttributes.SetStyle(Value: TFontStyles);
  9129. var
  9130.   Format: TCharFormat;
  9131. begin
  9132.   InitFormat(Format);
  9133.   with Format do
  9134.   begin
  9135.     dwMask := CFM_BOLD or CFM_ITALIC or CFM_UNDERLINE or CFM_STRIKEOUT;
  9136.     if fsBold in Value then dwEffects := dwEffects or CFE_BOLD;
  9137.     if fsItalic in Value then dwEffects := dwEffects or CFE_ITALIC;
  9138.     if fsUnderline in Value then dwEffects := dwEffects or CFE_UNDERLINE;
  9139.     if fsStrikeOut in Value then dwEffects := dwEffects or CFE_STRIKEOUT;
  9140.   end;
  9141.   SetAttributes(Format);
  9142. end;
  9143.  
  9144. function TTextAttributes.GetSize: Integer;
  9145. var
  9146.   Format: TCharFormat;
  9147. begin
  9148.   GetAttributes(Format);
  9149.   Result := Format.yHeight div 20;
  9150. end;
  9151.  
  9152. procedure TTextAttributes.SetSize(Value: Integer);
  9153. var
  9154.   Format: TCharFormat;
  9155. begin
  9156.   InitFormat(Format);
  9157.   with Format do
  9158.   begin
  9159.     dwMask := Integer(CFM_SIZE);
  9160.     yHeight := Value * 20;
  9161.   end;
  9162.   SetAttributes(Format);
  9163. end;
  9164.  
  9165. function TTextAttributes.GetHeight: Integer;
  9166. begin
  9167.   Result := MulDiv(Size, RichEdit.FScreenLogPixels, 72);
  9168. end;
  9169.  
  9170. procedure TTextAttributes.SetHeight(Value: Integer);
  9171. begin
  9172.   Size := MulDiv(Value, 72, RichEdit.FScreenLogPixels);
  9173. end;
  9174.  
  9175. function TTextAttributes.GetPitch: TFontPitch;
  9176. var
  9177.   Format: TCharFormat;
  9178. begin
  9179.   GetAttributes(Format);
  9180.   case (Format.bPitchAndFamily and $03) of
  9181.     DEFAULT_PITCH: Result := fpDefault;
  9182.     VARIABLE_PITCH: Result := fpVariable;
  9183.     FIXED_PITCH: Result := fpFixed;
  9184.   else
  9185.     Result := fpDefault;
  9186.   end;
  9187. end;
  9188.  
  9189. procedure TTextAttributes.SetPitch(Value: TFontPitch);
  9190. var
  9191.   Format: TCharFormat;
  9192. begin
  9193.   InitFormat(Format);
  9194.   with Format do
  9195.   begin
  9196.     case Value of
  9197.       fpVariable: Format.bPitchAndFamily := VARIABLE_PITCH;
  9198.       fpFixed: Format.bPitchAndFamily := FIXED_PITCH;
  9199.     else
  9200.       Format.bPitchAndFamily := DEFAULT_PITCH;
  9201.     end;
  9202.   end;
  9203.   SetAttributes(Format);
  9204. end;
  9205.  
  9206. procedure TTextAttributes.Assign(Source: TPersistent);
  9207. begin
  9208.   if Source is TFont then
  9209.   begin
  9210.     Color := TFont(Source).Color;
  9211.     Name := TFont(Source).Name;
  9212.     Charset := TFont(Source).Charset;
  9213.     Style := TFont(Source).Style;
  9214.     Size := TFont(Source).Size;
  9215.     Pitch := TFont(Source).Pitch;
  9216.   end
  9217.   else if Source is TTextAttributes then
  9218.   begin
  9219.     Color := TTextAttributes(Source).Color;
  9220.     Name := TTextAttributes(Source).Name;
  9221.     Charset := TTextAttributes(Source).Charset;
  9222.     Style := TTextAttributes(Source).Style;
  9223.     Pitch := TTextAttributes(Source).Pitch;
  9224.   end
  9225.   else inherited Assign(Source);
  9226. end;
  9227.  
  9228. procedure TTextAttributes.AssignTo(Dest: TPersistent);
  9229. begin
  9230.   if Dest is TFont then
  9231.   begin
  9232.     TFont(Dest).Color := Color;
  9233.     TFont(Dest).Name := Name;
  9234.     TFont(Dest).Charset := Charset;
  9235.     TFont(Dest).Style := Style;
  9236.     TFont(Dest).Size := Size;
  9237.     TFont(Dest).Pitch := Pitch;
  9238.   end
  9239.   else if Dest is TTextAttributes then
  9240.   begin
  9241.     TTextAttributes(Dest).Color := Color;
  9242.     TTextAttributes(Dest).Name := Name;
  9243.     TTextAttributes(Dest).Charset := Charset;
  9244.     TTextAttributes(Dest).Style := Style;
  9245.     TTextAttributes(Dest).Pitch := Pitch;
  9246.   end
  9247.   else inherited AssignTo(Dest);
  9248. end;
  9249.  
  9250. { TParaAttributes }
  9251.  
  9252. constructor TParaAttributes.Create(AOwner: TCustomRichEdit);
  9253. begin
  9254.   inherited Create;
  9255.   RichEdit := AOwner;
  9256. end;
  9257.  
  9258. procedure TParaAttributes.InitPara(var Paragraph: TParaFormat);
  9259. begin
  9260.   FillChar(Paragraph, SizeOf(TParaFormat), 0);
  9261.   Paragraph.cbSize := SizeOf(TParaFormat);
  9262. end;
  9263.  
  9264. procedure TParaAttributes.GetAttributes(var Paragraph: TParaFormat);
  9265. begin
  9266.   InitPara(Paragraph);
  9267.   if RichEdit.HandleAllocated then
  9268.     SendMessage(RichEdit.Handle, EM_GETPARAFORMAT, 0, LPARAM(@Paragraph));
  9269. end;
  9270.  
  9271. procedure TParaAttributes.SetAttributes(var Paragraph: TParaFormat);
  9272. begin
  9273.   RichEdit.HandleNeeded; { we REALLY need the handle for BiDi }
  9274.   if RichEdit.HandleAllocated then
  9275.   begin
  9276.     if RichEdit.UseRightToLeftAlignment then
  9277.       if Paragraph.wAlignment = PFA_LEFT then
  9278.         Paragraph.wAlignment := PFA_RIGHT
  9279.       else if Paragraph.wAlignment = PFA_RIGHT then
  9280.         Paragraph.wAlignment := PFA_LEFT;
  9281.     SendMessage(RichEdit.Handle, EM_SETPARAFORMAT, 0, LPARAM(@Paragraph));
  9282.   end;
  9283. end;
  9284.  
  9285. function TParaAttributes.GetAlignment: TAlignment;
  9286. var
  9287.   Paragraph: TParaFormat;
  9288. begin
  9289.   GetAttributes(Paragraph);
  9290.   Result := TAlignment(Paragraph.wAlignment - 1);
  9291. end;
  9292.  
  9293. procedure TParaAttributes.SetAlignment(Value: TAlignment);
  9294. var
  9295.   Paragraph: TParaFormat;
  9296. begin
  9297.   InitPara(Paragraph);
  9298.   with Paragraph do
  9299.   begin
  9300.     dwMask := PFM_ALIGNMENT;
  9301.     wAlignment := Ord(Value) + 1;
  9302.   end;
  9303.   SetAttributes(Paragraph);
  9304. end;
  9305.  
  9306. function TParaAttributes.GetNumbering: TNumberingStyle;
  9307. var
  9308.   Paragraph: TParaFormat;
  9309. begin
  9310.   GetAttributes(Paragraph);
  9311.   Result := TNumberingStyle(Paragraph.wNumbering);
  9312. end;
  9313.  
  9314. procedure TParaAttributes.SetNumbering(Value: TNumberingStyle);
  9315. var
  9316.   Paragraph: TParaFormat;
  9317. begin
  9318.   case Value of
  9319.     nsBullet: if LeftIndent < 10 then LeftIndent := 10;
  9320.     nsNone: LeftIndent := 0;
  9321.   end;
  9322.   InitPara(Paragraph);
  9323.   with Paragraph do
  9324.   begin
  9325.     dwMask := PFM_NUMBERING;
  9326.     wNumbering := Ord(Value);
  9327.   end;
  9328.   SetAttributes(Paragraph);
  9329. end;
  9330.  
  9331. function TParaAttributes.GetFirstIndent: Longint;
  9332. var
  9333.   Paragraph: TParaFormat;
  9334. begin
  9335.   GetAttributes(Paragraph);
  9336.   Result := Paragraph.dxStartIndent div 20
  9337. end;
  9338.  
  9339. procedure TParaAttributes.SetFirstIndent(Value: Longint);
  9340. var
  9341.   Paragraph: TParaFormat;
  9342. begin
  9343.   InitPara(Paragraph);
  9344.   with Paragraph do
  9345.   begin
  9346.     dwMask := PFM_STARTINDENT;
  9347.     dxStartIndent := Value * 20;
  9348.   end;
  9349.   SetAttributes(Paragraph);
  9350. end;
  9351.  
  9352. function TParaAttributes.GetLeftIndent: Longint;
  9353. var
  9354.   Paragraph: TParaFormat;
  9355. begin
  9356.   GetAttributes(Paragraph);
  9357.   Result := Paragraph.dxOffset div 20;
  9358. end;
  9359.  
  9360. procedure TParaAttributes.SetLeftIndent(Value: Longint);
  9361. var
  9362.   Paragraph: TParaFormat;
  9363. begin
  9364.   InitPara(Paragraph);
  9365.   with Paragraph do
  9366.   begin
  9367.     dwMask := PFM_OFFSET;
  9368.     dxOffset := Value * 20;
  9369.   end;
  9370.   SetAttributes(Paragraph);
  9371. end;
  9372.  
  9373. function TParaAttributes.GetRightIndent: Longint;
  9374. var
  9375.   Paragraph: TParaFormat;
  9376. begin
  9377.   GetAttributes(Paragraph);
  9378.   Result := Paragraph.dxRightIndent div 20;
  9379. end;
  9380.  
  9381. procedure TParaAttributes.SetRightIndent(Value: Longint);
  9382. var
  9383.   Paragraph: TParaFormat;
  9384. begin
  9385.   InitPara(Paragraph);
  9386.   with Paragraph do
  9387.   begin
  9388.     dwMask := PFM_RIGHTINDENT;
  9389.     dxRightIndent := Value * 20;
  9390.   end;
  9391.   SetAttributes(Paragraph);
  9392. end;
  9393.  
  9394. function TParaAttributes.GetTab(Index: Byte): Longint;
  9395. var
  9396.   Paragraph: TParaFormat;
  9397. begin
  9398.   GetAttributes(Paragraph);
  9399.   Result := Paragraph.rgxTabs[Index] div 20;
  9400. end;
  9401.  
  9402. procedure TParaAttributes.SetTab(Index: Byte; Value: Longint);
  9403. var
  9404.   Paragraph: TParaFormat;
  9405. begin
  9406.   GetAttributes(Paragraph);
  9407.   with Paragraph do
  9408.   begin
  9409.     rgxTabs[Index] := Value * 20;
  9410.     dwMask := PFM_TABSTOPS;
  9411.     if cTabCount < Index then cTabCount := Index;
  9412.     SetAttributes(Paragraph);
  9413.   end;
  9414. end;
  9415.  
  9416. function TParaAttributes.GetTabCount: Integer;
  9417. var
  9418.   Paragraph: TParaFormat;
  9419. begin
  9420.   GetAttributes(Paragraph);
  9421.   Result := Paragraph.cTabCount;
  9422. end;
  9423.  
  9424. procedure TParaAttributes.SetTabCount(Value: Integer);
  9425. var
  9426.   Paragraph: TParaFormat;
  9427. begin
  9428.   GetAttributes(Paragraph);
  9429.   with Paragraph do
  9430.   begin
  9431.     dwMask := PFM_TABSTOPS;
  9432.     cTabCount := Value;
  9433.     SetAttributes(Paragraph);
  9434.   end;
  9435. end;
  9436.  
  9437. procedure TParaAttributes.Assign(Source: TPersistent);
  9438. var
  9439.   I: Integer;
  9440. begin
  9441.   if Source is TParaAttributes then
  9442.   begin
  9443.     Alignment := TParaAttributes(Source).Alignment;
  9444.     FirstIndent := TParaAttributes(Source).FirstIndent;
  9445.     LeftIndent := TParaAttributes(Source).LeftIndent;
  9446.     RightIndent := TParaAttributes(Source).RightIndent;
  9447.     Numbering := TParaAttributes(Source).Numbering;
  9448.     for I := 0 to MAX_TAB_STOPS - 1 do
  9449.       Tab[I] := TParaAttributes(Source).Tab[I];
  9450.   end
  9451.   else inherited Assign(Source);
  9452. end;
  9453.  
  9454. { TConversion }
  9455.  
  9456. function TConversion.ConvertReadStream(Stream: TStream; Buffer: PChar; BufSize: Integer): Integer;
  9457. begin
  9458.   Result := Stream.Read(Buffer^, BufSize);
  9459. end;
  9460.  
  9461. function TConversion.ConvertWriteStream(Stream: TStream; Buffer: PChar; BufSize: Integer): Integer;
  9462. begin
  9463.   Result := Stream.Write(Buffer^, BufSize);
  9464. end;
  9465.  
  9466. { TRichEditStrings }
  9467.  
  9468. const
  9469.   ReadError = $0001;
  9470.   WriteError = $0002;
  9471.   NoError = $0000;
  9472.  
  9473. type
  9474.   TSelection = record
  9475.     StartPos, EndPos: Integer;
  9476.   end;
  9477.  
  9478.   TRichEditStrings = class(TStrings)
  9479.   private
  9480.     RichEdit: TCustomRichEdit;
  9481.     FPlainText: Boolean;
  9482.     FConverter: TConversion;
  9483.     procedure EnableChange(const Value: Boolean);
  9484.   protected
  9485.     function Get(Index: Integer): string; override;
  9486.     function GetCount: Integer; override;
  9487.     procedure Put(Index: Integer; const S: string); override;
  9488.     procedure SetUpdateState(Updating: Boolean); override;
  9489.     procedure SetTextStr(const Value: string); override;
  9490.   public
  9491.     destructor Destroy; override;
  9492.     procedure Clear; override;
  9493.     procedure AddStrings(Strings: TStrings); override;
  9494.     procedure Delete(Index: Integer); override;
  9495.     procedure Insert(Index: Integer; const S: string); override;
  9496.     procedure LoadFromFile(const FileName: string); override;
  9497.     procedure LoadFromStream(Stream: TStream); override;
  9498.     procedure SaveToFile(const FileName: string); override;
  9499.     procedure SaveToStream(Stream: TStream); override;
  9500.     property PlainText: Boolean read FPlainText write FPlainText;
  9501.   end;
  9502.  
  9503. destructor TRichEditStrings.Destroy;
  9504. begin
  9505.   FConverter.Free;
  9506.   inherited Destroy;
  9507. end;
  9508.  
  9509. procedure TRichEditStrings.AddStrings(Strings: TStrings);
  9510. var
  9511.   SelChange: TNotifyEvent;
  9512. begin
  9513.   SelChange := RichEdit.OnSelectionChange;
  9514.   RichEdit.OnSelectionChange := nil;
  9515.   try
  9516.     inherited AddStrings(Strings);
  9517.   finally
  9518.     RichEdit.OnSelectionChange := SelChange;
  9519.   end;
  9520. end;
  9521.  
  9522. function TRichEditStrings.GetCount: Integer;
  9523. begin
  9524.   Result := SendMessage(RichEdit.Handle, EM_GETLINECOUNT, 0, 0);
  9525.   if SendMessage(RichEdit.Handle, EM_LINELENGTH, SendMessage(RichEdit.Handle,
  9526.     EM_LINEINDEX, Result - 1, 0), 0) = 0 then Dec(Result);
  9527. end;
  9528.  
  9529. function TRichEditStrings.Get(Index: Integer): string;
  9530. var
  9531.   Text: array[0..4095] of Char;
  9532.   L: Integer;
  9533. begin
  9534.   Word((@Text)^) := SizeOf(Text);
  9535.   L := SendMessage(RichEdit.Handle, EM_GETLINE, Index, Longint(@Text));
  9536.   if (Text[L - 2] = #13) and (Text[L - 1] = #10) then Dec(L, 2);
  9537.   SetString(Result, Text, L);
  9538. end;
  9539.  
  9540. procedure TRichEditStrings.Put(Index: Integer; const S: string);
  9541. var
  9542.   Selection: TCharRange;
  9543. begin
  9544.   if Index >= 0 then
  9545.   begin
  9546.     Selection.cpMin := SendMessage(RichEdit.Handle, EM_LINEINDEX, Index, 0);
  9547.     if Selection.cpMin <> -1 then
  9548.     begin
  9549.       Selection.cpMax := Selection.cpMin +
  9550.         SendMessage(RichEdit.Handle, EM_LINELENGTH, Selection.cpMin, 0);
  9551.       SendMessage(RichEdit.Handle, EM_EXSETSEL, 0, Longint(@Selection));
  9552.       SendMessage(RichEdit.Handle, EM_REPLACESEL, 0, Longint(PChar(S)));
  9553.     end;
  9554.   end;
  9555. end;
  9556.  
  9557. procedure TRichEditStrings.Insert(Index: Integer; const S: string);
  9558. var
  9559.   L: Integer;
  9560.   Selection: TCharRange;
  9561.   Fmt: PChar;
  9562.   Str: string;
  9563. begin
  9564.   if Index >= 0 then
  9565.   begin
  9566.     Selection.cpMin := SendMessage(RichEdit.Handle, EM_LINEINDEX, Index, 0);
  9567.     if Selection.cpMin >= 0 then Fmt := '%s'#13#10
  9568.     else begin
  9569.       Selection.cpMin :=
  9570.         SendMessage(RichEdit.Handle, EM_LINEINDEX, Index - 1, 0);
  9571.       if Selection.cpMin < 0 then Exit;
  9572.       L := SendMessage(RichEdit.Handle, EM_LINELENGTH, Selection.cpMin, 0);
  9573.       if L = 0 then Exit;
  9574.       Inc(Selection.cpMin, L);
  9575.       Fmt := #13#10'%s';
  9576.     end;
  9577.     Selection.cpMax := Selection.cpMin;
  9578.     SendMessage(RichEdit.Handle, EM_EXSETSEL, 0, Longint(@Selection));
  9579.     Str := Format(Fmt, [S]);
  9580.     SendMessage(RichEdit.Handle, EM_REPLACESEL, 0, LongInt(PChar(Str)));
  9581.     if RichEdit.SelStart <> (Selection.cpMax + Length(Str)) then
  9582.       raise EOutOfResources.Create(sRichEditInsertError);
  9583.   end;
  9584. end;
  9585.  
  9586. procedure TRichEditStrings.Delete(Index: Integer);
  9587. const
  9588.   Empty: PChar = '';
  9589. var
  9590.   Selection: TCharRange;
  9591. begin
  9592.   if Index < 0 then Exit;
  9593.   Selection.cpMin := SendMessage(RichEdit.Handle, EM_LINEINDEX, Index, 0);
  9594.   if Selection.cpMin <> -1 then
  9595.   begin
  9596.     Selection.cpMax := SendMessage(RichEdit.Handle, EM_LINEINDEX, Index + 1, 0);
  9597.     if Selection.cpMax = -1 then
  9598.       Selection.cpMax := Selection.cpMin +
  9599.         SendMessage(RichEdit.Handle, EM_LINELENGTH, Selection.cpMin, 0);
  9600.     SendMessage(RichEdit.Handle, EM_EXSETSEL, 0, Longint(@Selection));
  9601.     SendMessage(RichEdit.Handle, EM_REPLACESEL, 0, Longint(Empty));
  9602.   end;
  9603. end;
  9604.  
  9605. procedure TRichEditStrings.Clear;
  9606. begin
  9607.   RichEdit.Clear;
  9608. end;
  9609.  
  9610. procedure TRichEditStrings.SetUpdateState(Updating: Boolean);
  9611. begin
  9612.   if RichEdit.Showing then
  9613.     SendMessage(RichEdit.Handle, WM_SETREDRAW, Ord(not Updating), 0);
  9614.   if not Updating then begin
  9615.     RichEdit.Refresh;
  9616.     RichEdit.Perform(CM_TEXTCHANGED, 0, 0);
  9617.   end;
  9618. end;
  9619.  
  9620. procedure TRichEditStrings.EnableChange(const Value: Boolean);
  9621. var
  9622.   EventMask: Longint;
  9623. begin
  9624.   with RichEdit do
  9625.   begin
  9626.     if Value then
  9627.       EventMask := SendMessage(Handle, EM_GETEVENTMASK, 0, 0) or ENM_CHANGE
  9628.     else
  9629.       EventMask := SendMessage(Handle, EM_GETEVENTMASK, 0, 0) and not ENM_CHANGE;
  9630.     SendMessage(Handle, EM_SETEVENTMASK, 0, EventMask);
  9631.   end;
  9632. end;
  9633.  
  9634. procedure TRichEditStrings.SetTextStr(const Value: string);
  9635. begin
  9636.   EnableChange(False);
  9637.   try
  9638.     inherited SetTextStr(Value);
  9639.   finally
  9640.     EnableChange(True);
  9641.   end;
  9642. end;
  9643.  
  9644. function AdjustLineBreaks(Dest, Source: PChar): Integer; assembler;
  9645. asm
  9646.         PUSH    ESI
  9647.         PUSH    EDI
  9648.         MOV     EDI,EAX
  9649.         MOV     ESI,EDX
  9650.         MOV     EDX,EAX
  9651.         CLD
  9652. @@1:    LODSB
  9653. @@2:    OR      AL,AL
  9654.         JE      @@4
  9655.         CMP     AL,0AH
  9656.         JE      @@3
  9657.         STOSB
  9658.         CMP     AL,0DH
  9659.         JNE     @@1
  9660.         MOV     AL,0AH
  9661.         STOSB
  9662.         LODSB
  9663.         CMP     AL,0AH
  9664.         JE      @@1
  9665.         JMP     @@2
  9666. @@3:    MOV     EAX,0A0DH
  9667.         STOSW
  9668.         JMP     @@1
  9669. @@4:    STOSB
  9670.         LEA     EAX,[EDI-1]
  9671.         SUB     EAX,EDX
  9672.         POP     EDI
  9673.         POP     ESI
  9674. end;
  9675.  
  9676. function StreamSave(dwCookie: Longint; pbBuff: PByte;
  9677.   cb: Longint; var pcb: Longint): Longint; stdcall;
  9678. var
  9679.   StreamInfo: PRichEditStreamInfo;
  9680. begin
  9681.   Result := NoError;
  9682.   StreamInfo := PRichEditStreamInfo(Pointer(dwCookie));
  9683.   try
  9684.     pcb := 0;
  9685.     if StreamInfo^.Converter <> nil then
  9686.       pcb := StreamInfo^.Converter.ConvertWriteStream(StreamInfo^.Stream, PChar(pbBuff), cb);
  9687.   except
  9688.     Result := WriteError;
  9689.   end;
  9690. end;
  9691.  
  9692. function StreamLoad(dwCookie: Longint; pbBuff: PByte;
  9693.   cb: Longint; var pcb: Longint): Longint; stdcall;
  9694. var
  9695.   Buffer, pBuff: PChar;
  9696.   StreamInfo: PRichEditStreamInfo;
  9697. begin
  9698.   Result := NoError;
  9699.   StreamInfo := PRichEditStreamInfo(Pointer(dwCookie));
  9700.   Buffer := StrAlloc(cb + 1);
  9701.   try
  9702.     cb := cb div 2;
  9703.     pcb := 0;
  9704.     pBuff := Buffer + cb;
  9705.     try
  9706.       if StreamInfo^.Converter <> nil then
  9707.         pcb := StreamInfo^.Converter.ConvertReadStream(StreamInfo^.Stream, pBuff, cb);
  9708.       if pcb > 0 then
  9709.       begin
  9710.         pBuff[pcb] := #0;
  9711.         if pBuff[pcb - 1] = #13 then pBuff[pcb - 1] := #0;
  9712.         pcb := AdjustLineBreaks(Buffer, pBuff);
  9713.         Move(Buffer^, pbBuff^, pcb);
  9714.       end;
  9715.     except
  9716.       Result := ReadError;
  9717.     end;
  9718.   finally
  9719.     StrDispose(Buffer);
  9720.   end;
  9721. end;
  9722.  
  9723. procedure TRichEditStrings.LoadFromStream(Stream: TStream);
  9724. var
  9725.   EditStream: TEditStream;
  9726.   Position: Longint;
  9727.   TextType: Longint;
  9728.   StreamInfo: TRichEditStreamInfo;
  9729.   Converter: TConversion;
  9730. begin
  9731.   StreamInfo.Stream := Stream;
  9732.   if FConverter <> nil then Converter := FConverter
  9733.   else Converter := RichEdit.DefaultConverter.Create;
  9734.   StreamInfo.Converter := Converter;
  9735.   try
  9736.     with EditStream do
  9737.     begin
  9738.       dwCookie := LongInt(Pointer(@StreamInfo));
  9739.       pfnCallBack := @StreamLoad;
  9740.       dwError := 0;
  9741.     end;
  9742.     Position := Stream.Position;
  9743.     if PlainText then TextType := SF_TEXT
  9744.     else TextType := SF_RTF;
  9745.     SendMessage(RichEdit.Handle, EM_STREAMIN, TextType, Longint(@EditStream));
  9746.     if (TextType = SF_RTF) and (EditStream.dwError <> 0) then
  9747.     begin
  9748.       Stream.Position := Position;
  9749.       if PlainText then TextType := SF_RTF
  9750.       else TextType := SF_TEXT;
  9751.       SendMessage(RichEdit.Handle, EM_STREAMIN, TextType, Longint(@EditStream));
  9752.       if EditStream.dwError <> 0 then
  9753.         raise EOutOfResources.Create(sRichEditLoadFail);
  9754.     end;
  9755.   finally
  9756.     if FConverter = nil then Converter.Free;
  9757.   end;
  9758. end;
  9759.  
  9760. procedure TRichEditStrings.SaveToStream(Stream: TStream);
  9761. var
  9762.   EditStream: TEditStream;
  9763.   TextType: Longint;
  9764.   StreamInfo: TRichEditStreamInfo;
  9765.   Converter: TConversion;
  9766. begin
  9767.   if FConverter <> nil then Converter := FConverter
  9768.   else Converter := RichEdit.DefaultConverter.Create;
  9769.   StreamInfo.Stream := Stream;
  9770.   StreamInfo.Converter := Converter;
  9771.   try
  9772.     with EditStream do
  9773.     begin
  9774.       dwCookie := LongInt(Pointer(@StreamInfo));
  9775.       pfnCallBack := @StreamSave;
  9776.       dwError := 0;
  9777.     end;
  9778.     if PlainText then TextType := SF_TEXT
  9779.     else TextType := SF_RTF;
  9780.     SendMessage(RichEdit.Handle, EM_STREAMOUT, TextType, Longint(@EditStream));
  9781.     if EditStream.dwError <> 0 then
  9782.       raise EOutOfResources.Create(sRichEditSaveFail);
  9783.   finally
  9784.     if FConverter = nil then Converter.Free;
  9785.   end;
  9786. end;
  9787.  
  9788. procedure TRichEditStrings.LoadFromFile(const FileName: string);
  9789. var
  9790.   Ext: string;
  9791.   Convert: PConversionFormat;
  9792. begin
  9793.   Ext := AnsiLowerCaseFileName(ExtractFileExt(Filename));
  9794.   System.Delete(Ext, 1, 1);
  9795.   Convert := ConversionFormatList;
  9796.   while Convert <> nil do
  9797.     with Convert^ do
  9798.       if Extension <> Ext then Convert := Next
  9799.       else Break;
  9800.   if Convert = nil then
  9801.     Convert := @TextConversionFormat;
  9802.   if FConverter = nil then FConverter := Convert^.ConversionClass.Create;
  9803.   try
  9804.     inherited LoadFromFile(FileName);
  9805.   except
  9806.     FConverter.Free;
  9807.     FConverter := nil;
  9808.     raise;
  9809.   end;
  9810.   RichEdit.DoSetMaxLength($7FFFFFF0);
  9811. end;
  9812.  
  9813. procedure TRichEditStrings.SaveToFile(const FileName: string);
  9814. var
  9815.   Ext: string;
  9816.   Convert: PConversionFormat;
  9817. begin
  9818.   Ext := AnsiLowerCaseFileName(ExtractFileExt(Filename));
  9819.   System.Delete(Ext, 1, 1);
  9820.   Convert := ConversionFormatList;
  9821.   while Convert <> nil do
  9822.     with Convert^ do
  9823.       if Extension <> Ext then Convert := Next
  9824.       else Break;
  9825.   if Convert = nil then
  9826.     Convert := @TextConversionFormat;
  9827.   if FConverter = nil then FConverter := Convert^.ConversionClass.Create;
  9828.   try
  9829.     inherited SaveToFile(FileName);
  9830.   except
  9831.     FConverter.Free;
  9832.     FConverter := nil;
  9833.     raise;
  9834.   end;
  9835. end;
  9836.  
  9837. { TRichEdit }
  9838.  
  9839. constructor TCustomRichEdit.Create(AOwner: TComponent);
  9840. var
  9841.   DC: HDC;
  9842. begin
  9843.   inherited Create(AOwner);
  9844.   FSelAttributes := TTextAttributes.Create(Self, atSelected);
  9845.   FDefAttributes := TTextAttributes.Create(Self, atDefaultText);
  9846.   FParagraph := TParaAttributes.Create(Self);
  9847.   FRichEditStrings := TRichEditStrings.Create;
  9848.   TRichEditStrings(FRichEditStrings).RichEdit := Self;
  9849.   TabStop := True;
  9850.   Width := 185;
  9851.   Height := 89;
  9852.   AutoSize := False;
  9853.   DoubleBuffered := False;
  9854.   FHideSelection := True;
  9855.   HideScrollBars := True;
  9856.   DC := GetDC(0);
  9857.   FScreenLogPixels := GetDeviceCaps(DC, LOGPIXELSY);
  9858.   DefaultConverter := TConversion;
  9859.   ReleaseDC(0, DC);
  9860.   FOldParaAlignment := Alignment;
  9861.   Perform(CM_PARENTBIDIMODECHANGED, 0, 0);
  9862. end;
  9863.  
  9864. destructor TCustomRichEdit.Destroy;
  9865. begin
  9866.   FSelAttributes.Free;
  9867.   FDefAttributes.Free;
  9868.   FParagraph.Free;
  9869.   FRichEditStrings.Free;
  9870.   FMemStream.Free;
  9871.   inherited Destroy;
  9872. end;
  9873.  
  9874. procedure TCustomRichEdit.Clear;
  9875. begin
  9876.   inherited Clear;
  9877.   Modified := False;
  9878. end;
  9879.  
  9880. procedure TCustomRichEdit.CreateParams(var Params: TCreateParams);
  9881. const
  9882.   RichEditModuleName = 'RICHED32.DLL';
  9883.   HideScrollBars: array[Boolean] of DWORD = (ES_DISABLENOSCROLL, 0);
  9884.   HideSelections: array[Boolean] of DWORD = (ES_NOHIDESEL, 0);
  9885. begin
  9886.   if FRichEditModule = 0 then
  9887.   begin
  9888.     FRichEditModule := LoadLibrary(RichEditModuleName);
  9889.     if FRichEditModule <= HINSTANCE_ERROR then FRichEditModule := 0;
  9890.   end;
  9891.   inherited CreateParams(Params);
  9892.   CreateSubClass(Params, 'RICHEDIT');
  9893.   with Params do
  9894.   begin
  9895.     Style := Style or HideScrollBars[FHideScrollBars] or
  9896.       HideSelections[HideSelection];
  9897.     WindowClass.style := WindowClass.style and not (CS_HREDRAW or CS_VREDRAW);
  9898.   end;
  9899. end;
  9900.  
  9901. procedure TCustomRichEdit.CreateWnd;
  9902. var
  9903.   Plain, DesignMode, WasModified: Boolean;
  9904. begin
  9905.   WasModified := inherited Modified;
  9906.   inherited CreateWnd;
  9907.   if (SysLocale.FarEast) and not (SysLocale.PriLangID = LANG_JAPANESE) then
  9908.     Font.Charset := GetDefFontCharSet;
  9909.   SendMessage(Handle, EM_SETEVENTMASK, 0,
  9910.     ENM_CHANGE or ENM_SELCHANGE or ENM_REQUESTRESIZE or
  9911.     ENM_PROTECTED);
  9912.   SendMessage(Handle, EM_SETBKGNDCOLOR, 0, ColorToRGB(Color));
  9913.   if FMemStream <> nil then
  9914.   begin
  9915.     Plain := PlainText;
  9916.     FMemStream.ReadBuffer(DesignMode, sizeof(DesignMode));
  9917.     PlainText := DesignMode;
  9918.     try
  9919.       Lines.LoadFromStream(FMemStream);
  9920.       FMemStream.Free;
  9921.       FMemStream := nil;
  9922.     finally
  9923.       PlainText := Plain;
  9924.     end;
  9925.   end;
  9926.   Modified := WasModified;
  9927. end;
  9928.  
  9929. procedure TCustomRichEdit.DestroyWnd;
  9930. var
  9931.   Plain, DesignMode: Boolean;
  9932. begin
  9933.   FModified := Modified;
  9934.   FMemStream := TMemoryStream.Create;
  9935.   Plain := PlainText;
  9936.   DesignMode := (csDesigning in ComponentState);
  9937.   PlainText := DesignMode;
  9938.   FMemStream.WriteBuffer(DesignMode, sizeof(DesignMode));
  9939.   try
  9940.     Lines.SaveToStream(FMemStream);
  9941.     FMemStream.Position := 0;
  9942.   finally
  9943.     PlainText := Plain;
  9944.   end;
  9945.   inherited DestroyWnd;
  9946. end;
  9947.  
  9948. procedure TCustomRichEdit.WMNCDestroy(var Message: TWMNCDestroy);
  9949. begin
  9950.   inherited;
  9951. end;
  9952.  
  9953. procedure TCustomRichEdit.WMSetFont(var Message: TWMSetFont);
  9954. begin
  9955.   FDefAttributes.Assign(Font);
  9956. end;
  9957.  
  9958. procedure TCustomRichEdit.WMRButtonUp(var Message: TWMRButtonUp);
  9959. begin
  9960.   // RichEd20 does not pass the WM_RBUTTONUP message to defwndproc,
  9961.   // so we get no WM_CONTEXTMENU message.  Simulate message here.
  9962.   if Win32MajorVersion < 5 then
  9963.     Perform(WM_CONTEXTMENU, Handle, LParam(PointToSmallPoint(
  9964.       ClientToScreen(SmallPointToPoint(Message.Pos)))));
  9965.   inherited;
  9966. end;
  9967.  
  9968. procedure TCustomRichEdit.CMFontChanged(var Message: TMessage);
  9969. begin
  9970.   FDefAttributes.Assign(Font);
  9971. end;
  9972.  
  9973. procedure TCustomRichEdit.DoSetMaxLength(Value: Integer);
  9974. begin
  9975.   SendMessage(Handle, EM_EXLIMITTEXT, 0, Value);
  9976. end;
  9977.  
  9978. function TCustomRichEdit.GetCaretPos;
  9979. var
  9980.   CharRange: TCharRange;
  9981. begin
  9982.   SendMessage(Handle, EM_EXGETSEL, 0, LongInt(@CharRange));
  9983.   Result.X := CharRange.cpMax;
  9984.   Result.Y := SendMessage(Handle, EM_EXLINEFROMCHAR, 0, Result.X);
  9985.   Result.X := Result.X - SendMessage(Handle, EM_LINEINDEX, -1, 0);
  9986. end;
  9987.  
  9988. function TCustomRichEdit.GetSelLength: Integer;
  9989. var
  9990.   CharRange: TCharRange;
  9991. begin
  9992.   SendMessage(Handle, EM_EXGETSEL, 0, Longint(@CharRange));
  9993.   Result := CharRange.cpMax - CharRange.cpMin;
  9994. end;
  9995.  
  9996. function TCustomRichEdit.GetSelStart: Integer;
  9997. var
  9998.   CharRange: TCharRange;
  9999. begin
  10000.   SendMessage(Handle, EM_EXGETSEL, 0, Longint(@CharRange));
  10001.   Result := CharRange.cpMin;
  10002. end;
  10003.  
  10004. function TCustomRichEdit.GetSelTextBuf(Buffer: PChar; BufSize: Integer): Integer;
  10005. var
  10006.   S: string;
  10007. begin
  10008.   S := GetSelText;
  10009.   Result := Length(S);
  10010.   if BufSize < Length(S) then Result := BufSize;
  10011.   StrPLCopy(Buffer, S, Result);
  10012. end;
  10013.  
  10014. function TCustomRichEdit.GetSelText: string;
  10015. var
  10016.   Length: Integer;
  10017. begin
  10018.   SetLength(Result, GetSelLength + 1);
  10019.   Length := SendMessage(Handle, EM_GETSELTEXT, 0, Longint(PChar(Result)));
  10020.   SetLength(Result, Length);
  10021. end;
  10022.  
  10023. procedure TCustomRichEdit.CMBiDiModeChanged(var Message: TMessage);
  10024. var
  10025.   AParagraph: TParaFormat;
  10026. begin
  10027.   HandleNeeded; { we REALLY need the handle for BiDi }
  10028.   inherited;
  10029.   Paragraph.GetAttributes(AParagraph);
  10030.   AParagraph.dwMask := PFM_ALIGNMENT;
  10031.   AParagraph.wAlignment := Ord(Alignment) + 1;
  10032.   Paragraph.SetAttributes(AParagraph);
  10033. end;
  10034.  
  10035. procedure TCustomRichEdit.SetHideScrollBars(Value: Boolean);
  10036. begin
  10037.   if HideScrollBars <> Value then
  10038.   begin
  10039.     FHideScrollBars := value;
  10040.     RecreateWnd;
  10041.   end;
  10042. end;
  10043.  
  10044. procedure TCustomRichEdit.SetHideSelection(Value: Boolean);
  10045. begin
  10046.   if HideSelection <> Value then
  10047.   begin
  10048.     FHideSelection := Value;
  10049.     SendMessage(Handle, EM_HIDESELECTION, Ord(HideSelection), LongInt(True));
  10050.   end;
  10051. end;
  10052.  
  10053. procedure TCustomRichEdit.SetSelAttributes(Value: TTextAttributes);
  10054. begin
  10055.   SelAttributes.Assign(Value);
  10056. end;
  10057.  
  10058. procedure TCustomRichEdit.SetSelLength(Value: Integer);
  10059. var
  10060.   CharRange: TCharRange;
  10061. begin
  10062.   SendMessage(Handle, EM_EXGETSEL, 0, Longint(@CharRange));
  10063.   CharRange.cpMax := CharRange.cpMin + Value;
  10064.   SendMessage(Handle, EM_EXSETSEL, 0, Longint(@CharRange));
  10065.   SendMessage(Handle, EM_SCROLLCARET, 0, 0);
  10066. end;
  10067.  
  10068. procedure TCustomRichEdit.SetDefAttributes(Value: TTextAttributes);
  10069. begin
  10070.   DefAttributes.Assign(Value);
  10071. end;
  10072.  
  10073. function TCustomRichEdit.GetPlainText: Boolean;
  10074. begin
  10075.   Result := TRichEditStrings(Lines).PlainText;
  10076. end;
  10077.  
  10078. procedure TCustomRichEdit.SetPlainText(Value: Boolean);
  10079. begin
  10080.   TRichEditStrings(Lines).PlainText := Value;
  10081. end;
  10082.  
  10083. procedure TCustomRichEdit.CMColorChanged(var Message: TMessage);
  10084. begin
  10085.   inherited;
  10086.   SendMessage(Handle, EM_SETBKGNDCOLOR, 0, ColorToRGB(Color))
  10087. end;
  10088.  
  10089. procedure TCustomRichEdit.SetRichEditStrings(Value: TStrings);
  10090. begin
  10091.   FRichEditStrings.Assign(Value);
  10092. end;
  10093.  
  10094. procedure TCustomRichEdit.SetSelStart(Value: Integer);
  10095. var
  10096.   CharRange: TCharRange;
  10097. begin
  10098.   CharRange.cpMin := Value;
  10099.   CharRange.cpMax := Value;
  10100.   SendMessage(Handle, EM_EXSETSEL, 0, Longint(@CharRange));
  10101. end;
  10102.  
  10103. procedure TCustomRichEdit.Print(const Caption: string);
  10104. var
  10105.   Range: TFormatRange;
  10106.   LastChar, MaxLen, LogX, LogY, OldMap: Integer;
  10107.   SaveRect: TRect;
  10108. begin
  10109.   FillChar(Range, SizeOf(TFormatRange), 0);
  10110.   with Printer, Range do
  10111.   begin
  10112.     Title := Caption;
  10113.     BeginDoc;
  10114.     hdc := Handle;
  10115.     hdcTarget := hdc;
  10116.     LogX := GetDeviceCaps(Handle, LOGPIXELSX);
  10117.     LogY := GetDeviceCaps(Handle, LOGPIXELSY);
  10118.     if IsRectEmpty(PageRect) then
  10119.     begin
  10120.       rc.right := PageWidth * 1440 div LogX;
  10121.       rc.bottom := PageHeight * 1440 div LogY;
  10122.     end
  10123.     else begin
  10124.       rc.left := PageRect.Left * 1440 div LogX;
  10125.       rc.top := PageRect.Top * 1440 div LogY;
  10126.       rc.right := PageRect.Right * 1440 div LogX;
  10127.       rc.bottom := PageRect.Bottom * 1440 div LogY;
  10128.     end;
  10129.     rcPage := rc;
  10130.     SaveRect := rc;
  10131.     LastChar := 0;
  10132.     MaxLen := GetTextLen;
  10133.     chrg.cpMax := -1;
  10134.     // ensure printer DC is in text map mode
  10135.     OldMap := SetMapMode(hdc, MM_TEXT);
  10136.     SendMessage(Self.Handle, EM_FORMATRANGE, 0, 0);    // flush buffer
  10137.     try
  10138.       repeat
  10139.         rc := SaveRect;
  10140.         chrg.cpMin := LastChar;
  10141.         LastChar := SendMessage(Self.Handle, EM_FORMATRANGE, 1, Longint(@Range));
  10142.         if (LastChar < MaxLen) and (LastChar <> -1) then NewPage;
  10143.       until (LastChar >= MaxLen) or (LastChar = -1);
  10144.       EndDoc;
  10145.     finally
  10146.       SendMessage(Self.Handle, EM_FORMATRANGE, 0, 0);  // flush buffer
  10147.       SetMapMode(hdc, OldMap);       // restore previous map mode
  10148.     end;
  10149.   end;
  10150. end;
  10151.  
  10152. var
  10153.   Painting: Boolean = False;
  10154.  
  10155. procedure TCustomRichEdit.WMPaint(var Message: TWMPaint);
  10156. var
  10157.   R, R1: TRect;
  10158. begin
  10159.   if GetUpdateRect(Handle, R, True) then
  10160.   begin
  10161.     with ClientRect do R1 := Rect(Right - 3, Top, Right, Bottom);
  10162.     if IntersectRect(R, R, R1) then InvalidateRect(Handle, @R1, True);
  10163.   end;
  10164.   if Painting then
  10165.     Invalidate
  10166.   else begin
  10167.     Painting := True;
  10168.     try
  10169.       inherited;
  10170.     finally
  10171.       Painting := False;
  10172.     end;
  10173.   end;
  10174. end;
  10175.  
  10176. procedure TCustomRichEdit.WMSetCursor(var Message: TWMSetCursor);
  10177. var
  10178.   P: TPoint;
  10179. begin
  10180.   inherited;
  10181.   if Message.Result = 0 then
  10182.   begin
  10183.     Message.Result := 1;
  10184.     GetCursorPos(P);
  10185.     with PointToSmallPoint(P) do
  10186.       case Perform(WM_NCHITTEST, 0, MakeLong(X, Y)) of
  10187.         HTVSCROLL,
  10188.         HTHSCROLL:
  10189.           Windows.SetCursor(Screen.Cursors[crArrow]);
  10190.         HTCLIENT:
  10191.           Windows.SetCursor(Screen.Cursors[crIBeam]);
  10192.       end;
  10193.   end;
  10194. end;
  10195.  
  10196. procedure TCustomRichEdit.CNNotify(var Message: TWMNotify);
  10197. begin
  10198.   with Message do
  10199.     case NMHdr^.code of
  10200.       EN_SELCHANGE: SelectionChange;
  10201.       EN_REQUESTRESIZE: RequestSize(PReqSize(NMHdr)^.rc);
  10202.       EN_SAVECLIPBOARD:
  10203.         with PENSaveClipboard(NMHdr)^ do
  10204.           if not SaveClipboard(cObjectCount, cch) then Result := 1;
  10205.       EN_PROTECTED:
  10206.         with PENProtected(NMHdr)^.chrg do
  10207.           if not ProtectChange(cpMin, cpMax) then Result := 1;
  10208.     end;
  10209. end;
  10210.  
  10211. function TCustomRichEdit.SaveClipboard(NumObj, NumChars: Integer): Boolean;
  10212. begin
  10213.   Result := True;
  10214.   if Assigned(OnSaveClipboard) then OnSaveClipboard(Self, NumObj, NumChars, Result);
  10215. end;
  10216.  
  10217. function TCustomRichEdit.ProtectChange(StartPos, EndPos: Integer): Boolean;
  10218. begin
  10219.   Result := False;
  10220.   if Assigned(OnProtectChange) then OnProtectChange(Self, StartPos, EndPos, Result);
  10221. end;
  10222.  
  10223. procedure TCustomRichEdit.SelectionChange;
  10224. begin
  10225.   if Assigned(OnSelectionChange) then OnSelectionChange(Self);
  10226. end;
  10227.  
  10228. procedure TCustomRichEdit.RequestSize(const Rect: TRect);
  10229. begin
  10230.   if Assigned(OnResizeRequest) then OnResizeRequest(Self, Rect);
  10231. end;
  10232.  
  10233. function TCustomRichEdit.FindText(const SearchStr: string;
  10234.   StartPos, Length: Integer; Options: TSearchTypes): Integer;
  10235. var
  10236.   Find: TFindText;
  10237.   Flags: Integer;
  10238. begin
  10239.   with Find.chrg do
  10240.   begin
  10241.     cpMin := StartPos;
  10242.     cpMax := cpMin + Length;
  10243.   end;
  10244.   Flags := 0;
  10245.   if stWholeWord in Options then Flags := Flags or FT_WHOLEWORD;
  10246.   if stMatchCase in Options then Flags := Flags or FT_MATCHCASE;
  10247.   Find.lpstrText := PChar(SearchStr);
  10248.   Result := SendMessage(Handle, EM_FINDTEXT, Flags, LongInt(@Find));
  10249. end;
  10250.  
  10251. procedure AppendConversionFormat(const Ext: string; AClass: TConversionClass);
  10252. var
  10253.   NewRec: PConversionFormat;
  10254. begin
  10255.   New(NewRec);
  10256.   with NewRec^ do
  10257.   begin
  10258.     Extension := AnsiLowerCaseFileName(Ext);
  10259.     ConversionClass := AClass;
  10260.     Next := ConversionFormatList;
  10261.   end;
  10262.   ConversionFormatList := NewRec;
  10263. end;
  10264.  
  10265. class procedure TCustomRichEdit.RegisterConversionFormat(const AExtension: string;
  10266.   AConversionClass: TConversionClass);
  10267. begin
  10268.   AppendConversionFormat(AExtension, AConversionClass);
  10269. end;
  10270.  
  10271. { TUpDown }
  10272.  
  10273. constructor TCustomUpDown.Create(AOwner: TComponent);
  10274. begin
  10275.   inherited Create(AOwner);
  10276.   Width := GetSystemMetrics(SM_CXVSCROLL);
  10277.   Height := GetSystemMetrics(SM_CYVSCROLL);
  10278.   Height := Height + (Height div 2);
  10279.   FArrowKeys := True;
  10280.   FMax := 100;
  10281.   FIncrement := 1;
  10282.   FAlignButton := udRight;
  10283.   FOrientation := udVertical;
  10284.   FThousands := True;
  10285.   ControlStyle := ControlStyle - [csDoubleClicks];
  10286. end;
  10287.  
  10288. procedure TCustomUpDown.CreateParams(var Params: TCreateParams);
  10289. begin
  10290.   InitCommonControl(ICC_UPDOWN_CLASS);
  10291.   inherited CreateParams(Params);
  10292.   with Params do
  10293.   begin
  10294.     Style := Style or UDS_SETBUDDYINT;
  10295.     if FAlignButton = udRight then Style := Style or UDS_ALIGNRIGHT
  10296.     else Style := Style or UDS_ALIGNLEFT;
  10297.     if FOrientation = udHorizontal then Style := Style or UDS_HORZ;
  10298.     if FArrowKeys then Style := Style or UDS_ARROWKEYS;
  10299.     if not FThousands then Style := Style or UDS_NOTHOUSANDS;
  10300.     if FWrap then Style := Style or UDS_WRAP;
  10301.   end;
  10302.   CreateSubClass(Params, UPDOWN_CLASS);
  10303.   with Params.WindowClass do
  10304.     style := style and not (CS_HREDRAW or CS_VREDRAW) or CS_DBLCLKS;
  10305. end;
  10306.  
  10307. procedure TCustomUpDown.CreateWnd;
  10308. var
  10309.   OrigWidth: Integer;
  10310.   AccelArray: array [0..0] of TUDAccel;
  10311. begin
  10312.   OrigWidth := Width;  { control resizes width - disallowing user to set width }
  10313.   inherited CreateWnd;
  10314.   if FAssociate <> nil then
  10315.   begin
  10316.     UndoAutoResizing(FAssociate);
  10317.     SendMessage(Handle, UDM_SETBUDDY, FAssociate.Handle, 0);
  10318.   end;
  10319.   Width := OrigWidth;
  10320.   SendMessage(Handle, UDM_SETRANGE, 0, MakeLong(FMax, FMin));
  10321.   SendMessage(Handle, UDM_SETPOS, 0, MakeLong(FPosition, 0));
  10322.   SendMessage(Handle, UDM_GETACCEL, 1, Longint(@AccelArray));
  10323.   AccelArray[0].nInc := FIncrement;
  10324.   SendMessage(Handle, UDM_SETACCEL, 1, Longint(@AccelArray));
  10325. end;
  10326.  
  10327. procedure TCustomUpDown.WMVScroll(var Message: TWMVScroll);
  10328. begin
  10329.   inherited;
  10330.   if Message.ScrollCode = SB_THUMBPOSITION then
  10331.   begin
  10332.     if Message.Pos > FPosition then
  10333.       Click(btNext)
  10334.     else if Message.Pos < FPosition then Click(btPrev);
  10335.  
  10336.     FPosition := Message.Pos;
  10337.   end;
  10338. end;
  10339.  
  10340. procedure TCustomUpDown.WMSize(var Message: TWMSize);
  10341. var
  10342.   R: TRect;
  10343. begin
  10344.   inherited;
  10345.   R := ClientRect;
  10346.   InvalidateRect(Handle, @R, False);
  10347. end;
  10348.  
  10349. procedure TCustomUpDown.WMHScroll(var Message: TWMHScroll);
  10350. begin
  10351.   inherited;
  10352.   if Message.ScrollCode = SB_THUMBPOSITION then
  10353.   begin
  10354.     if Message.Pos > FPosition then Click(btNext)
  10355.     else if Message.Pos < FPosition then Click(btPrev);
  10356.     FPosition := Message.Pos;
  10357.   end;
  10358. end;
  10359.  
  10360. function TCustomUpDown.DoCanChange(NewVal: SmallInt; Delta: SmallInt): Boolean;
  10361. begin
  10362.   FNewValue := NewVal;
  10363.   FNewValueDelta := Delta;
  10364.  
  10365.   Result := CanChange;
  10366. end;
  10367.  
  10368. function TCustomUpDown.CanChange: Boolean;
  10369. var
  10370.   Direction: TUpDownDirection;
  10371.   
  10372. begin
  10373.   Result := True;
  10374.   Direction := updNone;
  10375.  
  10376.   if (FNewValue < Min) and (FNewValueDelta < 0) or
  10377.   (FNewValue > Max) and (FNewValueDelta > 0) then
  10378.     Direction := updNone
  10379.   else if FNewValueDelta < 0 then
  10380.     Direction := updDown
  10381.   else if FNewValueDelta > 0 then
  10382.     Direction := updUp;
  10383.  
  10384.   if Assigned(FOnChanging) then
  10385.     FOnChanging(Self, Result);
  10386.   if Assigned(FOnChangingEx) then
  10387.     FOnChangingEx(Self, Result, FNewValue, Direction);
  10388. end;
  10389.  
  10390. procedure TCustomUpDown.CMAllChildrenFlipped(var Message: TMessage);
  10391. begin
  10392.   if FAlignButton = udRight then
  10393.     SetAlignButton(udLeft)
  10394.   else
  10395.     SetAlignButton(udRight);
  10396. end;
  10397.  
  10398. procedure TCustomUpDown.CNNotify(var Message: TWMNotify);
  10399. begin
  10400.   with Message do
  10401.     if NMHdr^.code = UDN_DELTAPOS then
  10402.     begin
  10403.       LongBool(Result) := not DoCanChange(PNMUpDown(NMHdr).iPos + PNMUpDown(NMHdr).iDelta,
  10404.                                           PNMUpDown(NMHdr).iDelta);
  10405.     end;
  10406. end;
  10407.  
  10408. procedure TCustomUpDown.Click(Button: TUDBtnType);
  10409. begin
  10410.   if Assigned(FOnClick) then FOnClick(Self, Button);
  10411. end;
  10412.  
  10413. procedure TCustomUpDown.SetAssociate(Value: TWinControl);
  10414. var
  10415.   I: Integer;
  10416.  
  10417.   function IsClass(ClassType: TClass; const Name: string): Boolean;
  10418.   begin
  10419.     Result := True;
  10420.     while ClassType <> nil do
  10421.     begin
  10422.       if ClassType.ClassNameIs(Name) then Exit;
  10423.       ClassType := ClassType.ClassParent;
  10424.     end;
  10425.     Result := False;
  10426.   end;
  10427.  
  10428. begin
  10429.   if Value <> nil then
  10430.     for I := 0 to Parent.ControlCount - 1 do // is control already associated
  10431.       if (Parent.Controls[I] is TCustomUpDown) and (Parent.Controls[I] <> Self) then
  10432.         if TCustomUpDown(Parent.Controls[I]).Associate = Value then
  10433.           raise Exception.CreateResFmt(@sUDAssociated,
  10434.             [Value.Name, Parent.Controls[I].Name]);
  10435.  
  10436.   if FAssociate <> nil then { undo the current associate control }
  10437.   begin
  10438.     if HandleAllocated then
  10439.       SendMessage(Handle, UDM_SETBUDDY, 0, 0);
  10440.     FAssociate := nil;
  10441.   end;
  10442.  
  10443.   if (Value <> nil) and (Value.Parent = Self.Parent) and
  10444.     not (Value is TCustomUpDown) and
  10445.     not (Value is TCustomTreeView) and not (Value is TCustomListView) and
  10446.     not IsClass(Value.ClassType, 'TDBEdit') and
  10447.     not IsClass(Value.ClassType, 'TDBMemo') then
  10448.   begin
  10449.     if HandleAllocated then
  10450.     begin
  10451.       UndoAutoResizing(Value);
  10452.       SendMessage(Handle, UDM_SETBUDDY, Value.Handle, 0);
  10453.     end;
  10454.     FAssociate := Value;
  10455.     if Value is TCustomEdit then
  10456.       TCustomEdit(Value).Text := IntToStr(FPosition);
  10457.   end;
  10458. end;
  10459.  
  10460. procedure TCustomUpDown.UndoAutoResizing(Value: TWinControl);
  10461. var
  10462.   OrigWidth, NewWidth, DeltaWidth: Integer;
  10463.   OrigLeft, NewLeft, DeltaLeft: Integer;
  10464. begin
  10465.   { undo Window's auto-resizing }
  10466.   OrigWidth := Value.Width;
  10467.   OrigLeft := Value.Left;
  10468.   SendMessage(Handle, UDM_SETBUDDY, Value.Handle, 0);
  10469.   NewWidth := Value.Width;
  10470.   NewLeft := Value.Left;
  10471.   DeltaWidth := OrigWidth - NewWidth;
  10472.   DeltaLeft := NewLeft - OrigLeft;
  10473.   Value.Width := OrigWidth + DeltaWidth;
  10474.   Value.Left := OrigLeft - DeltaLeft;
  10475. end;
  10476.  
  10477. procedure TCustomUpDown.Notification(AComponent: TComponent;
  10478.   Operation: TOperation);
  10479. begin
  10480.   inherited Notification(AComponent, Operation);
  10481.   if (Operation = opRemove) and (AComponent = FAssociate) then
  10482.     if HandleAllocated then
  10483.     begin
  10484.       SendMessage(Handle, UDM_SETBUDDY, 0, 0);
  10485.       FAssociate := nil;
  10486.     end;
  10487. end;
  10488.  
  10489. function TCustomUpDown.GetPosition: SmallInt;
  10490. begin
  10491.   if HandleAllocated then
  10492.   begin
  10493.     Result := LoWord(SendMessage(Handle, UDM_GETPOS, 0, 0));
  10494.     FPosition := Result;
  10495.   end
  10496.   else Result := FPosition;
  10497. end;
  10498.  
  10499. procedure TCustomUpDown.SetMin(Value: SmallInt);
  10500. begin
  10501.   if Value <> FMin then
  10502.   begin
  10503.     FMin := Value;
  10504.     if HandleAllocated then
  10505.       SendMessage(Handle, UDM_SETRANGE, 0, MakeLong(FMax, FMin));
  10506.   end;
  10507. end;
  10508.  
  10509. procedure TCustomUpDown.SetMax(Value: SmallInt);
  10510. begin
  10511.   if Value <> FMax then
  10512.   begin
  10513.     FMax := Value;
  10514.     if HandleAllocated then
  10515.       SendMessage(Handle, UDM_SETRANGE, 0, MakeLong(FMax, FMin));
  10516.   end;
  10517. end;
  10518.  
  10519. procedure TCustomUpDown.SetIncrement(Value: Integer);
  10520. var
  10521.   AccelArray: array [0..0] of TUDAccel;
  10522. begin
  10523.   if Value <> FIncrement then
  10524.   begin
  10525.     FIncrement := Value;
  10526.     if HandleAllocated then
  10527.     begin
  10528.       SendMessage(Handle, UDM_GETACCEL, 1, Longint(@AccelArray));
  10529.       AccelArray[0].nInc := Value;
  10530.       SendMessage(Handle, UDM_SETACCEL, 1, Longint(@AccelArray));
  10531.     end;
  10532.   end;
  10533. end;
  10534.  
  10535. procedure TCustomUpDown.SetPosition(Value: SmallInt);
  10536. begin
  10537.   if Value <> FPosition then
  10538.   begin
  10539.     if not (csDesigning in ComponentState) then
  10540.       if not DoCanChange(Value, Value-FPosition) then Exit;
  10541.     FPosition := Value;
  10542.     if (csDesigning in ComponentState) and (FAssociate <> nil) then
  10543.       if FAssociate is TCustomEdit then
  10544.         TCustomEdit(FAssociate).Text := IntToStr(FPosition);
  10545.     if HandleAllocated then
  10546.       SendMessage(Handle, UDM_SETPOS, 0, MakeLong(FPosition, 0));
  10547.   end;
  10548. end;
  10549.  
  10550. procedure TCustomUpDown.SetOrientation(Value: TUDOrientation);
  10551. begin
  10552.   if Value <> FOrientation then
  10553.   begin
  10554.     FOrientation := Value;
  10555.     if ComponentState * [csLoading, csUpdating] = [] then
  10556.       SetBounds(Left, Top, Height, Width);
  10557.     if HandleAllocated then
  10558.       SendMessage(Handle, UDM_SETBUDDY, 0, 0);
  10559.     RecreateWnd;
  10560.   end;
  10561. end;
  10562.  
  10563. procedure TCustomUpDown.SetAlignButton(Value: TUDAlignButton);
  10564. begin
  10565.   if Value <> FAlignButton then
  10566.   begin
  10567.     FAlignButton := Value;
  10568.     if HandleAllocated then
  10569.       SendMessage(Handle, UDM_SETBUDDY, 0, 0);
  10570.     RecreateWnd;
  10571.   end;
  10572. end;
  10573.  
  10574. procedure TCustomUpDown.SetArrowKeys(Value: Boolean);
  10575. begin
  10576.   if Value <> FArrowKeys then
  10577.   begin
  10578.     FArrowKeys := Value;
  10579.     if HandleAllocated then
  10580.       SendMessage(Handle, UDM_SETBUDDY, 0, 0);
  10581.     RecreateWnd;
  10582.   end;
  10583. end;
  10584.  
  10585. procedure TCustomUpDown.SetThousands(Value: Boolean);
  10586. begin
  10587.   if Value <> FThousands then
  10588.   begin
  10589.     FThousands := Value;
  10590.     if HandleAllocated then
  10591.       SendMessage(Handle, UDM_SETBUDDY, 0, 0);
  10592.     RecreateWnd;
  10593.   end;
  10594. end;
  10595.  
  10596. procedure TCustomUpDown.SetWrap(Value: Boolean);
  10597. begin
  10598.   if Value <> FWrap then
  10599.   begin
  10600.     FWrap := Value;
  10601.     if HandleAllocated then
  10602.       SendMessage(Handle, UDM_SETBUDDY, 0, 0);
  10603.     RecreateWnd;
  10604.   end;
  10605. end;
  10606.  
  10607. { THotKey }
  10608.  
  10609. constructor TCustomHotKey.Create(AOwner: TComponent);
  10610. begin
  10611.   inherited Create(AOwner);
  10612.   Width := 121;
  10613.   Height := 25;
  10614.   TabStop := True;
  10615.   ParentColor := False;
  10616.   FAutoSize := True;
  10617.   FInvalidKeys := [hcNone, hcShift];
  10618.   FModifiers := [hkAlt];
  10619.   FHotKey := $0041;     // default - 'Alt+A'
  10620.   AdjustHeight;
  10621. end;
  10622.  
  10623. procedure TCustomHotKey.CreateParams(var Params: TCreateParams);
  10624. begin
  10625.   InitCommonControl(ICC_HOTKEY_CLASS);
  10626.   inherited CreateParams(Params);
  10627.   CreateSubClass(Params, HOTKEYCLASS);
  10628.   with Params.WindowClass do
  10629.     style := style and not (CS_HREDRAW or CS_VREDRAW);
  10630. end;
  10631.  
  10632. procedure TCustomHotKey.CreateWnd;
  10633. begin
  10634.   inherited CreateWnd;
  10635.   SendMessage(Handle, HKM_SETRULES, Byte(FInvalidKeys), MakeLong(Byte(FModifiers), 0));
  10636.   SendMessage(Handle, HKM_SETHOTKEY, MakeWord(Byte(FHotKey), Byte(FModifiers)), 0);
  10637. end;
  10638.  
  10639. procedure TCustomHotKey.SetAutoSize(Value: Boolean);
  10640. begin
  10641.   if FAutoSize <> Value then
  10642.   begin
  10643.     FAutoSize := Value;
  10644.     UpdateHeight;
  10645.   end;
  10646. end;
  10647.  
  10648. procedure TCustomHotKey.SetModifiers(Value: THKModifiers);
  10649. begin
  10650.   if Value <> FModifiers then
  10651.   begin
  10652.     FModifiers := Value;
  10653.     SendMessage(Handle, HKM_SETRULES, Byte(FInvalidKeys), MakeLong(Byte(Value), 0));
  10654.     SendMessage(Handle, HKM_SETHOTKEY, MakeWord(Byte(FHotKey), Byte(FModifiers)), 0);
  10655.   end;
  10656. end;
  10657.  
  10658. procedure TCustomHotKey.SetInvalidKeys(Value: THKInvalidKeys);
  10659. begin
  10660.   if Value <> FInvalidKeys then
  10661.   begin
  10662.     FInvalidKeys := Value;
  10663.     SendMessage(Handle, HKM_SETRULES, Byte(Value), MakeLong(Byte(FModifiers), 0));
  10664.     SendMessage(Handle, HKM_SETHOTKEY, MakeWord(Byte(FHotKey), Byte(FModifiers)), 0);
  10665.   end;
  10666. end;
  10667.  
  10668. function TCustomHotKey.GetHotKey: TShortCut;
  10669. var
  10670.   HK: Longint;
  10671. begin
  10672.   HK := SendMessage(Handle, HKM_GETHOTKEY, 0, 0);
  10673.   Result := HotKeyToShortCut(HK);
  10674. end;
  10675.  
  10676. procedure TCustomHotKey.SetHotKey(Value: TShortCut);
  10677. begin
  10678.   ShortCutToHotKey(Value);
  10679.   SendMessage(Handle, HKM_SETHOTKEY, MakeWord(Byte(FHotKey), Byte(FModifiers)), 0);
  10680. end;
  10681.  
  10682. procedure TCustomHotKey.UpdateHeight;
  10683. begin
  10684.   if AutoSize then
  10685.   begin
  10686.     ControlStyle := ControlStyle + [csFixedHeight];
  10687.     AdjustHeight;
  10688.   end else
  10689.     ControlStyle := ControlStyle - [csFixedHeight];
  10690. end;
  10691.  
  10692. procedure TCustomHotKey.AdjustHeight;
  10693. var
  10694.   DC: HDC;
  10695.   SaveFont: HFont;
  10696.   I: Integer;
  10697.   SysMetrics, Metrics: TTextMetric;
  10698. begin
  10699.   DC := GetDC(0);
  10700.   GetTextMetrics(DC, SysMetrics);
  10701.   SaveFont := SelectObject(DC, Font.Handle);
  10702.   GetTextMetrics(DC, Metrics);
  10703.   SelectObject(DC, SaveFont);
  10704.   ReleaseDC(0, DC);
  10705.   if NewStyleControls then
  10706.   begin
  10707.     if Ctl3D then I := 8 else I := 6;
  10708.     I := GetSystemMetrics(SM_CYBORDER) * I;
  10709.   end else
  10710.   begin
  10711.     I := SysMetrics.tmHeight;
  10712.     if I > Metrics.tmHeight then I := Metrics.tmHeight;
  10713.     I := I div 4 + GetSystemMetrics(SM_CYBORDER) * 4;
  10714.   end;
  10715.   Height := Metrics.tmHeight + I;
  10716. end;
  10717.  
  10718. procedure TCustomHotKey.ShortCutToHotKey(Value: TShortCut);
  10719. begin
  10720.   FHotKey := Value and not (scShift + scCtrl + scAlt);
  10721.   FModifiers := [];
  10722.   if Value and scShift <> 0 then Include(FModifiers, hkShift);
  10723.   if Value and scCtrl <> 0 then Include(FModifiers, hkCtrl);
  10724.   if Value and scAlt <> 0 then Include(FModifiers, hkAlt);
  10725. end;
  10726.  
  10727. function TCustomHotKey.HotKeyToShortCut(Value: Longint): TShortCut;
  10728. begin
  10729.   Byte(FModifiers) := LoWord(HiByte(Value));
  10730.   FHotKey := LoWord(LoByte(Value));
  10731.   Result := FHotKey;
  10732.   if hkShift in FModifiers then Inc(Result, scShift);
  10733.   if hkCtrl in FModifiers then Inc(Result, scCtrl);
  10734.   if hkAlt in FModifiers then Inc(Result, scAlt);
  10735. end;
  10736.  
  10737. { TListColumn }
  10738.  
  10739. constructor TListColumn.Create(Collection: TCollection);
  10740. var
  10741.   Column: TLVColumn;
  10742. begin
  10743.   FOrderTag := Collection.Count;
  10744.   inherited Create(Collection);
  10745.   FWidth := 50;
  10746.   FAlignment := taLeftJustify;
  10747.   FImageIndex := -1;
  10748.   with Column do
  10749.   begin
  10750.     mask := LVCF_FMT or LVCF_WIDTH or LVCF_IMAGE;
  10751.     fmt := LVCFMT_LEFT;
  10752.     cx := FWidth;
  10753.     iImage := FImageIndex;
  10754.   end;
  10755.   if TListColumns(Collection).Owner.HandleAllocated then
  10756.     ListView_InsertColumn(TListColumns(Collection).Owner.Handle, Index, Column);
  10757. end;
  10758.  
  10759. destructor TListColumn.Destroy;
  10760. var
  10761.   Columns: TListColumns;
  10762. begin
  10763.   Columns := TListColumns(Collection);
  10764.   if TListColumns(Collection).Owner.HandleAllocated then
  10765.     ListView_DeleteColumn(TListColumns(Collection).Owner.Handle, Index);
  10766.   inherited Destroy;
  10767.   Columns.UpdateCols;
  10768. end;
  10769.  
  10770. procedure TListColumn.DefineProperties(Filer: TFiler);
  10771. begin
  10772.   inherited DefineProperties(Filer);
  10773.   Filer.DefineProperty('WidthType', ReadData, WriteData,
  10774.     WidthType <= ColumnTextWidth);
  10775. end;
  10776.  
  10777. procedure TListColumn.ReadData(Reader: TReader);
  10778. begin
  10779.   with Reader do
  10780.   begin
  10781.     ReadListBegin;
  10782.     Width := TWidth(ReadInteger);
  10783.     ReadListEnd;
  10784.   end;
  10785. end;
  10786.  
  10787. procedure TListColumn.WriteData(Writer: TWriter);
  10788. begin
  10789.   with Writer do
  10790.   begin
  10791.     WriteListBegin;
  10792.     WriteInteger(Ord(WidthType));
  10793.     WriteListEnd;
  10794.   end;
  10795. end;
  10796.  
  10797. procedure TListColumn.DoChange;
  10798.  
  10799.   procedure WriteCols;
  10800.   var
  10801.     Writer: TWriter;
  10802.     LV: TCustomListView;
  10803.   begin
  10804.     LV := TListColumns(Collection).Owner;
  10805.     if LV.HandleAllocated or ([csLoading, csReading] * LV.ComponentState <> []) or
  10806.       LV.FReading then Exit;
  10807.     if LV.FColStream = nil then LV.FColStream := TMemoryStream.Create
  10808.     else LV.FColStream.Size := 0;
  10809.     Writer := TWriter.Create(LV.FColStream, 1024);
  10810.     try
  10811.       Writer.WriteCollection(Collection);
  10812.     finally
  10813.       Writer.Free;
  10814.       LV.FColStream.Position := 0;
  10815.     end;
  10816.   end;
  10817.  
  10818. var
  10819.   I: Integer;
  10820. begin
  10821.   for I := 0 to Collection.Count - 1 do
  10822.     if TListColumn(Collection.Items[I]).WidthType <= ColumnTextWidth then Break;
  10823.   Changed(I <> Collection.Count);
  10824.   WriteCols;
  10825. end;
  10826.  
  10827. procedure TListColumn.SetIndex(Value: Integer);
  10828. var
  10829.   ColumnOrder: array of Integer;
  10830.   I: Integer;
  10831. begin
  10832.   inherited SetIndex(Value);
  10833.   SetLength(ColumnOrder, Collection.Count);
  10834.   for I := 0 to Collection.Count - 1 do
  10835.     ColumnOrder[I] := TListColumn(Collection.Items[I]).FOrderTag;
  10836.   ListView_SetColumnOrderArray(TListColumns(Collection).Owner.Handle,
  10837.     Collection.Count, PInteger(ColumnOrder));
  10838. end;
  10839.  
  10840. procedure TListColumn.SetCaption(const Value: string);
  10841. begin
  10842.   if FCaption <> Value then
  10843.   begin
  10844.     FCaption := Value;
  10845.     DoChange;
  10846.   end;
  10847. end;
  10848.  
  10849. function TListColumn.GetWidth: TWidth;
  10850. begin
  10851.   if FWidth = 0 then
  10852.     FWidth := ListView_GetColumnWidth(TListColumns(Collection).Owner.Handle, Index);
  10853.   Result := FWidth;
  10854. end;
  10855.  
  10856. function TListColumn.IsWidthStored: Boolean;
  10857. begin
  10858.   Result := not FAutoSize;
  10859. end;
  10860.  
  10861. procedure TListColumn.SetWidth(Value: TWidth);
  10862. begin
  10863.   if FWidth <> Value then
  10864.   begin
  10865.     if ((Value < MinWidth) and (Value >= 0)) then Value := MinWidth
  10866.     else if ((MaxWidth > 0) and (Value > MaxWidth)) then Value := MaxWidth;
  10867.     FWidth := Value;
  10868.     DoChange;
  10869.   end;
  10870. end;
  10871.  
  10872. procedure TListColumn.SetAlignment(Value: TAlignment);
  10873. begin
  10874.   if (Alignment <> Value) and (Index <> 0) then
  10875.   begin
  10876.     FAlignment := Value;
  10877.     Changed(False);
  10878.     TListColumns(Collection).Owner.Repaint;
  10879.   end;
  10880. end;
  10881.  
  10882. procedure TListColumn.SetAutoSize(Value: Boolean);
  10883. begin
  10884.   if FAutoSize <> Value then
  10885.   begin
  10886.     FAutoSize := Value;
  10887.     if TListColumns(Collection).Owner <> nil then
  10888.       TListColumns(Collection).Owner.AdjustSize;
  10889.     DoChange;
  10890.   end;
  10891. end;
  10892.  
  10893. procedure TListColumn.SetImageIndex(Value: TImageIndex);
  10894. begin
  10895.   if FImageIndex <> Value then
  10896.   begin
  10897.     FImageIndex := Value;
  10898.     DoChange;
  10899.   end;
  10900. end;
  10901.  
  10902. procedure TListColumn.SetMaxWidth(Value: TWidth);
  10903. begin
  10904.   if FMaxWidth <> Value then
  10905.   begin
  10906.     FMaxWidth := Value;
  10907.     Changed(False);
  10908.   end;
  10909. end;
  10910.  
  10911. procedure TListColumn.SetMinWidth(Value: TWidth);
  10912. begin
  10913.   if FMinWidth <> Value then
  10914.   begin
  10915.     FMinWidth := Value;
  10916.     Changed(False);
  10917.   end;
  10918. end;
  10919.  
  10920. procedure TListColumn.Assign(Source: TPersistent);
  10921. var
  10922.   Column: TListColumn;
  10923. begin
  10924.   if Source is TListColumn then
  10925.   begin
  10926.     Column := TListColumn(Source);
  10927.     Alignment := Column.Alignment;
  10928.     AutoSize := Column.AutoSize;
  10929.     Caption := Column.Caption;
  10930.     ImageIndex := Column.ImageIndex;
  10931.     MaxWidth := Column.MaxWidth;
  10932.     MinWidth := Column.MinWidth;
  10933.     Width := Column.Width;
  10934.   end
  10935.   else inherited Assign(Source);
  10936. end;
  10937.  
  10938. function TListColumn.GetDisplayName: string;
  10939. begin
  10940.   Result := Caption;
  10941.   if Result = '' then Result := inherited GetDisplayName;
  10942. end;
  10943.  
  10944. { TListColumns }
  10945.  
  10946. constructor TListColumns.Create(AOwner: TCustomListView);
  10947. begin
  10948.   inherited Create(TListColumn);
  10949.   FOwner := AOwner;
  10950. end;
  10951.  
  10952. function TListColumns.GetItem(Index: Integer): TListColumn;
  10953. begin
  10954.   Result := TListColumn(inherited GetItem(Index));
  10955. end;
  10956.  
  10957. procedure TListColumns.SetItem(Index: Integer; Value: TListColumn);
  10958. begin
  10959.   inherited SetItem(Index, Value);
  10960. end;
  10961.  
  10962. function TListColumns.Add: TListColumn;
  10963. begin
  10964.   Result := TListColumn(inherited Add);
  10965.   UpdateCols;
  10966. end;
  10967.  
  10968. function TListColumns.GetOwner: TPersistent;
  10969. begin
  10970.   Result := FOwner;
  10971. end;
  10972.  
  10973. procedure TListColumns.Update(Item: TCollectionItem);
  10974. begin
  10975.   if Item <> nil then
  10976.     Owner.UpdateColumn(Item.Index) else
  10977.     Owner.UpdateColumns;
  10978. end;
  10979.  
  10980. procedure TListColumns.UpdateCols;
  10981. var
  10982.   I: Integer;
  10983.   LVColumn: TLVColumn;
  10984. begin
  10985.   if not Owner.HandleAllocated then Exit;
  10986.   BeginUpdate;
  10987.   try
  10988.     for I := Count - 1 downto 0 do
  10989.       ListView_DeleteColumn(Owner.Handle, I);
  10990.  
  10991.     for I := 0 to Count - 1 do
  10992.     begin
  10993.       with LVColumn do
  10994.       begin
  10995.         mask := LVCF_FMT or LVCF_WIDTH;
  10996.         fmt := LVCFMT_LEFT;
  10997.         cx := Items[I].FWidth;
  10998.       end;
  10999.       ListView_InsertColumn(Owner.Handle, I, LVColumn);
  11000.       Items[I].FOrderTag := I;
  11001.     end;
  11002.     Owner.UpdateColumns;
  11003.   finally
  11004.     EndUpdate;
  11005.   end;
  11006. end;
  11007.  
  11008. { TWorkArea }
  11009.  
  11010. constructor TWorkArea.Create(Collection: TCollection);
  11011. begin
  11012.   inherited Create(Collection);
  11013.   FColor := clWindowText;
  11014.   FDisplayName := '';
  11015. end;
  11016.  
  11017. function TWorkArea.GetDisplayName: string;
  11018. begin
  11019.   Result := FDisplayName;
  11020. end;
  11021.  
  11022. procedure TWorkArea.SetColor(const Value: TColor);
  11023. begin
  11024.   FColor := Value;
  11025.   Changed(True);
  11026. end;
  11027.  
  11028. procedure TWorkArea.SetDisplayName(const Value: string);
  11029. begin
  11030.   FDisplayName := Value;
  11031.   Changed(True);
  11032. end;
  11033.  
  11034. procedure TWorkArea.SetRect(const Value: TRect);
  11035. begin
  11036.   FRect := Value;
  11037.   Changed(True);
  11038. end;
  11039.  
  11040. { TWorkAreas }
  11041.  
  11042. procedure TWorkAreas.Update(Item: TCollectionItem);
  11043. var
  11044.   I: Integer;
  11045.   Rects: array of TRect;
  11046.   ListView: TCustomListView;
  11047. begin
  11048.   ListView := TCustomListView(GetOwner);
  11049.   SetLength(Rects, Count);
  11050.   for I := 0 to Count-1 do
  11051.     Rects[I] := Items[I].Rect;
  11052.   ListView_SetWorkAreas(ListView.Handle, Count, Pointer(Rects));
  11053.   ListView.Invalidate;
  11054. end;
  11055.  
  11056. procedure TWorkAreas.Changed;
  11057. begin
  11058.   Update(nil);
  11059. end;
  11060.  
  11061. function TWorkAreas.Add: TWorkArea;
  11062. begin
  11063.   Result := TWorkArea(inherited Add);
  11064. end;
  11065.  
  11066. function TWorkAreas.GetItem(Index: Integer): TWorkArea;
  11067. begin
  11068.   Result := TWorkArea(inherited GetItem(Index));
  11069. end;
  11070.  
  11071. procedure TWorkAreas.SetItem(Index: Integer; const Value: TWorkArea);
  11072. begin
  11073.   inherited SetItem(Index, Value);
  11074.   Update(nil);
  11075. end;
  11076.  
  11077. procedure TWorkAreas.Delete(Index: Integer);
  11078. begin
  11079.   Items[Index].Free;
  11080.   Changed;
  11081. end;
  11082.  
  11083. function TWorkAreas.Insert(Index: Integer): TWorkArea;
  11084. begin
  11085.   Result := TWorkArea(inherited Insert(Index));
  11086. end;
  11087.  
  11088. { TSubItems }
  11089.  
  11090. type
  11091.   TSubItems = class(TStringList)
  11092.   private
  11093.     FOwner: TListItem;
  11094.     FImageIndices: TList;
  11095.     procedure SetColumnWidth(Index: Integer);
  11096.     procedure RefreshItem(Index: Integer);
  11097.     function GetImageIndex(Index: Integer): TImageIndex;
  11098.     procedure SetImageIndex(Index: Integer; const Value: TImageIndex);
  11099.   protected
  11100.     function GetHandle: HWND;
  11101.     function Add(const S: string): Integer; override;
  11102.     procedure Delete(Index: Integer); override;
  11103.     procedure Put(Index: Integer; const S: string); override;
  11104.     procedure SetUpdateState(Updating: Boolean); override;
  11105.   public
  11106.     constructor Create(AOwner: TListItem);
  11107.     destructor Destroy; override;
  11108.     procedure Insert(Index: Integer; const S: string); override;
  11109.     property Handle: HWND read GetHandle;
  11110.     property Owner: TListItem read FOwner;
  11111.     property ImageIndex[Index: Integer]: TImageIndex read GetImageIndex write SetImageIndex;
  11112.   end;
  11113.  
  11114. constructor TSubItems.Create(AOwner: TListItem);
  11115. begin
  11116.   inherited Create;
  11117.   FOwner := AOwner;
  11118.   FImageIndices := TList.Create;
  11119. end;
  11120.  
  11121. destructor TSubItems.Destroy;
  11122. begin
  11123.   FImageIndices.Free;
  11124.   inherited;
  11125. end;
  11126.  
  11127. function TSubItems.Add(const S: string): Integer;
  11128. begin
  11129.   Result := inherited Add(S);
  11130.   FImageIndices.Add(Pointer(-1));
  11131.   RefreshItem(Result + 1);
  11132. end;
  11133.  
  11134. procedure TSubItems.Delete(Index: Integer);
  11135. begin
  11136.   inherited;
  11137.   FImageIndices.Delete(Index);
  11138.   Owner.Update;
  11139. end;
  11140.  
  11141. function TSubItems.GetHandle: HWND;
  11142. begin
  11143.   Result := Owner.Owner.Handle;
  11144. end;
  11145.  
  11146. procedure TSubItems.SetColumnWidth(Index: Integer);
  11147. var
  11148.   ListView: TCustomListView;
  11149. begin
  11150.   ListView := Owner.ListView;
  11151.   if ListView.ColumnsShowing and
  11152.     (ListView.Columns.Count > Index) and
  11153.     (ListView.Column[Index].WidthType = ColumnTextWidth) then
  11154.     ListView.UpdateColumn(Index);
  11155. end;
  11156.  
  11157. procedure TSubItems.Insert(Index: Integer; const S: string);
  11158. var
  11159.   i: Integer;
  11160. begin
  11161.   inherited Insert(Index, S);
  11162.   FImageIndices.Insert(Index, Pointer(-1));
  11163.   for i := Index + 1 to Count do RefreshItem(i);
  11164. end;
  11165.  
  11166. procedure TSubItems.Put(Index: Integer; const S: string);
  11167. begin
  11168.   inherited Put(Index, S);
  11169.   RefreshItem(Index + 1);
  11170. end;
  11171.  
  11172. procedure TSubItems.RefreshItem(Index: Integer);
  11173. begin
  11174.   ListView_SetItemText(Handle, Owner.Index, Index, LPSTR_TEXTCALLBACK);
  11175.   SetColumnWidth(Index);
  11176. end;
  11177.  
  11178. procedure TSubItems.SetUpdateState(Updating: Boolean);
  11179. begin
  11180.   Owner.Owner.SetUpdateState(Updating);
  11181. end;
  11182.  
  11183. function TSubItems.GetImageIndex(Index: Integer): TImageIndex;
  11184. begin
  11185.   Result := TImageIndex(FImageIndices[Index]);
  11186. end;
  11187.  
  11188. procedure TSubItems.SetImageIndex(Index: Integer; const Value: TImageIndex);
  11189. begin
  11190.   FImageIndices[Index] := Pointer(Value);
  11191. end;
  11192.  
  11193. { TListItem }
  11194.  
  11195. constructor TListItem.Create(AOwner: TListItems);
  11196. begin
  11197.   FOwner := AOwner;
  11198.   FSubItems := TSubItems.Create(Self);
  11199.   FOverlayIndex := -1;
  11200.   FStateIndex := -1;
  11201. end;
  11202.  
  11203. destructor TListItem.Destroy;
  11204. begin
  11205.   FDeleting := True;
  11206.   if Owner.Owner.FLastDropTarget = Self then
  11207.     Owner.Owner.FLastDropTarget := nil;
  11208.   if ListView.HandleAllocated then ListView_DeleteItem(Handle, Index);
  11209.   FSubItems.Free;
  11210.   inherited Destroy;
  11211. end;
  11212.  
  11213. function TListItem.GetListView: TCustomListView;
  11214. begin
  11215.   Result := Owner.Owner;
  11216. end;
  11217.  
  11218. procedure TListItem.Delete;
  11219. begin
  11220.   if not FDeleting and (Self <> ListView.FTempItem) then Free;
  11221. end;
  11222.  
  11223. function TListItem.GetHandle: HWND;
  11224. begin
  11225.   Result := ListView.Handle;
  11226. end;
  11227.  
  11228. procedure TListItem.MakeVisible(PartialOK: Boolean);
  11229. begin
  11230.   ListView_EnsureVisible(Handle, Index, PartialOK);
  11231. end;
  11232.  
  11233. function TListItem.GetChecked: Boolean;
  11234. begin
  11235.   with Owner.Owner do
  11236.     if not OwnerData and HandleAllocated then
  11237.       Result := (ListView_GetCheckState(Handle, Index) <> 0)
  11238.     else
  11239.       Result := FChecked;
  11240. end;
  11241.  
  11242. procedure TListItem.SetChecked(Value: Boolean);
  11243. var
  11244.   LV: TCustomListView;
  11245. begin
  11246.   FChecked := Value;
  11247.   LV := Owner.Owner;
  11248.   if not LV.OwnerData and LV.HandleAllocated then
  11249.     ListView_SetCheckState(LV.Handle, Index, Value);
  11250. end;
  11251.  
  11252. function TListItem.GetLeft: Integer;
  11253. begin
  11254.   Result := GetPosition.X;
  11255. end;
  11256.  
  11257. procedure TListItem.SetLeft(Value: Integer);
  11258. begin
  11259.   SetPosition(Point(Value, Top));
  11260. end;
  11261.  
  11262. function TListItem.GetTop: Integer;
  11263. begin
  11264.   Result := GetPosition.Y;
  11265. end;
  11266.  
  11267. procedure TListItem.SetTop(Value: Integer);
  11268. begin
  11269.   SetPosition(Point(Left, Value));
  11270. end;
  11271.  
  11272. procedure TListItem.Update;
  11273. begin
  11274.   ListView_Update(Handle, Index);
  11275. end;
  11276.  
  11277. procedure TListItem.SetCaption(const Value: string);
  11278. begin
  11279.   FCaption := Value;
  11280.   if not Owner.Owner.OwnerData then
  11281.     ListView_SetItemText(Handle, Index, 0, LPSTR_TEXTCALLBACK);
  11282.   if ListView.ColumnsShowing and
  11283.     (ListView.Columns.Count > 0) and
  11284.     (ListView.Column[0].WidthType <= ColumnTextWidth) then
  11285.     ListView.UpdateColumns;
  11286.   if ListView.SortType in [stBoth, stText] then ListView.AlphaSort;
  11287. end;
  11288.  
  11289. procedure TListItem.SetData(Value: Pointer);
  11290. begin
  11291.   FData := Value;
  11292.   if ListView.SortType in [stBoth, stData] then ListView.AlphaSort;
  11293. end;
  11294.  
  11295. function TListItem.EditCaption: Boolean;
  11296. begin
  11297.   ListView.SetFocus;
  11298.   Result := ListView_EditLabel(Handle, Index) <> 0;
  11299. end;
  11300.  
  11301. procedure TListItem.CancelEdit;
  11302. begin
  11303.   ListView_EditLabel(Handle, -1);
  11304. end;
  11305.  
  11306. function TListItem.GetState(Index: Integer): Boolean;
  11307. var
  11308.   Mask: Integer;
  11309. begin
  11310.   case Index of
  11311.     0: Mask := LVIS_CUT;
  11312.     1: Mask := LVIS_DROPHILITED;
  11313.     2: Mask := LVIS_FOCUSED;
  11314.     3: Mask := LVIS_SELECTED;
  11315.     4: Mask := LVIS_ACTIVATING;
  11316.   else
  11317.     Mask := 0;
  11318.   end;
  11319.   Result := ListView_GetItemState(Handle, Self.Index, Mask) and Mask <> 0;
  11320. end;
  11321.  
  11322. procedure TListItem.SetState(Index: Integer; State: Boolean);
  11323. var
  11324.   Mask: Integer;
  11325.   Data: Integer;
  11326. begin
  11327.   case Index of
  11328.     0: Mask := LVIS_CUT;
  11329.     1: Mask := LVIS_DROPHILITED;
  11330.     2: Mask := LVIS_FOCUSED;
  11331.     3: Mask := LVIS_SELECTED;
  11332.     4: Mask := LVIS_ACTIVATING;
  11333.   else
  11334.     Mask := 0;
  11335.   end;
  11336.   if State then Data := Mask
  11337.   else Data := 0;
  11338.   ListView_SetItemState(Handle, Self.Index, Data, Mask);
  11339. end;
  11340.  
  11341. procedure TListItem.SetImage(Index: Integer; Value: TImageIndex);
  11342. var
  11343.   Item: TLVItem;
  11344. begin
  11345.   case Index of
  11346.     0:  if Value <> FImageIndex then
  11347.         begin
  11348.           FImageIndex := Value;
  11349.           if not Owner.Owner.OwnerData then
  11350.           begin
  11351.             with Item do
  11352.             begin
  11353.               mask := LVIF_IMAGE;
  11354.               iImage := I_IMAGECALLBACK;
  11355.               iItem := Self.Index;
  11356.               iSubItem := 0;
  11357.             end;
  11358.             ListView_SetItem(Handle, Item);
  11359.           end;
  11360.         end;
  11361.     1:  if Value <> FOverlayIndex then
  11362.         begin
  11363.           FOverlayIndex := Value;
  11364.           if not Owner.Owner.OwnerData then
  11365.             ListView_SetItemState(Handle, Self.Index,
  11366.               IndexToOverlayMask(OverlayIndex + 1), LVIS_OVERLAYMASK);
  11367.         end;
  11368.     2:  if Value <> FStateIndex then
  11369.         begin
  11370.           FStateIndex := Value;
  11371.           if Owner.Owner.CheckBoxes and (Value = -1) then
  11372.             Value := 0;
  11373.           if not Owner.Owner.OwnerData then
  11374.             ListView_SetItemState(Handle, Self.Index,
  11375.               IndexToStateImageMask(Value + 1), LVIS_STATEIMAGEMASK);
  11376.         end;
  11377.   end;
  11378.   if not Owner.Owner.OwnerData then
  11379.     ListView.UpdateItems(Self.Index, Self.Index);
  11380. end;
  11381.  
  11382. procedure TListItem.SetIndent(Value: Integer);
  11383. var
  11384.   Item: TLVItem;
  11385. begin
  11386.   if FIndent <> Value then
  11387.   begin
  11388.     FIndent := Value;
  11389.     if not Owner.Owner.OwnerData then
  11390.     begin
  11391.       with Item do
  11392.       begin
  11393.         mask := LVIF_INDENT;
  11394.         iIndent := Value;
  11395.         iItem := Self.Index;
  11396.         iSubItem := 0;
  11397.       end;
  11398.       ListView_SetItem(Handle, Item);
  11399.       ListView.UpdateItems(Self.Index, Self.Index);
  11400.     end;
  11401.   end;
  11402. end;
  11403.  
  11404. procedure TListItem.Assign(Source: TPersistent);
  11405. begin
  11406.   if Source is TListItem then
  11407.     with Source as TListItem do
  11408.     begin
  11409.       Self.Caption := Caption;
  11410.       Self.Data := Data;
  11411.       Self.ImageIndex := ImageIndex;
  11412.       Self.Indent := Indent;
  11413.       Self.OverlayIndex := OverlayIndex;
  11414.       Self.StateIndex := StateIndex;
  11415.       Self.SubItems := SubItems;
  11416.       Self.Checked := Checked;
  11417.     end
  11418.   else inherited Assign(Source);
  11419. end;
  11420.  
  11421. function TListItem.IsEqual(Item: TListItem): Boolean;
  11422. begin
  11423.   Result := (Caption = Item.Caption) and (Data = Item.Data);
  11424. end;
  11425.  
  11426. procedure TListItem.SetSubItems(Value: TStrings);
  11427. begin
  11428.   if Value <> nil then FSubItems.Assign(Value);
  11429. end;
  11430.  
  11431. function TListItem.GetIndex: Integer;
  11432. begin
  11433.   if Owner.Owner.OwnerData then
  11434.     Result := FIndex else
  11435.     Result := Owner.IndexOf(Self);
  11436. end;
  11437.  
  11438. function TListItem.GetPosition: TPoint;
  11439. begin
  11440.   ListView_GetItemPosition(Handle, Index, Result);
  11441. end;
  11442.  
  11443. procedure TListItem.SetPosition(const Value: TPoint);
  11444. begin
  11445.   if ListView.ViewStyle in [vsSmallIcon, vsIcon] then
  11446.     ListView_SetItemPosition32(Handle, Index, Value.X, Value.Y);
  11447. end;
  11448.  
  11449. function TListItem.DisplayRect(Code: TDisplayCode): TRect;
  11450. const
  11451.   Codes: array[TDisplayCode] of Longint = (LVIR_BOUNDS, LVIR_ICON, LVIR_LABEL,
  11452.     LVIR_SELECTBOUNDS);
  11453. begin
  11454.   ListView_GetItemRect(Handle, Index, Result, Codes[Code]);
  11455. end;
  11456.  
  11457. function TListItem.GetSubItemImage(Index: Integer): Integer;
  11458. begin
  11459.   Result := TSubItems(FSubItems).ImageIndex[Index];
  11460. end;
  11461.  
  11462. procedure TListItem.SetSubItemImage(Index: Integer; const Value: Integer);
  11463. var
  11464.   item: TLVItem;
  11465. begin
  11466.   {Storage of sub-item image indices cannot be provided by the control because
  11467.    all display-related content requires a callback}
  11468.   TSubItems(FSubItems).ImageIndex[Index] := Value;
  11469.   if not Owner.Owner.OwnerData then
  11470.   begin
  11471.     with item do
  11472.     begin
  11473.       mask := LVIF_IMAGE;
  11474.       iImage := I_IMAGECALLBACK;
  11475.       iItem := Self.Index;
  11476.       iSubItem := Index+1;
  11477.     end;
  11478.     ListView_SetItem(Handle, item);
  11479.   end;
  11480. end;
  11481.  
  11482. function TListItem.WorkArea: Integer;
  11483. begin
  11484.   with Owner.Owner.WorkAreas do
  11485.   begin
  11486.     Result := Count-1;
  11487.     while (Result >= 0) and not PtInRect(Items[Result].Rect, GetPosition) do
  11488.       Dec(Result);
  11489.   end;
  11490. end;
  11491.  
  11492. { TListItems }
  11493.  
  11494. type
  11495.   PItemHeader = ^TItemHeader;
  11496.   TItemHeader = packed record
  11497.     Size, Count: Integer;
  11498.     Items: record end;
  11499.   end;
  11500.   PItemInfo = ^TItemInfo;
  11501.   TItemInfo = packed record
  11502.     ImageIndex: Integer;
  11503.     StateIndex: Integer;
  11504.     OverlayIndex: Integer;
  11505.     SubItemCount: Integer;
  11506.     Data: Pointer;
  11507.     Caption: string[255];
  11508.   end;
  11509.   ShortStr = string[255];
  11510.   PShortStr = ^ShortStr;
  11511.  
  11512. constructor TListItems.Create(AOwner: TCustomListView);
  11513. begin
  11514.   inherited Create;
  11515.   FOwner := AOwner;
  11516. end;
  11517.  
  11518. destructor TListItems.Destroy;
  11519. begin
  11520.   Clear;
  11521.   inherited Destroy;
  11522. end;
  11523.  
  11524. function TListItems.Add: TListItem;
  11525. begin
  11526.   Result := Owner.CreateListItem;
  11527.   ListView_InsertItem(Handle, CreateItem(Count, Result));
  11528. end;
  11529.  
  11530. function TListItems.Insert(Index: Integer): TListItem;
  11531. begin
  11532.   Result := Owner.CreateListItem;
  11533.   ListView_InsertItem(Handle, CreateItem(Index, Result));
  11534. end;
  11535.  
  11536. function TListItems.GetCount: Integer;
  11537. begin
  11538.   if Owner.HandleAllocated then Result := ListView_GetItemCount(Handle)
  11539.   else Result := 0;
  11540. end;
  11541.  
  11542. function TListItems.GetHandle: HWND;
  11543. begin
  11544.   Result := Owner.Handle;
  11545. end;
  11546.  
  11547. function TListItems.GetItem(Index: Integer): TListItem;
  11548. var
  11549.   Item: TLVItem;
  11550. begin
  11551.   Result := nil;
  11552.   if Owner.HandleAllocated then
  11553.   begin
  11554.     if Owner.OwnerData then
  11555.     begin
  11556.       FillChar(Item, SizeOf(Item), 0);
  11557.       with Item do
  11558.       begin
  11559.         mask := 0;
  11560.         iItem := Index;
  11561.         iSubItem := 0;
  11562.       end;
  11563.       Result := Owner.GetItem(Item);
  11564.     end
  11565.     else
  11566.     begin
  11567.       with Item do
  11568.       begin
  11569.         mask := LVIF_PARAM;
  11570.         iItem := Index;
  11571.         iSubItem := 0;
  11572.       end;
  11573.       if ListView_GetItem(Handle, Item) then Result := TListItem(Item.lParam);
  11574.     end;
  11575.   end;
  11576. end;
  11577.  
  11578. function TListItems.IndexOf(Value: TListItem): Integer;
  11579. var
  11580.   Info: TLVFindInfo;
  11581. begin
  11582.   with Info do
  11583.   begin
  11584.     flags := LVFI_PARAM;
  11585.     lParam := Integer(Value);
  11586.   end;
  11587.   Result := ListView_FindItem(Handle, -1, Info);
  11588. end;
  11589.  
  11590. procedure TListItems.SetCount(Value: Integer);
  11591. begin
  11592.   ListView_SetItemCountEx(Handle, Value, LVSICF_NOINVALIDATEALL);
  11593. end;
  11594.  
  11595. procedure TListItems.SetItem(Index: Integer; Value: TListItem);
  11596. begin
  11597.   Item[Index].Assign(Value);
  11598. end;
  11599.  
  11600. procedure TListItems.Clear;
  11601. begin
  11602.   if Owner.HandleAllocated then ListView_DeleteAllItems(Handle);
  11603. end;
  11604.  
  11605. procedure TListItems.BeginUpdate;
  11606. begin
  11607.   if FUpdateCount = 0 then SetUpdateState(True);
  11608.   Inc(FUpdateCount);
  11609. end;
  11610.  
  11611. procedure TListItems.SetUpdateState(Updating: Boolean);
  11612. var
  11613.   i: Integer;
  11614. begin
  11615.   if Updating then
  11616.   begin
  11617.     with Owner do
  11618.     begin
  11619.       FSavedSort := SortType;
  11620.       SortType := stNone;
  11621.     end;
  11622.     for i := 0 to Owner.Columns.Count - 1 do
  11623.     begin
  11624.       with Owner.Columns[i] as TListColumn do
  11625.         if WidthType < 0 then
  11626.         begin
  11627.           FPrivateWidth := WidthType;
  11628.           FWidth := Width;
  11629.           DoChange;
  11630.         end;
  11631.     end;
  11632.     SendMessage(Handle, WM_SETREDRAW, 0, 0);
  11633.     if Owner.ColumnsShowing and Owner.ValidHeaderHandle then
  11634.       SendMessage(Owner.FHeaderHandle, WM_SETREDRAW, 0, 0);
  11635.   end
  11636.   else if FUpdateCount = 0 then
  11637.   begin
  11638.     Owner.SortType := Owner.FSavedSort;
  11639.     for i := 0 to Owner.Columns.Count - 1 do
  11640.     begin
  11641.       with Owner.Columns[i] as TListColumn do
  11642.         if FPrivateWidth < 0 then
  11643.         begin
  11644.           Width := FPrivateWidth;
  11645.           FPrivateWidth := 0;
  11646.         end;
  11647.     end;
  11648.     FNoRedraw := True;
  11649.     try
  11650.       SendMessage(Handle, WM_SETREDRAW, 1, 0);
  11651.       Owner.Invalidate;
  11652.     finally
  11653.       FNoRedraw := False;
  11654.     end;
  11655.     if Owner.ColumnsShowing and Owner.ValidHeaderHandle then
  11656.       SendMessage(Owner.FHeaderHandle, WM_SETREDRAW, 1, 0);
  11657.   end;
  11658. end;
  11659.  
  11660. procedure TListItems.EndUpdate;
  11661. begin
  11662.   Dec(FUpdateCount);
  11663.   if FUpdateCount = 0 then SetUpdateState(False);
  11664. end;
  11665.  
  11666. procedure TListItems.Assign(Source: TPersistent);
  11667. var
  11668.   Items: TListItems;
  11669.   I: Integer;
  11670. begin
  11671.   if Source is TListItems then
  11672.   begin
  11673.     Clear;
  11674.     Items := TListItems(Source);
  11675.     for I := 0 to Items.Count - 1 do Add.Assign(Items[I]);
  11676.   end
  11677.   else inherited Assign(Source);
  11678. end;
  11679.  
  11680. procedure TListItems.DefineProperties(Filer: TFiler);
  11681.  
  11682.   function WriteItems: Boolean;
  11683.   var
  11684.     I: Integer;
  11685.     Items: TListItems;
  11686.   begin
  11687.     Items := TListItems(Filer.Ancestor);
  11688.     if (Items = nil) then
  11689.       Result := Count > 0
  11690.     else if (Items.Count <> Count) then
  11691.       Result := True
  11692.     else
  11693.     begin
  11694.       Result := False;
  11695.       for I := 0 to Count - 1 do
  11696.       begin
  11697.         Result := not Item[I].IsEqual(Items[I]);
  11698.         if Result then Break;
  11699.       end
  11700.     end;
  11701.   end;
  11702.  
  11703. begin
  11704.   inherited DefineProperties(Filer);
  11705.   Filer.DefineBinaryProperty('Data', ReadData, WriteData, WriteItems);
  11706. end;
  11707.  
  11708. const SubItemImageTag: SmallInt = $7FFF;
  11709.  
  11710. procedure TListItems.ReadData(Stream: TStream);
  11711. var
  11712.   I, J, Size, L, Len: Integer;
  11713.   ItemHeader: PItemHeader;
  11714.   ItemInfo: PItemInfo;
  11715.   PStr: PShortStr;
  11716.   PInt: PSmallInt;
  11717. begin
  11718.   Clear;
  11719.   Stream.ReadBuffer(Size, SizeOf(Integer));
  11720.   ItemHeader := AllocMem(Size);
  11721.   try
  11722.     Stream.ReadBuffer(ItemHeader^.Count, Size - SizeOf(Integer));
  11723.     ItemInfo := @ItemHeader^.Items;
  11724.     PStr := nil;
  11725.     for I := 0 to ItemHeader^.Count - 1 do
  11726.     begin
  11727.       with Add do
  11728.       begin
  11729.         Caption := ItemInfo^.Caption;
  11730.         ImageIndex := ItemInfo^.ImageIndex;
  11731.         OverlayIndex := ItemInfo^.OverlayIndex;
  11732.         StateIndex := ItemInfo^.StateIndex;
  11733.         Data := ItemInfo^.Data;
  11734.         PStr := @ItemInfo^.Caption;
  11735.         Inc(Integer(PStr), Length(PStr^) + 1);
  11736.         Len := 0;
  11737.         for J := 0 to ItemInfo^.SubItemCount - 1 do
  11738.         begin
  11739.           SubItems.Add(PStr^);
  11740.           L := Length(PStr^);
  11741.           Inc(Len, L + 1);
  11742.           Inc(Integer(PStr), L + 1);
  11743.         end;
  11744.       end;
  11745.       Inc(Integer(ItemInfo), SizeOf(TItemInfo) - 255 +
  11746.         Length(ItemInfo.Caption) + Len);
  11747.     end;
  11748.     //read subitem images, if present.
  11749.     if PChar(PStr) - PChar(ItemHeader) < Size then
  11750.     begin
  11751.       PInt := Pointer(PStr);
  11752.       for I := 0 to Count - 1 do
  11753.         with Item[I] do
  11754.           for J := 0 to SubItems.Count - 1 do
  11755.           begin
  11756.             SubItemImages[J] := PInt^;
  11757.             Inc(PInt);
  11758.           end;
  11759.     end;
  11760.   finally
  11761.     FreeMem(ItemHeader, Size);
  11762.   end;
  11763. end;
  11764.  
  11765. procedure TListItems.WriteData(Stream: TStream);
  11766. var
  11767.   I, J, Size, L, Len: Integer;
  11768.   ItemHeader: PItemHeader;
  11769.   ItemInfo: PItemInfo;
  11770.   PStr: PShortStr;
  11771.   PInt: PSmallInt;
  11772.  
  11773.   function GetLength(const S: string): Integer;
  11774.   begin
  11775.     Result := Length(S);
  11776.     if Result > 255 then Result := 255;
  11777.   end;
  11778.  
  11779. begin
  11780.   Size := SizeOf(TItemHeader);
  11781.   for I := 0 to Count - 1 do
  11782.   begin
  11783.     L := GetLength(Item[I].Caption);
  11784.     for J := 0 to Item[I].SubItems.Count - 1 do
  11785.     begin
  11786.       Inc(L, GetLength(Item[I].SubItems[J]) + 1);
  11787.       Inc(L, SizeOf(SmallInt)); //subitem images.
  11788.     end;
  11789.     Inc(Size, SizeOf(TItemInfo) - 255 + L); 
  11790.   end;
  11791.   ItemHeader := AllocMem(Size);
  11792.   try
  11793.     ItemHeader^.Size := Size;
  11794.     ItemHeader^.Count := Count;
  11795.     ItemInfo := @ItemHeader^.Items;
  11796.     PStr := nil;
  11797.     for I := 0 to Count - 1 do
  11798.     begin
  11799.       with Item[I] do
  11800.       begin
  11801.         ItemInfo^.Caption := Caption;
  11802.         ItemInfo^.ImageIndex := ImageIndex;
  11803.         ItemInfo^.OverlayIndex := OverlayIndex;
  11804.         ItemInfo^.StateIndex := StateIndex;
  11805.         ItemInfo^.Data := Data;
  11806.         ItemInfo^.SubItemCount := SubItems.Count;
  11807.         PStr := @ItemInfo^.Caption;
  11808.         Inc(Integer(PStr), Length(ItemInfo^.Caption) + 1);
  11809.         Len := 0;
  11810.         for J := 0 to SubItems.Count - 1 do
  11811.         begin
  11812.           PStr^ := SubItems[J];
  11813.           L := Length(PStr^);
  11814.           Inc(Len, L + 1);
  11815.           Inc(Integer(PStr), L + 1);
  11816.         end;
  11817.       end;
  11818.       Inc(Integer(ItemInfo), SizeOf(TItemInfo) - 255 +
  11819.         Length(ItemInfo^.Caption) + Len);
  11820.     end;
  11821.     //write SubItem images.
  11822.     PInt := Pointer(PStr);
  11823.     for I := 0 to Count - 1 do
  11824.     begin
  11825.       with Item[I] do
  11826.         for J := 0 to SubItems.Count - 1 do
  11827.         begin
  11828.           PInt^ := SubItemImages[J];
  11829.           Inc(PInt);
  11830.         end;
  11831.     end;
  11832.     Stream.WriteBuffer(ItemHeader^, Size);
  11833.   finally
  11834.     FreeMem(ItemHeader, Size);
  11835.   end;
  11836. end;
  11837.  
  11838. procedure TListItems.Delete(Index: Integer);
  11839. begin
  11840.   Item[Index].Delete;
  11841. end;
  11842.  
  11843. function TListItems.CreateItem(Index: Integer;
  11844.   ListItem: TListItem): TLVItem;
  11845. begin
  11846.   with Result do
  11847.   begin
  11848.     mask := LVIF_PARAM or LVIF_IMAGE;
  11849.     iItem := Index;
  11850.     iSubItem := 0;
  11851.     iImage := I_IMAGECALLBACK;
  11852.     lParam := Longint(ListItem);
  11853.   end;
  11854. end;
  11855.  
  11856. { TIconOptions }
  11857.  
  11858. constructor TIconOptions.Create(AOwner: TCustomListView);
  11859. begin
  11860.   inherited Create;
  11861.   if AOwner = nil then raise Exception.CreateRes(@sInvalidOwner);
  11862.   FListView := AOwner;
  11863.   Arrangement := iaTop;
  11864.   AutoArrange := False;
  11865.   WrapText := True;
  11866. end;
  11867.  
  11868. procedure TIconOptions.SetArrangement(Value: TIconArrangement);
  11869. begin
  11870.   if Value <> Arrangement then
  11871.   begin;
  11872.     FArrangement := Value;
  11873.     FListView.RecreateWnd;
  11874.   end;
  11875. end;
  11876.  
  11877. procedure TIconOptions.SetAutoArrange(Value: Boolean);
  11878. begin
  11879.   if Value <> AutoArrange then
  11880.   begin
  11881.     FAutoArrange := Value;
  11882.     FListView.RecreateWnd;
  11883.   end;
  11884. end;
  11885.  
  11886. procedure TIconOptions.SetWrapText(Value: Boolean);
  11887. begin
  11888.   if Value <> WrapText then
  11889.   begin
  11890.     FWrapText := Value;
  11891.     FListView.RecreateWnd;
  11892.   end;
  11893. end;
  11894.  
  11895. { TCustomListView }
  11896.  
  11897. function DefaultListViewSort(Item1, Item2: TListItem;
  11898.   lParam: Integer): Integer; stdcall;
  11899. begin
  11900.   with Item1 do
  11901.     if Assigned(ListView.OnCompare) then
  11902.       ListView.OnCompare(ListView, Item1, Item2, lParam, Result)
  11903.     else Result := lstrcmp(PChar(Item1.Caption), PChar(Item2.Caption));
  11904. end;
  11905.  
  11906. constructor TCustomListView.Create(AOwner: TComponent);
  11907. begin
  11908.   inherited Create(AOwner);
  11909.   ControlStyle := ControlStyle - [csCaptureMouse] + [csDisplayDragImage, csReflector];
  11910.   Width := 250;
  11911.   Height := 150;
  11912.   BorderStyle := bsSingle;
  11913.   ViewStyle := vsIcon;
  11914.   ParentColor := False;
  11915.   TabStop := True;
  11916.   HideSelection := True;
  11917.   ShowColumnHeaders := True;
  11918.   ColumnClick := True;
  11919.   FCanvas := TControlCanvas.Create;
  11920.   TControlCanvas(FCanvas).Control := Self;
  11921.   FDragIndex := -1;
  11922.   FListColumns := TListColumns.Create(Self);
  11923.   FListItems := TListItems.Create(Self);
  11924.   FTempItem := CreateListItem;
  11925.   FIconOptions := TIconOptions.Create(Self);
  11926.   FWorkAreas := TWorkAreas.Create(Self, TWorkArea);
  11927.   FShowWorkAreas := False;
  11928.   FUpdatingColumnOrder := False;
  11929.   FOwnerDataCount := 0;
  11930.   FDragImage := TDragImageList.CreateSize(32, 32);
  11931.   FEditInstance := MakeObjectInstance(EditWndProc);
  11932.   FHeaderInstance := MakeObjectInstance(HeaderWndProc);
  11933.   FLargeChangeLink := TChangeLink.Create;
  11934.   FLargeChangeLink.OnChange := ImageListChange;
  11935.   FSmallChangeLink := TChangeLink.Create;
  11936.   FSmallChangeLink.OnChange := ImageListChange;
  11937.   FStateChangeLink := TChangeLink.Create;
  11938.   FStateChangeLink.OnChange := ImageListChange;
  11939. end;
  11940.  
  11941. destructor TCustomListView.Destroy;
  11942. begin
  11943.   if HandleAllocated then DestroyWindowHandle;
  11944.   FDragImage.Free;
  11945.   FListColumns.Free;
  11946.   FTempItem.Free;
  11947.   FListItems.Free;
  11948.   FIconOptions.Free;
  11949.   FMemStream.Free;
  11950.   FColStream.Free;
  11951.   FCheckStream.Free;
  11952.   FWorkAreas.Free;
  11953.   FreeObjectInstance(FEditInstance);
  11954.   if FHeaderHandle <> 0 then
  11955.     SetWindowLong(FHeaderHandle, GWL_WNDPROC, LongInt(FDefHeaderProc));
  11956.   FreeObjectInstance(FHeaderInstance);
  11957.   FLargeChangeLink.Free;
  11958.   FSmallChangeLink.Free;
  11959.   FStateChangeLink.Free;
  11960.   FCanvas.Free;
  11961.   inherited Destroy;
  11962. end;
  11963.  
  11964. procedure TCustomListView.CreateParams(var Params: TCreateParams);
  11965. const
  11966.   BorderStyles: array[TBorderStyle] of DWORD = (0, WS_BORDER);
  11967.   EditStyles: array[Boolean] of DWORD = (LVS_EDITLABELS, 0);
  11968.   MultiSelections: array[Boolean] of DWORD = (LVS_SINGLESEL, 0);
  11969.   HideSelections: array[Boolean] of DWORD = (LVS_SHOWSELALWAYS, 0);
  11970.   Arrangements: array[TIconArrangement] of DWORD = (LVS_ALIGNTOP,
  11971.     LVS_ALIGNLEFT);
  11972.   AutoArrange: array[Boolean] of DWORD = (0, LVS_AUTOARRANGE);
  11973.   WrapText: array[Boolean] of DWORD = (LVS_NOLABELWRAP, 0);
  11974.   ViewStyles: array[TViewStyle] of DWORD = (LVS_ICON, LVS_SMALLICON,
  11975.     LVS_LIST, LVS_REPORT);
  11976.   ShowColumns: array[Boolean] of DWORD = (LVS_NOCOLUMNHEADER, 0);
  11977.   ColumnClicks: array[Boolean] of DWORD = (LVS_NOSORTHEADER, 0);
  11978. begin
  11979.   InitCommonControl(ICC_LISTVIEW_CLASSES);
  11980.   inherited CreateParams(Params);
  11981.   CreateSubClass(Params, WC_LISTVIEW);
  11982.   with Params do
  11983.   begin
  11984.     Style := Style or WS_CLIPCHILDREN or ViewStyles[ViewStyle] or
  11985.       BorderStyles[BorderStyle] or Arrangements[IconOptions.Arrangement] or
  11986.       EditStyles[ReadOnly] or MultiSelections[MultiSelect] or
  11987.       HideSelections[HideSelection] or
  11988.       AutoArrange[IconOptions.AutoArrange] or
  11989.       WrapText[IconOptions.WrapText] or
  11990.       ShowColumns[ShowColumnHeaders] or
  11991.       ColumnClicks[ColumnClick] or
  11992.       LVS_SHAREIMAGELISTS;
  11993.     if FOwnerData then Style := Style or LVS_OWNERDATA;
  11994.     if FOwnerDraw then Style := Style or LVS_OWNERDRAWFIXED;
  11995.     if Ctl3D and NewStyleControls and (FBorderStyle = bsSingle) then
  11996.     begin
  11997.       Style := Style and not WS_BORDER;
  11998.       ExStyle := Params.ExStyle or WS_EX_CLIENTEDGE;
  11999.     end;
  12000.     WindowClass.style := WindowClass.style and not (CS_HREDRAW or CS_VREDRAW);
  12001.   end;
  12002. end;
  12003.  
  12004. procedure TCustomListView.CreateWnd;
  12005.  
  12006.   procedure ReadCols;
  12007.   var
  12008.     Reader: TReader;
  12009.   begin
  12010.     if FColStream = nil then Exit;
  12011.     Columns.Clear;
  12012.     Reader := TReader.Create(FColStream, 1024);
  12013.     try
  12014.       Reader.ReadValue;
  12015.       Reader.ReadCollection(Columns);
  12016.     finally
  12017.       Reader.Free;
  12018.     end;
  12019.     FColStream.Destroy;
  12020.     FColStream := nil;
  12021.   end;
  12022.  
  12023. begin
  12024.   inherited CreateWnd;
  12025.   ResetExStyles;
  12026.   SetTextBKColor(Color);
  12027.   SetTextColor(Font.Color);
  12028.   SetAllocBy(AllocBy);
  12029.   if FMemStream <> nil then
  12030.   begin
  12031.     Items.BeginUpdate;
  12032.     FReading := True;
  12033.     try
  12034.       Columns.Clear;
  12035.       FMemStream.ReadComponent(Self);
  12036.       FMemStream.Destroy;
  12037.       FMemStream := nil;
  12038.       if OwnerData then Items.Count := FOwnerDataCount;
  12039.       if FCheckboxes then RestoreChecks;
  12040.       ReadCols;
  12041.       Font := Font;
  12042.     finally
  12043.       Items.EndUpdate;
  12044.       FReading := False;
  12045.     end;
  12046.   end;
  12047.   Columns.UpdateCols;
  12048.   if (LargeImages <> nil) and LargeImages.HandleAllocated then
  12049.     SetImageList(LargeImages.Handle, LVSIL_NORMAL);
  12050.   if (SmallImages <> nil) and SmallImages.HandleAllocated then
  12051.     SetImageList(SmallImages.Handle, LVSIL_SMALL);
  12052.   if (StateImages <> nil) and StateImages.HandleAllocated then
  12053.     SetImageList(StateImages.Handle, LVSIL_STATE);
  12054.   DoAutoSize;
  12055. end;
  12056.  
  12057. procedure TCustomListView.DestroyWnd;
  12058. begin
  12059.   if FMemStream = nil then FMemStream := TMemoryStream.Create
  12060.   else FMemStream.Size := 0;
  12061.   if OwnerData then FOwnerDataCount := Items.Count;
  12062.   FMemStream.WriteComponent(Self);
  12063.   FMemStream.Position := 0;
  12064.   if FCheckboxes then SaveChecks;
  12065.   inherited DestroyWnd;
  12066. end;
  12067.  
  12068. procedure TCustomListView.SetImageList(Value: HImageList; Flags: Integer);
  12069. begin
  12070.   if HandleAllocated then ListView_SetImageList(Handle, Value, Flags);
  12071. end;
  12072.  
  12073. procedure TCustomListView.ImageListChange(Sender: TObject);
  12074. var
  12075.   ImageHandle: HImageList;
  12076. begin
  12077.   if HandleAllocated then
  12078.   begin
  12079.     if TCustomImageList(Sender).HandleAllocated then
  12080.       ImageHandle := TCustomImageList(Sender).Handle
  12081.     else
  12082.       ImageHandle := 0;
  12083.     if Sender = LargeImages then SetImageList(ImageHandle, LVSIL_NORMAL)
  12084.     else if Sender = SmallImages then SetImageList(ImageHandle, LVSIL_SMALL)
  12085.     else if Sender = StateImages then SetImageList(ImageHandle, LVSIL_STATE);
  12086.   end;
  12087. end;
  12088.  
  12089. procedure TCustomListView.Notification(AComponent: TComponent;
  12090.   Operation: TOperation);
  12091. begin
  12092.   inherited Notification(AComponent, Operation);
  12093.   if Operation = opRemove then
  12094.   begin
  12095.     if AComponent = LargeImages then LargeImages := nil;
  12096.     if AComponent = SmallImages then SmallImages := nil;
  12097.     if AComponent = StateImages then StateImages := nil;
  12098.   end;
  12099. end;
  12100.  
  12101. procedure TCustomListView.HeaderWndProc(var Message: TMessage);
  12102.  
  12103.   procedure UpdateColumnOrder;
  12104.   var
  12105.     I: Integer;
  12106.     ColumnOrder: array of Integer;
  12107.   begin
  12108.     SetLength(ColumnOrder, Columns.Count);
  12109.     ListView_GetColumnOrderArray(Handle, Columns.Count, PInteger(ColumnOrder));
  12110.     FListColumns.BeginUpdate;
  12111.     try
  12112.       for I := 0 to FListColumns.Count - 1 do
  12113.         GetColumnFromTag(ColumnOrder[I]).Index := I;
  12114.       if Assigned(FOnColumnDragged) then FOnColumnDragged(Self);
  12115.     finally
  12116.       FListColumns.EndUpdate;
  12117.       FUpdatingColumnOrder := False;
  12118.     end;
  12119.   end;
  12120.  
  12121. begin
  12122.   try
  12123.     with Message do
  12124.     begin
  12125.       case Msg of
  12126.         WM_CAPTURECHANGED:
  12127.           if FUpdatingColumnOrder then UpdateColumnOrder;
  12128.         WM_NCHITTEST:
  12129.           with TWMNCHitTest(Message) do
  12130.             if csDesigning in ComponentState then
  12131.             begin
  12132.               Result := Windows.HTTRANSPARENT;
  12133.               Exit;
  12134.             end;
  12135.         WM_NCDESTROY:
  12136.           begin
  12137.             Result := CallWindowProc(FDefHeaderProc, FHeaderHandle, Msg, WParam, LParam);
  12138.             FHeaderHandle := 0;
  12139.             FDefHeaderProc := nil;
  12140.             Exit;
  12141.           end;
  12142.       end;
  12143.       Result := CallWindowProc(FDefHeaderProc, FHeaderHandle, Msg, WParam, LParam);
  12144.     end;
  12145.   except
  12146.     Application.HandleException(Self);
  12147.   end;
  12148. end;
  12149.  
  12150. procedure TCustomListView.EditWndProc(var Message: TMessage);
  12151. begin
  12152.   try
  12153.     with Message do
  12154.     begin
  12155.       case Msg of
  12156.         WM_KEYDOWN,
  12157.         WM_SYSKEYDOWN: if DoKeyDown(TWMKey(Message)) then Exit;
  12158.         WM_CHAR: if DoKeyPress(TWMKey(Message)) then Exit;
  12159.         WM_KEYUP,
  12160.         WM_SYSKEYUP: if DoKeyUp(TWMKey(Message)) then Exit;
  12161.         CN_KEYDOWN,
  12162.         CN_CHAR, CN_SYSKEYDOWN,
  12163.         CN_SYSCHAR:
  12164.           begin
  12165.             WndProc(Message);
  12166.             Exit;
  12167.           end;
  12168.       end;
  12169.       Result := CallWindowProc(FDefEditProc, FEditHandle, Msg, WParam, LParam);
  12170.     end;
  12171.   except
  12172.     Application.HandleException(Self);
  12173.   end;
  12174. end;
  12175.  
  12176. procedure TCustomListView.UpdateItems(FirstIndex, LastIndex: Integer);
  12177. begin
  12178.   ListView_RedrawItems(Handle, FirstIndex, LastIndex);
  12179. end;
  12180.  
  12181. procedure TCustomListView.ResetExStyles;
  12182. var
  12183.   Styles: DWORD;
  12184.   TempImages: TCustomImageList;
  12185. begin
  12186.   if HandleAllocated then
  12187.   begin
  12188.     TempImages := nil;
  12189.     if StateImages <> nil then
  12190.     begin
  12191.       TempImages := StateImages;
  12192.       StateImages := nil;
  12193.     end;
  12194.     Styles := LVS_EX_SUBITEMIMAGES or LVS_EX_INFOTIP;
  12195.     if FCheckboxes then Styles := LVS_EX_CHECKBOXES;
  12196.     if FGridLines then Styles := Styles or LVS_EX_GRIDLINES;
  12197.     if FHotTrack then Styles := Styles or LVS_EX_TRACKSELECT;
  12198.     if FRowSelect then Styles := Styles or LVS_EX_FULLROWSELECT;
  12199.     if FFlatScrollBars then Styles := Styles or LVS_EX_FLATSB;
  12200.     if FFullDrag then Styles := Styles or LVS_EX_HEADERDRAGDROP;
  12201.     if FShowWorkAreas then Styles := Styles or LVS_EX_MULTIWORKAREAS; 
  12202.     if htHandPoint in FHotTrackStyles then
  12203.       Styles := Styles or LVS_EX_ONECLICKACTIVATE
  12204.     else if FHotTrackStyles * [htUnderlineHot, htUnderlineCold] <> [] then
  12205.       Styles := Styles or LVS_EX_TWOCLICKACTIVATE;
  12206.     if htUnderlineHot in FHotTrackStyles then
  12207.       Styles := Styles or LVS_EX_UNDERLINEHOT;
  12208.     if htUnderlineCold in FHotTrackStyles then
  12209.       Styles := Styles or LVS_EX_UNDERLINECOLD;
  12210.     ListView_SetExtendedListViewStyle(Handle, Styles);
  12211.     if TempImages <> nil then
  12212.       StateImages := TempImages;
  12213.   end;
  12214. end;
  12215.  
  12216. procedure TCustomListView.RestoreChecks;
  12217. var
  12218.   i: Integer;
  12219.   Value: Boolean;
  12220. begin
  12221.   for i := 0 to Items.Count - 1 do
  12222.   begin
  12223.     if FCheckStream <> nil then
  12224.     begin
  12225.       FCheckStream.Read(Value, SizeOf(Value));
  12226.       Items[i].Checked := Value;
  12227.     end
  12228.     else
  12229.       Items[i].Checked := Items[i].FChecked;
  12230.   end;
  12231.   FCheckStream.Free;
  12232.   FCheckStream := nil;
  12233. end;
  12234.  
  12235. procedure TCustomListView.SaveChecks;
  12236. var
  12237.   i: Integer;
  12238.   Value: Boolean;
  12239. begin
  12240.   if FCheckStream = nil then FCheckStream := TMemoryStream.Create
  12241.   else FCheckStream.Size := 0;
  12242.   for i := 0 to Items.Count - 1 do
  12243.   begin
  12244.     Value := Items[i].Checked;
  12245.     FCheckStream.Write(Value, SizeOf(Value));
  12246.   end;
  12247.   FCheckStream.Position := 0;
  12248. end;
  12249.  
  12250. procedure TCustomListView.SetCheckboxes(Value: Boolean);
  12251. var
  12252.   I: Integer;
  12253. begin
  12254.   if FCheckboxes <> Value then
  12255.   begin
  12256.     FCheckboxes := Value;
  12257.     ResetExStyles;
  12258.     if FCheckboxes then
  12259.       RestoreChecks
  12260.     else
  12261.       for I := 0 to Items.Count - 1 do
  12262.         Items[I].FChecked := (ListView_GetCheckState(Handle, Items[I].Index) <> 0)
  12263.   end;
  12264. end;
  12265.  
  12266. procedure TCustomListView.SetGridLines(Value: Boolean);
  12267. begin
  12268.   if FGridLines <> Value then
  12269.   begin
  12270.     FGridLines := Value;
  12271.     ResetExStyles;
  12272.   end;
  12273. end;
  12274.  
  12275. procedure TCustomListView.SetHotTrack(Value: Boolean);
  12276. begin
  12277.   if FHotTrack <> Value then
  12278.   begin
  12279.     FHotTrack := Value;
  12280.     ResetExStyles;
  12281.   end;
  12282. end;
  12283.  
  12284. procedure TCustomListView.SetHotTrackStyles(Value: TListHotTrackStyles);
  12285. begin
  12286.   if FHotTrackStyles <> Value then
  12287.   begin
  12288.     FHotTrackStyles := Value;
  12289.     ResetExStyles;
  12290.   end;
  12291. end;
  12292.  
  12293. procedure TCustomListView.SetOwnerData(Value: Boolean);
  12294. begin
  12295.   if FOwnerData <> Value then
  12296.   begin
  12297.     Items.Clear;
  12298.     FOwnerData := Value;
  12299.     RecreateWnd;
  12300.   end;
  12301. end;
  12302.  
  12303. procedure TCustomListView.SetOwnerDraw(Value: Boolean);
  12304. begin
  12305.   if FOwnerDraw <> Value then
  12306.   begin
  12307.     FOwnerDraw := Value;
  12308.     RecreateWnd;
  12309.   end;
  12310. end;
  12311.  
  12312. procedure TCustomListView.SetRowSelect(Value: Boolean);
  12313. begin
  12314.   if FRowSelect <> Value then
  12315.   begin
  12316.     FRowSelect := Value;
  12317.     ResetExStyles;
  12318.   end;
  12319. end;
  12320.  
  12321. procedure TCustomListView.SetFlatScrollBars(Value: Boolean);
  12322. begin
  12323.   if FFlatScrollBars <> Value then
  12324.   begin
  12325.     FFlatScrollBars := Value;
  12326.     ResetExStyles;
  12327.   end;
  12328. end;
  12329.  
  12330. procedure TCustomListView.SetFullDrag(Value: Boolean);
  12331. begin
  12332.   if FFullDrag <> Value then
  12333.   begin
  12334.     FFullDrag := Value;
  12335.     ResetExStyles;
  12336.   end;
  12337. end;
  12338.  
  12339. procedure TCustomListView.SetBorderStyle(Value: TBorderStyle);
  12340. begin
  12341.   if BorderStyle <> Value then
  12342.   begin
  12343.     FBorderStyle := Value;
  12344.     RecreateWnd;
  12345.   end;
  12346. end;
  12347.  
  12348. procedure TCustomListView.SetColumnClick(Value: Boolean);
  12349. begin
  12350.   if ColumnClick <> Value then
  12351.   begin
  12352.     FColumnClick := Value;
  12353.     RecreateWnd;
  12354.   end;
  12355. end;
  12356.  
  12357. procedure TCustomListView.SetMultiSelect(Value: Boolean);
  12358. begin
  12359.   if Value <> MultiSelect then
  12360.   begin
  12361.     FMultiSelect := Value;
  12362.     RecreateWnd;
  12363.   end;
  12364. end;
  12365.  
  12366. procedure TCustomListView.SetColumnHeaders(Value: Boolean);
  12367. begin
  12368.   if Value <> ShowColumnHeaders then
  12369.   begin
  12370.     FShowColumnHeaders := Value;
  12371.     RecreateWnd;
  12372.   end;
  12373. end;
  12374.  
  12375. procedure TCustomListView.SetTextColor(Value: TColor);
  12376. begin
  12377.   ListView_SetTextColor(Handle, ColorToRGB(Font.Color));
  12378. end;
  12379.  
  12380. procedure TCustomListView.SetTextBkColor(Value: TColor);
  12381. begin
  12382.   ListView_SetTextBkColor(Handle, ColorToRGB(Color));
  12383.   ListView_SetBkColor(Handle, ColorToRGB(Color));
  12384. end;
  12385.  
  12386. procedure TCustomListView.SetAllocBy(Value: Integer);
  12387. begin
  12388.   if AllocBy <> Value then
  12389.   begin
  12390.     FAllocBy := Value;
  12391.     if HandleAllocated then ListView_SetItemCount(Handle, Value);
  12392.   end;
  12393. end;
  12394.  
  12395. procedure TCustomListView.CMColorChanged(var Message: TMessage);
  12396. begin
  12397.   inherited;
  12398.   if HandleAllocated then SetTextBkColor(Color);
  12399. end;
  12400.  
  12401. procedure TCustomListView.CMCtl3DChanged(var Message: TMessage);
  12402. begin
  12403.   if FBorderStyle = bsSingle then RecreateWnd;
  12404.   inherited;
  12405. end;
  12406.  
  12407. procedure TCustomListView.WMNotify(var Message: TWMNotify);
  12408. var
  12409.   Col: TListColumn;
  12410.   P: TPoint;
  12411.   hChildWnd: HWND;
  12412.   WndClass: string;
  12413.   hdhti: THDHitTestInfo;
  12414. begin
  12415.   inherited;
  12416.   if ValidHeaderHandle and (Message.NMHdr^.hWndFrom = FHeaderHandle) then
  12417.     with Message.NMHdr^ do
  12418.       case code of
  12419.         HDN_ENDTRACK:
  12420.           with PHDNotify(Pointer(Message.NMHdr))^, PItem^ do
  12421.           if (Mask and HDI_WIDTH) <> 0 then
  12422.             begin
  12423.               Col := GetColumnFromTag(Item);
  12424.               if Col.MinWidth >= cxy then
  12425.                 cxy := Col.MinWidth
  12426.               else if (Col.MaxWidth > 0) and (Col.MaxWidth <= cxy) then
  12427.                 cxy := Col.MaxWidth;
  12428.               Col.Width := cxy;
  12429.             end;
  12430.         HDN_ENDDRAG:
  12431.           FUpdatingColumnOrder := True;
  12432.         HDN_DIVIDERDBLCLICK:
  12433.           with PHDNotify(Pointer(Message.NMHdr))^ do
  12434.           begin
  12435.             Col := GetColumnFromTag(Item);
  12436.             Col.Width := ListView_GetColumnWidth(Handle, Item);
  12437.             if IsCustomDrawn(dtControl, cdPrePaint) then Invalidate;
  12438.           end;
  12439.         NM_RCLICK:
  12440.           begin
  12441.             P := Point(LoWord(GetMessagePos), HiWord(GetMessagePos));
  12442.             hChildWnd := ChildWindowFromPoint(Handle, ScreenToClient(P));
  12443.             if (hChildWnd <> 0) and (hChildWnd <> Handle) then
  12444.             begin
  12445.               SetLength(WndClass, 80);
  12446.               SetLength(WndClass, GetClassName(hChildWnd, PChar(WndClass), Length(WndClass)));
  12447.               if WndClass = 'SysHeader32' then
  12448.               begin
  12449.                 hdhti.Point := ScreenToClient(P);
  12450.                 if SendMessage(hChildWnd, HDM_HITTEST, 1, Longint(@hdhti)) >= 0 then
  12451.                   ColRightClick(GetColumnFromTag(hdhti.Item), hdhti.Point);
  12452.               end;
  12453.             end;
  12454.           end;
  12455.       end;
  12456. end;
  12457.  
  12458. function TCustomListView.ColumnsShowing: Boolean;
  12459. begin
  12460.   Result := (ViewStyle = vsReport);
  12461. end;
  12462.  
  12463. function TCustomListView.ValidHeaderHandle: Boolean;
  12464. begin
  12465.   Result := FHeaderHandle <> 0;
  12466. end;
  12467.  
  12468. procedure TCustomListView.CMFontChanged(var Message: TMessage);
  12469. begin
  12470.   inherited;
  12471.   if HandleAllocated then
  12472.   begin
  12473.     SetTextColor(Font.Color);
  12474.     if ValidHeaderHandle then
  12475.       InvalidateRect(FHeaderHandle, nil, True);
  12476.   end;
  12477. end;
  12478.  
  12479. procedure TCustomListView.SetHideSelection(Value: Boolean);
  12480. begin
  12481.   if Value <> HideSelection then
  12482.   begin
  12483.     FHideSelection := Value;
  12484.     RecreateWnd;
  12485.   end;
  12486. end;
  12487.  
  12488. procedure TCustomListView.SetReadOnly(Value: Boolean);
  12489. begin
  12490.   if Value <> ReadOnly then
  12491.   begin
  12492.     FReadOnly := Value;
  12493.     RecreateWnd;
  12494.   end;
  12495. end;
  12496.  
  12497. procedure TCustomListView.SetIconOptions(Value: TIconOptions);
  12498. begin
  12499.   with FIconOptions do
  12500.   begin
  12501.     Arrangement := Value.Arrangement;
  12502.     AutoArrange := Value.AutoArrange;
  12503.     WrapText := Value.WrapText;
  12504.   end;
  12505. end;
  12506.  
  12507. procedure TCustomListView.SetViewStyle(Value: TViewStyle);
  12508. const
  12509.   ViewStyles: array[TViewStyle] of Integer = (LVS_ICON, LVS_SMALLICON,
  12510.     LVS_LIST, LVS_REPORT);
  12511. var
  12512.   Style: Longint;
  12513. begin
  12514.   if Value <> FViewStyle then
  12515.   begin
  12516.     FViewStyle := Value;
  12517.     if HandleAllocated then
  12518.     begin
  12519.       Style := GetWindowLong(Handle, GWL_STYLE);
  12520.       Style := Style and (not LVS_TYPEMASK);
  12521.       Style := Style or ViewStyles[FViewStyle];
  12522.       SetWindowLong(Handle, GWL_STYLE, Style);
  12523.       UpdateColumns;
  12524.       case ViewStyle of
  12525.         vsIcon,
  12526.         vsSmallIcon:
  12527.           if IconOptions.Arrangement = iaTop then
  12528.             Arrange(arAlignTop) else
  12529.             Arrange(arAlignLeft);
  12530.       end;
  12531.     end;
  12532.   end;
  12533. end;
  12534.  
  12535. procedure TCustomListView.WMParentNotify(var Message: TWMParentNotify);
  12536. begin
  12537.   with Message do
  12538.     if (Event = WM_CREATE) and (FHeaderHandle = 0) then
  12539.     begin
  12540.       FHeaderHandle := ChildWnd;
  12541.       FDefHeaderProc := Pointer(GetWindowLong(FHeaderHandle, GWL_WNDPROC));
  12542.       SetWindowLong(FHeaderHandle, GWL_WNDPROC, LongInt(FHeaderInstance));
  12543.     end;
  12544.   inherited;
  12545. end;
  12546.  
  12547. function TCustomListView.GetItemIndex(Value: TListItem): Integer;
  12548. var
  12549.   I: Integer;
  12550. begin
  12551.   Result := -1;
  12552.   for I := 0 to Items.Count - 1 do if Items[I] = Value then Break;
  12553.   if I < Items.Count then Result := I;
  12554. end;
  12555.  
  12556. function TCustomListView.OwnerDataFetch(Item: TListItem; Request: TItemRequest): Boolean;
  12557. begin
  12558.   if Assigned(FOnData) then
  12559.   begin
  12560.     FOnData(Self, Item);
  12561.     Result := True;
  12562.   end
  12563.   else Result := False;
  12564. end;
  12565.  
  12566. function TCustomListView.OwnerDataFind(Find: TItemFind; const FindString: string;
  12567.   const FindPosition: TPoint; FindData: Pointer; StartIndex: Integer;
  12568.   Direction: TSearchDirection; Wrap: Boolean): Integer;
  12569. begin
  12570.   Result := -1;
  12571.   if Assigned(FOnDataFind) then FOnDataFind(Self, Find, FindString, FindPosition,
  12572.     FindData, StartIndex, Direction, Wrap, Result)
  12573. end;
  12574.  
  12575. function TCustomListView.OwnerDataHint(StartIndex, EndIndex: Integer): Boolean;
  12576. begin
  12577.   if Assigned(FOnDataHint) then
  12578.   begin
  12579.     FOnDataHint(Self, StartIndex, EndIndex);
  12580.     Result := True;
  12581.   end
  12582.   else Result := False;
  12583. end;
  12584.  
  12585. function TCustomListView.OwnerDataStateChange(StartIndex, EndIndex: Integer;
  12586.   OldState, NewState: TItemStates): Boolean;
  12587. begin
  12588.   if Assigned(FOnDataStateChange) then
  12589.   begin
  12590.     FOnDataStateChange(Self, StartIndex, EndIndex, OldState, NewState);
  12591.     Result := True;
  12592.   end
  12593.   else Result := False;
  12594. end;
  12595.  
  12596. function TCustomListView.CreateListItem: TListItem;
  12597. begin
  12598.   Result := TListItem.Create(Items);
  12599. end;
  12600.  
  12601. function TCustomListView.GetItem(Value: TLVItem): TListItem;
  12602. var
  12603.   S: string;
  12604.   Request: TItemRequest;
  12605.  
  12606.   function ConvertMask(Mask: Longint): TItemRequest;
  12607.   begin
  12608.     Result := [];
  12609.     if Mask and LVIF_TEXT <> 0 then
  12610.       Include(Result, irText);
  12611.     if Mask and LVIF_IMAGE <> 0 then
  12612.       Include(Result, irImage);
  12613.     if Mask and LVIF_PARAM <> 0 then
  12614.       Include(Result, irParam);
  12615.     if Mask and LVIF_STATE <> 0 then
  12616.       Include(Result, irState);
  12617.     if Mask and LVIF_INDENT <> 0 then
  12618.       Include(Result, irIndent);
  12619.   end;
  12620.  
  12621. begin
  12622.   with Value do
  12623.     if (mask and LVIF_PARAM) <> 0 then
  12624.       Result := TListItem(lParam)
  12625.     else
  12626.     begin
  12627.       if OwnerData then
  12628.       begin
  12629.         if iItem < 0 then
  12630.           Result := nil
  12631.         else if iSubItem = 0 then
  12632.         begin
  12633.           Request := ConvertMask(mask);
  12634.           FTempItem.FIndex := iItem;
  12635.           FTempItem.FData := Pointer(lParam);
  12636.           FTempItem.FSubItems.Clear;
  12637.           if (irText in Request) and (pszText <> nil) then
  12638.             S := StrPas(pszText) else
  12639.             S := '';
  12640.             FTempItem.FCaption := S;
  12641.           if irImage in Request then
  12642.             FTempItem.FImageIndex := iImage;
  12643.           if irIndent in Request then
  12644.             FTempItem.FIndent := iIndent;
  12645.           OwnerDataFetch(FTempItem, Request);
  12646.           Result := FTempItem;
  12647.         end
  12648.         else
  12649.           Result := FTempItem;
  12650.       end
  12651.       else
  12652.         Result := Items[IItem];
  12653.     end;
  12654. end;
  12655.  
  12656. function TCustomListView.GetSelCount: Integer;
  12657. begin
  12658.   Result := ListView_GetSelectedCount(Handle);
  12659. end;
  12660.  
  12661. procedure TCustomListView.CNNotify(var Message: TWMNotify);
  12662. var
  12663.   Item: TListItem;
  12664.   I: Integer;
  12665.   R: TRect;
  12666.   DefaultDraw: Boolean;
  12667.   ItemFind: TItemFind;
  12668.   FindString: string;
  12669.   FindPos: TPoint;
  12670.   FindData: Pointer;
  12671.   SearchDir: TSearchDirection;
  12672.   TmpItem: TLVItem;
  12673.   SubItem: Boolean;
  12674.   SubItemImage: Integer;
  12675.   LogFont: TLogFont;
  12676.  
  12677.   function ConvertFlags(Flags: Integer): TItemFind;
  12678.   begin
  12679.     if Flags and LVFI_PARAM <> 0 then
  12680.       Result := ifData
  12681.     else if Flags and LVFI_PARTIAL <> 0 then
  12682.       Result := ifPartialString
  12683.     else if Flags and LVFI_STRING <> 0 then
  12684.       Result := ifExactString
  12685.     else if Flags and LVFI_NEARESTXY <> 0 then
  12686.       Result := ifNearest
  12687.     else
  12688.       Result := ifData; // Fall-back value
  12689.   end;
  12690.  
  12691.   function ConvertStates(State: Integer): TItemStates;
  12692.   begin
  12693.     Result := [];
  12694.     if State and LVIS_ACTIVATING <> 0 then
  12695.       Include(Result, isActivating);
  12696.     if State and LVIS_CUT <> 0 then
  12697.       Include(Result, isCut);
  12698.     if State and LVIS_DROPHILITED <> 0 then
  12699.       Include(Result, isDropHilited);
  12700.     if State and LVIS_FOCUSED <> 0 then
  12701.       Include(Result, isFocused);
  12702.     if State and LVIS_SELECTED <> 0 then
  12703.       Include(Result, isSelected);
  12704.   end;
  12705.  
  12706. begin
  12707.   with Message do
  12708.     case NMHdr^.code of
  12709.       HDN_TRACK:
  12710.         with PHDNotify(Pointer(Message.NMHdr))^, PItem^ do
  12711.           if ((Mask and HDI_WIDTH) <> 0) then
  12712.           begin
  12713.             if Column[Item].MinWidth >= cxy then
  12714.               Column[Item].Width := Column[Item].MinWidth
  12715.             else if Column[Item].MaxWidth <= cxy then
  12716.               Column[Item].Width := Column[Item].MaxWidth;
  12717.           end;
  12718.  
  12719.       NM_CUSTOMDRAW:
  12720.         with PNMCustomDraw(NMHdr)^ do
  12721.         try
  12722.           FCanvas.Lock;
  12723.           Result := CDRF_DODEFAULT;
  12724.           if (dwDrawStage and CDDS_ITEM) = 0 then
  12725.           begin
  12726.             R := ClientRect;
  12727.             case dwDrawStage of
  12728.               CDDS_PREPAINT:
  12729.               begin
  12730.                 if IsCustomDrawn(dtControl, cdPrePaint) then
  12731.                 begin
  12732.                   try
  12733.                     FCanvas.Handle := hdc;
  12734.                     FCanvas.Font := Font;
  12735.                     FCanvas.Brush := Brush;
  12736.                     DefaultDraw := CustomDraw(R, cdPrePaint);
  12737.                   finally
  12738.                     FCanvas.Handle := 0;
  12739.                   end;
  12740.                   if not DefaultDraw then
  12741.                   begin
  12742.                     Result := CDRF_SKIPDEFAULT;
  12743.                     Exit;
  12744.                   end;
  12745.                 end;
  12746.                 if IsCustomDrawn(dtItem, cdPrePaint) or IsCustomDrawn(dtItem, cdPreErase) then
  12747.                   Result := CDRF_NOTIFYITEMDRAW;
  12748.                 if IsCustomDrawn(dtItem, cdPostPaint) then
  12749.                   Result := Result or CDRF_NOTIFYPOSTPAINT;
  12750.                 if IsCustomDrawn(dtItem, cdPostErase) then
  12751.                   Result := Result or CDRF_NOTIFYPOSTERASE;
  12752.                 if IsCustomDrawn(dtSubItem, cdPrePaint) then
  12753.                   Result := Result or CDRF_NOTIFYSUBITEMDRAW;
  12754.               end;
  12755.               CDDS_POSTPAINT:
  12756.                 if IsCustomDrawn(dtControl, cdPostPaint) then
  12757.                   CustomDraw(R, cdPostPaint);
  12758.               CDDS_PREERASE:
  12759.                 if IsCustomDrawn(dtControl, cdPreErase) then
  12760.                   CustomDraw(R, cdPreErase);
  12761.               CDDS_POSTERASE:
  12762.                 if IsCustomDrawn(dtControl, cdPostErase) then
  12763.                   CustomDraw(R, cdPostErase);
  12764.             end;
  12765.           end else
  12766.           begin
  12767.             SubItem := dwDrawStage and CDDS_SUBITEM <> 0;
  12768.             { Don't call CustomDrawSubItem for the 0th subitem since
  12769.               CustomDrawItem draws that item. }
  12770.             if SubItem and (PNMLVCustomDraw(NMHdr)^.iSubItem = 0) then Exit;
  12771.             FillChar(TmpItem, SizeOf(TmpItem), 0);
  12772.             TmpItem.iItem := dwItemSpec;
  12773.             if dwDrawStage and CDDS_ITEMPREPAINT <> 0 then
  12774.             begin
  12775.               try
  12776.                 FCanvas.Handle := hdc;
  12777.                 FCanvas.Font := Font;
  12778.                 FCanvas.Brush := Brush;
  12779.                 FCanvas.Font.OnChange := CanvasChanged;
  12780.                 FCanvas.Brush.OnChange := CanvasChanged;
  12781.                 FCanvasChanged := False;
  12782.                 if SubItem then
  12783.                   DefaultDraw := CustomDrawSubItem(GetItem(TmpItem),
  12784.                     PNMLVCustomDraw(NMHdr)^.iSubItem,
  12785.                     TCustomDrawState(Word(uItemState)), cdPrePaint)
  12786.                 else
  12787.                   DefaultDraw := CustomDrawItem(GetItem(TmpItem),
  12788.                     TCustomDrawState(Word(uItemState)), cdPrePaint);
  12789.                 if not DefaultDraw then
  12790.                 begin
  12791.                   Result := Result or CDRF_SKIPDEFAULT;
  12792.                   Exit;
  12793.                 end
  12794.                 else if FCanvasChanged then
  12795.                 begin
  12796.                   FCanvasChanged := False;
  12797.                   FCanvas.Font.OnChange := nil;
  12798.                   FCanvas.Brush.OnChange := nil;
  12799.                   with PNMLVCustomDraw(NMHdr)^ do
  12800.                   begin
  12801.                     clrText := ColorToRGB(FCanvas.Font.Color);
  12802.                     clrTextBk := ColorToRGB(FCanvas.Brush.Color);
  12803.                     if GetObject(FCanvas.Font.Handle, SizeOf(LogFont), @LogFont) <> 0 then
  12804.                     begin
  12805.                       FCanvas.Handle := 0;  // disconnect from hdc
  12806.                       // don't delete the stock font
  12807.                       SelectObject(hdc, CreateFontIndirect(LogFont));
  12808.                       Result := Result or CDRF_NEWFONT;
  12809.                     end;
  12810.                   end;
  12811.                 end;
  12812.               finally
  12813.                 FCanvas.Handle := 0;
  12814.               end;
  12815.               if not SubItem then
  12816.               begin
  12817.                 if IsCustomDrawn(dtSubItem, cdPrePaint) then
  12818.                   Result := Result or CDRF_NOTIFYSUBITEMDRAW;
  12819.                 if IsCustomDrawn(dtItem, cdPostPaint) then
  12820.                   Result := Result or CDRF_NOTIFYPOSTPAINT;
  12821.                 if IsCustomDrawn(dtItem, cdPostErase) then
  12822.                   Result := Result or CDRF_NOTIFYPOSTERASE;
  12823.               end else
  12824.               begin
  12825.                 if IsCustomDrawn(dtSubItem, cdPostPaint) then
  12826.                   Result := Result or CDRF_NOTIFYPOSTPAINT;
  12827.                 if IsCustomDrawn(dtSubItem, cdPostErase) then
  12828.                   Result := Result or CDRF_NOTIFYPOSTERASE;
  12829.               end;
  12830.             end
  12831.             else if dwDrawStage and CDDS_ITEMPOSTPAINT <> 0 then
  12832.             begin
  12833.               if SubItem then
  12834.                 CustomDrawSubItem(GetItem(TmpItem),
  12835.                   PNMLVCustomDraw(NMHdr)^.iSubItem,
  12836.                   TCustomDrawState(Word(uItemState)), cdPostPaint)
  12837.               else
  12838.                 CustomDrawItem(GetItem(TmpItem),
  12839.                   TCustomDrawState(Word(uItemState)), cdPostPaint);
  12840.             end
  12841.             else if dwDrawStage and CDDS_ITEMPREERASE <> 0 then
  12842.             begin
  12843.               if SubItem then
  12844.                 CustomDrawSubItem(GetItem(TmpItem),
  12845.                   PNMLVCustomDraw(NMHdr)^.iSubItem,
  12846.                   TCustomDrawState(Word(uItemState)), cdPreErase)
  12847.               else
  12848.                 CustomDrawItem(GetItem(TmpItem),
  12849.                   TCustomDrawState(Word(uItemState)), cdPreErase);
  12850.             end
  12851.             else if dwDrawStage and CDDS_ITEMPOSTERASE <> 0 then
  12852.             begin
  12853.               if SubItem then
  12854.                 CustomDrawSubItem(GetItem(TmpItem),
  12855.                   PNMLVCustomDraw(NMHdr)^.iSubItem,
  12856.                   TCustomDrawState(Word(uItemState)), cdPostErase)
  12857.               else
  12858.                 CustomDrawItem(GetItem(TmpItem),
  12859.                   TCustomDrawState(Word(uItemState)), cdPostErase);
  12860.             end;
  12861.           end;
  12862.         finally
  12863.           FCanvas.Unlock;
  12864.         end;
  12865.  
  12866.       LVN_BEGINDRAG: FDragIndex := PNMListView(NMHdr)^.iItem;
  12867.       LVN_DELETEITEM: Delete(TListItem(PNMListView(NMHdr)^.lParam));
  12868.       LVN_DELETEALLITEMS:
  12869.         for I := Items.Count - 1 downto 0 do Delete(Items[I]);
  12870.       LVN_GETDISPINFO:
  12871.         begin
  12872.           Item := GetItem(PLVDispInfo(NMHdr)^.item);
  12873.           with PLVDispInfo(NMHdr)^.item do
  12874.           begin
  12875.             if (mask and LVIF_TEXT) <> 0 then
  12876.               if iSubItem = 0 then
  12877.                 StrPLCopy(pszText, Item.Caption, cchTextMax)
  12878.               else
  12879.                 with Item.SubItems do
  12880.                   if iSubItem <= Count then
  12881.                     StrPLCopy(pszText, Strings[iSubItem - 1], cchTextMax)
  12882.                   else pszText[0] := #0;
  12883.             if (mask and LVIF_IMAGE) <> 0 then
  12884.             begin
  12885.               if iSubItem = 0 then
  12886.               begin
  12887.                 GetImageIndex(Item);
  12888.                 iImage := Item.ImageIndex;
  12889.                 if Assigned(FStateImages) then
  12890.                 begin
  12891.                   state := IndexToStateImageMask(Item.StateIndex + 1);
  12892.                   stateMask := $F000;
  12893.                   mask := mask or LVIF_STATE;
  12894.                 end;
  12895.               end
  12896.               else
  12897.                 if (iSubItem-1 >= 0) and (iSubItem-1 < Item.FSubItems.Count) then
  12898.                 begin
  12899.                   SubItemImage := Item.SubItemImages[iSubItem-1];
  12900.                   GetSubItemImage(Item, iSubItem-1, SubItemImage);
  12901.                   iImage := SubItemImage;
  12902.                 end;
  12903.             end;
  12904.             if (mask and LVIF_INDENT) <> 0 then
  12905.               iIndent := Item.Indent;
  12906.           end;
  12907.         end;
  12908.  
  12909.       LVN_ODCACHEHINT:
  12910.         with PNMLVCacheHint(NMHdr)^ do
  12911.           OwnerDataHint(iFrom, iTo);
  12912.       LVN_ODFINDITEM:
  12913.         with PNMLVFindItem(NMHdr)^ do
  12914.         begin
  12915.           ItemFind := ConvertFlags(lvfi.flags);
  12916.           FindData := nil;
  12917.           FindString := '';
  12918.           FindPos := Point(0,0);
  12919.           SearchDir := sdAll;
  12920.           case ItemFind of
  12921.             ifData: FindData := Pointer(lvfi.lParam);
  12922.             ifPartialString, ifExactString:
  12923.               if lvfi.psz <> nil then
  12924.                 FindString := StrPas(lvfi.psz) else
  12925.                 FindString := '';
  12926.             ifNearest:
  12927.               begin
  12928.                 FindPos := lvfi.pt;
  12929.                 case lvfi.vkDirection of
  12930.                   VK_LEFT: SearchDir := sdLeft;
  12931.                   VK_UP: SearchDir := sdAbove;
  12932.                   VK_RIGHT: SearchDir := sdRight;
  12933.                   VK_DOWN: SearchDir := sdBelow;
  12934.                 end;
  12935.               end;
  12936.           end;
  12937.           Result := OwnerDataFind(ConvertFlags(lvfi.flags), FindString, FindPos,
  12938.             FindData, iStart, SearchDir, lvfi.flags and LVFI_WRAP <> 0);
  12939.         end;
  12940.       LVN_ODSTATECHANGED:
  12941.         with PNMLVODStateChange(NMHdr)^ do
  12942.           OwnerDataStateChange(iFrom, iTo, ConvertStates(uNewState),
  12943.             ConvertStates(uOldState));
  12944.  
  12945.       LVN_BEGINLABELEDIT:
  12946.         begin
  12947.           Item := GetItem(PLVDispInfo(NMHdr)^.item);
  12948.           if not CanEdit(Item) then Result := 1;
  12949.           if Result = 0 then
  12950.           begin
  12951.             FEditHandle := ListView_GetEditControl(Handle);
  12952.             FDefEditProc := Pointer(GetWindowLong(FEditHandle, GWL_WNDPROC));
  12953.             SetWindowLong(FEditHandle, GWL_WNDPROC, LongInt(FEditInstance));
  12954.           end;
  12955.         end;
  12956.       LVN_ENDLABELEDIT:
  12957.         with PLVDispInfo(NMHdr)^ do
  12958.           if (item.pszText <> nil) and (item.IItem <> -1) then
  12959.             Edit(item);
  12960.       LVN_COLUMNCLICK:
  12961.         ColClick(Column[PNMListView(NMHdr)^.iSubItem]);
  12962.       LVN_INSERTITEM: InsertItem(Items[PNMListView(NMHdr)^.iItem]);
  12963.       LVN_ITEMCHANGING:
  12964.         with PNMListView(NMHdr)^ do
  12965.           if not CanChange(Items[iItem], uChanged) then Result := 1;
  12966.       LVN_ITEMCHANGED:
  12967.         with PNMListView(NMHdr)^ do
  12968.         begin
  12969.           Item := Items[iItem];
  12970.           Change(Item, uChanged);
  12971.           if Assigned(FOnSelectItem) and (uChanged = LVIF_STATE) then
  12972.           begin
  12973.             if (uOldState and LVIS_SELECTED <> 0) and
  12974.               (uNewState and LVIS_SELECTED = 0) then
  12975.               FOnSelectItem(Self, Item, False)
  12976.             else if (uOldState and LVIS_SELECTED = 0) and
  12977.               (uNewState and LVIS_SELECTED <> 0) then
  12978.               FOnSelectItem(Self, Item, True);
  12979.           end;
  12980.         end;
  12981.       LVN_GETINFOTIP:
  12982.         if Assigned(FOnInfoTip) then
  12983.           Application.ActivateHint(Mouse.CursorPos);
  12984.       NM_CLICK: FClicked := True;
  12985.       NM_RCLICK: FRClicked := True;
  12986.     end;
  12987. end;
  12988.  
  12989. procedure TCustomListView.ChangeScale(M, D: Integer);
  12990. var
  12991.   I: Integer;
  12992. begin
  12993.   if sfWidth in ScalingFlags then
  12994.     for I := 0 to Columns.Count-1 do
  12995.       Columns[I].Width := MulDiv(Columns[I].Width, M, D);
  12996.   inherited ChangeScale(M,D);
  12997. end;
  12998.  
  12999. procedure TCustomListView.ColClick(Column: TListColumn);
  13000. begin
  13001.   if Assigned(FOnColumnClick) then FOnColumnClick(Self, Column);
  13002. end;
  13003.  
  13004. procedure TCustomListView.ColRightClick(Column: TListColumn; Point: TPoint);
  13005. begin
  13006.   if Assigned(FOnColumnRightClick) then FOnColumnRightClick(Self, Column, Point);
  13007. end;
  13008.  
  13009. procedure TCustomListView.InsertItem(Item: TListItem);
  13010. begin
  13011.   if Assigned(FOnInsert) then FOnInsert(Self, Item);
  13012. end;
  13013.  
  13014. function TCustomListView.CanChange(Item: TListItem; Change: Integer): Boolean;
  13015. var
  13016.   ItemChange: TItemChange;
  13017. begin
  13018.   Result := True;
  13019.   case Change of
  13020.     LVIF_TEXT: ItemChange := ctText;
  13021.     LVIF_IMAGE: ItemChange := ctImage;
  13022.     LVIF_STATE: ItemChange := ctState;
  13023.   else
  13024.     Exit;
  13025.   end;
  13026.   if Assigned(FOnChanging) then FOnChanging(Self, Item, ItemChange, Result);
  13027. end;
  13028.  
  13029. procedure TCustomListView.Change(Item: TListItem; Change: Integer);
  13030. var
  13031.   ItemChange: TItemChange;
  13032. begin
  13033.   case Change of
  13034.     LVIF_TEXT: ItemChange := ctText;
  13035.     LVIF_IMAGE: ItemChange := ctImage;
  13036.     LVIF_STATE: ItemChange := ctState;
  13037.   else
  13038.     Exit;
  13039.   end;
  13040.   if Assigned(FOnChange) then FOnChange(Self, Item, ItemChange);
  13041. end;
  13042.  
  13043. procedure TCustomListView.Delete(Item: TListItem);
  13044. begin
  13045.   if (Item <> nil) and not Item.FProcessedDeleting then
  13046.   begin
  13047.     if Assigned(FOnDeletion) then FOnDeletion(Self, Item);
  13048.     Item.FProcessedDeleting := True;
  13049.     Item.Delete;
  13050.   end;
  13051. end;
  13052.  
  13053. function TCustomListView.CanEdit(Item: TListItem): Boolean;
  13054. begin
  13055.   Result := True;
  13056.   if Assigned(FOnEditing) then FOnEditing(Self, Item, Result);
  13057. end;
  13058.  
  13059. procedure TCustomListView.Edit(const Item: TLVItem);
  13060. var
  13061.   S: string;
  13062.   EditItem: TListItem;
  13063. begin
  13064.   with Item do
  13065.   begin
  13066.     S := pszText;
  13067.     EditItem := GetItem(Item);
  13068.     if Assigned(FOnEdited) then FOnEdited(Self, EditItem, S);
  13069.     if EditItem <> nil then EditItem.Caption := S;
  13070.   end;
  13071. end;
  13072.  
  13073. function TCustomListView.IsEditing: Boolean;
  13074. var
  13075.   ControlHand: HWnd;
  13076. begin
  13077.   ControlHand := ListView_GetEditControl(Handle);
  13078.   Result := (ControlHand <> 0) and IsWindowVisible(ControlHand);
  13079. end;
  13080.  
  13081. function TCustomListView.GetDragImages: TDragImageList;
  13082. begin
  13083.   if SelCount = 1 then
  13084.     Result := FDragImage else
  13085.     Result := nil;
  13086. end;
  13087.  
  13088. procedure TCustomListView.WndProc(var Message: TMessage);
  13089. begin
  13090.   if not (csDesigning in ComponentState) and ((Message.Msg = WM_LBUTTONDOWN) or
  13091.     (Message.Msg = WM_LBUTTONDBLCLK)) and not Dragging and (DragMode = dmAutomatic) then
  13092.   begin
  13093.     if not IsControlMouseMsg(TWMMouse(Message)) then
  13094.     begin
  13095.       ControlState := ControlState + [csLButtonDown];
  13096.       Dispatch(Message);
  13097.     end;
  13098.   end
  13099.   else if not (((Message.Msg = WM_PAINT) or (Message.Msg = WM_ERASEBKGND)) and
  13100.     Items.FNoRedraw) then
  13101.     inherited WndProc(Message);
  13102. end;
  13103.  
  13104. procedure TCustomListView.DoStartDrag(var DragObject: TDragObject);
  13105. var
  13106.   P, P1: TPoint;
  13107.   ImageHandle: HImageList;
  13108.   DragItem: TListItem;
  13109. begin
  13110.   inherited DoStartDrag(DragObject);
  13111.   FLastDropTarget := nil;
  13112.   GetCursorPos(P);
  13113.   P := ScreenToClient(P);
  13114.   if FDragIndex <> -1 then
  13115.     DragItem := Items[FDragIndex]
  13116.     else DragItem := nil;
  13117.   FDragIndex := -1;
  13118.   if DragItem = nil then
  13119.     with P do DragItem := GetItemAt(X, Y);
  13120.   if DragItem <> nil then
  13121.   begin
  13122.     ImageHandle := ListView_CreateDragImage(Handle, DragItem.Index, P1);
  13123.     if ImageHandle <> 0 then
  13124.       with FDragImage do
  13125.       begin
  13126.         Handle := ImageHandle;
  13127.         with P, DragItem.DisplayRect(drBounds) do
  13128.           SetDragImage(0, X - Left , Y - Top);
  13129.       end;
  13130.   end;
  13131. end;
  13132.  
  13133. procedure TCustomListView.DoEndDrag(Target: TObject; X, Y: Integer);
  13134.  
  13135. begin
  13136.   inherited DoEndDrag(Target, X, Y);
  13137.   FLastDropTarget := nil;
  13138. end;
  13139.  
  13140. procedure TCustomListView.CMDrag(var Message: TCMDrag);
  13141. var
  13142.   I: Integer;
  13143.   Item: TListItem;
  13144. begin
  13145.   inherited;
  13146.   with Message, DragRec^ do
  13147.     case DragMessage of
  13148.       dmDragMove: with ScreenToClient(Pos) do DoDragOver(Source, X, Y, Message.Result <> 0);
  13149.       dmDragLeave:
  13150.         begin
  13151.           TDragObject(Source).HideDragImage;
  13152.           FLastDropTarget := DropTarget;
  13153.           DropTarget := nil;
  13154.           Update;
  13155.           TDragObject(Source).ShowDragImage;
  13156.         end;
  13157.       dmDragDrop:
  13158.         begin
  13159.           FLastDropTarget := nil;
  13160.           { ListView_GetNextItem always returns nil for OwnerData = True and
  13161.             LVNI_ALL and LVNI_DROPHIGHLITED, so it is necessary to find the
  13162.             DropTarget and reset it by iterating through all items, starting
  13163.             with the first one that's visible }
  13164.           if OwnerData then
  13165.           begin
  13166.             if ViewStyle in [vsIcon, vsSmallIcon] then
  13167.               Item := GetNearestItem(Point(0, 0), sdAll)
  13168.             else
  13169.               Item := TopItem;
  13170.             if Item <> nil then
  13171.             for I := Item.Index to Items.Count - 1 do
  13172.               if Items[I].DropTarget then
  13173.               begin
  13174.                 Items[I].DropTarget := False;
  13175.                 Exit;
  13176.               end;
  13177.             end;
  13178.         end;
  13179.     end
  13180. end;
  13181.  
  13182. procedure TCustomListView.DoDragOver(Source: TDragObject; X, Y: Integer; CanDrop: Boolean);
  13183. var
  13184.   Item: TListItem;
  13185.   Target: TListItem;
  13186. begin
  13187.   Item := GetItemAt(X, Y);
  13188.   if Item <> nil then
  13189.   begin
  13190.     Target := DropTarget;
  13191.     if (Item <> Target) or (Item = FLastDropTarget) then
  13192.     begin
  13193.       FLastDropTarget := nil;
  13194.       TDragObject(Source).HideDragImage;
  13195.       Update;
  13196.       if Target <> nil then
  13197.         Target.DropTarget := False;
  13198.       Item.DropTarget := CanDrop;
  13199.       Update;
  13200.       TDragObject(Source).ShowDragImage;
  13201.     end;
  13202.   end;
  13203. end;
  13204.  
  13205. procedure TCustomListView.SetItems(Value: TListItems);
  13206. begin
  13207.   FListItems.Assign(Value);
  13208. end;
  13209.  
  13210. procedure TCustomListView.SetListColumns(Value: TListColumns);
  13211. begin
  13212.   FListColumns.Assign(Value);
  13213. end;
  13214.  
  13215. function TCustomListView.CustomSort(SortProc: TLVCompare; lParam: Longint): Boolean;
  13216. begin
  13217.   Result := False;
  13218.   if HandleAllocated then
  13219.   begin
  13220.     if not Assigned(SortProc) then SortProc := @DefaultListViewSort;
  13221.     Result := ListView_SortItems(Handle, SortProc, lParam);
  13222.   end;
  13223. end;
  13224.  
  13225. function TCustomListView.AlphaSort: Boolean;
  13226. begin
  13227.   if HandleAllocated then
  13228.     Result := ListView_SortItems(Handle, @DefaultListViewSort, 0)
  13229.   else Result := False;
  13230. end;
  13231.  
  13232. procedure TCustomListView.SetSortType(Value: TSortType);
  13233. begin
  13234.   if SortType <> Value then
  13235.   begin
  13236.     FSortType := Value;
  13237.     if ((SortType in [stData, stBoth]) and Assigned(OnCompare)) or
  13238.       (SortType in [stText, stBoth]) then
  13239.       AlphaSort;
  13240.   end;
  13241. end;
  13242.  
  13243. function TCustomListView.GetVisibleRowCount: Integer;
  13244. begin
  13245.   if ViewStyle in [vsReport, vsList] then
  13246.     Result := ListView_GetCountPerPage(Handle)
  13247.   else Result := 0;
  13248. end;
  13249.  
  13250. function TCustomListView.GetViewOrigin: TPoint;
  13251. begin
  13252.   ListView_GetOrigin(Handle, Result);
  13253. end;
  13254.  
  13255. function TCustomListView.GetTopItem: TListItem;
  13256. var
  13257.   Index: Integer;
  13258. begin
  13259.   Result := nil;
  13260.   if not (ViewStyle in [vsSmallIcon, vsIcon]) then
  13261.   begin
  13262.     Index := ListView_GetTopIndex(Handle);
  13263.     if Index <> -1 then Result := Items[Index];
  13264.   end;
  13265. end;
  13266.  
  13267. function TCustomListView.GetBoundingRect: TRect;
  13268. begin
  13269.   ListView_GetViewRect(Handle, Result);
  13270. end;
  13271.  
  13272. procedure TCustomListView.Scroll(DX, DY: Integer);
  13273. begin
  13274.   ListView_Scroll(Handle, DX, DY);
  13275. end;
  13276.  
  13277. procedure TCustomListView.SetLargeImages(Value: TCustomImageList);
  13278. begin
  13279.   if LargeImages <> Value then
  13280.   begin
  13281.     if LargeImages <> nil then
  13282.       LargeImages.UnRegisterChanges(FLargeChangeLink);
  13283.     FLargeImages := Value;
  13284.     if LargeImages <> nil then
  13285.     begin
  13286.       LargeImages.RegisterChanges(FLargeChangeLink);
  13287.       LargeImages.FreeNotification(Self);
  13288.       SetImageList(LargeImages.Handle, LVSIL_NORMAL)
  13289.     end
  13290.     else SetImageList(0, LVSIL_NORMAL);
  13291.     Invalidate;
  13292.   end;
  13293. end;
  13294.  
  13295. procedure TCustomListView.SetSmallImages(Value: TCustomImageList);
  13296. begin
  13297.   if Value <> SmallImages then
  13298.   begin
  13299.     if SmallImages <> nil then
  13300.       SmallImages.UnRegisterChanges(FSmallChangeLink);
  13301.     FSmallImages := Value;
  13302.     if SmallImages <> nil then
  13303.     begin
  13304.       SmallImages.RegisterChanges(FSmallChangeLink);
  13305.       SmallImages.FreeNotification(Self);
  13306.       SetImageList(SmallImages.Handle, LVSIL_SMALL)
  13307.     end
  13308.     else SetImageList(0, LVSIL_SMALL);
  13309.     Invalidate;
  13310.   end;
  13311. end;
  13312.  
  13313. procedure TCustomListView.SetStateImages(Value: TCustomImageList);
  13314. begin
  13315.   if StateImages <> Value then
  13316.   begin
  13317.     if StateImages <> nil then
  13318.       StateImages.UnRegisterChanges(FStateChangeLink);
  13319.     FStateImages := Value;
  13320.     if CheckBoxes then SaveChecks;
  13321.     if StateImages <> nil then
  13322.     begin
  13323.       StateImages.RegisterChanges(FStateChangeLink);
  13324.       StateImages.FreeNotification(Self);
  13325.       SetImageList(StateImages.Handle, LVSIL_STATE);
  13326.       if CheckBoxes then RestoreChecks;
  13327.     end
  13328.     else
  13329.     begin
  13330.       SetImageList(0, LVSIL_STATE);
  13331.       if CheckBoxes then
  13332.       begin
  13333.         CheckBoxes := False;
  13334.         CheckBoxes := True;
  13335.       end;
  13336.     end;
  13337.     Invalidate;
  13338.   end;
  13339. end;
  13340.  
  13341. function TCustomListView.GetColumnFromIndex(Index: Integer): TListColumn;
  13342. begin
  13343.   Result := FListColumns[Index];
  13344. end;
  13345.  
  13346. function TCustomListView.FindCaption(StartIndex: Integer; Value: string;
  13347.   Partial, Inclusive, Wrap: Boolean): TListItem;
  13348. const
  13349.   FullString: array[Boolean] of Integer = (0, LVFI_PARTIAL);
  13350.   Wraps: array[Boolean] of Integer = (0, LVFI_WRAP);
  13351. var
  13352.   Info: TLVFindInfo;
  13353.   Index: Integer;
  13354. begin
  13355.   with Info do
  13356.   begin
  13357.     flags := LVFI_STRING or FullString[Partial] or Wraps[Wrap];
  13358.     psz := PChar(Value);
  13359.   end;
  13360.   if Inclusive then Dec(StartIndex);
  13361.   Index := ListView_FindItem(Handle, StartIndex, Info);
  13362.   if Index <> -1 then Result := Items[Index]
  13363.   else Result := nil;
  13364. end;
  13365.  
  13366. function TCustomListView.FindData(StartIndex: Integer; Value: Pointer;
  13367.   Inclusive, Wrap: Boolean): TListItem;
  13368. var
  13369.   I: Integer;
  13370.   Item: TListItem;
  13371. begin
  13372.   Result := nil;
  13373.   if Inclusive then Dec(StartIndex);
  13374.   for I := StartIndex + 1 to Items.Count - 1 do
  13375.   begin
  13376.     Item := Items[I];
  13377.     if (Item <> nil) and (Item.Data = Value) then
  13378.     begin
  13379.       Result := Item;
  13380.       Exit;
  13381.     end;
  13382.   end;
  13383.   if Wrap then
  13384.   begin
  13385.     if Inclusive then Inc(StartIndex);
  13386.     for I := 0 to StartIndex - 1 do
  13387.     begin
  13388.       Item := Items[I];
  13389.       if (Item <> nil) and (Item.Data = Value) then
  13390.       begin
  13391.         Result := Item;
  13392.         Exit;
  13393.       end;
  13394.     end;
  13395.   end;
  13396. end;
  13397.  
  13398. function TCustomListView.GetHitTestInfoAt(X, Y: Integer): THitTests;
  13399. var
  13400.   HitTest: TLVHitTestInfo;
  13401. begin
  13402.   Result := [];
  13403.   with HitTest do
  13404.   begin
  13405.     pt.X := X;
  13406.     pt.Y := Y;
  13407.     ListView_HitTest(Handle, HitTest);
  13408.  
  13409.     //! WINBUG: LVHT_ABOVE and LVHT_ONITEMSTATEICON have the same value!
  13410.     //! We can determine whether a LVHT_ABOVE ocurred ourselves by checking
  13411.     //! whether the Y is below 0, and whether a LVHT_ONITEMSTATEICON ocurred
  13412.     //! by
  13413.     if ((flags and LVHT_ABOVE) <> 0) and (Y < 0) then Include(Result, htAbove);
  13414.     if (flags and LVHT_BELOW) <> 0 then Include(Result, htBelow);
  13415.     if (flags and LVHT_NOWHERE) <> 0 then Include(Result, htNowhere);
  13416.     if (flags and LVHT_ONITEM) = LVHT_ONITEM then
  13417.       Include(Result, htOnItem)
  13418.     else
  13419.     begin
  13420.       if (flags and LVHT_ONITEMICON) <> 0 then Include(Result, htOnIcon);
  13421.       if (flags and LVHT_ONITEMLABEL) <> 0 then Include(Result, htOnLabel);
  13422.       if (flags and LVHT_ONITEMSTATEICON) <> 0 then Include(Result, htOnStateIcon);
  13423.     end;
  13424.     if (flags and LVHT_TOLEFT) <> 0 then Include(Result, htToLeft);
  13425.     if (flags and LVHT_TORIGHT) <> 0 then Include(Result, htToRight);
  13426.   end;
  13427. end;
  13428.  
  13429. function TCustomListView.GetSelection: TListItem;
  13430. begin
  13431.   Result := GetNextItem(nil, sdAll, [isSelected]);
  13432. end;
  13433.  
  13434. procedure TCustomListView.SetSelection(Value: TListItem);
  13435. var
  13436.   I: Integer;
  13437. begin
  13438.   if Value <> nil then Value.Selected := True
  13439.   else begin
  13440.     Value := Selected;
  13441.     for I := 0 to SelCount - 1 do
  13442.       if Value <> nil then
  13443.       begin
  13444.         Value.Selected := False;
  13445.         Value := GetNextItem(Value, sdAll, [isSelected]);
  13446.       end;
  13447.   end;
  13448. end;
  13449.  
  13450. function TCustomListView.GetDropTarget: TListItem;
  13451. begin
  13452.   Result := GetNextItem(nil, sdAll, [isDropHilited]);
  13453.   if Result = nil then
  13454.     Result := FLastDropTarget;
  13455. end;
  13456.  
  13457. procedure TCustomListView.SetDropTarget(Value: TListItem);
  13458. begin
  13459.   if HandleAllocated then
  13460.     if Value <> nil then Value.DropTarget := True
  13461.     else begin
  13462.       Value := DropTarget;
  13463.       if Value <> nil then Value.DropTarget := False;
  13464.     end;
  13465. end;
  13466.  
  13467. function TCustomListView.GetFocused: TListItem;
  13468. begin
  13469.   Result := GetNextItem(nil, sdAll, [isFocused]);
  13470. end;
  13471.  
  13472. procedure TCustomListView.SetFocused(Value: TListItem);
  13473. begin
  13474.   if HandleAllocated then
  13475.     if Value <> nil then Value.Focused := True
  13476.     else begin
  13477.       Value := ItemFocused;
  13478.       if Value <> nil then Value.Focused := False;
  13479.     end;
  13480. end;
  13481.  
  13482. procedure TCustomListView.GetImageIndex(Item: TListItem);
  13483. begin
  13484.   if Assigned(FOnGetImageIndex) then FOnGetImageIndex(Self, Item);
  13485. end;
  13486.  
  13487. function TCustomListView.GetNextItem(StartItem: TListItem;
  13488.   Direction: TSearchDirection; States: TItemStates): TListItem;
  13489. var
  13490.   Flags, Index: Integer;
  13491. begin
  13492.   Result := nil;
  13493.   if HandleAllocated then
  13494.   begin
  13495.     Flags := 0;
  13496.     case Direction of
  13497.       sdAbove: Flags := LVNI_ABOVE;
  13498.       sdBelow: Flags := LVNI_BELOW;
  13499.       sdLeft: Flags := LVNI_TOLEFT;
  13500.       sdRight: Flags := LVNI_TORIGHT;
  13501.       sdAll: Flags := LVNI_ALL;
  13502.     end;
  13503.     if StartItem <> nil then Index := StartItem.Index
  13504.     else Index := -1;
  13505.     if isCut in States then Flags := Flags or LVNI_CUT;
  13506.     if isDropHilited in States then Flags := Flags or LVNI_DROPHILITED;
  13507.     if isFocused in States then Flags := Flags or LVNI_FOCUSED;
  13508.     if isSelected in States then Flags := Flags or LVNI_SELECTED;
  13509.     Index := ListView_GetNextItem(Handle, Index, Flags);
  13510.     if Index <> -1 then Result := Items[Index];
  13511.   end;
  13512. end;
  13513.  
  13514. function TCustomListView.GetNearestItem(Point: TPoint;
  13515.   Direction: TSearchDirection): TListItem;
  13516. const
  13517.   Directions: array[TSearchDirection] of Integer = (VK_LEFT, VK_RIGHT,
  13518.     VK_UP, VK_DOWN, 0);
  13519. var
  13520.   Info: TLVFindInfo;
  13521.   Index: Integer;
  13522. begin
  13523.   with Info do
  13524.   begin
  13525.     flags := LVFI_NEARESTXY;
  13526.     pt := Point;
  13527.     vkDirection := Directions[Direction];
  13528.   end;
  13529.   Index := ListView_FindItem(Handle, -1, Info);
  13530.   if Index <> -1 then Result := Items[Index]
  13531.   else Result := nil;
  13532. end;
  13533.  
  13534. function TCustomListView.GetItemAt(X, Y: Integer): TListItem;
  13535. var
  13536.   Info: TLVHitTestInfo;
  13537. var
  13538.   Index: Integer;
  13539. begin
  13540.   Result := nil;
  13541.   if HandleAllocated then
  13542.   begin
  13543.     Info.pt := Point(X, Y);
  13544.     Index := ListView_HitTest(Handle, Info);
  13545.     if Index <> -1 then Result := Items[Index];
  13546.   end;
  13547. end;
  13548.  
  13549. procedure TCustomListView.Arrange(Code: TListArrangement);
  13550. const
  13551.   Codes: array[TListArrangement] of Longint = (LVA_ALIGNBOTTOM, LVA_ALIGNLEFT,
  13552.     LVA_ALIGNRIGHT, LVA_ALIGNTOP, LVA_DEFAULT, LVA_SNAPTOGRID);
  13553. begin
  13554.   ListView_Arrange(Handle, Codes[Code]);
  13555. end;
  13556.  
  13557. function TCustomListView.StringWidth(S: string): Integer;
  13558. begin
  13559.   Result := ListView_GetStringWidth(Handle, PChar(S));
  13560. end;
  13561.  
  13562. procedure TCustomListView.UpdateColumns;
  13563. var
  13564.   I: Integer;
  13565. begin
  13566.   if HandleAllocated and not FUpdatingColumnOrder then
  13567.     for I := 0 to Columns.Count - 1 do UpdateColumn(I);
  13568. end;
  13569.  
  13570. procedure TCustomListView.UpdateColumn(AnIndex: Integer);
  13571. const IAlignment: array[Boolean, TAlignment] of LongInt =
  13572.   ((LVCFMT_LEFT, LVCFMT_RIGHT, LVCFMT_CENTER),
  13573.    (LVCFMT_RIGHT, LVCFMT_LEFT, LVCFMT_CENTER));
  13574. var
  13575.   Column: TLVColumn;
  13576.   AAlignment: TAlignment;
  13577. begin
  13578.   if HandleAllocated then
  13579.     with Column, Columns.Items[AnIndex] do
  13580.     begin
  13581.       mask := LVCF_TEXT or LVCF_FMT or LVCF_IMAGE;
  13582.       iImage := FImageIndex;
  13583.       pszText := PChar(Caption);
  13584.       AAlignment := Alignment;
  13585.       if Index <> 0 then
  13586.         fmt := IAlignment[UseRightToLeftAlignment, AAlignment]
  13587.       else fmt := LVCFMT_LEFT;
  13588.       if FImageIndex <> -1 then
  13589.         fmt := fmt or LVCFMT_IMAGE or LVCFMT_COL_HAS_IMAGES;
  13590.       if WidthType > ColumnTextWidth then
  13591.       begin
  13592.         mask := mask or LVCF_WIDTH;
  13593.         cx := FWidth;
  13594.         ListView_SetColumn(Handle, Columns[AnIndex].FOrderTag, Column);
  13595.       end
  13596.       else begin
  13597.         ListView_SetColumn(Handle, Columns[AnIndex].FOrderTag, Column);
  13598.       if ViewStyle = vsList then
  13599.           ListView_SetColumnWidth(Handle, -1, WidthType)
  13600.       else if (ViewStyle = vsReport) and not OwnerData then
  13601.           ListView_SetColumnWidth(Handle, Columns[AnIndex].FOrderTag, WidthType);
  13602.       end;
  13603.     end;
  13604. end;
  13605.  
  13606. procedure TCustomListView.WMLButtonDown(var Message: TWMLButtonDown);
  13607. var
  13608.   Item: TListItem;
  13609.   MousePos: TPoint;
  13610.   ShiftState: TShiftState;
  13611. begin
  13612.   SetFocus;
  13613.   ShiftState := KeysToShiftState(Message.Keys);
  13614.   FClicked := False;
  13615.   FDragIndex := -1;
  13616.   inherited;
  13617.   if (DragMode = dmAutomatic) and MultiSelect then
  13618.   begin
  13619.     if not (ssShift in ShiftState) and not (ssCtrl in ShiftState) then
  13620.     begin
  13621.       if not FClicked then
  13622.       begin
  13623.         Item := GetItemAt(Message.XPos, Message.YPos);
  13624.         if (Item <> nil) and Item.Selected then
  13625.         begin
  13626.           BeginDrag(False);
  13627.           Exit;
  13628.         end;
  13629.       end;
  13630.     end;
  13631.   end;
  13632.   if FClicked then
  13633.   begin
  13634.     GetCursorPos(MousePos);
  13635.     with PointToSmallPoint(ScreenToClient(MousePos)) do
  13636.       if not Dragging then
  13637.       begin
  13638.         Perform(WM_LBUTTONUP, 0, MakeLong(X, Y));
  13639.         FClicked := False;
  13640.       end
  13641.       else SendMessage(GetCapture, WM_LBUTTONUP, 0, MakeLong(X, Y));
  13642.   end
  13643.   else if (DragMode = dmAutomatic) and not (MultiSelect and
  13644.     ((ssShift in ShiftState) or (ssCtrl in ShiftState))) then
  13645.   begin
  13646.     Item := GetItemAt(Message.XPos, Message.YPos);
  13647.     if (Item <> nil) and Item.Selected then
  13648.       BeginDrag(False);
  13649.   end;
  13650. end;
  13651.  
  13652. procedure TCustomListView.DoAutoSize;
  13653. var
  13654.   I, Count, WorkWidth, TmpWidth, Remain: Integer;
  13655.   List: TList;
  13656.   Column: TListColumn;
  13657. begin
  13658.   { Try to fit all sections within client width }
  13659.   List := TList.Create;
  13660.   try
  13661.     WorkWidth := ClientWidth;
  13662.     for I := 0 to Columns.Count - 1 do
  13663.     begin
  13664.       Column := Columns[I];
  13665.       if Column.AutoSize then
  13666.         List.Add(Column)
  13667.       else
  13668.         Dec(WorkWidth, Column.Width);
  13669.     end;
  13670.     if List.Count > 0 then
  13671.     begin
  13672.       Columns.BeginUpdate;
  13673.       try
  13674.         repeat
  13675.           Count := List.Count;
  13676.           Remain := WorkWidth mod Count;
  13677.           { Try to redistribute sizes to those sections which can take it }
  13678.           TmpWidth := WorkWidth div Count;
  13679.           for I := Count - 1 downto 0 do
  13680.           begin
  13681.             Column := TListColumn(List[I]);
  13682.             if I = 0 then
  13683.               Inc(TmpWidth, Remain);
  13684.             Column.Width := TmpWidth;
  13685.           end;
  13686.  
  13687.           { Verify new sizes don't conflict with min/max section widths and
  13688.             adjust if necessary. }
  13689.           TmpWidth := WorkWidth div Count;
  13690.           for I := Count - 1 downto 0 do
  13691.           begin
  13692.             Column := TListColumn(List[I]);
  13693.             if I = 0 then
  13694.               Inc(TmpWidth, Remain);
  13695.             if Column.Width <> TmpWidth then
  13696.             begin
  13697.               List.Delete(I);
  13698.               Dec(WorkWidth, Column.Width);
  13699.             end;
  13700.           end;
  13701.         until (List.Count = 0) or (List.Count = Count);
  13702.       finally
  13703.         Columns.EndUpdate;
  13704.       end;
  13705.     end;
  13706.   finally
  13707.     List.Free;
  13708.   end;
  13709. end;
  13710.  
  13711. procedure TCustomListView.WMWindowPosChanged(var Message: TWMWindowPosChanged);
  13712. begin
  13713.   if not (csReading in ComponentState) and
  13714.      (Message.WindowPos^.flags and SWP_NOSIZE = 0) and HandleAllocated then
  13715.     DoAutoSize;
  13716.   inherited;
  13717. end;
  13718.  
  13719. function TCustomListView.GetSearchString: string;
  13720. var
  13721.   Buffer: array[0..1023] of char;
  13722. begin
  13723.   Result := '';
  13724.   if HandleAllocated and ListView_GetISearchString(Handle, Buffer) then
  13725.     Result := Buffer;
  13726. end;
  13727.  
  13728. procedure TCustomListView.CNDrawItem(var Message: TWMDrawItem);
  13729. var
  13730.   State: TOwnerDrawState;
  13731.   SaveIndex: Integer;
  13732. begin
  13733.   with Message.DrawItemStruct^ do
  13734.   begin
  13735.     State := TOwnerDrawState(LongRec(itemState).Lo);
  13736.     SaveIndex := SaveDC(hDC);
  13737.     FCanvas.Lock;
  13738.     try
  13739.       FCanvas.Handle := hDC;
  13740.       FCanvas.Font := Font;
  13741.       FCanvas.Brush := Brush;
  13742.       if itemID = DWORD(-1) then FCanvas.FillRect(rcItem)
  13743.       else DrawItem(Items[itemID], rcItem, State);
  13744.     finally
  13745.       FCanvas.Handle := 0;
  13746.       FCanvas.Unlock;
  13747.       RestoreDC(hDC, SaveIndex);
  13748.     end;
  13749.   end;
  13750.   Message.Result := 1;
  13751. end;
  13752.  
  13753. { CustomDraw support }
  13754.  
  13755. procedure TCustomListView.CanvasChanged;
  13756. begin
  13757.   FCanvasChanged := True;
  13758. end;
  13759.  
  13760. function TCustomListView.IsCustomDrawn(Target: TCustomDrawTarget;
  13761.   Stage: TCustomDrawStage): Boolean;
  13762. begin
  13763.   { List view doesn't support erase notifications }
  13764.   if Stage = cdPrePaint then
  13765.   begin
  13766.     if Target = dtSubItem then
  13767.       Result := Assigned(FOnCustomDrawSubItem) or Assigned(FOnAdvancedCustomDrawSubItem)
  13768.     else if Target = dtItem then
  13769.       Result := Assigned(FOnCustomDrawItem) or Assigned(FOnAdvancedCustomDrawItem) or
  13770.         Assigned(FOnCustomDrawSubItem) or Assigned(FOnAdvancedCustomDrawSubItem)
  13771.     else
  13772.       Result := Assigned(FOnCustomDraw) or Assigned(FOnAdvancedCustomDraw) or
  13773.         Assigned(FOnCustomDrawItem) or Assigned(FOnAdvancedCustomDrawItem) or
  13774.         Assigned(FOnCustomDrawSubItem) or Assigned(FOnAdvancedCustomDrawSubItem);
  13775.   end
  13776.   else
  13777.   begin
  13778.     if Target = dtSubItem then
  13779.       Result := Assigned(FOnAdvancedCustomDrawSubItem)
  13780.     else if Target = dtItem then
  13781.       Result := Assigned(FOnAdvancedCustomDrawItem) or Assigned(FOnAdvancedCustomDrawSubItem)
  13782.     else
  13783.       Result := Assigned(FOnAdvancedCustomDraw) or Assigned(FOnAdvancedCustomDrawItem) or
  13784.         Assigned(FOnAdvancedCustomDrawSubItem);
  13785.   end;
  13786. end;
  13787.  
  13788. function TCustomListView.CustomDraw(const ARect: TRect; Stage: TCustomDrawStage): Boolean;
  13789. begin
  13790.   Result := True;
  13791.   if (Stage = cdPrePaint) and Assigned(FOnCustomDraw) then FOnCustomDraw(Self, ARect, Result);
  13792.   if Assigned(FOnAdvancedCustomDraw) then FOnAdvancedCustomDraw(Self, ARect, Stage, Result)
  13793. end;
  13794.  
  13795. function TCustomListView.CustomDrawItem(Item: TListItem; State: TCustomDrawState;
  13796.   Stage: TCustomDrawStage): Boolean;
  13797. begin
  13798.   Result := True;
  13799.   if (Stage = cdPrePaint) and Assigned(FOnCustomDrawItem) then FOnCustomDrawItem(Self, Item, State, Result);
  13800.   if Assigned(FOnAdvancedCustomDrawItem) then FOnAdvancedCustomDrawItem(Self, Item, State, Stage, Result);
  13801. end;
  13802.  
  13803. function TCustomListView.CustomDrawSubItem(Item: TListItem; SubItem: Integer;
  13804.   State: TCustomDrawState; Stage: TCustomDrawStage): Boolean;
  13805. begin
  13806.   Result := True;
  13807.   if (Stage = cdPrePaint) and Assigned(FOnCustomDrawSubItem) then
  13808.     FOnCustomDrawSubItem(Self, Item, SubItem, State, Result);
  13809.   if Assigned(FOnAdvancedCustomDrawSubItem) then
  13810.     FOnAdvancedCustomDrawSubItem(Self, Item, SubItem, State, Stage, Result);
  13811. end;
  13812.  
  13813. procedure TCustomListView.DrawItem(Item: TListItem; Rect: TRect;
  13814.   State: TOwnerDrawState);
  13815. begin
  13816.   TControlCanvas(FCanvas).UpdateTextFlags;
  13817.   if Assigned(FOnDrawItem) then FOnDrawItem(Self, Item, Rect, State)
  13818.   else
  13819.   begin
  13820.     FCanvas.FillRect(Rect);
  13821.     FCanvas.TextOut(Rect.Left + 2, Rect.Top, Item.Caption);
  13822.   end;
  13823. end;
  13824.  
  13825. procedure TCustomListView.GetSubItemImage(Item: TListItem;
  13826.   SubItem: Integer; var ImageIndex: Integer);
  13827. begin
  13828.   if Assigned(FOnGetSubItemImage) and (SubItem < Item.SubItems.Count) and (SubItem >= 0) then
  13829.     FOnGetSubItemImage(Self, Item, SubItem, ImageIndex);
  13830. end;
  13831.  
  13832. procedure TCustomListView.DrawWorkAreas;
  13833. var
  13834.   I, dX, dY: Integer;
  13835.   R: TRect;
  13836. begin
  13837.   with FCanvas do
  13838.   begin
  13839.     Brush.Style := bsClear;
  13840.     for I := 0 to WorkAreas.Count-1 do
  13841.     begin
  13842.       Pen.Color := WorkAreas[I].Color;
  13843.       Pen.Style := psDot;
  13844.       dX := -GetViewOrigin.X;
  13845.       dY := -GetViewOrigin.Y;
  13846.       R := WorkAreas[I].Rect;
  13847.       OffsetRect(R, dX, dY);
  13848.       Rectangle(R.Left, R.Top, R.Right, R.Bottom);
  13849.       if WorkAreas[I].DisplayName <> '' then
  13850.       begin
  13851.         Pen.Style := psSolid;
  13852.         Font.Color := WorkAreas[I].Color;
  13853.         TextOut(R.Left, R.Bottom, WorkAreas[I].DisplayName);
  13854.       end;
  13855.     end;
  13856.   end;
  13857. end;
  13858.  
  13859. procedure TCustomListView.WMPaint(var Message: TWMPaint);
  13860. begin
  13861.   inherited;
  13862.   if (ViewStyle in [vsIcon, vsSmallIcon]) and FShowWorkAreas then
  13863.     DrawWorkAreas;
  13864. end;
  13865.  
  13866. procedure TCustomListView.SetShowWorkAreas(const Value: Boolean);
  13867. begin
  13868.   FShowWorkAreas := Value;
  13869.   Invalidate;
  13870. end;
  13871.  
  13872. { InfoTip support }
  13873.  
  13874. procedure TCustomListView.CMHintShow(var Message: TMessage);
  13875. var
  13876.   Item: TListItem;
  13877.   ItemRect: TRect;
  13878.   InfoTip: string;
  13879. begin
  13880.   if Assigned(FOnInfoTip) then
  13881.     with TCMHintShow(Message) do
  13882.     begin
  13883.       Item := GetItemAt(HintInfo.CursorPos.X, HintInfo.CursorPos.Y);
  13884.       if Item <> nil then
  13885.       begin
  13886.         InfoTip := Item.Caption;
  13887.         DoInfoTip(Item, InfoTip);
  13888.         ItemRect := Item.DisplayRect(drBounds);
  13889.         ItemRect.TopLeft := ClientToScreen(ItemRect.TopLeft);
  13890.         ItemRect.BottomRight := ClientToScreen(ItemRect.BottomRight);
  13891.         with HintInfo^ do
  13892.         begin
  13893.           HintInfo.CursorRect := ItemRect;
  13894.           HintInfo.HintStr := InfoTip;
  13895.           HintPos.Y := CursorRect.Top + GetSystemMetrics(SM_CYCURSOR);
  13896.           HintPos.X := CursorRect.Left + GetSystemMetrics(SM_CXCURSOR);
  13897.           HintInfo.HintMaxWidth := ClientWidth;
  13898.           Message.Result := 0;
  13899.         end
  13900.       end;
  13901.     end
  13902.   else
  13903.     inherited;
  13904. end;
  13905.  
  13906. procedure TCustomListView.DoInfoTip(Item: TListItem; var InfoTip: string);
  13907. begin
  13908.   if Assigned(FOnInfoTip) then FOnInfoTip(Self, Item, InfoTip);
  13909. end;
  13910.  
  13911. procedure TCustomListView.SetHoverTime(Value: Integer);
  13912. begin
  13913.   if Value <> GetHoverTime then
  13914.     ListView_SetHoverTime(Handle, Value);
  13915. end;
  13916.  
  13917. function TCustomListView.GetHoverTime: Integer;
  13918. begin
  13919.   Result := ListView_GetHoverTime(Handle);
  13920. end;
  13921.  
  13922. function TCustomListView.AreItemsStored: Boolean;
  13923. begin
  13924.   Result := not OwnerData;
  13925. end;
  13926.  
  13927. procedure TCustomListView.MouseUp(Button: TMouseButton; Shift: TShiftState;
  13928.   X, Y: Integer);
  13929. begin
  13930.   if (GetItemAt(X, Y) <> nil) or not FClicked then
  13931.     inherited;
  13932. end;
  13933.  
  13934. function TCustomListView.GetColumnFromTag(Tag: Integer): TListColumn;
  13935. var
  13936.   I: Integer;
  13937. begin
  13938.   for I := 0 to Columns.Count - 1 do
  13939.   begin
  13940.     Result := Columns[I];
  13941.     if Result.FOrderTag = Tag then Exit;
  13942.   end;
  13943.   Result := nil;
  13944. end;
  13945.  
  13946. procedure TCustomListView.WMContextMenu(var Message: TWMContextMenu);
  13947. var
  13948.   R: TRect;
  13949. begin
  13950.   if (Message.XPos < 0) and (Selected <> nil) then
  13951.   begin
  13952.     R := Selected.DisplayRect(drSelectBounds);
  13953.     Message.Pos := PointToSmallPoint(ClientToScreen(Point(R.Left, R.Bottom)));
  13954.   end;
  13955.   inherited;
  13956. end;
  13957.  
  13958. { TAnimate }
  13959.  
  13960. type
  13961.   TAnimateParams = record
  13962.     FileName: string;
  13963.     CommonAVI: TCommonAVI;
  13964.     ResHandle: THandle;
  13965.     ResName: string;
  13966.     ResId: Integer;
  13967.   end;
  13968.  
  13969. constructor TAnimate.Create(AOwner: TComponent);
  13970. begin
  13971.   inherited Create(AOwner);
  13972.   ControlStyle := ControlStyle + [csReflector];
  13973.   Width := 100;
  13974.   Height := 80;
  13975.   AutoSize := True;
  13976.   FCenter := True;
  13977.   FStartFrame := 1;
  13978.   FTransparent := True;
  13979. end;
  13980.  
  13981. procedure TAnimate.CreateParams(var Params: TCreateParams);
  13982. const
  13983.   CenterStyles: array[Boolean] of DWORD = (0, ACS_CENTER);
  13984.   TimerStyles: array[Boolean] of DWORD = (0, ACS_TIMER);
  13985.   TransparentStyles: array[Boolean] of DWORD = (0, ACS_TRANSPARENT);
  13986. begin
  13987.   InitCommonControl(ICC_ANIMATE_CLASS);
  13988.   inherited CreateParams(Params);
  13989.   { In versions of COMCTL32.DLL earlier than 4.71 the ANIMATE common control
  13990.     requires that it be created in the same instance address space as the AVI
  13991.     resource. }
  13992.   if GetComCtlVersion < ComCtlVersionIE4 then
  13993.     Params.WindowClass.hInstance := GetActualResHandle;
  13994.   CreateSubClass(Params, ANIMATE_CLASS);
  13995.   with Params do
  13996.   begin
  13997.     Style := Style or CenterStyles[FCenter] or TimerStyles[FTimers] or
  13998.       TransparentStyles[FTransparent];
  13999.     WindowClass.style := WindowClass.style and not (CS_HREDRAW or CS_VREDRAW);
  14000.     { Make sure window class is unique per instance if running a version of
  14001.       COMCTl32.DLL which doesn't support loading an AVI resource from a separate
  14002.       address space. }
  14003.     if GetComCtlVersion < ComCtlVersionIE4 then
  14004.       StrFmt(WinClassName, '%s.%.8X:%.8X', [ClassName, HInstance, GetCurrentThreadID]);
  14005.   end;
  14006. end;
  14007.  
  14008. procedure TAnimate.CreateWnd;
  14009. begin
  14010.   FRecreateNeeded := False;
  14011.   FOpen := False;
  14012.   inherited CreateWnd;
  14013.   UpdateActiveState;
  14014. end;
  14015.  
  14016. procedure TAnimate.DestroyWnd;
  14017. var
  14018.   OldActive, OldOpen: Boolean;
  14019. begin
  14020.   OldActive := FActive;
  14021.   OldOpen := FOpen;
  14022.   SetOpen(False);
  14023.   inherited DestroyWnd;
  14024.   FOpen := OldOpen;
  14025.   FActive := OldActive;
  14026. end;
  14027.  
  14028. procedure TAnimate.UpdateActiveState;
  14029. begin
  14030.   if not (csLoading in ComponentState) then
  14031.   begin
  14032.     { Attempt to open AVI and set active if applicable }
  14033.     SetOpen(True);
  14034.     if FActive then
  14035.     begin
  14036.       FActive := False;
  14037.       SetActive(True);
  14038.     end;
  14039.   end;
  14040. end;
  14041.  
  14042. procedure TAnimate.WMNCCalcSize(var Message: TWMNCCalcSize);
  14043. begin
  14044.   if csDesigning in ComponentState then
  14045.     with Message.CalcSize_Params^ do
  14046.       InflateRect(rgrc[0], -1, -1);
  14047.   inherited;
  14048. end;
  14049.  
  14050. procedure TAnimate.WMNCHitTest(var Message: TWMNCHitTest);
  14051. begin
  14052.   with Message do
  14053.     if not (csDesigning in ComponentState) then
  14054.       Result := HTCLIENT
  14055.     else
  14056.       inherited;
  14057. end;
  14058.  
  14059. procedure TAnimate.WMNCPaint(var Message: TMessage);
  14060. var
  14061.   DC: HDC;
  14062.   R: TRect;
  14063.   Pen, SavePen: HPEN;
  14064. begin
  14065.   if csDesigning in ComponentState then
  14066.   begin
  14067.     { Get window DC that is clipped to the non-client area }
  14068.     DC := GetDCEx(Handle, 0, DCX_WINDOW or DCX_CACHE or DCX_CLIPSIBLINGS);
  14069.     try
  14070.       GetWindowRect(Handle, R);
  14071.       OffsetRect(R, -R.Left, -R.Top);
  14072.       with R do
  14073.       begin
  14074.         ExcludeClipRect(DC, Left+1, Top+1, Right-1, Bottom-1);
  14075.         Pen := CreatePen(PS_DASH, 1, clBlack);
  14076.         SavePen := SelectObject(DC, Pen);
  14077.         SetBkColor(DC, ColorToRGB(Color));
  14078.         Rectangle(DC, R.Left, R.Top, R.Right, R.Bottom);
  14079.         if SavePen <> 0 then SelectObject(DC, SavePen);
  14080.         DeleteObject(Pen);
  14081.       end;
  14082.     finally
  14083.       ReleaseDC(Handle, DC);
  14084.     end;
  14085.   end
  14086.   else inherited;
  14087. end;
  14088.  
  14089. procedure TAnimate.WMSize(var Message: TWMSize);
  14090. begin
  14091.   inherited;
  14092. end;
  14093.  
  14094. procedure TAnimate.WMWindowPosChanged(var Message: TWMWindowPosChanged);
  14095. var
  14096.   R: TRect;
  14097. begin
  14098.   inherited;
  14099.   InvalidateRect(Handle, nil, True);
  14100.   R := Rect(0, 0, FrameWidth, FrameHeight);
  14101.   if Center then
  14102.     OffsetRect(R, (ClientWidth - (R.Right - R.Left)) div 2,
  14103.       (ClientHeight - (R.Bottom - R.Top)) div 2);
  14104.   ValidateRect(Handle, @R);
  14105.   UpdateWindow(Handle);
  14106.   InvalidateRect(Handle, @R, False);
  14107. end;
  14108.  
  14109. procedure TAnimate.CMColorChanged(var Message: TMessage);
  14110. begin
  14111.   inherited;
  14112.   if not (csLoading in ComponentState) then
  14113.     RecreateWnd;
  14114. end;
  14115.  
  14116. procedure TAnimate.CNCommand(var Message: TWMCommand);
  14117. begin
  14118.   inherited;
  14119.   case Message.NotifyCode of
  14120.     ACN_START: DoStart;
  14121.     ACN_STOP:
  14122.       if FStopCount = 0 then
  14123.         DoStop
  14124.       else
  14125.         Dec(FStopCount);
  14126.   end;
  14127. end;
  14128.  
  14129. procedure TAnimate.DoOpen;
  14130. begin
  14131.   if Assigned(FOnOpen) then FOnOpen(Self);
  14132. end;
  14133.  
  14134. procedure TAnimate.DoClose;
  14135. begin
  14136.   if Assigned(FOnClose) then FOnClose(Self);
  14137. end;
  14138.  
  14139. procedure TAnimate.DoStart;
  14140. begin
  14141.   if Assigned(FOnStart) then FOnStart(Self);
  14142. end;
  14143.  
  14144. procedure TAnimate.DoStop;
  14145. begin
  14146.   if Assigned(FOnStop) then FOnStop(Self);
  14147.   FActive := False;
  14148. end;
  14149.  
  14150. procedure TAnimate.Loaded;
  14151. begin
  14152.   inherited Loaded;
  14153.   if FStreamedActive then SetActive(True);
  14154. end;
  14155.  
  14156. procedure TAnimate.GetAnimateParams(var Params);
  14157. begin
  14158.   with TAnimateParams(Params) do
  14159.   begin
  14160.     FileName := FFileName;
  14161.     CommonAVI := FCommonAVI;
  14162.     ResHandle := FResHandle;
  14163.     ResName := FResName;
  14164.     ResId := FResId;
  14165.   end;
  14166. end;
  14167.  
  14168. procedure TAnimate.SetAnimateParams(const Params);
  14169. begin
  14170.   with TAnimateParams(Params) do
  14171.   begin
  14172.     FFileName := FileName;
  14173.     FCommonAVI := CommonAVI;
  14174.     FResHandle := ResHandle;
  14175.     FResName := ResName;
  14176.     FResId := ResId;
  14177.   end;
  14178. end;
  14179.  
  14180. function TAnimate.GetActualResHandle: THandle;
  14181. begin
  14182.   if FCommonAVI <> aviNone then Result := GetShellModule
  14183.   else if FResHandle <> 0 then Result := FResHandle
  14184.   else if MainInstance <> 0 then Result := MainInstance
  14185.   else Result := HInstance;
  14186. end;
  14187.  
  14188. function TAnimate.GetActualResId: Integer;
  14189. const
  14190.   CommonAVIId: array[TCommonAVI] of Integer = (0, 150, 151, 152, 160, 161, 162,
  14191.     163, 164);
  14192. begin
  14193.   if FCommonAVI <> aviNone then Result := CommonAVIId[FCommonAVI]
  14194.   else if FFileName <> '' then Result := Integer(FFileName)
  14195.   else if FResName <> '' then Result := Integer(FResName)
  14196.   else Result := FResId;
  14197. end;
  14198.  
  14199. procedure TAnimate.GetFrameInfo;
  14200.  
  14201.   function CreateResStream: TStream;
  14202.   const
  14203.     ResType = 'AVI';
  14204.   var
  14205.     Instance: THandle;
  14206.   begin
  14207.     { AVI is from a file }
  14208.     if FFileName <> '' then
  14209.       Result := TFileStream.Create(FFileName, fmShareDenyNone)
  14210.     else
  14211.     begin
  14212.       { AVI is from a resource }
  14213.       Instance := GetActualResHandle;
  14214.       if FResName <> '' then
  14215.         Result := TResourceStream.Create(Instance, FResName, ResType)
  14216.       else Result := TResourceStream.CreateFromID(Instance, GetActualResId, ResType);
  14217.     end;
  14218.   end;
  14219.  
  14220. const
  14221.   CountOffset = 48;
  14222.   WidthOffset = 64;
  14223.   HeightOffset = 68;
  14224. begin
  14225.   with CreateResStream do
  14226.   try
  14227.     if Seek(CountOffset, soFromBeginning) = CountOffset then
  14228.       ReadBuffer(FFrameCount, SizeOf(FFrameCount));
  14229.     if Seek(WidthOffset, soFromBeginning) = WidthOffset then
  14230.       ReadBuffer(FFrameWidth, SizeOf(FFrameWidth));
  14231.     if Seek(HeightOffset, soFromBeginning) = HeightOffset then
  14232.       ReadBuffer(FFrameHeight, SizeOf(FFrameHeight));
  14233.   finally
  14234.     Free;
  14235.   end;
  14236. end;
  14237.  
  14238. procedure TAnimate.SetActive(Value: Boolean);
  14239. begin
  14240.   if (csReading in ComponentState) then
  14241.   begin
  14242.     if Value then FStreamedActive := True;
  14243.   end
  14244.   else
  14245.   begin
  14246.     if FActive <> Value then
  14247.     begin
  14248.       if Value then
  14249.         Play(FStartFrame, FStopFrame, FRepetitions)
  14250.       else
  14251.         Stop;
  14252.     end;
  14253.   end;
  14254. end;
  14255.  
  14256. procedure TAnimate.SetCenter(Value: Boolean);
  14257. begin
  14258.   if FCenter <> Value then
  14259.   begin
  14260.     FCenter := Value;
  14261.     RecreateWnd;
  14262.   end;
  14263. end;
  14264.  
  14265. procedure TAnimate.SetCommonAVI(Value: TCommonAVI);
  14266. begin
  14267.   if FCommonAVI <> Value then
  14268.   begin
  14269.     FRecreateNeeded := (FCommonAVI = aviNone) and
  14270.       (GetComCtlVersion < ComCtlVersionIE4);
  14271.     FCommonAVI := Value;
  14272.     FFileName := '';
  14273.     FResHandle := 0;
  14274.     FResName := '';
  14275.     FResId := 0;
  14276.     if Value = aviNone then SetOpen(False) else Reset;
  14277.   end;
  14278. end;
  14279.  
  14280. procedure TAnimate.SetFileName(Value: string);
  14281. var
  14282.   Save: TAnimateParams;
  14283. begin
  14284.   if AnsiCompareText(FFileName, Value) <> 0 then
  14285.   begin
  14286.     GetAnimateParams(Save);
  14287.     try
  14288.       FFileName := Value;
  14289.       FCommonAVI := aviNone;
  14290.       FResHandle := 0;
  14291.       FResName := '';
  14292.       FResId := 0;
  14293.       if FFileName = '' then SetOpen(False) else Reset;
  14294.     except
  14295.       SetAnimateParams(Save);
  14296.       raise;
  14297.     end;
  14298.   end;
  14299. end;
  14300.  
  14301. procedure TAnimate.SetOpen(Value: Boolean);
  14302. begin
  14303.   if (FOpen <> Value) then
  14304.     if Value then
  14305.     begin
  14306.       FOpen := InternalOpen;
  14307.       if AutoSize then AdjustSize;
  14308.     end
  14309.     else FOpen := InternalClose;
  14310. end;
  14311.  
  14312. procedure TAnimate.SetRepetitions(Value: Integer);
  14313. begin
  14314.   if FRepetitions <> Value then
  14315.   begin
  14316.     FRepetitions := Value;
  14317.     if not (csLoading in ComponentState) then Stop;
  14318.   end;
  14319. end;
  14320.  
  14321. procedure TAnimate.SetResHandle(Value: THandle);
  14322. begin
  14323.   if FResHandle <> Value then
  14324.   begin
  14325.     FResHandle := Value;
  14326.     FRecreateNeeded := GetComCtlVersion < ComCtlVersionIE4;
  14327.     FCommonAVI := aviNone;
  14328.     FFileName := '';
  14329.     if FResHandle = 0 then SetOpen(False) else Reset;
  14330.   end;
  14331. end;
  14332.  
  14333. procedure TAnimate.SetResId(Value: Integer);
  14334. begin
  14335.   if FResId <> Value then
  14336.   begin
  14337.     FResId := Value;
  14338.     FRecreateNeeded := ((FCommonAVI <> aviNone) or (FFileName <> '')) and
  14339.       (GetComCtlVersion < ComCtlVersionIE4);
  14340.     FCommonAVI := aviNone;
  14341.     FFileName := '';
  14342.     FResName := '';
  14343.     if Value = 0 then SetOpen(False) else Reset;
  14344.   end;
  14345. end;
  14346.  
  14347. procedure TAnimate.SetResName(Value: string);
  14348. begin
  14349.   if FResName <> Value then
  14350.   begin
  14351.     FResName := Value;
  14352.     FRecreateNeeded := (FCommonAVI <> aviNone) or (FFileName <> '') and
  14353.       (GetComCtlVersion < ComCtlVersionIE4);
  14354.     FCommonAVI := aviNone;
  14355.     FFileName := '';
  14356.     FResId := 0;
  14357.     if Value = '' then SetOpen(False) else Reset;
  14358.   end;
  14359. end;
  14360.  
  14361. procedure TAnimate.SetStartFrame(Value: Smallint);
  14362. begin
  14363.   if FStartFrame <> Value then
  14364.   begin
  14365.     FStartFrame := Value;
  14366.     if not (csLoading in ComponentState) then
  14367.     begin
  14368.       Stop;
  14369.       Seek(Value);
  14370.     end;
  14371.   end;
  14372. end;
  14373.  
  14374. procedure TAnimate.SetStopFrame(Value: Smallint);
  14375. begin
  14376.   if FStopFrame <> Value then
  14377.   begin
  14378.     FStopFrame := Value;
  14379.     if not (csLoading in ComponentState) then Stop;
  14380.   end;
  14381. end;
  14382.  
  14383. procedure TAnimate.SetTimers(Value: Boolean);
  14384. begin
  14385.   if FTimers <> Value then
  14386.   begin
  14387.     FTimers := Value;
  14388.     RecreateWnd;
  14389.   end;
  14390. end;
  14391.  
  14392. procedure TAnimate.SetTransparent(Value: Boolean);
  14393. begin
  14394.   if FTransparent <> Value then
  14395.   begin
  14396.     FTransparent := Value;
  14397.     RecreateWnd;
  14398.   end;
  14399. end;
  14400.  
  14401. procedure TAnimate.CheckOpen;
  14402. begin
  14403.   SetOpen(True);
  14404.   if not Open then raise Exception.CreateRes(@SCannotOpenAVI);
  14405. end;
  14406.  
  14407. function TAnimate.InternalOpen: Boolean;
  14408. var
  14409.   R: TRect;
  14410. begin
  14411.   if FRecreateNeeded then RecreateWnd;
  14412.   HandleNeeded;
  14413.   { Preserve dimensions to prevent auto sizing }
  14414.   if not Center then R := BoundsRect;
  14415.   Result := Perform(ACM_OPEN, GetActualResHandle, GetActualResId) <> 0;
  14416.   { Restore dimensions in case control was resized }
  14417.   if not Center then BoundsRect := R;
  14418.   if Result then
  14419.   begin
  14420.     GetFrameInfo;
  14421.     FStartFrame := 1;
  14422.     FStopFrame := FFrameCount;
  14423.     DoOpen;
  14424.   end;
  14425. end;
  14426.  
  14427. function TAnimate.InternalClose: Boolean;
  14428. begin
  14429.   if FActive then Stop;
  14430.   Result := SendMessage(Handle, ACM_OPEN, 0, 0) <> 0;
  14431.   DoClose;
  14432.   Invalidate;
  14433. end;
  14434.  
  14435. procedure TAnimate.Play(FromFrame, ToFrame: Word; Count: Integer);
  14436. begin
  14437.   HandleNeeded;
  14438.   CheckOpen;
  14439.   FActive := True;
  14440.   { ACM_PLAY excpects -1 for repeated animations }
  14441.   if Count = 0 then Count := -1;
  14442.   if Perform(ACM_PLAY, Count, MakeLong(FromFrame - 1, ToFrame - 1)) <> 1 then
  14443.     FActive := False;
  14444. end;
  14445.  
  14446. procedure TAnimate.Reset;
  14447. begin
  14448.   if not (csLoading in ComponentState) then
  14449.   begin
  14450.     SetOpen(False);
  14451.     Seek(1);
  14452.   end;
  14453. end;
  14454.  
  14455. procedure TAnimate.Seek(Frame: Smallint);
  14456. begin
  14457.   CheckOpen;
  14458.   SendMessage(Handle, ACM_PLAY, 1, MakeLong(Frame - 1, Frame - 1));
  14459. end;
  14460.  
  14461. procedure TAnimate.Stop;
  14462. begin
  14463.   { Seek to first frame }
  14464.   SendMessage(Handle, ACM_PLAY, 1, MakeLong(StartFrame - 1, StartFrame - 1));
  14465.   FActive := False;
  14466.   Inc(FStopCount);
  14467.   DoStop;
  14468. end;
  14469.  
  14470. function TAnimate.CanAutoSize(var NewWidth, NewHeight: Integer): Boolean;
  14471. begin
  14472.   if Open then
  14473.   begin
  14474.     Result := True;
  14475.     NewWidth := FrameWidth;
  14476.     NewHeight := FrameHeight;
  14477.   end
  14478.   else Result := False;
  14479. end;
  14480.  
  14481. { TToolButton }
  14482.  
  14483. constructor TToolButton.Create(AOwner: TComponent);
  14484. begin
  14485.   inherited Create(AOwner);
  14486.   ControlStyle := [csCaptureMouse, csSetCaption, csClickEvents];
  14487.   Width := 23;
  14488.   Height := 22;
  14489.   FImageIndex := -1;
  14490.   FStyle := tbsButton;
  14491. end;
  14492.  
  14493. procedure TToolButton.MouseDown(Button: TMouseButton; Shift: TShiftState;
  14494.   X, Y: Integer);
  14495. begin
  14496.   if (Style = tbsDropDown) and (Button = mbLeft) and Enabled then
  14497.     Down := not Down;
  14498.   inherited MouseDown(Button, Shift, X, Y);
  14499. end;
  14500.  
  14501. procedure TToolButton.MouseMove(Shift: TShiftState; X, Y: Integer);
  14502. begin
  14503.   inherited MouseMove(Shift, X, Y);
  14504.   if (Style = tbsDropDown) and MouseCapture then
  14505.     Down := (X >= 0) and (X < ClientWidth) and (Y >= 0) and (Y <= ClientHeight);
  14506. end;
  14507.  
  14508. procedure TToolButton.MouseUp(Button: TMouseButton; Shift: TShiftState;
  14509.   X, Y: Integer);
  14510. begin
  14511.   inherited MouseUp(Button, Shift, X, Y);
  14512.   if (Button = mbLeft) and (X >= 0) and (X < ClientWidth) and (Y >= 0) and
  14513.     (Y <= ClientHeight) then
  14514.   if Style = tbsDropDown then Down := False;
  14515. end;
  14516.  
  14517. procedure TToolButton.Click;
  14518. begin
  14519.   inherited Click;
  14520. end;
  14521.  
  14522. procedure TToolButton.Notification(AComponent: TComponent;
  14523.   Operation: TOperation);
  14524. begin
  14525.   inherited Notification(AComponent, Operation);
  14526.   if Operation = opRemove then
  14527.   begin
  14528.     if AComponent = DropdownMenu then
  14529.       DropdownMenu := nil
  14530.     else if AComponent = MenuItem then
  14531.       MenuItem := nil;
  14532.   end;
  14533. end;
  14534.  
  14535. procedure TToolButton.CMTextChanged(var Message: TMessage);
  14536. begin
  14537.   inherited;
  14538.   UpdateControl;
  14539.   if not (csLoading in ComponentState) and (FToolBar <> nil) and FToolBar.ShowCaptions then
  14540.   begin
  14541.     FToolBar.FButtonWidth := 0;
  14542.     FToolBar.FButtonHeight := 0;
  14543.     FToolBar.RecreateButtons;
  14544.   end;
  14545. end;
  14546.  
  14547. procedure TToolButton.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);
  14548. var
  14549.   Pos: Integer;
  14550.   Reordered, NeedsUpdate: Boolean;
  14551.   ResizeWidth, ResizeHeight: Boolean;
  14552. begin
  14553.   if ((ALeft <> Left) or (ATop <> Top) or
  14554.     (AWidth <> Width) or (AHeight <> Height)) and
  14555.     (FUpdateCount = 0) and not (csLoading in ComponentState) and
  14556.     (FToolBar <> nil) then
  14557.   begin
  14558.     Pos := Index;
  14559.     Reordered := FToolBar.ReorderButton(Pos, ALeft, ATop) <> Pos;
  14560.     if Reordered then
  14561.     begin
  14562.       NeedsUpdate := False;
  14563.       if Index < Pos then Pos := Index
  14564.     end
  14565.     else
  14566.     begin
  14567.       NeedsUpdate := (Style in [tbsSeparator, tbsDivider]) and (AWidth <> Width);
  14568.       Reordered := NeedsUpdate;
  14569.     end;
  14570.     if (Style = tbsDropDown) and ((GetComCtlVersion >= ComCtlVersionIE4) or
  14571.       { IE3 doesn't display drop-down arrows }
  14572.       not FToolBar.Flat) then
  14573.         AWidth := FToolBar.ButtonWidth + AWidth - Width;
  14574.     ResizeWidth := not (Style in [tbsSeparator, tbsDivider]) and
  14575.       (AWidth <> FToolBar.ButtonWidth);
  14576.     ResizeHeight := AHeight <> FToolBar.ButtonHeight;
  14577.     if NeedsUpdate then inherited SetBounds(ALeft, ATop, AWidth, AHeight);
  14578.     if csDesigning in ComponentState then
  14579.     begin
  14580.       if ResizeWidth then FToolBar.ButtonWidth := AWidth;
  14581.       if ResizeHeight then FToolBar.ButtonHeight := AHeight;
  14582.     end;
  14583.     if Reordered and not ResizeWidth and not ResizeHeight then
  14584.     begin
  14585.       if NeedsUpdate then
  14586.         if Style in [tbsSeparator, tbsDivider] then
  14587.           FToolBar.RefreshButton(Pos)
  14588.         else
  14589.           FToolBar.UpdateButton(Pos);
  14590.       FToolBar.ResizeButtons;
  14591.       FToolBar.RepositionButtons(0);
  14592.     end
  14593.     else
  14594.       FToolBar.RepositionButton(Pos);
  14595.   end
  14596.   else inherited SetBounds(ALeft, ATop, AWidth, AHeight);
  14597. end;
  14598.  
  14599. procedure TToolButton.Paint;
  14600. const
  14601.   XorColor = $00FFD8CE;
  14602.   DropDownWidth = 14;
  14603. var
  14604.   R: TRect;
  14605. begin
  14606.   if FToolBar = nil then Exit;
  14607.   if (Style = tbsDropDown) and not FToolbar.Flat and not FToolBar.FMenuDropped
  14608.   and (GetComCtlVersion = ComCtlVersionIE5) then
  14609.   with Canvas do
  14610.   begin
  14611.     if not Down then
  14612.     begin
  14613.       R := Rect(Width - DropDownWidth, 1, Width, Height);
  14614.       DrawEdge(Handle, R, BDR_RAISEDOUTER, BF_TOP or BF_RIGHT or BF_BOTTOM);
  14615.       R.Top := 0;
  14616.       DrawEdge(Handle, R, EDGE_ETCHED, BF_LEFT);
  14617.     end
  14618.     else begin
  14619.       R := Rect(Width - DropDownWidth + 1, -1, Width, Height);
  14620.       DrawEdge(Handle, R, BDR_SUNKEN, BF_TOP or BF_RIGHT or BF_BOTTOM);
  14621.       DrawEdge(Handle, R, EDGE_ETCHED, BF_LEFT);
  14622.     end;
  14623.   end;
  14624.   if Style = tbsDivider then
  14625.     with Canvas do
  14626.     begin
  14627.       R := Rect(Width div 2 - 1, 0, Width, Height);
  14628.       DrawEdge(Handle, R, EDGE_ETCHED, BF_LEFT)
  14629.     end;
  14630.   if csDesigning in ComponentState then
  14631.     { Draw separator outline }
  14632.     if Style in [tbsSeparator, tbsDivider] then
  14633.       with Canvas do
  14634.       begin
  14635.         Pen.Style := psDot;
  14636.         Pen.Mode := pmXor;
  14637.         Pen.Color := XorColor;
  14638.         Brush.Style := bsClear;
  14639.         Rectangle(0, 0, ClientWidth, ClientHeight);
  14640.       end
  14641.     { Draw Flat button face }
  14642.     else if FToolBar.Flat and not Down then
  14643.       with Canvas do
  14644.       begin
  14645.         R := Rect(0, 0, Width, Height);
  14646.         DrawEdge(Handle, R, BDR_RAISEDINNER, BF_RECT);
  14647.       end;
  14648. end;
  14649.  
  14650. const
  14651.   ButtonStates: array[TToolButtonState] of Word = (TBSTATE_CHECKED,
  14652.     TBSTATE_PRESSED, TBSTATE_ENABLED, TBSTATE_HIDDEN, TBSTATE_INDETERMINATE,
  14653.     TBSTATE_WRAP, TBSTATE_ELLIPSES, TBSTATE_MARKED);
  14654.  
  14655.   ButtonStyles: array[TToolButtonStyle] of Word = (TBSTYLE_BUTTON, TBSTYLE_CHECK,
  14656.     TBSTYLE_DROPDOWN, TBSTYLE_SEP, TBSTYLE_SEP);
  14657.  
  14658. function TToolButton.GetButtonState: Byte;
  14659. begin
  14660.   Result := 0;
  14661.   if FDown then
  14662.     if Style = tbsCheck then
  14663.       Result := Result or ButtonStates[tbsChecked]
  14664.     else
  14665.       Result := Result or ButtonStates[tbsPressed];
  14666.   if Enabled and ((FToolBar = nil) or FToolBar.Enabled) then
  14667.     Result := Result or ButtonStates[tbsEnabled];
  14668.   if not Visible and not (csDesigning in ComponentState) then
  14669.     Result := Result or ButtonStates[tbsHidden];
  14670.   if FIndeterminate then Result := Result or ButtonStates[tbsIndeterminate];
  14671.   if FWrap then Result := Result or ButtonStates[tbsWrap];
  14672.   if FMarked then Result := Result or ButtonStates[tbsMarked];
  14673. end;
  14674.  
  14675. procedure TToolButton.SetAutoSize(Value: Boolean);
  14676. begin
  14677.   if Value <> AutoSize then
  14678.   begin
  14679.     FAutoSize := Value;
  14680.     UpdateControl;
  14681.     if not (csLoading in ComponentState) and (FToolBar <> nil) and
  14682.       FToolBar.ShowCaptions then
  14683.     begin
  14684.       FToolBar.FButtonWidth := 0;
  14685.       FToolBar.FButtonHeight := 0;
  14686.       FToolBar.RecreateButtons;
  14687.     end;
  14688.   end;
  14689. end;
  14690.  
  14691. procedure TToolButton.SetButtonState(State: Byte);
  14692. begin
  14693.   FDown := State and (TBSTATE_CHECKED or TBSTATE_PRESSED) <> 0;
  14694.   Enabled := State and TBSTATE_ENABLED <> 0;
  14695.   if not (csDesigning in ComponentState) then
  14696.     Visible := State and TBSTATE_HIDDEN = 0;
  14697.   FIndeterminate := not FDown and (State and TBSTATE_INDETERMINATE <> 0);
  14698.   FWrap := State and TBSTATE_WRAP <> 0;
  14699.   FMarked := State and TBSTATE_MARKED <> 0;
  14700. end;
  14701.  
  14702. procedure TToolButton.SetToolBar(AToolBar: TToolBar);
  14703. begin
  14704.   if FToolBar <> AToolBar then
  14705.   begin
  14706.     if FToolBar <> nil then FToolBar.RemoveButton(Self);
  14707.     Parent := AToolBar;
  14708.     if AToolBar <> nil then AToolBar.InsertButton(Self);
  14709.   end;
  14710. end;
  14711.  
  14712. procedure TToolButton.CMVisibleChanged(var Message: TMessage);
  14713. begin
  14714.   if not (csDesigning in ComponentState) and (FToolBar <> nil) then
  14715.   begin
  14716.     if FToolBar <> nil then
  14717.       with FToolBar do
  14718.       begin
  14719.         Perform(TB_HIDEBUTTON, Index, Longint(Ord(not Self.Visible)));
  14720.         { Force a resize to occur }
  14721.         if AutoSize then AdjustSize;
  14722.       end;
  14723.     UpdateControl;
  14724.     FToolBar.RepositionButtons(Index);
  14725.   end;
  14726. end;
  14727.  
  14728. procedure TToolButton.CMEnabledChanged(var Message: TMessage);
  14729. begin
  14730.   if FToolBar <> nil then
  14731.     FToolBar.Perform(TB_ENABLEBUTTON, Index, Ord(Enabled));
  14732. end;
  14733.  
  14734. procedure TToolButton.CMHitTest(var Message: TCMHitTest);
  14735. begin
  14736.   Message.Result := Ord(not (Style in [tbsDivider, tbsSeparator]) or (DragKind = dkDock));
  14737. end;
  14738.  
  14739. procedure TToolButton.SetDown(Value: Boolean);
  14740. const
  14741.   DownMessage: array[Boolean] of Integer = (TB_PRESSBUTTON, TB_CHECKBUTTON);
  14742. begin
  14743.   if Value <> FDown then
  14744.   begin
  14745.     FDown := Value;
  14746.     if FToolBar <> nil then
  14747.     begin
  14748.       FToolBar.Perform(DownMessage[Style = tbsCheck], Index, MakeLong(Ord(Value), 0));
  14749.       FToolBar.UpdateButtonStates;
  14750.     end;
  14751.   end;
  14752. end;
  14753.  
  14754. procedure TToolButton.SetDropdownMenu(Value: TPopupMenu);
  14755. begin
  14756.   if Value <> FDropdownMenu then
  14757.   begin
  14758.     FDropdownMenu := Value;
  14759.     if Value <> nil then Value.FreeNotification(Self);
  14760.   end;
  14761. end;
  14762.  
  14763. procedure TToolButton.SetGrouped(Value: Boolean);
  14764. begin
  14765.   if FGrouped <> Value then
  14766.   begin
  14767.     FGrouped := Value;
  14768.     UpdateControl;
  14769.   end;
  14770. end;
  14771.  
  14772. procedure TToolButton.SetImageIndex(Value: TImageIndex);
  14773. begin
  14774.   if FImageIndex <> Value then
  14775.   begin
  14776.     FImageIndex := Value;
  14777.     if FToolBar <> nil then
  14778.     begin
  14779.       RefreshControl;
  14780.       FToolBar.Perform(TB_CHANGEBITMAP, Index, Value);
  14781.       if FToolBar.Transparent or FToolBar.Flat then Invalidate;
  14782.     end;
  14783.   end;
  14784. end;
  14785.  
  14786. procedure TToolButton.SetMarked(Value: Boolean);
  14787. begin
  14788.   if FMarked <> Value then
  14789.   begin
  14790.     FMarked := Value;
  14791.     if FToolBar <> nil then
  14792.       FToolBar.Perform(TB_MARKBUTTON, Index, Longint(Ord(Value)));
  14793.   end;
  14794. end;
  14795.  
  14796. procedure TToolButton.SetIndeterminate(Value: Boolean);
  14797. begin
  14798.   if FIndeterminate <> Value then
  14799.   begin
  14800.     if Value then SetDown(False);
  14801.     FIndeterminate := Value;
  14802.     if FToolBar <> nil then
  14803.       FToolBar.Perform(TB_INDETERMINATE, Index, Longint(Ord(Value)));
  14804.   end;
  14805. end;
  14806.  
  14807. procedure TToolButton.SetMenuItem(Value: TMenuItem);
  14808. begin
  14809.   { Copy all appropriate values from menu item }
  14810.   if Value <> nil then
  14811.   begin
  14812.     if FMenuItem <> Value then
  14813.       Value.FreeNotification(Self);
  14814.     Action := Value.Action;
  14815.     Caption := Value.Caption;
  14816.     Down := Value.Checked;
  14817.     Enabled := Value.Enabled;
  14818.     Hint := Value.Hint;
  14819.     ImageIndex := Value.ImageIndex;
  14820.     Visible := Value.Visible;
  14821.   end;
  14822.   FMenuItem := Value;
  14823. end;
  14824.  
  14825. procedure TToolButton.SetStyle(Value: TToolButtonStyle);
  14826. begin
  14827.   if FStyle <> Value then
  14828.   begin
  14829.     FStyle := Value;
  14830.     Invalidate;
  14831.     if not (csLoading in ComponentState) and (FToolBar <> nil) then
  14832.     begin
  14833.       if FToolBar.ShowCaptions then
  14834.       begin
  14835.         FToolBar.FButtonWidth := 0;
  14836.         FToolBar.FButtonHeight := 0;
  14837.         FToolBar.RecreateButtons
  14838.       end
  14839.       else
  14840.       begin
  14841.         if Style in [tbsDivider, tbsSeparator] then
  14842.           RefreshControl
  14843.         else
  14844.         if Style = tbsDropDown then
  14845.           FToolbar.RecreateButtons
  14846.         else
  14847.           UpdateControl;
  14848.         FToolBar.ResizeButtons;
  14849.         FToolbar.RepositionButtons(Index);
  14850.       end;
  14851.       FToolBar.AdjustSize;
  14852.     end;
  14853.   end;
  14854. end;
  14855.  
  14856. procedure TToolButton.SetWrap(Value: Boolean);
  14857. begin
  14858.   if FWrap <> Value then
  14859.   begin
  14860.     FWrap := Value;
  14861.     if FToolBar <> nil then
  14862.       RefreshControl;
  14863.   end;
  14864. end;
  14865.  
  14866. procedure TToolButton.BeginUpdate;
  14867. begin
  14868.   Inc(FUpdateCount);
  14869. end;
  14870.  
  14871. procedure TToolButton.EndUpdate;
  14872. begin
  14873.   Dec(FUpdateCount);
  14874. end;
  14875.  
  14876. function TToolButton.GetIndex: Integer;
  14877. begin
  14878.   if FToolBar <> nil then
  14879.     Result := FToolBar.FButtons.IndexOf(Self)
  14880.   else
  14881.     Result := -1;
  14882. end;
  14883.  
  14884. function TToolButton.IsWidthStored: Boolean;
  14885. begin
  14886.   Result := Style in [tbsSeparator, tbsDivider];
  14887. end;
  14888.  
  14889. procedure TToolButton.RefreshControl;
  14890. begin
  14891.   if (FToolBar <> nil) and FToolBar.RefreshButton(Index) then
  14892.   begin
  14893. {    R := BoundsRect;
  14894.     R.Left := 0;
  14895.     ValidateRect(FToolBar.Handle, @R);
  14896.     R.Bottom := R.Top;
  14897.     R.Top := 0;
  14898.     R.Right := FToolBar.ClientWidth;
  14899.     ValidateRect(FToolBar.Handle, @R);}
  14900.   end;
  14901. end;
  14902.  
  14903. procedure TToolButton.UpdateControl;
  14904. begin
  14905.   if FToolBar <> nil then FToolBar.UpdateButton(Index);
  14906. end;
  14907.  
  14908. function TToolButton.CheckMenuDropdown: Boolean;
  14909. begin
  14910.   Result := not (csDesigning in ComponentState) and ((DropdownMenu <> nil) and
  14911.     DropdownMenu.AutoPopup or (MenuItem <> nil)) and (FToolBar <> nil) and
  14912.     FToolBar.CheckMenuDropdown(Self);
  14913. end;
  14914.  
  14915. function TToolButton.IsCheckedStored: Boolean;
  14916. begin
  14917.   Result := (ActionLink = nil) or not TToolButtonActionLink(ActionLink).IsCheckedLinked;
  14918. end;
  14919.  
  14920. function TToolButton.IsImageIndexStored: Boolean;
  14921. begin
  14922.   Result := (ActionLink = nil) or not TToolButtonActionLink(ActionLink).IsImageIndexLinked;
  14923. end;
  14924.  
  14925. procedure TToolButton.ActionChange(Sender: TObject; CheckDefaults: Boolean);
  14926. begin
  14927.   inherited ActionChange(Sender, CheckDefaults);
  14928.   if Sender is TCustomAction then
  14929.     with TCustomAction(Sender) do
  14930.     begin
  14931.       if not CheckDefaults or (Self.Down = False) then
  14932.         Self.Down := Checked;
  14933.       if not CheckDefaults or (Self.ImageIndex = -1) then
  14934.         Self.ImageIndex := ImageIndex;
  14935.     end;
  14936. end;
  14937.  
  14938. function TToolButton.GetActionLinkClass: TControlActionLinkClass;
  14939. begin
  14940.   Result := TToolButtonActionLink;
  14941. end;
  14942.  
  14943. procedure TToolButton.AssignTo(Dest: TPersistent);
  14944. begin
  14945.   inherited AssignTo(Dest);
  14946.   if Dest is TCustomAction then
  14947.     with TCustomAction(Dest) do
  14948.     begin
  14949.       Checked := Self.Down;
  14950.       ImageIndex := Self.ImageIndex;
  14951.     end;
  14952. end;
  14953.  
  14954. procedure TToolButton.ValidateContainer(AComponent: TComponent);
  14955. var
  14956.   W: Integer;
  14957. begin
  14958.   inherited ValidateContainer(AComponent);
  14959.   { Update non-stored Width and Height if inserting into TToolBar }
  14960.   if (csLoading in ComponentState) and (AComponent is TToolBar) then
  14961.   begin
  14962.     if Style in [tbsDivider, tbsSeparator] then
  14963.       W := Width else
  14964.       W := TToolBar(AComponent).ButtonWidth;
  14965.     SetBounds(Left, Top, W, TToolBar(AComponent).ButtonHeight);
  14966.   end;
  14967. end;
  14968.  
  14969. { TToolBar }
  14970.  
  14971. constructor TToolBar.Create(AOwner: TComponent);
  14972. begin
  14973.   inherited Create(AOwner);
  14974.   ControlStyle := [csAcceptsControls, csCaptureMouse, csClickEvents,
  14975.     csDoubleClicks, csMenuEvents, csSetCaption];
  14976.   Width := 150;
  14977.   Height := 29;
  14978.   Align := alTop;
  14979.   EdgeBorders := [ebTop];
  14980.   FButtonWidth := 23;
  14981.   FButtonHeight := 22;
  14982.   FNewStyle := True;
  14983.   FWrapable := True;
  14984.   FButtons := TList.Create;
  14985.   FCanvas := TControlCanvas.Create;
  14986.   TControlCanvas(FCanvas).Control := Self;
  14987.   FImageChangeLink := TChangeLink.Create;
  14988.   FImageChangeLink.OnChange := ImageListChange;
  14989.   FDisabledImageChangeLink := TChangeLink.Create;
  14990.   FDisabledImageChangeLink.OnChange := DisabledImageListChange;
  14991.   FHotImageChangeLink := TChangeLink.Create;
  14992.   FHotImageChangeLink.OnChange := HotImageListChange;
  14993.   FNullBitmap := TBitmap.Create;
  14994.   with FNullBitmap do
  14995.   begin
  14996.     Width := 1;
  14997.     Height := 1;
  14998.     Canvas.Brush.Color := clBtnFace;
  14999.     Canvas.FillRect(Rect(0,0,1,1));
  15000.   end;
  15001.   FloatingDockSiteClass := TToolDockForm;
  15002. end;
  15003.  
  15004. destructor TToolBar.Destroy;
  15005. var
  15006.   I: Integer;
  15007. begin
  15008.   FNullBitmap.Free;
  15009.   FHotImageChangeLink.Free;
  15010.   FDisabledImageChangeLink.Free;
  15011.   FImageChangeLink.Free;
  15012.   for I := 0 to FButtons.Count - 1 do
  15013.     if TControl(FButtons[I]) is TToolButton then
  15014.       TToolButton(FButtons[I]).FToolBar := nil;
  15015.   FButtons.Free;
  15016.   FCanvas.Free;
  15017.   inherited Destroy;
  15018. end;
  15019.  
  15020. procedure TToolBar.CreateParams(var Params: TCreateParams);
  15021. const
  15022.   TBSTYLE_TRANSPARENT = $8000;  // IE4 style
  15023.   DefaultStyles = CCS_NOPARENTALIGN or CCS_NOMOVEY or CCS_NORESIZE or CCS_NODIVIDER;
  15024.   ListStyles: array[Boolean] of DWORD = (0, TBSTYLE_LIST);
  15025.   FlatStyles: array[Boolean] of DWORD = (0, TBSTYLE_FLAT);
  15026.   TransparentStyles: array[Boolean] of DWORD = (0, TBSTYLE_TRANSPARENT);
  15027. begin
  15028.   FNewStyle := InitCommonControl(ICC_BAR_CLASSES);
  15029.   inherited CreateParams(Params);
  15030.   CreateSubClass(Params, TOOLBARCLASSNAME);
  15031.   with Params do
  15032.   begin
  15033.     Style := Style or DefaultStyles or FlatStyles[FFlat] or ListStyles[FList] or
  15034.       TransparentStyles[FTransparent];
  15035.     //! WINBUG: Without this style the toolbar is has a two pixel margin above
  15036.     //! the buttons when ShowCaptions = True.
  15037.     if ShowCaptions then
  15038.       Style := Style or TBSTYLE_TRANSPARENT;//!
  15039.     WindowClass.style := WindowClass.style and not (CS_HREDRAW or CS_VREDRAW);
  15040.   end;
  15041. end;
  15042.  
  15043. procedure TToolBar.CreateWnd;
  15044. const
  15045.   { IE4 support }
  15046.   TB_SETEXTENDEDSTYLE     = (WM_USER + 84); // For TBSTYLE_EX_*
  15047.   TB_GETEXTENDEDSTYLE     = (WM_USER + 85); // For TBSTYLE_EX_*
  15048.   TBSTYLE_EX_DRAWDDARROWS = $0001;          // IE4 toolbar style
  15049. var
  15050.   DisplayDC: HDC;
  15051.   SaveFont, StockFont: HFONT;
  15052.   TxtMetric: TTextMetric;
  15053. begin
  15054.   inherited CreateWnd;
  15055.   { Maintain backward compatibility with IE3 which always draws drop-down arrows
  15056.     for buttons in which Style = tbsDropDown. }
  15057.   if GetComCtlVersion >= ComCtlVersionIE4 then
  15058.     Perform(TB_SETEXTENDEDSTYLE, 0, Perform(TB_GETEXTENDEDSTYLE, 0, 0) or
  15059.       TBSTYLE_EX_DRAWDDARROWS);
  15060.   FOldHandle := 0;
  15061.   StockFont := GetStockObject(SYSTEM_FONT);
  15062.   if StockFont <> 0 then
  15063.   begin
  15064.     DisplayDC := GetDC(0);
  15065.     if (DisplayDC <> 0) then
  15066.     begin
  15067.       SaveFont := SelectObject(DisplayDC, StockFont);
  15068.       if (GetTextMetrics(DisplayDC, TxtMetric)) then
  15069.         with TxtMetric do
  15070.           FHeightMargin := tmHeight - tmInternalLeading - tmExternalLeading + 1;
  15071.       SelectObject(DisplayDC, SaveFont);
  15072.       ReleaseDC(0, DisplayDC);
  15073.     end;
  15074.   end;
  15075.   RecreateButtons;
  15076.   Invalidate;
  15077. end;
  15078.  
  15079. procedure TToolBar.CreateButtons(NewWidth, NewHeight: Integer);
  15080.  
  15081.   function ToolButtonVisible: Boolean;
  15082.   var
  15083.     I: Integer;
  15084.     Control: TControl;
  15085.   begin
  15086.     for I := 0 to FButtons.Count - 1 do
  15087.     begin
  15088.       Control := TControl(FButtons[I]);
  15089.       if (Control is TToolButton) and ((csDesigning in ComponentState) or
  15090.         Control.Visible) and not (TToolButton(Control).Style in
  15091.         [tbsSeparator, tbsDivider]) then
  15092.       begin
  15093.         Result := True;
  15094.         Exit;
  15095.       end;
  15096.     end;
  15097.     Result := False;
  15098.   end;
  15099.  
  15100. var
  15101.   ImageWidth, ImageHeight: Integer;
  15102.   I: Integer;
  15103. begin
  15104.   BeginUpdate;
  15105.   try
  15106.     HandleNeeded;
  15107.     Perform(TB_BUTTONSTRUCTSIZE, SizeOf(TTBButton), 0);
  15108.     Perform(TB_SETINDENT, FIndent, 0);
  15109.     if FImages <> nil then
  15110.     begin
  15111.       ImageWidth := FImages.Width;
  15112.       ImageHeight := FImages.Height;
  15113.     end
  15114.     else if FDisabledImages <> nil then
  15115.     begin
  15116.       ImageWidth := FDisabledImages.Width;
  15117.       ImageHeight := FDisabledImages.Height;
  15118.     end
  15119.     else if FHotImages <> nil then
  15120.     begin
  15121.       ImageWidth := FHotImages.Width;
  15122.       ImageHeight := FHotImages.Height;
  15123.     end
  15124.     else
  15125.     begin
  15126.       ImageWidth := 0;
  15127.       ImageHeight := 0;
  15128.     end;
  15129.     Perform(TB_SETBITMAPSIZE, 0, MakeLParam(ImageWidth, ImageHeight));
  15130.     { Adjust the working height if there is a visible TToolButton whose caption
  15131.       height is automatically added by the common control. }
  15132.     if ShowCaptions and ToolButtonVisible then Dec(NewHeight, FHeightMargin);
  15133.     { Prevent toolbar from setting default button size }
  15134.     if NewWidth <= 0 then NewWidth := 1;
  15135.     if NewHeight <= 0 then NewHeight := 1;
  15136.     Perform(TB_SETBUTTONSIZE, 0, MakeLParam(NewWidth, NewHeight));
  15137.     FButtonWidth := NewWidth;
  15138.     FButtonHeight := NewHeight;
  15139.   finally
  15140.     EndUpdate;
  15141.   end;
  15142.   { Retrieve current button sizes }
  15143.   for I := 0 to InternalButtonCount - 1 do Perform(TB_DELETEBUTTON, 0, 0);
  15144.   UpdateButtons;
  15145.   UpdateImages;
  15146.   GetButtonSize(FButtonWidth, FButtonHeight);
  15147. end;
  15148.  
  15149. procedure TToolBar.RepositionButton(Index: Integer);
  15150. var
  15151.   TBButton: TTBButton;
  15152.   Button: TControl;
  15153.   R: TRect;
  15154.   AdjustY: Integer;
  15155. begin
  15156.   if (csLoading in ComponentState) or
  15157.     (Perform(TB_GETBUTTON, Index, Longint(@TBButton)) = 0) then
  15158.     Exit;
  15159.   if Perform(TB_GETITEMRECT, Index, Longint(@R)) <> 0 then
  15160.   begin
  15161.     Button := TControl(TBButton.dwData);
  15162.     if Button is TToolButton then TToolButton(Button).BeginUpdate;
  15163.     try
  15164.       if not (Button is TToolButton) then
  15165.         with Button do
  15166.         begin
  15167.           if Button is TWinControl then HandleNeeded;
  15168.           { Check for a control that doesn't size and center it }
  15169.           BoundsRect := R;
  15170.           if Height < R.Bottom - R.Top then
  15171.           begin
  15172.             AdjustY := (R.Bottom - R.Top - Height) div 2;
  15173.             SetBounds(R.Left, R.Top + AdjustY, R.Right - R.Left, Height);
  15174.           end;
  15175.         end
  15176.       else
  15177.         Button.BoundsRect := R;
  15178.     finally
  15179.       if Button is TToolButton then TToolButton(Button).EndUpdate;
  15180.     end;
  15181.   end;
  15182. end;
  15183.  
  15184. procedure TToolBar.RepositionButtons(Index: Integer);
  15185. var
  15186.   I: Integer;
  15187. begin
  15188.   if (csLoading in ComponentState) or (FUpdateCount > 0) then Exit;
  15189.   BeginUpdate;
  15190.   try
  15191.     for I := InternalButtonCount - 1 downto Index do RepositionButton(I);
  15192.   finally
  15193.     EndUpdate;
  15194.   end;
  15195. end;
  15196.  
  15197. procedure TToolBar.GetButtonSize(var AWidth, AHeight: Integer);
  15198. var
  15199.   LastIndex: Integer;
  15200.   R: TRect;
  15201.   TBButton: TTBButton;
  15202. begin
  15203.   if HandleAllocated then
  15204.   begin
  15205.     if GetComCtlVersion >= ComCtlVersionIE3 then
  15206.     begin
  15207.       LastIndex := Perform(TB_GETBUTTONSIZE, 0, 0);
  15208.       AHeight := LastIndex shr 16;
  15209.       AWidth := LastIndex and $FFFF;
  15210.     end
  15211.     else
  15212.     begin
  15213.       LastIndex := InternalButtonCount - 1;
  15214.       if LastIndex < 0 then Exit;
  15215.       while (LastIndex >= 0) and
  15216.         (Perform(TB_GETBUTTON, LastIndex, Integer(@TBButton)) <> 0) and
  15217.         (TBButton.fsStyle and TBSTYLE_SEP <> 0) do
  15218.         Dec(LastIndex);
  15219.       if LastIndex < 0 then
  15220.       begin
  15221.         if Perform(TB_GETITEMRECT, 0, Longint(@R)) <> 0 then
  15222.           AHeight := R.Bottom - R.Top;
  15223.         Exit;
  15224.       end;
  15225.       if Perform(TB_GETITEMRECT, LastIndex, Longint(@R)) <> 0 then
  15226.       begin
  15227.         AHeight := R.Bottom - R.Top;
  15228.         AWidth := R.Right - R.Left;
  15229.       end;
  15230.     end;
  15231.   end;
  15232. end;
  15233.  
  15234. procedure TToolBar.SetButtonHeight(Value: Integer);
  15235. begin
  15236.   if Value <> FButtonHeight then
  15237.   begin
  15238.     FButtonHeight := Value;
  15239.     RecreateButtons;
  15240.   end;
  15241. end;
  15242.  
  15243. procedure TToolBar.SetButtonWidth(Value: Integer);
  15244. begin
  15245.   if Value <> FButtonWidth then
  15246.   begin
  15247.     FButtonWidth := Value;
  15248.     RecreateButtons;
  15249.   end;
  15250. end;
  15251.  
  15252. procedure TToolBar.InsertButton(Control: TControl);
  15253. var
  15254.   FromIndex, ToIndex: Integer;
  15255. begin
  15256.   if Control is TToolButton then TToolButton(Control).FToolBar := Self;
  15257.   if not (csLoading in Control.ComponentState) then
  15258.   begin
  15259.     FromIndex := FButtons.IndexOf(Control);
  15260.     if FromIndex >= 0 then
  15261.       ToIndex := ReorderButton(Fromindex, Control.Left, Control.Top)
  15262.     else
  15263.     begin
  15264.       ToIndex := ButtonIndex(FromIndex, Control.Left, Control.Top);
  15265.       FButtons.Insert(ToIndex, Control);
  15266.       UpdateItem(TB_INSERTBUTTON, ToIndex, ToIndex);
  15267.     end;
  15268.   end
  15269.   else
  15270.   begin
  15271.     ToIndex := FButtons.Add(Control);
  15272.     UpdateButton(ToIndex);
  15273.   end;
  15274.   if Wrapable then
  15275.     RepositionButtons(0)
  15276.   else
  15277.     RepositionButtons(ToIndex);
  15278.   RecreateButtons;
  15279. end;
  15280.  
  15281. procedure TToolBar.RemoveButton(Control: TControl);
  15282. var
  15283.   I, Pos: Integer;
  15284. begin
  15285.   I := FButtons.IndexOf(Control);
  15286.   if I >= 0 then
  15287.   begin
  15288.     if Control is TToolButton then TToolButton(Control).FToolBar := nil;
  15289.     Pos := FButtons.Remove(Control);
  15290.     Perform(TB_DELETEBUTTON, Pos, 0);
  15291.     ResizeButtons;
  15292.     if Wrapable then
  15293.       RepositionButtons(0)
  15294.     else
  15295.       RepositionButtons(Pos);
  15296.     RecreateButtons;
  15297.   end;
  15298. end;
  15299.  
  15300. function TToolBar.UpdateItem(Message, FromIndex, ToIndex: Integer): Boolean;
  15301. var
  15302.   Control: TControl;
  15303.   Button: TTBButton;
  15304.   CaptionText: string;
  15305.   Buffer: array[0..4095] of Char;
  15306. begin
  15307.   Control := TControl(FButtons[FromIndex]);
  15308.   if Control is TToolButton then
  15309.     with TToolButton(Control) do
  15310.     begin
  15311.       FillChar(Button, SizeOf(Button), 0);
  15312.       if Style in [tbsSeparator, tbsDivider] then
  15313.       begin
  15314.         Button.iBitmap := Width;
  15315.         Button.idCommand := -1;
  15316.       end
  15317.       else
  15318.       begin
  15319.         if ImageIndex < 0 then
  15320.           Button.iBitmap := -2 else
  15321.           Button.iBitmap := ImageIndex;
  15322.         Button.idCommand := FromIndex;
  15323.       end;
  15324.       with Button do
  15325.       begin
  15326.         fsStyle := ButtonStyles[Style];
  15327.         if AutoSize and (GetComCtlVersion >= ComCtlVersionIE4) then
  15328.           fsStyle := fsStyle or TBSTYLE_AUTOSIZE;
  15329.       end;
  15330.       Button.fsState := GetButtonState;
  15331.       if FGrouped then Button.fsStyle := Button.fsStyle or TBSTYLE_GROUP;
  15332.       Button.dwData := Longint(Control);
  15333.       if ShowCaptions then
  15334.       begin
  15335.         if Caption <> '' then
  15336.           CaptionText := Caption
  15337.         else
  15338.           { Common control requries at least a space is used when showing button
  15339.             captions.  If any one button's caption is empty (-1) then none of
  15340.             the buttons' captions will not be displayed. }
  15341.           CaptionText := ' ';
  15342.         StrPCopy(Buffer, CaptionText);
  15343.         { TB_ADDSTRING requires two null terminators }
  15344.         Buffer[Length(CaptionText) + 1] := #0;
  15345.         Button.iString := Self.Perform(TB_ADDSTRING, 0, Longint(@Buffer));
  15346.       end
  15347.       else
  15348.         Button.iString := -1;
  15349.     end
  15350.   else
  15351.   begin
  15352.     FillChar(Button, SizeOf(Button), 0);
  15353.     Button.fsStyle := ButtonStyles[tbsSeparator];
  15354.     Button.iBitmap := Control.Width;
  15355.     Button.idCommand := -1;
  15356.     if not Control.Visible and not (csDesigning in Control.ComponentState) then
  15357.       Button.fsState := Button.fsState or ButtonStates[tbsHidden];
  15358.     Button.dwData := Longint(Control);
  15359.     Button.iString := -1;
  15360.   end;
  15361.   Result := Self.Perform(Message, ToIndex, Integer(@Button)) <> 0;
  15362. end;
  15363.  
  15364. function TToolBar.UpdateItem2(Message, FromIndex, ToIndex: Integer): Boolean;
  15365. var
  15366.   Control: TControl;
  15367.   Button: TTBButtonInfo;
  15368.   CaptionText: string;
  15369.   Buffer: array[0..4095] of Char;
  15370. begin
  15371.   Control := TControl(FButtons[FromIndex]);
  15372.   FillChar(Button, SizeOf(Button), 0);
  15373.   Button.cbSize := SizeOf(Button);
  15374.   if Control is TToolButton then
  15375.     with TToolButton(Control) do
  15376.     begin
  15377.       Button.dwMask := TBIF_STATE or TBIF_STYLE or TBIF_LPARAM or TBIF_COMMAND
  15378.         or TBIF_SIZE;
  15379.       if Style in [tbsSeparator, tbsDivider] then
  15380.       begin
  15381.         Button.idCommand := -1;
  15382.       end
  15383.       else
  15384.       begin
  15385.         Button.dwMask := Button.dwMask or TBIF_IMAGE;
  15386.         if ImageIndex < 0 then
  15387.           Button.iImage := -2 else
  15388.           Button.iImage := ImageIndex;
  15389.         Button.idCommand := FromIndex;
  15390.       end;
  15391.       with Button do
  15392.       begin
  15393.         cx := Width;
  15394.         fsStyle := ButtonStyles[Style];
  15395.         if AutoSize then fsStyle := fsStyle or TBSTYLE_AUTOSIZE;
  15396.         if Grouped then Button.fsStyle := Button.fsStyle or TBSTYLE_GROUP;
  15397.       end;
  15398.       Button.fsState := GetButtonState;
  15399.       Button.lParam := Longint(Control);
  15400.       if ShowCaptions then
  15401.       begin
  15402.         if Caption <> '' then
  15403.           CaptionText := Caption
  15404.         else
  15405.           { Common control requries at least a space is used when showing button
  15406.             captions.  If any one button's caption is empty (-1) then none of
  15407.             the buttons' captions will not be displayed. }
  15408.           CaptionText := ' ';
  15409.         StrPCopy(Buffer, CaptionText);
  15410.         { TB_ADDSTRING requires two null terminators }
  15411.         Buffer[Length(CaptionText) + 1] := #0;
  15412.         //Button.iString := Self.Perform(TB_ADDSTRING, 0, Longint(@Buffer));
  15413.         Button.pszText := Buffer;
  15414.         Button.cchText := Length(CaptionText);
  15415.         Button.dwMask := Button.dwMask or TBIF_TEXT;
  15416.       end
  15417.       else
  15418.       begin
  15419.         Button.pszText := nil;
  15420.         Button.cchText := 0;
  15421.       end;
  15422.  
  15423. if Style in [tbsSeparator, tbsDivider] then
  15424. begin
  15425.   with Button do
  15426.   begin
  15427.     dwMask := TBIF_STYLE or TBIF_STATE or TBIF_LPARAM;
  15428.     fsState := TBSTATE_ENABLED or TBSTATE_WRAP;
  15429.     fsStyle := TBSTYLE_BUTTON;
  15430.   end;
  15431. end;
  15432.  
  15433.     end
  15434.   else
  15435.   begin
  15436.     Button.dwMask := TBIF_TEXT or TBIF_STATE or TBIF_STYLE or TBIF_LPARAM or
  15437.       TBIF_COMMAND or TBIF_SIZE;
  15438.     Button.fsStyle := ButtonStyles[tbsSeparator];
  15439.     Button.cx := Control.Width;
  15440.     Button.idCommand := -1;
  15441.     Button.lParam := Longint(Control);
  15442.     Button.pszText := nil;
  15443.     Button.cchText := 0;
  15444.   end;
  15445.   Result := Self.Perform(Message, ToIndex, Integer(@Button)) <> 0;
  15446. end;
  15447.  
  15448. function TToolBar.RefreshButton(Index: Integer): Boolean;
  15449. var
  15450.   Style: Longint;
  15451. begin
  15452.   if not (csLoading in ComponentState) and (FUpdateCount = 0) then
  15453.   begin
  15454.     BeginUpdate;
  15455.     try
  15456.       Style := GetWindowLong(Handle, GWL_STYLE);
  15457.       SetWindowLong(Handle, GWL_STYLE, Style and not WS_VISIBLE);
  15458.       try
  15459.         Result := (Index < InternalButtonCount) and
  15460.           UpdateItem(TB_DELETEBUTTON, Index, Index) and
  15461.           UpdateItem(TB_INSERTBUTTON, Index, Index);
  15462.       finally
  15463.         SetWindowLong(Handle, GWL_STYLE, Style);
  15464.       end;
  15465.     finally
  15466.       EndUpdate;
  15467.     end;
  15468.   end
  15469.   else
  15470.     Result := False;
  15471. end;
  15472.  
  15473. procedure TToolBar.UpdateButton(Index: Integer);
  15474. var
  15475.   Style: Longint;
  15476. begin
  15477.   if (csLoading in ComponentState) or (FUpdateCount > 0) then Exit;
  15478.   BeginUpdate;
  15479.   try
  15480.     HandleNeeded;
  15481.     Style := GetWindowLong(Handle, GWL_STYLE);
  15482.     SetWindowLong(Handle, GWL_STYLE, Style and not WS_VISIBLE);
  15483.     try
  15484.       if Index < InternalButtonCount then
  15485.         UpdateItem2(TB_SETBUTTONINFO, Index, Index)
  15486.       else
  15487.         UpdateItem(TB_INSERTBUTTON, Index, Index);
  15488.     finally
  15489.       SetWindowLong(Handle, GWL_STYLE, Style);
  15490.     end;
  15491.   finally
  15492.     EndUpdate;
  15493.   end;
  15494. end;
  15495.  
  15496. procedure TToolBar.UpdateButtons;
  15497. const
  15498.   BlankButton: TTBButton = (iBitmap: 0; idCommand: 0; fsState: 0;
  15499.     fsStyle: TBSTYLE_BUTTON; dwData: 0; iString: 0);
  15500. var
  15501.   I: Integer;
  15502.   Count: Integer;
  15503.   Style: Longint;
  15504. begin
  15505.   BeginUpdate;
  15506.   try
  15507.     HandleNeeded;
  15508.     Style := GetWindowLong(Handle, GWL_STYLE);
  15509.     SetWindowLong(Handle, GWL_STYLE, Style and not WS_VISIBLE);
  15510.     try
  15511.       Count := InternalButtonCount;
  15512.       for I := 0 to FButtons.Count - 1 do
  15513.       begin
  15514.         if I < Count then
  15515.           UpdateItem2(TB_SETBUTTONINFO, I, I)
  15516.         else
  15517.           UpdateItem(TB_INSERTBUTTON, I, I);
  15518.       end;
  15519.     finally
  15520.       SetWindowLong(Handle, GWL_STYLE, Style);
  15521.     end;
  15522.   finally
  15523.     EndUpdate;
  15524.   end;
  15525.   RepositionButtons(0);
  15526. end;
  15527.  
  15528. procedure TToolBar.UpdateButtonState(Index: Integer);
  15529. var
  15530.   TBButton: TTBButton;
  15531. begin
  15532.   if (Perform(TB_GETBUTTON, Index, Integer(@TBButton)) <> 0) then
  15533.     with TToolButton(TBButton.dwData) do
  15534.     begin
  15535.       SetButtonState(TBButton.fsState);
  15536.       Self.Perform(TB_SETSTATE, Index, MakeLong(GetButtonState, 0));
  15537.     end;
  15538. end;
  15539.  
  15540. procedure TToolBar.UpdateButtonStates;
  15541. var
  15542.   I: Integer;
  15543. begin
  15544.   for I := 0 to FButtons.Count - 1 do
  15545.     if TControl(FButtons[I]) is TToolButton then
  15546.       UpdateButtonState(I);
  15547. end;
  15548.  
  15549. procedure TToolBar.SetShowCaptions(Value: Boolean);
  15550. begin
  15551.   if FShowCaptions <> Value then
  15552.   begin
  15553.     FShowCaptions := Value;
  15554.     if not (csLoading in ComponentState) then
  15555.       RecreateWnd;
  15556.     AdjustSize;
  15557.   end;
  15558. end;
  15559.  
  15560. function TToolBar.GetButton(Index: Integer): TToolButton;
  15561. begin
  15562.   Result := FButtons[Index];
  15563. end;
  15564.  
  15565. function TToolBar.GetButtonCount: Integer;
  15566. begin
  15567.   Result := FButtons.Count;
  15568. end;
  15569.  
  15570. function TToolBar.GetRowCount: Integer;
  15571. begin
  15572.   Result := Perform(TB_GETROWS, 0, 0);
  15573. end;
  15574.  
  15575. procedure TToolBar.SetList(Value: Boolean);
  15576. begin
  15577.   if FList <> Value then
  15578.   begin
  15579.     FList := Value;
  15580.     RecreateWnd;
  15581.   end;
  15582. end;
  15583.  
  15584. procedure TToolBar.SetFlat(Value: Boolean);
  15585. begin
  15586.   if FFlat <> Value then
  15587.   begin
  15588.     FFlat := Value;
  15589.     RecreateWnd;
  15590.   end;
  15591. end;
  15592.  
  15593. procedure TToolBar.SetTransparent(Value: Boolean);
  15594. begin
  15595.   if FTransparent <> Value then
  15596.   begin
  15597.     FTransparent := Value;
  15598.     RecreateWnd;
  15599.   end;
  15600. end;
  15601.  
  15602. procedure TToolBar.SetWrapable(Value: Boolean);
  15603. begin
  15604.   if FWrapable <> Value then
  15605.   begin
  15606.     FWrapable := Value;
  15607.     if AutoSize then AdjustSize;
  15608.   end;
  15609. end;
  15610.  
  15611. procedure TToolBar.Notification(AComponent: TComponent;
  15612.   Operation: TOperation);
  15613. begin
  15614.   inherited Notification(AComponent, Operation);
  15615.   if Operation = opRemove then
  15616.   begin
  15617.     if AComponent = FImages then Images := nil;
  15618.     if AComponent = FHotImages then HotImages := nil;
  15619.     if AComponent = FDisabledImages then DisabledImages := nil;
  15620.   end;
  15621. end;
  15622.  
  15623. procedure TToolBar.LoadImages(AImages: TCustomImageList);
  15624. var
  15625.   AddBitmap: TTBAddBitmap;
  15626.   ReplaceBitmap: TTBReplaceBitmap;
  15627.   NewHandle: HBITMAP;
  15628.  
  15629.   function GetImageBitmap(ImageList: TCustomImageList): HBITMAP;
  15630.   var
  15631.     I: Integer;
  15632.     Bitmap: TBitmap;
  15633.     R: TRect;
  15634.   begin
  15635.     Bitmap := TBitmap.Create;
  15636.     try
  15637.       Bitmap.Width := ImageList.Width * ImageList.Count;
  15638.       Bitmap.Height := ImageList.Height;
  15639.       R := Rect(0,0,Width,Height);
  15640.       with Bitmap.Canvas do
  15641.       begin
  15642.         Brush.Color := clBtnFace;
  15643.         FillRect(R);
  15644.       end;
  15645.       for I := 0 to ImageList.Count - 1 do
  15646.         ImageList_Draw(ImageList.Handle, I, Bitmap.Canvas.Handle,
  15647.           I * ImageList.Width, 0, ILD_TRANSPARENT);
  15648.       Result := Bitmap.ReleaseHandle;
  15649.     finally
  15650.       Bitmap.Free;
  15651.     end;
  15652.   end;
  15653.  
  15654. begin
  15655.   if AImages <> nil then
  15656.     NewHandle := GetImageBitmap(AImages)
  15657.   else
  15658.     with TBitmap.Create do
  15659.     try
  15660.       Assign(FNullBitmap);
  15661.       NewHandle := ReleaseHandle;
  15662.     finally
  15663.       Free;
  15664.     end;
  15665.   if FOldHandle = 0 then
  15666.   begin
  15667.     AddBitmap.hInst := 0;
  15668.     AddBitmap.nID := NewHandle;
  15669.     Perform(TB_ADDBITMAP, ButtonCount, Longint(@AddBitmap));
  15670.   end
  15671.   else
  15672.   begin
  15673.     with ReplaceBitmap do
  15674.     begin
  15675.       hInstOld := 0;
  15676.       nIDOld := FOldHandle;
  15677.       hInstNew := 0;
  15678.       nIDNew := NewHandle;
  15679.       nButtons := ButtonCount;
  15680.     end;
  15681.     Perform(TB_REPLACEBITMAP, 0, Longint(@ReplaceBitmap));
  15682.     if FOldHandle <> 0 then DeleteObject(FOldHandle);
  15683.   end;
  15684.   FOldHandle := NewHandle;
  15685. end;
  15686.  
  15687. procedure TToolBar.UpdateImages;
  15688. begin
  15689.   if FNewStyle then
  15690.   begin
  15691.     if FImages <> nil then SetImageList(FImages.Handle);
  15692.     if FDisabledImages <> nil then SetDisabledImageList(FDisabledImages.Handle);
  15693.     if FHotImages <> nil then SetHotImageList(FHotImages.Handle);
  15694.   end
  15695.   else
  15696.     if HandleAllocated then LoadImages(FImages);
  15697. end;
  15698.  
  15699. procedure TToolBar.ImageListChange(Sender: TObject);
  15700. begin
  15701.   if HandleAllocated and (Sender = Images) then RecreateButtons;
  15702. end;
  15703.  
  15704. procedure TToolBar.SetImageList(Value: HImageList);
  15705. begin
  15706.   if HandleAllocated then Perform(TB_SETIMAGELIST, 0, Value);
  15707.   Invalidate;
  15708. end;
  15709.  
  15710. procedure TToolBar.SetImages(Value: TCustomImageList);
  15711. begin
  15712.   if FImages <> nil then FImages.UnRegisterChanges(FImageChangeLink);
  15713.   FImages := Value;
  15714.   if FImages <> nil then
  15715.   begin
  15716.     FImages.RegisterChanges(FImageChangeLink);
  15717.     FImages.FreeNotification(Self);
  15718.   end
  15719.   else
  15720.     SetImageList(0);
  15721.   RecreateButtons;
  15722. end;
  15723.  
  15724. procedure TToolBar.DisabledImageListChange(Sender: TObject);
  15725. begin
  15726.   if HandleAllocated and (Sender = DisabledImages) then RecreateButtons;
  15727. end;
  15728.  
  15729. procedure TToolBar.SetDisabledImageList(Value: HImageList);
  15730. begin
  15731.   if HandleAllocated then Perform(TB_SETDISABLEDIMAGELIST, 0, Value);
  15732.   Invalidate;
  15733. end;
  15734.  
  15735. procedure TToolBar.SetDisabledImages(Value: TCustomImageList);
  15736. begin
  15737.   if FDisabledImages <> nil then FDisabledImages.UnRegisterChanges(FDisabledImageChangeLink);
  15738.   FDisabledImages := Value;
  15739.   if FDisabledImages <> nil then
  15740.   begin
  15741.     FDisabledImages.RegisterChanges(FDisabledImageChangeLink);
  15742.     FDisabledImages.FreeNotification(Self);
  15743.   end
  15744.   else
  15745.     SetDisabledImageList(0);
  15746.   RecreateButtons;
  15747. end;
  15748.  
  15749. procedure TToolBar.HotImageListChange(Sender: TObject);
  15750. begin
  15751.   if HandleAllocated and (Sender = HotImages) then RecreateButtons;
  15752. end;
  15753.  
  15754. procedure TToolBar.SetHotImageList(Value: HImageList);
  15755. begin
  15756.   if HandleAllocated then Perform(TB_SETHOTIMAGELIST, 0, Value);
  15757.   Invalidate;
  15758. end;
  15759.  
  15760. procedure TToolBar.SetHotImages(Value: TCustomImageList);
  15761. begin
  15762.   if FHotImages <> nil then FHotImages.UnRegisterChanges(FHotImageChangeLink);
  15763.   FHotImages := Value;
  15764.   if FHotImages <> nil then
  15765.   begin
  15766.     FHotImages.RegisterChanges(FHotImageChangeLink);
  15767.     FHotImages.FreeNotification(Self);
  15768.   end
  15769.   else
  15770.     SetHotImageList(0);
  15771.   RecreateButtons;
  15772. end;
  15773.  
  15774. procedure TToolBar.SetIndent(Value: Integer);
  15775. begin
  15776.   if FIndent <> Value then
  15777.   begin
  15778.     FIndent := Value;
  15779.     RecreateWnd;
  15780.   end;
  15781. end;
  15782.  
  15783. procedure TToolBar.RecreateButtons;
  15784. begin
  15785.   if not (csLoading in ComponentState) or HandleAllocated then
  15786.   begin
  15787.     CreateButtons(FButtonWidth, FButtonHeight);
  15788.     ResizeButtons;
  15789.   end;
  15790. end;
  15791.  
  15792. procedure TToolBar.WMCaptureChanged(var Message: TMessage);
  15793. begin
  15794.   inherited;
  15795.   if FInMenuLoop and FCaptureChangeCancels then CancelMenu;
  15796. end;
  15797.  
  15798. procedure TToolBar.WMKeyDown(var Message: TWMKeyDown);
  15799. var
  15800.   Item: Integer;
  15801.   Button: TToolButton;
  15802.   P: TPoint;
  15803. begin
  15804.   if FInMenuLoop then
  15805.   begin
  15806.     Item := Perform(TB_GETHOTITEM, 0, 0);
  15807.     case Message.CharCode of
  15808.       VK_RETURN, VK_DOWN:
  15809.         begin
  15810.           if (Item > -1) and (Item < FButtons.Count) then
  15811.           begin
  15812.             Button := TToolButton(FButtons[Item]);
  15813.             P := Button.ClientToScreen(Point(1, 1));
  15814.             ClickButton(Button);
  15815.           end;
  15816.           { Prevent default processing }
  15817.           if Message.CharCode = VK_DOWN then Exit;
  15818.         end;
  15819.       VK_ESCAPE: CancelMenu;
  15820.     end;
  15821.   end;
  15822.   inherited;
  15823. end;
  15824.  
  15825. procedure TToolBar.GetChildren(Proc: TGetChildProc; Root: TComponent);
  15826. var
  15827.   I: Integer;
  15828.   Control: TControl;
  15829. begin
  15830.   for I := 0 to FButtons.Count - 1 do Proc(TComponent(FButtons[I]));
  15831.   for I := 0 to ControlCount - 1 do
  15832.   begin
  15833.     Control := Controls[I];
  15834.     if (Control.Owner = Root) and (FButtons.IndexOf(Control) = -1) then Proc(Control);
  15835.   end;
  15836. end;
  15837.  
  15838. procedure TToolBar.Loaded;
  15839. var
  15840.   I: Integer;
  15841. begin
  15842.   RecreateButtons;
  15843.   { Make sure we dock controls after streaming }
  15844.   for I := 0 to ControlCount - 1 do
  15845.     Controls[I].HostDockSite := Self;
  15846.   inherited Loaded;
  15847.   ResizeButtons;
  15848.   RepositionButtons(0);
  15849. end;
  15850.  
  15851. procedure TToolBar.BeginUpdate;
  15852. begin
  15853.   Inc(FUpdateCount);
  15854. end;
  15855.  
  15856. procedure TToolBar.EndUpdate;
  15857. begin
  15858.   Dec(FUpdateCount);
  15859. end;
  15860.  
  15861. procedure TToolBar.ResizeButtons;
  15862. begin
  15863.   if not (csLoading in ComponentState) and HandleAllocated then
  15864.   begin
  15865.     Perform(TB_AUTOSIZE, 0, 0);
  15866.     if AutoSize then AdjustSize;
  15867.   end;
  15868. end;
  15869.  
  15870. function TToolBar.InternalButtonCount: Integer;
  15871. begin
  15872.   Result := Perform(TB_BUTTONCOUNT, 0, 0);
  15873. end;
  15874.  
  15875. function TToolBar.ButtonIndex(OldIndex, ALeft, ATop: Integer): Integer;
  15876. var
  15877.   Dist, Tmp, Head, Tail: Integer;
  15878.   Control: TControl;
  15879. begin
  15880.   if (OldIndex >= 0) and (FButtons.Count <= 1) then
  15881.   begin
  15882.     Result := OldIndex;
  15883.     Exit;
  15884.   end;
  15885.   { Find row closest to ATop }
  15886.   Result := 0;
  15887.   if FButtons.Count = 0 then Exit;
  15888.   Tmp := 0;
  15889.   Head := 0;
  15890.   Tail := 0;
  15891.   Dist := MaxInt;
  15892.   while (Dist > 0) and (Result < FButtons.Count) do
  15893.   begin
  15894.     if Result <> OldIndex then
  15895.     begin
  15896.       Control := TControl(FButtons[Result]);
  15897.       if (Control is TToolButton) and TToolButton(Control).Wrap or
  15898.         (Result = FButtons.Count - 1) then
  15899.       begin
  15900.         if Abs(ATop - Control.Top) < Dist then
  15901.         begin
  15902.           Dist := Abs(ATop - Control.Top);
  15903.           Head := Tmp;
  15904.           Tail := Result;
  15905.         end;
  15906.         Tmp := Result + 1;
  15907.       end;
  15908.     end
  15909.     else
  15910.       Tail := Result;
  15911.     Inc(Result);
  15912.   end;
  15913.   { Find button on Row closest to ALeft }
  15914.   for Result := Head to Tail do
  15915.     if (Result <> OldIndex) and (ALeft <= TControl(FButtons[Result]).Left) then
  15916.       Break;
  15917.   { Return old position if new position is last on the row and old position
  15918.     was already the last on the row. }
  15919.   if (Result = OldIndex + 1) and (OldIndex in [Head..Tail]) then
  15920.     Result := OldIndex;
  15921. end;
  15922.  
  15923. function TToolBar.ReorderButton(OldIndex, ALeft, ATop: Integer): Integer;
  15924. var
  15925.   Control: TControl;
  15926. begin
  15927.   Result := ButtonIndex(OldIndex, ALeft, ATop);
  15928.   if Result <> OldIndex then
  15929.   begin
  15930.     { If we are inserting to the right of our deletion then account for shift }
  15931.     if OldIndex < Result then Dec(Result);
  15932.     Control := FButtons[OldIndex];
  15933.     FButtons.Delete(OldIndex);
  15934.     FButtons.Insert(Result, Control);
  15935.     BeginUpdate;
  15936.     try
  15937.       Perform(TB_DELETEBUTTON, OldIndex, 0);
  15938.       UpdateItem(TB_INSERTBUTTON, Result, Result);
  15939.     finally
  15940.       EndUpdate;
  15941.     end;
  15942.   end;
  15943. end;
  15944.  
  15945. procedure TToolBar.AdjustControl(Control: TControl);
  15946. var
  15947.   I, Pos: Integer;
  15948.   R: TRect;
  15949.   Reordered, NeedsUpdate: Boolean;
  15950. begin
  15951.   Pos := FButtons.IndexOf(Control);
  15952.   if Pos = -1 then Exit;
  15953.   Reordered := ReorderButton(Pos, Control.Left, Control.Top) <> Pos;
  15954.   NeedsUpdate := False;
  15955.   if Reordered then
  15956.   begin
  15957.     I := FButtons.IndexOf(Control);
  15958.     if I < Pos then Pos := I;
  15959.   end
  15960.   else if Perform(TB_GETITEMRECT, Pos, Longint(@R)) <> 0 then
  15961.   begin
  15962.     NeedsUpdate := Control.Width <> R.Right - R.Left;
  15963.     Reordered := NeedsUpdate;
  15964.   end;
  15965.   if (csDesigning in ComponentState) and (Control.Height <> ButtonHeight) then
  15966.     ButtonHeight := Control.Height
  15967.   else
  15968.     if Reordered then
  15969.     begin
  15970.       if NeedsUpdate then
  15971.         RefreshButton(Pos);
  15972.       ResizeButtons;
  15973.       RepositionButtons(0);
  15974.     end
  15975.     else
  15976.       RepositionButton(Pos);
  15977. end;
  15978.  
  15979. procedure TToolBar.AlignControls(AControl: TControl; var Rect: TRect);
  15980. begin
  15981.   if FUpdateCount > 0 then Exit;
  15982.   if AControl = nil then
  15983.     RepositionButtons(0)
  15984.   else if not (AControl is TToolButton) then
  15985.     AdjustControl(AControl);
  15986. end;
  15987.  
  15988. procedure TToolBar.ChangeScale(M, D: Integer);
  15989. begin
  15990.   { Scaling isn't a standard behavior for toolbars.  We prevent scaling from
  15991.     occurring here. }
  15992. end;
  15993.  
  15994. procedure TToolBar.WMEraseBkgnd(var Message: TWMEraseBkgnd);
  15995. begin
  15996.   if not Transparent then
  15997.     inherited else
  15998.     DefaultHandler(Message);
  15999. end;
  16000.  
  16001. procedure TToolBar.WMGetDlgCode(var Message: TMessage);
  16002. begin
  16003.   if FInMenuLoop then
  16004.     Message.Result := DLGC_WANTARROWS;
  16005. end;
  16006.  
  16007. { Need to read/write caption ourselves - default wndproc seems to discard it. }
  16008.  
  16009. procedure TToolBar.WMGetText(var Message: TWMGetText);
  16010. begin
  16011.   with Message do
  16012.     Result := StrLen(StrLCopy(PChar(Text), PChar(FCaption), TextMax - 1));
  16013. end;
  16014.  
  16015. procedure TToolBar.WMGetTextLength(var Message: TWMGetTextLength);
  16016. begin
  16017.   Message.Result := Length(FCaption);
  16018. end;
  16019.  
  16020. procedure TToolBar.WMSetText(var Message: TWMSetText);
  16021. begin
  16022.   with Message do
  16023.     SetString(FCaption, Text, StrLen(Text));
  16024. end;
  16025.  
  16026. procedure TToolBar.WMNotifyFormat(var Message: TMessage);
  16027. begin
  16028.   with Message do
  16029.     Result := DefWindowProc(Handle, Msg, WParam, LParam);
  16030. end;
  16031.  
  16032. procedure TToolBar.WMSize(var Message: TWMSize);
  16033. var
  16034.   W, H: Integer;
  16035. begin
  16036.   inherited;
  16037.   if not AutoSize then
  16038.   begin
  16039.     W := Width;
  16040.     H := Height;
  16041.     WrapButtons(W, H);
  16042.   end;
  16043. end;
  16044.  
  16045. procedure TToolBar.WMSysChar(var Message: TWMSysChar);
  16046. var
  16047.   Form: TCustomForm;
  16048. begin
  16049.   { Default wndproc doesn't re-route WM_SYSCHAR messages to parent. }
  16050.   Form := GetParentForm(Self);
  16051.   if Form <> nil then
  16052.   begin
  16053.     Form.Dispatch(Message);
  16054.     Exit;
  16055.   end
  16056.   else
  16057.     inherited;
  16058. end;
  16059.  
  16060. procedure TToolBar.WMWindowPosChanged(var Message: TWMWindowPosChanged);
  16061. var
  16062.   R: TRect;
  16063.   NcX, NcY: Integer;
  16064.   Rgn1, Rgn2: HRgn;
  16065. begin
  16066.   { Erase only what's been uncovered when toolbar is flat - avoid flicker }
  16067.   if Flat and HandleAllocated and (Parent <> nil) then
  16068.   begin
  16069.     GetWindowRect(Handle, R);
  16070.     NcX := R.Right - R.Left - ClientWidth;
  16071.     NcY := R.Bottom - R.Top - ClientHeight;
  16072.     Rgn1 := CreateRectRgn(0, 0, Width - NcX, Height - NcY);
  16073.     with Message.WindowPos^ do
  16074.       Rgn2 := CreateRectRgn(0, 0, cx - NcY, cy - NcY);
  16075.     CombineRgn(Rgn1, Rgn2, Rgn1, RGN_XOR);
  16076.     GetRgnBox(Rgn1, R);
  16077.     { Allow a 2 pixel buffer }
  16078.     Dec(R.Left, 2);
  16079.     DeleteObject(Rgn1);
  16080.     DeleteObject(Rgn2);
  16081.     inherited;
  16082.     RedrawWindow(Handle, @R, 0, RDW_INVALIDATE or RDW_ERASE);
  16083.   end
  16084.   else
  16085.     inherited;
  16086. end;
  16087.  
  16088. procedure TToolBar.WMWindowPosChanging(var Message: TWMWindowPosChanging);
  16089. const
  16090.   BackgroundValid = SWP_NOSIZE or SWP_NOMOVE;
  16091. var
  16092.   R: TRect;
  16093. begin
  16094.   { Invalidate old background when toolbar is flat and is about to be moved }
  16095.   if Transparent and (Message.WindowPos^.flags and BackgroundValid <> BackgroundValid) and
  16096.     (Parent <> nil) and Parent.HandleAllocated then
  16097.   begin
  16098.     R := BoundsRect;
  16099.     InvalidateRect(Parent.Handle, @R, True);
  16100.   end;
  16101.   inherited;
  16102. end;
  16103.  
  16104. function TToolBar.WrapButtons(var NewWidth, NewHeight: Integer): Boolean;
  16105. var
  16106.   Index, NcX, NcY: Integer;
  16107.   Vertical: Boolean;
  16108.   PrevSize, CurrSize: TPoint;
  16109.   R: TRect;
  16110.   WrapStates: TBits;
  16111.  
  16112.   procedure CalcSize(var CX, CY: Integer);
  16113.   var
  16114.     IsWrapped: Boolean;
  16115.     I, Tmp, X, Y, HeightChange: Integer;
  16116.     Control: TControl;
  16117.   begin
  16118.     CX := 0;
  16119.     CY := 0;
  16120.     X := Indent;
  16121.     Y := 0;
  16122.     for I := 0 to FButtons.Count - 1 do
  16123.     begin
  16124.       Control := TControl(FButtons[I]);
  16125.       if (csDesigning in ComponentState) or Control.Visible then
  16126.       begin
  16127.         if (Control is TToolButton) and (I < FButtons.Count - 1) then
  16128.           if WrapStates <> nil then
  16129.             IsWrapped := WrapStates[I] else
  16130.             IsWrapped := TToolButton(Control).Wrap
  16131.         else
  16132.           IsWrapped := False;
  16133.         if Control is TToolButton and
  16134.           (TToolButton(Control).Style in [tbsSeparator, tbsDivider]) then
  16135.         begin
  16136.           { Store the change in height, from the current row to the next row
  16137.             after wrapping, in HeightChange. THe IE4 version of comctl32
  16138.             considers this height to be the width the last separator on the
  16139.             current row - prior versions of comctl32 consider this height to be
  16140.             2/3 the width the last separator. }
  16141.           HeightChange := Control.Width;
  16142.           if (GetComCtlVersion < ComCtlVersionIE4) or not Flat and
  16143.             (GetComCtlVersion >= ComCtlVersionIE401) then
  16144.             HeightChange := HeightChange * 2 div 3;
  16145.           if IsWrapped and (I < FButtons.Count - 1) then
  16146.           begin
  16147.             Tmp := Y + ButtonHeight + HeightChange;
  16148.             if Tmp > CY then
  16149.               CY := Tmp;
  16150.           end
  16151.           else
  16152.           begin
  16153.             Tmp := X + Control.Width;
  16154.             if Tmp > CX then
  16155.               CX := Tmp;
  16156.           end;
  16157.           if IsWrapped then
  16158.             Inc(Y, HeightChange);
  16159.         end
  16160.         else
  16161.         begin
  16162.           Tmp := X + Control.Width;
  16163.           if Tmp > CX then
  16164.             CX := Tmp;
  16165.           Tmp := Y + ButtonHeight;
  16166.           if Tmp > CY then
  16167.             CY := Tmp;
  16168.         end;
  16169.         if IsWrapped then
  16170.         begin
  16171.           X := Indent;
  16172.           Inc(Y, ButtonHeight);
  16173.         end
  16174.         else
  16175.           Inc(X, Control.Width);
  16176.       end;
  16177.     end;
  16178.     { Adjust for 2 pixel top margin when not flat style buttons }
  16179.     if (CY > 0) and not Flat then Inc(CY, 2);
  16180.   end;
  16181.  
  16182.   function WrapHorz(CX: Integer): Integer;
  16183.   var
  16184.     I, J, X: Integer;
  16185.     Control: TControl;
  16186.     Found: Boolean;
  16187.   begin
  16188.     Result := 1;
  16189.     X := Indent;
  16190.     I := 0;
  16191.     while I < FButtons.Count do
  16192.     begin
  16193.       Control := TControl(FButtons[I]);
  16194.       if Control is TToolButton then
  16195.         WrapStates[I] := False;
  16196.       if (csDesigning in ComponentState) or Control.Visible then
  16197.       begin
  16198.         if (X + Control.Width > CX) and (not (Control is TToolButton) or
  16199.           not (TToolButton(Control).Style in [tbsDivider, tbsSeparator])) then
  16200.         begin
  16201.           Found := False;
  16202.           for J := I downto 0 do
  16203.             if TControl(FButtons[J]) is TToolButton then
  16204.               with TToolButton(FButtons[J]) do
  16205.                 if ((csDesigning in ComponentState) or Visible) and
  16206.                   (Style in [tbsSeparator, tbsDivider]) then
  16207.                 begin
  16208.                   if not WrapStates[J] then
  16209.                   begin
  16210.                     Found := True;
  16211.                     I := J;
  16212.                     X := Indent;
  16213.                     WrapStates[J] := True;
  16214.                     Inc(Result);
  16215.                   end;
  16216.                   Break;
  16217.                 end;
  16218.           if not Found then
  16219.           begin
  16220.             for J := I - 1 downto 0 do
  16221.               if TControl(FButtons[J]) is TToolButton then
  16222.                 with TToolButton(FButtons[J]) do
  16223.                   if (csDesigning in ComponentState) or Visible then
  16224.                   begin
  16225.                     if not WrapStates[J] then
  16226.                     begin
  16227.                       Found := True;
  16228.                       I := J;
  16229.                       X := Indent;
  16230.                       WrapStates[J] := True;
  16231.                       Inc(Result);
  16232.                     end;
  16233.                     Break;
  16234.                   end;
  16235.             if not Found then
  16236.               Inc(X, Control.Width);
  16237.           end;
  16238.         end
  16239.         else
  16240.           Inc(X, Control.Width);
  16241.       end;
  16242.       Inc(I);
  16243.     end;
  16244.   end;
  16245.  
  16246.   function WrapSizeVert(var CX, CY: Integer): Integer;
  16247.   var
  16248.     HorzSize, VertSize, Size, PrevSize: TPoint;
  16249.   begin
  16250.     PrevSize := Point(-1,-1);
  16251.     Size := Point(0,0);
  16252.     Result := 0;
  16253.     WrapHorz(0);
  16254.     CalcSize(VertSize.X, VertSize.Y);
  16255.     WrapHorz(MaxInt);
  16256.     CalcSize(HorzSize.X, HorzSize.Y);
  16257.     while VertSize.X < HorzSize.X do
  16258.     begin
  16259.       PrevSize := Size;
  16260.       Size.X := (VertSize.X + HorzSize.X) div 2;
  16261.       Result := WrapHorz(Size.X);
  16262.       CalcSize(Size.X, Size.Y);
  16263.       if CY < Size.Y then
  16264.       begin
  16265.         if (VertSize.X = Size.X) and (VertSize.Y = Size.Y) then
  16266.         begin
  16267.           Result := WrapHorz(HorzSize.X);
  16268.           Break;
  16269.         end;
  16270.         VertSize := Size;
  16271.       end
  16272.       else if CY > Size.Y then
  16273.       begin
  16274.         HorzSize := Size;
  16275.         if (PrevSize.X = Size.X) and (PrevSize.Y = Size.Y) then Break;
  16276.       end
  16277.       else
  16278.         Break;
  16279.     end;
  16280.   end;
  16281.  
  16282.   function WrapSizeHorz(var CX, CY: Integer): Integer;
  16283.   var
  16284.     HorzRows, VertRows, Min, Mid, Max: Integer;
  16285.     HorzSize: TPoint;
  16286.   begin
  16287.     Result := 0;
  16288.     Min := 0;
  16289.     Max := CX;
  16290.     HorzRows := WrapHorz(Max);
  16291.     VertRows := WrapHorz(0);
  16292.     if HorzRows <> VertRows then
  16293.       while Min < Max do
  16294.       begin
  16295.         Mid := (Min + Max) div 2;
  16296.         VertRows := WrapHorz(Mid);
  16297.         if VertRows = HorzRows then
  16298.           Max := Mid
  16299.         else
  16300.         begin
  16301.           if Min = Mid then
  16302.           begin
  16303.             WrapHorz(Max);
  16304.             Break;
  16305.           end;
  16306.           Min := Mid;
  16307.         end;
  16308.       end;
  16309.     CalcSize(HorzSize.X, HorzSize.Y);
  16310.     WrapHorz(HorzSize.X);
  16311.   end;
  16312.  
  16313. begin
  16314.   Result := True;
  16315.   if HandleAllocated then
  16316.   begin
  16317.     Index := InternalButtonCount - 1;
  16318.     if (Index >= 0) or not (csDesigning in ComponentState) then
  16319.     begin
  16320.       WrapStates := nil;
  16321.       PrevSize.X := ClientWidth;
  16322.       PrevSize.Y := ClientHeight;
  16323.       { Calculate non-client border size }
  16324.       NcX := Width - PrevSize.X;
  16325.       NcY := Height - PrevSize.Y;
  16326.       { Remember previous size for comparison }
  16327.       R.BottomRight := PrevSize;
  16328.       CalcSize(PrevSize.X, PrevSize.Y);
  16329.       { Get current window size minus the non-client borders }
  16330.       CurrSize := Point(NewWidth - NcX, NewHeight - NcY);
  16331.  
  16332.       { Decide best way to calculate layout }
  16333.       if Align <> alNone then
  16334.         Vertical := Align in [alLeft, alRight]
  16335.       else
  16336.         Vertical := Abs(CurrSize.X - R.Right) < Abs(CurrSize.Y - R.Bottom);
  16337.       if Wrapable then
  16338.       begin
  16339.         WrapStates := TBits.Create;
  16340.         try
  16341.           WrapStates.Size := FButtons.Count;
  16342.           if Vertical then
  16343.             WrapSizeVert(CurrSize.X, CurrSize.Y)
  16344.           else
  16345.             WrapSizeHorz(CurrSize.X, CurrSize.Y);
  16346.           { CurrSize now has optimium dimensions }
  16347.           CalcSize(CurrSize.X, CurrSize.Y);
  16348.           if (Vertical or (Align = alNone)) and (CurrSize.X <> PrevSize.X) or
  16349.             (CurrSize.Y <> PrevSize.Y) then
  16350.           begin
  16351.             { Enforce changes to Wrap property }
  16352.             for Index := 0 to WrapStates.Size - 1 do
  16353.               if TControl(FButtons[Index]) is TToolButton then
  16354.                 TToolButton(FButtons[Index]).Wrap := WrapStates[Index];
  16355.             RepositionButtons(0);
  16356.           end
  16357.           else
  16358.             { Overwrite any changes to buttons' Wrap property }
  16359.             UpdateButtonStates;
  16360.         finally
  16361.           WrapStates.Free;
  16362.         end;
  16363.       end
  16364.       else
  16365.         { CurrSize now has optimium dimensions }
  16366.         CalcSize(CurrSize.X, CurrSize.Y);
  16367.       if AutoSize and (Align <> alClient) then
  16368.       begin
  16369.         if Vertical or (Align = alNone) then
  16370.           NewWidth := CurrSize.X + NcX;
  16371.         if not Vertical or (Align = alNone) then
  16372.           NewHeight := CurrSize.Y + NcY;
  16373.       end;
  16374.     end;
  16375.   end;
  16376. end;
  16377.  
  16378. function TToolBar.CanAutoSize(var NewWidth, NewHeight: Integer): Boolean;
  16379. begin
  16380.   Result := WrapButtons(NewWidth, NewHeight);
  16381. end;
  16382.  
  16383. procedure TToolBar.CMControlChange(var Message: TCMControlChange);
  16384. begin
  16385.   inherited;
  16386.   with Message do
  16387.     if Inserting then
  16388.       InsertButton(Control)
  16389.     else
  16390.       RemoveButton(Control);
  16391. end;
  16392.  
  16393. procedure TToolBar.CNChar(var Message: TWMChar);
  16394. begin
  16395.   { We got here through the installed ToolMenuKeyHook }
  16396.   if FInMenuLoop and not (csDesigning in ComponentState) then
  16397.     with Message do
  16398.       if Perform(CM_DIALOGCHAR, CharCode, KeyData) <> 0 then
  16399.         Result := 1;
  16400. end;
  16401.  
  16402. procedure TToolBar.CMDialogChar(var Message: TCMDialogChar);
  16403. var
  16404.   Button: TToolButton;
  16405. begin
  16406.   if Enabled and Showing and ShowCaptions then
  16407.   begin
  16408.     Button := FindButtonFromAccel(Message.CharCode);
  16409.     if Button <> nil then
  16410.     begin
  16411.       { Display a drop-down menu after hitting the accelerator key if IE3
  16412.         is installed. Otherwise, fire the OnClick event for IE4. We do this
  16413.         because the IE4 version of the drop-down metaphor is more complete,
  16414.         allowing the user to click a button OR drop-down its menu. }
  16415.       if ((Button.Style <> tbsDropDown) or (GetComCtlVersion < ComCtlVersionIE4)) and
  16416.         ((Button.DropdownMenu <> nil) or (Button.MenuItem <> nil)) then
  16417.         TrackMenu(Button)
  16418.       else
  16419.         Button.Click;
  16420.       Message.Result := 1;
  16421.       Exit;
  16422.     end;
  16423.   end;
  16424.   inherited;
  16425. end;
  16426.  
  16427. procedure TToolBar.CMEnabledChanged(var Message: TMessage);
  16428. begin
  16429.   inherited;
  16430.   Broadcast(Message);
  16431. end;
  16432.  
  16433. procedure TToolBar.CMColorChanged(var Message: TMessage);
  16434. begin
  16435.   inherited;
  16436.   RecreateWnd;
  16437. end;
  16438.  
  16439. procedure TToolBar.CMParentColorChanged(var Message: TMessage);
  16440. begin
  16441.   inherited;
  16442.   { If toolbar is transparent then repaint when parent changes color }
  16443.   if Transparent then Invalidate;
  16444. end;
  16445.  
  16446. procedure TToolBar.CNSysKeyDown(var Message: TWMSysKeyDown);
  16447. begin
  16448.   inherited;
  16449.   if (Message.CharCode = VK_MENU) then
  16450.     CancelMenu;
  16451. end;
  16452.  
  16453. procedure TToolBar.CMSysFontChanged(var Message: TMessage);
  16454. begin
  16455.   inherited;
  16456.   RecreateWnd;
  16457. end;
  16458.  
  16459. procedure TToolBar.CNDropDownClosed(var Message: TMessage);
  16460. begin
  16461.   ClearTempMenu;
  16462.   FMenuDropped := False;
  16463.   if (GetComCtlVersion = ComCtlVersionIE5) and (FMenuButton <> nil)
  16464.     then FMenuButton.Invalidate;
  16465.   FCaptureChangeCancels := True;
  16466. end;
  16467.  
  16468. procedure TToolBar.CNNotify(var Message: TWMNotify);
  16469. var
  16470.   Button: TToolButton;
  16471.   DefaultDraw: Boolean;
  16472.   R: TRect;
  16473.   Flags: TTBCustomDrawFlags;
  16474.   LogFont: TLogFont;
  16475. begin
  16476.   with Message do
  16477.     case NMHdr^.code of
  16478.       TBN_DROPDOWN:
  16479.         with PNMToolBar(NMHdr)^ do
  16480.           { We can safely assume that a TBN_DROPDOWN message was generated by a
  16481.             TToolButton and not any TControl. }
  16482.           if Perform(TB_GETBUTTON, iItem, Longint(@tbButton)) <> 0 then
  16483.           begin
  16484.             Button := TToolButton(tbButton.dwData);
  16485.             if Button <> nil then
  16486.               Button.CheckMenuDropDown;
  16487.           end;
  16488.       NM_CUSTOMDRAW:
  16489.         with PNMTBCustomDraw(NMHdr)^ do
  16490.         try
  16491.           FCanvas.Lock;
  16492.           Result := CDRF_DODEFAULT;
  16493.           if (nmcd.dwDrawStage and CDDS_ITEM) = 0 then
  16494.           begin
  16495.             R := ClientRect;
  16496.             case nmcd.dwDrawStage of
  16497.               CDDS_PREPAINT:
  16498.               begin
  16499.                 if IsCustomDrawn(dtControl, cdPrePaint) then
  16500.                 begin
  16501.                   try
  16502.                     FCanvas.Handle := nmcd.hdc;
  16503.                     FCanvas.Font := Font;
  16504.                     FCanvas.Brush := Brush;
  16505.                     DefaultDraw := CustomDraw(R, cdPrePaint);
  16506.                     if not DefaultDraw then
  16507.                     begin
  16508.                       Result := CDRF_SKIPDEFAULT;
  16509.                       Exit;
  16510.                     end;
  16511.                     clrText := ColorToRGB(FCanvas.Font.Color);
  16512.                     clrBtnFace := ColorToRGB(FCanvas.Brush.Color);
  16513.                   finally
  16514.                     FCanvas.Handle := 0;
  16515.                   end;
  16516.                 end;
  16517.                 if IsCustomDrawn(dtItem, cdPrePaint) or IsCustomDrawn(dtItem, cdPreErase) then
  16518.                   Result := Result or CDRF_NOTIFYITEMDRAW;
  16519.                 if IsCustomDrawn(dtItem, cdPostPaint) then
  16520.                   Result := Result or CDRF_NOTIFYPOSTPAINT;
  16521.                 if IsCustomDrawn(dtItem, cdPostErase) then
  16522.                   Result := Result or CDRF_NOTIFYPOSTERASE;
  16523.               end;
  16524.               CDDS_POSTPAINT:
  16525.                 if IsCustomDrawn(dtControl, cdPostPaint) then
  16526.                   CustomDraw(R, cdPostPaint);
  16527.               CDDS_PREERASE:
  16528.                 if IsCustomDrawn(dtControl, cdPreErase) then
  16529.                   CustomDraw(R, cdPreErase);
  16530.               CDDS_POSTERASE:
  16531.                 if IsCustomDrawn(dtControl, cdPostErase) then
  16532.                   CustomDraw(R, cdPostErase);
  16533.             end;
  16534.           end else
  16535.           begin
  16536.             Button := Buttons[nmcd.dwItemSpec];
  16537.             if Button = nil then Exit;
  16538.             case nmcd.dwDrawStage of
  16539.               CDDS_ITEMPREPAINT:
  16540.                 try
  16541.                   FCanvas.Handle := nmcd.hdc;
  16542.                   FCanvas.Font := Self.Font;
  16543.                   FCanvas.Brush := Self.Brush;
  16544.                   FCanvas.Font.OnChange := CanvasChanged;
  16545.                   FCanvas.Brush.OnChange := CanvasChanged;
  16546.                   FCanvasChanged := False;
  16547.                   Flags := [];
  16548.                   DefaultDraw := CustomDrawButton(Button,
  16549.                     TCustomDrawState(Word(nmcd.uItemState)), cdPrePaint, Flags);
  16550.                   if tbNoEdges in Flags then
  16551.                     Result := Result or TBCDRF_NOEDGES;
  16552.                   if tbHiliteHotTrack in Flags then
  16553.                     Result := Result or TBCDRF_HILITEHOTTRACK;
  16554.                   if tbNoOffset in Flags then
  16555.                     Result := Result or TBCDRF_NOOFFSET;
  16556.                   if tbNoMark in Flags then
  16557.                     Result := Result or TBCDRF_NOMARK;
  16558.                   if tbNoEtchedEffect in Flags then
  16559.                     Result := Result or TBCDRF_NOETCHEDEFFECT;
  16560.                   clrText := ColorToRGB(FCanvas.Font.Color);
  16561.                   clrBtnFace := ColorToRGB(FCanvas.Brush.Color);
  16562.                   if not DefaultDraw then
  16563.                   begin
  16564.                     Result := Result or CDRF_SKIPDEFAULT;
  16565.                     Exit;
  16566.                   end else if FCanvasChanged then
  16567.                   begin
  16568.                     FCanvasChanged := False;
  16569.                     FCanvas.Font.OnChange := nil;
  16570.                     FCanvas.Brush.OnChange := nil;
  16571.                     if GetObject(FCanvas.Font.Handle, SizeOf(LogFont), @LogFont) <> 0 then
  16572.                     begin
  16573.                       FCanvas.Handle := 0;  // disconnect from hdc
  16574.                       // don't delete the stock font
  16575.                       SelectObject(nmcd.hdc, CreateFontIndirect(LogFont));
  16576.                       Result := Result or CDRF_NEWFONT;
  16577.                     end;
  16578.                     if IsCustomDrawn(dtItem, cdPostPaint) then
  16579.                       Result := Result or CDRF_NOTIFYPOSTPAINT;
  16580.                   end;
  16581.                 finally
  16582.                   FCanvas.Handle := 0;
  16583.                 end;
  16584.               CDDS_ITEMPOSTPAINT:
  16585.                 if Button <> nil then
  16586.                   CustomDrawButton(Button, TCustomDrawState(Word(nmcd.uItemState)),
  16587.                     cdPostPaint, Flags);
  16588.               CDDS_ITEMPREERASE:
  16589.                 if Button <> nil then
  16590.                   CustomDrawButton(Button, TCustomDrawState(Word(nmcd.uItemState)),
  16591.                     cdPreErase, Flags);
  16592.               CDDS_ITEMPOSTERASE:
  16593.                 if Button <> nil then
  16594.                   CustomDrawButton(Button, TCustomDrawState(Word(nmcd.uItemState)),
  16595.                     cdPostErase, Flags);
  16596.             end;
  16597.           end;
  16598.         finally
  16599.           FCanvas.Unlock;
  16600.         end;
  16601.     end;
  16602. end;
  16603.  
  16604. type
  16605.   TControlAccess = class(TControl);
  16606.  
  16607. procedure TToolBar.WndProc(var Message: TMessage);
  16608. var
  16609.   Control: TControl;
  16610.   CapControl: TControl;
  16611.   Msg: TMsg;
  16612.  
  16613.   function IsToolButtonMouseMsg(var Message: TWMMouse): Boolean;
  16614.   begin
  16615.     if GetCapture = Handle then
  16616.     begin
  16617.       CapControl := GetCaptureControl;
  16618.       if (CapControl <> nil) and (CapControl.Parent <> Self) then
  16619.         CapControl := nil;
  16620.     end
  16621.     else
  16622.       CapControl := nil;
  16623.     Control := ControlAtPos(SmallPointToPoint(Message.Pos), False);
  16624.     Result := (Control <> nil) and (Control is TToolButton) and
  16625.       not Control.Dragging;
  16626.   end;
  16627.  
  16628.   procedure SendDropdownMsg(Button: TToolButton);
  16629.   var
  16630.     Msg: TNMToolBar;
  16631.   begin
  16632.     FillChar(Msg, SizeOf(Msg), 0);
  16633.     with Msg, hdr do
  16634.     begin
  16635.       hwndFrom := Handle;
  16636.       idFrom := Handle;
  16637.       code := TBN_DROPDOWN;
  16638.       iItem := Button.Index;
  16639.     end;
  16640.     SendMessage(Handle, WM_NOTIFY, Handle, Longint(@Msg));
  16641.   end;
  16642.  
  16643. begin
  16644.   if not (csDesigning in ComponentState) then
  16645.   begin
  16646.     case Message.Msg of
  16647.       WM_MOUSEMOVE:
  16648.         begin
  16649.           { Call default wndproc to get buttons to repaint when Flat = True. }
  16650.           if IsToolButtonMouseMsg(TWMMouse(Message)) then
  16651.           begin
  16652.             { Prevent painting of flat buttons when they are dock clients }
  16653.             if TControlAccess(Control).DragMode <> dmAutomatic then
  16654.               DefaultHandler(Message);
  16655.           end
  16656.           else
  16657.             DefaultHandler(Message);
  16658.         end;
  16659.       WM_LBUTTONUP:
  16660.         { Update button states after a click. }
  16661.         if IsToolButtonMouseMsg(TWMMouse(Message)) then
  16662.         begin
  16663.           DefaultHandler(Message);
  16664.           if CapControl = Control then
  16665.           begin
  16666.             with TToolButton(Control) do
  16667.               if Down and Grouped and AllowAllUp and (Style = tbsCheck) then
  16668.                 Down := False;
  16669.             UpdateButtonStates;
  16670.           end
  16671.           else if (CapControl is TToolButton) or (TToolButton(Control).Style = tbsDropDown) then
  16672.             Exit;
  16673.         end;
  16674.       WM_LBUTTONDOWN, WM_LBUTTONDBLCLK:
  16675.         if IsToolButtonMouseMsg(TWMMouse(Message)) then
  16676.         begin
  16677.           { Check if mouse is clicked on a drop-down button's arrow (for IE4
  16678.             the arrow is within 13 pixels from the right, for IE3 there is no
  16679.             distinction - the entire button is used).  If an arrow click is
  16680.             detected then don't process this mouse event - a TBN_DROPDOWN
  16681.             notification will be created for us by the default wndproc. }
  16682.           with TToolButton(Control) do
  16683.           begin
  16684.             { Allow IsControlMouseMsg to deliver message to button }
  16685.             if FInMenuLoop and Self.MouseCapture then MouseCapture := True;
  16686.             if (Style <> tbsDropDown) or
  16687.               (GetComCtlVersion >= ComCtlVersionIE4) and
  16688.               (TWMMouse(Message).XPos < Left + ButtonWidth) then
  16689.               inherited WndProc(Message);
  16690.           end;
  16691.           if not Control.Dragging then DefaultHandler(Message);
  16692.           if (TToolButton(Control).Style <> tbsDropDown) and
  16693.             ((TToolButton(Control).DropdownMenu <> nil) or
  16694.             (TToolButton(Control).MenuItem <> nil)) then
  16695.           begin
  16696.             try
  16697.               SendDropDownMsg(TToolButton(Control));
  16698.             finally
  16699.               { Here we remove WM_LBUTTONDOWN message sent and instead dispatch
  16700.                 it as a WM_LBUTTONUP to get a Click fired. }
  16701.               Msg.Message := 0;
  16702.               if PeekMessage(Msg, Handle, WM_LBUTTONDOWN, WM_LBUTTONDOWN,
  16703.                 PM_REMOVE) and (Msg.Message = WM_QUIT) then
  16704.                 PostQuitMessage(Msg.WParam)
  16705.               else
  16706.               begin
  16707.                 Message.Msg := WM_LBUTTONUP;
  16708.                 Dispatch(Message);
  16709.               end;
  16710.             end;
  16711.           end;
  16712.           Exit;
  16713.         end;
  16714.     end
  16715.   end;
  16716.   inherited WndProc(Message);
  16717. end;
  16718.  
  16719. procedure TToolBar.FlipChildren(AllLevels: Boolean);
  16720. begin { do not flip controls }
  16721. end;
  16722.  
  16723. function TToolBar.FindButtonFromAccel(Accel: Word): TToolButton;
  16724. var
  16725.   I: Integer;
  16726. begin
  16727.   for I := 0 to FButtons.Count - 1 do
  16728.     if TControl(FButtons[I]) is TToolButton then
  16729.     begin
  16730.       Result := TToolButton(FButtons[I]);
  16731.       if Result.Visible and Result.Enabled and IsAccel(Accel, Result.Caption) then
  16732.         Exit;
  16733.     end;
  16734.   Result := nil;
  16735. end;
  16736.  
  16737. { CustomDraw support }
  16738.  
  16739. function TToolBar.IsCustomDrawn(Target: TCustomDrawTarget;
  16740.   Stage: TCustomDrawStage): Boolean;
  16741. begin
  16742.   if Stage = cdPrePaint then
  16743.   begin
  16744.     if Target = dtItem then
  16745.       Result := Assigned(FOnCustomDrawButton) or Assigned(FOnAdvancedCustomDrawButton)
  16746.     else if Target = dtControl then
  16747.       Result := Assigned(FOnCustomDraw) or Assigned(FOnAdvancedCustomDraw) or
  16748.         Assigned(FOnCustomDrawButton) or Assigned(FOnAdvancedCustomDrawButton)
  16749.     else
  16750.       Result := False;
  16751.   end
  16752.   else
  16753.   begin
  16754.     if Target = dtItem then
  16755.       Result := Assigned(FOnAdvancedCustomDrawButton)
  16756.     else if Target = dtControl then
  16757.       Result := Assigned(FOnAdvancedCustomDraw) or Assigned(FOnAdvancedCustomDrawButton)
  16758.     else
  16759.       Result := False;
  16760.   end;
  16761. end;
  16762.  
  16763. function TToolBar.CustomDraw(const ARect: TRect; Stage: TCustomDrawStage): Boolean;
  16764. begin
  16765.   Result := True;
  16766.   if (Stage = cdPrePaint) and Assigned(FOnCustomDraw) then FOnCustomDraw(Self, ARect, Result);
  16767.   if Assigned(FOnAdvancedCustomDraw) then FOnAdvancedCustomDraw(Self, ARect, Stage, Result);
  16768. end;
  16769.  
  16770. function TToolBar.CustomDrawButton(Button: TToolButton; State: TCustomDrawState;
  16771.   Stage: TCustomDrawStage; var Flags: TTBCustomDrawFlags): Boolean;
  16772. begin
  16773.   Result := True;
  16774.   if (Stage = cdPrePaint) and Assigned(FOnCustomDrawButton) then FOnCustomDrawButton(Self, Button, State, Result);
  16775.   if Assigned(FOnAdvancedCustomDrawButton) then FOnAdvancedCustomDrawButton(Self, button, State, Stage, Flags, Result);
  16776. end;
  16777.  
  16778. procedure TToolBar.CanvasChanged(Sender: TObject);
  16779. begin
  16780.   FCanvasChanged := True;
  16781. end;
  16782.  
  16783. { Toolbar menu support }
  16784.  
  16785. var
  16786.   ToolMenuHook: HHOOK;
  16787.   InitDone: Boolean = False;
  16788.   MenuToolBar, MenuToolBar2: TToolBar;
  16789.   MenuButtonIndex: Integer;
  16790.   LastMenuItem: TMenuItem;
  16791.   LastMousePos: TPoint;
  16792.   StillModal: Boolean;
  16793.  
  16794. function ToolMenuGetMsgHook(Code: Integer; WParam: Longint; var Msg: TMsg): Longint; stdcall;
  16795. const
  16796.   RightArrowKey: array[Boolean] of Word = (VK_LEFT, VK_RIGHT);
  16797.   LeftArrowKey: array[Boolean] of Word = (VK_RIGHT, VK_LEFT);
  16798. var
  16799.   P: TPoint;
  16800.   Target: TControl;
  16801.   Item: Integer;
  16802.   FindKind: TFindItemKind;
  16803.   ParentMenu: TMenu;
  16804.  
  16805.   function FindButton(Forward: Boolean): TToolButton;
  16806.   var
  16807.     ToolBar: TToolBar;
  16808.     I, J, Count: Integer;
  16809.   begin
  16810.     ToolBar := MenuToolBar;
  16811.     if ToolBar <> nil then
  16812.     begin
  16813.       J := MenuButtonIndex;
  16814.       I := J;
  16815.       Count := ToolBar.ButtonCount;
  16816.       if Forward then
  16817.         repeat
  16818.           if I = Count - 1 then
  16819.             I := 0
  16820.           else
  16821.             Inc(I);
  16822.           Result := ToolBar.Buttons[I];
  16823.           if Result.Visible and Result.Enabled and Result.Grouped then Exit;
  16824.         until I = J
  16825.       else
  16826.         repeat
  16827.           if I = 0 then
  16828.             I := Count - 1
  16829.           else
  16830.             Dec(I);
  16831.           Result := ToolBar.Buttons[I];
  16832.           if Result.Visible and Result.Enabled and Result.Grouped then Exit;
  16833.         until I = J;
  16834.     end;
  16835.     Result := nil;
  16836.   end;
  16837.  
  16838. begin
  16839.   if LastMenuItem <> nil then
  16840.   begin
  16841.     ParentMenu := LastMenuItem.GetParentMenu;
  16842.     if ParentMenu <> nil then
  16843.     begin
  16844.       if ParentMenu.IsRightToLeft then
  16845.         if Msg.WParam = VK_LEFT then
  16846.           Msg.WParam := VK_RIGHT
  16847.         else if Msg.WParam = VK_RIGHT then
  16848.           Msg.WParam := VK_LEFT;
  16849.     end;
  16850.   end;
  16851.   Result := CallNextHookEx(ToolMenuHook, Code, WParam, Longint(@Msg));
  16852.   if Result <> 0 then Exit;
  16853.   if (Code = MSGF_MENU) then
  16854.   begin
  16855.     Target := nil;
  16856.     if not InitDone then
  16857.     begin
  16858.       InitDone := True;
  16859.       PostMessage(Msg.Hwnd, WM_KEYDOWN, VK_DOWN, 0);
  16860.     end;
  16861.     case Msg.Message of
  16862.       WM_MENUSELECT:
  16863.         begin
  16864.           if (HiWord(Msg.WParam) = $FFFF) and (Msg.LParam = 0) then
  16865.           begin
  16866.             if not StillModal then
  16867.               MenuToolBar.CancelMenu;
  16868.             Exit;
  16869.           end
  16870.           else
  16871.             StillModal := False;
  16872.           FindKind := fkCommand;
  16873.           if HiWord(Msg.WParam) and MF_POPUP <> 0 then FindKind := fkHandle;
  16874.             if FindKind = fkHandle then
  16875.               Item := GetSubMenu(Msg.LParam, LoWord(Msg.WParam))
  16876.             else
  16877.               Item := LoWord(Msg.WParam);
  16878.             LastMenuItem := MenuToolBar.FTempMenu.FindItem(Item, FindKind);
  16879.         end;
  16880.       WM_SYSKEYDOWN:
  16881.         if Msg.WParam = VK_MENU then
  16882.         begin
  16883.           MenuToolBar.CancelMenu;
  16884.           Exit;
  16885.         end;
  16886.       WM_KEYDOWN:
  16887.         if Msg.WParam = VK_RETURN then
  16888.           MenuToolBar.FMenuResult := True
  16889.         else if Msg.WParam = VK_ESCAPE then
  16890.           StillModal := True
  16891.         else if LastMenuItem <> nil then
  16892.         begin
  16893.           if (Msg.WParam = VK_RIGHT) and (LastMenuItem.Count = 0) then
  16894.             Target := FindButton(True)
  16895.           else if (Msg.WParam = VK_LEFT) and (LastMenuItem.GetParentComponent is TPopupMenu) then
  16896.             Target := FindButton(False)
  16897.           else
  16898.             Target := nil;
  16899.           if Target <> nil then
  16900.             P := Target.ClientToScreen(Point(0,0));
  16901.         end;
  16902.       WM_MOUSEMOVE:
  16903.         begin
  16904.           P := Msg.pt;
  16905.           if (P.X <> LastMousePos.X) or (P.Y <> LastMousePos.Y) then
  16906.           begin
  16907.             Target := FindDragTarget(P, False);
  16908.             LastMousePos := P;
  16909.           end;
  16910.         end;
  16911.     end;
  16912.     if (Target <> nil) and (Target is TToolButton) then
  16913.     begin
  16914.       with TToolButton(Target) do
  16915.         if (Index <> MenuButtonIndex) and Grouped and (Parent <> nil) and
  16916.           Parent.HandleAllocated then
  16917.         begin
  16918.           StillModal := True;
  16919.           MenuToolBar.FCaptureChangeCancels := False;
  16920.           MenuToolBar.ClickButton(TToolButton(Target));
  16921.           MenuToolBar.ClickButton(TToolButton(Target));
  16922.         end;
  16923.     end;
  16924.   end;
  16925. end;
  16926.  
  16927. procedure InitToolMenuHooks;
  16928. begin
  16929.   StillModal := False;
  16930.   GetCursorPos(LastMousePos);
  16931.   if ToolMenuHook = 0 then
  16932.     ToolMenuHook := SetWindowsHookEx(WH_MSGFILTER, @ToolMenuGetMsgHook, 0,
  16933.       GetCurrentThreadID);
  16934. end;
  16935.  
  16936. procedure ReleaseToolMenuHooks;
  16937. begin
  16938.   if ToolMenuHook <> 0 then UnhookWindowsHookEx(ToolMenuHook);
  16939.   ToolMenuHook := 0;
  16940.   LastMenuItem := nil;
  16941.   MenuToolBar := nil;
  16942.   MenuButtonIndex := -1;
  16943.   InitDone := False;
  16944. end;
  16945.  
  16946. var
  16947.   ToolMenuKeyHook: HHOOK;
  16948.  
  16949. function ToolMenuKeyMsgHook(Code: Integer; WParam: Longint; var Msg: TMsg): Longint; stdcall;
  16950. begin
  16951.   if (Code = HC_ACTION) then
  16952.   begin
  16953.     if Msg.Message = CM_DEACTIVATE then
  16954.       MenuToolBar2.CancelMenu
  16955.     else if (ToolMenuHook = 0) and ((Msg.Message = WM_CHAR) or
  16956.       (Msg.Message = WM_KEYDOWN) or (Msg.Message = WM_KEYUP) or
  16957.       (Msg.Message = WM_SYSKEYDOWN) or (Msg.Message = WM_SYSKEYUP)) then
  16958.       Msg.hwnd := MenuToolBar2.Handle;
  16959.   end;
  16960.   Result := CallNextHookEx(ToolMenuKeyHook, Code, WParam, Longint(@Msg))
  16961. end;
  16962.  
  16963. procedure InitToolMenuKeyHooks;
  16964. begin
  16965.   if ToolMenuKeyHook = 0 then
  16966.     ToolMenuKeyHook := SetWindowsHookEx(WH_GETMESSAGE, @ToolMenuKeyMsgHook, 0,
  16967.       GetCurrentThreadID);
  16968. end;
  16969.  
  16970. procedure ReleaseToolMenuKeyHooks;
  16971. begin
  16972.   if ToolMenuKeyHook <> 0 then UnhookWindowsHookEx(ToolMenuKeyHook);
  16973.   ToolMenuKeyHook := 0;
  16974.   MenuToolBar2 := nil;
  16975. end;
  16976.  
  16977. procedure TToolBar.ClearTempMenu;
  16978. var
  16979.   I: Integer;
  16980.   Item: TMenuItem;
  16981. begin
  16982.   if (FButtonMenu <> nil) and (FMenuButton <> nil) and
  16983.     (FMenuButton.MenuItem <> nil) and (FTempMenu <> nil) then
  16984.   begin
  16985.     for I := FTempMenu.Items.Count - 1 downto 0 do
  16986.     begin
  16987.       Item := FTempMenu.Items[I];
  16988.       FTempMenu.Items.Delete(I);
  16989.       FButtonMenu.Insert(0, Item);
  16990.     end;
  16991.     FTempMenu.Free;
  16992.     FTempMenu := nil;
  16993.     FMenuButton := nil;
  16994.     FButtonMenu := nil;
  16995.   end;
  16996. end;
  16997.  
  16998. function TToolBar.CheckMenuDropdown(Button: TToolButton): Boolean;
  16999. var
  17000.   Hook: Boolean;
  17001.   Menu: TMenu;
  17002.   Item: TMenuItem;
  17003.   I: Integer;
  17004.   ParentMenu: TMenu;
  17005.   APoint: TPoint;
  17006. begin
  17007.   Result := False;
  17008.   if Button = nil then Exit;
  17009.   FCaptureChangeCancels := False;
  17010.   try
  17011.     if Button.DropdownMenu <> nil then
  17012.       FTempMenu := Button.DropdownMenu
  17013.     else if Button.MenuItem <> nil then
  17014.     begin
  17015.       Button.MenuItem.Click;
  17016.       ClearTempMenu;
  17017.       FTempMenu := TPopupMenu.Create(Self);
  17018.       ParentMenu := Button.MenuItem.GetParentMenu;
  17019.       if ParentMenu <> nil then
  17020.         FTempMenu.BiDiMode := ParentMenu.BiDiMode;
  17021.       FTempMenu.HelpContext := Button.MenuItem.HelpContext;
  17022.       FTempMenu.TrackButton := tbLeftButton;
  17023.       Menu := Button.MenuItem.GetParentMenu;
  17024.       if Menu <> nil then
  17025.         FTempMenu.Images := Menu.Images;
  17026.       FButtonMenu := Button.MenuItem;
  17027.       for I := FButtonMenu.Count - 1 downto 0 do
  17028.       begin
  17029.         Item := FButtonMenu.Items[I];
  17030.         FButtonMenu.Delete(I);
  17031.         FTempMenu.Items.Insert(0, Item);
  17032.       end;
  17033.     end
  17034.     else
  17035.       Exit;
  17036.     SendCancelMode(nil);
  17037.     FTempMenu.PopupComponent := Self;
  17038.     Hook := Button.Grouped or (Button.MenuItem <> nil);
  17039.     if Hook then
  17040.     begin
  17041.       MenuButtonIndex := Button.Index;
  17042.       MenuToolBar := Self;
  17043.       InitToolMenuHooks;
  17044.     end;
  17045.     Perform(TB_SETHOTITEM, -1, 0);
  17046.     try
  17047.       APoint := Button.ClientToScreen(Point(0, Button.ClientHeight));
  17048.       if FTempMenu.IsRightToLeft then Inc(APoint.X, Button.Width);
  17049.       FMenuDropped := True;
  17050.       if GetComCtlVersion = ComCtlVersionIE5 then
  17051.         Button.Invalidate;
  17052.       FTempMenu.Popup(APoint.X, APoint.Y);
  17053.     finally
  17054.       if Hook then ReleaseToolMenuHooks;
  17055.     end;
  17056.     FMenuButton := Button;
  17057.     if StillModal then
  17058.       Perform(TB_SETHOTITEM, Button.Index, 0);
  17059.     Result := True;
  17060.   finally
  17061.     PostMessage(Handle, CN_DROPDOWNCLOSED, 0, 0);
  17062.   end;
  17063. end;
  17064.  
  17065. procedure TToolBar.WMSysCommand(var Message: TWMSysCommand);
  17066.  
  17067.   function IsMenuBar: Boolean;
  17068.   var
  17069.     I: Integer;
  17070.   begin
  17071.     Result := False;
  17072.     for I := 0 to FButtons.Count - 1 do
  17073.       if (TControl(FButtons[I]) is TToolButton)
  17074.       and Assigned(TToolButton(FButtons[I]).MenuItem) then
  17075.       begin
  17076.         Result := True;
  17077.         Break;
  17078.       end;
  17079.   end;
  17080.  
  17081. var
  17082.   Button: TToolButton;
  17083. begin
  17084.   { Enter menu loop if only the Alt key is pressed -- ignore Alt-Space and let
  17085.     the default processing show the system menu. }
  17086.   if not FInMenuLoop and Enabled and Showing and ShowCaptions and IsMenuBar then
  17087.     with Message do
  17088.       if (CmdType and $FFF0 = SC_KEYMENU) and (Key <> VK_SPACE) and
  17089.         (Key <> Word('-')) and (GetCapture = 0) then
  17090.       begin
  17091.         if Key = 0 then
  17092.           Button := nil else
  17093.           Button := FindButtonFromAccel(Key);
  17094.         if (Key = 0) or (Button <> nil) then
  17095.         begin
  17096.           TrackMenu(Button);
  17097.           Result := 1;
  17098.           Exit;
  17099.         end;
  17100.       end;
  17101. end;
  17102.  
  17103. procedure TToolBar.ClickButton(Button: TToolButton);
  17104. var
  17105.   P: TPoint;
  17106. begin
  17107.   FCaptureChangeCancels := False;
  17108.   P := Button.ClientToScreen(Point(0, 0));
  17109.   PostMessage(Handle, WM_LBUTTONDOWN, MK_LBUTTON,
  17110.     Longint(PointToSmallPoint(ScreenToClient(P))));
  17111. end;
  17112.  
  17113. procedure TToolBar.InitMenu(Button: TToolButton);
  17114. begin
  17115.   Perform(TB_SETANCHORHIGHLIGHT, 1, 0);
  17116.   MenuToolBar2 := Self;
  17117.   MouseCapture := True;
  17118.   InitToolMenuKeyHooks;
  17119.   if Button <> nil then
  17120.   begin
  17121.     Perform(TB_SETHOTITEM, Button.Index, 0);
  17122.     ClickButton(Button);
  17123.   end
  17124.   else
  17125.     Perform(TB_SETHOTITEM, 0, 0);
  17126.   if Button = nil then
  17127.     FCaptureChangeCancels := True;
  17128. end;
  17129.  
  17130. procedure TToolBar.CancelMenu;
  17131. begin
  17132.   if FInMenuLoop then
  17133.   begin
  17134.     ReleaseToolMenuKeyHooks;
  17135.     MouseCapture := False;
  17136.     Perform(TB_SETANCHORHIGHLIGHT, 0, 0);
  17137.   end;
  17138.   FInMenuLoop := False;
  17139.   FCaptureChangeCancels := False;
  17140.   Perform(TB_SETHOTITEM, -1, 0);
  17141. end;
  17142.  
  17143. function TToolBar.TrackMenu(Button: TToolButton): Boolean;
  17144. begin
  17145.   { Alread in menu loop - click button to drop-down menu }
  17146.   if FInMenuLoop then
  17147.   begin
  17148.     if Button <> nil then
  17149.     begin
  17150.       ClickButton(Button);
  17151.       Result := True;
  17152.     end
  17153.     else
  17154.       Result := False;
  17155.     Exit;
  17156.   end;
  17157.  
  17158.   InitMenu(Button);
  17159.   try
  17160.     FInMenuLoop := True;
  17161.     repeat
  17162.       Application.HandleMessage;
  17163.       if Application.Terminated then
  17164.         FInMenuLoop := False;
  17165.     until not FInMenuLoop;
  17166.  
  17167.   finally
  17168.     CancelMenu;
  17169.   end;
  17170.   Result := FMenuResult;
  17171. end;
  17172.  
  17173. procedure TToolBar.CMFontChanged(var Message);
  17174. begin
  17175.   if HandleAllocated and FShowCaptions then Perform(WM_SETFONT, Font.Handle, 0);
  17176.   NotifyControls(CM_PARENTFONTCHANGED);
  17177. end;
  17178.  
  17179. { TCoolBand }
  17180.  
  17181. constructor TCoolBand.Create(Collection: TCollection);
  17182. begin
  17183.   FWidth := 40;
  17184.   FBreak := True;
  17185.   FColor := clBtnFace;
  17186.   FFixedBackground := True;
  17187.   FImageIndex := -1;
  17188.   FMinHeight := 25;
  17189.   FParentColor := True;
  17190.   FParentBitmap := True;
  17191.   FBitmap := TBitmap.Create;
  17192.   FBitmap.OnChange := BitmapChanged;
  17193.   FVisible := True;
  17194.   FDDB := TBitmap.Create;
  17195.   inherited Create(Collection);
  17196.   ParentColorChanged;
  17197.   ParentBitmapChanged;
  17198. end;
  17199.  
  17200. destructor TCoolBand.Destroy;
  17201. var
  17202.   AControl: TWinControl;
  17203. begin
  17204.   FDDB.Free;
  17205.   FBitmap.Free;
  17206.   AControl := Control;
  17207.   FControl := nil;
  17208.   inherited Destroy;
  17209.   if (AControl <> nil) and not (csDestroying in AControl.ComponentState) and
  17210.     AControl.HandleAllocated then
  17211.   begin
  17212.     AControl.BringToFront;
  17213.     AControl.Perform(CM_SHOWINGCHANGED, 0, 0);
  17214.   end;
  17215. end;
  17216.  
  17217. procedure TCoolBand.Assign(Source: TPersistent);
  17218.  
  17219.   function FindControl(AControl: TWinControl): TWinControl;
  17220.   begin
  17221.     if AControl <> nil then
  17222.       Result := CoolBar.Owner.FindComponent(AControl.Name) as TWinControl
  17223.     else
  17224.       Result := nil;
  17225.   end;
  17226.  
  17227. begin
  17228.   if Source is TCoolBand then
  17229.   begin
  17230.     Bitmap := TCoolBand(Source).Bitmap;
  17231.     Break := TCoolBand(Source).Break;
  17232.     Color := TCoolBand(Source).Color;
  17233.     FixedBackground := TCoolBand(Source).FixedBackground;
  17234.     FixedSize := TCoolBand(Source).FixedSize;
  17235.     HorizontalOnly := TCoolBand(Source).HorizontalOnly;
  17236.     ImageIndex := TCoolBand(Source).ImageIndex;
  17237.     MinHeight := TCoolBand(Source).MinHeight;
  17238.     MinWidth := TCoolBand(Source).MinWidth;
  17239.     ParentBitmap := TCoolBand(Source).ParentBitmap;
  17240.     ParentColor := TCoolBand(Source).ParentColor;
  17241.     Text := TCoolBand(Source).Text;
  17242.     Visible := TCoolBand(Source).Visible;
  17243.     Width := TCoolBand(Source).Width;
  17244.     Control := FindControl(TCoolBand(Source).Control);
  17245.   end
  17246.   else inherited Assign(Source);
  17247. end;
  17248.  
  17249. function TCoolBand.GetDisplayName: string;
  17250. begin
  17251.   Result := FText;
  17252.   if Result = '' then Result := inherited GetDisplayName;
  17253. end;
  17254.  
  17255. function TCoolBand.GetVisible: Boolean;
  17256. begin
  17257.   Result := FVisible and (not CoolBar.Vertical or not FHorizontalOnly);
  17258. end;
  17259.  
  17260. function TCoolBand.CoolBar: TCoolBar;
  17261. begin
  17262.   Result := TCoolBands(Collection).FCoolBar;
  17263. end;
  17264.  
  17265. procedure TCoolBand.ParentColorChanged;
  17266. begin
  17267.   if FParentColor then
  17268.   begin
  17269.     SetColor(CoolBar.Color);
  17270.     FParentColor := True;
  17271.   end;
  17272. end;
  17273.  
  17274. procedure TCoolBand.ParentBitmapChanged;
  17275. begin
  17276.   BitmapChanged(Self);
  17277. end;
  17278.  
  17279. procedure TCoolBand.BitmapChanged(Sender: TObject);
  17280. begin
  17281.   if not ParentBitmap then
  17282.   begin
  17283.     FDDB.Assign(FBitmap);
  17284.     if not FDDB.Empty then FDDB.HandleType := bmDDB;
  17285.   end
  17286.   else
  17287.     FDDB.Assign(nil);
  17288.   Changed(False);
  17289. end;
  17290.  
  17291. procedure TCoolBand.SetBitmap(Value: TBitmap);
  17292. begin
  17293.   FParentBitmap := False;
  17294.   FBitmap.Assign(Value);
  17295.   Changed(True);
  17296. end;
  17297.  
  17298. function TCoolBand.GetHeight: Integer;
  17299. begin
  17300.   Result := CoolBar.GetRowHeight(Index);
  17301. end;
  17302.  
  17303. procedure TCoolBand.SetBorderStyle(Value: TBorderStyle);
  17304. begin
  17305.   if FBorderStyle <> Value then
  17306.   begin
  17307.     FBorderStyle := Value;
  17308.     Changed(False);
  17309.   end;
  17310. end;
  17311.  
  17312. procedure TCoolBand.SetBreak(Value: Boolean);
  17313. begin
  17314.   if FBreak <> Value then
  17315.   begin
  17316.     FBreak := Value;
  17317.     Changed(False);
  17318.   end;
  17319. end;
  17320.  
  17321. procedure TCoolBand.SetFixedSize(Value: Boolean);
  17322. begin
  17323.   if FFixedSize <> Value then
  17324.   begin
  17325.     if Value then
  17326.     begin
  17327.       FBreak := False;
  17328.       FFixedSize := True;
  17329.       Changed(True);
  17330.     end
  17331.     else
  17332.     begin
  17333.       FFixedSize := False;
  17334.       Changed(False);
  17335.     end;
  17336.   end;
  17337. end;
  17338.  
  17339. procedure TCoolBand.SetMinHeight(Value: Integer);
  17340. begin
  17341.   if FMinHeight <> Value then
  17342.   begin
  17343.     FMinHeight := Value;
  17344.     Changed(False);
  17345.   end;
  17346. end;
  17347.  
  17348. procedure TCoolBand.SetMinWidth(Value: Integer);
  17349. begin
  17350.   if FMinWidth <> Value then
  17351.   begin
  17352.     FMinWidth := Value;
  17353.     Changed(FixedSize);
  17354.   end;
  17355. end;
  17356.  
  17357. procedure TCoolBand.SetVisible(Value: Boolean);
  17358. begin
  17359.   if FVisible <> Value then
  17360.   begin
  17361.     FVisible := Value;
  17362.     Changed(True);
  17363.   end;
  17364. end;
  17365.  
  17366. procedure TCoolBand.SetHorizontalOnly(Value: Boolean);
  17367. begin
  17368.   if FHorizontalOnly <> Value then
  17369.   begin
  17370.     FHorizontalOnly := Value;
  17371.     Changed(CoolBar.Vertical);
  17372.   end;
  17373. end;
  17374.  
  17375. procedure TCoolBand.SetImageIndex(Value: TImageIndex);
  17376. begin
  17377.   if FImageIndex <> Value then
  17378.   begin
  17379.     FImageIndex := Value;
  17380.     Changed(False);
  17381.   end;
  17382. end;
  17383.  
  17384. procedure TCoolBand.SetFixedBackground(Value: Boolean);
  17385. begin
  17386.   if FFixedBackground <> Value then
  17387.   begin
  17388.     FFixedBackground := Value;
  17389.     Changed(False);
  17390.   end;
  17391. end;
  17392.  
  17393. procedure TCoolBand.SetColor(Value: TColor);
  17394. begin
  17395.   if FColor <> Value then
  17396.   begin
  17397.     FColor := Value;
  17398.     FParentColor := False;
  17399.     Changed(False);
  17400.   end;
  17401. end;
  17402.  
  17403. procedure TCoolBand.SetControl(Value: TWinControl);
  17404. var
  17405.   Band: TCoolBand;
  17406.   PrevControl: TWinControl;
  17407. begin
  17408.   if FControl <> Value then
  17409.   begin
  17410.     if Value <> nil then
  17411.     begin
  17412.       Band := TCoolBands(Collection).FindBand(Value);
  17413.       if (Band <> nil) and (Band <> Self) then Band.SetControl(nil);
  17414.     end;
  17415.     PrevControl := FControl;
  17416.     FControl := Value;
  17417.     if Value <> nil then Value.FreeNotification(CoolBar);
  17418.     Changed(True);
  17419.     if PrevControl <> nil then PrevControl.Perform(CM_SHOWINGCHANGED, 0, 0);
  17420.   end;
  17421. end;
  17422.  
  17423. procedure TCoolBand.SetText(const Value: string);
  17424. begin
  17425.   if FText <> Value then
  17426.   begin
  17427.     FText := Value;
  17428.     Changed(True);
  17429.   end;
  17430. end;
  17431.  
  17432. function TCoolBand.IsColorStored: Boolean;
  17433. begin
  17434.   Result := not ParentColor;
  17435. end;
  17436.  
  17437. procedure TCoolBand.SetParentColor(Value: Boolean);
  17438. begin
  17439.   if FParentColor <> Value then
  17440.   begin
  17441.     FParentColor := Value;
  17442.     Changed(False);
  17443.   end;
  17444. end;
  17445.  
  17446. function TCoolBand.IsBitmapStored: Boolean;
  17447. begin
  17448.   Result := not ParentBitmap;
  17449. end;
  17450.  
  17451. procedure TCoolBand.SetParentBitmap(Value: Boolean);
  17452. begin
  17453.   if FParentBitmap <> Value then
  17454.   begin
  17455.     FParentBitmap := Value;
  17456.     ParentBitmapChanged;
  17457.   end;
  17458. end;
  17459.  
  17460. procedure TCoolBand.SetWidth(Value: Integer);
  17461. begin
  17462.   if FWidth <> Value then
  17463.   begin
  17464.     FWidth := Value;
  17465.     Changed(False);
  17466.   end;
  17467. end;
  17468.  
  17469. { TCoolBands }
  17470.  
  17471. constructor TCoolBands.Create(CoolBar: TCoolBar);
  17472. begin
  17473.   inherited Create(TCoolBand);
  17474.   FCoolBar := CoolBar;
  17475. end;
  17476.  
  17477. function TCoolBands.Add: TCoolBand;
  17478. begin
  17479.   Result := TCoolBand(inherited Add);
  17480. end;
  17481.  
  17482. function TCoolBands.FindBand(AControl: TControl): TCoolBand;
  17483. var
  17484.   I: Integer;
  17485. begin
  17486.   for I := 0 to Count - 1 do
  17487.   begin
  17488.     Result := TCoolBand(inherited GetItem(I));
  17489.     if Result.FControl = AControl then Exit;
  17490.   end;
  17491.   Result := nil;
  17492. end;
  17493.  
  17494. function TCoolBands.HaveGraphic: Boolean;
  17495. var
  17496.   I: Integer;
  17497. begin
  17498.   Result := False;
  17499.   for I := 0 to Count - 1 do
  17500.     if not Items[I].FDDB.Empty then
  17501.     begin
  17502.       Result := True;
  17503.       Exit;
  17504.     end;
  17505. end;
  17506.  
  17507. function TCoolBands.GetItem(Index: Integer): TCoolBand;
  17508. begin
  17509.   Result := TCoolBand(inherited GetItem(Index));
  17510. end;
  17511.  
  17512. function TCoolBands.GetOwner: TPersistent;
  17513. begin
  17514.   Result := FCoolBar;
  17515. end;
  17516.  
  17517. procedure TCoolBands.SetItem(Index: Integer; Value: TCoolBand);
  17518. begin
  17519.   inherited SetItem(Index, Value);
  17520. end;
  17521.  
  17522. procedure TCoolBands.Update(Item: TCollectionItem);
  17523. begin
  17524.   if (Item <> nil) then
  17525.     FCoolBar.UpdateBand(Item.Index)
  17526.   else
  17527.     FCoolBar.UpdateBands;
  17528. end;
  17529.  
  17530. { TToolButtonActionLink }
  17531.  
  17532. procedure TToolButtonActionLink.AssignClient(AClient: TObject);
  17533. begin
  17534.   inherited AssignClient(AClient);
  17535.   FClient := AClient as TToolButton;
  17536. end;
  17537.  
  17538. function TToolButtonActionLink.IsCheckedLinked: Boolean;
  17539. begin
  17540.   Result := inherited IsCheckedLinked and
  17541.     (FClient.Down = (Action as TCustomAction).Checked);
  17542. end;
  17543.  
  17544. function TToolButtonActionLink.IsImageIndexLinked: Boolean;
  17545. begin
  17546.   Result := inherited IsImageIndexLinked and
  17547.     (FClient.ImageIndex = (Action as TCustomAction).ImageIndex);
  17548. end;
  17549.  
  17550. procedure TToolButtonActionLink.SetChecked(Value: Boolean);
  17551. begin
  17552.   if IsCheckedLinked then FClient.Down := Value;
  17553. end;
  17554.  
  17555. procedure TToolButtonActionLink.SetImageIndex(Value: Integer);
  17556. begin
  17557.   if IsImageIndexLinked then FClient.ImageIndex := Value;
  17558. end;
  17559.  
  17560. { TToolBarDragDockObject }
  17561.  
  17562. function TToolBarDockObject.GetDragCursor(Accepted: Boolean; X, Y: Integer): TCursor;
  17563. begin
  17564.   if Accepted then Result := crDrag
  17565.   else Result := crNoDrop;
  17566. end;
  17567.  
  17568. procedure TToolBarDockObject.AdjustDockRect(ARect: TRect);
  17569. var
  17570.   CX, CY: Integer;
  17571. begin
  17572.   { Adjust DockRect so that its upper left corner is under mouse cursor }
  17573.   inherited AdjustDockRect(ARect);
  17574.   with DockRect do
  17575.   begin
  17576.     CX := DragPos.X - Left;
  17577.     CY := DragPos.Y - Top;
  17578.     Inc(Left, CX);
  17579.     Inc(Top, CY);
  17580.     Inc(Right, CX);
  17581.     Inc(Bottom, CY);
  17582.   end;
  17583. end;
  17584.  
  17585. function TToolBarDockObject.ToolDockImage(Erase: Boolean): Boolean;
  17586. var
  17587.   DesktopWindow: HWND;
  17588.   DC: HDC;
  17589.   OldBrush: HBrush;
  17590.   DrawRect: TRect;
  17591.   PenSize: Integer;
  17592.   ToolBar: TToolBar;
  17593.   FromIndex, ToIndex: Integer;
  17594.   Pos: TPoint;
  17595.  
  17596.   function IndexOfControl: Integer;
  17597.   begin
  17598.     for Result := 0 to TToolBar(DragTarget).ButtonCount - 1 do
  17599.       if TToolBar(DragTarget).Buttons[Result] = Control then Exit;
  17600.     Result := -1;
  17601.   end;
  17602.  
  17603. begin
  17604.   { Find toolbar rect }
  17605.   if not Erase or (TObject(DragTarget) is TToolBar) then
  17606.   begin
  17607.     ToolBar := TToolBar(DragTarget);
  17608.     if Control.Parent = ToolBar then
  17609.       FromIndex := IndexOfControl else
  17610.       FromIndex := -1;
  17611.     Pos := ToolBar.ScreenToClient(DockRect.TopLeft);
  17612.     ToIndex := ToolBar.ButtonIndex(FromIndex, Pos.X, Pos.Y);
  17613.     DrawRect := DockRect;
  17614.     if ToIndex >= 0 then
  17615.     begin
  17616.       if ToolBar.ButtonCount = 0 then
  17617.         Pos := Point(0, 0)
  17618.       else if ToIndex = ToolBar.ButtonCount then
  17619.         with ToolBar.Buttons[ToIndex-1] do
  17620.           Pos := Point(Left + Width, Top)
  17621.       else
  17622.         with ToolBar.Buttons[ToIndex] do
  17623.           Pos := Point(Left, Top);
  17624.       with DrawRect do
  17625.         DrawRect := Bounds(Pos.X, Pos.Y, Right - Left, Bottom - Top);
  17626.       MapWindowPoints(ToolBar.Handle, 0, DrawRect, 2);
  17627.     end;
  17628.     Result := not Cancelling and CompareMem(@DrawRect, @FEraseDockRect, SizeOf(TRect));
  17629.   end
  17630.   else
  17631.     Result := False;
  17632.  
  17633.   { Only erase when DrawRect differs }
  17634.   if Erase then
  17635.   begin
  17636.     if Result then Exit;
  17637.     DrawRect := FEraseDockRect;
  17638.   end
  17639.   else
  17640.   begin
  17641.     DockRect := DrawRect;
  17642.     Result := not Result;
  17643.     if not Result then Exit;
  17644.     FEraseDockRect := DrawRect;
  17645.   end;
  17646.  
  17647.   PenSize := FrameWidth;
  17648.   DesktopWindow := GetDesktopWindow;
  17649.   DC := GetDCEx(DesktopWindow, 0, DCX_CACHE or DCX_LOCKWINDOWUPDATE);
  17650.   try
  17651.     OldBrush := SelectObject(DC, Brush.Handle);
  17652.     with DrawRect do
  17653.     begin
  17654.       PatBlt(DC, Left + PenSize, Top, Right - Left - PenSize, PenSize, PATINVERT);
  17655.       PatBlt(DC, Right - PenSize, Top + PenSize, PenSize, Bottom - Top - PenSize, PATINVERT);
  17656.       PatBlt(DC, Left, Bottom - PenSize, Right - Left - PenSize, PenSize, PATINVERT);
  17657.       PatBlt(DC, Left, Top, PenSize, Bottom - Top - PenSize, PATINVERT);
  17658.     end;
  17659.     SelectObject(DC, OldBrush);
  17660.   finally
  17661.     ReleaseDC(DesktopWindow, DC);
  17662.   end;
  17663. end;
  17664.  
  17665. procedure TToolBarDockObject.DrawDragDockImage;
  17666. begin
  17667.   if TObject(DragTarget) is TToolBar then
  17668.   begin
  17669.     FErase := True;
  17670.     ToolDockImage(False);
  17671.   end
  17672.   else
  17673.   begin
  17674.     FEraseDockRect := Rect(0,0,0,0);
  17675.     inherited DrawDragDockImage;
  17676.   end;
  17677. end;
  17678.  
  17679. procedure TToolBarDockObject.EraseDragDockImage;
  17680. begin
  17681.   if FErase then
  17682.   begin
  17683.     FErase := False;
  17684.     ToolDockImage(True);
  17685.   end
  17686.   else
  17687.     inherited EraseDragDockImage;
  17688. end;
  17689.  
  17690. { TCoolBar }
  17691.  
  17692. const
  17693.   GripSizeIE3 = 8;
  17694.   GripSizeIE4 = 5;
  17695.   ControlMargin = 4;
  17696.   BandBorderSize = 2;
  17697.   IDMask = $7FFFFFFF;
  17698.   SoftBreakMask = $80000000;
  17699.   { Results for HitTest }
  17700.   RBHT_NONE = RBHT_CLIENT or RBHT_NOWHERE;
  17701.  
  17702. { Maintain backward compatibility with IE3 }
  17703. function SizeOfReBarBandInfo: Integer; assembler;
  17704. const
  17705.   SizeOfStruct = SizeOf(TReBarBandInfo);
  17706. asm
  17707.         CALL    GetComCtlVersion
  17708.         CMP     EAX,ComCtlVersionIE4
  17709.         MOV     EAX,SizeOfStruct
  17710.         JNL     @@1
  17711.         MOV     EAX,TReBarBandInfo.cyChild
  17712. @@1:
  17713. end;
  17714.  
  17715. constructor TCoolBar.Create(AOwner: TComponent);
  17716. begin
  17717.   CheckCommonControl(ICC_COOL_CLASSES);
  17718.   inherited Create(AOwner);
  17719.   ControlStyle := [csAcceptsControls, csCaptureMouse, csClickEvents, csOpaque,
  17720.     csDoubleClicks];
  17721.   Width := 150;
  17722.   Height := 75;
  17723.   Align := alTop;
  17724.   ParentColor := True;
  17725.   ParentFont := True;
  17726.   FBandBorderStyle := bsSingle;
  17727.   FBandMaximize := bmClick;
  17728.   FBitmap := TBitmap.Create;
  17729.   FBitmap.OnChange := BitmapChanged;
  17730.   FCaptionFont := TFont.Create;
  17731.   FShowText := True;
  17732.   FDDB := TBitmap.Create;
  17733.   FBands := TCoolBands.Create(Self);
  17734.   FImageChangeLink := TChangeLink.Create;
  17735.   FImageChangeLink.OnChange := ImageListChange;
  17736. end;
  17737.  
  17738. destructor TCoolBar.Destroy;
  17739. begin
  17740.   FBands.Free;
  17741.   FImageChangeLink.Free;
  17742.   FDDB.Free;
  17743.   FCaptionFont.Free;
  17744.   FBitmap.Free;
  17745.   inherited Destroy;
  17746. end;
  17747.  
  17748. procedure TCoolBar.CreateParams(var Params: TCreateParams);
  17749. const
  17750.   DefaultStyles = CCS_NOPARENTALIGN or CCS_NOMOVEY or CCS_NORESIZE or CCS_NODIVIDER;
  17751.   BandBorderStyles: array[TBorderStyle] of DWORD = (0, RBS_BANDBORDERS);
  17752.   FixedStyles: array[Boolean] of DWORD = (0, RBS_FIXEDORDER);
  17753.   HeightStyles: array[Boolean] of DWORD = (RBS_VARHEIGHT, 0);
  17754.   VerticalStyles: array[Boolean] of DWORD = (0, CCS_VERT);
  17755. begin
  17756.   inherited CreateParams(Params);
  17757.   CreateSubClass(Params, REBARCLASSNAME);
  17758.   with Params do
  17759.   begin
  17760.     Style := Style or DefaultStyles or BandBorderStyles[FBandBorderStyle] or
  17761.       FixedStyles[FFixedOrder] or HeightStyles[FFixedSize] or
  17762.       VerticalStyles[FVertical];
  17763.     if BandMaximize = bmDblClick then Style := Style or RBS_DBLCLKTOGGLE;
  17764.     WindowClass.style := WindowClass.style and not (CS_HREDRAW or CS_VREDRAW) or
  17765.       CS_DBLCLKS;
  17766.   end;
  17767. end;
  17768.  
  17769. procedure TCoolBar.CreateWnd;
  17770. begin
  17771.   inherited CreateWnd;
  17772.   FCaptionFont.Handle := GetCaptionFont;
  17773.   FCaptionFontHeight := GetCaptionFontHeight;
  17774.   if not (csLoading in ComponentState) then UpdateBands;
  17775. end;
  17776.  
  17777. procedure TCoolBar.Loaded;
  17778. begin
  17779.   inherited Loaded;
  17780.   UpdateBands;
  17781. end;
  17782.  
  17783. procedure TCoolBar.RefreshControl(Band: TCoolBand);
  17784. var
  17785.   NewWidth, NewMinHeight, CaptionSize, W, H: Integer;
  17786.   DoUpdate: Boolean;
  17787.  
  17788.   function IsBandCurrent: Boolean;
  17789.   var
  17790.     BandInfo: TReBarBandInfo;
  17791.   begin
  17792.     FillChar(BandInfo, SizeOfReBarBandInfo, 0);
  17793.     BandInfo.cbSize := SizeOfReBarBandInfo;
  17794.     BandInfo.fMask := RBBIM_CHILD;
  17795.     Result := TWinControl(Band.Control).HandleAllocated and
  17796.       (Perform(RB_GETBANDINFO_PRE_IE4, Band.FID and IDMask, Integer(@BandInfo)) <> 0) and
  17797.       (BandInfo.hwndChild = TWinControl(Band.Control).Handle);
  17798.   end;
  17799.  
  17800. begin
  17801.   { Refresh band if control has moved/resized }
  17802.   if (Band <> nil) and (Band.Control <> nil) then
  17803.   begin
  17804.     // The following line can be removed to prevent the band's visible state
  17805.     // from being synchronized with the control.
  17806.     Band.Visible := Band.Control.Visible;
  17807.     BeginUpdate;
  17808.     try
  17809.       CaptionSize := GetCaptionSize(Band);
  17810.       if Vertical then
  17811.       begin
  17812.         W := Band.Control.Height;
  17813.         H := Band.Control.Width;
  17814.       end
  17815.       else
  17816.       begin
  17817.         W := Band.Control.Width;
  17818.         H := Band.Control.Height;
  17819.       end;
  17820.       NewWidth := W + CaptionSize + ControlMargin;
  17821.       NewMinHeight := H;
  17822.       if (NewWidth <> Band.Width) or (NewMinHeight <> Band.MinHeight) or
  17823.         not IsBandCurrent then
  17824.       begin
  17825.         DoUpdate := True;
  17826.         if Band.FixedSize or FixedOrder and (Band.FID and IDMask = 0) then
  17827.           Dec(NewWidth, ControlMargin);
  17828.         Band.Width := NewWidth;
  17829.         Band.MinHeight := NewMinHeight;
  17830.       end
  17831.       else DoUpdate := False;
  17832.     finally
  17833.       EndUpdate;
  17834.     end;
  17835.     if DoUpdate then
  17836.     begin
  17837.       Bands.Update(Band);
  17838.       ReadBands;
  17839.     end;
  17840.   end;
  17841. end;
  17842.  
  17843. procedure TCoolBar.AlignControls(AControl: TControl; var Rect: TRect);
  17844. var
  17845.   I: Integer;
  17846. begin
  17847.   if not (csDestroying in ComponentState) and (FUpdateCount = 0) and
  17848.     ((AControl = nil) and (Bands.Count > 0) or (AControl is TWinControl)) then
  17849.   begin
  17850.     ReadBands;
  17851.     if AControl = nil then
  17852.     begin
  17853.       for I := 0 to FBands.Count - 1 do
  17854.         RefreshControl(FBands[I]);
  17855.     end
  17856.     else RefreshControl(FBands.FindBand(TWinControl(AControl)));
  17857.   end;
  17858. end;
  17859.  
  17860. procedure TCoolBar.Change;
  17861. var
  17862.   Form: TCustomForm;
  17863. begin
  17864.   if csDesigning in ComponentState then
  17865.   begin
  17866.     Form := GetParentForm(Self);
  17867.     if (Form <> nil) and (Form.Designer <> nil) then Form.Designer.Modified;
  17868.   end;
  17869.   if Assigned(FOnChange) then FOnChange(Self);
  17870. end;
  17871.  
  17872. function TCoolBar.GetAlign: TAlign;
  17873. begin
  17874.   Result := inherited Align;
  17875. end;
  17876.  
  17877. { Coolbars take their text font from Windows' caption font minus any bold
  17878.   characteristics it may have. }
  17879. function TCoolBar.GetCaptionFont: HFONT;
  17880. var
  17881.   NonClientMetrics: TNonClientMetrics;
  17882. begin
  17883.   with NonClientMetrics do
  17884.   begin
  17885.     cbSize := sizeof(TNonClientMetrics);
  17886.     if not SystemParametersInfo(SPI_GETNONCLIENTMETRICS, 0, @NonClientMetrics, 0) then
  17887.       GetObject(GetStockObject(SYSTEM_FONT), SizeOf(lfCaptionFont), @lfCaptionFont);
  17888.     { Remove any bold styles }
  17889.     lfCaptionFont.lfWeight := FW_NORMAL;
  17890.     Result := CreateFontIndirect(lfCaptionFont)
  17891.   end;
  17892. end;
  17893.  
  17894. function TCoolBar.GetCaptionFontHeight: Integer;
  17895. var
  17896.   TxtMetric: TTextMetric;
  17897. begin
  17898.   Result := 0;
  17899.   if HandleAllocated then
  17900.     with TControlCanvas.Create do
  17901.     try
  17902.       Control := Self;
  17903.       Font := FCaptionFont;
  17904.       if (GetTextMetrics(Handle, TxtMetric)) then
  17905.         Result := TxtMetric.tmHeight;
  17906.     finally
  17907.       Free;
  17908.     end;
  17909. end;
  17910.  
  17911. { Return height/width (depending on Vertical property) of coolbar grip area }
  17912. function TCoolBar.GetCaptionSize(Band: TCoolBand): Integer;
  17913. var
  17914.   Text: string;
  17915.   Adjust, DesignText: Boolean;
  17916. begin
  17917.   Result := 0;
  17918.   Adjust := False;
  17919.   if (Band <> nil) and ((csDesigning in ComponentState) or Band.Visible) then
  17920.   begin
  17921.     DesignText := (csDesigning in ComponentState) and
  17922.       (Band.Control = nil) and (Band.Text = '');
  17923.     if ShowText or DesignText then
  17924.     begin
  17925.       if DesignText then
  17926.         Text := Band.DisplayName
  17927.       else
  17928.         Text := Band.Text;
  17929.       if Text <> '' then
  17930.       begin
  17931.         Adjust := True;
  17932.         if Vertical then
  17933.           Result := FCaptionFontHeight
  17934.         else
  17935.           with TControlCanvas.Create do
  17936.           try
  17937.             Control := Self;
  17938.             Font := FCaptionFont;
  17939.             Result := TextWidth(Text)
  17940.           finally
  17941.             Free;
  17942.           end;
  17943.       end;
  17944.     end;
  17945.     if Band.ImageIndex >= 0 then
  17946.     begin
  17947.       if Adjust then Inc(Result, 2);
  17948.       if FImages <> nil then
  17949.       begin
  17950.         Adjust := True;
  17951.         if Vertical then
  17952.           Inc(Result, FImages.Height)
  17953.         else
  17954.           Inc(Result, FImages.Width)
  17955.       end
  17956.       else if not Adjust then
  17957.         Inc(Result, ControlMargin);
  17958.     end;
  17959.     if Adjust then Inc(Result, ControlMargin);
  17960.     if (not FixedOrder or (Band.FID and IDMask > 0)) and not Band.FixedSize then
  17961.     begin
  17962.       Inc(Result, ControlMargin);
  17963.       { The grip size in IE4 is 3 pixels narrower than IE3 }
  17964.       if GetComCtlVersion < ComCtlVersionIE4 then
  17965.         Inc(Result, GripSizeIE3)
  17966.       else
  17967.         Inc(Result, GripSizeIE4);
  17968.     end;
  17969.   end;
  17970. end;
  17971.  
  17972. procedure TCoolBar.SetAlign(Value: TAlign);
  17973. var
  17974.   PrevAlign, NewAlign: TAlign;
  17975. begin
  17976.   PrevAlign := inherited Align;
  17977.   inherited Align := Value;
  17978.   NewAlign := inherited Align;
  17979.   if not (csReading in ComponentState) then
  17980.     if NewAlign <> PrevAlign then
  17981.       case NewAlign of
  17982.         alLeft, alRight: Vertical := True;
  17983.         alTop, alBottom: Vertical := False;
  17984.       end;
  17985. end;
  17986.  
  17987. procedure TCoolBar.SetBands(Value: TCoolBands);
  17988. begin
  17989.   FBands.Assign(Value);
  17990. end;
  17991.  
  17992. procedure TCoolBar.SetBandBorderStyle(Value: TBorderStyle);
  17993. begin
  17994.   if FBandBorderStyle <> Value then
  17995.   begin
  17996.     FBandBorderStyle := Value;
  17997.     RecreateWnd;
  17998.   end;
  17999. end;
  18000.  
  18001. procedure TCoolBar.SetBandMaximize(Value: TCoolBandMaximize);
  18002. begin
  18003.   if FBandMaximize <> Value then
  18004.   begin
  18005.     FBandMaximize := Value;
  18006.     RecreateWnd;
  18007.   end;
  18008. end;
  18009.  
  18010. procedure TCoolBar.SetFixedSize(Value: Boolean);
  18011. begin
  18012.   if FFixedSize <> Value then
  18013.   begin
  18014.     FFixedSize := Value;
  18015.     RecreateWnd;
  18016.   end;
  18017. end;
  18018.  
  18019. procedure TCoolBar.SetFixedOrder(Value: Boolean);
  18020. begin
  18021.   if FFixedOrder <> Value then
  18022.   begin
  18023.     FFixedOrder := Value;
  18024.     RecreateWnd;
  18025.   end;
  18026. end;
  18027.  
  18028. procedure TCoolBar.ImageListChange(Sender: TObject);
  18029. begin
  18030.   if HandleAllocated and (Sender = Images) then
  18031.     if Images.HandleAllocated then
  18032.       SetImageList(Images.Handle)
  18033.     else
  18034.       SetImageList(0);
  18035. end;
  18036.  
  18037. procedure TCoolBar.SetImageList(Value: HImageList);
  18038. var
  18039.   BarInfo: TReBarInfo;
  18040. begin
  18041.   if HandleAllocated then
  18042.   begin
  18043.     if Value = 0 then
  18044.       RecreateWnd
  18045.     else
  18046.     begin
  18047.       BarInfo.cbSize := SizeOf(TReBarInfo);
  18048.       BarInfo.fMask := RBIM_IMAGELIST;
  18049.       BarInfo.himl := Value;
  18050.       Perform(RB_SETBARINFO, 0, Integer(@BarInfo));
  18051.       Invalidate;
  18052.     end;
  18053.   end;
  18054. end;
  18055.  
  18056. procedure TCoolBar.SetImages(Value: TCustomImageList);
  18057. begin
  18058.   if FImages <> nil then FImages.UnRegisterChanges(FImageChangeLink);
  18059.   FImages := Value;
  18060.   if FImages <> nil then
  18061.   begin
  18062.     FImages.RegisterChanges(FImageChangeLink);
  18063.     FImages.FreeNotification(Self);
  18064.     SetImageList(FImages.Handle);
  18065.   end
  18066.   else SetImageList(0);
  18067. end;
  18068.  
  18069. procedure TCoolBar.SetShowText(Value: Boolean);
  18070. begin
  18071.   if FShowText <> Value then
  18072.   begin
  18073.     FShowText := Value;
  18074.     if not (csLoading in ComponentState) then UpdateBands;
  18075.   end;
  18076. end;
  18077.  
  18078. procedure TCoolBar.Notification(AComponent: TComponent;
  18079.   Operation: TOperation);
  18080. var
  18081.   Band: TCoolBand;
  18082. begin
  18083.   inherited Notification(AComponent, Operation);
  18084.   if not (csDestroying in ComponentState) and (Operation = opRemove) then
  18085.   begin
  18086.     if (AComponent is TWinControl) then
  18087.     begin
  18088.       Band := Bands.FindBand(TControl(AComponent));
  18089.       if Band <> nil then Band.FControl := nil;
  18090.     end
  18091.     else if AComponent = FImages then Images := nil;
  18092.   end;
  18093. end;
  18094.  
  18095. procedure TCoolBar.FlipChildren(AllLevels: Boolean);
  18096. begin { do not flip controls }
  18097. end;
  18098.  
  18099. function TCoolBar.GetPalette: HPALETTE;
  18100. begin
  18101.   if not FDDB.Empty then
  18102.     Result := FDDB.Palette
  18103.   else
  18104.     Result := inherited GetPalette;
  18105. end;
  18106.  
  18107. procedure TCoolBar.BitmapChanged(Sender: TObject);
  18108. var
  18109.   I: Integer;
  18110. begin
  18111.   FDDB.Assign(FBitmap);
  18112.   if not FDDB.Empty then FDDB.HandleType := bmDDB;
  18113.   for I := 0 to FBands.Count - 1 do Bands[I].ParentBitmapChanged;
  18114.   if HandleAllocated then
  18115.     RedrawWindow(Handle, nil, 0, RDW_INVALIDATE or RDW_ERASE or RDW_ALLCHILDREN);
  18116. end;
  18117.  
  18118. procedure TCoolBar.BeginUpdate;
  18119. begin
  18120.   Inc(FUpdateCount);
  18121. end;
  18122.  
  18123. procedure TCoolBar.EndUpdate;
  18124. begin
  18125.   Dec(FUpdateCount);
  18126. end;
  18127.  
  18128. function TCoolBar.IsAutoSized: Boolean;
  18129. begin
  18130.   Result := AutoSize and ((Vertical and (Align in [alNone, alLeft, alRight])) or
  18131.     not Vertical and (Align in [alNone, alTop, alBottom]));
  18132. end;
  18133.  
  18134. function TCoolBar.IsBackgroundDirty: Boolean;
  18135. begin
  18136.   Result := HandleAllocated and not IsAutoSized;
  18137. end;
  18138.  
  18139. procedure TCoolBar.SetBitmap(Value: TBitmap);
  18140. begin
  18141.   FBitmap.Assign(Value);
  18142. end;
  18143.  
  18144. procedure TCoolBar.SetVertical(Value: Boolean);
  18145. begin
  18146.   if FVertical <> Value then
  18147.   begin
  18148.     FVertical := Value;
  18149.     RecreateWnd;
  18150.     if not (csLoading in ComponentState) then
  18151.     begin
  18152.       if HandleAllocated then
  18153.         RedrawWindow(Handle, nil, 0, RDW_FRAME or RDW_ERASE or RDW_INVALIDATE);
  18154.     end;
  18155.   end;
  18156. end;
  18157.  
  18158. function TCoolBar.UpdateItem(Message, FromIndex, ToIndex: Integer): Boolean;
  18159. const
  18160.   RBBS_GRIPPERALWAYS = $00000080; // IE4 style: always show the gripper
  18161.   RBBS_NOGRIPPER = $00000100;     // IE4 style: never show the gripper
  18162.   BorderStyles: array[TBorderStyle] of DWORD = (0, RBBS_CHILDEDGE);
  18163.   BreakStyles: array[Boolean] of DWORD = (0, RBBS_BREAK);
  18164.   FixedBmpStyles: array[Boolean] of DWORD = (0, RBBS_FIXEDBMP);
  18165.   FixedSizeStyles: array[Boolean] of DWORD = (0, RBBS_FIXEDSIZE);
  18166.   GripperStyles: array[Boolean] of DWORD = (RBBS_GRIPPERALWAYS, RBBS_NOGRIPPER);
  18167. var
  18168.   BandInfo: TReBarBandInfo;
  18169.   Band: TCoolBand;
  18170.   WasFocused, DesignText: Boolean;
  18171.   Text: string;
  18172. begin
  18173.   Result := False;
  18174.   if HandleAllocated then
  18175.   begin
  18176.     Band := Bands[FromIndex];
  18177.     { Make sure child control is properly parented by coolbar and visible
  18178.       according to band's visible property }
  18179.     if Band.Control <> nil then
  18180.       with Band.Control do
  18181.       begin
  18182.         WasFocused := Focused;
  18183.         BeginUpdate;
  18184.         try
  18185.           Parent := Self;
  18186.         finally
  18187.           EndUpdate;
  18188.         end;
  18189.         // The following line can be removed to prevent the control's visible
  18190.         // state from being synchronized with the band.
  18191.           Visible := Band.Visible;
  18192.       end
  18193.     else
  18194.       WasFocused := False;
  18195.     if not (csDesigning in ComponentState) and not Band.Visible then Exit;
  18196.     FillChar(BandInfo, SizeOf(BandInfo), 0);
  18197.     with BandInfo do
  18198.     begin
  18199.       cbSize := SizeOfReBarBandInfo;
  18200.       wID := Integer(Band);
  18201.       { Assign background color }
  18202.       if Band.ParentColor then
  18203.         clrBack := ColorToRGB(Color)
  18204.       else
  18205.         clrBack := ColorToRGB(Band.Color);
  18206.       { Assign basic styles }
  18207.       with Band do
  18208.       begin
  18209.         fStyle := BreakStyles[Break] or FixedSizeStyles[FixedSize] or
  18210.           BorderStyles[BorderStyle] or FixedBmpStyles[FixedBackground];
  18211.         { Here we attempt to make IE4 behave like IE3 in regards to when the
  18212.           grip on bands are displayed: never on the first band when FixedOrder
  18213.           is True, and never on a band in which FixedSize is True; otherwise,
  18214.           always show the grip. }
  18215.         if GetComCtlVersion >= ComCtlVersionIE4 then
  18216.           fStyle := fStyle or GripperStyles[FixedOrder and (FromIndex = 0) or
  18217.             FixedSize];
  18218.       end;
  18219.       fMask := RBBIM_STYLE or RBBIM_COLORS or RBBIM_SIZE or RBBIM_BACKGROUND or
  18220.          RBBIM_IMAGE or RBBIM_ID;
  18221.       { Assign background bitmap }
  18222.       if Band.ParentBitmap then
  18223.         hbmBack := FDDB.Handle
  18224.       else
  18225.         hbmBack := Band.FDDB.Handle;
  18226.       iImage := Band.ImageIndex;
  18227.       { Assign child control }
  18228.       if (Band.Control <> nil) and
  18229.         (Band.Control.Visible or (csDesigning in ComponentState)) then
  18230.         hwndChild := Band.Control.Handle;
  18231.       cx := Band.Width;
  18232.       { Assign minimum child width from child control's current width if band
  18233.         is fixed in size and a MinWidth value hasn't already been set }
  18234.       if Band.FixedSize and (Band.MinWidth <= 0) and (Band.Control <> nil) then
  18235.         if Vertical then
  18236.           cxMinChild := Band.Control.Height
  18237.         else
  18238.           cxMinChild := Band.Control.Width
  18239.       else
  18240.         cxMinChild := Band.MinWidth;
  18241.       if GetComCtlVersion < ComCtlVersionIE401 then
  18242.       begin
  18243.         //WINBUG: COMCTL32.DLL is off by 4 pixels in its sizing logic.  Whatever
  18244.         //  is specified as the minimum size, the system rebar will allow that band
  18245.         //  to be 4 actual pixels smaller!  That's why we add 4 to the size here.
  18246.         Inc(cxMinChild, 4);
  18247.       end;
  18248.       cyMinChild := Band.MinHeight;
  18249.       fMask := fMask or RBBIM_CHILD or RBBIM_CHILDSIZE;
  18250.       { Assign text to band }
  18251.       DesignText := (csDesigning in ComponentState) and
  18252.         (Band.Control = nil) and (Band.Text = '');
  18253.       if ShowText or DesignText then
  18254.       begin
  18255.         if DesignText then
  18256.           Text := Band.DisplayName
  18257.         else
  18258.           Text := Band.Text;
  18259.         lpText := PChar(Text);
  18260.         fMask := fMask or RBBIM_TEXT;
  18261.       end;
  18262.     end;
  18263.     { Add/insert band }
  18264.     Result := Perform(Message, ToIndex, Integer(@BandInfo)) <> 0;
  18265.     { Update focus }
  18266.     if WasFocused then
  18267.       with Band.Control do
  18268.         if Handle <> 0 then Windows.SetFocus(Handle);
  18269.   end;
  18270. end;
  18271.  
  18272. function TCoolBar.ReadBands: Boolean;
  18273. const
  18274.   { IE4 support }
  18275.   RB_GETRECT = (WM_USER + 9); // Get a band's bounding rectangle
  18276. var
  18277.   I: Longword;
  18278.   NewWidth, NewIndex: Integer;
  18279.   ClientSize, RowSize, BorderSize: Longword;
  18280.   BandInfo: TReBarBandInfo;
  18281.   NewBreak: Boolean;
  18282.   R: TRect;
  18283.   Resize: Boolean;
  18284. begin
  18285.   Result := False;
  18286.   if HandleAllocated and (FUpdateCount = 0) then
  18287.   begin
  18288.     { Retrieve current band settings }
  18289.     FillChar(BandInfo, SizeOfReBarBandInfo, 0);
  18290.     BandInfo.cbSize := SizeOfReBarBandInfo;
  18291.     BandInfo.fMask := RBBIM_STYLE or RBBIM_SIZE or RBBIM_ID;
  18292.     BeginUpdate;
  18293.     try
  18294.       I := 0;
  18295.       NewIndex := 0;
  18296.       if BandBorderStyle = bsSingle then
  18297.         BorderSize := BandBorderSize
  18298.       else
  18299.         BorderSize := 0;
  18300.       { Compute row size vs. client size as we iterate to determine "soft"
  18301.         breaks between rows }
  18302.       if Vertical then
  18303.         ClientSize := ClientHeight
  18304.       else
  18305.         ClientSize := ClientWidth;
  18306.       RowSize := 0;
  18307.       while (I < FBands.FVisibleCount) and (NewIndex < FBands.Count) do
  18308.       begin
  18309.         { Get info from coolbar about visible band }
  18310.         if (Perform(RB_GETBANDINFO_PRE_IE4, I, Integer(@BandInfo)) <> 0) and
  18311.           (BandInfo.wID <> 0) then
  18312.         begin
  18313.           { Find opening for visible band }
  18314.           if not (csDesigning in ComponentState) then
  18315.             for NewIndex := NewIndex to FBands.Count - 1 do
  18316.               if FBands[NewIndex].Visible then Break;
  18317.           with BandInfo, TCoolBand(wID) do
  18318.           begin
  18319.             { Determine width of band by calling RB_GETRECT if we're in IE4.
  18320.               Otherwise, cx returns a valid value. }
  18321.             if (GetComCtlVersion >= ComCtlVersionIE4) and
  18322.               (Perform(RB_GETRECT, I, Integer(@R)) <> 0) then
  18323.               cx := R.Right - R.Left;
  18324.             NewWidth := cx;
  18325.             NewBreak := fStyle and RBBS_BREAK <> 0;
  18326.             if NewBreak or (I = 0) then
  18327.               RowSize := cx
  18328.             else
  18329.               Inc(RowSize, cx + BorderSize);
  18330.             if RowSize > ClientSize then
  18331.             begin
  18332.               RowSize := cx;
  18333.               FID := SoftBreakMask or I;
  18334.             end
  18335.             else
  18336.               FID := I;
  18337.             Resize := Break <> NewBreak;
  18338.             if Resize or (Index <> NewIndex) or (Width <> NewWidth) then
  18339.             begin
  18340.               Result := True;
  18341.               Break := NewBreak;
  18342.               { Exchange bands }
  18343.               FBands[NewIndex].Index := Index;
  18344.               Index := NewIndex;
  18345.               Width := NewWidth;
  18346.             end;
  18347.           end;
  18348.         end;
  18349.         Inc(I);
  18350.         Inc(NewIndex);
  18351.       end;
  18352.     finally
  18353.       EndUpdate;
  18354.     end;
  18355.   end;
  18356. end;
  18357.  
  18358. procedure TCoolBar.UpdateBand(Index: Integer);
  18359. begin
  18360.   if HandleAllocated and (FUpdateCount = 0) then
  18361.     UpdateItem(RB_SETBANDINFO, Index, Bands[Index].FID and IDMask)
  18362. end;
  18363.  
  18364. procedure TCoolBar.UpdateBands;
  18365. var
  18366.   I, BandCount: Integer;
  18367.   WindowLocked: Boolean;
  18368. begin
  18369.   if HandleAllocated and (FUpdateCount = 0) then
  18370.   begin
  18371.     BeginUpdate;
  18372.     WindowLocked := LockWindowUpdate(GetDesktopWindow);
  18373.     try
  18374.       BandCount := Perform(RB_GETBANDCOUNT, 0, 0);
  18375.       for I := 0 to BandCount - 1 do
  18376.         Perform(RB_DELETEBAND, 0, 0);
  18377.       if FixedOrder then
  18378.         { Add bands from first to last }
  18379.         for I := 0 to Bands.Count - 1 do
  18380.           UpdateItem(RB_INSERTBAND, I, -1)
  18381.       else
  18382.         { Add bands from last to first }
  18383.         for I := Bands.Count - 1 downto 0 do
  18384.           UpdateItem(RB_INSERTBAND, I, 0);
  18385.       if FImages <> nil then SetImageList(FImages.Handle);
  18386.       { Coolbar doesn't automatically redraw window when we remove the last band }
  18387.       if BandCount > Perform(RB_GETBANDCOUNT, 0, 0) then
  18388.         Invalidate;
  18389.     finally
  18390.       if WindowLocked then LockWindowUpdate(0);
  18391.       EndUpdate;
  18392.     end;
  18393.     FBands.FVisibleCount := Perform(RB_GETBANDCOUNT, 0, 0);
  18394.     ReadBands;
  18395.     if AutoSize then AdjustSize;
  18396.   end;
  18397. end;
  18398.  
  18399. { Return height of row for given band }
  18400. function TCoolBar.GetRowHeight(Index: Integer): Integer;
  18401. const
  18402.   ChildEdgeSize = 4;
  18403. var
  18404.   Last, I, Size, TmpSize: Integer;
  18405.   DesignText: Boolean;
  18406.   Band: TCoolBand;
  18407.   Text: string;
  18408. begin
  18409.   Result := 0;
  18410.   Last := FBands.Count - 1;
  18411.   if FixedSize then
  18412.     Index := 0
  18413.   else
  18414.   begin
  18415.     { Find last band in row }
  18416.     I := Index;
  18417.     while I < Last do
  18418.       if ((csDesigning in ComponentState) or FBands[I+1].Visible) and
  18419.         (FBands[I+1].Break or (FBands[I+1].FID and SoftBreakMask <> 0)) then
  18420.         Break
  18421.       else
  18422.         Inc(I);
  18423.     Last := I;
  18424.     { Find first band in row }
  18425.     while Index > 0 do
  18426.       if ((csDesigning in ComponentState) or FBands[Index].Visible) and
  18427.         (FBands[Index].Break or (FBands[Index].FID and SoftBreakMask <> 0)) then
  18428.         Break
  18429.       else
  18430.         Dec(Index);
  18431.   end;
  18432.   { Compute maximum band size between Index and Last }
  18433.   for I := Index to Last do
  18434.   begin
  18435.     Band := FBands[I];
  18436.     if (csDesigning in ComponentState) or Band.Visible then
  18437.     begin
  18438.       { Calc control size }
  18439.       if Band.Control <> nil then
  18440.       begin
  18441.         Size := Band.MinHeight;
  18442.         if Band.BorderStyle = bsNone then Dec(Size, ChildEdgeSize);
  18443.       end
  18444.       else Size := 0;
  18445.       { Calc text size }
  18446.       DesignText := (csDesigning in ComponentState) and
  18447.         (Band.Control = nil) and (Band.Text = '');
  18448.       if ShowText or DesignText then
  18449.       begin
  18450.         if DesignText then
  18451.           Text := Band.DisplayName
  18452.         else
  18453.           Text := Band.Text;
  18454.         if Text <> '' then
  18455.           if Vertical then
  18456.               with TControlCanvas.Create do
  18457.               try
  18458.                 Control := Self;
  18459.                 Font := FCaptionFont;
  18460.                 TmpSize := TextWidth(Text);
  18461.               finally
  18462.                 Free;
  18463.               end
  18464.           else
  18465.             TmpSize := FCaptionFontHeight
  18466.         else
  18467.           TmpSize := 0;
  18468.         if TmpSize > Size then
  18469.           Size := TmpSize;
  18470.       end;
  18471.       { Calc image size }
  18472.       if (Images <> nil) and (Band.ImageIndex >= 0) then
  18473.       begin
  18474.         if Vertical then
  18475.           TmpSize := Images.Height
  18476.         else
  18477.           TmpSize := Images.Width;
  18478.         if TmpSize > Size then
  18479.           Size := TmpSize;
  18480.       end;
  18481.       { Adjust for child edges }
  18482.       Inc(Size, ChildEdgeSize);
  18483.       { Remember max value }
  18484.       if Size > Result then
  18485.         Result := Size;
  18486.     end;
  18487.   end;
  18488. end;
  18489.  
  18490. function TCoolBar.PtInGripRect(const Pos: TPoint; var Band: TCoolBand): Integer;
  18491. var
  18492.   I, PosX, PosY, X, Y: Integer;
  18493.   PrevWidth, RowHeight, BorderSize: Integer;
  18494.   HitTestInfo: TRBHitTestInfo;
  18495.   BandInfo: TReBarBandInfo;
  18496. begin
  18497.   if GetComCtlVersion >= ComCtlVersionIE4 then
  18498.   begin
  18499.     HitTestInfo.pt := Pos;
  18500.     I := Perform(RB_HITTEST, 0, Longint(@HitTestInfo));
  18501.     FillChar(BandInfo, SizeOfReBarBandInfo, 0);
  18502.     BandInfo.cbSize := SizeOfReBarBandInfo;
  18503.     BandInfo.fMask := RBBIM_ID;
  18504.     if (Perform(RB_GETBANDINFO_PRE_IE4, I, Integer(@BandInfo)) <> 0) and
  18505.       (BandInfo.wID <> 0) then
  18506.       Band := TCoolBand(BandInfo.wID) else
  18507.       Band := nil;
  18508.     Result := HitTestInfo.flags;
  18509.     Exit;
  18510.   end
  18511.   else if FBands.FVisibleCount > 0 then
  18512.   begin
  18513.     Band := nil;
  18514.     if Vertical then
  18515.     begin
  18516.       PosX := Pos.Y;
  18517.       PosY := Pos.X;
  18518.     end
  18519.     else
  18520.     begin
  18521.       PosX := Pos.X;
  18522.       PosY := Pos.Y;
  18523.     end;
  18524.     X := 0;
  18525.     Y := 0;
  18526.     PrevWidth := 0;
  18527.     RowHeight := 0;
  18528.     if BandBorderStyle = bsSingle then
  18529.       BorderSize := BandBorderSize
  18530.     else
  18531.       BorderSize := 0;
  18532.     for I := 0 to FBands.Count - 1 do
  18533.     begin
  18534.       Band := FBands[I];
  18535.       if (csDesigning in ComponentState) or Band.Visible then
  18536.       begin
  18537.         if (Band.FID and IDMask = 0) or (Band.Break or
  18538.           (Band.FID and SoftBreakMask <> 0)) then
  18539.         begin
  18540.           X := 0;
  18541.           if Band.FID and IDMask > 0 then
  18542.             Inc(Y, RowHeight + BorderSize);
  18543.           RowHeight := GetRowHeight(I);
  18544.         end
  18545.         else
  18546.           Inc(X, PrevWidth);
  18547.         PrevWidth := Band.Width + BorderSize;
  18548.         if (PosX < X) or (PosX > X + Band.Width) or (PosY < Y) or
  18549.           (PosY > Y + RowHeight) then Continue;
  18550.         { Find hittest area }
  18551.         if not Band.FixedSize and (not FixedOrder or
  18552.           (Band.FID and IDMask > 0)) and (PosX <= X + GetCaptionSize(Band)) then
  18553.         begin
  18554.           { The grip size in IE4 is 3 pixels narrower than IE3 }
  18555.           if (PosX > X + GripSizeIE3) or (GetComCtlVersion >= ComCtlVersionIE4) and
  18556.             (PosX > X + GripSizeIE4) then
  18557.             Result := RBHT_CAPTION
  18558.           else
  18559.             Result := RBHT_GRABBER;
  18560.           Exit;
  18561.         end
  18562.         else
  18563.           System.Break;
  18564.       end;
  18565.     end;
  18566.   end;
  18567.   Result := RBHT_CLIENT;
  18568. end;
  18569.  
  18570. procedure TCoolBar.WMCaptureChanged(var Message: TMessage);
  18571. begin
  18572.   inherited;
  18573.   { Synchronize band properties - something may have changed }
  18574.   PostMessage(Handle, CN_BANDCHANGE + 1, 0, 0)
  18575. end;
  18576.  
  18577. procedure TCoolBar.WMEraseBkgnd(var Message: TWMEraseBkgnd);
  18578. begin
  18579.   if IsBackgroundDirty or (IsAutoSized and (Bands.Count = 0)) then
  18580.     inherited;
  18581.   DefaultHandler(Message);
  18582. end;
  18583.  
  18584. procedure TCoolBar.WMLButtonDown(var Message: TWMLButtonDown);
  18585. var
  18586.   Band: TCoolBand;
  18587. begin
  18588.   if PtInGripRect(SmallPointToPoint(Message.Pos), Band) and RBHT_NONE = 0 then
  18589.     FTrackDrag := Message.Pos;
  18590.   inherited;
  18591. end;
  18592.  
  18593. procedure TCoolBar.WMLButtonUp(var Message: TWMLButtonUp);
  18594. begin
  18595.   if not (csDesigning in ComponentState) and (BandMaximize <> bmNone) or
  18596.     (FTrackDrag.X < Message.XPos - 1) or (FTrackDrag.X > Message.XPos + 1) or
  18597.     (FTrackDrag.Y < Message.YPos - 1) or (FTrackDrag.Y > Message.YPos + 1) then
  18598.     inherited
  18599.   else
  18600.     MouseCapture := False;
  18601. end;
  18602.  
  18603. procedure TCoolBar.WMNotifyFormat(var Message: TMessage);
  18604. begin
  18605.   with Message do
  18606.     Result := DefWindowProc(Handle, Msg, WParam, LParam);
  18607. end;
  18608.  
  18609. procedure TCoolBar.WMSetCursor(var Message: TWMSetCursor);
  18610. var
  18611.   P: TPoint;
  18612.   Band: TCoolBand;
  18613.   Grip: Integer;
  18614.   MsgPos: Longint;
  18615. begin
  18616.   { Ignore default processing since it's flawed when coolbar is vertical }
  18617.   with Message do
  18618.     if (CursorWnd = Handle) and (Smallint(HitTest) = HTCLIENT) then
  18619.     begin
  18620.       Result := 1;
  18621.       MsgPos := GetMessagePos;
  18622.       P.X := MsgPos and $FFFF;
  18623.       P.Y := MsgPos shr 16;
  18624.       Windows.ScreenToClient(CursorWnd, P);
  18625.       Grip := PtInGripRect(P, Band);
  18626.       if Grip and RBHT_NONE = 0 then
  18627.       begin
  18628.         if Grip = RBHT_CAPTION then
  18629.           Windows.SetCursor(Screen.Cursors[crHandPoint])
  18630.         else if Vertical then
  18631.           Windows.SetCursor(Screen.Cursors[crSizeNS])
  18632.         else Windows.SetCursor(Screen.Cursors[crSizeWE]);
  18633.       end
  18634.       else Windows.SetCursor(Screen.Cursors[crDefault]);
  18635.     end
  18636.     else inherited;
  18637. end;
  18638.  
  18639. procedure TCoolBar.WMSize(var Message: TWMSize);
  18640. begin
  18641.   inherited;
  18642. end;
  18643.  
  18644. procedure TCoolBar.WndProc(var Message: TMessage);
  18645. begin
  18646.   if (csDesigning in ComponentState) then
  18647.     case Message.Msg of
  18648.       WM_MOUSEMOVE, WM_LBUTTONDBLCLK, WM_RBUTTONDBLCLK:
  18649.         begin
  18650.           { Enabled csDesignInteractive temporarily so that we may handle the
  18651.             design-time dragging of bands }
  18652.           ControlStyle := ControlStyle + [csDesignInteractive];
  18653.           try
  18654.             inherited WndProc(Message);
  18655.           finally
  18656.             ControlStyle := ControlStyle - [csDesignInteractive];
  18657.           end;
  18658.           Exit;
  18659.         end;
  18660.       { We just dragged a band - disable any drag events }
  18661.       WM_LBUTTONUP: MouseCapture := False;
  18662.     end;
  18663.   case Message.Msg of
  18664.     CN_BANDCHANGE + 1:
  18665.       Message.Msg := CN_BANDCHANGE;
  18666.     WM_PARENTNOTIFY:
  18667.       { A child control may have performed a RecreateWnd.  Make sure the bands
  18668.         are referring to current window handle values. }
  18669.       if Message.WParam and $FFFF = WM_CREATE then
  18670.         UpdateBands;
  18671.   end;
  18672.   inherited WndProc(Message);
  18673. end;
  18674.  
  18675. procedure TCoolBar.CMColorChanged(var Message: TMessage);
  18676. var
  18677.   I: Integer;
  18678. begin
  18679.   inherited;
  18680.   if FBands <> nil then
  18681.     for I := 0 to FBands.Count - 1 do Bands[I].ParentColorChanged;
  18682.   if HandleAllocated then
  18683.     RedrawWindow(Handle, nil, 0, RDW_INVALIDATE or RDW_ERASE or RDW_FRAME);
  18684. end;
  18685.  
  18686. procedure TCoolBar.CMControlChange(var Message: TCMControlChange);
  18687. var
  18688.   Band: TCoolBand;
  18689. begin
  18690.   if FUpdateCount = 0 then
  18691.   begin
  18692.     { Can only accept TWinControl descendants }
  18693.     if not (csLoading in ComponentState) and (Message.Control is TWinControl) then
  18694.       if Message.Inserting then
  18695.         with Bands.Add do SetControl(TWinControl(Message.Control))
  18696.       else
  18697.       begin
  18698.         Band := Bands.FindBand(Message.Control);
  18699.         if Band <> nil then Band.Free;
  18700.       end;
  18701.   end;
  18702. end;
  18703.  
  18704. procedure TCoolBar.CMDesignHitTest(var Message: TCMDesignHitTest);
  18705. var
  18706.   Band: TCoolBand;
  18707. begin
  18708.   if not (csDesignInteractive in ControlStyle) and
  18709.     (PtInGripRect(SmallPointToPoint(Message.Pos), Band) and RBHT_NONE = 0) then
  18710.     Message.Result := 1 else
  18711.     inherited;
  18712. end;
  18713.  
  18714. procedure TCoolBar.CMSysColorChange(var Message: TMessage);
  18715. begin
  18716.   inherited;
  18717.   if not (csLoading in ComponentState) then
  18718.   begin
  18719.     Message.Msg := WM_SYSCOLORCHANGE;
  18720.     DefaultHandler(Message);
  18721.   end;
  18722. end;
  18723.  
  18724. procedure TCoolBar.CMSysFontChanged(var Message: TMessage);
  18725. begin
  18726.   inherited;
  18727.   RecreateWnd;
  18728. end;
  18729.  
  18730. procedure TCoolBar.CMWinIniChange(var Message: TWMWinIniChange);
  18731. begin
  18732.   inherited;
  18733.   FCaptionFont.Handle := GetCaptionFont;
  18734.   FCaptionFontHeight := GetCaptionFontHeight;
  18735. end;
  18736.  
  18737. procedure TCoolBar.CNBandChange(var Message: TMessage);
  18738. begin
  18739.   if ReadBands then Change;
  18740. end;
  18741.  
  18742. procedure TCoolBar.CNNotify(var Message: TWMNotify);
  18743. begin
  18744.   if (Message.NMHdr^.code = RBN_HEIGHTCHANGE) then
  18745.     if IsAutoSized and (ComponentState * [csLoading, csDestroying] = []) then
  18746.     begin
  18747.       ReadBands;
  18748.       BeginUpdate;
  18749.       try
  18750.         if AutoSize then AdjustSize;
  18751.       finally
  18752.         EndUpdate;
  18753.       end;
  18754.     end
  18755.     else if IsBackgroundDirty then
  18756.       Invalidate;
  18757. end;
  18758.  
  18759. function TCoolBar.CanAutoSize(var NewWidth, NewHeight: Integer): Boolean;
  18760.  
  18761.   function GetDisplaySize: Integer;
  18762.   var
  18763.     I, RowCount: Integer;
  18764.   begin
  18765.     Result := 0;
  18766.     RowCount := 0;
  18767.     for I := 0 to FBands.Count - 1 do
  18768.       with FBands[I] do
  18769.         if ((csDesigning in ComponentState) or Visible) and
  18770.           ((FID and IDMask = 0) or (Break or (FID and SoftBreakMask <> 0))) then
  18771.         begin
  18772.           Inc(RowCount);
  18773.           Inc(Result, GetRowHeight(I));
  18774.         end;
  18775.     if (RowCount > 1) and (BandBorderStyle = bsSingle) then
  18776.       Inc(Result, (RowCount - 1) * BandBorderSize);
  18777.   end;
  18778.  
  18779. begin
  18780.   Result := False;
  18781.   if HandleAllocated and (IsAutoSized and ((FBands.Count > 0) or
  18782.     not (csDesigning in ComponentState))) then
  18783.       if Vertical and (Align in [alNone, AlLeft, alRight]) then
  18784.       begin
  18785.         Result := True;
  18786.         NewWidth := GetDisplaySize + Width - ClientWidth;
  18787.       end
  18788.       else if not Vertical and (Align in [alNone, alTop, alBottom]) then
  18789.       begin
  18790.         Result := True;
  18791.         NewHeight := GetDisplaySize + Height - ClientHeight;
  18792.       end;
  18793. end;
  18794.  
  18795. function TCoolBar.HitTest(const Pos: TPoint): TCoolBand;
  18796. begin
  18797.   PtInGripRect(Pos, Result);
  18798. end;
  18799.  
  18800. procedure TCoolBar.PaintWindow(DC: HDC);
  18801. begin
  18802.   Perform(WM_ERASEBKGND, DC, 0);
  18803.   inherited;
  18804. end;
  18805.  
  18806. { TMonthCalColors }
  18807.  
  18808. const
  18809.   ColorIndex: array[0..5] of Integer = (MCSC_BACKGROUND, MCSC_TEXT,
  18810.     MCSC_TITLEBK, MCSC_TITLETEXT, MCSC_MONTHBK, MCSC_TRAILINGTEXT);
  18811.  
  18812. constructor TMonthCalColors.Create(AOwner: TCommonCalendar);
  18813. begin
  18814.   Owner := AOwner;
  18815.   FBackColor := clWindow;
  18816.   FTextColor := clWindowText;
  18817.   FTitleBackColor := clActiveCaption;
  18818.   FTitleTextColor := clWhite;
  18819.   FMonthBackColor := clWhite;
  18820.   FTrailingTextColor := clInactiveCaptionText;
  18821. end;
  18822.  
  18823. procedure TMonthCalColors.Assign(Source: TPersistent);
  18824. var
  18825.   SourceName: string;
  18826. begin
  18827.   if Source = nil then SourceName := 'nil'
  18828.   else SourceName := Source.ClassName;
  18829.   if (Source = nil) or not (Source is TMonthCalColors) then
  18830.     raise EConvertError.CreateResFmt(@SAssignError, [SourceName, ClassName]);
  18831.   FBackColor := TMonthCalColors(Source).BackColor;
  18832.   FTextColor := TMonthCalColors(Source).TextColor;
  18833.   FTitleBackColor := TMonthCalColors(Source).TitleBackColor;
  18834.   FTitleTextColor := TMonthCalColors(Source).TitleTextColor;
  18835.   FMonthBackColor := TMonthCalColors(Source).MonthBackColor;
  18836.   FTrailingTextColor := TMonthCalColors(Source).TrailingTextColor;
  18837. end;
  18838.  
  18839. procedure TMonthCalColors.SetColor(Index: Integer; Value: TColor);
  18840. begin
  18841.   case Index of
  18842.     0: FBackColor := Value;
  18843.     1: FTextColor := Value;
  18844.     2: FTitleBackColor := Value;
  18845.     3: FTitleTextColor := Value;
  18846.     4: FMonthBackColor := Value;
  18847.     5: FTrailingTextColor := Value;
  18848.   end;
  18849.   if Owner.HandleAllocated then
  18850.     Owner.MsgSetCalColors(ColorIndex[Index], ColorToRGB(Value));
  18851. end;
  18852.  
  18853. procedure TMonthCalColors.SetAllColors;
  18854. begin
  18855.   SetColor(0, FBackColor);
  18856.   SetColor(1, FTextColor);
  18857.   SetColor(2, FTitleBackColor);
  18858.   SetColor(3, FTitleTextColor);
  18859.   SetColor(4, FMonthBackColor);
  18860.   SetColor(5, FTrailingTextColor);
  18861. end;
  18862.  
  18863. { TCommonCalendar }
  18864.  
  18865. constructor TCommonCalendar.Create(AOwner: TComponent);
  18866. begin
  18867.   CheckCommonControl(ICC_DATE_CLASSES);
  18868.   inherited Create(AOwner);
  18869.   FShowToday := True;
  18870.   FShowTodayCircle := True;
  18871.   ControlStyle := [csOpaque, csClickEvents, csDoubleClicks, csReflector];
  18872.   FCalColors := TDateTimeColors.Create(Self);
  18873.   FDateTime := Now;
  18874.   FFirstDayOfWeek := dowLocaleDefault;
  18875.   FMaxSelectRange := 31;
  18876.   FMonthDelta := 1;
  18877. end;
  18878.  
  18879. destructor TCommonCalendar.Destroy;
  18880. begin
  18881.   inherited Destroy;
  18882.   FCalColors.Free;
  18883. end;
  18884.  
  18885. procedure TCommonCalendar.BoldDays(Days: array of LongWord; var MonthBoldInfo: LongWord);
  18886. var
  18887.   I: LongWord;
  18888. begin
  18889.   MonthBoldInfo := 0;
  18890.   for I := Low(Days) to High(Days) do
  18891.     if (Days[I] > 0) and (Days[I] < 32) then
  18892.       MonthBoldInfo := MonthBoldInfo or ($00000001 shl (Days[I] - 1));
  18893. end;
  18894.  
  18895. procedure TCommonCalendar.CheckEmptyDate;
  18896. begin
  18897.   // do nothing
  18898. end;
  18899.  
  18900. procedure TCommonCalendar.CheckValidDate(Value: TDate);
  18901. begin
  18902.   if (FMaxDate <> 0.0) and (Value > FMaxDate) then
  18903.     raise CalExceptionClass.CreateFmt(SDateTimeMax, [DateToStr(FMaxDate)]);
  18904.   if (FMinDate <> 0.0) and (Value < FMinDate) then
  18905.     raise CalExceptionClass.CreateFmt(SDateTimeMin, [DateToStr(FMinDate)]);
  18906. end;
  18907.  
  18908. procedure TCommonCalendar.CreateWnd;
  18909. begin
  18910.   inherited CreateWnd;
  18911.   FCalColors.SetAllColors;
  18912.   SetRange(FMinDate, FMaxDate);
  18913.   SetMaxSelectRange(FMaxSelectRange);
  18914.   SetMonthDelta(FMonthDelta);
  18915.   SetFirstDayOfWeek(FFirstDayOfWeek);
  18916.   if FMultiSelect then
  18917.     SetSelectedRange(FDateTime, FEndDate)
  18918.   else
  18919.     SetDateTime(FDateTime);
  18920. end;
  18921.  
  18922. function TCommonCalendar.GetCalStyles: DWORD;
  18923. const
  18924.   ShowTodayFlags: array[Boolean] of DWORD = (MCS_NOTODAY, 0);
  18925.   ShowTodayCircleFlags: array[Boolean] of DWORD = (MCS_NOTODAYCIRCLE, 0);
  18926.   WeekNumFlags: array[Boolean] of DWORD = (0, MCS_WEEKNUMBERS);
  18927.   MultiSelFlags: array[Boolean] of DWORD = (0, MCS_MULTISELECT);
  18928. begin
  18929.   Result := MCS_DAYSTATE or ShowTodayFlags[FShowToday] or
  18930.     ShowTodayCircleFlags[FShowTodayCircle] or WeekNumFlags[FWeekNumbers] or
  18931.     MultiSelFlags[FMultiSelect];
  18932. end;
  18933.  
  18934. function TCommonCalendar.DoStoreEndDate: Boolean;
  18935. begin
  18936.   Result := FMultiSelect;
  18937. end;
  18938.  
  18939. function TCommonCalendar.DoStoreMaxDate: Boolean;
  18940. begin
  18941.   Result := FMaxDate <> 0.0;
  18942. end;
  18943.  
  18944. function TCommonCalendar.DoStoreMinDate: Boolean;
  18945. begin
  18946.   Result := FMinDate <> 0.0;
  18947. end;
  18948.  
  18949. function TCommonCalendar.GetDate: TDate;
  18950. begin
  18951.   Result := TDate(FDateTime);
  18952. end;
  18953.  
  18954. procedure TCommonCalendar.SetCalColors(Value: TDateTimeColors);
  18955. begin
  18956.   if FCalColors <> Value then FCalColors.Assign(Value);
  18957. end;
  18958.  
  18959. procedure TCommonCalendar.SetDate(Value: TDate);
  18960. begin
  18961.   ReplaceTime(TDateTime(Value), FDateTime);
  18962.   if Value = 0.0 then CheckEmptyDate;
  18963.   try
  18964.     CheckValidDate(Trunc(Value));
  18965.     SetDateTime(Value);
  18966.   except
  18967.     SetDateTime(FDateTime);
  18968.     raise;
  18969.   end;
  18970. end;
  18971.  
  18972. procedure TCommonCalendar.SetDateTime(Value: TDateTime);
  18973. var
  18974.   ST: TSystemTime;
  18975. begin
  18976.   DateTimeToSystemTime(Value, ST);
  18977.   if FMultiSelect then
  18978.     SetSelectedRange(Value, FEndDate)
  18979.   else begin
  18980.     if HandleAllocated then
  18981.       if not MsgSetDateTime(ST) then
  18982.         raise ECommonCalendarError.CreateRes(@sFailSetCalDateTime);
  18983.     FDateTime := Value;
  18984.   end;
  18985. end;
  18986.  
  18987. procedure TCommonCalendar.SetEndDate(Value: TDate);
  18988. var
  18989.   TruncValue: TDate;
  18990. begin
  18991.   TruncValue := Trunc(Value);
  18992.   if Trunc(FEndDate) <> TruncValue then
  18993.   begin
  18994.     Value := TruncValue + 0.0;
  18995.     if Value = 0.0 then CheckEmptyDate;
  18996.     SetSelectedRange(Date, TruncValue);
  18997.   end;
  18998. end;
  18999.  
  19000. procedure TCommonCalendar.SetFirstDayOfWeek(Value: TCalDayOfWeek);
  19001. var
  19002.   DOWFlag: Integer;
  19003.   A: array[0..1] of char;
  19004. begin
  19005.   if HandleAllocated then
  19006.   begin
  19007.     if Value = dowLocaleDefault then
  19008.     begin
  19009.       GetLocaleInfo(LOCALE_USER_DEFAULT, LOCALE_IFIRSTDAYOFWEEK, A, SizeOf(A));
  19010.       DOWFlag := Ord(A[0]) - Ord('0');
  19011.     end
  19012.     else
  19013.       DOWFlag := Ord(Value);
  19014.     if CalendarHandle <> 0 then
  19015.       MonthCal_SetFirstDayOfWeek(CalendarHandle, DOWFlag);
  19016.   end;
  19017.   FFirstDayOfWeek := Value;
  19018. end;
  19019.  
  19020. procedure TCommonCalendar.SetMaxDate(Value: TDate);
  19021. begin
  19022.   if (FMinDate <> 0.0) and (Value < FMinDate) then
  19023.     raise CalExceptionClass.CreateFmt(SDateTimeMin, [DateToStr(FMinDate)]);
  19024.   if FMaxDate <> Value then
  19025.   begin
  19026.     SetRange(FMinDate, Value);
  19027.     FMaxDate := Value;
  19028.   end;
  19029. end;
  19030.  
  19031. procedure TCommonCalendar.SetMaxSelectRange(Value: Integer);
  19032. begin
  19033.   if FMultiSelect and HandleAllocated then
  19034.     if not MonthCal_SetMaxSelCount(CalendarHandle, Value) then
  19035.       raise ECommonCalendarError.CreateRes(@sFailSetCalMaxSelRange);
  19036.   FMaxSelectRange := Value;
  19037. end;
  19038.  
  19039. procedure TCommonCalendar.SetMinDate(Value: TDate);
  19040. begin
  19041.   if (FMaxDate <> 0.0) and (Value > FMaxDate) then
  19042.     raise CalExceptionClass.CreateFmt(SDateTimeMax, [DateToStr(FMaxDate)]);
  19043.   if FMinDate <> Value then
  19044.   begin
  19045.     SetRange(Value, FMaxDate);
  19046.     FMinDate := Value;
  19047.   end;
  19048. end;
  19049.  
  19050. procedure TCommonCalendar.SetMonthDelta(Value: Integer);
  19051. begin
  19052.   if HandleAllocated and (CalendarHandle <> 0) then
  19053.     MonthCal_SetMonthDelta(CalendarHandle, Value);
  19054.   FMonthDelta := Value;
  19055. end;
  19056.  
  19057. procedure TCommonCalendar.SetMultiSelect(Value: Boolean);
  19058. begin
  19059.   if FMultiSelect <> Value then
  19060.   begin
  19061.     FMultiSelect := Value;
  19062.     if Value then FEndDate := FDateTime
  19063.     else FEndDate := 0.0;
  19064.     RecreateWnd;
  19065.   end;
  19066. end;
  19067.  
  19068. procedure TCommonCalendar.SetRange(MinVal, MaxVal: TDate);
  19069. var
  19070.   STA: packed array[1..2] of TSystemTime;
  19071.   Flags: DWORD;
  19072.   TruncDate, TruncEnd, TruncMin, TruncMax: Int64;
  19073. begin
  19074.   Flags := 0;
  19075.   TruncMin := Trunc(MinVal);
  19076.   TruncMax := Trunc(MaxVal);
  19077.   TruncDate := Trunc(FDateTime);
  19078.   TruncEnd := Trunc(FEndDate);
  19079.   if TruncMin <> 0 then
  19080.   begin
  19081.     if TruncDate < TruncMin then SetDate(MinVal);
  19082.     if TruncEnd < TruncMin then SetEndDate(MinVal);
  19083.     Flags := Flags or GDTR_MIN;
  19084.     DateTimeToSystemTime(TruncMin, STA[1]);
  19085.   end;
  19086.   if TruncMax <> 0 then
  19087.   begin
  19088.     if TruncDate > TruncMax then SetDate(MaxVal);
  19089.     if TruncEnd > TruncMax then SetEndDate(MaxVal);
  19090.     Flags := Flags or GDTR_MAX;
  19091.     DateTimeToSystemTime(TruncMax, STA[2]);
  19092.   end;
  19093.   if HandleAllocated then
  19094.     if not MsgSetRange(Flags, @STA[1]) then
  19095.       raise ECommonCalendarError.CreateRes(@sFailSetCalMinMaxRange);
  19096. end;
  19097.  
  19098. procedure TCommonCalendar.SetSelectedRange(Date, EndDate: TDate);
  19099. var
  19100.   DateArray: array[1..2] of TSystemTime;
  19101. begin
  19102.   if not FMultiSelect then
  19103.     SetDateTime(Date)
  19104.   else begin
  19105.     DateTimeToSystemTime(Date, DateArray[1]);
  19106.     DateTimeToSystemTime(EndDate, DateArray[2]);
  19107.     if HandleAllocated then
  19108.       if not MonthCal_SetSelRange(Handle, @DateArray[1]) then
  19109.         raise ECommonCalendarError.CreateRes(@sFailsetCalSelRange);
  19110.     FDateTime := Date;
  19111.     FEndDate := EndDate;
  19112.   end;
  19113. end;
  19114.  
  19115. procedure TCommonCalendar.SetShowToday(Value: Boolean);
  19116. begin
  19117.   if FShowToday <> Value then
  19118.   begin
  19119.     FShowToday := Value;
  19120.     SetComCtlStyle(Self, MCS_NOTODAY, not Value);
  19121.   end;
  19122. end;
  19123.  
  19124. procedure TCommonCalendar.SetShowTodayCircle(Value: Boolean);
  19125. begin
  19126.   if FShowTodayCircle <> Value then
  19127.   begin
  19128.     FShowTodayCircle := Value;
  19129.     SetComCtlStyle(Self, MCS_NOTODAYCIRCLE, not Value);
  19130.   end;
  19131. end;
  19132.  
  19133. procedure TCommonCalendar.SetWeekNumbers(Value: Boolean);
  19134. begin
  19135.   if FWeekNumbers <> Value then
  19136.   begin
  19137.     FWeekNumbers := Value;
  19138.     SetComCtlStyle(Self, MCS_WEEKNUMBERS, Value);
  19139.   end;
  19140. end;
  19141.  
  19142. function IsBlankSysTime(const ST: TSystemTime): Boolean;
  19143. type
  19144.   TFast = array [0..3] of DWORD;
  19145. begin
  19146.   Result := (TFast(ST)[0] or TFast(ST)[1] or TFast(ST)[2] or TFast(ST)[3]) = 0;
  19147. end;
  19148.  
  19149. { TMonthCalendar }
  19150.  
  19151. constructor TMonthCalendar.Create(AOwner: TComponent);
  19152. begin
  19153.   FCalExceptionClass := EMonthCalError;
  19154.   inherited Create(AOwner);
  19155.   Width := 191;
  19156.   Height := 154;
  19157. end;
  19158.  
  19159. procedure TMonthCalendar.CMFontChanged(var Message: TMessage);
  19160. begin
  19161.   inherited;
  19162.   if HandleAllocated then Perform(WM_SIZE, 0, 0);
  19163. end;
  19164.  
  19165. procedure TMonthCalendar.CNNotify(var Message: TWMNotify);
  19166. var
  19167.   ST: PSystemTime;
  19168.   I, MonthNo: Integer;
  19169.   CurState: PMonthDayState;
  19170. begin
  19171.   with Message, NMHdr^ do
  19172.   begin
  19173.     case code of
  19174.       MCN_GETDAYSTATE:
  19175.         with PNmDayState(NMHdr)^ do
  19176.         begin
  19177.           FillChar(prgDayState^, cDayState * SizeOf(TMonthDayState), 0);
  19178.           if Assigned(FOnGetMonthInfo) then
  19179.           begin
  19180.             CurState := prgDayState;
  19181.             for I := 0 to cDayState - 1 do
  19182.             begin
  19183.               MonthNo := stStart.wMonth + I;
  19184.               if MonthNo > 12 then MonthNo := MonthNo - 12;
  19185.               FOnGetMonthInfo(Self, MonthNo, CurState^);
  19186.               Inc(CurState);
  19187.             end;
  19188.           end;
  19189.         end;
  19190.       MCN_SELECT, MCN_SELCHANGE:
  19191.         begin
  19192.           ST := @PNMSelChange(NMHdr).stSelStart;
  19193.           if not IsBlankSysTime(ST^) then
  19194.             FDateTime := SystemTimeToDateTime(ST^);
  19195.           if FMultiSelect then
  19196.           begin
  19197.             ST := @PNMSelChange(NMHdr).stSelEnd;
  19198.             if not IsBlankSysTime(ST^) then
  19199.               FEndDate := SystemTimeToDateTime(ST^);
  19200.           end;
  19201.         end;
  19202.     end;
  19203.   end;
  19204.   inherited;
  19205. end;
  19206.  
  19207. procedure TMonthCalendar.ConstrainedResize(var MinWidth, MinHeight, MaxWidth,
  19208.   MaxHeight: Integer);
  19209. var
  19210.   R: TRect;
  19211.   CtlMinWidth, CtlMinHeight: Integer;
  19212. begin
  19213.   if HandleAllocated then
  19214.   begin
  19215.     MonthCal_GetMinReqRect(Handle, R);
  19216.     with R do
  19217.     begin
  19218.       CtlMinHeight := Bottom - Top;
  19219.       CtlMinWidth := Right - Left;
  19220.     end;
  19221.     if MinHeight < CtlMinHeight then MinHeight := CtlMinHeight;
  19222.     if MinWidth < CtlMinWidth then MinWidth := CtlMinWidth;
  19223.   end;
  19224.   inherited ConstrainedResize(MinWidth, MinHeight, MaxWidth, MaxHeight);
  19225. end;
  19226.  
  19227. procedure TMonthCalendar.CreateParams(var Params: TCreateParams);
  19228. begin
  19229.   inherited CreateParams(Params);
  19230.   CreateSubClass(Params, MONTHCAL_CLASS);
  19231.   with Params do
  19232.   begin
  19233.     Style := Style or GetCalStyles;
  19234.     WindowClass.style := WindowClass.style and not (CS_HREDRAW or CS_VREDRAW) or
  19235.       CS_DBLCLKS;
  19236.   end;
  19237. end;
  19238.  
  19239. function TMonthCalendar.GetCalendarHandle: HWND;
  19240. begin
  19241.   Result := Handle;
  19242. end;
  19243.  
  19244. function TMonthCalendar.MsgSetCalColors(ColorIndex: Integer; ColorValue: TColor): Boolean;
  19245. begin
  19246.   Result := True;
  19247.   if HandleAllocated then
  19248.     Result := MonthCal_SetColor(Handle, ColorIndex, ColorValue) <> DWORD($FFFFFFFF);
  19249. end;
  19250.  
  19251. function TMonthCalendar.MsgSetDateTime(Value: TSystemTime): Boolean;
  19252. begin
  19253.   Result := True;
  19254.   if HandleAllocated then
  19255.     Result := MonthCal_SetCurSel(Handle, Value);
  19256. end;
  19257.  
  19258. function TMonthCalendar.MsgSetRange(Flags: Integer; SysTime: PSystemTime): Boolean;
  19259. begin
  19260.   Result := True;
  19261.   if HandleAllocated then
  19262.     if Flags <> 0 then Result := MonthCal_SetRange(Handle, Flags, SysTime);
  19263. end;
  19264.  
  19265. function TMonthCalendar.CanAutoSize(var NewWidth, NewHeight: Integer): Boolean;
  19266. var
  19267.   R: TRect;
  19268. begin
  19269.   if HandleAllocated then
  19270.   begin
  19271.     Result := True;
  19272.     Perform(MCM_GETMINREQRECT, 0, Longint(@R));
  19273.     with R do
  19274.     begin
  19275.       NewWidth := Right - Left;
  19276.       NewHeight := Bottom - Top;
  19277.     end;
  19278.   end
  19279.   else Result := False;
  19280. end;
  19281.  
  19282. { TDateTimePicker }
  19283.  
  19284. constructor TDateTimePicker.Create(AOwner: TComponent);
  19285. begin
  19286.   FCalExceptionClass := EDateTimeError;
  19287.   FChanging := False;
  19288.   inherited Create(AOwner);
  19289.   DateTimeToSystemTime(FDateTime, FLastChange);
  19290.   FShowCheckbox := False;
  19291.   FChecked := True;
  19292.   ControlStyle := ControlStyle + [csFixedHeight, csReflector];
  19293.   Color := clWindow;
  19294.   ParentColor := False;
  19295.   TabStop := True;
  19296.   Width := 186;
  19297.   AdjustHeight;
  19298. end;
  19299.  
  19300. procedure TDateTimePicker.AdjustHeight;
  19301. var
  19302.   DC: HDC;
  19303.   SaveFont: HFont;
  19304.   SysMetrics, Metrics: TTextMetric;
  19305. begin
  19306.   DC := GetDC(0);
  19307.   try
  19308.     GetTextMetrics(DC, SysMetrics);
  19309.     SaveFont := SelectObject(DC, Font.Handle);
  19310.     GetTextMetrics(DC, Metrics);
  19311.     SelectObject(DC, SaveFont);
  19312.   finally
  19313.     ReleaseDC(0, DC);
  19314.   end;
  19315.   Height := Metrics.tmHeight + (GetSystemMetrics(SM_CYBORDER) * 8);
  19316. end;
  19317.  
  19318. procedure TDateTimePicker.CheckEmptyDate;
  19319. begin
  19320.   if not FShowCheckbox then raise EDateTimeError.CreateRes(@SNeedAllowNone);
  19321.   FChecked := False;
  19322.   Invalidate;
  19323. end;
  19324.  
  19325. procedure TDateTimePicker.CreateParams(var Params: TCreateParams);
  19326. const
  19327.   Formats: array[TDTDateFormat] of DWORD = (DTS_SHORTDATEFORMAT,
  19328.     DTS_LONGDATEFORMAT);
  19329. var
  19330.   ACalAlignment: TDTCalAlignment;
  19331. begin
  19332.   inherited CreateParams(Params);
  19333.   CreateSubClass(Params, DATETIMEPICK_CLASS);
  19334.   with Params do
  19335.   begin
  19336.     Style := Style or Formats[FDateFormat];
  19337.     if FDateMode = dmUpDown then Style := Style or DTS_UPDOWN;
  19338.     if FKind = dtkTime then Style := Style or DTS_TIMEFORMAT;
  19339.     ACalAlignment := FCalAlignment;
  19340.     if UseRightToLeftAlignment then
  19341.       if ACalAlignment = dtaLeft then
  19342.         ACalAlignment := dtaRight
  19343.       else
  19344.         ACalAlignment := dtaLeft;
  19345.     if ACalAlignment = dtaRight then Style := Style or DTS_RIGHTALIGN;
  19346.     if FParseInput then Style := Style or DTS_APPCANPARSE;
  19347.     if FShowCheckbox then Style := Style or DTS_SHOWNONE;
  19348.     WindowClass.style := WindowClass.style and not (CS_HREDRAW or CS_VREDRAW);
  19349.   end;
  19350. end;
  19351.  
  19352. procedure TDateTimePicker.Change;
  19353. begin
  19354.   if Assigned(FOnChange) then FOnChange(Self);
  19355. end;
  19356.  
  19357. procedure TDateTimePicker.CreateWnd;
  19358. begin
  19359.   inherited CreateWnd;
  19360.   SetChecked(FChecked);
  19361. end;
  19362.  
  19363. procedure TDateTimePicker.CMColorChanged(var Message: TMessage);
  19364. begin
  19365.   inherited;
  19366.   InvalidateRect(Handle, nil, True);
  19367. end;
  19368.  
  19369. procedure TDateTimePicker.CMFontChanged(var Message: TMessage);
  19370. begin
  19371.   inherited;
  19372.   AdjustHeight;
  19373.   InvalidateRect(Handle, nil, True);
  19374. end;
  19375.  
  19376. procedure TDateTimePicker.CNNotify(var Message: TWMNotify);
  19377. var
  19378.   DT: TDateTime;
  19379.   AllowChange: Boolean;
  19380. begin
  19381.   with Message, NMHdr^ do
  19382.   begin
  19383.     Result := 0;
  19384.     case code of
  19385.       DTN_CLOSEUP:
  19386.         begin
  19387.           FDroppedDown := False;
  19388.           SetDate(SystemTimeToDateTime(FLastChange));
  19389.           if Assigned(FOnCloseUp) then FOnCloseUp(Self);
  19390.         end;
  19391.       DTN_DATETIMECHANGE:
  19392.         begin
  19393.           with PNMDateTimeChange(NMHdr)^ do
  19394.           begin
  19395.             if FDroppedDown and (dwFlags = GDT_VALID) then
  19396.             begin
  19397.               FLastChange := st;
  19398.               FDateTime := SystemTimeToDateTime(FLastChange);
  19399.             end
  19400.             else begin
  19401.               if FShowCheckbox and IsBlankSysTime(st) then
  19402.                 FChecked := False
  19403.               else if dwFlags = GDT_VALID then
  19404.               begin
  19405.                 FLastChange := st;
  19406.                 DT := SystemTimeToDateTime(st);
  19407.                 if Kind = dtkDate then SetDate(DT)
  19408.                 else SetTime(DT);
  19409.                 if FShowCheckbox then FChecked := True;
  19410.               end;
  19411.             end;
  19412.             Change;
  19413.           end;
  19414.         end;
  19415.       DTN_DROPDOWN:
  19416.         begin
  19417.           DateTimeToSystemTime(Date, FLastChange);
  19418.           FDroppedDown := True;
  19419.           if Assigned(FOnDropDown) then FOnDropDown(Self);
  19420.         end;
  19421.       DTN_USERSTRING:
  19422.         begin
  19423.           AllowChange := Assigned(FOnUserInput);
  19424.           with PNMDateTimeString(NMHdr)^ do
  19425.           begin
  19426.             if AllowChange then
  19427.             begin
  19428.               DT := 0.0;
  19429.               FOnUserInput(Self, pszUserString, DT, AllowChange);
  19430.               DateTimeToSystemTime(DT, st);
  19431.             end;
  19432.             dwFlags := Ord(not AllowChange);
  19433.           end;
  19434.         end;
  19435.     else
  19436.       inherited;
  19437.     end;
  19438.   end;
  19439. end;
  19440.  
  19441. function TDateTimePicker.GetCalendarHandle: HWND;
  19442. begin
  19443.   Result := DateTime_GetMonthCal(Handle);
  19444. end;
  19445.  
  19446. function TDateTimePicker.GetTime: TTime;
  19447. begin
  19448.   Result := TTime(FDateTime);
  19449. end;
  19450.  
  19451. function TDateTimePicker.MsgSetCalColors(ColorIndex: Integer; ColorValue: TColor): Boolean;
  19452. begin
  19453.   Result := True;
  19454.   if HandleAllocated then
  19455.     Result := DateTime_SetMonthCalColor(Handle, ColorIndex, ColorValue) <> DWORD($FFFFFFFF);
  19456. end;
  19457.  
  19458. function TDateTimePicker.MsgSetDateTime(Value: TSystemTime): Boolean;
  19459. begin
  19460.   Result := True;
  19461.   if HandleAllocated then
  19462.     if not FChanging then
  19463.     begin
  19464.       FChanging := True;
  19465.       try
  19466.         Result := DateTime_SetSystemTime(Handle, GDT_VALID, Value);
  19467.         if FShowCheckbox and not (csLoading in ComponentState)then
  19468.           FChecked := Result;
  19469.       finally
  19470.         FChanging := False;
  19471.       end;
  19472.     end;
  19473. end;
  19474.  
  19475. function TDateTimePicker.MsgSetRange(Flags: Integer; SysTime: PSystemTime): Boolean;
  19476. begin
  19477.   Result := True;
  19478.   if HandleAllocated then
  19479.     if Flags <> 0 then Result := DateTime_SetRange(Handle, Flags, SysTime);
  19480. end;
  19481.  
  19482. procedure TDateTimePicker.SetCalAlignment(Value: TDTCalAlignment);
  19483. begin
  19484.   if FCalAlignment <> Value then
  19485.   begin
  19486.     FCalAlignment := Value;
  19487.     if not (csDesigning in ComponentState) then
  19488.       SetComCtlStyle(Self, DTS_RIGHTALIGN, Value = dtaRight);
  19489.   end;
  19490. end;
  19491.  
  19492. procedure TDateTimePicker.SetChecked(Value: Boolean);
  19493. var
  19494.   ST: TSystemTime;
  19495. begin
  19496.   FChecked := Value;
  19497.   if FShowCheckbox then
  19498.   begin
  19499.     if Value then SetDateTime(FDateTime)
  19500.     else DateTime_SetSystemTime(Handle, GDT_NONE, ST);
  19501.     Invalidate;
  19502.   end;
  19503. end;
  19504.  
  19505. procedure TDateTimePicker.SetDateFormat(Value: TDTDateFormat);
  19506. begin
  19507.   if FDateFormat <> Value then
  19508.   begin
  19509.     FDateFormat := Value;
  19510.     RecreateWnd;
  19511.   end;
  19512. end;
  19513.  
  19514. procedure TDateTimePicker.SetDateMode(Value: TDTDateMode);
  19515. begin
  19516.   if FDateMode <> Value then
  19517.   begin
  19518.     FDateMode := Value;
  19519.     RecreateWnd;
  19520.   end;
  19521. end;
  19522.  
  19523. procedure TDateTimePicker.SetKind(Value: TDateTimeKind);
  19524. begin
  19525.   if FKind <> Value then
  19526.   begin
  19527.     FKind := Value;
  19528.     RecreateWnd;
  19529.   end;
  19530. end;
  19531.  
  19532. procedure TDateTimePicker.SetParseInput(Value: Boolean);
  19533. begin
  19534.   if FParseInput <> Value then
  19535.   begin
  19536.     FParseInput := Value;
  19537.     if not (csDesigning in ComponentState) then
  19538.       SetComCtlStyle(Self, DTS_APPCANPARSE, Value);
  19539.   end;
  19540. end;
  19541.  
  19542. procedure TDateTimePicker.SetShowCheckbox(Value: Boolean);
  19543. begin
  19544.   if FShowCheckbox <> Value then
  19545.   begin
  19546.     FShowCheckbox := Value;
  19547.     RecreateWnd;
  19548.   end;
  19549. end;
  19550.  
  19551. procedure TDateTimePicker.SetTime(Value: TTime);
  19552. begin
  19553.   if Abs(Frac(FDateTime)) <> Abs(Frac(Value)) then
  19554.   begin
  19555.     ReplaceDate(TDateTime(Value), FDateTime);
  19556.     if Value = 0.0 then
  19557.     begin
  19558.       if not FShowCheckbox then raise EDateTimeError.CreateRes(@SNeedAllowNone);
  19559.       FChecked := False;
  19560.       Invalidate;
  19561.     end
  19562.     else
  19563.       SetDateTime(Value);
  19564.   end;
  19565. end;
  19566.  
  19567. { TPageScroller }
  19568.  
  19569. constructor TPageScroller.Create(AOwner: TComponent);
  19570. begin
  19571.   inherited Create(AOwner);
  19572.   Width := 150;
  19573.   Height := 45;
  19574.   TabStop := True;
  19575.   ControlStyle := ControlStyle - [csCaptureMouse, csSetCaption] + [csAcceptsControls];
  19576.   FButtonSize := 12;
  19577.   FDragScroll := True;
  19578. end;
  19579.  
  19580. procedure TPageScroller.CreateParams(var Params: TCreateParams);
  19581. const
  19582.   OrientationStyle: array[TPageScrollerOrientation] of DWORD = (PGS_HORZ, PGS_VERT);
  19583. begin
  19584.   InitCommonControl(ICC_PAGESCROLLER_CLASS);
  19585.   inherited CreateParams(Params);
  19586.   CreateSubClass(Params, WC_PAGESCROLLER);
  19587.   with Params do
  19588.   begin
  19589.     if AutoScroll then Style := Style or PGS_AUTOSCROLL;
  19590.     if DragScroll then Style := Style or PGS_DRAGNDROP;
  19591.     Style := Style or OrientationStyle[Orientation];
  19592.     WindowClass.style := WindowClass.style and not (CS_HREDRAW or CS_VREDRAW);
  19593.   end;
  19594. end;
  19595.  
  19596. procedure TPageScroller.CreateWnd;
  19597. begin
  19598.   inherited CreateWnd;
  19599.   Perform(CM_COLORCHANGED, 0, 0);
  19600.   if (FControl <> nil) then
  19601.     Perform(PGM_SETCHILD, 0, FControl.Handle);
  19602.   Perform(PGM_SETBUTTONSIZE, 0, ButtonSize);
  19603.   Perform(PGM_SETBORDER, 0, Margin);
  19604.   Perform(PGM_SETPOS, 0, Position);
  19605.   Perform(PGM_RECALCSIZE, 0, 0);
  19606. end;
  19607.  
  19608. function TPageScroller.GetButtonState(Button: TPageScrollerButton): TPageScrollerButtonState;
  19609. const
  19610.   ButtonPos: array[TPageScrollerButton] of Integer = (PGB_TOPORLEFT,
  19611.     PGB_BOTTOMORRIGHT);
  19612. begin
  19613.   case SendMessage(Handle, PGM_GETBUTTONSTATE, 0, ButtonPos[Button]) of
  19614.     PGF_NORMAL: Result := bsNormal;
  19615.     PGF_GRAYED: Result := bsGrayed;
  19616.     PGF_DEPRESSED: Result := bsDepressed;
  19617.     PGF_HOT: Result := bsHot;
  19618.   else
  19619.     Result := bsInvisible;
  19620.   end;
  19621. end;
  19622.  
  19623. procedure TPageScroller.Notification(AComponent: TComponent;
  19624.   Operation: TOperation);
  19625. begin
  19626.   inherited Notification(AComponent, Operation);
  19627.   if (Operation = opRemove) and (AComponent = Control) then Control := nil;
  19628. end;
  19629.  
  19630. procedure TPageScroller.Scroll(Shift: TShiftState; X, Y: Integer;
  19631.   Orientation: TPageScrollerOrientation; var Delta: Integer);
  19632. begin
  19633.   if Assigned(FOnScroll) then FOnScroll(Self, Shift, X, Y, Orientation, Delta);
  19634. end;
  19635.  
  19636. procedure TPageScroller.UpdatePreferredSize;
  19637. begin
  19638.   if Orientation = soHorizontal then
  19639.     FPreferredSize := Control.Left + Control.Width else
  19640.     FPreferredSize := Control.Top + Control.Height;
  19641. end;
  19642.  
  19643. procedure TPageScroller.SetAutoScroll(Value: Boolean);
  19644. begin
  19645.   if AutoScroll <> Value then
  19646.   begin
  19647.     FAutoScroll := Value;
  19648.     RecreateWnd;
  19649.   end;
  19650. end;
  19651.  
  19652. procedure TPageScroller.SetButtonSize(Value: Integer);
  19653. begin
  19654.   if ButtonSize <> Value then
  19655.   begin
  19656.     FButtonSize := Value;
  19657.     SendMessage(Handle, PGM_SETBUTTONSIZE, 0, Value);
  19658.     FButtonSize := Perform(PGM_GETBUTTONSIZE, 0, 0);
  19659.   end;
  19660. end;
  19661.  
  19662. procedure TPageScroller.DoSetControl(Value: TWinControl);
  19663. begin
  19664.   FControl := Value;
  19665.   if csDestroying in ComponentState then Exit;
  19666.   if FControl <> nil then
  19667.   begin
  19668.     UpdatePreferredSize;
  19669.     FControl.FreeNotification(Self);
  19670.     FControl.Parent := Self;
  19671.     SendMessage(Handle, PGM_SETCHILD, 0, FControl.Handle);
  19672.   end
  19673.   else
  19674.     SendMessage(Handle, PGM_SETCHILD, 0, 0);
  19675.   SendMessage(Handle, PGM_RECALCSIZE, 0, 0);
  19676. end;
  19677.  
  19678. procedure TPageScroller.SetControl(Value: TWinControl);
  19679. var
  19680.   PrevControl: TWinControl;
  19681. begin
  19682.   if Control <> Value then
  19683.   begin
  19684.     PrevControl := FControl;
  19685.     DoSetControl(Value);
  19686.     if (PrevControl <> nil) and not (csDestroying in PrevControl.ComponentState) then
  19687.       PrevControl.Parent := Parent;
  19688.   end;
  19689. end;
  19690.  
  19691. procedure TPageScroller.SetDragScroll(Value: Boolean);
  19692. begin
  19693.   if DragScroll <> Value then
  19694.   begin
  19695.     FDragScroll := Value;
  19696.     RecreateWnd;
  19697.   end;
  19698. end;
  19699.  
  19700. procedure TPageScroller.SetMargin(Value: Integer);
  19701. begin
  19702.   if Margin <> Value then
  19703.   begin
  19704.     FMargin := Value;
  19705.     SendMessage(Handle, PGM_SETBORDER, 0, Value);
  19706.     FMargin := Perform(PGM_GETBORDER, 0, 0);
  19707.   end;
  19708. end;
  19709.  
  19710. procedure TPageScroller.SetOrientation(Value: TPageScrollerOrientation);
  19711. begin
  19712.   if Orientation <> Value then
  19713.   begin
  19714.     FOrientation := Value;
  19715.     RecreateWnd;
  19716.   end;
  19717. end;
  19718.  
  19719. procedure TPageScroller.SetPosition(Value: Integer);
  19720. begin
  19721.   if Position <> Value then
  19722.   begin
  19723.     FPosition := Value;
  19724.     SendMessage(Handle, PGM_SETPOS, 0, Value);
  19725.     Perform(PGM_RECALCSIZE, 0, 0);
  19726.     FPosition := Perform(PGM_GETPOS, 0, 0);
  19727.   end;
  19728. end;
  19729.  
  19730. procedure TPageScroller.AlignControls(AControl: TControl; var Rect: TRect);
  19731. begin
  19732.   if (csDesigning in ComponentState) or (AControl <> nil) and
  19733.     (AControl = Control) then
  19734.   begin
  19735.     inherited AlignControls(AControl, Rect);
  19736.     if Control <> nil then
  19737.     begin
  19738.       UpdatePreferredSize;
  19739.       { Prevent recursion for those controls that don't allow resizing }
  19740.       if (Orientation = soHorizontal) and (Control.Height = ClientHeight) or
  19741.         (Orientation = soVertical) and (Control.Width = ClientWidth) then
  19742.         Perform(PGM_RECALCSIZE, 0, 0);
  19743.     end;
  19744.   end;
  19745.   FPosition := Perform(PGM_GETPOS, 0, 0);
  19746. end;
  19747.  
  19748. procedure TPageScroller.WMNCHitTest(var Message: TWMNCHitTest);
  19749. begin
  19750.   with Message do
  19751.     if ControlCount = 0 then
  19752.       Result := HTCLIENT
  19753.     else
  19754.       inherited;
  19755. end;
  19756.  
  19757. procedure TPageScroller.CNNotify(var Message: TWMNotify);
  19758. var
  19759.   Direction: TPageScrollerOrientation;
  19760.  
  19761.   function KeysToShiftState(Keys: Word): TShiftState;
  19762.   begin
  19763.     Result := [ssLeft];
  19764.     if Keys and PGK_SHIFT <> 0 then Include(Result, ssShift);
  19765.     if Keys and PGK_CONTROL <> 0 then Include(Result, ssCtrl);
  19766.     if Keys and PGK_MENU <> 0 then Include(Result, ssAlt);
  19767.   end;
  19768.  
  19769. begin
  19770.   with Message do
  19771.     case NMHdr^.code of
  19772.       PGN_CALCSIZE:
  19773.         if Control <> nil then
  19774.           with PNMPGCalcSize(NMHdr)^ do
  19775.           begin
  19776.             if Orientation = soHorizontal then
  19777.             begin
  19778.               iWidth := FPreferredSize + 2 * BorderWidth;
  19779.               iHeight := Control.Height + 2 * BorderWidth;
  19780.             end
  19781.             else
  19782.             begin
  19783.               iWidth := Control.Width + 2 * BorderWidth;
  19784.               iHeight := FPreferredSize + 2 * BorderWidth;
  19785.             end;
  19786.           end;
  19787.       PGN_SCROLL:
  19788.         with PNMPGScroll(NMHdr)^ do
  19789.         begin
  19790.           if iDir in [PGF_SCROLLDOWN, PGF_SCROLLUP] then
  19791.           begin
  19792.             Direction := soVertical;
  19793.             if iDir = PGF_SCROLLUP then
  19794.               iScroll := -iScroll;
  19795.           end
  19796.           else
  19797.           begin
  19798.             Direction := soHorizontal;
  19799.             if iDir = PGF_SCROLLLEFT then
  19800.               iScroll := -iScroll;
  19801.           end;
  19802.           Scroll(KeysToShiftState(fwKeys), iXPos, iYPos, Direction, iScroll);
  19803.           { WINBUG: When scrolling right or down, if the first button isn't
  19804.             visible then the iScroll amount needs to be adjusted by the
  19805.             first button's size. }
  19806.           if iScroll > 0 then
  19807.           begin
  19808.             if (GetButtonState(sbFirst) = bsInvisible) then
  19809.               Inc(iScroll, ButtonSize);
  19810.           end;
  19811.           if iScroll < 0 then iScroll := -iScroll;
  19812.           if Orientation = soHorizontal then
  19813.             FPosition := iXPos + iScroll else
  19814.             FPosition := iYPos + iScroll;
  19815.         end;
  19816.     end;
  19817. end;
  19818.  
  19819. procedure TPageScroller.CMColorChanged(var Message: TMessage);
  19820. begin
  19821.   if HandleAllocated then
  19822.     SendMessage(Handle, PGM_SETBKCOLOR, 0, ColorToRGB(Color));
  19823.   inherited;
  19824. end;
  19825.  
  19826. procedure TPageScroller.CMControlChange(var Message: TCMControlChange);
  19827. begin
  19828.   { Can only accept TWinControl descendants }
  19829.   if not (csLoading in ComponentState) and (Message.Control is TWinControl) then
  19830.   begin
  19831.     if Message.Inserting then
  19832.       DoSetControl(TWinControl(Message.Control));
  19833.   end;
  19834. end;
  19835.  
  19836. initialization
  19837.  
  19838. finalization
  19839.   if ShellModule <> 0 then FreeLibrary(ShellModule);
  19840.   if FRichEditModule <> 0 then FreeLibrary(FRichEditModule);
  19841. end.
  19842.