home *** CD-ROM | disk | FTP | other *** search
/ PC Plus SuperCD (UK) 2000 March / pcp161b.iso / full / delphi / RUNIMAGE / DELPHI30 / SOURCE / VCL / COMCTRLS.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1997-08-03  |  382.1 KB  |  13,842 lines
  1.  
  2. {*******************************************************}
  3. {                                                       }
  4. {       Delphi Visual Component Library                 }
  5. {                                                       }
  6. {       Copyright (c) 1996,97 Borland International     }
  7. {                                                       }
  8. {*******************************************************}
  9.  
  10. unit ComCtrls;
  11.  
  12. {$R-}
  13.  
  14. interface
  15.  
  16. uses Messages, Windows, SysUtils, CommCtrl, Classes, Controls, Forms,
  17.   Menus, Graphics, StdCtrls, RichEdit, ToolWin;
  18.  
  19. type
  20.   TTabChangingEvent = procedure(Sender: TObject;
  21.     var AllowChange: Boolean) of object;
  22.  
  23.   TTabPosition = (tpTop, tpBottom);
  24.  
  25.   TCustomTabControl = class(TWinControl)
  26.   private
  27.     FTabs: TStrings;
  28.     FSaveTabs: TStringList;
  29.     FSaveTabIndex: Integer;
  30.     FTabSize: TSmallPoint;
  31.     FMultiLine: Boolean;
  32.     FUpdating: Boolean;
  33.     FHotTrack: Boolean;
  34.     FScrollOpposite: Boolean;
  35.     FTabPosition: TTabPosition;
  36.     FOnChange: TNotifyEvent;
  37.     FOnChanging: TTabChangingEvent;
  38.     function GetDisplayRect: TRect;
  39.     function GetTabIndex: Integer;
  40.     procedure SetHotTrack(Value: Boolean);
  41.     procedure SetMultiLine(Value: Boolean);
  42.     procedure SetScrollOpposite(Value: Boolean);
  43.     procedure SetTabHeight(Value: Smallint);
  44.     procedure SetTabIndex(Value: Integer);
  45.     procedure SetTabPosition(Value: TTabPosition);
  46.     procedure SetTabs(Value: TStrings);
  47.     procedure SetTabWidth(Value: Smallint);
  48.     procedure TabsChanged;
  49.     procedure UpdateTabSize;
  50.     procedure WMDestroy(var Message: TWMDestroy); message WM_DESTROY;
  51.     procedure WMEraseBkgnd(var Message: TMessage); message WM_ERASEBKGND;
  52.     procedure WMNotifyFormat(var Message: TMessage); message WM_NOTIFYFORMAT;
  53.     procedure WMSize(var Message: TMessage); message WM_SIZE;
  54.     procedure CMFontChanged(var Message); message CM_FONTCHANGED;
  55.     procedure CMSysColorChange(var Message: TMessage); message CM_SYSCOLORCHANGE;
  56.     procedure CMTabStopChanged(var Message: TMessage); message CM_TABSTOPCHANGED;
  57.     procedure CNNotify(var Message: TWMNotify); message CN_NOTIFY;
  58.   protected
  59.     procedure AlignControls(AControl: TControl; var Rect: TRect); override;
  60.     function CanChange: Boolean; dynamic;
  61.     procedure Change; dynamic;
  62.     procedure CreateParams(var Params: TCreateParams); override;
  63.     procedure CreateWnd; override;
  64.     procedure DestroyWnd; override;
  65.     property DisplayRect: TRect read GetDisplayRect;
  66.     property HotTrack: Boolean read FHotTrack write SetHotTrack default False;
  67.     property MultiLine: Boolean read FMultiLine write SetMultiLine default False;
  68.     property ScrollOpposite: Boolean read FScrollOpposite
  69.       write SetScrollOpposite default False;
  70.     property TabHeight: Smallint read FTabSize.Y write SetTabHeight default 0;
  71.     property TabIndex: Integer read GetTabIndex write SetTabIndex default -1;
  72.     property TabPosition: TTabPosition read FTabPosition write SetTabPosition
  73.       default tpTop;
  74.     property Tabs: TStrings read FTabs write SetTabs;
  75.     property TabWidth: Smallint read FTabSize.X write SetTabWidth default 0;
  76.     property OnChange: TNotifyEvent read FOnChange write FOnChange;
  77.     property OnChanging: TTabChangingEvent read FOnChanging write FOnChanging;
  78.   public
  79.     constructor Create(AOwner: TComponent); override;
  80.     destructor Destroy; override;
  81.     property TabStop default True;
  82.   end;
  83.  
  84.   TTabControl = class(TCustomTabControl)
  85.   public
  86.     property DisplayRect;
  87.   published
  88.     property Align;
  89.     property DragCursor;
  90.     property DragMode;
  91.     property Enabled;
  92.     property Font;
  93.     property HotTrack;
  94.     property MultiLine;
  95.     property ParentFont;
  96.     property ParentShowHint;
  97.     property PopupMenu;
  98.     property ScrollOpposite;
  99.     property ShowHint;
  100.     property TabHeight;
  101.     property TabIndex;
  102.     property TabOrder;
  103.     property TabPosition;
  104.     property Tabs;
  105.     property TabStop;
  106.     property TabWidth;
  107.     property Visible;
  108.     property OnChange;
  109.     property OnChanging;
  110.     property OnDragDrop;
  111.     property OnDragOver;
  112.     property OnEndDrag;
  113.     property OnEnter;
  114.     property OnExit;
  115.     property OnMouseDown;
  116.     property OnMouseMove;
  117.     property OnMouseUp;
  118.     property OnStartDrag;
  119.   end;
  120.  
  121.   TPageControl = class;
  122.  
  123.   TTabSheet = class(TWinControl)
  124.   private
  125.     FPageControl: TPageControl;
  126.     FTabVisible: Boolean;
  127.     FTabShowing: Boolean;
  128.     function GetPageIndex: Integer;
  129.     function GetTabIndex: Integer;
  130.     procedure SetPageControl(APageControl: TPageControl);
  131.     procedure SetPageIndex(Value: Integer);
  132.     procedure SetTabShowing(Value: Boolean);
  133.     procedure SetTabVisible(Value: Boolean);
  134.     procedure UpdateTabShowing;
  135.     procedure CMTextChanged(var Message: TMessage); message CM_TEXTCHANGED;
  136.   protected
  137.     procedure CreateParams(var Params: TCreateParams); override;
  138.     procedure ReadState(Reader: TReader); override;
  139.   public
  140.     constructor Create(AOwner: TComponent); override;
  141.     destructor Destroy; override;
  142.     property PageControl: TPageControl read FPageControl write SetPageControl;
  143.     property TabIndex: Integer read GetTabIndex;
  144.   published
  145.     property Caption;
  146.     property Enabled;
  147.     property Font;
  148.     property Height stored False;
  149.     property Left stored False;
  150.     property PageIndex: Integer read GetPageIndex write SetPageIndex stored False;
  151.     property ParentFont;
  152.     property ParentShowHint;
  153.     property PopupMenu;
  154.     property ShowHint;
  155.     property TabVisible: Boolean read FTabVisible write SetTabVisible default True;
  156.     property Top stored False;
  157.     property Visible stored False;
  158.     property Width stored False;
  159.     property OnDragDrop;
  160.     property OnDragOver;
  161.     property OnEnter;
  162.     property OnExit;
  163.     property OnMouseDown;
  164.     property OnMouseMove;
  165.     property OnMouseUp;
  166.   end;
  167.  
  168.   TPageControl = class(TCustomTabControl)
  169.   private
  170.     FPages: TList;
  171.     FActivePage: TTabSheet;
  172.     procedure ChangeActivePage(Page: TTabSheet);
  173.     procedure DeleteTab(Page: TTabSheet);
  174.     function GetPage(Index: Integer): TTabSheet;
  175.     function GetPageCount: Integer;
  176.     procedure InsertPage(Page: TTabSheet);
  177.     procedure InsertTab(Page: TTabSheet);
  178.     procedure MoveTab(CurIndex, NewIndex: Integer);
  179.     procedure RemovePage(Page: TTabSheet);
  180.     procedure SetActivePage(Page: TTabSheet);
  181.     procedure UpdateTab(Page: TTabSheet);
  182.     procedure UpdateActivePage;
  183.     procedure CMDesignHitTest(var Message: TCMDesignHitTest); message CM_DESIGNHITTEST;
  184.     procedure CMDialogKey(var Message: TCMDialogKey); message CM_DIALOGKEY;
  185.   protected
  186.     procedure Change; override;
  187.     procedure GetChildren(Proc: TGetChildProc; Root: TComponent); override;
  188.     procedure SetChildOrder(Child: TComponent; Order: Integer); override;
  189.     procedure ShowControl(AControl: TControl); override;
  190.   public
  191.     constructor Create(AOwner: TComponent); override;
  192.     destructor Destroy; override;
  193.     function FindNextPage(CurPage: TTabSheet;
  194.       GoForward, CheckTabVisible: Boolean): TTabSheet;
  195.     procedure SelectNextPage(GoForward: Boolean);
  196.     property PageCount: Integer read GetPageCount;
  197.     property Pages[Index: Integer]: TTabSheet read GetPage;
  198.   published
  199.     property ActivePage: TTabSheet read FActivePage write SetActivePage;
  200.     property Align;
  201.     property DragCursor;
  202.     property DragMode;
  203.     property Enabled;
  204.     property Font;
  205.     property HotTrack;
  206.     property MultiLine;
  207.     property ParentFont;
  208.     property ParentShowHint;
  209.     property PopupMenu;
  210.     property ScrollOpposite;
  211.     property ShowHint;
  212.     property TabHeight;
  213.     property TabOrder;
  214.     property TabPosition;
  215.     property TabStop;
  216.     property TabWidth;
  217.     property Visible;
  218.     property OnChange;
  219.     property OnChanging;
  220.     property OnDragDrop;
  221.     property OnDragOver;
  222.     property OnEndDrag;
  223.     property OnEnter;
  224.     property OnExit;
  225.     property OnMouseDown;
  226.     property OnMouseMove;
  227.     property OnMouseUp;
  228.     property OnStartDrag;
  229.   end;
  230.  
  231.   TStatusBar = class;
  232.  
  233.   TStatusPanelStyle = (psText, psOwnerDraw);
  234.   TStatusPanelBevel = (pbNone, pbLowered, pbRaised);
  235.  
  236.   TStatusPanel = class(TCollectionItem)
  237.   private
  238.     FText: string;
  239.     FWidth: Integer;
  240.     FAlignment: TAlignment;
  241.     FBevel: TStatusPanelBevel;
  242.     FStyle: TStatusPanelStyle;
  243.     function GetDisplayName: string; override;
  244.     procedure SetAlignment(Value: TAlignment);
  245.     procedure SetBevel(Value: TStatusPanelBevel);
  246.     procedure SetStyle(Value: TStatusPanelStyle);
  247.     procedure SetText(const Value: string);
  248.     procedure SetWidth(Value: Integer);
  249.   public
  250.     constructor Create(Collection: TCollection); override;
  251.     procedure Assign(Source: TPersistent); override;
  252.   published
  253.     property Alignment: TAlignment read FAlignment write SetAlignment default taLeftJustify;
  254.     property Bevel: TStatusPanelBevel read FBevel write SetBevel default pbLowered;
  255.     property Style: TStatusPanelStyle read FStyle write SetStyle default psText;
  256.     property Text: string read FText write SetText;
  257.     property Width: Integer read FWidth write SetWidth;
  258.   end;
  259.  
  260.   TStatusPanels = class(TCollection)
  261.   private
  262.     FStatusBar: TStatusBar;
  263.     function GetItem(Index: Integer): TStatusPanel;
  264.     procedure SetItem(Index: Integer; Value: TStatusPanel);
  265.   protected
  266.     function GetOwner: TPersistent; override;
  267.     procedure Update(Item: TCollectionItem); override;
  268.   public
  269.     constructor Create(StatusBar: TStatusBar);
  270.     function Add: TStatusPanel;
  271.     property Items[Index: Integer]: TStatusPanel read GetItem write SetItem; default;
  272.   end;
  273.  
  274.   TDrawPanelEvent = procedure(StatusBar: TStatusBar; Panel: TStatusPanel;
  275.     const Rect: TRect) of object;
  276.  
  277.   TStatusBar = class(TWinControl)
  278.   private
  279.     FPanels: TStatusPanels;
  280.     FCanvas: TCanvas;
  281.     FSimpleText: string;
  282.     FSimplePanel: Boolean;
  283.     FSizeGrip: Boolean;
  284.     FOnDrawPanel: TDrawPanelEvent;
  285.     FOnResize: TNotifyEvent;
  286.     procedure SetPanels(Value: TStatusPanels);
  287.     procedure SetSimplePanel(Value: Boolean);
  288.     procedure SetSimpleText(const Value: string);
  289.     procedure SetSizeGrip(Value: Boolean);
  290.     procedure UpdatePanel(Index: Integer);
  291.     procedure UpdatePanels;
  292.     procedure CNDrawItem(var Message: TWMDrawItem); message CN_DRAWITEM;
  293.     procedure WMSize(var Message: TWMSize); message WM_SIZE;
  294.   protected
  295.     procedure CreateParams(var Params: TCreateParams); override;
  296.     procedure CreateWnd; override;
  297.     procedure DrawPanel(Panel: TStatusPanel; const Rect: TRect); dynamic;
  298.     procedure Resize; dynamic;
  299.   public
  300.     constructor Create(AOwner: TComponent); override;
  301.     destructor Destroy; override;
  302.     property Canvas: TCanvas read FCanvas;
  303.   published
  304.     property Align default alBottom;
  305.     property DragCursor;
  306.     property DragMode;
  307.     property Enabled;
  308.     property Font;
  309.     property Panels: TStatusPanels read FPanels write SetPanels;
  310.     property ParentFont;
  311.     property ParentShowHint;
  312.     property PopupMenu;
  313.     property ShowHint;
  314.     property SimplePanel: Boolean read FSimplePanel write SetSimplePanel;
  315.     property SimpleText: string read FSimpleText write SetSimpleText;
  316.     property SizeGrip: Boolean read FSizeGrip write SetSizeGrip default True;
  317.     property Visible;
  318.     property OnClick;
  319.     property OnDblClick;
  320.     property OnDragDrop;
  321.     property OnDragOver;
  322.     property OnEndDrag;
  323.     property OnMouseDown;
  324.     property OnMouseMove;
  325.     property OnMouseUp;
  326.     property OnDrawPanel: TDrawPanelEvent read FOnDrawPanel write FOnDrawPanel;
  327.     property OnResize: TNotifyEvent read FOnResize write FOnResize;
  328.     property OnStartDrag;
  329.   end;
  330.  
  331.   THeaderControl = class;
  332.  
  333.   THeaderSectionStyle = (hsText, hsOwnerDraw);
  334.  
  335.   THeaderSection = class(TCollectionItem)
  336.   private
  337.     FText: string;
  338.     FWidth: Integer;
  339.     FMinWidth: Integer;
  340.     FMaxWidth: Integer;
  341.     FAlignment: TAlignment;
  342.     FStyle: THeaderSectionStyle;
  343.     FAllowClick: Boolean;
  344.     function GetLeft: Integer;
  345.     function GetRight: Integer;
  346.     procedure SetAlignment(Value: TAlignment);
  347.     procedure SetMaxWidth(Value: Integer);
  348.     procedure SetMinWidth(Value: Integer);
  349.     procedure SetStyle(Value: THeaderSectionStyle);
  350.     procedure SetText(const Value: string);
  351.     procedure SetWidth(Value: Integer);
  352.   protected
  353.     function GetDisplayName: string; override;
  354.   public
  355.     constructor Create(Collection: TCollection); override;
  356.     procedure Assign(Source: TPersistent); override;
  357.     property Left: Integer read GetLeft;
  358.     property Right: Integer read GetRight;
  359.   published
  360.     property Alignment: TAlignment read FAlignment write SetAlignment default taLeftJustify;
  361.     property AllowClick: Boolean read FAllowClick write FAllowClick default True;
  362.     property MaxWidth: Integer read FMaxWidth write SetMaxWidth default 10000;
  363.     property MinWidth: Integer read FMinWidth write SetMinWidth default 0;
  364.     property Style: THeaderSectionStyle read FStyle write SetStyle default hsText;
  365.     property Text: string read FText write SetText;
  366.     property Width: Integer read FWidth write SetWidth;
  367.   end;
  368.  
  369.   THeaderSections = class(TCollection)
  370.   private
  371.     FHeaderControl: THeaderControl;
  372.     function GetItem(Index: Integer): THeaderSection;
  373.     procedure SetItem(Index: Integer; Value: THeaderSection);
  374.   protected
  375.     function GetOwner: TPersistent; override;
  376.     procedure Update(Item: TCollectionItem); override;
  377.   public
  378.     constructor Create(HeaderControl: THeaderControl);
  379.     function Add: THeaderSection;
  380.     property Items[Index: Integer]: THeaderSection read GetItem write SetItem; default;
  381.   end;
  382.  
  383.   TSectionTrackState = (tsTrackBegin, tsTrackMove, tsTrackEnd);
  384.  
  385.   TDrawSectionEvent = procedure(HeaderControl: THeaderControl;
  386.     Section: THeaderSection; const Rect: TRect; Pressed: Boolean) of object;
  387.   TSectionNotifyEvent = procedure(HeaderControl: THeaderControl;
  388.     Section: THeaderSection) of object;
  389.   TSectionTrackEvent = procedure(HeaderControl: THeaderControl;
  390.     Section: THeaderSection; Width: Integer;
  391.     State: TSectionTrackState) of object;
  392.  
  393.   THeaderControl = class(TWinControl)
  394.   private
  395.     FSections: THeaderSections;
  396.     FCanvas: TCanvas;
  397.     FHotTrack: Boolean;
  398.     FOnDrawSection: TDrawSectionEvent;
  399.     FOnResize: TNotifyEvent;
  400.     FOnSectionClick: TSectionNotifyEvent;
  401.     FOnSectionResize: TSectionNotifyEvent;
  402.     FOnSectionTrack: TSectionTrackEvent;
  403.     procedure SetHotTrack(Value: Boolean);
  404.     procedure SetSections(Value: THeaderSections);
  405.     procedure UpdateItem(Message, Index: Integer);
  406.     procedure UpdateSection(Index: Integer);
  407.     procedure UpdateSections;
  408.     procedure CNDrawItem(var Message: TWMDrawItem); message CN_DRAWITEM;
  409.     procedure CNNotify(var Message: TWMNotify); message CN_NOTIFY;
  410.     procedure WMLButtonDown(var Message: TWMLButtonDown); message WM_LBUTTONDOWN;
  411.     procedure WMSize(var Message: TWMSize); message WM_SIZE;
  412.     procedure WMWindowPosChanged(var Message: TWMWindowPosChanged); message WM_WINDOWPOSCHANGED;
  413.   protected
  414.     procedure CreateParams(var Params: TCreateParams); override;
  415.     procedure CreateWnd; override;
  416.     procedure DrawSection(Section: THeaderSection; const Rect: TRect;
  417.       Pressed: Boolean); dynamic;
  418.     procedure Resize; dynamic;
  419.     procedure SectionClick(Section: THeaderSection); dynamic;
  420.     procedure SectionResize(Section: THeaderSection); dynamic;
  421.     procedure SectionTrack(Section: THeaderSection; Width: Integer;
  422.       State: TSectionTrackState); dynamic;
  423.   public
  424.     constructor Create(AOwner: TComponent); override;
  425.     destructor Destroy; override;
  426.     property Canvas: TCanvas read FCanvas;
  427.   published
  428.     property Align default alTop;
  429.     property DragCursor;
  430.     property DragMode;
  431.     property Enabled;
  432.     property Font;
  433.     property HotTrack: Boolean read FHotTrack write SetHotTrack default False;
  434.     property Sections: THeaderSections read FSections write SetSections;
  435.     property ShowHint;
  436.     property ParentFont;
  437.     property ParentShowHint;
  438.     property PopupMenu;
  439.     property Visible;
  440.     property OnDragDrop;
  441.     property OnDragOver;
  442.     property OnEndDrag;
  443.     property OnMouseDown;
  444.     property OnMouseMove;
  445.     property OnMouseUp;
  446.     property OnDrawSection: TDrawSectionEvent read FOnDrawSection write FOnDrawSection;
  447.     property OnResize: TNotifyEvent read FOnResize write FOnResize;
  448.     property OnSectionClick: TSectionNotifyEvent read FOnSectionClick write FOnSectionClick;
  449.     property OnSectionResize: TSectionNotifyEvent read FOnSectionResize write FOnSectionResize;
  450.     property OnSectionTrack: TSectionTrackEvent read FOnSectionTrack write FOnSectionTrack;
  451.     property OnStartDrag;
  452.   end;
  453.  
  454. { TTreeNode }
  455.  
  456.   TCustomTreeView = class;
  457.   TTreeNodes = class;
  458.  
  459.   TNodeState = (nsCut, nsDropHilited, nsFocused, nsSelected, nsExpanded);
  460.   TNodeAttachMode = (naAdd, naAddFirst, naAddChild, naAddChildFirst, naInsert);
  461.   TAddMode = (taAddFirst, taAdd, taInsert);
  462.  
  463.   PNodeInfo = ^TNodeInfo;
  464.   TNodeInfo = packed record
  465.     ImageIndex: Integer;
  466.     SelectedIndex: Integer;
  467.     StateIndex: Integer;
  468.     OverlayIndex: Integer;
  469.     Data: Pointer;
  470.     Count: Integer;
  471.     Text: string[255];
  472.   end;
  473.  
  474.   TTreeNode = class(TPersistent)
  475.   private
  476.     FOwner: TTreeNodes;
  477.     FText: string;
  478.     FData: Pointer;
  479.     FItemId: HTreeItem;
  480.     FImageIndex: Integer;
  481.     FSelectedIndex: Integer;
  482.     FOverlayIndex: Integer;
  483.     FStateIndex: Integer;
  484.     FDeleting: Boolean;
  485.     FInTree: Boolean;
  486.     function CompareCount(CompareMe: Integer): Boolean;
  487.     function DoCanExpand(Expand: Boolean): Boolean;
  488.     procedure DoExpand(Expand: Boolean);
  489.     procedure ExpandItem(Expand: Boolean; Recurse: Boolean);
  490.     function GetAbsoluteIndex: Integer;
  491.     function GetExpanded: Boolean;
  492.     function GetLevel: Integer;
  493.     function GetParent: TTreeNode;
  494.     function GetChildren: Boolean;
  495.     function GetCut: Boolean;
  496.     function GetDropTarget: Boolean;
  497.     function GetFocused: Boolean;
  498.     function GetIndex: Integer;
  499.     function GetItem(Index: Integer): TTreeNode;
  500.     function GetSelected: Boolean;
  501.     function GetState(NodeState: TNodeState): Boolean;
  502.     function GetCount: Integer;
  503.     function GetTreeView: TCustomTreeView;
  504.     procedure InternalMove(ParentNode, Node: TTreeNode; HItem: HTreeItem;
  505.       AddMode: TAddMode);
  506.     function IsEqual(Node: TTreeNode): Boolean;
  507.     function IsNodeVisible: Boolean;
  508.     procedure ReadData(Stream: TStream; Info: PNodeInfo);
  509.     procedure SetChildren(Value: Boolean);
  510.     procedure SetCut(Value: Boolean);
  511.     procedure SetData(Value: Pointer);
  512.     procedure SetDropTarget(Value: Boolean);
  513.     procedure SetItem(Index: Integer; Value: TTreeNode);
  514.     procedure SetExpanded(Value: Boolean);
  515.     procedure SetFocused(Value: Boolean);
  516.     procedure SetImageIndex(Value: Integer);
  517.     procedure SetOverlayIndex(Value: Integer);
  518.     procedure SetSelectedIndex(Value: Integer);
  519.     procedure SetSelected(Value: Boolean);
  520.     procedure SetStateIndex(Value: Integer);
  521.     procedure SetText(const S: string);
  522.     procedure WriteData(Stream: TStream; Info: PNodeInfo);
  523.   public
  524.     constructor Create(AOwner: TTreeNodes);
  525.     destructor Destroy; override;
  526.     function AlphaSort: Boolean;
  527.     procedure Assign(Source: TPersistent); override;
  528.     procedure Collapse(Recurse: Boolean);
  529.     function CustomSort(SortProc: TTVCompare; Data: Longint): Boolean;
  530.     procedure Delete;
  531.     procedure DeleteChildren;
  532.     function DisplayRect(TextOnly: Boolean): TRect;
  533.     function EditText: Boolean;
  534.     procedure EndEdit(Cancel: Boolean);
  535.     procedure Expand(Recurse: Boolean);
  536.     function GetFirstChild: TTreeNode;
  537.     function GetHandle: HWND;
  538.     function GetLastChild: TTreeNode;
  539.     function GetNext: TTreeNode;
  540.     function GetNextChild(Value: TTreeNode): TTreeNode;
  541.     function GetNextSibling: TTreeNode;
  542.     function GetNextVisible: TTreeNode;
  543.     function GetPrev: TTreeNode;
  544.     function GetPrevChild(Value: TTreeNode): TTreeNode;
  545.     function GetPrevSibling: TTreeNode;
  546.     function GetPrevVisible: TTreeNode;
  547.     function HasAsParent(Value: TTreeNode): Boolean;
  548.     function IndexOf(Value: TTreeNode): Integer;
  549.     procedure MakeVisible;
  550.     procedure MoveTo(Destination: TTreeNode; Mode: TNodeAttachMode); virtual;
  551.     property AbsoluteIndex: Integer read GetAbsoluteIndex;
  552.     property Count: Integer read GetCount;
  553.     property Cut: Boolean read GetCut write SetCut;
  554.     property Data: Pointer read FData write SetData;
  555.     property Deleting: Boolean read FDeleting;
  556.     property Focused: Boolean read GetFocused write SetFocused;
  557.     property DropTarget: Boolean read GetDropTarget write SetDropTarget;
  558.     property Selected: Boolean read GetSelected write SetSelected;
  559.     property Expanded: Boolean read GetExpanded write SetExpanded;
  560.     property Handle: HWND read GetHandle;
  561.     property HasChildren: Boolean read GetChildren write SetChildren;
  562.     property ImageIndex: Integer read FImageIndex write SetImageIndex;
  563.     property Index: Integer read GetIndex;
  564.     property IsVisible: Boolean read IsNodeVisible;
  565.     property Item[Index: Integer]: TTreeNode read GetItem write SetItem; default;
  566.     property ItemId: HTreeItem read FItemId;
  567.     property Level: Integer read GetLevel;
  568.     property OverlayIndex: Integer read FOverlayIndex write SetOverlayIndex;
  569.     property Owner: TTreeNodes read FOwner;
  570.     property Parent: TTreeNode read GetParent;
  571.     property SelectedIndex: Integer read FSelectedIndex write SetSelectedIndex;
  572.     property StateIndex: Integer read FStateIndex write SetStateIndex;
  573.     property Text: string read FText write SetText;
  574.     property TreeView: TCustomTreeView read GetTreeView;
  575.   end;
  576.  
  577. { TTreeNodes }
  578.  
  579.   TTreeNodes = class(TPersistent)
  580.   private
  581.     FOwner: TCustomTreeView;
  582.     FUpdateCount: Integer;
  583.     procedure AddedNode(Value: TTreeNode);
  584.     function GetHandle: HWND;
  585.     function GetNodeFromIndex(Index: Integer): TTreeNode;
  586.     procedure ReadData(Stream: TStream);
  587.     procedure Repaint(Node: TTreeNode);
  588.     procedure WriteData(Stream: TStream);
  589.   protected
  590.     function AddItem(Parent, Target: HTreeItem; const Item: TTVItem;
  591.       AddMode: TAddMode): HTreeItem;
  592.     function InternalAddObject(Node: TTreeNode; const S: string;
  593.       Ptr: Pointer; AddMode: TAddMode): TTreeNode;
  594.     procedure DefineProperties(Filer: TFiler); override;
  595.     function CreateItem(Node: TTreeNode): TTVItem;
  596.     function GetCount: Integer;
  597.     procedure SetItem(Index: Integer; Value: TTreeNode);
  598.     procedure SetUpdateState(Updating: Boolean);
  599.   public
  600.     constructor Create(AOwner: TCustomTreeView);
  601.     destructor Destroy; override;
  602.     function AddChildFirst(Node: TTreeNode; const S: string): TTreeNode;
  603.     function AddChild(Node: TTreeNode; const S: string): TTreeNode;
  604.     function AddChildObjectFirst(Node: TTreeNode; const S: string;
  605.       Ptr: Pointer): TTreeNode;
  606.     function AddChildObject(Node: TTreeNode; const S: string;
  607.       Ptr: Pointer): TTreeNode;
  608.     function AddFirst(Node: TTreeNode; const S: string): TTreeNode;
  609.     function Add(Node: TTreeNode; const S: string): TTreeNode;
  610.     function AddObjectFirst(Node: TTreeNode; const S: string;
  611.       Ptr: Pointer): TTreeNode;
  612.     function AddObject(Node: TTreeNode; const S: string;
  613.       Ptr: Pointer): TTreeNode;
  614.     procedure Assign(Source: TPersistent); override;
  615.     procedure BeginUpdate;
  616.     procedure Clear;
  617.     procedure Delete(Node: TTreeNode);
  618.     procedure EndUpdate;
  619.     function GetFirstNode: TTreeNode;
  620.     function GetNode(ItemId: HTreeItem): TTreeNode;
  621.     function Insert(Node: TTreeNode; const S: string): TTreeNode;
  622.     function InsertObject(Node: TTreeNode; const S: string;
  623.       Ptr: Pointer): TTreeNode;
  624.     property Count: Integer read GetCount;
  625.     property Handle: HWND read GetHandle;
  626.     property Item[Index: Integer]: TTreeNode read GetNodeFromIndex; default;
  627.     property Owner: TCustomTreeView read FOwner;
  628.   end;
  629.  
  630. { TCustomTreeView }
  631.  
  632.   THitTest = (htAbove, htBelow, htNowhere, htOnItem, htOnButton,
  633.     htOnIcon, htOnIndent, htOnLabel, htOnRight,
  634.     htOnStateIcon, htToLeft, htToRight);
  635.   THitTests = set of THitTest;
  636.   ETreeViewError = class(Exception);
  637.  
  638.   TTVChangingEvent = procedure(Sender: TObject; Node: TTreeNode;
  639.     var AllowChange: Boolean) of object;
  640.   TTVChangedEvent = procedure(Sender: TObject; Node: TTreeNode) of object;
  641.   TTVEditingEvent = procedure(Sender: TObject; Node: TTreeNode;
  642.     var AllowEdit: Boolean) of object;
  643.   TTVEditedEvent = procedure(Sender: TObject; Node: TTreeNode; var S: string) of object;
  644.   TTVExpandingEvent = procedure(Sender: TObject; Node: TTreeNode;
  645.     var AllowExpansion: Boolean) of object;
  646.   TTVCollapsingEvent = procedure(Sender: TObject; Node: TTreeNode;
  647.     var AllowCollapse: Boolean) of object;
  648.   TTVExpandedEvent = procedure(Sender: TObject; Node: TTreeNode) of object;
  649.   TTVCompareEvent = procedure(Sender: TObject; Node1, Node2: TTreeNode;
  650.     Data: Integer; var Compare: Integer) of object;
  651.  
  652.   TSortType = (stNone, stData, stText, stBoth);
  653.  
  654.   TCustomTreeView = class(TWinControl)
  655.   private
  656.     FShowLines: Boolean;
  657.     FShowRoot: Boolean;
  658.     FShowButtons: Boolean;
  659.     FBorderStyle: TBorderStyle;
  660.     FReadOnly: Boolean;
  661.     FImages: TImageList;
  662.     FStateImages: TImageList;
  663.     FImageChangeLink: TChangeLink;
  664.     FStateChangeLink: TChangeLink;
  665.     FDragImage: TImageList;
  666.     FTreeNodes: TTreeNodes;
  667.     FSortType: TSortType;
  668.     FSaveItems: TStringList;
  669.     FSaveTopIndex: Integer;
  670.     FSaveIndex: Integer;
  671.     FSaveIndent: Integer;
  672.     FHideSelection: Boolean;
  673.     FMemStream: TMemoryStream;
  674.     FEditInstance: Pointer;
  675.     FDefEditProc: Pointer;
  676.     FEditHandle: HWND;
  677.     FDragged: Boolean;
  678.     FRClickNode: TTreeNode;
  679.     FLastDropTarget: TTreeNode;
  680.     FDragNode: TTreeNode;
  681.     FManualNotify: Boolean;
  682.     FRightClickSelect: Boolean;
  683.     FSavedSort: TSortType;
  684.     FStateChanging: Boolean;
  685.     FWideText: WideString;
  686.     FOnEditing: TTVEditingEvent;
  687.     FOnEdited: TTVEditedEvent;
  688.     FOnExpanded: TTVExpandedEvent;
  689.     FOnExpanding: TTVExpandingEvent;
  690.     FOnCollapsed: TTVExpandedEvent;
  691.     FOnCollapsing: TTVCollapsingEvent;
  692.     FOnChanging: TTVChangingEvent;
  693.     FOnChange: TTVChangedEvent;
  694.     FOnCompare: TTVCompareEvent;
  695.     FOnDeletion: TTVExpandedEvent;
  696.     FOnGetImageIndex: TTVExpandedEvent;
  697.     FOnGetSelectedIndex: TTVExpandedEvent;
  698.     procedure CMColorChanged(var Message: TMessage); message CM_COLORCHANGED;
  699.     procedure CMCtl3DChanged(var Message: TMessage); message CM_CTL3DCHANGED;
  700.     procedure CMDrag(var Message: TCMDrag); message CM_DRAG;
  701.     procedure CNNotify(var Message: TWMNotify); message CN_NOTIFY;
  702.     procedure EditWndProc(var Message: TMessage);
  703.     procedure DoDragOver(Source: TDragObject; X, Y: Integer; CanDrop: Boolean);
  704.     procedure GetImageIndex(Node: TTreeNode);
  705.     procedure GetSelectedIndex(Node: TTreeNode);
  706.     function GetDropTarget: TTreeNode;
  707.     function GetIndent: Integer;
  708.     function GetNodeFromItem(const Item: TTVItem): TTreeNode;
  709.     function GetSelection: TTreeNode;
  710.     function GetTopItem: TTreeNode;
  711.     procedure ImageListChange(Sender: TObject);
  712.     procedure SetBorderStyle(Value: TBorderStyle);
  713.     procedure SetButtonStyle(Value: Boolean);
  714.     procedure SetDropTarget(Value: TTreeNode);
  715.     procedure SetHideSelection(Value: Boolean);
  716.     procedure SetImageList(Value: HImageList; Flags: Integer);
  717.     procedure SetIndent(Value: Integer);
  718.     procedure SetImages(Value: TImageList);
  719.     procedure SetLineStyle(Value: Boolean);
  720.     procedure SetReadOnly(Value: Boolean);
  721.     procedure SetRootStyle(Value: Boolean);
  722.     procedure SetSelection(Value: TTreeNode);
  723.     procedure SetSortType(Value: TSortType);
  724.     procedure SetStateImages(Value: TImageList);
  725.     procedure SetStyle(Value: Integer; UseStyle: Boolean);
  726.     procedure SetTreeNodes(Value: TTreeNodes);
  727.     procedure SetTopItem(Value: TTreeNode);
  728.     procedure WMLButtonDown(var Message: TWMLButtonDown); message WM_LBUTTONDOWN;
  729.     procedure WMRButtonDown(var Message: TWMRButtonDown); message WM_RBUTTONDOWN;
  730.     procedure WMRButtonUp(var Message: TWMRButtonUp); message WM_RBUTTONUP;
  731.     procedure WMNotify(var Message: TWMNotify); message WM_NOTIFY;
  732.     procedure CMSysColorChange(var Message: TMessage); message CM_SYSCOLORCHANGE;
  733.   protected
  734.     function CanEdit(Node: TTreeNode): Boolean; dynamic;
  735.     function CanChange(Node: TTreeNode): Boolean; dynamic;
  736.     function CanCollapse(Node: TTreeNode): Boolean; dynamic;
  737.     function CanExpand(Node: TTreeNode): Boolean; dynamic;
  738.     procedure Change(Node: TTreeNode); dynamic;
  739.     procedure Collapse(Node: TTreeNode); dynamic;
  740.     function CreateNode: TTreeNode; virtual;
  741.     procedure CreateParams(var Params: TCreateParams); override;
  742.     procedure CreateWnd; override;
  743.     procedure DestroyWnd; override;
  744.     procedure DoEndDrag(Target: TObject; X, Y: Integer); override;
  745.     procedure DoStartDrag(var DragObject: TDragObject); override;
  746.     procedure Edit(const Item: TTVItem); dynamic;
  747.     procedure Expand(Node: TTreeNode); dynamic;
  748.     function GetDragImages: TCustomImageList; override;
  749.     procedure Loaded; override;
  750.     procedure Notification(AComponent: TComponent;
  751.       Operation: TOperation); override;
  752.     procedure SetDragMode(Value: TDragMode); override;
  753.     procedure WndProc(var Message: TMessage); override;
  754.     property OnEditing: TTVEditingEvent read FOnEditing write FOnEditing;
  755.     property OnEdited: TTVEditedEvent read FOnEdited write FOnEdited;
  756.     property OnExpanding: TTVExpandingEvent read FOnExpanding write FOnExpanding;
  757.     property OnExpanded: TTVExpandedEvent read FOnExpanded write FOnExpanded;
  758.     property OnCollapsing: TTVCollapsingEvent read FOnCollapsing write FOnCollapsing;
  759.     property OnCollapsed: TTVExpandedEvent read FOnCollapsed write FOnCollapsed;
  760.     property OnChanging: TTVChangingEvent read FOnChanging write FOnChanging;
  761.     property OnChange: TTVChangedEvent read FOnChange write FOnChange;
  762.     property OnCompare: TTVCompareEvent read FOnCompare write FOnCompare;
  763.     property OnDeletion: TTVExpandedEvent read FOnDeletion write FOnDeletion;
  764.     property OnGetImageIndex: TTVExpandedEvent read FOnGetImageIndex write FOnGetImageIndex;
  765.     property OnGetSelectedIndex: TTVExpandedEvent read FOnGetSelectedIndex write FOnGetSelectedIndex;
  766.     property ShowButtons: Boolean read FShowButtons write SetButtonStyle default True;
  767.     property BorderStyle: TBorderStyle read FBorderStyle write SetBorderStyle default bsSingle;
  768.     property ShowLines: Boolean read FShowLines write SetLineStyle default True;
  769.     property ShowRoot: Boolean read FShowRoot write SetRootStyle default True;
  770.     property ReadOnly: Boolean read FReadOnly write SetReadOnly default False;
  771.     property RightClickSelect: Boolean read FRightClickSelect write FRightClickSelect default False;
  772.     property Indent: Integer read GetIndent write SetIndent;
  773.     property Items: TTreeNodes read FTreeNodes write SetTreeNodes;
  774.     property SortType: TSortType read FSortType write SetSortType default stNone;
  775.     property HideSelection: Boolean read FHideSelection write SetHideSelection default True;
  776.     property Images: TImageList read FImages write SetImages;
  777.     property StateImages: TImageList read FStateImages write SetStateImages;
  778.   public
  779.     constructor Create(AOwner: TComponent); override;
  780.     destructor Destroy; override;
  781.     function AlphaSort: Boolean;
  782.     function CustomSort(SortProc: TTVCompare; Data: Longint): Boolean;
  783.     procedure FullCollapse;
  784.     procedure FullExpand;
  785.     function GetHitTestInfoAt(X, Y: Integer): THitTests;
  786.     function GetNodeAt(X, Y: Integer): TTreeNode;
  787.     function IsEditing: Boolean;
  788.     procedure LoadFromFile(const FileName: string);
  789.     procedure LoadFromStream(Stream: TStream);
  790.     procedure SaveToFile(const FileName: string);
  791.     procedure SaveToStream(Stream: TStream);
  792.     property DropTarget: TTreeNode read GetDropTarget write SetDropTarget;
  793.     property Selected: TTreeNode read GetSelection write SetSelection;
  794.     property TopItem: TTreeNode read GetTopItem write SetTopItem;
  795.   end;
  796.  
  797.   TTreeView = class(TCustomTreeView)
  798.   published
  799.     property ShowButtons;
  800.     property BorderStyle;
  801.     property DragCursor;
  802.     property ShowLines;
  803.     property ShowRoot;
  804.     property ReadOnly;
  805.     property RightClickSelect;
  806.     property DragMode;
  807.     property HideSelection;
  808.     property Indent;
  809.     property Items;
  810.     property OnEditing;
  811.     property OnEdited;
  812.     property OnExpanding;
  813.     property OnExpanded;
  814.     property OnCollapsing;
  815.     property OnCompare;
  816.     property OnCollapsed;
  817.     property OnChanging;
  818.     property OnChange;
  819.     property OnDeletion;
  820.     property OnGetImageIndex;
  821.     property OnGetSelectedIndex;
  822.     property Align;
  823.     property Enabled;
  824.     property Font;
  825.     property Color;
  826.     property ParentColor default False;
  827.     property ParentCtl3D;
  828.     property Ctl3D;
  829.     property SortType;
  830.     property TabOrder;
  831.     property TabStop default True;
  832.     property Visible;
  833.     property OnClick;
  834.     property OnEnter;
  835.     property OnExit;
  836.     property OnDragDrop;
  837.     property OnDragOver;
  838.     property OnStartDrag;
  839.     property OnEndDrag;
  840.     property OnMouseDown;
  841.     property OnMouseMove;
  842.     property OnMouseUp;
  843.     property OnDblClick;
  844.     property OnKeyDown;
  845.     property OnKeyPress;
  846.     property OnKeyUp;
  847.     property PopupMenu;
  848.     property ParentFont;
  849.     property ParentShowHint;
  850.     property ShowHint;
  851.     property Images;
  852.     property StateImages;
  853.   end;
  854.  
  855. { TTrackBar }
  856.  
  857.   TTrackBarOrientation = (trHorizontal, trVertical);
  858.   TTickMark = (tmBottomRight, tmTopLeft, tmBoth);
  859.   TTickStyle = (tsNone, tsAuto, tsManual);
  860.  
  861.   TTrackBar = class(TWinControl)
  862.   private
  863.     FOrientation: TTrackBarOrientation;
  864.     FTickMarks: TTickMark;
  865.     FTickStyle: TTickStyle;
  866.     FLineSize: Integer;
  867.     FPageSize: Integer;
  868.     FMin: Integer;
  869.     FMax: Integer;
  870.     FFrequency: Integer;
  871.     FPosition: Integer;
  872.     FSelStart: Integer;
  873.     FSelEnd: Integer;
  874.     FOnChange: TNotifyEvent;
  875.     procedure SetOrientation(Value: TTrackBarOrientation);
  876.     procedure SetParams(APosition, AMin, AMax: Integer);
  877.     procedure SetPosition(Value: Integer);
  878.     procedure SetMin(Value: Integer);
  879.     procedure SetMax(Value: Integer);
  880.     procedure SetFrequency(Value: Integer);
  881.     procedure SetTickStyle(Value: TTickStyle);
  882.     procedure SetTickMarks(Value: TTickMark);
  883.     procedure SetLineSize(Value: Integer);
  884.     procedure SetPageSize(Value: Integer);
  885.     procedure SetSelStart(Value: Integer);
  886.     procedure SetSelEnd(Value: Integer);
  887.     procedure UpdateSelection;
  888.     procedure CNHScroll(var Message: TWMHScroll); message CN_HSCROLL;
  889.     procedure CNVScroll(var Message: TWMVScroll); message CN_VSCROLL;
  890.   protected
  891.     procedure CreateParams(var Params: TCreateParams); override;
  892.     procedure CreateWnd; override;
  893.     procedure DestroyWnd; override;
  894.   public
  895.     constructor Create(AOwner: TComponent); override;
  896.     procedure SetTick(Value: Integer);
  897.   published
  898.     property Ctl3D;
  899.     property DragCursor;
  900.     property DragMode;
  901.     property Enabled;
  902.     property LineSize: Integer read FLineSize write SetLineSize default 1;
  903.     property Max: Integer read FMax write SetMax default 10;
  904.     property Min: Integer read FMin write SetMin default 0;
  905.     property Orientation: TTrackBarOrientation read FOrientation write SetOrientation;
  906.     property ParentCtl3D;
  907.     property ParentShowHint;
  908.     property PageSize: Integer read FPageSize write SetPageSize default 2;
  909.     property PopupMenu;
  910.     property Frequency: Integer read FFrequency write SetFrequency;
  911.     property Position: Integer read FPosition write SetPosition;
  912.     property SelEnd: Integer read FSelEnd write SetSelEnd;
  913.     property SelStart: Integer read FSelStart write SetSelStart;
  914.     property ShowHint;
  915.     property TabOrder;
  916.     property TabStop default True;
  917.     property TickMarks: TTickMark read FTickMarks write SetTickMarks;
  918.     property TickStyle: TTickStyle read FTickStyle write SetTickStyle;
  919.     property Visible;
  920.     property OnChange: TNotifyEvent read FOnChange write FOnChange;
  921.     property OnDragDrop;
  922.     property OnDragOver;
  923.     property OnEndDrag;
  924.     property OnEnter;
  925.     property OnExit;
  926.     property OnKeyDown;
  927.     property OnKeyPress;
  928.     property OnKeyUp;
  929.     property OnStartDrag;
  930.   end;
  931.  
  932. { TProgressBar }
  933.  
  934.   TProgressRange = Integer; // for backward compatibility
  935.  
  936.   TProgressBar = class(TWinControl)
  937.   private
  938.     FMin: Integer;
  939.     FMax: Integer;
  940.     FStep: Integer;
  941.     FPosition: Integer;
  942.     F32BitMode: Boolean;
  943.     function GetMin: Integer;
  944.     function GetMax: Integer;
  945.     function GetPosition: Integer;
  946.     procedure SetParams(AMin, AMax: Integer);
  947.     procedure SetMin(Value: Integer);
  948.     procedure SetMax(Value: Integer);
  949.     procedure SetPosition(Value: Integer);
  950.     procedure SetStep(Value: Integer);
  951.   protected
  952.     procedure CreateParams(var Params: TCreateParams); override;
  953.     procedure CreateWnd; override;
  954.   public
  955.     constructor Create(AOwner: TComponent); override;
  956.     procedure StepIt;
  957.     procedure StepBy(Delta: Integer);
  958.   published
  959.     property Align;
  960.     property DragCursor;
  961.     property DragMode;
  962.     property Enabled;
  963.     property Hint;
  964.     property Min: Integer read GetMin write SetMin;
  965.     property Max: Integer read GetMax write SetMax;
  966.     property ParentShowHint;
  967.     property PopupMenu;
  968.     property Position: Integer read GetPosition write SetPosition default 0;
  969.     property Step: Integer read FStep write SetStep default 10;
  970.     property ShowHint;
  971.     property TabOrder;
  972.     property TabStop;
  973.     property Visible;
  974.     property OnDragDrop;
  975.     property OnDragOver;
  976.     property OnEndDrag;
  977.     property OnEnter;
  978.     property OnExit;
  979.     property OnMouseDown;
  980.     property OnMouseMove;
  981.     property OnMouseUp;
  982.     property OnStartDrag;
  983.   end;
  984.  
  985. { TTextAttributes }
  986.  
  987.   TCustomRichEdit = class;
  988.  
  989.   TAttributeType = (atSelected, atDefaultText);
  990.   TConsistentAttribute = (caBold, caColor, caFace, caItalic,
  991.     caSize, caStrikeOut, caUnderline, caProtected);
  992.   TConsistentAttributes = set of TConsistentAttribute;
  993.  
  994.   TTextAttributes = class(TPersistent)
  995.   private
  996.     RichEdit: TCustomRichEdit;
  997.     FType: TAttributeType;
  998.     procedure GetAttributes(var Format: TCharFormat);
  999.     function GetCharset: TFontCharset;
  1000.     function GetColor: TColor;
  1001.     function GetConsistentAttributes: TConsistentAttributes;
  1002.     function GetHeight: Integer;
  1003.     function GetName: TFontName;
  1004.     function GetPitch: TFontPitch;
  1005.     function GetProtected: Boolean;
  1006.     function GetSize: Integer;
  1007.     function GetStyle: TFontStyles;
  1008.     procedure SetAttributes(var Format: TCharFormat);
  1009.     procedure SetCharset(Value: TFontCharset);
  1010.     procedure SetColor(Value: TColor);
  1011.     procedure SetHeight(Value: Integer);
  1012.     procedure SetName(Value: TFontName);
  1013.     procedure SetPitch(Value: TFontPitch);
  1014.     procedure SetProtected(Value: Boolean);
  1015.     procedure SetSize(Value: Integer);
  1016.     procedure SetStyle(Value: TFontStyles);
  1017.   protected
  1018.     procedure InitFormat(var Format: TCharFormat);
  1019.     procedure AssignTo(Dest: TPersistent); override;
  1020.   public
  1021.     constructor Create(AOwner: TCustomRichEdit; AttributeType: TAttributeType);
  1022.     procedure Assign(Source: TPersistent); override;
  1023.     property Charset: TFontCharset read GetCharset write SetCharset;
  1024.     property Color: TColor read GetColor write SetColor;
  1025.     property ConsistentAttributes: TConsistentAttributes read GetConsistentAttributes;
  1026.     property Name: TFontName read GetName write SetName;
  1027.     property Pitch: TFontPitch read GetPitch write SetPitch;
  1028.     property Protected: Boolean read GetProtected write SetProtected;
  1029.     property Size: Integer read GetSize write SetSize;
  1030.     property Style: TFontStyles read GetStyle write SetStyle;
  1031.     property Height: Integer read GetHeight write SetHeight;
  1032.   end;
  1033.  
  1034. { TParaAttributes }
  1035.  
  1036.   TNumberingStyle = (nsNone, nsBullet);
  1037.  
  1038.   TParaAttributes = class(TPersistent)
  1039.   private
  1040.     RichEdit: TCustomRichEdit;
  1041.     procedure GetAttributes(var Paragraph: TParaFormat);
  1042.     function GetAlignment: TAlignment;
  1043.     function GetFirstIndent: Longint;
  1044.     function GetLeftIndent: Longint;
  1045.     function GetRightIndent: Longint;
  1046.     function GetNumbering: TNumberingStyle;
  1047.     function GetTab(Index: Byte): Longint;
  1048.     function GetTabCount: Integer;
  1049.     procedure InitPara(var Paragraph: TParaFormat);
  1050.     procedure SetAlignment(Value: TAlignment);
  1051.     procedure SetAttributes(var Paragraph: TParaFormat);
  1052.     procedure SetFirstIndent(Value: Longint);
  1053.     procedure SetLeftIndent(Value: Longint);
  1054.     procedure SetRightIndent(Value: Longint);
  1055.     procedure SetNumbering(Value: TNumberingStyle);
  1056.     procedure SetTab(Index: Byte; Value: Longint);
  1057.     procedure SetTabCount(Value: Integer);
  1058.   public
  1059.     constructor Create(AOwner: TCustomRichEdit);
  1060.     procedure Assign(Source: TPersistent); override;
  1061.     property Alignment: TAlignment read GetAlignment write SetAlignment;
  1062.     property FirstIndent: Longint read GetFirstIndent write SetFirstIndent;
  1063.     property LeftIndent: Longint read GetLeftIndent write SetLeftIndent;
  1064.     property Numbering: TNumberingStyle read GetNumbering write SetNumbering;
  1065.     property RightIndent: Longint read GetRightIndent write SetRightIndent;
  1066.     property Tab[Index: Byte]: Longint read GetTab write SetTab;
  1067.     property TabCount: Integer read GetTabCount write SetTabCount;
  1068.   end;
  1069.  
  1070. { TCustomRichEdit }
  1071.  
  1072.   TRichEditResizeEvent = procedure(Sender: TObject; Rect: TRect) of object;
  1073.   TRichEditProtectChange = procedure(Sender: TObject;
  1074.     StartPos, EndPos: Integer; var AllowChange: Boolean) of object;
  1075.   TRichEditSaveClipboard = procedure(Sender: TObject;
  1076.     NumObjects, NumChars: Integer; var SaveClipboard: Boolean) of object;
  1077.   TSearchType = (stWholeWord, stMatchCase);
  1078.   TSearchTypes = set of TSearchType;
  1079.  
  1080.   TConversion = class(TObject)
  1081.   public
  1082.     function ConvertReadStream(Stream: TStream; Buffer: PChar; BufSize: Integer): Integer; virtual;
  1083.     function ConvertWriteStream(Stream: TStream; Buffer: PChar; BufSize: Integer): Integer; virtual;
  1084.   end;
  1085.  
  1086.   TConversionClass = class of TConversion;
  1087.  
  1088.   PConversionFormat = ^TConversionFormat;
  1089.   TConversionFormat = record
  1090.     ConversionClass: TConversionClass;
  1091.     Extension: string;
  1092.     Next: PConversionFormat;
  1093.   end;
  1094.  
  1095.   PRichEditStreamInfo = ^TRichEditStreamInfo;
  1096.   TRichEditStreamInfo = record
  1097.     Converter: TConversion;
  1098.     Stream: TStream;
  1099.   end;
  1100.  
  1101.   TCustomRichEdit = class(TCustomMemo)
  1102.   private
  1103.     FLibHandle: THandle;
  1104.     FHideScrollBars: Boolean;
  1105.     FSelAttributes: TTextAttributes;
  1106.     FDefAttributes: TTextAttributes;
  1107.     FParagraph: TParaAttributes;
  1108.     FScreenLogPixels: Integer;
  1109.     FRichEditStrings: TStrings;
  1110.     FMemStream: TMemoryStream;
  1111.     FOnSelChange: TNotifyEvent;
  1112.     FHideSelection: Boolean;
  1113.     FModified: Boolean;
  1114.     FDefaultConverter: TConversionClass;
  1115.     FOnResizeRequest: TRichEditResizeEvent;
  1116.     FOnProtectChange: TRichEditProtectChange;
  1117.     FOnSaveClipboard: TRichEditSaveClipboard;
  1118.     FPageRect: TRect;
  1119.     procedure CMColorChanged(var Message: TMessage); message CM_COLORCHANGED;
  1120.     procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
  1121.     procedure CNNotify(var Message: TWMNotify); message CN_NOTIFY;
  1122.     function GetPlainText: Boolean;
  1123.     function ProtectChange(StartPos, EndPos: Integer): Boolean;
  1124.     function SaveClipboard(NumObj, NumChars: Integer): Boolean;
  1125.     procedure SetHideScrollBars(Value: Boolean);
  1126.     procedure SetHideSelection(Value: Boolean);
  1127.     procedure SetPlainText(Value: Boolean);
  1128.     procedure SetRichEditStrings(Value: TStrings);
  1129.     procedure SetDefAttributes(Value: TTextAttributes);
  1130.     procedure SetSelAttributes(Value: TTextAttributes);
  1131.     procedure WMNCDestroy(var Message: TWMNCDestroy); message WM_NCDESTROY;
  1132.     procedure WMSetCursor(var Message: TWMSetCursor); message WM_SETCURSOR;
  1133.     procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
  1134.     procedure WMSetFont(var Message: TWMSetFont); message WM_SETFONT;
  1135.   protected
  1136.     procedure CreateParams(var Params: TCreateParams); override;
  1137.     procedure CreateWnd; override;
  1138.     procedure DestroyWnd; override;
  1139.     procedure RequestSize(const Rect: TRect); virtual;
  1140.     procedure SelectionChange; dynamic;
  1141.     procedure DoSetMaxLength(Value: Integer); override;
  1142.     function GetSelLength: Integer; override;
  1143.     function GetSelStart: Integer; override;
  1144.     function GetSelText: string; override;
  1145.     procedure SetSelLength(Value: Integer); override;
  1146.     procedure SetSelStart(Value: Integer); override;
  1147.     property HideSelection: Boolean read FHideSelection write SetHideSelection default True;
  1148.     property HideScrollBars: Boolean read FHideScrollBars
  1149.       write SetHideScrollBars default True;
  1150.     property Lines: TStrings read FRichEditStrings write SetRichEditStrings;
  1151.     property OnSaveClipboard: TRichEditSaveClipboard read FOnSaveClipboard
  1152.       write FOnSaveClipboard;
  1153.     property OnSelectionChange: TNotifyEvent read FOnSelChange write FOnSelChange;
  1154.     property OnProtectChange: TRichEditProtectChange read FOnProtectChange
  1155.       write FOnProtectChange;
  1156.     property OnResizeRequest: TRichEditResizeEvent read FOnResizeRequest
  1157.       write FOnResizeRequest;
  1158.     property PlainText: Boolean read GetPlainText write SetPlainText default False;
  1159.   public
  1160.     constructor Create(AOwner: TComponent); override;
  1161.     destructor Destroy; override;
  1162.     procedure Clear; override;
  1163.     function FindText(const SearchStr: string;
  1164.       StartPos, Length: Integer; Options: TSearchTypes): Integer;
  1165.     function GetSelTextBuf(Buffer: PChar; BufSize: Integer): Integer; override;
  1166.     procedure Print(const Caption: string);
  1167.     class procedure RegisterConversionFormat(const AExtension: string;
  1168.       AConversionClass: TConversionClass);
  1169.     property DefaultConverter: TConversionClass
  1170.       read FDefaultConverter write FDefaultConverter;
  1171.     property DefAttributes: TTextAttributes read FDefAttributes write SetDefAttributes;
  1172.     property SelAttributes: TTextAttributes read FSelAttributes write SetSelAttributes;
  1173.     property PageRect: TRect read FPageRect write FPageRect;
  1174.     property Paragraph: TParaAttributes read FParagraph;
  1175.   end;
  1176.  
  1177.   TRichEdit = class(TCustomRichEdit)
  1178.   published
  1179.     property Align;
  1180.     property Alignment;
  1181.     property BorderStyle;
  1182.     property Color;
  1183.     property Ctl3D;
  1184.     property DragCursor;
  1185.     property DragMode;
  1186.     property Enabled;
  1187.     property Font;
  1188.     property HideSelection;
  1189.     property HideScrollBars;
  1190.     property ImeMode;
  1191.     property ImeName;
  1192.     property Lines;
  1193.     property MaxLength;
  1194.     property ParentColor;
  1195.     property ParentCtl3D;
  1196.     property ParentFont;
  1197.     property ParentShowHint;
  1198.     property PlainText;
  1199.     property PopupMenu;
  1200.     property ReadOnly;
  1201.     property ScrollBars;
  1202.     property ShowHint;
  1203.     property TabOrder;
  1204.     property TabStop default True;
  1205.     property Visible;
  1206.     property WantTabs;
  1207.     property WantReturns;
  1208.     property WordWrap;
  1209.     property OnChange;
  1210.     property OnDragDrop;
  1211.     property OnDragOver;
  1212.     property OnEndDrag;
  1213.     property OnEnter;
  1214.     property OnExit;
  1215.     property OnKeyDown;
  1216.     property OnKeyPress;
  1217.     property OnKeyUp;
  1218.     property OnMouseDown;
  1219.     property OnMouseMove;
  1220.     property OnMouseUp;
  1221.     property OnResizeRequest;
  1222.     property OnSelectionChange;
  1223.     property OnStartDrag;
  1224.     property OnProtectChange;
  1225.     property OnSaveClipboard;
  1226.   end;
  1227.  
  1228. { TUpDown }
  1229.  
  1230.   TUDAlignButton = (udLeft, udRight);
  1231.   TUDOrientation = (udHorizontal, udVertical);
  1232.   TUDBtnType = (btNext, btPrev);
  1233.   TUDClickEvent = procedure (Sender: TObject; Button: TUDBtnType) of object;
  1234.   TUDChangingEvent = procedure (Sender: TObject; var AllowChange: Boolean) of object;
  1235.  
  1236.   TCustomUpDown = class(TWinControl)
  1237.   private
  1238.     FArrowKeys: Boolean;
  1239.     FAssociate: TWinControl;
  1240.     FMin: SmallInt;
  1241.     FMax: SmallInt;
  1242.     FIncrement: Integer;
  1243.     FPosition: SmallInt;
  1244.     FThousands: Boolean;
  1245.     FWrap: Boolean;
  1246.     FOnClick: TUDClickEvent;
  1247.     FAlignButton: TUDAlignButton;
  1248.     FOrientation: TUDOrientation;
  1249.     FOnChanging: TUDChangingEvent;
  1250.     procedure UndoAutoResizing(Value: TWinControl);
  1251.     procedure SetAssociate(Value: TWinControl);
  1252.     function GetPosition: SmallInt;
  1253.     procedure SetMin(Value: SmallInt);
  1254.     procedure SetMax(Value: SmallInt);
  1255.     procedure SetIncrement(Value: Integer);
  1256.     procedure SetPosition(Value: SmallInt);
  1257.     procedure SetAlignButton(Value: TUDAlignButton);
  1258.     procedure SetOrientation(Value: TUDOrientation);
  1259.     procedure SetArrowKeys(Value: Boolean);
  1260.     procedure SetThousands(Value: Boolean);
  1261.     procedure SetWrap(Value: Boolean);
  1262.     procedure CNNotify(var Message: TWMNotify); message CN_NOTIFY;
  1263.     procedure WMHScroll(var Message: TWMHScroll); message CN_HSCROLL;
  1264.     procedure WMSize(var Message: TWMSize); message WM_SIZE;
  1265.     procedure WMVScroll(var Message: TWMVScroll); message CN_VSCROLL;
  1266.   protected
  1267.     function CanChange: Boolean;
  1268.     procedure CreateParams(var Params: TCreateParams); override;
  1269.     procedure CreateWnd; override;
  1270.     procedure Notification(AComponent: TComponent; Operation: TOperation); override;
  1271.     procedure Click(Button: TUDBtnType); dynamic;
  1272.     property AlignButton: TUDAlignButton read FAlignButton write SetAlignButton default udRight;
  1273.     property ArrowKeys: Boolean read FArrowKeys write SetArrowKeys default True;
  1274.     property Associate: TWinControl read FAssociate write SetAssociate;
  1275.     property Min: SmallInt read FMin write SetMin;
  1276.     property Max: SmallInt read FMax write SetMax default 100;
  1277.     property Increment: Integer read FIncrement write SetIncrement default 1;
  1278.     property Orientation: TUDOrientation read FOrientation write SetOrientation default udVertical;
  1279.     property Position: SmallInt read GetPosition write SetPosition;
  1280.     property Thousands: Boolean read FThousands write SetThousands default True;
  1281.     property Wrap: Boolean read FWrap write SetWrap;
  1282.     property OnChanging: TUDChangingEvent read FOnChanging write FOnChanging;
  1283.     property OnClick: TUDClickEvent read FOnClick write FOnClick;
  1284.   public
  1285.     constructor Create(AOwner: TComponent); override;
  1286.   end;
  1287.  
  1288.   TUpDown = class(TCustomUpDown)
  1289.   published
  1290.     property AlignButton;
  1291.     property Associate;
  1292.     property ArrowKeys;
  1293.     property Enabled;
  1294.     property Hint;
  1295.     property Min;
  1296.     property Max;
  1297.     property Increment;
  1298.     property Orientation;
  1299.     property ParentShowHint;
  1300.     property PopupMenu;
  1301.     property Position;
  1302.     property ShowHint;
  1303.     property TabOrder;
  1304.     property TabStop;
  1305.     property Thousands;
  1306.     property Visible;
  1307.     property Wrap;
  1308.     property OnChanging;
  1309.     property OnClick;
  1310.     property OnEnter;
  1311.     property OnExit;
  1312.     property OnMouseDown;
  1313.     property OnMouseMove;
  1314.     property OnMouseUp;
  1315.   end;
  1316.  
  1317. { THotKey }
  1318.  
  1319.   THKModifier = (hkShift, hkCtrl, hkAlt, hkExt);
  1320.   THKModifiers = set of THKModifier;
  1321.   THKInvalidKey = (hcNone, hcShift, hcCtrl, hcAlt, hcShiftCtrl,
  1322.     hcShiftAlt, hcCtrlAlt, hcShiftCtrlAlt);
  1323.   THKInvalidKeys = set of THKInvalidKey;
  1324.  
  1325.   TCustomHotKey = class(TWinControl)
  1326.   private
  1327.     FAutoSize: Boolean;
  1328.     FModifiers: THKModifiers;
  1329.     FInvalidKeys: THKInvalidKeys;
  1330.     FHotKey: Word;
  1331.     procedure AdjustHeight;
  1332.     procedure SetAutoSize(Value: Boolean);
  1333.     procedure SetInvalidKeys(Value: THKInvalidKeys);
  1334.     procedure SetModifiers(Value: THKModifiers);
  1335.     procedure UpdateHeight;
  1336.     function GetHotKey: TShortCut;
  1337.     procedure SetHotKey(Value: TShortCut);
  1338.     procedure ShortCutToHotKey(Value: TShortCut);
  1339.     function HotKeyToShortCut(Value: Longint): TShortCut;
  1340.   protected
  1341.     procedure CreateParams(var Params: TCreateParams); override;
  1342.     procedure CreateWnd; override;
  1343.     property AutoSize: Boolean read FAutoSize write SetAutoSize default True;
  1344.     property InvalidKeys: THKInvalidKeys read FInvalidKeys write SetInvalidKeys;
  1345.     property Modifiers: THKModifiers read FModifiers write SetModifiers;
  1346.     property HotKey: TShortCut read GetHotKey write SetHotKey;
  1347.     property TabStop default True;
  1348.   public
  1349.     constructor Create(AOwner: TComponent); override;
  1350.   end;
  1351.  
  1352.   THotKey = class(TCustomHotKey)
  1353.   published
  1354.     property AutoSize;
  1355.     property Enabled;
  1356.     property Hint;
  1357.     property HotKey;
  1358.     property InvalidKeys;
  1359.     property Modifiers;
  1360.     property ParentShowHint;
  1361.     property PopupMenu;
  1362.     property ShowHint;
  1363.     property TabOrder;
  1364.     property TabStop;
  1365.     property Visible;
  1366.     property OnEnter;
  1367.     property OnExit;
  1368.     property OnMouseDown;
  1369.     property OnMouseMove;
  1370.     property OnMouseUp;
  1371.   end;
  1372.  
  1373. const
  1374.   ColumnHeaderWidth = LVSCW_AUTOSIZE_USEHEADER;
  1375.   ColumnTextWidth = LVSCW_AUTOSIZE;
  1376.  
  1377. type
  1378.   TListColumns = class;
  1379.   TListItems = class;
  1380.   TCustomListView = class;
  1381.   TWidth = ColumnHeaderWidth..MaxInt;
  1382.  
  1383.   TListColumn = class(TCollectionItem)
  1384.   private
  1385.     FCaption: string;
  1386.     FAlignment: TAlignment;
  1387.     FWidth: TWidth;
  1388.     FPrivateWidth: TWidth;
  1389.     procedure DoChange;
  1390.     function GetWidth: TWidth;
  1391.     procedure ReadData(Reader: TReader);
  1392.     procedure SetAlignment(Value: TAlignment);
  1393.     procedure SetCaption(const Value: string);
  1394.     procedure SetWidth(Value: TWidth);
  1395.     procedure WriteData(Writer: TWriter);
  1396.   protected
  1397.     procedure DefineProperties(Filer: TFiler); override;
  1398.     function GetDisplayName: string; override;
  1399.   public
  1400.     constructor Create(Collection: TCollection); override;
  1401.     destructor Destroy; override;
  1402.     procedure Assign(Source: TPersistent); override;
  1403.     property WidthType: TWidth read FWidth;
  1404.   published
  1405.     property Alignment: TAlignment read FAlignment write SetAlignment default taLeftJustify;
  1406.     property Caption: string read FCaption write SetCaption;
  1407.     property Width: TWidth read GetWidth write SetWidth default 50;
  1408.   end;
  1409.  
  1410.   TListColumns = class(TCollection)
  1411.   private
  1412.     FOwner: TCustomListView;
  1413.     function GetItem(Index: Integer): TListColumn;
  1414.     procedure SetItem(Index: Integer; Value: TListColumn);
  1415.   protected
  1416.     function GetOwner: TPersistent; override;
  1417.     procedure Update(Item: TCollectionItem); override;
  1418.   public
  1419.     constructor Create(AOwner: TCustomListView);
  1420.     function Add: TListColumn;
  1421.     property Owner: TCustomListView read FOwner;
  1422.     property Items[Index: Integer]: TListColumn read GetItem write SetItem; default;
  1423.   end;
  1424.  
  1425.   TDisplayCode = (drBounds, drIcon, drLabel, drSelectBounds);
  1426.  
  1427.   { TListItem }
  1428.  
  1429.   TListItem = class(TPersistent)
  1430.   private
  1431.     FOwner: TListItems;
  1432.     FSubItems: TStrings;
  1433.     FData: Pointer;
  1434.     FImageIndex: Integer;
  1435.     FOverlayIndex: Integer;
  1436.     FStateIndex: Integer;
  1437.     FCaption: string;
  1438.     FDeleting: Boolean;
  1439.     FProcessedDeleting: Boolean;
  1440.     FChecked: Boolean;
  1441.     function GetChecked: Boolean;
  1442.     function GetHandle: HWND;
  1443.     function GetIndex: Integer;
  1444.     function GetListView: TCustomListView;
  1445.     function GetLeft: Integer;
  1446.     function GetState(Index: Integer): Boolean;
  1447.     function GetTop: Integer;
  1448.     function IsEqual(Item: TListItem): Boolean;
  1449.     procedure SetChecked(Value: Boolean);
  1450.     procedure SetCaption(const Value: string);
  1451.     procedure SetData(Value: Pointer);
  1452.     procedure SetImage(Index: Integer; Value: Integer);
  1453.     procedure SetLeft(Value: Integer);
  1454.     procedure SetState(Index: Integer; State: Boolean);
  1455.     procedure SetSubItems(Value: TStrings);
  1456.     procedure SetTop(Value: Integer);
  1457.   protected
  1458.     procedure Assign(Source: TPersistent); override;
  1459.   public
  1460.     constructor Create(AOwner: TListItems);
  1461.     destructor Destroy; override;
  1462.     procedure CancelEdit;
  1463.     procedure Delete;
  1464.     function DisplayRect(Code: TDisplayCode): TRect;
  1465.     function EditCaption: Boolean;
  1466.     function GetPosition: TPoint;
  1467.     procedure MakeVisible(PartialOK: Boolean);
  1468.     procedure Update;
  1469.     procedure SetPosition(const Value: TPoint);
  1470.     property Caption: string read FCaption write SetCaption;
  1471.     property Checked: Boolean read GetChecked write SetChecked;
  1472.     property Cut: Boolean index 0 read GetState write SetState;
  1473.     property Data: Pointer read FData write SetData;
  1474.     property DropTarget: Boolean index 1 read GetState write SetState;
  1475.     property Focused: Boolean index 2 read GetState write SetState;
  1476.     property Handle: HWND read GetHandle;
  1477.     property ImageIndex: Integer index 0 read FImageIndex write SetImage;
  1478.     property Index: Integer read GetIndex;
  1479.     property Left: Integer read GetLeft write SetLeft;
  1480.     property ListView: TCustomListView read GetListView;
  1481.     property Owner: TListItems read FOwner;
  1482.     property OverlayIndex: Integer index 1 read FOverlayIndex write SetImage;
  1483.     property Selected: Boolean index 3 read GetState write SetState;
  1484.     property StateIndex: Integer index 2 read FStateIndex write SetImage;
  1485.     property SubItems: TStrings read FSubItems write SetSubItems;
  1486.     property Top: Integer read GetTop write SetTop;
  1487.   end;
  1488.  
  1489. { TListItems }
  1490.  
  1491.   TListItems = class(TPersistent)
  1492.   private
  1493.     FOwner: TCustomListView;
  1494.     FUpdateCount: Integer;
  1495.     FNoRedraw: Boolean;
  1496.     procedure ReadData(Stream: TStream);
  1497.     procedure WriteData(Stream: TStream);
  1498.   protected
  1499.     procedure DefineProperties(Filer: TFiler); override;
  1500.     function CreateItem(Index: Integer; ListItem: TListItem): TLVItem;
  1501.     function GetCount: Integer;
  1502.     function GetHandle: HWND;
  1503.     function GetItem(Index: Integer): TListItem;
  1504.     procedure SetItem(Index: Integer; Value: TListItem);
  1505.     procedure SetUpdateState(Updating: Boolean);
  1506.   public
  1507.     constructor Create(AOwner: TCustomListView);
  1508.     destructor Destroy; override;
  1509.     function Add: TListItem;
  1510.     procedure Assign(Source: TPersistent); override;
  1511.     procedure BeginUpdate;
  1512.     procedure Clear;
  1513.     procedure Delete(Index: Integer);
  1514.     procedure EndUpdate;
  1515.     function IndexOf(Value: TListItem): Integer;
  1516.     function Insert(Index: Integer): TListItem;
  1517.     property Count: Integer read GetCount;
  1518.     property Handle: HWND read GetHandle;
  1519.     property Item[Index: Integer]: TListItem read GetItem write SetItem; default;
  1520.     property Owner: TCustomListView read FOwner;
  1521.   end;
  1522.  
  1523. { TIconOptions }
  1524.  
  1525.   TIconArrangement = (iaTop, iaLeft);
  1526.  
  1527.   TIconOptions = class(TPersistent)
  1528.   private
  1529.     FListView: TCustomListView;
  1530.     FArrangement: TIconArrangement;
  1531.     FAutoArrange: Boolean;
  1532.     FWrapText: Boolean;
  1533.     procedure SetArrangement(Value: TIconArrangement);
  1534.     procedure SetAutoArrange(Value: Boolean);
  1535.     procedure SetWrapText(Value: Boolean);
  1536.   public
  1537.     constructor Create(AOwner: TCustomListView);
  1538.   published
  1539.     property Arrangement: TIconArrangement read FArrangement write SetArrangement default iaTop;
  1540.     property AutoArrange: Boolean read FAutoArrange write SetAutoArrange default False;
  1541.     property WrapText: Boolean read FWrapText write SetWrapText default True;
  1542.   end;
  1543.  
  1544.   TListArrangement = (arAlignBottom, arAlignLeft, arAlignRight,
  1545.     arAlignTop, arDefault, arSnapToGrid);
  1546.   TViewStyle = (vsIcon, vsSmallIcon, vsList, vsReport);
  1547.   TItemState = (isNone, isCut, isDropHilited, isFocused, isSelected);
  1548.   TItemStates = set of TItemState;
  1549.   TItemChange = (ctText, ctImage, ctState);
  1550.   TLVDeletedEvent = procedure(Sender: TObject; Item: TListItem) of object;
  1551.   TLVEditingEvent = procedure(Sender: TObject; Item: TListItem;
  1552.     var AllowEdit: Boolean) of object;
  1553.   TLVEditedEvent = procedure(Sender: TObject; Item: TListItem; var S: string) of object;
  1554.   TLVChangeEvent = procedure(Sender: TObject; Item: TListItem;
  1555.     Change: TItemChange) of object;
  1556.   TLVChangingEvent = procedure(Sender: TObject; Item: TListItem;
  1557.     Change: TItemChange; var AllowChange: Boolean) of object;
  1558.   TLVColumnClickEvent = procedure(Sender: TObject; Column: TListColumn) of object;
  1559.   TLVCompareEvent = procedure(Sender: TObject; Item1, Item2: TListItem;
  1560.     Data: Integer; var Compare: Integer) of object;
  1561.   TSearchDirection = (sdLeft, sdRight, sdAbove, sdBelow, sdAll);
  1562.  
  1563. { TCustomListView }
  1564.  
  1565.   TCustomListView = class(TWinControl)
  1566.   private
  1567.     FBorderStyle: TBorderStyle;
  1568.     FViewStyle: TViewStyle;
  1569.     FReadOnly: Boolean;
  1570.     FLargeImages: TImageList;
  1571.     FSmallImages: TImageList;
  1572.     FStateImages: TImageList;
  1573.     FDragImage: TImageList;
  1574.     FMultiSelect: Boolean;
  1575.     FSortType: TSortType;
  1576.     FColumnClick: Boolean;
  1577.     FShowColumnHeaders: Boolean;
  1578.     FListItems: TListItems;
  1579.     FClicked: Boolean;
  1580.     FRClicked: Boolean;
  1581.     FIconOptions: TIconOptions;
  1582.     FHideSelection: Boolean;
  1583.     FListColumns: TListColumns;
  1584.     FMemStream: TMemoryStream;
  1585.     FColStream: TMemoryStream;
  1586.     FCheckStream: TMemoryStream;
  1587.     FEditInstance: Pointer;
  1588.     FDefEditProc: Pointer;
  1589.     FEditHandle: HWND;
  1590.     FHeaderInstance: Pointer;
  1591.     FDefHeaderProc: Pointer;
  1592.     FHeaderHandle: HWND;
  1593.     FAllocBy: Integer;
  1594.     FDragIndex: Integer;
  1595.     FLastDropTarget: TListItem;
  1596.     FCheckboxes: Boolean;
  1597.     FGridLines: Boolean;
  1598.     FHotTrack: Boolean;
  1599.     FRowSelect: Boolean;
  1600.     FLargeChangeLink: TChangeLink;
  1601.     FSmallChangeLink: TChangeLink;
  1602.     FStateChangeLink: TChangeLink;
  1603.     FSavedSort: TSortType;
  1604.     FReading: Boolean;
  1605.     FOnChange: TLVChangeEvent;
  1606.     FOnChanging: TLVChangingEvent;
  1607.     FOnColumnClick: TLVColumnClickEvent;
  1608.     FOnDeletion: TLVDeletedEvent;
  1609.     FOnEditing: TLVEditingEvent;
  1610.     FOnEdited: TLVEditedEvent;
  1611.     FOnInsert: TLVDeletedEvent;
  1612.     FOnCompare: TLVCompareEvent;
  1613.     procedure CMColorChanged(var Message: TMessage); message CM_COLORCHANGED;
  1614.     procedure CMCtl3DChanged(var Message: TMessage); message CM_CTL3DCHANGED;
  1615.     procedure CMDrag(var Message: TCMDrag); message CM_DRAG;
  1616.     procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
  1617.     procedure CNNotify(var Message: TWMNotify); message CN_NOTIFY;
  1618.     procedure DoDragOver(Source: TDragObject; X, Y: Integer; CanDrop: Boolean);
  1619.     procedure EditWndProc(var Message: TMessage);
  1620.     function GetBoundingRect: TRect;
  1621.     function GetColumnFromIndex(Index: Integer): TListColumn;
  1622.     function GetDropTarget: TListItem;
  1623.     function GetFocused: TListItem;
  1624.     function GetItem(Value: TLVItem): TListItem;
  1625.     function GetSelCount: Integer;
  1626.     function GetSelection: TListItem;
  1627.     function GetTopItem: TListItem;
  1628.     function GetViewOrigin: TPoint;
  1629.     function GetVisibleRowCount: Integer;
  1630.     procedure HeaderWndProc(var Message: TMessage);
  1631.     procedure ImageListChange(Sender: TObject);
  1632.     procedure RestoreChecks;
  1633.     procedure SaveChecks;
  1634.     procedure SetBorderStyle(Value: TBorderStyle);
  1635.     procedure SetColumnClick(Value: Boolean);
  1636.     procedure SetColumnHeaders(Value: Boolean);
  1637.     procedure SetDropTarget(Value: TListItem);
  1638.     procedure SetFocused(Value: TListItem);
  1639.     procedure SetHideSelection(Value: Boolean);
  1640.     procedure SetIconOptions(Value: TIconOptions);
  1641.     procedure SetImageList(Value: HImageList; Flags: Integer);
  1642.     procedure SetLargeImages(Value: TImageList);
  1643.     procedure SetAllocBy(Value: Integer);
  1644.     procedure SetItems(Value: TListItems);
  1645.     procedure SetListColumns(Value: TListColumns);
  1646.     procedure SetMultiSelect(Value: Boolean);
  1647.     procedure SetReadOnly(Value: Boolean);
  1648.     procedure SetSmallImages(Value: TImageList);
  1649.     procedure SetSortType(Value: TSortType);
  1650.     procedure SetSelection(Value: TListItem);
  1651.     procedure SetStateImages(Value: TImageList);
  1652.     procedure SetTextBkColor(Value: TColor);
  1653.     procedure SetTextColor(Value: TColor);
  1654.     procedure SetViewStyle(Value: TViewStyle);
  1655.     procedure SetCheckboxes(Value: Boolean);
  1656.     procedure SetGridLines(Value: Boolean);
  1657.     procedure SetHotTrack(Value: Boolean);
  1658.     procedure SetRowSelect(Value: Boolean);
  1659.     procedure ResetExStyles;
  1660.     function ValidHeaderHandle: Boolean;
  1661.     procedure WMLButtonDown(var Message: TWMLButtonDown); message WM_LBUTTONDOWN;
  1662.     procedure WMNotify(var Message: TWMNotify); message WM_NOTIFY;
  1663.     procedure WMParentNotify(var Message: TWMParentNotify); message WM_PARENTNOTIFY;
  1664.     procedure WMRButtonDown(var Message: TWMRButtonDown); message WM_RBUTTONDOWN;
  1665.   protected
  1666.     function CanChange(Item: TListItem; Change: Integer): Boolean; dynamic;
  1667.     function CanEdit(Item: TListItem): Boolean; dynamic;
  1668.     procedure Change(Item: TListItem; Change: Integer); dynamic;
  1669.     procedure ColClick(Column: TListColumn); dynamic;
  1670.     function ColumnsShowing: Boolean;
  1671.     function CreateListItem: TListItem; virtual;
  1672.     procedure CreateParams(var Params: TCreateParams); override;
  1673.     procedure CreateWnd; override;
  1674.     procedure Delete(Item: TListItem); dynamic;
  1675.     procedure DestroyWnd; override;
  1676.     procedure DoEndDrag(Target: TObject; X, Y: Integer); override;
  1677.     procedure DoStartDrag(var DragObject: TDragObject); override;
  1678.     procedure Edit(const Item: TLVItem); dynamic;
  1679.     function GetDragImages: TCustomImageList; override;
  1680.     function GetItemIndex(Value: TListItem): Integer;
  1681.     procedure InsertItem(Item: TListItem); dynamic;
  1682.     procedure Notification(AComponent: TComponent; Operation: TOperation); override;
  1683.     procedure UpdateColumn(Index: Integer);
  1684.     procedure UpdateColumns;
  1685.     procedure WndProc(var Message: TMessage); override;
  1686.     property BorderStyle: TBorderStyle read FBorderStyle write SetBorderStyle default bsSingle;
  1687.     property Columns: TListColumns read FListColumns write SetListColumns;
  1688.     property ColumnClick: Boolean read FColumnClick write SetColumnClick default True;
  1689.     property ReadOnly: Boolean read FReadOnly write SetReadOnly;
  1690.     property HideSelection: Boolean read FHideSelection write SetHideSelection default True;
  1691.     property IconOptions: TIconOptions read FIconOptions write SetIconOptions;
  1692.     property Items: TListItems read FListItems write SetItems;
  1693.     property AllocBy: Integer read FAllocBy write SetAllocBy default 0;
  1694.     property LargeImages: TImageList read FLargeImages write SetLargeImages;
  1695.     property MultiSelect: Boolean read FMultiSelect write SetMultiSelect default False;
  1696.     property OnChange: TLVChangeEvent read FOnChange write FOnChange;
  1697.     property OnChanging: TLVChangingEvent read FOnChanging write FOnChanging;
  1698.     property OnColumnClick: TLVColumnClickEvent read FOnColumnClick
  1699.       write FOnColumnClick;
  1700.     property OnCompare: TLVCompareEvent read FOnCompare write FOnCompare;
  1701.     property OnDeletion: TLVDeletedEvent read FOnDeletion write FOnDeletion;
  1702.     property OnEdited: TLVEditedEvent read FOnEdited write FOnEdited;
  1703.     property OnEditing: TLVEditingEvent read FOnEditing write FOnEditing;
  1704.     property OnInsert: TLVDeletedEvent read FOnInsert write FOnInsert;
  1705.     property ShowColumnHeaders: Boolean read FShowColumnHeaders write
  1706.       SetColumnHeaders default True;
  1707.     property SmallImages: TImageList read FSmallImages write SetSmallImages;
  1708.     property SortType: TSortType read FSortType write SetSortType default stNone;
  1709.     property StateImages: TImageList read FStateImages write SetStateImages;
  1710.     property ViewStyle: TViewStyle read FViewStyle write SetViewStyle default vsIcon;
  1711.   public
  1712.     constructor Create(AOwner: TComponent); override;
  1713.     destructor Destroy; override;
  1714.     function AlphaSort: Boolean;
  1715.     procedure Arrange(Code: TListArrangement);
  1716.     function FindCaption(StartIndex: Integer; Value: string;
  1717.       Partial, Inclusive, Wrap: Boolean): TListItem;
  1718.     function FindData(StartIndex: Integer; Value: Pointer;
  1719.       Inclusive, Wrap: Boolean): TListItem;
  1720.     function GetItemAt(X, Y: Integer): TListItem;
  1721.     function GetNearestItem(Point: TPoint;
  1722.       Direction: TSearchDirection): TListItem;
  1723.     function GetNextItem(StartItem: TListItem;
  1724.       Direction: TSearchDirection; States: TItemStates): TListItem;
  1725.     function GetSearchString: string;
  1726.     function IsEditing: Boolean;
  1727.     procedure Scroll(DX, DY: Integer);
  1728.     property Checkboxes: Boolean read FCheckboxes write SetCheckboxes default False;
  1729.     property Column[Index: Integer]: TListColumn read GetColumnFromIndex;
  1730.     property DropTarget: TListItem read GetDropTarget write SetDropTarget;
  1731.     property GridLines: Boolean read FGridLines write SetGridLines default False;
  1732.     property HotTrack: Boolean read FHotTrack write SetHotTrack default False;
  1733.     property ItemFocused: TListItem read GetFocused write SetFocused;
  1734.     property RowSelect: Boolean read FRowSelect write SetRowSelect default False;
  1735.     property SelCount: Integer read GetSelCount;
  1736.     property Selected: TListItem read GetSelection write SetSelection;
  1737.     function CustomSort(SortProc: TLVCompare; lParam: Longint): Boolean;
  1738.     function StringWidth(S: string): Integer;
  1739.     procedure UpdateItems(FirstIndex, LastIndex: Integer);
  1740.     property TopItem: TListItem read GetTopItem;
  1741.     property ViewOrigin: TPoint read GetViewOrigin;
  1742.     property VisibleRowCount: Integer read GetVisibleRowCount;
  1743.     property BoundingRect: TRect read GetBoundingRect;
  1744.   end;
  1745.  
  1746. { TListView }
  1747.  
  1748.   TListView = class(TCustomListView)
  1749.   published
  1750.     property Align;
  1751.     property BorderStyle;
  1752.     property Color;
  1753.     property ColumnClick;
  1754.     property OnClick;
  1755.     property OnDblClick;
  1756.     property Columns;
  1757.     property Ctl3D;
  1758.     property DragMode;
  1759.     property ReadOnly default False;
  1760.     property Enabled;
  1761.     property Font;
  1762.     property GridLines;
  1763.     property HideSelection;
  1764.     property HotTrack;
  1765.     property IconOptions;
  1766.     property Items;
  1767.     property Checkboxes;
  1768.     property AllocBy;
  1769.     property MultiSelect;
  1770.     property RowSelect;
  1771.     property OnChange;
  1772.     property OnChanging;
  1773.     property OnColumnClick;
  1774.     property OnCompare;
  1775.     property OnDeletion;
  1776.     property OnEdited;
  1777.     property OnEditing;
  1778.     property OnEnter;
  1779.     property OnExit;
  1780.     property OnInsert;
  1781.     property OnDragDrop;
  1782.     property OnDragOver;
  1783.     property DragCursor;
  1784.     property OnStartDrag;
  1785.     property OnEndDrag;
  1786.     property OnMouseDown;
  1787.     property OnMouseMove;
  1788.     property OnMouseUp;
  1789.     property ParentColor default False;
  1790.     property ParentFont;
  1791.     property ParentShowHint;
  1792.     property ShowHint;
  1793.     property PopupMenu;
  1794.     property ShowColumnHeaders;
  1795.     property SortType;
  1796.     property TabOrder;
  1797.     property TabStop default True;
  1798.     property ViewStyle;
  1799.     property Visible;
  1800.     property OnKeyDown;
  1801.     property OnKeyPress;
  1802.     property OnKeyUp;
  1803.     property LargeImages;
  1804.     property SmallImages;
  1805.     property StateImages;
  1806.   end;
  1807.  
  1808. { TAnimate }
  1809.  
  1810.   TCommonAVI = (aviNone, aviFindFolder, aviFindFile, aviFindComputer, aviCopyFiles,
  1811.     aviCopyFile, aviRecycleFile, aviEmptyRecycle, aviDeleteFile);
  1812.  
  1813.   TAnimate = class(TWinControl)
  1814.   private
  1815.     FActive: Boolean;
  1816.     FAutoSize: Boolean;
  1817.     FFileName: string;
  1818.     FCenter: Boolean;
  1819.     FCommonAVI: TCommonAVI;
  1820.     FFrameCount: Integer;
  1821.     FFrameHeight: Integer;
  1822.     FFrameWidth: Integer;
  1823.     FOpen: Boolean;
  1824.     FRecreateNeeded: Boolean;
  1825.     FRepetitions: Integer;
  1826.     FResHandle: THandle;
  1827.     FResId: Integer;
  1828.     FResName: string;
  1829.     FStreamedActive: Boolean;
  1830.     FTimers: Boolean;
  1831.     FTransparent: Boolean;
  1832.     FStartFrame: Smallint;
  1833.     FStopFrame: Smallint;
  1834.     FStopCount: Integer;
  1835.     FOnOpen: TNotifyEvent;
  1836.     FOnClose: TNotifyEvent;
  1837.     FOnStart: TNotifyEvent;
  1838.     FOnStop: TNotifyEvent;
  1839.     procedure AdjustSize;
  1840.     procedure CheckOpen;
  1841.     function InternalClose: Boolean;
  1842.     function InternalOpen: Boolean;
  1843.     procedure GetAnimateParams(var Params);
  1844.     function GetActualResHandle: THandle;
  1845.     function GetActualResId: Integer;
  1846.     procedure GetFrameInfo;
  1847.     procedure SetAnimateParams(const Params);
  1848.     procedure SetActive(Value: Boolean);
  1849.     procedure SetAutoSize(Value: Boolean);
  1850.     procedure SetFileName(Value: string);
  1851.     procedure SetCenter(Value: Boolean);
  1852.     procedure SetCommonAVI(Value: TCommonAVI);
  1853.     procedure SetOpen(Value: Boolean);
  1854.     procedure SetRepetitions(Value: Integer);
  1855.     procedure SetResHandle(Value: THandle);
  1856.     procedure SetResId(Value: Integer);
  1857.     procedure SetResName(Value: string);
  1858.     procedure SetTimers(Value: Boolean);
  1859.     procedure SetTransparent(Value: Boolean);
  1860.     procedure SetStartFrame(Value: Smallint);
  1861.     procedure SetStopFrame(Value: Smallint);
  1862.     procedure UpdateActiveState;
  1863.     procedure WMNCCalcSize(var Message: TWMNCCalcSize); message WM_NCCALCSIZE;
  1864.     procedure WMNCHitTest(var Message: TWMNCHitTest); message WM_NCHITTEST;
  1865.     procedure WMNCPaint(var Message: TMessage); message WM_NCPAINT;
  1866.     procedure WMSize(var Message: TWMSize); message WM_SIZE;
  1867.     procedure WMWindowPosChanged(var Message: TWMWindowPosChanged); message WM_WINDOWPOSCHANGED;
  1868.     procedure WMWindowPosChanging(var Message: TWMWindowPosChanging); message WM_WINDOWPOSCHANGING;
  1869.     procedure CMColorChanged(var Message: TMessage); message CM_COLORCHANGED;
  1870.     procedure CNCommand(var Message: TWMCommand); message CN_COMMAND;
  1871.   protected
  1872.     procedure CreateParams(var Params: TCreateParams); override;
  1873.     procedure CreateWnd; override;
  1874.     procedure DestroyWnd; override;
  1875.     procedure DoOpen; virtual;
  1876.     procedure DoClose; virtual;
  1877.     procedure DoStart; virtual;
  1878.     procedure DoStop; virtual;
  1879.     procedure Loaded; override;
  1880.   public
  1881.     constructor Create(AOwner: TComponent); override;
  1882.     property FrameCount: Integer read FFrameCount;
  1883.     property FrameHeight: Integer read FFrameHeight;
  1884.     property FrameWidth: Integer read FFrameWidth;
  1885.     property Open: Boolean read FOpen write SetOpen;
  1886.     procedure Play(FromFrame, ToFrame: Word; Count: Integer);
  1887.     procedure Reset;
  1888.     procedure Seek(Frame: Smallint);
  1889.     procedure Stop;
  1890.     property ResHandle: THandle read FResHandle write SetResHandle;
  1891.     property ResId: Integer read FResId write SetResId;
  1892.     property ResName: string read FResName write SetResName;
  1893.   published
  1894.     property Active: Boolean read FActive write SetActive;
  1895.     property AutoSize: Boolean read FAutoSize write SetAutoSize default True;
  1896.     property Align;
  1897.     property Center: Boolean read FCenter write SetCenter default True;
  1898.     property Color;
  1899.     property CommonAVI: TCommonAVI read FCommonAVI write SetCommonAVI default aviNone;
  1900.     property FileName: string read FFileName write SetFileName;
  1901.     property ParentColor;
  1902.     property ParentShowHint;
  1903.     property Repetitions: Integer read FRepetitions write SetRepetitions default 0;
  1904.     property ShowHint;
  1905.     property StartFrame: Smallint read FStartFrame write SetStartFrame default 1;
  1906.     property StopFrame: Smallint read FStopFrame write SetStopFrame default 0;
  1907.     property Timers: Boolean read FTimers write SetTimers default False;
  1908.     property Transparent: Boolean read FTransparent write SetTransparent default True;
  1909.     property Visible;
  1910.     property OnOpen: TNotifyEvent read FOnOpen write FOnOpen;
  1911.     property OnClose: TNotifyEvent read FOnClose write FOnClose;
  1912.     property OnStart: TNotifyEvent read FOnStart write FOnStart;
  1913.     property OnStop: TNotifyEvent read FOnStop write FOnStop;
  1914.   end;
  1915.  
  1916. { TToolBar }
  1917.  
  1918. const
  1919.   CN_REQUESTALIGN = WM_USER + $1000;
  1920.  
  1921. type
  1922.   TToolButtonStyle = (tbsButton, tbsCheck, tbsDropDown, tbsSeparator, tbsDivider);
  1923.  
  1924.   TToolButtonState = (tbsChecked, tbsPressed, tbsEnabled, tbsHidden,
  1925.     tbsIndeterminate, tbsWrap);
  1926.  
  1927.   TToolBar = class;
  1928.  
  1929.   TToolButton = class(TGraphicControl)
  1930.   private
  1931.     FAllowAllUp: Boolean;
  1932.     FDown: Boolean;
  1933.     FGrouped: Boolean;
  1934.     FImageIndex: Integer;
  1935.     FIndeterminate: Boolean;
  1936.     FDropdownMenu: TPopupMenu;
  1937.     FWrap: Boolean;
  1938.     FStreamedDown: Boolean;
  1939.     FStyle: TToolButtonStyle;
  1940.     FUpdateCount: Integer;
  1941.     function CheckMenuDropdown: Boolean;
  1942.     function GetButtonState: Byte;
  1943.     function GetIndex: Integer;
  1944.     procedure SetButtonState(State: Byte);
  1945.     procedure SetDown(Value: Boolean);
  1946.     procedure SetDropdownMenu(Value: TPopupMenu);
  1947.     procedure SetGrouped(Value: Boolean);
  1948.     procedure SetImageIndex(Value: Integer);
  1949.     procedure SetIndeterminate(Value: Boolean);
  1950.     procedure SetStyle(Value: TToolButtonStyle);
  1951.     procedure SetWrap(Value: Boolean);
  1952.     procedure CMEnabledChanged(var Message: TMessage); message CM_ENABLEDCHANGED;
  1953.     procedure CMTextChanged(var Message: TMessage); message CM_TEXTCHANGED;
  1954.     procedure CMVisibleChanged(var Message: TMessage); message CM_VISIBLECHANGED;
  1955.   protected
  1956.     FToolBar: TToolBar;
  1957.     procedure BeginUpdate; virtual;
  1958.     procedure EndUpdate; virtual;
  1959.     procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
  1960.     procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
  1961.     procedure MouseUp(Button: TMouseButton; Shift: TShiftState;
  1962.       X, Y: Integer); override;
  1963.     procedure Notification(AComponent: TComponent; Operation: TOperation); override;
  1964.     procedure Paint; override;
  1965.     procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override;
  1966.     procedure SetToolBar(AToolBar: TToolBar);
  1967.     procedure UpdateControl; virtual;
  1968.     property Index: Integer read GetIndex;
  1969.   public
  1970.     constructor Create(AOwner: TComponent); override;
  1971.     procedure Click; override;
  1972.   published
  1973.     property AllowAllUp: Boolean read FAllowAllUp write FAllowAllUp default False;
  1974.     property Caption;
  1975.     property Down: Boolean read FDown write SetDown default False;
  1976.     property DragCursor;
  1977.     property DragMode;
  1978.     property DropdownMenu: TPopupMenu read FDropdownMenu write SetDropdownMenu;
  1979.     property Enabled;
  1980.     property Grouped: Boolean read FGrouped write SetGrouped default False;
  1981.     property ImageIndex: Integer read FImageIndex write SetImageIndex;
  1982.     property Indeterminate: Boolean read FIndeterminate write SetIndeterminate default False;
  1983.     property ParentShowHint;
  1984.     property PopupMenu;
  1985.     property Wrap: Boolean read FWrap write SetWrap default False;
  1986.     property ShowHint;
  1987.     property Style: TToolButtonStyle read FStyle write SetStyle default tbsButton;
  1988.     property Visible;
  1989.     property OnClick;
  1990.     property OnDragDrop;
  1991.     property OnDragOver;
  1992.     property OnEndDrag;
  1993.     property OnMouseDown;
  1994.     property OnMouseMove;
  1995.     property OnMouseUp;
  1996.     property OnStartDrag;
  1997.   end;
  1998.  
  1999.   TToolBar = class(TToolWindow)
  2000.   private
  2001.     FAutoSize: Boolean;
  2002.     FButtonWidth: Integer;
  2003.     FButtonHeight: Integer;
  2004.     FButtons: TList;
  2005.     FShowCaptions: Boolean;
  2006.     FList: Boolean;
  2007.     FFlat: Boolean;
  2008.     FWrapable: Boolean;
  2009.     FImages: TImageList;
  2010.     FImageChangeLink: TChangeLink;
  2011.     FDisabledImages: TImageList;
  2012.     FDisabledImageChangeLink: TChangeLink;
  2013.     FHotImages: TImageList;
  2014.     FHotImageChangeLink: TChangeLink;
  2015.     FIndent: Integer;
  2016.     FNewStyle: Boolean;
  2017.     FNullBitmap: TBitmap;
  2018.     FOldHandle: HBitmap;
  2019.     FUpdateCount: Integer;
  2020.     FHeightMargin: Integer;
  2021.     FOnResize: TNotifyEvent;
  2022.     procedure AdjustSize;
  2023.     function ButtonIndex(OldIndex, ALeft, ATop: Integer): Integer;
  2024.     procedure LoadImages(AImages: TImageList);
  2025.     procedure SetAutoSize(Value: Boolean);
  2026.     function GetButton(Index: Integer): TToolButton;
  2027.     function GetButtonCount: Integer;
  2028.     procedure GetButtonSize(var AWidth, AHeight: Integer);
  2029.     function GetRowCount: Integer;
  2030.     procedure SetList(Value: Boolean);
  2031.     procedure SetShowCaptions(Value: Boolean);
  2032.     procedure SetFlat(Value: Boolean);
  2033.     procedure SetWrapable(Value: Boolean);
  2034.     procedure InsertButton(Control: TControl);
  2035.     procedure RemoveButton(Control: TControl);
  2036.     procedure UpdateButton(Index: Integer);
  2037.     procedure UpdateButtons;
  2038.     procedure UpdateButtonState(Index: Integer);
  2039.     procedure UpdateButtonStates;
  2040.     procedure UpdateItem(Message, FromIndex, ToIndex: Integer);
  2041.     procedure CreateButtons(NewWidth, NewHeight: Integer);
  2042.     procedure SetButtonWidth(Value: Integer);
  2043.     procedure SetButtonHeight(Value: Integer);
  2044.     procedure UpdateImages;
  2045.     procedure ImageListChange(Sender: TObject);
  2046.     procedure SetImageList(Value: HImageList);
  2047.     procedure SetImages(Value: TImageList);
  2048.     procedure DisabledImageListChange(Sender: TObject);
  2049.     procedure SetDisabledImageList(Value: HImageList);
  2050.     procedure SetDisabledImages(Value: TImageList);
  2051.     procedure HotImageListChange(Sender: TObject);
  2052.     procedure SetHotImageList(Value: HImageList);
  2053.     procedure SetHotImages(Value: TImageList);
  2054.     procedure SetIndent(Value: Integer);
  2055.     procedure AdjustControl(Control: TControl);
  2056.     procedure RecreateButtons;
  2057.     procedure BeginUpdate;
  2058.     procedure EndUpdate;
  2059.     procedure ResizeButtons;
  2060.     function InternalButtonCount: Integer;
  2061.     function ReorderButton(OldIndex, ALeft, ATop: Integer): Boolean;
  2062.     procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND;
  2063.     procedure WMNotifyFormat(var Message: TMessage); message WM_NOTIFYFORMAT;
  2064.     procedure WMSize(var Message: TWMSize); message WM_SIZE;
  2065.     procedure WMWindowPosChanged(var Message: TWMWindowPosChanged); message WM_WINDOWPOSCHANGED;
  2066.     procedure WMWindowPosChanging(var Message: TWMWindowPosChanging); message WM_WINDOWPOSCHANGING;
  2067.     procedure CMColorChanged(var Message: TMessage); message CM_COLORCHANGED;
  2068.     procedure CMControlChange(var Message: TCMControlChange); message CM_CONTROLCHANGE;
  2069.     procedure CMEnabledChanged(var Message: TMessage); message CM_ENABLEDCHANGED;
  2070.     procedure CMSysFontChanged(var Message: TMessage); message CM_SYSFONTCHANGED;
  2071.     procedure CNRequestAlign(var Message: TMessage); message CN_REQUESTALIGN;
  2072.   protected
  2073.     procedure AlignControls(AControl: TControl; var Rect: TRect); override;
  2074.     procedure CreateParams(var Params: TCreateParams); override;
  2075.     procedure CreateWnd; override;
  2076.     procedure GetChildren(Proc: TGetChildProc; Root: TComponent); override;
  2077.     procedure Loaded; override;
  2078.     procedure Notification(AComponent: TComponent;
  2079.       Operation: TOperation); override;
  2080.     procedure RepositionButton(Index: Integer);
  2081.     procedure RepositionButtons(Index: Integer);
  2082.     procedure Resize; dynamic;
  2083.     procedure WndProc(var Message: TMessage); override;
  2084.   public
  2085.     constructor Create(AOwner: TComponent); override;
  2086.     destructor Destroy; override;
  2087.     property ButtonCount: Integer read GetButtonCount;
  2088.     property Buttons[Index: Integer]: TToolButton read GetButton;
  2089.     property RowCount: Integer read GetRowCount;
  2090.   published
  2091.     property Align default alTop;
  2092.     property AutoSize: Boolean read FAutoSize write SetAutoSize default False;
  2093.     property BorderWidth;
  2094.     property ButtonHeight: Integer read FButtonHeight write SetButtonHeight default 22;
  2095.     property ButtonWidth: Integer read FButtonWidth write SetButtonWidth default 23;
  2096.     property Color;
  2097.     property Ctl3D;
  2098.     property DisabledImages: TImageList read FDisabledImages write SetDisabledImages;
  2099.     property DragCursor;
  2100.     property DragMode;
  2101.     property EdgeBorders default [ebTop];
  2102.     property EdgeInner;
  2103.     property EdgeOuter;
  2104.     property Enabled;
  2105.     property Flat: Boolean read FFlat write SetFlat default False;
  2106.     property Font;
  2107.     property Height default 32;
  2108.     property HotImages: TImageList read FHotImages write SetHotImages;
  2109.     property Images: TImageList read FImages write SetImages;
  2110.     property Indent: Integer read FIndent write SetIndent default 0;
  2111.     property List: Boolean read FList write SetList default False;
  2112.     property ParentColor;
  2113.     property ParentFont;
  2114.     property ParentShowHint;
  2115.     property PopupMenu;
  2116.     property ShowCaptions: Boolean read FShowCaptions write SetShowCaptions default False;
  2117.     property ShowHint;
  2118.     property TabOrder;
  2119.     property TabStop;
  2120.     property Visible;
  2121.     property Wrapable: Boolean read FWrapable write SetWrapable default True;
  2122.     property OnClick;
  2123.     property OnDblClick;
  2124.     property OnDragDrop;
  2125.     property OnDragOver;
  2126.     property OnEndDrag;
  2127.     property OnEnter;
  2128.     property OnExit;
  2129.     property OnMouseDown;
  2130.     property OnMouseMove;
  2131.     property OnMouseUp;
  2132.     property OnResize: TNotifyEvent read FOnResize write FOnResize;
  2133.     property OnStartDrag;
  2134.  
  2135.   end;
  2136.  
  2137. { TCoolBar }
  2138.  
  2139. const
  2140.   CN_BANDCHANGE = WM_USER + $1000;
  2141.  
  2142. type
  2143.   TCoolBar = class;
  2144.  
  2145.   TCoolBand = class(TCollectionItem)
  2146.   private
  2147.     FBorderStyle: TBorderStyle;
  2148.     FBreak: Boolean;
  2149.     FFixedSize: Boolean;
  2150.     FVisible: Boolean;
  2151.     FHorizontalOnly: Boolean;
  2152.     FImageIndex: Integer;
  2153.     FFixedBackground: Boolean;
  2154.     FMinHeight: Integer;
  2155.     FMinWidth: Integer;
  2156.     FColor: TColor;
  2157.     FControl: TWinControl;
  2158.     FParentColor: Boolean;
  2159.     FParentBitmap: Boolean;
  2160.     FBitmap: TBitmap;
  2161.     FText: string;
  2162.     FWidth: Integer;
  2163.     FDDB: TBitmap;
  2164.     FID: Integer;
  2165.     function CoolBar: TCoolBar;
  2166.     function IsColorStored: Boolean;
  2167.     function IsBitmapStored: Boolean;
  2168.     procedure BitmapChanged(Sender: TObject);
  2169.     function GetHeight: Integer;
  2170.     function GetVisible: Boolean;
  2171.     procedure SetBorderStyle(Value: TBorderStyle);
  2172.     procedure SetBreak(Value: Boolean);
  2173.     procedure SetFixedSize(Value: Boolean);
  2174.     procedure SetMinHeight(Value: Integer);
  2175.     procedure SetMinWidth(Value: Integer);
  2176.     procedure SetVisible(Value: Boolean);
  2177.     procedure SetHorizontalOnly(Value: Boolean);
  2178.     procedure SetImageIndex(Value: Integer);
  2179.     procedure SetFixedBackground(Value: Boolean);
  2180.     procedure SetColor(Value: TColor);
  2181.     procedure SetControl(Value: TWinControl);
  2182.     procedure SetParentColor(Value: Boolean);
  2183.     procedure SetParentBitmap(Value: Boolean);
  2184.     procedure SetBitmap(Value: TBitmap);
  2185.     procedure SetText(const Value: string);
  2186.     procedure SetWidth(Value: Integer);
  2187.   protected
  2188.     function GetDisplayName: string; override;
  2189.     procedure ParentColorChanged; dynamic;
  2190.     procedure ParentBitmapChanged; dynamic;
  2191.   public
  2192.     constructor Create(Collection: TCollection); override;
  2193.     destructor Destroy; override;
  2194.     procedure Assign(Source: TPersistent); override;
  2195.     property BorderStyle: TBorderStyle read FBorderStyle write SetBorderStyle default bsSingle;
  2196.     property Height: Integer read GetHeight;
  2197.   published
  2198.     property Bitmap: TBitmap read FBitmap write SetBitmap stored IsBitmapStored;
  2199.     property Break: Boolean read FBreak write SetBreak default True;
  2200.     property Color: TColor read FColor write SetColor stored IsColorStored default clBtnFace;
  2201.     property Control: TWinControl read FControl write SetControl;
  2202.     property FixedBackground: Boolean read FFixedBackground write SetFixedBackground default True;
  2203.     property FixedSize: Boolean read FFixedSize write SetFixedSize default False;
  2204.     property HorizontalOnly: Boolean read FHorizontalOnly write SetHorizontalOnly default False;
  2205.     property ImageIndex: Integer read FImageIndex write SetImageIndex;
  2206.     property MinHeight: Integer read FMinHeight write SetMinHeight default 25;
  2207.     property MinWidth: Integer read FMinWidth write SetMinWidth default 0;
  2208.     property ParentColor: Boolean read FParentColor write SetParentColor default True;
  2209.     property ParentBitmap: Boolean read FParentBitmap write SetParentBitmap default True;
  2210.     property Text: string read FText write SetText;
  2211.     property Visible: Boolean read GetVisible write SetVisible default True;
  2212.     property Width: Integer read FWidth write SetWidth;
  2213.   end;
  2214.  
  2215.   TCoolBands = class(TCollection)
  2216.   private
  2217.     FCoolBar: TCoolBar;
  2218.     FVisibleCount: Integer;
  2219.     function GetItem(Index: Integer): TCoolBand;
  2220.     procedure SetItem(Index: Integer; Value: TCoolBand);
  2221.   protected
  2222.     function GetOwner: TPersistent; override;
  2223.     procedure Update(Item: TCollectionItem); override;
  2224.     function FindBand(AControl: TControl): TCoolBand;
  2225.     function HaveGraphic: Boolean;
  2226.   public
  2227.     constructor Create(CoolBar: TCoolBar);
  2228.     function Add: TCoolBand;
  2229.     property CoolBar: TCoolBar read FCoolBar;
  2230.     property Items[Index: Integer]: TCoolBand read GetItem write SetItem; default;
  2231.   end;
  2232.  
  2233.   TCoolBar = class(TToolWindow)
  2234.   private
  2235.     FAutoSize: Boolean;
  2236.     FBands: TCoolBands;
  2237.     FBandBorderStyle: TBorderStyle;
  2238.     FBitmap: TBitmap;
  2239.     FCaptionFont: TFont;
  2240.     FCaptionFontHeight: Integer;
  2241.     FDDB: TBitmap;
  2242.     FFixedSize: Boolean;
  2243.     FFixedOrder: Boolean;
  2244.     FImages: TImageList;
  2245.     FImageChangeLink: TChangeLink;
  2246.     FShowText: Boolean;
  2247.     FVertical: Boolean;
  2248.     FTrackDrag: TSmallPoint;
  2249.     FUpdateCount: Integer;
  2250.     FOnChange: TNotifyEvent;
  2251.     FOnResize: TNotifyEvent;
  2252.     procedure AdjustSize;
  2253.     procedure BeginUpdate;
  2254.     procedure BitmapChanged(Sender: TObject);
  2255.     procedure DisableBands;
  2256.     procedure EndUpdate;
  2257.     function IsAutoSized: Boolean;
  2258.     function IsBackgroundDirty: Boolean;
  2259.     function GetAlign: TAlign;
  2260.     function GetCaptionFont: HFONT;
  2261.     function GetCaptionFontHeight: Integer;
  2262.     function GetCaptionSize(Band: TCoolBand): Integer;
  2263.     function GetRowHeight(Index: Integer): Integer;
  2264.     procedure SetAlign(Value: TAlign);
  2265.     procedure SetAutoSize(Value: Boolean);
  2266.     procedure SetBands(Value: TCoolBands);
  2267.     procedure SetBandBorderStyle(Value: TBorderStyle);
  2268.     procedure SetBitmap(Value: TBitmap);
  2269.     procedure SetFixedSize(Value: Boolean);
  2270.     procedure SetFixedOrder(Value: Boolean);
  2271.     procedure SetImageList(Value: HImageList);
  2272.     procedure SetImages(Value: TImageList);
  2273.     procedure SetShowText(Value: Boolean);
  2274.     procedure SetVertical(Value: Boolean);
  2275.     procedure ImageListChange(Sender: TObject);
  2276.     function PtInGripRect(const Pos: TPoint): Integer;
  2277.     function ReadBands: Boolean;
  2278.     function UpdateItem(Message, FromIndex, ToIndex: Integer): Boolean;
  2279.     procedure UpdateBand(Index: Integer);
  2280.     procedure UpdateBands;
  2281.     procedure WMCaptureChanged(var Message: TMessage); message WM_CAPTURECHANGED;
  2282.     procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND;
  2283.     procedure WMLButtonDown(var Message: TWMLButtonDown); message WM_LBUTTONDOWN;
  2284.     procedure WMLButtonUp(var Message: TWMLButtonUp); message WM_LBUTTONUP;
  2285.     procedure WMNotifyFormat(var Message: TMessage); message WM_NOTIFYFORMAT;
  2286.     procedure WMSetCursor(var Message: TWMSetCursor); message WM_SETCURSOR;
  2287.     procedure WMSize(var Message: TWMSize); message WM_SIZE;
  2288.     procedure WMWindowPosChanged(var Message: TWMWindowPosChanged); message WM_WINDOWPOSCHANGED;
  2289.     procedure CMColorChanged(var Message: TMessage); message CM_COLORCHANGED;
  2290.     procedure CMControlChange(var Message: TCMControlChange); message CM_CONTROLCHANGE;
  2291.     procedure CMDesignHitTest(var Message: TCMDesignHitTest); message CM_DESIGNHITTEST;
  2292.     procedure CNBandChange(var Message: TMessage); message CN_BANDCHANGE;
  2293.     procedure CNNotify(var Message: TWMNotify); message CN_NOTIFY;
  2294.     procedure CMSysColorChange(var Message: TMessage); message CM_SYSCOLORCHANGE;
  2295.     procedure CMSysFontChanged(var Message: TMessage); message CM_SYSFONTCHANGED;
  2296.     procedure CMWinIniChange(var Message: TWMWinIniChange); message CM_WININICHANGE;
  2297.   protected
  2298.     procedure AlignControls(AControl: TControl; var Rect: TRect); override;
  2299.     procedure Change; dynamic;
  2300.     procedure CreateParams(var Params: TCreateParams); override;
  2301.     procedure CreateWnd; override;
  2302.     function GetPalette: HPALETTE; override;
  2303.     procedure Loaded; override;
  2304.     procedure Notification(AComponent: TComponent; Operation: TOperation); override;
  2305.     procedure Resize; dynamic;
  2306.     procedure WndProc(var Message: TMessage); override;
  2307.   public
  2308.     constructor Create(AOwner: TComponent); override;
  2309.     destructor Destroy; override;
  2310.   published
  2311.     property Align read GetAlign write SetAlign default alTop;
  2312.     property AutoSize: Boolean read FAutoSize write SetAutoSize default False;
  2313.     property BandBorderStyle: TBorderStyle read FBandBorderStyle write SetBandBorderStyle default bsSingle;
  2314.     property Bands: TCoolBands read FBands write SetBands;
  2315.     property BorderWidth;
  2316.     property Color;
  2317.     property Ctl3D;
  2318.     property DragCursor;
  2319.     property DragMode;
  2320.     property EdgeBorders;
  2321.     property EdgeInner;
  2322.     property EdgeOuter;
  2323.     property Enabled;
  2324.     property FixedSize: Boolean read FFixedSize write SetFixedSize default False;
  2325.     property FixedOrder: Boolean read FFixedOrder write SetFixedOrder default False;
  2326.     property Font;
  2327.     property Images: TImageList read FImages write SetImages;
  2328.     property ParentColor;
  2329.     property ParentFont;
  2330.     property ParentShowHint;
  2331.     property Bitmap: TBitmap read FBitmap write SetBitmap;
  2332.     property PopupMenu;
  2333.     property ShowHint;
  2334.     property ShowText: Boolean read FShowText write SetShowText default True;
  2335.     property Vertical: Boolean read FVertical write SetVertical default False;
  2336.     property Visible;
  2337.     property OnChange: TNotifyEvent read FOnChange write FOnChange;
  2338.     property OnClick;
  2339.     property OnDblClick;
  2340.     property OnDragDrop;
  2341.     property OnDragOver;
  2342.     property OnEndDrag;
  2343.     property OnMouseDown;
  2344.     property OnMouseMove;
  2345.     property OnMouseUp;
  2346.     property OnResize: TNotifyEvent read FOnResize write FOnResize;
  2347.     property OnStartDrag;
  2348.   end;
  2349.  
  2350. type
  2351.   EDateTimeError = class(Exception);
  2352.  
  2353.   TDateTimeKind = (dtkDate, dtkTime);
  2354.   TDTDateMode = (dmComboBox, dmUpDown);
  2355.   TDTDateFormat = (dfShort, dfLong);
  2356.   TDTCalAlignment = (dtaLeft, dtaRight);
  2357.  
  2358.   TDTParseInputEvent = procedure(Sender: TObject; const UserString: string;
  2359.     var DateAndTime: TDateTime; var AllowChange: Boolean) of object;
  2360.  
  2361.   TDateTimePicker = class;
  2362.  
  2363.   TDateTimeColors = class(TPersistent)
  2364.   private
  2365.     Owner: TDateTimePicker;
  2366.     FBackColor: TColor;
  2367.     FTextColor: TColor;
  2368.     FTitleBackColor: TColor;
  2369.     FTitleTextColor: TColor;
  2370.     FMonthBackColor: TColor;
  2371.     FTrailingTextColor: TColor;
  2372.     procedure SetColor(Index: Integer; Value: TColor);
  2373.     procedure SetAllColors;
  2374.   public
  2375.     constructor Create(AOwner: TDateTimePicker);
  2376.     procedure Assign(Source: TPersistent); override;
  2377.   published
  2378.     property BackColor: TColor index 0 read FBackColor write SetColor default clWindow;
  2379.     property TextColor: TColor index 1 read FTextColor write SetColor default clWindowText;
  2380.     property TitleBackColor: TColor index 2 read FTitleBackColor write SetColor default clActiveCaption;
  2381.     property TitleTextColor: TColor index 3 read FTitleTextColor write SetColor default clWhite;
  2382.     property MonthBackColor: TColor index 4 read FMonthBackColor write SetColor default clWhite;
  2383.     property TrailingTextColor: TColor index 5read FTrailingTextColor
  2384.       write SetColor default clInactiveCaptionText;
  2385.   end;
  2386.  
  2387.   TDateTimePicker = class(TWinControl)
  2388.   private
  2389.     FCalAlignment: TDTCalAlignment;
  2390.     FCalColors: TDateTimeColors;
  2391.     FChecked: Boolean;
  2392.     FDateTime: TDateTime;
  2393.     FDateFormat: TDTDateFormat;
  2394.     FDateMode: TDTDateMode;
  2395.     FKind: TDateTimeKind;
  2396.     FParseInput: Boolean;
  2397.     FMaxDate: TDate;
  2398.     FMinDate: TDate;
  2399.     FShowCheckbox: Boolean;
  2400.     FOnUserInput: TDTParseInputEvent;
  2401.     FOnCloseUp: TNotifyEvent;
  2402.     FOnChange: TNotifyEvent;
  2403.     FOnDropDown: TNotifyEvent;
  2404.     procedure AdjustHeight;
  2405.     function GetDate: TDate;
  2406.     function GetTime: TTime;
  2407.     procedure SetCalAlignment(Value: TDTCalAlignment);
  2408.     procedure SetCalColors(Value: TDateTimeColors);
  2409.     procedure SetChecked(Value: Boolean);
  2410.     procedure SetDate(Value: TDate);
  2411.     procedure SetDateMode(Value: TDTDateMode);
  2412.     procedure SetDateFormat(Value: TDTDateFormat);
  2413.     procedure SetDateTime(Value: TDateTime);
  2414.     procedure SetKind(Value: TDateTimeKind);
  2415.     procedure SetParseInput(Value: Boolean);
  2416.     procedure SetMaxDate(Value: TDate);
  2417.     procedure SetMinDate(Value: TDate);
  2418.     procedure SetRange(MinVal, MaxVal: TDateTime);
  2419.     procedure SetShowCheckbox(Value: Boolean);
  2420.     procedure SetTime(Value: TTime);
  2421.     procedure CMColorChanged(var Message: TMessage); message CM_COLORCHANGED;
  2422.     procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
  2423.     procedure CNNotify(var Message: TWMNotify); message CN_NOTIFY;
  2424.   protected
  2425.     procedure CreateParams(var Params: TCreateParams); override;
  2426.     procedure CreateWnd; override;
  2427.   public
  2428.     constructor Create(AOwner: TComponent); override;
  2429.     destructor Destroy; override;
  2430.   published
  2431.     property CalAlignment: TDTCalAlignment read FCalAlignment write SetCalAlignment;
  2432.     property CalColors: TDateTimeColors read FCalColors write SetCalColors;
  2433.     // The Date, Time, ShowCheckbox, and Checked properties must be in this order:
  2434.     property Date: TDate read GetDate write SetDate;
  2435.     property Time: TTime read GetTime write SetTime;
  2436.     property ShowCheckbox: Boolean read FShowCheckbox write SetShowCheckbox default False;
  2437.     property Checked: Boolean read FChecked write SetChecked default True;
  2438.     property Color stored True default clWindow;
  2439.     property DateFormat: TDTDateFormat read FDateFormat write SetDateFormat;
  2440.     property DateMode: TDTDateMode read FDateMode write SetDateMode;
  2441.     property DragCursor;
  2442.     property DragMode;
  2443.     property Enabled;
  2444.     property Font;
  2445.     property ImeMode;
  2446.     property ImeName;
  2447.     property Kind: TDateTimeKind read FKind write SetKind;
  2448.     property MaxDate: TDate read FMaxDate write SetMaxDate;
  2449.     property MinDate: TDate read FMinDate write SetMinDate;
  2450.     property ParseInput: Boolean read FParseInput write SetParseInput;
  2451.     property ParentColor default False;
  2452.     property ParentFont;
  2453.     property ParentShowHint;
  2454.     property PopupMenu;
  2455.     property ShowHint;
  2456.     property TabStop default True;
  2457.     property Visible;
  2458.     property OnClick;
  2459.     property OnCloseUp: TNotifyEvent read FOnCloseUp write FOnCloseUp;
  2460.     property OnChange: TNotifyEvent read FOnChange write FOnChange;
  2461.     property OnDropDown: TNotifyEvent read FOnDropDown write FOnDropDown;
  2462.     property OnDblClick;
  2463.     property OnDragDrop;
  2464.     property OnDragOver;
  2465.     property OnEndDrag;
  2466.     property OnEnter;
  2467.     property OnExit;
  2468.     property OnKeyDown;
  2469.     property OnKeyPress;
  2470.     property OnKeyUp;
  2471.     property OnStartDrag;
  2472.     property OnUserInput: TDTParseInputEvent read FOnUserInput write FOnUserInput;
  2473.   end;
  2474.  
  2475. function InitCommonControl(CC: Integer): Boolean;
  2476. procedure CheckCommonControl(CC: Integer);
  2477.  
  2478. implementation
  2479.  
  2480. uses Printers, Consts, ComStrs;
  2481.  
  2482. const
  2483.   SectionSizeArea = 8;
  2484.   RTFConversionFormat: TConversionFormat = (
  2485.     ConversionClass: TConversion;
  2486.     Extension: 'rtf';
  2487.     Next: nil);
  2488.   TextConversionFormat: TConversionFormat = (
  2489.     ConversionClass: TConversion;
  2490.     Extension: 'txt';
  2491.     Next: @RTFConversionFormat);
  2492.  
  2493. var
  2494.   ConversionFormatList: PConversionFormat = @TextConversionFormat;
  2495.   ShellModule: THandle;
  2496.  
  2497. function InitCommonControl(CC: Integer): Boolean;
  2498. var
  2499.   ICC: TInitCommonControlsEx;
  2500. begin
  2501.   ICC.dwSize := SizeOf(TInitCommonControlsEx);
  2502.   ICC.dwICC := CC;
  2503.   Result := InitCommonControlsEx(ICC);
  2504.   if not Result then InitCommonControls;
  2505. end;
  2506.  
  2507. procedure CheckCommonControl(CC: Integer);
  2508. begin
  2509.   if not InitCommonControl(CC) then
  2510.     raise EComponentError.Create(SInvalidComCtl32);
  2511. end;
  2512.  
  2513. { TTabStrings }
  2514.  
  2515. type
  2516.   TTabStrings = class(TStrings)
  2517.   private
  2518.     FTabControl: TCustomTabControl;
  2519.   protected
  2520.     function Get(Index: Integer): string; override;
  2521.     function GetCount: Integer; override;
  2522.     function GetObject(Index: Integer): TObject; override;
  2523.     procedure Put(Index: Integer; const S: string); override;
  2524.     procedure PutObject(Index: Integer; AObject: TObject); override;
  2525.     procedure SetUpdateState(Updating: Boolean); override;
  2526.   public
  2527.     procedure Clear; override;
  2528.     procedure Delete(Index: Integer); override;
  2529.     procedure Insert(Index: Integer; const S: string); override;
  2530.   end;
  2531.  
  2532. procedure TabControlError;
  2533. begin
  2534.   raise EListError.Create(sTabAccessError);
  2535. end;
  2536.  
  2537. procedure TTabStrings.Clear;
  2538. begin
  2539.   if SendMessage(FTabControl.Handle, TCM_DELETEALLITEMS, 0, 0) = 0 then
  2540.     TabControlError;
  2541.   FTabControl.TabsChanged;
  2542. end;
  2543.  
  2544. procedure TTabStrings.Delete(Index: Integer);
  2545. begin
  2546.   if SendMessage(FTabControl.Handle, TCM_DELETEITEM, Index, 0) = 0 then
  2547.     TabControlError;
  2548.   FTabControl.TabsChanged;
  2549. end;
  2550.  
  2551. function TTabStrings.Get(Index: Integer): string;
  2552. var
  2553.   TCItem: TTCItem;
  2554.   Buffer: array[0..4095] of Char;
  2555. begin
  2556.   TCItem.mask := TCIF_TEXT;
  2557.   TCItem.pszText := Buffer;
  2558.   TCItem.cchTextMax := SizeOf(Buffer);
  2559.   if SendMessage(FTabControl.Handle, TCM_GETITEM, Index,
  2560.     Longint(@TCItem)) = 0 then TabControlError;
  2561.   Result := Buffer;
  2562. end;
  2563.  
  2564. function TTabStrings.GetCount: Integer;
  2565. begin
  2566.   Result := SendMessage(FTabControl.Handle, TCM_GETITEMCOUNT, 0, 0);
  2567. end;
  2568.  
  2569. function TTabStrings.GetObject(Index: Integer): TObject;
  2570. var
  2571.   TCItem: TTCItem;
  2572. begin
  2573.   TCItem.mask := TCIF_PARAM;
  2574.   if SendMessage(FTabControl.Handle, TCM_GETITEM, Index,
  2575.     Longint(@TCItem)) = 0 then TabControlError;
  2576.   Result := TObject(TCItem.lParam);
  2577. end;
  2578.  
  2579. procedure TTabStrings.Put(Index: Integer; const S: string);
  2580. var
  2581.   TCItem: TTCItem;
  2582. begin
  2583.   TCItem.mask := TCIF_TEXT;
  2584.   TCItem.pszText := PChar(S);
  2585.   if SendMessage(FTabControl.Handle, TCM_SETITEM, Index,
  2586.     Longint(@TCItem)) = 0 then TabControlError;
  2587.   FTabControl.TabsChanged;
  2588. end;
  2589.  
  2590. procedure TTabStrings.PutObject(Index: Integer; AObject: TObject);
  2591. var
  2592.   TCItem: TTCItem;
  2593. begin
  2594.   TCItem.mask := TCIF_PARAM;
  2595.   TCItem.lParam := Longint(AObject);
  2596.   if SendMessage(FTabControl.Handle, TCM_SETITEM, Index,
  2597.     Longint(@TCItem)) = 0 then TabControlError;
  2598. end;
  2599.  
  2600. procedure TTabStrings.Insert(Index: Integer; const S: string);
  2601. var
  2602.   TCItem: TTCItem;
  2603. begin
  2604.   TCItem.mask := TCIF_TEXT;
  2605.   TCItem.pszText := PChar(S);
  2606.   if SendMessage(FTabControl.Handle, TCM_INSERTITEM, Index,
  2607.     Longint(@TCItem)) < 0 then TabControlError;
  2608.   FTabControl.TabsChanged;
  2609. end;
  2610.  
  2611. procedure TTabStrings.SetUpdateState(Updating: Boolean);
  2612. begin
  2613.   FTabControl.FUpdating := Updating;
  2614.   SendMessage(FTabControl.Handle, WM_SETREDRAW, Ord(not Updating), 0);
  2615.   if not Updating then
  2616.   begin
  2617.     FTabControl.Invalidate;
  2618.     FTabControl.TabsChanged;
  2619.   end;
  2620. end;
  2621.  
  2622. { TCustomTabControl }
  2623.  
  2624. constructor TCustomTabControl.Create(AOwner: TComponent);
  2625. begin
  2626.   inherited Create(AOwner);
  2627.   Width := 289;
  2628.   Height := 193;
  2629.   TabStop := True;
  2630.   ControlStyle := [csAcceptsControls, csDoubleClicks];
  2631.   FTabs := TTabStrings.Create;
  2632.   TTabStrings(FTabs).FTabControl := Self;
  2633. end;
  2634.  
  2635. destructor TCustomTabControl.Destroy;
  2636. begin
  2637.   FTabs.Free;
  2638.   FSaveTabs.Free;
  2639.   inherited Destroy;
  2640. end;
  2641.  
  2642. function TCustomTabControl.CanChange: Boolean;
  2643. begin
  2644.   Result := True;
  2645.   if Assigned(FOnChanging) then FOnChanging(Self, Result);
  2646. end;
  2647.  
  2648. procedure TCustomTabControl.Change;
  2649. begin
  2650.   if Assigned(FOnChange) then FOnChange(Self);
  2651. end;
  2652.  
  2653. procedure TCustomTabControl.CreateParams(var Params: TCreateParams);
  2654. const
  2655.   AlignStyles: array[TTabPosition] of Integer = (0, TCS_BOTTOM);
  2656. begin
  2657.   InitCommonControl(ICC_TAB_CLASSES);
  2658.   inherited CreateParams(Params);
  2659.   CreateSubClass(Params, WC_TABCONTROL);
  2660.   with Params do
  2661.   begin
  2662.     Style := Style or WS_CLIPCHILDREN or AlignStyles[FTabPosition];
  2663.     if not TabStop then Style := Style or TCS_FOCUSNEVER;
  2664.     if FMultiLine then Style := Style or TCS_MULTILINE;
  2665.     if FTabSize.X <> 0 then Style := Style or TCS_FIXEDWIDTH;
  2666.     if FHotTrack and (not (csDesigning in ComponentState)) then
  2667.       Style := Style or TCS_HOTTRACK;
  2668.     if FScrollOpposite then Style := Style or TCS_SCROLLOPPOSITE;
  2669.     WindowClass.style := WindowClass.style and not (CS_HREDRAW or CS_VREDRAW) or
  2670.       CS_DBLCLKS;
  2671.   end;
  2672. end;
  2673.  
  2674. procedure TCustomTabControl.CreateWnd;
  2675. begin
  2676.   inherited CreateWnd;
  2677.   if Integer(FTabSize) <> 0 then UpdateTabSize;
  2678.   if FSaveTabs <> nil then
  2679.   begin
  2680.     FTabs.Assign(FSaveTabs);
  2681.     SetTabIndex(FSaveTabIndex);
  2682.     FSaveTabs.Free;
  2683.     FSaveTabs := nil;
  2684.   end;
  2685. end;
  2686.  
  2687. procedure TCustomTabControl.DestroyWnd;
  2688. begin
  2689.   if FTabs.Count > 0 then
  2690.   begin
  2691.     FSaveTabs := TStringList.Create;
  2692.     FSaveTabs.Assign(FTabs);
  2693.     FSaveTabIndex := GetTabIndex;
  2694.   end;
  2695.   inherited DestroyWnd;
  2696. end;
  2697.  
  2698. procedure TCustomTabControl.AlignControls(AControl: TControl;
  2699.   var Rect: TRect);
  2700. begin
  2701.   Rect := DisplayRect;
  2702.   inherited AlignControls(AControl, Rect);
  2703. end;
  2704.  
  2705. function TCustomTabControl.GetDisplayRect: TRect;
  2706. begin
  2707.   Result := ClientRect;
  2708.   SendMessage(Handle, TCM_ADJUSTRECT, 0, Integer(@Result));
  2709.   Inc(Result.Top, 2);
  2710. end;
  2711.  
  2712. function TCustomTabControl.GetTabIndex: Integer;
  2713. begin
  2714.   Result := SendMessage(Handle, TCM_GETCURSEL, 0, 0);
  2715. end;
  2716.  
  2717. procedure TCustomTabControl.SetHotTrack(Value: Boolean);
  2718. begin
  2719.   if FHotTrack <> Value then
  2720.   begin
  2721.     FHotTrack := Value;
  2722.     RecreateWnd;
  2723.   end;
  2724. end;
  2725.  
  2726. procedure TCustomTabControl.SetMultiLine(Value: Boolean);
  2727. begin
  2728.   if FMultiLine <> Value then
  2729.   begin
  2730.     FMultiLine := Value;
  2731.     if not Value then FScrollOpposite := Value;
  2732.     RecreateWnd;
  2733.   end;
  2734. end;
  2735.  
  2736. procedure TCustomTabControl.SetScrollOpposite(Value: Boolean);
  2737. begin
  2738.   if FScrollOpposite <> Value then
  2739.   begin
  2740.     FScrollOpposite := Value;
  2741.     if Value then FMultiLine := Value;
  2742.     RecreateWnd;
  2743.   end;
  2744. end;
  2745.  
  2746. procedure TCustomTabControl.SetTabHeight(Value: Smallint);
  2747. begin
  2748.   if FTabSize.Y <> Value then
  2749.   begin
  2750.     if Value < 0 then
  2751.       raise EInvalidOperation.CreateFmt(SPropertyOutOfRange, [Self.Classname]);
  2752.     FTabSize.Y := Value;
  2753.     UpdateTabSize;
  2754.   end;
  2755. end;
  2756.  
  2757. procedure TCustomTabControl.SetTabIndex(Value: Integer);
  2758. begin
  2759.   SendMessage(Handle, TCM_SETCURSEL, Value, 0);
  2760. end;
  2761.  
  2762. procedure TCustomTabControl.SetTabPosition(Value: TTabPosition);
  2763. begin
  2764.   if FTabPosition <> Value then
  2765.   begin
  2766.     FTabPosition := Value;
  2767.     RecreateWnd;
  2768.   end;
  2769. end;
  2770.  
  2771. procedure TCustomTabControl.SetTabs(Value: TStrings);
  2772. begin
  2773.   FTabs.Assign(Value);
  2774. end;
  2775.  
  2776. procedure TCustomTabControl.SetTabWidth(Value: Smallint);
  2777. var
  2778.   OldValue: Smallint;
  2779. begin
  2780.   if FTabSize.X <> Value then
  2781.   begin
  2782.     if Value < 0 then
  2783.       raise EInvalidOperation.CreateFmt(SPropertyOutOfRange, [Self.Classname]);
  2784.     OldValue := FTabSize.X;
  2785.     FTabSize.X := Value;
  2786.     if (OldValue = 0) or (Value = 0) then
  2787.       RecreateWnd else
  2788.       UpdateTabSize;
  2789.   end;
  2790. end;
  2791.  
  2792. procedure TCustomTabControl.TabsChanged;
  2793. begin
  2794.   if not FUpdating then
  2795.   begin
  2796.     if HandleAllocated then
  2797.       SendMessage(Handle, WM_SIZE, SIZE_RESTORED,
  2798.         Word(Width) or Word(Height) shl 16);
  2799.     Realign;
  2800.   end;
  2801. end;
  2802.  
  2803. procedure TCustomTabControl.UpdateTabSize;
  2804. begin
  2805.   SendMessage(Handle, TCM_SETITEMSIZE, 0, Integer(FTabSize));
  2806.   TabsChanged;
  2807. end;
  2808.  
  2809. procedure TCustomTabControl.WMDestroy(var Message: TWMDestroy);
  2810. var
  2811.   FocusHandle: HWnd;
  2812. begin
  2813.   FocusHandle := GetFocus;
  2814.   if (FocusHandle <> 0) and ((FocusHandle = Handle) or
  2815.     IsChild(Handle, FocusHandle)) then
  2816.     Windows.SetFocus(0);
  2817.   inherited;
  2818. end;
  2819.  
  2820. procedure TCustomTabControl.WMEraseBkgnd(var Message: TMessage);
  2821. begin
  2822.   if FDoubleBuffered and (Message.wParam <> Message.lParam) then Message.Result := 1
  2823.   else inherited;
  2824. end;
  2825.  
  2826. procedure TCustomTabControl.WMNotifyFormat(var Message: TMessage);
  2827. begin
  2828.   with Message do
  2829.     Result := DefWindowProc(Handle, Msg, WParam, LParam);
  2830. end;
  2831.  
  2832. procedure TCustomTabControl.WMSize(var Message: TMessage);
  2833. begin
  2834.   inherited;
  2835.   RedrawWindow(Handle, nil, 0, RDW_INVALIDATE or RDW_ERASE);
  2836. end;
  2837.  
  2838. procedure TCustomTabControl.CMFontChanged(var Message);
  2839. begin
  2840.   inherited;
  2841.   if HandleAllocated then Perform(WM_SIZE, 0, 0);
  2842. end;
  2843.  
  2844. procedure TCustomTabControl.CMSysColorChange(var Message: TMessage);
  2845. begin
  2846.   inherited;
  2847.   if not (csLoading in ComponentState) then
  2848.   begin
  2849.     Message.Msg := WM_SYSCOLORCHANGE;
  2850.     DefaultHandler(Message);
  2851.   end;
  2852. end;
  2853.  
  2854. procedure TCustomTabControl.CMTabStopChanged(var Message: TMessage);
  2855. begin
  2856.   if not (csDesigning in ComponentState) then RecreateWnd;
  2857. end;
  2858.  
  2859. procedure TCustomTabControl.CNNotify(var Message: TWMNotify);
  2860. begin
  2861.   with Message.NMHdr^ do
  2862.     case code of
  2863.       TCN_SELCHANGE:
  2864.         Change;
  2865.       TCN_SELCHANGING:
  2866.         begin
  2867.           Message.Result := 1;
  2868.           if CanChange then Message.Result := 0;
  2869.         end;
  2870.     end;
  2871. end;
  2872.  
  2873. { TTabSheet }
  2874.  
  2875. constructor TTabSheet.Create(AOwner: TComponent);
  2876. begin
  2877.   inherited Create(AOwner);
  2878.   Align := alClient;
  2879.   ControlStyle := ControlStyle + [csAcceptsControls, csNoDesignVisible];
  2880.   Visible := False;
  2881.   FTabVisible := True;
  2882. end;
  2883.  
  2884. destructor TTabSheet.Destroy;
  2885. begin
  2886.   if FPageControl <> nil then FPageControl.RemovePage(Self);
  2887.   inherited Destroy;
  2888. end;
  2889.  
  2890. function TTabSheet.GetPageIndex: Integer;
  2891. begin
  2892.   if FPageControl <> nil then
  2893.     Result := FPageControl.FPages.IndexOf(Self) else
  2894.     Result := -1;
  2895. end;
  2896.  
  2897. function TTabSheet.GetTabIndex: Integer;
  2898. var
  2899.   I: Integer;
  2900. begin
  2901.   Result := 0;
  2902.   if not FTabShowing then Dec(Result) else
  2903.     for I := 0 to PageIndex - 1 do
  2904.       if TTabSheet(FPageControl.FPages[I]).FTabShowing then
  2905.         Inc(Result);
  2906. end;
  2907.  
  2908. procedure TTabSheet.CreateParams(var Params: TCreateParams);
  2909. begin
  2910.   inherited CreateParams(Params);
  2911.   with Params.WindowClass do
  2912.     style := style and not (CS_HREDRAW or CS_VREDRAW);
  2913. end;
  2914.  
  2915. procedure TTabSheet.ReadState(Reader: TReader);
  2916. begin
  2917.   inherited ReadState(Reader);
  2918.   if Reader.Parent is TPageControl then
  2919.     PageControl := TPageControl(Reader.Parent);
  2920. end;
  2921.  
  2922. procedure TTabSheet.SetPageControl(APageControl: TPageControl);
  2923. begin
  2924.   if FPageControl <> APageControl then
  2925.   begin
  2926.     if FPageControl <> nil then FPageControl.RemovePage(Self);
  2927.     Parent := APageControl;
  2928.     if APageControl <> nil then APageControl.InsertPage(Self);
  2929.   end;
  2930. end;
  2931.  
  2932. procedure TTabSheet.SetPageIndex(Value: Integer);
  2933. var
  2934.   I, MaxPageIndex: Integer;
  2935. begin
  2936.   if FPageControl <> nil then
  2937.   begin
  2938.     MaxPageIndex := FPageControl.FPages.Count - 1;
  2939.     if Value > MaxPageIndex then
  2940.       raise EListError.CreateFmt(SPageIndexError, [Value, MaxPageIndex]);
  2941.     I := TabIndex;
  2942.     FPageControl.FPages.Move(PageIndex, Value);
  2943.     if I >= 0 then FPageControl.MoveTab(I, TabIndex);
  2944.   end;
  2945. end;
  2946.  
  2947. procedure TTabSheet.SetTabShowing(Value: Boolean);
  2948. begin
  2949.   if FTabShowing <> Value then
  2950.     if Value then
  2951.     begin
  2952.       FTabShowing := True;
  2953.       FPageControl.InsertTab(Self);
  2954.     end else
  2955.     begin
  2956.       FPageControl.DeleteTab(Self);
  2957.       FTabShowing := False;
  2958.     end;
  2959. end;
  2960.  
  2961. procedure TTabSheet.SetTabVisible(Value: Boolean);
  2962. begin
  2963.   if FTabVisible <> Value then
  2964.   begin
  2965.     FTabVisible := Value;
  2966.     UpdateTabShowing;
  2967.   end;
  2968. end;
  2969.  
  2970. procedure TTabSheet.UpdateTabShowing;
  2971. begin
  2972.   SetTabShowing((FPageControl <> nil) and FTabVisible);
  2973. end;
  2974.  
  2975. procedure TTabSheet.CMTextChanged(var Message: TMessage);
  2976. begin
  2977.   if FTabShowing then FPageControl.UpdateTab(Self);
  2978. end;
  2979.  
  2980. { TPageControl }
  2981.  
  2982. constructor TPageControl.Create(AOwner: TComponent);
  2983. begin
  2984.   inherited Create(AOwner);
  2985.   ControlStyle := [csDoubleClicks, csOpaque];
  2986.   FPages := TList.Create;
  2987. end;
  2988.  
  2989. destructor TPageControl.Destroy;
  2990. var
  2991.   I: Integer;
  2992. begin
  2993.   for I := 0 to FPages.Count - 1 do TTabSheet(FPages[I]).FPageControl := nil;
  2994.   FPages.Free;
  2995.   inherited Destroy;
  2996. end;
  2997.  
  2998. procedure TPageControl.Change;
  2999. var
  3000.   Form: TCustomForm;
  3001. begin
  3002.   UpdateActivePage;
  3003.   if csDesigning in ComponentState then
  3004.   begin
  3005.     Form := GetParentForm(Self);
  3006.     if (Form <> nil) and (Form.Designer <> nil) then Form.Designer.Modified;
  3007.   end;
  3008.   inherited Change;
  3009. end;
  3010.  
  3011. procedure TPageControl.ChangeActivePage(Page: TTabSheet);
  3012. var
  3013.   ParentForm: TCustomForm;
  3014. begin
  3015.   if FActivePage <> Page then
  3016.   begin
  3017.     ParentForm := GetParentForm(Self);
  3018.     if (ParentForm <> nil) and (FActivePage <> nil) and
  3019.       FActivePage.ContainsControl(ParentForm.ActiveControl) then
  3020.     begin
  3021.       ParentForm.ActiveControl := FActivePage;
  3022.       if ParentForm.ActiveControl <> FActivePage then
  3023.       begin
  3024.         TabIndex := FActivePage.TabIndex;
  3025.         Exit;
  3026.       end;
  3027.     end;
  3028.     if Page <> nil then
  3029.     begin
  3030.       Page.BringToFront;
  3031.       Page.Visible := True;
  3032.       if (ParentForm <> nil) and (FActivePage <> nil) and
  3033.         (ParentForm.ActiveControl = FActivePage) then
  3034.         if Page.CanFocus then
  3035.           ParentForm.ActiveControl := Page else
  3036.           ParentForm.ActiveControl := Self;
  3037.     end;
  3038.     if FActivePage <> nil then FActivePage.Visible := False;
  3039.     FActivePage := Page;
  3040.     if (ParentForm <> nil) and (FActivePage <> nil) and
  3041.       (ParentForm.ActiveControl = FActivePage) then
  3042.       FActivePage.SelectFirst;
  3043.   end;
  3044. end;
  3045.  
  3046. procedure TPageControl.DeleteTab(Page: TTabSheet);
  3047. begin
  3048.   Tabs.Delete(Page.TabIndex);
  3049.   UpdateActivePage;
  3050. end;
  3051.  
  3052. function TPageControl.FindNextPage(CurPage: TTabSheet;
  3053.   GoForward, CheckTabVisible: Boolean): TTabSheet;
  3054. var
  3055.   I, StartIndex: Integer;
  3056. begin
  3057.   if FPages.Count <> 0 then
  3058.   begin
  3059.     StartIndex := FPages.IndexOf(CurPage);
  3060.     if StartIndex = -1 then
  3061.       if GoForward then StartIndex := FPages.Count - 1 else StartIndex := 0;
  3062.     I := StartIndex;
  3063.     repeat
  3064.       if GoForward then
  3065.       begin
  3066.         Inc(I);
  3067.         if I = FPages.Count then I := 0;
  3068.       end else
  3069.       begin
  3070.         if I = 0 then I := FPages.Count;
  3071.         Dec(I);
  3072.       end;
  3073.       Result := FPages[I];
  3074.       if not CheckTabVisible or Result.TabVisible then Exit;
  3075.     until I = StartIndex;
  3076.   end;
  3077.   Result := nil;
  3078. end;
  3079.  
  3080. procedure TPageControl.GetChildren(Proc: TGetChildProc; Root: TComponent);
  3081. var
  3082.   I: Integer;
  3083. begin
  3084.   for I := 0 to FPages.Count - 1 do Proc(TComponent(FPages[I]));
  3085. end;
  3086.  
  3087. function TPageControl.GetPage(Index: Integer): TTabSheet;
  3088. begin
  3089.   Result := FPages[Index];
  3090. end;
  3091.  
  3092. function TPageControl.GetPageCount: Integer;
  3093. begin
  3094.   Result := FPages.Count;
  3095. end;
  3096.  
  3097. procedure TPageControl.InsertPage(Page: TTabSheet);
  3098. begin
  3099.   FPages.Add(Page);
  3100.   Page.FPageControl := Self;
  3101.   Page.UpdateTabShowing;
  3102. end;
  3103.  
  3104. procedure TPageControl.InsertTab(Page: TTabSheet);
  3105. begin
  3106.   Tabs.InsertObject(Page.TabIndex, Page.Caption, Page);
  3107.   UpdateActivePage;
  3108. end;
  3109.  
  3110. procedure TPageControl.MoveTab(CurIndex, NewIndex: Integer);
  3111. begin
  3112.   Tabs.Move(CurIndex, NewIndex);
  3113. end;
  3114.  
  3115. procedure TPageControl.RemovePage(Page: TTabSheet);
  3116. begin
  3117.   if FActivePage = Page then SetActivePage(nil);
  3118.   Page.SetTabShowing(False);
  3119.   Page.FPageControl := nil;
  3120.   FPages.Remove(Page);
  3121. end;
  3122.  
  3123. procedure TPageControl.SelectNextPage(GoForward: Boolean);
  3124. var
  3125.   Page: TTabSheet;
  3126. begin
  3127.   Page := FindNextPage(ActivePage, GoForward, True);
  3128.   if (Page <> nil) and (Page <> ActivePage) and CanChange then
  3129.   begin
  3130.     TabIndex := Page.TabIndex;
  3131.     Change;
  3132.   end;
  3133. end;
  3134.  
  3135. procedure TPageControl.SetActivePage(Page: TTabSheet);
  3136. begin
  3137.   if (Page <> nil) and (Page.PageControl <> Self) then Exit;
  3138.   ChangeActivePage(Page);
  3139.   if Page = nil then
  3140.     TabIndex := -1
  3141.   else if Page = FActivePage then
  3142.     TabIndex := Page.TabIndex;
  3143. end;
  3144.  
  3145. procedure TPageControl.SetChildOrder(Child: TComponent; Order: Integer);
  3146. begin
  3147.   TTabSheet(Child).PageIndex := Order;
  3148. end;
  3149.  
  3150. procedure TPageControl.ShowControl(AControl: TControl);
  3151. begin
  3152.   if (AControl is TTabSheet) and (TTabSheet(AControl).PageControl = Self) then
  3153.     SetActivePage(TTabSheet(AControl));
  3154.   inherited ShowControl(AControl);
  3155. end;
  3156.  
  3157. procedure TPageControl.UpdateTab(Page: TTabSheet);
  3158. begin
  3159.   Tabs[Page.TabIndex] := Page.Caption;
  3160. end;
  3161.  
  3162. procedure TPageControl.UpdateActivePage;
  3163. begin
  3164.   if TabIndex >= 0 then SetActivePage(TTabSheet(Tabs.Objects[TabIndex]));
  3165. end;
  3166.  
  3167. procedure TPageControl.CMDesignHitTest(var Message: TCMDesignHitTest);
  3168. var
  3169.   HitIndex: Integer;
  3170.   HitTestInfo: TTCHitTestInfo;
  3171. begin
  3172.   HitTestInfo.pt := SmallPointToPoint(Message.Pos);
  3173.   HitIndex := SendMessage(Handle, TCM_HITTEST, 0, Longint(@HitTestInfo));
  3174.   if (HitIndex >= 0) and (HitIndex <> TabIndex) then Message.Result := 1;
  3175. end;
  3176.  
  3177. procedure TPageControl.CMDialogKey(var Message: TCMDialogKey);
  3178. begin
  3179.   if (Message.CharCode = VK_TAB) and (GetKeyState(VK_CONTROL) < 0) then
  3180.   begin
  3181.     SelectNextPage(GetKeyState(VK_SHIFT) >= 0);
  3182.     Message.Result := 1;
  3183.   end else
  3184.     inherited;
  3185. end;
  3186.  
  3187. { TStatusPanel }
  3188.  
  3189. constructor TStatusPanel.Create(Collection: TCollection);
  3190. begin
  3191.   FWidth := 50;
  3192.   FBevel := pbLowered;
  3193.   inherited Create(Collection);
  3194. end;
  3195.  
  3196. procedure TStatusPanel.Assign(Source: TPersistent);
  3197. begin
  3198.   if Source is TStatusPanel then
  3199.   begin
  3200.     Text := TStatusPanel(Source).Text;
  3201.     Width := TStatusPanel(Source).Width;
  3202.     Alignment := TStatusPanel(Source).Alignment;
  3203.     Bevel := TStatusPanel(Source).Bevel;
  3204.     Style := TStatusPanel(Source).Style;
  3205.     Exit;
  3206.   end;
  3207.   inherited Assign(Source);
  3208. end;
  3209.  
  3210. function TStatusPanel.GetDisplayName: string;
  3211. begin
  3212.   Result := Text;
  3213.   if Result = '' then Result := inherited GetDisplayName;
  3214. end;
  3215.  
  3216. procedure TStatusPanel.SetAlignment(Value: TAlignment);
  3217. begin
  3218.   if FAlignment <> Value then
  3219.   begin
  3220.     FAlignment := Value;
  3221.     Changed(False);
  3222.   end;
  3223. end;
  3224.  
  3225. procedure TStatusPanel.SetBevel(Value: TStatusPanelBevel);
  3226. begin
  3227.   if FBevel <> Value then
  3228.   begin
  3229.     FBevel := Value;
  3230.     Changed(True);
  3231.   end;
  3232. end;
  3233.  
  3234. procedure TStatusPanel.SetStyle(Value: TStatusPanelStyle);
  3235. begin
  3236.   if FStyle <> Value then
  3237.   begin
  3238.     FStyle := Value;
  3239.     Changed(False);
  3240.   end;
  3241. end;
  3242.  
  3243. procedure TStatusPanel.SetText(const Value: string);
  3244. begin
  3245.   if FText <> Value then
  3246.   begin
  3247.     FText := Value;
  3248.     Changed(False);
  3249.   end;
  3250. end;
  3251.  
  3252. procedure TStatusPanel.SetWidth(Value: Integer);
  3253. begin
  3254.   if FWidth <> Value then
  3255.   begin
  3256.     FWidth := Value;
  3257.     Changed(True);
  3258.   end;
  3259. end;
  3260.  
  3261. { TStatusPanels }
  3262.  
  3263. constructor TStatusPanels.Create(StatusBar: TStatusBar);
  3264. begin
  3265.   inherited Create(TStatusPanel);
  3266.   FStatusBar := StatusBar;
  3267. end;
  3268.  
  3269. function TStatusPanels.Add: TStatusPanel;
  3270. begin
  3271.   Result := TStatusPanel(inherited Add);
  3272. end;
  3273.  
  3274. function TStatusPanels.GetItem(Index: Integer): TStatusPanel;
  3275. begin
  3276.   Result := TStatusPanel(inherited GetItem(Index));
  3277. end;
  3278.  
  3279. function TStatusPanels.GetOwner: TPersistent;
  3280. begin
  3281.   Result := FStatusBar;
  3282. end;
  3283.  
  3284. procedure TStatusPanels.SetItem(Index: Integer; Value: TStatusPanel);
  3285. begin
  3286.   inherited SetItem(Index, Value);
  3287. end;
  3288.  
  3289. procedure TStatusPanels.Update(Item: TCollectionItem);
  3290. begin
  3291.   if Item <> nil then
  3292.     FStatusBar.UpdatePanel(Item.Index) else
  3293.     FStatusBar.UpdatePanels;
  3294. end;
  3295.  
  3296. { TStatusBar }
  3297.  
  3298. constructor TStatusBar.Create(AOwner: TComponent);
  3299. begin
  3300.   inherited Create(AOwner);
  3301.   ControlStyle := [csCaptureMouse, csClickEvents, csDoubleClicks, csOpaque];
  3302.   Color := clBtnFace;
  3303.   Height := 19;
  3304.   Align := alBottom;
  3305.   FPanels := TStatusPanels.Create(Self);
  3306.   FCanvas := TControlCanvas.Create;
  3307.   TControlCanvas(FCanvas).Control := Self;
  3308.   FSizeGrip := True;
  3309. end;
  3310.  
  3311. destructor TStatusBar.Destroy;
  3312. begin
  3313.   FCanvas.Free;
  3314.   FPanels.Free;
  3315.   inherited Destroy;
  3316. end;
  3317.  
  3318. procedure TStatusBar.CreateParams(var Params: TCreateParams);
  3319. begin
  3320.   InitCommonControl(ICC_BAR_CLASSES);
  3321.   inherited CreateParams(Params);
  3322.   CreateSubClass(Params, STATUSCLASSNAME);
  3323.   with Params do
  3324.   begin
  3325.     if FSizeGrip then
  3326.       Style := Style or SBARS_SIZEGRIP else
  3327.       Style := Style or CCS_TOP;
  3328.     WindowClass.style := WindowClass.style and not CS_HREDRAW;
  3329.   end;
  3330. end;
  3331.  
  3332. procedure TStatusBar.CreateWnd;
  3333. begin
  3334.   inherited CreateWnd;
  3335.   UpdatePanels;
  3336.   if FSimpleText <> '' then
  3337.     SendMessage(Handle, SB_SETTEXT, 255, Integer(PChar(FSimpleText)));
  3338.   if FSimplePanel then
  3339.     SendMessage(Handle, SB_SIMPLE, 1, 0);
  3340. end;
  3341.  
  3342. procedure TStatusBar.DrawPanel(Panel: TStatusPanel; const Rect: TRect);
  3343. begin
  3344.   if Assigned(FOnDrawPanel) then
  3345.     FOnDrawPanel(Self, Panel, Rect) else
  3346.     FCanvas.FillRect(Rect);
  3347. end;
  3348.  
  3349. procedure TStatusBar.Resize;
  3350. begin
  3351.   if Assigned(FOnResize) then FOnResize(Self);
  3352. end;
  3353.  
  3354. procedure TStatusBar.SetPanels(Value: TStatusPanels);
  3355. begin
  3356.   FPanels.Assign(Value);
  3357. end;
  3358.  
  3359. procedure TStatusBar.SetSimplePanel(Value: Boolean);
  3360. begin
  3361.   if FSimplePanel <> Value then
  3362.   begin
  3363.     FSimplePanel := Value;
  3364.     if HandleAllocated then
  3365.       SendMessage(Handle, SB_SIMPLE, Ord(FSimplePanel), 0);
  3366.   end;
  3367. end;
  3368.  
  3369. procedure TStatusBar.SetSimpleText(const Value: string);
  3370. begin
  3371.   if FSimpleText <> Value then
  3372.   begin
  3373.     FSimpleText := Value;
  3374.     if HandleAllocated then
  3375.       SendMessage(Handle, SB_SETTEXT, 255, Integer(PChar(FSimpleText)));
  3376.   end;
  3377. end;
  3378.  
  3379. procedure TStatusBar.SetSizeGrip(Value: Boolean);
  3380. begin
  3381.   if FSizeGrip <> Value then
  3382.   begin
  3383.     FSizeGrip := Value;
  3384.     RecreateWnd;
  3385.   end;
  3386. end;
  3387.  
  3388. procedure TStatusBar.UpdatePanel(Index: Integer);
  3389. var
  3390.   Flags: Integer;
  3391.   S: string;
  3392. begin
  3393.   if HandleAllocated then
  3394.     with Panels[Index] do
  3395.     begin
  3396.       Flags := 0;
  3397.       case Bevel of
  3398.         pbNone: Flags := SBT_NOBORDERS;
  3399.         pbRaised: Flags := SBT_POPOUT;
  3400.       end;
  3401.       if Style = psOwnerDraw then Flags := Flags or SBT_OWNERDRAW;
  3402.       S := Text;
  3403.       case Alignment of
  3404.         taCenter: S := #9 + S;
  3405.         taRightJustify: S := #9#9 + S;
  3406.       end;
  3407.       SendMessage(Handle, SB_SETTEXT, Index or Flags, Integer(PChar(S)));
  3408.       InvalidateRect(Handle, Nil, True);
  3409.     end;
  3410. end;
  3411.  
  3412. procedure TStatusBar.UpdatePanels;
  3413. const
  3414.   MaxPanelCount = 128;
  3415. var
  3416.   I, Count, PanelPos: Integer;
  3417.   PanelEdges: array[0..MaxPanelCount - 1] of Integer;
  3418. begin
  3419.   if HandleAllocated then
  3420.   begin
  3421.     Count := Panels.Count;
  3422.     if Count > MaxPanelCount then Count := MaxPanelCount;
  3423.     if Count = 0 then
  3424.     begin
  3425.       PanelEdges[0] := -1;
  3426.       SendMessage(Handle, SB_SETPARTS, 1, Integer(@PanelEdges));
  3427.       SendMessage(Handle, SB_SETTEXT, 0, Integer(PChar('')));
  3428.     end else
  3429.     begin
  3430.       PanelPos := 0;
  3431.       for I := 0 to Count - 2 do
  3432.       begin
  3433.         Inc(PanelPos, Panels[I].Width);
  3434.         PanelEdges[I] := PanelPos;
  3435.       end;
  3436.       PanelEdges[Count - 1] := -1;
  3437.       SendMessage(Handle, SB_SETPARTS, Count, Integer(@PanelEdges));
  3438.       for I := 0 to Count - 1 do UpdatePanel(I);
  3439.     end;
  3440.   end;
  3441. end;
  3442.  
  3443. procedure TStatusBar.CNDrawItem(var Message: TWMDrawItem);
  3444. var
  3445.   SaveIndex: Integer;
  3446. begin
  3447.   with Message.DrawItemStruct^ do
  3448.   begin
  3449.     SaveIndex := SaveDC(hDC);
  3450.     FCanvas.Handle := hDC;
  3451.     FCanvas.Font := Font;
  3452.     FCanvas.Brush.Color := clBtnFace;
  3453.     FCanvas.Brush.Style := bsSolid;
  3454.     DrawPanel(Panels[itemID], rcItem);
  3455.     FCanvas.Handle := 0;
  3456.     RestoreDC(hDC, SaveIndex);
  3457.   end;
  3458.   Message.Result := 1;
  3459. end;
  3460.  
  3461. procedure TStatusBar.WMSize(var Message: TWMSize);
  3462. begin
  3463.   { Eat WM_SIZE message to prevent control from doing alignment }
  3464.   if not (csLoading in ComponentState) then Resize;
  3465.   Repaint;
  3466. end;
  3467.  
  3468. { THeaderSection }
  3469.  
  3470. constructor THeaderSection.Create(Collection: TCollection);
  3471. begin
  3472.   FWidth := 50;
  3473.   FMaxWidth := 10000;
  3474.   FAllowClick := True;
  3475.   inherited Create(Collection);
  3476. end;
  3477.  
  3478. procedure THeaderSection.Assign(Source: TPersistent);
  3479. begin
  3480.   if Source is THeaderSection then
  3481.   begin
  3482.     Text := THeaderSection(Source).Text;
  3483.     Width := THeaderSection(Source).Width;
  3484.     MinWidth := THeaderSection(Source).MinWidth;
  3485.     MaxWidth := THeaderSection(Source).MaxWidth;
  3486.     Alignment := THeaderSection(Source).Alignment;
  3487.     Style := THeaderSection(Source).Style;
  3488.     AllowClick := THeaderSection(Source).AllowClick;
  3489.     Exit;
  3490.   end;
  3491.   inherited Assign(Source);
  3492. end;
  3493.  
  3494. function THeaderSection.GetDisplayName: string;
  3495. begin
  3496.   Result := Text;
  3497.   if Result = '' then Result := inherited GetDisplayName;
  3498. end;
  3499.  
  3500. function THeaderSection.GetLeft: Integer;
  3501. var
  3502.   I: Integer;
  3503. begin
  3504.   Result := 0;
  3505.   for I := 0 to Index - 1 do
  3506.     Inc(Result, THeaderSections(Collection)[I].Width);
  3507. end;
  3508.  
  3509. function THeaderSection.GetRight: Integer;
  3510. begin
  3511.   Result := Left + Width;
  3512. end;
  3513.  
  3514. procedure THeaderSection.SetAlignment(Value: TAlignment);
  3515. begin
  3516.   if FAlignment <> Value then
  3517.   begin
  3518.     FAlignment := Value;
  3519.     Changed(False);
  3520.   end;
  3521. end;
  3522.  
  3523. procedure THeaderSection.SetMaxWidth(Value: Integer);
  3524. begin
  3525.   if Value < FMinWidth then Value := FMinWidth;
  3526.   if Value > 10000 then Value := 10000;
  3527.   FMaxWidth := Value;
  3528.   SetWidth(FWidth);
  3529. end;
  3530.  
  3531. procedure THeaderSection.SetMinWidth(Value: Integer);
  3532. begin
  3533.   if Value < 0 then Value := 0;
  3534.   if Value > FMaxWidth then Value := FMaxWidth;
  3535.   FMinWidth := Value;
  3536.   SetWidth(FWidth);
  3537. end;
  3538.  
  3539. procedure THeaderSection.SetStyle(Value: THeaderSectionStyle);
  3540. begin
  3541.   if FStyle <> Value then
  3542.   begin
  3543.     FStyle := Value;
  3544.     Changed(False);
  3545.   end;
  3546. end;
  3547.  
  3548. procedure THeaderSection.SetText(const Value: string);
  3549. begin
  3550.   if FText <> Value then
  3551.   begin
  3552.     FText := Value;
  3553.     Changed(False);
  3554.   end;
  3555. end;
  3556.  
  3557. procedure THeaderSection.SetWidth(Value: Integer);
  3558. begin
  3559.   if Value < FMinWidth then Value := FMinWidth;
  3560.   if Value > FMaxWidth then Value := FMaxWidth;
  3561.   if FWidth <> Value then
  3562.   begin
  3563.     FWidth := Value;
  3564.     Changed(Index < Collection.Count - 1);
  3565.   end;
  3566. end;
  3567.  
  3568. { THeaderSections }
  3569.  
  3570. constructor THeaderSections.Create(HeaderControl: THeaderControl);
  3571. begin
  3572.   inherited Create(THeaderSection);
  3573.   FHeaderControl := HeaderControl;
  3574. end;
  3575.  
  3576. function THeaderSections.Add: THeaderSection;
  3577. begin
  3578.   Result := THeaderSection(inherited Add);
  3579. end;
  3580.  
  3581. function THeaderSections.GetItem(Index: Integer): THeaderSection;
  3582. begin
  3583.   Result := THeaderSection(inherited GetItem(Index));
  3584. end;
  3585.  
  3586. function THeaderSections.GetOwner: TPersistent;
  3587. begin
  3588.   Result := FHeaderControl;
  3589. end;
  3590.  
  3591. procedure THeaderSections.SetItem(Index: Integer; Value: THeaderSection);
  3592. begin
  3593.   inherited SetItem(Index, Value);
  3594. end;
  3595.  
  3596. procedure THeaderSections.Update(Item: TCollectionItem);
  3597. begin
  3598.   if Item <> nil then
  3599.     FHeaderControl.UpdateSection(Item.Index) else
  3600.     FHeaderControl.UpdateSections;
  3601. end;
  3602.  
  3603. { THeaderControl }
  3604.  
  3605. constructor THeaderControl.Create(AOwner: TComponent);
  3606. begin
  3607.   inherited Create(AOwner);
  3608.   ControlStyle := [];
  3609.   Align := alTop;
  3610.   Height := 17;
  3611.   FSections := THeaderSections.Create(Self);
  3612.   FCanvas := TControlCanvas.Create;
  3613.   TControlCanvas(FCanvas).Control := Self;
  3614. end;
  3615.  
  3616. destructor THeaderControl.Destroy;
  3617. begin
  3618.   FCanvas.Free;
  3619.   FSections.Free;
  3620.   inherited Destroy;
  3621. end;
  3622.  
  3623. procedure THeaderControl.CreateParams(var Params: TCreateParams);
  3624. begin
  3625.   InitCommonControl(ICC_LISTVIEW_CLASSES);
  3626.   inherited CreateParams(Params);
  3627.   CreateSubClass(Params, 'SysHeader32');
  3628.   with Params do
  3629.   begin
  3630.     Style := Style or HDS_BUTTONS;
  3631.     if FHotTrack then Style := Style or HDS_HOTTRACK;
  3632.     WindowClass.style := WindowClass.style and not (CS_HREDRAW or CS_VREDRAW);
  3633.   end;
  3634. end;
  3635.  
  3636. procedure THeaderControl.CreateWnd;
  3637. begin
  3638.   inherited CreateWnd;
  3639.   UpdateSections;
  3640. end;
  3641.  
  3642. procedure THeaderControl.DrawSection(Section: THeaderSection;
  3643.   const Rect: TRect; Pressed: Boolean);
  3644. begin
  3645.   if Assigned(FOnDrawSection) then
  3646.     FOnDrawSection(Self, Section, Rect, Pressed) else
  3647.     FCanvas.FillRect(Rect);
  3648. end;
  3649.  
  3650. procedure THeaderControl.Resize;
  3651. begin
  3652.   if Assigned(FOnResize) then FOnResize(Self);
  3653. end;
  3654.  
  3655. procedure THeaderControl.SectionClick(Section: THeaderSection);
  3656. begin
  3657.   if Assigned(FOnSectionClick) then FOnSectionClick(Self, Section);
  3658. end;
  3659.  
  3660. procedure THeaderControl.SectionResize(Section: THeaderSection);
  3661. begin
  3662.   if Assigned(FOnSectionResize) then FOnSectionResize(Self, Section);
  3663. end;
  3664.  
  3665. procedure THeaderControl.SectionTrack(Section: THeaderSection;
  3666.   Width: Integer; State: TSectionTrackState);
  3667. begin
  3668.   if Assigned(FOnSectionTrack) then FOnSectionTrack(Self, Section, Width, State);
  3669. end;
  3670.  
  3671. procedure THeaderControl.SetHotTrack(Value: Boolean);
  3672. begin
  3673.   if FHotTrack <> Value then
  3674.   begin
  3675.     FHotTrack := Value;
  3676.     RecreateWnd;
  3677.   end;
  3678. end;
  3679.  
  3680. procedure THeaderControl.SetSections(Value: THeaderSections);
  3681. begin
  3682.   FSections.Assign(Value);
  3683. end;
  3684.  
  3685. procedure THeaderControl.UpdateItem(Message, Index: Integer);
  3686. var
  3687.   Item: THDItem;
  3688. begin
  3689.   with Sections[Index] do
  3690.   begin
  3691.     FillChar(Item, SizeOf(Item), 0);
  3692.     Item.mask := HDI_WIDTH or HDI_TEXT or HDI_FORMAT;
  3693.     Item.cxy := Width;
  3694.     Item.pszText := PChar(Text);
  3695.     Item.cchTextMax := Length(Text);
  3696.     case Alignment of
  3697.       taLeftJustify: Item.fmt := HDF_LEFT;
  3698.       taRightJustify: Item.fmt := HDF_RIGHT;
  3699.     else
  3700.       Item.fmt := HDF_CENTER;
  3701.     end;
  3702.     if Style = hsOwnerDraw then
  3703.       Item.fmt := Item.fmt or HDF_OWNERDRAW else
  3704.       Item.fmt := Item.fmt or HDF_STRING;
  3705.     SendMessage(Handle, Message, Index, Integer(@Item));
  3706.   end;
  3707. end;
  3708.  
  3709. procedure THeaderControl.UpdateSection(Index: Integer);
  3710. begin
  3711.   if HandleAllocated then UpdateItem(HDM_SETITEM, Index);
  3712. end;
  3713.  
  3714. procedure THeaderControl.UpdateSections;
  3715. var
  3716.   I: Integer;
  3717. begin
  3718.   if HandleAllocated then
  3719.   begin
  3720.     for I := 0 to SendMessage(Handle, HDM_GETITEMCOUNT, 0, 0) - 1 do
  3721.       SendMessage(Handle, HDM_DELETEITEM, 0, 0);
  3722.     for I := 0 to Sections.Count - 1 do UpdateItem(HDM_INSERTITEM, I);
  3723.   end;
  3724. end;
  3725.  
  3726. procedure THeaderControl.CNDrawItem(var Message: TWMDrawItem);
  3727. var
  3728.   SaveIndex: Integer;
  3729. begin
  3730.   with Message.DrawItemStruct^ do
  3731.   begin
  3732.     SaveIndex := SaveDC(hDC);
  3733.     FCanvas.Handle := hDC;
  3734.     FCanvas.Font := Font;
  3735.     FCanvas.Brush.Color := clBtnFace;
  3736.     FCanvas.Brush.Style := bsSolid;
  3737.     DrawSection(Sections[itemID], rcItem, itemState and ODS_SELECTED <> 0);
  3738.     FCanvas.Handle := 0;
  3739.     RestoreDC(hDC, SaveIndex);
  3740.   end;
  3741.   Message.Result := 1;
  3742. end;
  3743.  
  3744. procedure THeaderControl.CNNotify(var Message: TWMNotify);
  3745. var
  3746.   Section: THeaderSection;
  3747.   TrackState: TSectionTrackState;
  3748. begin
  3749.   with PHDNotify(Message.NMHdr)^ do
  3750.     case Hdr.code of
  3751.       HDN_ITEMCLICK:
  3752.         SectionClick(Sections[Item]);
  3753.       HDN_ITEMCHANGED:
  3754.         if PItem^.mask and HDI_WIDTH <> 0 then
  3755.         begin
  3756.           Section := Sections[Item];
  3757.           if Section.FWidth <> PItem^.cxy then
  3758.           begin
  3759.             Section.FWidth := PItem^.cxy;
  3760.             SectionResize(Section);
  3761.           end;
  3762.         end;
  3763.       HDN_BEGINTRACK, HDN_TRACK, HDN_ENDTRACK:
  3764.         begin
  3765.           Section := Sections[Item];
  3766.           case Hdr.code of
  3767.             HDN_BEGINTRACK: TrackState := tsTrackBegin;
  3768.             HDN_ENDTRACK: TrackState := tsTrackEnd;
  3769.           else
  3770.             TrackState := tsTrackMove;
  3771.           end;
  3772.           with PItem^ do
  3773.           begin
  3774.             if cxy < Section.FMinWidth then cxy := Section.FMinWidth;
  3775.             if cxy > Section.FMaxWidth then cxy := Section.FMaxWidth;
  3776.             SectionTrack(Sections[Item], cxy, TrackState);
  3777.           end;
  3778.         end;
  3779.     end;
  3780. end;
  3781.  
  3782. procedure THeaderControl.WMLButtonDown(var Message: TWMLButtonDown);
  3783. var
  3784.   Index: Integer;
  3785.   Info: THDHitTestInfo;
  3786. begin
  3787.   Info.Point.X := Message.Pos.X;
  3788.   Info.Point.Y := Message.Pos.Y;
  3789.   Index := SendMessage(Handle, HDM_HITTEST, 0, Integer(@Info));
  3790.   if (Index < 0) or (Info.Flags and HHT_ONHEADER = 0) or
  3791.     Sections[Index].AllowClick then inherited;
  3792. end;
  3793.  
  3794. procedure THeaderControl.WMSize(var Message: TWMSize);
  3795. begin
  3796.   inherited;
  3797.   if not (csLoading in ComponentState) then Resize;
  3798. end;
  3799.  
  3800. procedure THeaderControl.WMWindowPosChanged(var Message: TWMWindowPosChanged);
  3801. begin
  3802.   inherited;
  3803.   Invalidate;
  3804. end;
  3805.  
  3806. { TTreeNode }
  3807.  
  3808. function DefaultTreeViewSort(Node1, Node2: TTreeNode; lParam: Integer): Integer; stdcall;
  3809. begin
  3810.   with Node1 do
  3811.     if Assigned(TreeView.OnCompare) then
  3812.       TreeView.OnCompare(TreeView, Node1, Node2, lParam, Result)
  3813.     else Result := lstrcmp(PChar(Node1.Text), PChar(Node2.Text));
  3814. end;
  3815.  
  3816. procedure TreeViewError(const Msg: string);
  3817. begin
  3818.   raise ETreeViewError.Create(Msg);
  3819. end;
  3820.  
  3821. procedure TreeViewErrorFmt(const Msg: string; Format: array of const);
  3822. begin
  3823.   raise ETreeViewError.CreateFmt(Msg, Format);
  3824. end;
  3825.  
  3826. constructor TTreeNode.Create(AOwner: TTreeNodes);
  3827. begin
  3828.   inherited Create;
  3829.   FOverlayIndex := -1;
  3830.   FStateIndex := -1;
  3831.   FOwner := AOwner;
  3832. end;
  3833.  
  3834. destructor TTreeNode.Destroy;
  3835. var
  3836.   Node: TTreeNode;
  3837.   CheckValue: Integer;
  3838. begin
  3839.   FDeleting := True;
  3840.   if Owner.Owner.FLastDropTarget = Self then
  3841.     Owner.Owner.FLastDropTarget := nil;
  3842.   Node := Parent;
  3843.   if (Node <> nil) and (not Node.Deleting) then
  3844.   begin
  3845.     if Node.IndexOf(Self) <> -1 then CheckValue := 1
  3846.     else CheckValue := 0;
  3847.     if Node.CompareCount(CheckValue) then
  3848.     begin
  3849.       Expanded := False;
  3850.       Node.HasChildren := False;
  3851.     end;
  3852.   end;
  3853.   if ItemId <> nil then TreeView_DeleteItem(Handle, ItemId);
  3854.   Data := nil;
  3855.   inherited Destroy;
  3856. end;
  3857.  
  3858. function TTreeNode.GetHandle: HWND;
  3859. begin
  3860.   Result := TreeView.Handle;
  3861. end;
  3862.  
  3863. function TTreeNode.GetTreeView: TCustomTreeView;
  3864. begin
  3865.   Result := Owner.Owner;
  3866. end;
  3867.  
  3868. function TTreeNode.HasAsParent(Value: TTreeNode): Boolean;
  3869. begin
  3870.   if Value <> Nil then
  3871.   begin
  3872.     if Parent = Nil then Result := False
  3873.     else if Parent = Value then Result := True
  3874.     else Result := Parent.HasAsParent(Value);
  3875.   end
  3876.   else Result := True;
  3877. end;
  3878.  
  3879. procedure TTreeNode.SetText(const S: string);
  3880. var
  3881.   Item: TTVItem;
  3882. begin
  3883.   FText := S;
  3884.   with Item do
  3885.   begin
  3886.     mask := TVIF_TEXT;
  3887.     hItem := ItemId;
  3888.     pszText := LPSTR_TEXTCALLBACK;
  3889.   end;
  3890.   TreeView_SetItem(Handle, Item);
  3891.   if (TreeView.SortType in [stText, stBoth]) and FInTree then
  3892.   begin
  3893.     if (Parent <> nil) then Parent.AlphaSort
  3894.     else TreeView.AlphaSort;
  3895.   end;
  3896. end;
  3897.  
  3898. procedure TTreeNode.SetData(Value: Pointer);
  3899. begin
  3900.   FData := Value;
  3901.   if (TreeView.SortType in [stData, stBoth]) and Assigned(TreeView.OnCompare)
  3902.     and (not Deleting) and FInTree then
  3903.   begin
  3904.     if Parent <> nil then Parent.AlphaSort
  3905.     else TreeView.AlphaSort;
  3906.   end;
  3907. end;
  3908.  
  3909. function TTreeNode.GetState(NodeState: TNodeState): Boolean;
  3910. var
  3911.   Item: TTVItem;
  3912. begin
  3913.   Result := False;
  3914.   with Item do
  3915.   begin
  3916.     mask := TVIF_STATE;
  3917.     hItem := ItemId;
  3918.     if TreeView_GetItem(Handle, Item) then
  3919.       case NodeState of
  3920.         nsCut: Result := (state and TVIS_CUT) <> 0;
  3921.         nsFocused: Result := (state and TVIS_FOCUSED) <> 0;
  3922.         nsSelected: Result := (state and TVIS_SELECTED) <> 0;
  3923.         nsExpanded: Result := (state and TVIS_EXPANDED) <> 0;
  3924.         nsDropHilited: Result := (state and TVIS_DROPHILITED) <> 0;
  3925.       end;
  3926.   end;
  3927. end;
  3928.  
  3929. procedure TTreeNode.SetImageIndex(Value: Integer);
  3930. var
  3931.   Item: TTVItem;
  3932. begin
  3933.   FImageIndex := Value;
  3934.   with Item do
  3935.   begin
  3936.     mask := TVIF_IMAGE or TVIF_HANDLE;
  3937.     hItem := ItemId;
  3938.     iImage := I_IMAGECALLBACK;
  3939.   end;
  3940.   TreeView_SetItem(Handle, Item);
  3941. end;
  3942.  
  3943. procedure TTreeNode.SetSelectedIndex(Value: Integer);
  3944. var
  3945.   Item: TTVItem;
  3946. begin
  3947.   FSelectedIndex := Value;
  3948.   with Item do
  3949.   begin
  3950.     mask := TVIF_SELECTEDIMAGE or TVIF_HANDLE;
  3951.     hItem := ItemId;
  3952.     iSelectedImage := I_IMAGECALLBACK;
  3953.   end;
  3954.   TreeView_SetItem(Handle, Item);
  3955. end;
  3956.  
  3957. procedure TTreeNode.SetOverlayIndex(Value: Integer);
  3958. var
  3959.   Item: TTVItem;
  3960. begin
  3961.   FOverlayIndex := Value;
  3962.   with Item do
  3963.   begin
  3964.     mask := TVIF_STATE or TVIF_HANDLE;
  3965.     stateMask := TVIS_OVERLAYMASK;
  3966.     hItem := ItemId;
  3967.     state := IndexToOverlayMask(OverlayIndex + 1);
  3968.   end;
  3969.   TreeView_SetItem(Handle, Item);
  3970. end;
  3971.  
  3972. procedure TTreeNode.SetStateIndex(Value: Integer);
  3973. var
  3974.   Item: TTVItem;
  3975. begin
  3976.   FStateIndex := Value;
  3977.   if Value >= 0 then Dec(Value);
  3978.   with Item do
  3979.   begin
  3980.     mask := TVIF_STATE or TVIF_HANDLE;
  3981.     stateMask := TVIS_STATEIMAGEMASK;
  3982.     hItem := ItemId;
  3983.     state := IndexToStateImageMask(Value + 1);
  3984.   end;
  3985.   TreeView_SetItem(Handle, Item);
  3986. end;
  3987.  
  3988. function TTreeNode.CompareCount(CompareMe: Integer): Boolean;
  3989. var
  3990.   Count: integer;
  3991.   Node: TTreeNode;
  3992. Begin
  3993.   Count := 0;
  3994.   Result := False;
  3995.   Node := GetFirstChild;
  3996.   while Node <> nil do
  3997.   begin
  3998.     Inc(Count);
  3999.     Node := Node.GetNextChild(Node);
  4000.     if Count > CompareMe then Exit;
  4001.   end;
  4002.   if Count = CompareMe then Result := True;
  4003. end;
  4004.  
  4005. function TTreeNode.DoCanExpand(Expand: Boolean): Boolean;
  4006. begin
  4007.   Result := False;
  4008.   if HasChildren then
  4009.   begin
  4010.     if Expand then Result := TreeView.CanExpand(Self)
  4011.     else Result := TreeView.CanCollapse(Self);
  4012.   end;
  4013. end;
  4014.  
  4015. procedure TTreeNode.DoExpand(Expand: Boolean);
  4016. begin
  4017.   if HasChildren then
  4018.   begin
  4019.     if Expand then TreeView.Expand(Self)
  4020.     else TreeView.Collapse(Self);
  4021.   end;
  4022. end;
  4023.  
  4024. procedure TTreeNode.ExpandItem(Expand: Boolean; Recurse: Boolean);
  4025. var
  4026.   Flag: Integer;
  4027.   Node: TTreeNode;
  4028. begin
  4029.   if Recurse then
  4030.   begin
  4031.     Node := Self;
  4032.     repeat
  4033.       Node.ExpandItem(Expand, False);
  4034.       Node := Node.GetNext;
  4035.     until (Node = nil) or (not Node.HasAsParent(Self));
  4036.   end
  4037.   else begin
  4038.     TreeView.FManualNotify := True;
  4039.     try
  4040.       Flag := 0;
  4041.       if Expand then
  4042.       begin
  4043.         if DoCanExpand(True) then
  4044.         begin
  4045.           Flag := TVE_EXPAND;
  4046.           DoExpand(True);
  4047.         end;
  4048.       end
  4049.       else begin
  4050.         if DoCanExpand(False) then
  4051.         begin
  4052.           Flag := TVE_COLLAPSE;
  4053.           DoExpand(False);
  4054.         end;
  4055.       end;
  4056.       if Flag <> 0 then TreeView_Expand(Handle, ItemId, Flag);
  4057.     finally
  4058.       TreeView.FManualNotify := False;
  4059.     end;
  4060.   end;
  4061. end;
  4062.  
  4063. procedure TTreeNode.Expand(Recurse: Boolean);
  4064. begin
  4065.   ExpandItem(True, Recurse);
  4066. end;
  4067.  
  4068. procedure TTreeNode.Collapse(Recurse: Boolean);
  4069. begin
  4070.   ExpandItem(False, Recurse);
  4071. end;
  4072.  
  4073. function TTreeNode.GetExpanded: Boolean;
  4074. begin
  4075.   Result := GetState(nsExpanded);
  4076. end;
  4077.  
  4078. procedure TTreeNode.SetExpanded(Value: Boolean);
  4079. begin
  4080.   if Value then Expand(False)
  4081.   else Collapse(False);
  4082. end;
  4083.  
  4084. function TTreeNode.GetSelected: Boolean;
  4085. begin
  4086.   Result := GetState(nsSelected);
  4087. end;
  4088.  
  4089. procedure TTreeNode.SetSelected(Value: Boolean);
  4090. begin
  4091.   if Value then TreeView_SelectItem(Handle, ItemId)
  4092.   else if Selected then TreeView_SelectItem(Handle, nil);
  4093. end;
  4094.  
  4095. function TTreeNode.GetCut: Boolean;
  4096. begin
  4097.   Result := GetState(nsCut);
  4098. end;
  4099.  
  4100. procedure TTreeNode.SetCut(Value: Boolean);
  4101. var
  4102.   Item: TTVItem;
  4103.   Template: Integer;
  4104. begin
  4105.   if Value then Template := -1
  4106.   else Template := 0;
  4107.   with Item do
  4108.   begin
  4109.     mask := TVIF_STATE;
  4110.     hItem := ItemId;
  4111.     stateMask := TVIS_CUT;
  4112.     state := stateMask and Template;
  4113.   end;
  4114.   TreeView_SetItem(Handle, Item);
  4115. end;
  4116.  
  4117. function TTreeNode.GetDropTarget: Boolean;
  4118. begin
  4119.   Result := GetState(nsDropHilited);
  4120. end;
  4121.  
  4122. procedure TTreeNode.SetDropTarget(Value: Boolean);
  4123. begin
  4124.   if Value then TreeView_SelectDropTarget(Handle, ItemId)
  4125.   else if DropTarget then TreeView_SelectDropTarget(Handle, nil);
  4126. end;
  4127.  
  4128. function TTreeNode.GetChildren: Boolean;
  4129. var
  4130.   Item: TTVItem;
  4131. begin
  4132.   Item.mask := TVIF_CHILDREN;
  4133.   Item.hItem := ItemId;
  4134.   if TreeView_GetItem(Handle, Item) then Result := Item.cChildren > 0
  4135.   else Result := False;
  4136. end;
  4137.  
  4138. procedure TTreeNode.SetFocused(Value: Boolean);
  4139. var
  4140.   Item: TTVItem;
  4141.   Template: Integer;
  4142. begin
  4143.   if Value then Template := -1
  4144.   else Template := 0;
  4145.   with Item do
  4146.   begin
  4147.     mask := TVIF_STATE;
  4148.     hItem := ItemId;
  4149.     stateMask := TVIS_FOCUSED;
  4150.     state := stateMask and Template;
  4151.   end;
  4152.   TreeView_SetItem(Handle, Item);
  4153. end;
  4154.  
  4155. function TTreeNode.GetFocused: Boolean;
  4156. begin
  4157.   Result := GetState(nsFocused);
  4158. end;
  4159.  
  4160. procedure TTreeNode.SetChildren(Value: Boolean);
  4161. var
  4162.   Item: TTVItem;
  4163. begin
  4164.   with Item do
  4165.   begin
  4166.     mask := TVIF_CHILDREN;
  4167.     hItem := ItemId;
  4168.     cChildren := Ord(Value);
  4169.   end;
  4170.   TreeView_SetItem(Handle, Item);
  4171. end;
  4172.  
  4173. function TTreeNode.GetParent: TTreeNode;
  4174. begin
  4175.   with FOwner do
  4176.     Result := GetNode(TreeView_GetParent(Handle, ItemId));
  4177. end;
  4178.  
  4179. function TTreeNode.GetNextSibling: TTreeNode;
  4180. begin
  4181.   with FOwner do
  4182.     Result := GetNode(TreeView_GetNextSibling(Handle, ItemId));
  4183. end;
  4184.  
  4185. function TTreeNode.GetPrevSibling: TTreeNode;
  4186. begin
  4187.   with FOwner do
  4188.     Result := GetNode(TreeView_GetPrevSibling(Handle, ItemId));
  4189. end;
  4190.  
  4191. function TTreeNode.GetNextVisible: TTreeNode;
  4192. begin
  4193.   if IsVisible then
  4194.     with FOwner do
  4195.       Result := GetNode(TreeView_GetNextVisible(Handle, ItemId))
  4196.   else Result := nil;
  4197. end;
  4198.  
  4199. function TTreeNode.GetPrevVisible: TTreeNode;
  4200. begin
  4201.   with FOwner do
  4202.     Result := GetNode(TreeView_GetPrevVisible(Handle, ItemId));
  4203. end;
  4204.  
  4205. function TTreeNode.GetNextChild(Value: TTreeNode): TTreeNode;
  4206. begin
  4207.   if Value <> nil then Result := Value.GetNextSibling
  4208.   else Result := nil;
  4209. end;
  4210.  
  4211. function TTreeNode.GetPrevChild(Value: TTreeNode): TTreeNode;
  4212. begin
  4213.   if Value <> nil then Result := Value.GetPrevSibling
  4214.   else Result := nil;
  4215. end;
  4216.  
  4217. function TTreeNode.GetFirstChild: TTreeNode;
  4218. begin
  4219.   with FOwner do
  4220.     Result := GetNode(TreeView_GetChild(Handle, ItemId));
  4221. end;
  4222.  
  4223. function TTreeNode.GetLastChild: TTreeNode;
  4224. var
  4225.   Node: TTreeNode;
  4226. begin
  4227.   Result := GetFirstChild;
  4228.   if Result <> nil then
  4229.   begin
  4230.     Node := Result;
  4231.     repeat
  4232.       Result := Node;
  4233.       Node := Result.GetNextSibling;
  4234.     until Node = nil;
  4235.   end;
  4236. end;
  4237.  
  4238. function TTreeNode.GetNext: TTreeNode;
  4239. var
  4240.   NodeID, ParentID: HTreeItem;
  4241.   Handle: HWND;
  4242. begin
  4243.   Handle := FOwner.Handle;
  4244.   NodeID := TreeView_GetChild(Handle, ItemId);
  4245.   if NodeID = nil then NodeID := TreeView_GetNextSibling(Handle, ItemId);
  4246.   ParentID := ItemId;
  4247.   while (NodeID = nil) and (ParentID <> nil) do
  4248.   begin
  4249.     ParentID := TreeView_GetParent(Handle, ParentID);
  4250.     NodeID := TreeView_GetNextSibling(Handle, ParentID);
  4251.   end;
  4252.   Result := FOwner.GetNode(NodeID);
  4253. end;
  4254.  
  4255. function TTreeNode.GetPrev: TTreeNode;
  4256. var
  4257.   Node: TTreeNode;
  4258. begin
  4259.   Result := GetPrevSibling;
  4260.   if Result <> nil then
  4261.   begin
  4262.     Node := Result;
  4263.     repeat
  4264.       Result := Node;
  4265.       Node := Result.GetLastChild;
  4266.     until Node = nil;
  4267.   end else
  4268.     Result := Parent;
  4269. end;
  4270.  
  4271. function TTreeNode.GetAbsoluteIndex: Integer;
  4272. var
  4273.   Node: TTreeNode;
  4274. begin
  4275.   Result := -1;
  4276.   Node := Self;
  4277.   while Node <> nil do
  4278.   begin
  4279.     Inc(Result);
  4280.     Node := Node.GetPrev;
  4281.   end;
  4282. end;
  4283.  
  4284. function TTreeNode.GetIndex: Integer;
  4285. var
  4286.   Node: TTreeNode;
  4287. begin
  4288.   Result := -1;
  4289.   Node := Self;
  4290.   while Node <> nil do
  4291.   begin
  4292.     Inc(Result);
  4293.     Node := Node.GetPrevSibling;
  4294.   end;
  4295. end;
  4296.  
  4297. function TTreeNode.GetItem(Index: Integer): TTreeNode;
  4298. begin
  4299.   Result := GetFirstChild;
  4300.   while (Result <> nil) and (Index > 0) do
  4301.   begin
  4302.     Result := GetNextChild(Result);
  4303.     Dec(Index);
  4304.   end;
  4305.   if Result = nil then TreeViewError(SListIndexError);
  4306. end;
  4307.  
  4308. procedure TTreeNode.SetItem(Index: Integer; Value: TTreeNode);
  4309. begin
  4310.   item[Index].Assign(Value);
  4311. end;
  4312.  
  4313. function TTreeNode.IndexOf(Value: TTreeNode): Integer;
  4314. var
  4315.   Node: TTreeNode;
  4316. begin
  4317.   Result := -1;
  4318.   Node := GetFirstChild;
  4319.   while (Node <> nil) do
  4320.   begin
  4321.     Inc(Result);
  4322.     if Node = Value then Break;
  4323.     Node := GetNextChild(Node);
  4324.   end;
  4325.   if Node = nil then Result := -1;
  4326. end;
  4327.  
  4328. function TTreeNode.GetCount: Integer;
  4329. var
  4330.   Node: TTreeNode;
  4331. begin
  4332.   Result := 0;
  4333.   Node := GetFirstChild;
  4334.   while Node <> nil do
  4335.   begin
  4336.     Inc(Result);
  4337.     Node := Node.GetNextChild(Node);
  4338.   end;
  4339. end;
  4340.  
  4341. procedure TTreeNode.EndEdit(Cancel: Boolean);
  4342. begin
  4343.   TreeView_EndEditLabelNow(Handle, Cancel);
  4344. end;
  4345.  
  4346. procedure TTreeNode.InternalMove(ParentNode, Node: TTreeNode;
  4347.   HItem: HTreeItem; AddMode: TAddMode);
  4348. var
  4349.   I: Integer;
  4350.   NodeId: HTreeItem;
  4351.   TreeViewItem: TTVItem;
  4352.   Children: Boolean;
  4353.   IsSelected: Boolean;
  4354. begin
  4355.   if (AddMode = taInsert) and (Node <> nil) then
  4356.     NodeId := Node.ItemId else
  4357.     NodeId := nil;
  4358.   Children := HasChildren;
  4359.   IsSelected := Selected;
  4360.   if (Parent <> nil) and (Parent.CompareCount(1)) then
  4361.   begin
  4362.     Parent.Expanded := False;
  4363.     Parent.HasChildren := False;
  4364.   end;
  4365.   with TreeViewItem do
  4366.   begin
  4367.     mask := TVIF_PARAM;
  4368.     hItem := ItemId;
  4369.     lParam := 0;
  4370.   end;
  4371.   TreeView_SetItem(Handle, TreeViewItem);
  4372.   with Owner do
  4373.     HItem := AddItem(HItem, NodeId, CreateItem(Self), AddMode);
  4374.   if HItem = nil then
  4375.     raise EOutOfResources.Create(sInsertError);
  4376.   for I := Count - 1 downto 0 do
  4377.     Item[I].InternalMove(Self, nil, HItem, taAddFirst);
  4378.   TreeView_DeleteItem(Handle, ItemId);
  4379.   FItemId := HItem;
  4380.   Assign(Self);
  4381.   HasChildren := Children;
  4382.   Selected := IsSelected;
  4383. end;
  4384.  
  4385. procedure TTreeNode.MoveTo(Destination: TTreeNode; Mode: TNodeAttachMode);
  4386. var
  4387.   AddMode: TAddMode;
  4388.   Node: TTreeNode;
  4389.   HItem: HTreeItem;
  4390.   OldOnChanging: TTVChangingEvent;
  4391.   OldOnChange: TTVChangedEvent;
  4392. begin
  4393.   OldOnChanging := TreeView.OnChanging;
  4394.   OldOnChange := TreeView.OnChange;
  4395.   TreeView.OnChanging := nil;
  4396.   TreeView.OnChange := nil;
  4397.   try
  4398.     if (Destination = nil) or not Destination.HasAsParent(Self) then
  4399.     begin
  4400.       AddMode := taAdd;
  4401.       if (Destination <> nil) and not (Mode in [naAddChild, naAddChildFirst]) then
  4402.         Node := Destination.Parent else
  4403.         Node := Destination;
  4404.       case Mode of
  4405.         naAdd,
  4406.         naAddChild: AddMode := taAdd;
  4407.         naAddFirst,
  4408.         naAddChildFirst: AddMode := taAddFirst;
  4409.         naInsert:
  4410.           begin
  4411.             Destination := Destination.GetPrevSibling;
  4412.             if Destination = nil then AddMode := taAddFirst
  4413.             else AddMode := taInsert;
  4414.           end;
  4415.       end;
  4416.       if Node <> nil then
  4417.         HItem := Node.ItemId else
  4418.         HItem := nil;
  4419.       InternalMove(Node, Destination, HItem, AddMode);
  4420.       Node := Parent;
  4421.       if Node <> nil then
  4422.       begin
  4423.         Node.HasChildren := True;
  4424.         Node.Expanded := True;
  4425.       end;
  4426.     end;
  4427.   finally
  4428.     TreeView.OnChanging := OldOnChanging;
  4429.     TreeView.OnChange := OldOnChange;
  4430.   end;
  4431. end;
  4432.  
  4433. procedure TTreeNode.MakeVisible;
  4434. begin
  4435.   TreeView_EnsureVisible(Handle, ItemId);
  4436. end;
  4437.  
  4438. function TTreeNode.GetLevel: Integer;
  4439. var
  4440.   Node: TTreeNode;
  4441. begin
  4442.   Result := 0;
  4443.   Node := Parent;
  4444.   while Node <> nil do
  4445.   begin
  4446.     Inc(Result);
  4447.     Node := Node.Parent;
  4448.   end;
  4449. end;
  4450.  
  4451. function TTreeNode.IsNodeVisible: Boolean;
  4452. var
  4453.   Rect: TRect;
  4454. begin
  4455.   Result := TreeView_GetItemRect(Handle, ItemId, Rect, True);
  4456. end;
  4457.  
  4458. function TTreeNode.EditText: Boolean;
  4459. begin
  4460.   Result := TreeView_EditLabel(Handle, ItemId) <> 0;
  4461. end;
  4462.  
  4463. function TTreeNode.DisplayRect(TextOnly: Boolean): TRect;
  4464. begin
  4465.   FillChar(Result, SizeOf(Result), 0);
  4466.   TreeView_GetItemRect(Handle, ItemId, Result, TextOnly);
  4467. end;
  4468.  
  4469. function TTreeNode.AlphaSort: Boolean;
  4470. begin
  4471.   Result := CustomSort(nil, 0);
  4472. end;
  4473.  
  4474. function TTreeNode.CustomSort(SortProc: TTVCompare; Data: Longint): Boolean;
  4475. var
  4476.   SortCB: TTVSortCB;
  4477. begin
  4478.   with SortCB do
  4479.   begin
  4480.     if not Assigned(SortProc) then lpfnCompare := @DefaultTreeViewSort
  4481.     else lpfnCompare := SortProc;
  4482.     hParent := ItemId;
  4483.     lParam := Data;
  4484.   end;
  4485.   Result := TreeView_SortChildrenCB(Handle, SortCB, 0);
  4486. end;
  4487.  
  4488. procedure TTreeNode.Delete;
  4489. begin
  4490.   if not Deleting then Free;
  4491. end;
  4492.  
  4493. procedure TTreeNode.DeleteChildren;
  4494. begin
  4495.   TreeView_Expand(TreeView.Handle, ItemID, TVE_COLLAPSE or TVE_COLLAPSERESET);
  4496.   HasChildren := False;
  4497. end;
  4498.  
  4499. procedure TTreeNode.Assign(Source: TPersistent);
  4500. var
  4501.   Node: TTreeNode;
  4502. begin
  4503.   if Source is TTreeNode then
  4504.   begin
  4505.     Node := TTreeNode(Source);
  4506.     Text := Node.Text;
  4507.     Data := Node.Data;
  4508.     ImageIndex := Node.ImageIndex;
  4509.     SelectedIndex := Node.SelectedIndex;
  4510.     StateIndex := Node.StateIndex;
  4511.     OverlayIndex := Node.OverlayIndex;
  4512.     Focused := Node.Focused;
  4513.     DropTarget := Node.DropTarget;
  4514.     Cut := Node.Cut;
  4515.     HasChildren := Node.HasChildren;
  4516.   end
  4517.   else inherited Assign(Source);
  4518. end;
  4519.  
  4520. function TTreeNode.IsEqual(Node: TTreeNode): Boolean;
  4521. begin
  4522.   Result := (Text = Node.Text) and (Data = Node.Data);
  4523. end;
  4524.  
  4525. procedure TTreeNode.ReadData(Stream: TStream; Info: PNodeInfo);
  4526. var
  4527.   I, Size, ItemCount: Integer;
  4528. begin
  4529.   Stream.ReadBuffer(Size, SizeOf(Size));
  4530.   Stream.ReadBuffer(Info^, Size);
  4531.   Text := Info^.Text;
  4532.   ImageIndex := Info^.ImageIndex;
  4533.   SelectedIndex := Info^.SelectedIndex;
  4534.   StateIndex := Info^.StateIndex;
  4535.   OverlayIndex := Info^.OverlayIndex;
  4536.   Data := Info^.Data;
  4537.   ItemCount := Info^.Count;
  4538.   for I := 0 to ItemCount - 1 do
  4539.     with Owner.AddChild(Self, '') do ReadData(Stream, Info);
  4540. end;
  4541.  
  4542. procedure TTreeNode.WriteData(Stream: TStream; Info: PNodeInfo);
  4543. var
  4544.   I, Size, L, ItemCount: Integer;
  4545. begin
  4546.   L := Length(Text);
  4547.   if L > 255 then L := 255;
  4548.   Size := SizeOf(TNodeInfo) + L - 255;
  4549.   Info^.Text := Text;
  4550.   Info^.ImageIndex := ImageIndex;
  4551.   Info^.SelectedIndex := SelectedIndex;
  4552.   Info^.OverlayIndex := OverlayIndex;
  4553.   Info^.StateIndex := StateIndex;
  4554.   Info^.Data := Data;
  4555.   ItemCount := Count;
  4556.   Info^.Count := ItemCount;
  4557.   Stream.WriteBuffer(Size, SizeOf(Size));
  4558.   Stream.WriteBuffer(Info^, Size);
  4559.   for I := 0 to ItemCount - 1 do Item[I].WriteData(Stream, Info);
  4560. end;
  4561.  
  4562. { TTreeNodes }
  4563.  
  4564. constructor TTreeNodes.Create(AOwner: TCustomTreeView);
  4565. begin
  4566.   inherited Create;
  4567.   FOwner := AOwner;
  4568. end;
  4569.  
  4570. destructor TTreeNodes.Destroy;
  4571. begin
  4572.   Clear;
  4573.   inherited Destroy;
  4574. end;
  4575.  
  4576. function TTreeNodes.GetCount: Integer;
  4577. begin
  4578.   if Owner.HandleAllocated then Result := TreeView_GetCount(Handle)
  4579.   else Result := 0;
  4580. end;
  4581.  
  4582. function TTreeNodes.GetHandle: HWND;
  4583. begin
  4584.   Result := Owner.Handle;
  4585. end;
  4586.  
  4587. procedure TTreeNodes.Delete(Node: TTreeNode);
  4588. begin
  4589.   if (Node.ItemId = nil) and Assigned(Owner.FOnDeletion) then
  4590.     Owner.FOnDeletion(Self, Node);
  4591.   Node.Delete;
  4592. end;
  4593.  
  4594. procedure TTreeNodes.Clear;
  4595. begin
  4596.   if Owner.HandleAllocated then
  4597.     TreeView_DeleteAllItems(Handle);
  4598. end;
  4599.  
  4600. function TTreeNodes.AddChildFirst(Node: TTreeNode; const S: string): TTreeNode;
  4601. begin
  4602.   Result := AddChildObjectFirst(Node, S, nil);
  4603. end;
  4604.  
  4605. function TTreeNodes.AddChildObjectFirst(Node: TTreeNode; const S: string;
  4606.   Ptr: Pointer): TTreeNode;
  4607. begin
  4608.   Result := InternalAddObject(Node, S, Ptr, taAddFirst);
  4609. end;
  4610.  
  4611. function TTreeNodes.AddChild(Node: TTreeNode; const S: string): TTreeNode;
  4612. begin
  4613.   Result := AddChildObject(Node, S, nil);
  4614. end;
  4615.  
  4616. function TTreeNodes.AddChildObject(Node: TTreeNode; const S: string;
  4617.   Ptr: Pointer): TTreeNode;
  4618. begin
  4619.   Result := InternalAddObject(Node, S, Ptr, taAdd);
  4620. end;
  4621.  
  4622. function TTreeNodes.AddFirst(Node: TTreeNode; const S: string): TTreeNode;
  4623. begin
  4624.   Result := AddObjectFirst(Node, S, nil);
  4625. end;
  4626.  
  4627. function TTreeNodes.AddObjectFirst(Node: TTreeNode; const S: string;
  4628.   Ptr: Pointer): TTreeNode;
  4629. begin
  4630.   if Node <> nil then Node := Node.Parent;
  4631.   Result := InternalAddObject(Node, S, Ptr, taAddFirst);
  4632. end;
  4633.  
  4634. function TTreeNodes.Add(Node: TTreeNode; const S: string): TTreeNode;
  4635. begin
  4636.   Result := AddObject(Node, S, nil);
  4637. end;
  4638.  
  4639. procedure TTreeNodes.Repaint(Node: TTreeNode);
  4640. var
  4641.   R: TRect;
  4642. begin
  4643.   if FUpdateCount < 1 then
  4644.   begin
  4645.     while (Node <> nil) and not Node.IsVisible do Node := Node.Parent;
  4646.     if Node <> nil then
  4647.     begin
  4648.       R := Node.DisplayRect(False);
  4649.       InvalidateRect(Owner.Handle, @R, True);
  4650.     end;
  4651.   end;
  4652. end;
  4653.  
  4654. function TTreeNodes.AddObject(Node: TTreeNode; const S: string;
  4655.   Ptr: Pointer): TTreeNode;
  4656. begin
  4657.   if Node <> nil then Node := Node.Parent;
  4658.   Result := InternalAddObject(Node, S, Ptr, taAdd);
  4659. end;
  4660.  
  4661. function TTreeNodes.Insert(Node: TTreeNode; const S: string): TTreeNode;
  4662. begin
  4663.   Result := InsertObject(Node, S, nil);
  4664. end;
  4665.  
  4666. procedure TTreeNodes.AddedNode(Value: TTreeNode);
  4667. begin
  4668.   if Value <> nil then
  4669.   begin
  4670.     Value.HasChildren := True;
  4671.     Repaint(Value);
  4672.   end;
  4673. end;
  4674.  
  4675. function TTreeNodes.InsertObject(Node: TTreeNode; const S: string;
  4676.   Ptr: Pointer): TTreeNode;
  4677. var
  4678.   Item, ItemId: HTreeItem;
  4679.   Parent: TTreeNode;
  4680.   AddMode: TAddMode;
  4681. begin
  4682.   Result := Owner.CreateNode;
  4683.   try
  4684.     Item := nil;
  4685.     ItemId := nil;
  4686.     Parent := nil;
  4687.     AddMode := taInsert;
  4688.     if Node <> nil then
  4689.     begin
  4690.       Parent := Node.Parent;
  4691.       if Parent <> nil then Item := Parent.ItemId;
  4692.       Node := Node.GetPrevSibling;
  4693.       if Node <> nil then ItemId := Node.ItemId
  4694.       else AddMode := taAddFirst;
  4695.     end;
  4696.     Result.Data := Ptr;
  4697.     Result.Text := S;
  4698.     Item := AddItem(Item, ItemId, CreateItem(Result), AddMode);
  4699.     if Item = nil then
  4700.       raise EOutOfResources.Create(sInsertError);
  4701.     Result.FItemId := Item;
  4702.     AddedNode(Parent);
  4703.   except
  4704.     Result.Free;
  4705.     raise;
  4706.   end;
  4707. end;
  4708.  
  4709. function TTreeNodes.InternalAddObject(Node: TTreeNode; const S: string;
  4710.   Ptr: Pointer; AddMode: TAddMode): TTreeNode;
  4711. var
  4712.   Item: HTreeItem;
  4713. begin
  4714.   Result := Owner.CreateNode;
  4715.   try
  4716.     if Node <> nil then Item := Node.ItemId
  4717.     else Item := nil;
  4718.     Result.Data := Ptr;
  4719.     Result.Text := S;
  4720.     Item := AddItem(Item, nil, CreateItem(Result), AddMode);
  4721.     if Item = nil then
  4722.       raise EOutOfResources.Create(sInsertError);
  4723.     Result.FItemId := Item;
  4724.     AddedNode(Node);
  4725.   except
  4726.     Result.Free;
  4727.     raise;
  4728.   end;
  4729. end;
  4730.  
  4731. function TTreeNodes.CreateItem(Node: TTreeNode): TTVItem;
  4732. begin
  4733.   Node.FInTree := True;
  4734.   with Result do
  4735.   begin
  4736.     mask := TVIF_TEXT or TVIF_PARAM or TVIF_IMAGE or TVIF_SELECTEDIMAGE;
  4737.     lParam := Longint(Node);
  4738.     pszText := LPSTR_TEXTCALLBACK;
  4739.     iImage := I_IMAGECALLBACK;
  4740.     iSelectedImage := I_IMAGECALLBACK;
  4741.   end;
  4742. end;
  4743.  
  4744. function TTreeNodes.AddItem(Parent, Target: HTreeItem;
  4745.   const Item: TTVItem; AddMode: TAddMode): HTreeItem;
  4746. var
  4747.   InsertStruct: TTVInsertStruct;
  4748. begin
  4749.   with InsertStruct do
  4750.   begin
  4751.     hParent := Parent;
  4752.     case AddMode of
  4753.       taAddFirst:
  4754.         hInsertAfter := TVI_FIRST;
  4755.       taAdd:
  4756.         hInsertAfter := TVI_LAST;
  4757.       taInsert:
  4758.         hInsertAfter := Target;
  4759.     end;
  4760.   end;
  4761.   InsertStruct.item := Item;
  4762.   Result := TreeView_InsertItem(Handle, InsertStruct);
  4763. end;
  4764.  
  4765. function TTreeNodes.GetFirstNode: TTreeNode;
  4766. begin
  4767.   Result := GetNode(TreeView_GetRoot(Handle));
  4768. end;
  4769.  
  4770. function TTreeNodes.GetNodeFromIndex(Index: Integer): TTreeNode;
  4771. begin
  4772.   Result := GetFirstNode;
  4773.   while (Index <> 0) and (Result <> nil) do
  4774.   begin
  4775.     Result := Result.GetNext;
  4776.     Dec(Index);
  4777.   end;
  4778.   if Result = nil then TreeViewError(sInvalidIndex);
  4779. end;
  4780.  
  4781. function TTreeNodes.GetNode(ItemId: HTreeItem): TTreeNode;
  4782. var
  4783.   Item: TTVItem;
  4784. begin
  4785.   with Item do
  4786.   begin
  4787.     hItem := ItemId;
  4788.     mask := TVIF_PARAM;
  4789.   end;
  4790.   if TreeView_GetItem(Handle, Item) then Result := TTreeNode(Item.lParam)
  4791.   else Result := nil;
  4792. end;
  4793.  
  4794. procedure TTreeNodes.SetItem(Index: Integer; Value: TTreeNode);
  4795. begin
  4796.   GetNodeFromIndex(Index).Assign(Value);
  4797. end;
  4798.  
  4799. procedure TTreeNodes.BeginUpdate;
  4800. begin
  4801.   if FUpdateCount = 0 then SetUpdateState(True);
  4802.   Inc(FUpdateCount);
  4803. end;
  4804.  
  4805. procedure TTreeNodes.SetUpdateState(Updating: Boolean);
  4806. begin
  4807.   SendMessage(Handle, WM_SETREDRAW, Ord(not Updating), 0);
  4808.   if Updating then Owner.Refresh;
  4809. end;
  4810.  
  4811. procedure TTreeNodes.EndUpdate;
  4812. begin
  4813.   Dec(FUpdateCount);
  4814.   if FUpdateCount = 0 then SetUpdateState(False);
  4815. end;
  4816.  
  4817. procedure TTreeNodes.Assign(Source: TPersistent);
  4818. var
  4819.   TreeNodes: TTreeNodes;
  4820.   MemStream: TMemoryStream;
  4821. begin
  4822.   if Source is TTreeNodes then
  4823.   begin
  4824.     TreeNodes := TTreeNodes(Source);
  4825.     Clear;
  4826.     MemStream := TMemoryStream.Create;
  4827.     try
  4828.       TreeNodes.WriteData(MemStream);
  4829.       MemStream.Position := 0;
  4830.       ReadData(MemStream);
  4831.     finally
  4832.       MemStream.Free;
  4833.     end;
  4834.   end
  4835.   else inherited Assign(Source);
  4836. end;
  4837.  
  4838. procedure TTreeNodes.DefineProperties(Filer: TFiler);
  4839.  
  4840.   function WriteNodes: Boolean;
  4841.   var
  4842.     I: Integer;
  4843.     Nodes: TTreeNodes;
  4844.   begin
  4845.     Nodes := TTreeNodes(Filer.Ancestor);
  4846.     if Nodes = nil then
  4847.       Result := Count > 0
  4848.     else if Nodes.Count <> Count then
  4849.       Result := True
  4850.     else
  4851.     begin
  4852.       Result := False;
  4853.       for I := 0 to Count - 1 do
  4854.       begin
  4855.         Result := not Item[I].IsEqual(Nodes[I]);
  4856.         if Result then Break;
  4857.       end
  4858.     end;
  4859.   end;
  4860.  
  4861. begin
  4862.   inherited DefineProperties(Filer);
  4863.   Filer.DefineBinaryProperty('Data', ReadData, WriteData, WriteNodes);
  4864. end;
  4865.  
  4866. procedure TTreeNodes.ReadData(Stream: TStream);
  4867. var
  4868.   I, Count: Integer;
  4869.   NodeInfo: TNodeInfo;
  4870. begin
  4871.   Clear;
  4872.   Stream.ReadBuffer(Count, SizeOf(Count));
  4873.   for I := 0 to Count - 1 do
  4874.     Add(nil, '').ReadData(Stream, @NodeInfo);
  4875. end;
  4876.  
  4877. procedure TTreeNodes.WriteData(Stream: TStream);
  4878. var
  4879.   I: Integer;
  4880.   Node: TTreeNode;
  4881.   NodeInfo: TNodeInfo;
  4882. begin
  4883.   I := 0;
  4884.   Node := GetFirstNode;
  4885.   while Node <> nil do
  4886.   begin
  4887.     Inc(I);
  4888.     Node := Node.GetNextSibling;
  4889.   end;
  4890.   Stream.WriteBuffer(I, SizeOf(I));
  4891.   Node := GetFirstNode;
  4892.   while Node <> nil do
  4893.   begin
  4894.     Node.WriteData(Stream, @NodeInfo);
  4895.     Node := Node.GetNextSibling;
  4896.   end;
  4897. end;
  4898.  
  4899. type
  4900.   TTreeStrings = class(TStrings)
  4901.   private
  4902.     FOwner: TTreeNodes;
  4903.   protected
  4904.     function Get(Index: Integer): string; override;
  4905.     function GetBufStart(Buffer: PChar; var Level: Integer): PChar;
  4906.     function GetCount: Integer; override;
  4907.     function GetObject(Index: Integer): TObject; override;
  4908.     procedure PutObject(Index: Integer; AObject: TObject); override;
  4909.     procedure SetUpdateState(Updating: Boolean); override;
  4910.   public
  4911.     constructor Create(AOwner: TTreeNodes);
  4912.     function Add(const S: string): Integer; override;
  4913.     procedure Clear; override;
  4914.     procedure Delete(Index: Integer); override;
  4915.     procedure Insert(Index: Integer; const S: string); override;
  4916.     procedure LoadTreeFromStream(Stream: TStream);
  4917.     procedure SaveTreeToStream(Stream: TStream);
  4918.     property Owner: TTreeNodes read FOwner;
  4919.   end;
  4920.  
  4921. constructor TTreeStrings.Create(AOwner: TTreeNodes);
  4922. begin
  4923.   inherited Create;
  4924.   FOwner := AOwner;
  4925. end;
  4926.  
  4927. function TTreeStrings.Get(Index: Integer): string;
  4928. const
  4929.   TabChar = #9;
  4930. var
  4931.   Level, I: Integer;
  4932.   Node: TTreeNode;
  4933. begin
  4934.   Result := '';
  4935.   Node := Owner.GetNodeFromIndex(Index);
  4936.   Level := Node.Level;
  4937.   for I := 0 to Level - 1 do Result := Result + TabChar;
  4938.   Result := Result + Node.Text;
  4939. end;
  4940.  
  4941. function TTreeStrings.GetBufStart(Buffer: PChar; var Level: Integer): PChar;
  4942. begin
  4943.   Level := 0;
  4944.   while Buffer^ in [' ', #9] do
  4945.   begin
  4946.     Inc(Buffer);
  4947.     Inc(Level);
  4948.   end;
  4949.   Result := Buffer;
  4950. end;
  4951.  
  4952. function TTreeStrings.GetObject(Index: Integer): TObject;
  4953. begin
  4954.   Result := Owner.GetNodeFromIndex(Index).Data;
  4955. end;
  4956.  
  4957. procedure TTreeStrings.PutObject(Index: Integer; AObject: TObject);
  4958. begin
  4959.   Owner.GetNodeFromIndex(Index).Data := AObject;
  4960. end;
  4961.  
  4962. function TTreeStrings.GetCount: Integer;
  4963. begin
  4964.   Result := Owner.Count;
  4965. end;
  4966.  
  4967. procedure TTreeStrings.Clear;
  4968. begin
  4969.   Owner.Clear;
  4970. end;
  4971.  
  4972. procedure TTreeStrings.Delete(Index: Integer);
  4973. begin
  4974.   Owner.GetNodeFromIndex(Index).Delete;
  4975. end;
  4976.  
  4977. procedure TTreeStrings.SetUpdateState(Updating: Boolean);
  4978. begin
  4979.   SendMessage(Owner.Handle, WM_SETREDRAW, Ord(not Updating), 0);
  4980.   if not Updating then Owner.Owner.Refresh;
  4981. end;
  4982.  
  4983. function TTreeStrings.Add(const S: string): Integer;
  4984. var
  4985.   Level, OldLevel, I: Integer;
  4986.   NewStr: string;
  4987.   Node: TTreeNode;
  4988. begin
  4989.   Result := GetCount;
  4990.   if (Length(S) = 1) and (S[1] = Chr($1A)) then Exit;
  4991.   Node := nil;
  4992.   OldLevel := 0;
  4993.   NewStr := GetBufStart(PChar(S), Level);
  4994.   if Result > 0 then
  4995.   begin
  4996.     Node := Owner.GetNodeFromIndex(Result - 1);
  4997.     OldLevel := Node.Level;
  4998.   end;
  4999.   if (Level > OldLevel) or (Node = nil) then
  5000.   begin
  5001.     if Level - OldLevel > 1 then TreeViewError(sInvalidLevel);
  5002.   end
  5003.   else begin
  5004.     for I := OldLevel downto Level do
  5005.     begin
  5006.       Node := Node.Parent;
  5007.       if (Node = nil) and (I - Level > 0) then
  5008.         TreeViewError(sInvalidLevel);
  5009.     end;
  5010.   end;
  5011.   Owner.AddChild(Node, NewStr);
  5012. end;
  5013.  
  5014. procedure TTreeStrings.Insert(Index: Integer; const S: string);
  5015. begin
  5016.   with Owner do
  5017.     Insert(GetNodeFromIndex(Index), S);
  5018. end;
  5019.  
  5020. procedure TTreeStrings.LoadTreeFromStream(Stream: TStream);
  5021. var
  5022.   List: TStringList;
  5023.   ANode, NextNode: TTreeNode;
  5024.   ALevel, i: Integer;
  5025.   CurrStr: string;
  5026. begin
  5027.   List := TStringList.Create;
  5028.   Owner.BeginUpdate;
  5029.   try
  5030.     try
  5031.       Clear;
  5032.       List.LoadFromStream(Stream);
  5033.       ANode := nil;
  5034.       for i := 0 to List.Count - 1 do
  5035.       begin
  5036.         CurrStr := GetBufStart(PChar(List[i]), ALevel);
  5037.         if ANode = nil then
  5038.           ANode := Owner.AddChild(nil, CurrStr)
  5039.         else if ANode.Level = ALevel then
  5040.           ANode := Owner.AddChild(ANode.Parent, CurrStr)
  5041.         else if ANode.Level = (ALevel - 1) then
  5042.           ANode := Owner.AddChild(ANode, CurrStr)
  5043.         else if ANode.Level > ALevel then
  5044.         begin
  5045.           NextNode := ANode.Parent;
  5046.           while NextNode.Level > ALevel do
  5047.             NextNode := NextNode.Parent;
  5048.           ANode := Owner.AddChild(NextNode.Parent, CurrStr);
  5049.         end
  5050.         else TreeViewErrorFmt(sInvalidLevelEx, [ALevel, CurrStr]);
  5051.       end;
  5052.     finally
  5053.       Owner.EndUpdate;
  5054.       List.Free;
  5055.     end;
  5056.   except
  5057.     Owner.Owner.Invalidate;  // force repaint on exception
  5058.     raise;
  5059.   end;
  5060. end;
  5061.  
  5062. procedure TTreeStrings.SaveTreeToStream(Stream: TStream);
  5063. const
  5064.   TabChar = #9;
  5065.   EndOfLine = #13#10;
  5066. var
  5067.   i: Integer;
  5068.   ANode: TTreeNode;
  5069.   NodeStr: string;
  5070. begin
  5071.   if Count > 0 then
  5072.   begin
  5073.     ANode := Owner[0];
  5074.     while ANode <> nil do
  5075.     begin
  5076.       NodeStr := '';
  5077.       for i := 0 to ANode.Level - 1 do NodeStr := NodeStr + TabChar;
  5078.       NodeStr := NodeStr + ANode.Text + EndOfLine;
  5079.       Stream.Write(Pointer(NodeStr)^, Length(NodeStr));
  5080.       ANode := ANode.GetNext;
  5081.     end;
  5082.   end;
  5083. end;
  5084.  
  5085. { TCustomTreeView }
  5086.  
  5087. constructor TCustomTreeView.Create(AOwner: TComponent);
  5088. begin
  5089.   inherited Create(AOwner);
  5090.   ControlStyle := ControlStyle - [csCaptureMouse] + [csDisplayDragImage, csReflector];
  5091.   Width := 121;
  5092.   Height := 97;
  5093.   TabStop := True;
  5094.   ParentColor := False;
  5095.   FTreeNodes := TTreeNodes.Create(Self);
  5096.   FBorderStyle := bsSingle;
  5097.   FShowButtons := True;
  5098.   FShowRoot := True;
  5099.   FShowLines := True;
  5100.   FHideSelection := True;
  5101.   FDragImage := TImageList.CreateSize(32, 32);
  5102.   FSaveIndent := -1;
  5103.   FEditInstance := MakeObjectInstance(EditWndProc);
  5104.   FImageChangeLink := TChangeLink.Create;
  5105.   FImageChangeLink.OnChange := ImageListChange;
  5106.   FStateChangeLink := TChangeLink.Create;
  5107.   FStateChangeLink.OnChange := ImageListChange;
  5108. end;
  5109.  
  5110. destructor TCustomTreeView.Destroy;
  5111. begin
  5112.   Items.Free;
  5113.   FSaveItems.Free;
  5114.   FDragImage.Free;
  5115.   FMemStream.Free;
  5116.   FreeObjectInstance(FEditInstance);
  5117.   FImageChangeLink.Free;
  5118.   FStateChangeLink.Free;
  5119.   inherited Destroy;
  5120. end;
  5121.  
  5122. procedure TCustomTreeView.CreateParams(var Params: TCreateParams);
  5123. const
  5124.   BorderStyles: array[TBorderStyle] of Integer = (0, WS_BORDER);
  5125.   LineStyles: array[Boolean] of Integer = (0, TVS_HASLINES);
  5126.   RootStyles: array[Boolean] of Integer = (0, TVS_LINESATROOT);
  5127.   ButtonStyles: array[Boolean] of Integer = (0, TVS_HASBUTTONS);
  5128.   EditStyles: array[Boolean] of Integer = (TVS_EDITLABELS, 0);
  5129.   HideSelections: array[Boolean] of Integer = (TVS_SHOWSELALWAYS, 0);
  5130.   DragStyles: array[TDragMode] of Integer = (TVS_DISABLEDRAGDROP, 0);
  5131. begin
  5132.   InitCommonControl(ICC_TREEVIEW_CLASSES);
  5133.   inherited CreateParams(Params);
  5134.   CreateSubClass(Params, WC_TREEVIEW);
  5135.   with Params do
  5136.   begin
  5137.     Style := Style or LineStyles[FShowLines] or BorderStyles[FBorderStyle] or
  5138.       RootStyles[FShowRoot] or ButtonStyles[FShowButtons] or
  5139.       EditStyles[FReadOnly] or HideSelections[FHideSelection] or
  5140.       DragStyles[DragMode];
  5141.     if Ctl3D and NewStyleControls and (FBorderStyle = bsSingle) then
  5142.     begin
  5143.       Style := Style and not WS_BORDER;
  5144.       ExStyle := Params.ExStyle or WS_EX_CLIENTEDGE;
  5145.     end;
  5146.     WindowClass.style := WindowClass.style and not (CS_HREDRAW or CS_VREDRAW);
  5147.   end;
  5148. end;
  5149.  
  5150. procedure TCustomTreeView.CreateWnd;
  5151. begin
  5152.   FStateChanging := False;
  5153.   inherited CreateWnd;
  5154.   if FMemStream <> nil then
  5155.   begin
  5156.     Items.ReadData(FMemStream);
  5157.     FMemStream.Destroy;
  5158.     FMemStream := nil;
  5159.     SetTopItem(Items.GetNodeFromIndex(FSaveTopIndex));
  5160.     FSaveTopIndex := 0;
  5161.     SetSelection(Items.GetNodeFromIndex(FSaveIndex));
  5162.     FSaveIndex := 0;
  5163.   end;
  5164.   if FSaveIndent <> -1 then Indent := FSaveIndent;
  5165.   if (Images <> nil) and Images.HandleAllocated then
  5166.     SetImageList(Images.Handle, TVSIL_NORMAL);
  5167.   if (StateImages <> nil) and StateImages.HandleAllocated then
  5168.     SetImageList(StateImages.Handle, TVSIL_STATE);
  5169. end;
  5170.  
  5171. procedure TCustomTreeView.DestroyWnd;
  5172. var
  5173.   Node: TTreeNode;
  5174. begin
  5175.   FStateChanging := True;
  5176.   if Items.Count > 0 then
  5177.   begin
  5178.     FMemStream := TMemoryStream.Create;
  5179.     Items.WriteData(FMemStream);
  5180.     FMemStream.Position := 0;
  5181.     Node := GetTopItem;
  5182.     if Node <> nil then FSaveTopIndex := Node.AbsoluteIndex;
  5183.     Node := Selected;
  5184.     if Node <> nil then FSaveIndex := Node.AbsoluteIndex;
  5185.   end;
  5186.   FSaveIndent := Indent;
  5187.   inherited DestroyWnd;
  5188. end;
  5189.  
  5190. procedure TCustomTreeView.EditWndProc(var Message: TMessage);
  5191. begin
  5192.   try
  5193.     with Message do
  5194.     begin
  5195.       case Msg of
  5196.         WM_KEYDOWN,
  5197.         WM_SYSKEYDOWN: if DoKeyDown(TWMKey(Message)) then Exit;
  5198.         WM_CHAR: if DoKeyPress(TWMKey(Message)) then Exit;
  5199.         WM_KEYUP,
  5200.         WM_SYSKEYUP: if DoKeyUp(TWMKey(Message)) then Exit;
  5201.         CN_KEYDOWN,
  5202.         CN_CHAR, CN_SYSKEYDOWN,
  5203.         CN_SYSCHAR:
  5204.           begin
  5205.             WndProc(Message);
  5206.             Exit;
  5207.           end;
  5208.       end;
  5209.       Result := CallWindowProc(FDefEditProc, FEditHandle, Msg, WParam, LParam);
  5210.     end;
  5211.   except
  5212.     Application.HandleException(Self);
  5213.   end;
  5214. end;
  5215.  
  5216. procedure TCustomTreeView.CMColorChanged(var Message: TMessage);
  5217. begin
  5218.   inherited;
  5219.   RecreateWnd;
  5220. end;
  5221.  
  5222. procedure TCustomTreeView.CMCtl3DChanged(var Message: TMessage);
  5223. begin
  5224.   inherited;
  5225.   if FBorderStyle = bsSingle then RecreateWnd;
  5226. end;
  5227.  
  5228. procedure TCustomTreeView.CMSysColorChange(var Message: TMessage);
  5229. begin
  5230.   inherited;
  5231.   if not (csLoading in ComponentState) then
  5232.   begin
  5233.     Message.Msg := WM_SYSCOLORCHANGE;
  5234.     DefaultHandler(Message);
  5235.   end;
  5236. end;
  5237.  
  5238. function TCustomTreeView.AlphaSort: Boolean;
  5239. var
  5240.   I: Integer;
  5241. begin
  5242.   if HandleAllocated then
  5243.   begin
  5244.     Result := CustomSort(nil, 0);
  5245.     for I := 0 to Items.Count - 1 do
  5246.       with Items[I] do
  5247.         if HasChildren then AlphaSort;
  5248.   end
  5249.   else Result := False;
  5250. end;
  5251.  
  5252. function TCustomTreeView.CustomSort(SortProc: TTVCompare; Data: Longint): Boolean;
  5253. var
  5254.   SortCB: TTVSortCB;
  5255.   I: Integer;
  5256.   Node: TTreeNode;
  5257. begin
  5258.   Result := False;
  5259.   if HandleAllocated then
  5260.   begin
  5261.     with SortCB do
  5262.     begin
  5263.       if not Assigned(SortProc) then lpfnCompare := @DefaultTreeViewSort
  5264.       else lpfnCompare := SortProc;
  5265.       hParent := TVI_ROOT;
  5266.       lParam := Data;
  5267.       Result := TreeView_SortChildrenCB(Handle, SortCB, 0);
  5268.     end;
  5269.     for I := 0 to Items.Count - 1 do
  5270.     begin
  5271.       Node := Items[I];
  5272.       if Node.HasChildren then Node.CustomSort(SortProc, Data);
  5273.     end;
  5274.   end;
  5275. end;
  5276.  
  5277. procedure TCustomTreeView.SetSortType(Value: TSortType);
  5278. begin
  5279.   if SortType <> Value then
  5280.   begin
  5281.     FSortType := Value;
  5282.     if ((SortType in [stData, stBoth]) and Assigned(OnCompare)) or
  5283.       (SortType in [stText, stBoth]) then
  5284.       AlphaSort;
  5285.   end;
  5286. end;
  5287.  
  5288. procedure TCustomTreeView.SetStyle(Value: Integer; UseStyle: Boolean);
  5289. var
  5290.   Style: Integer;
  5291. begin
  5292.   if HandleAllocated then
  5293.   begin
  5294.     Style := GetWindowLong(Handle, GWL_STYLE);
  5295.     if not UseStyle then Style := Style and not Value
  5296.     else Style := Style or Value;
  5297.     SetWindowLong(Handle, GWL_STYLE, Style);
  5298.   end;
  5299. end;
  5300.  
  5301. procedure TCustomTreeView.SetBorderStyle(Value: TBorderStyle);
  5302. begin
  5303.   if BorderStyle <> Value then
  5304.   begin
  5305.     FBorderStyle := Value;
  5306.     RecreateWnd;
  5307.   end;
  5308. end;
  5309.  
  5310. procedure TCustomTreeView.SetDragMode(Value: TDragMode);
  5311. begin
  5312.   if Value <> DragMode then
  5313.     SetStyle(TVS_DISABLEDRAGDROP, Value = dmManual);
  5314.   inherited;
  5315. end;
  5316.  
  5317. procedure TCustomTreeView.SetButtonStyle(Value: Boolean);
  5318. begin
  5319.   if ShowButtons <> Value then
  5320.   begin
  5321.     FShowButtons := Value;
  5322.     SetStyle(TVS_HASBUTTONS, Value);
  5323.   end;
  5324. end;
  5325.  
  5326. procedure TCustomTreeView.SetLineStyle(Value: Boolean);
  5327. begin
  5328.   if ShowLines <> Value then
  5329.   begin
  5330.     FShowLines := Value;
  5331.     SetStyle(TVS_HASLINES, Value);
  5332.   end;
  5333. end;
  5334.  
  5335. procedure TCustomTreeView.SetRootStyle(Value: Boolean);
  5336. begin
  5337.   if ShowRoot <> Value then
  5338.   begin
  5339.     FShowRoot := Value;
  5340.     SetStyle(TVS_LINESATROOT, Value);
  5341.   end;
  5342. end;
  5343.  
  5344. procedure TCustomTreeView.SetReadOnly(Value: Boolean);
  5345. begin
  5346.   if ReadOnly <> Value then
  5347.   begin
  5348.     FReadOnly := Value;
  5349.     SetStyle(TVS_EDITLABELS, not Value);
  5350.   end;
  5351. end;
  5352.  
  5353. procedure TCustomTreeView.SetHideSelection(Value: Boolean);
  5354. begin
  5355.   if HideSelection <> Value then
  5356.   begin
  5357.     FHideSelection := Value;
  5358.     SetStyle(TVS_SHOWSELALWAYS, not Value);
  5359.     Invalidate;
  5360.   end;
  5361. end;
  5362.  
  5363. function TCustomTreeView.GetNodeAt(X, Y: Integer): TTreeNode;
  5364. var
  5365.   HitTest: TTVHitTestInfo;
  5366. begin
  5367.   with HitTest do
  5368.   begin
  5369.     pt.X := X;
  5370.     pt.Y := Y;
  5371.     if TreeView_HitTest(Handle, HitTest) <> nil then
  5372.       Result := Items.GetNode(HitTest.hItem)
  5373.     else Result := nil;
  5374.   end;
  5375. end;
  5376.  
  5377. function TCustomTreeView.GetHitTestInfoAt(X, Y: Integer): THitTests;
  5378. var
  5379.   HitTest: TTVHitTestInfo;
  5380. begin
  5381.   Result := [];
  5382.   with HitTest do
  5383.   begin
  5384.     pt.X := X;
  5385.     pt.Y := Y;
  5386.     TreeView_HitTest(Handle, HitTest);
  5387.     if (flags and TVHT_ABOVE) <> 0 then Include(Result, htAbove);
  5388.     if (flags and TVHT_BELOW) <> 0 then Include(Result, htBelow);
  5389.     if (flags and TVHT_NOWHERE) <> 0 then Include(Result, htNowhere);
  5390.     if (flags and TVHT_ONITEM) <> 0 then Include(Result, htOnItem);
  5391.     if (flags and TVHT_ONITEMBUTTON) <> 0 then Include(Result, htOnButton);
  5392.     if (flags and TVHT_ONITEMICON) <> 0 then Include(Result, htOnIcon);
  5393.     if (flags and TVHT_ONITEMINDENT) <> 0 then Include(Result, htOnIndent);
  5394.     if (flags and TVHT_ONITEMLABEL) <> 0 then Include(Result, htOnLabel);
  5395.     if (flags and TVHT_ONITEMRIGHT) <> 0 then Include(Result, htOnRight);
  5396.     if (flags and TVHT_ONITEMSTATEICON) <> 0 then Include(Result, htOnStateIcon);
  5397.     if (flags and TVHT_TOLEFT) <> 0 then Include(Result, htToLeft);
  5398.     if (flags and TVHT_TORIGHT) <> 0 then Include(Result, htToRight);
  5399.   end;
  5400. end;
  5401.  
  5402. procedure TCustomTreeView.SetTreeNodes(Value: TTreeNodes);
  5403. begin
  5404.   Items.Assign(Value);
  5405. end;
  5406.  
  5407. procedure TCustomTreeView.SetIndent(Value: Integer);
  5408. begin
  5409.   if Value <> Indent then TreeView_SetIndent(Handle, Value);
  5410. end;
  5411.  
  5412. function TCustomTreeView.GetIndent: Integer;
  5413. begin
  5414.   Result := TreeView_GetIndent(Handle)
  5415. end;
  5416.  
  5417. procedure TCustomTreeView.FullExpand;
  5418. var
  5419.   Node: TTreeNode;
  5420. begin
  5421.   Node := Items.GetFirstNode;
  5422.   while Node <> nil do
  5423.   begin
  5424.     Node.Expand(True);
  5425.     Node := Node.GetNextSibling;
  5426.   end;
  5427. end;
  5428.  
  5429. procedure TCustomTreeView.FullCollapse;
  5430. var
  5431.   Node: TTreeNode;
  5432. begin
  5433.   Node := Items.GetFirstNode;
  5434.   while Node <> nil do
  5435.   begin
  5436.     Node.Collapse(True);
  5437.     Node := Node.GetNextSibling;
  5438.   end;
  5439. end;
  5440.  
  5441. procedure TCustomTreeView.Loaded;
  5442. begin
  5443.   inherited Loaded;
  5444.   if csDesigning in ComponentState then FullExpand;
  5445. end;
  5446.  
  5447. function TCustomTreeView.GetTopItem: TTreeNode;
  5448. begin
  5449.   if HandleAllocated then
  5450.     Result := Items.GetNode(TreeView_GetFirstVisible(Handle))
  5451.   else Result := nil;
  5452. end;
  5453.  
  5454. procedure TCustomTreeView.SetTopItem(Value: TTreeNode);
  5455. begin
  5456.   if HandleAllocated and (Value <> nil) then
  5457.     TreeView_SelectSetFirstVisible(Handle, Value.ItemId);
  5458. end;
  5459.  
  5460. function TCustomTreeView.GetSelection: TTreeNode;
  5461. begin
  5462.   if HandleAllocated then
  5463.   begin
  5464.     if FRightClickSelect and Assigned(FRClickNode) then
  5465.       Result := FRClickNode
  5466.     else
  5467.       Result := Items.GetNode(TreeView_GetSelection(Handle));
  5468.   end
  5469.   else Result := nil;
  5470. end;
  5471.  
  5472. procedure TCustomTreeView.SetSelection(Value: TTreeNode);
  5473. begin
  5474.   if Value <> nil then Value.Selected := True
  5475.   else TreeView_SelectItem(Handle, nil);
  5476. end;
  5477.  
  5478. function TCustomTreeView.GetDropTarget: TTreeNode;
  5479. begin
  5480.   if HandleAllocated then
  5481.   begin
  5482.     Result := Items.GetNode(TreeView_GetDropHilite(Handle));
  5483.     if Result = nil then Result := FLastDropTarget;
  5484.   end
  5485.   else Result := nil;
  5486. end;
  5487.  
  5488. procedure TCustomTreeView.SetDropTarget(Value: TTreeNode);
  5489. begin
  5490.   if HandleAllocated then
  5491.     if Value <> nil then Value.DropTarget := True
  5492.     else TreeView_SelectDropTarget(Handle, nil);
  5493. end;
  5494.  
  5495. function TCustomTreeView.GetNodeFromItem(const Item: TTVItem): TTreeNode;
  5496. begin
  5497.   with Item do
  5498.     if (state and TVIF_PARAM) <> 0 then Result := Pointer(lParam)
  5499.     else Result := Items.GetNode(hItem);
  5500. end;
  5501.  
  5502. function TCustomTreeView.IsEditing: Boolean;
  5503. var
  5504.   ControlHand: HWnd;
  5505. begin
  5506.   ControlHand := TreeView_GetEditControl(Handle);
  5507.   Result := (ControlHand <> 0) and IsWindowVisible(ControlHand);
  5508. end;
  5509.  
  5510. procedure TCustomTreeView.CNNotify(var Message: TWMNotify);
  5511. var
  5512.   Node: TTreeNode;
  5513.   MousePos: TPoint;
  5514. begin
  5515.   with Message.NMHdr^ do
  5516.     case code of
  5517.       TVN_BEGINDRAG:
  5518.         begin
  5519.           FDragged := True;
  5520.           with PNMTreeView(Pointer(Message.NMHdr))^ do
  5521.             FDragNode := GetNodeFromItem(ItemNew);
  5522.         end;
  5523.       TVN_BEGINLABELEDIT:
  5524.         begin
  5525.           with PTVDispInfo(Pointer(Message.NMHdr))^ do
  5526.             if Dragging or not CanEdit(GetNodeFromItem(item)) then
  5527.               Message.Result := 1;
  5528.           if Message.Result = 0 then
  5529.           begin
  5530.             FEditHandle := TreeView_GetEditControl(Handle);
  5531.             FDefEditProc := Pointer(GetWindowLong(FEditHandle, GWL_WNDPROC));
  5532.             SetWindowLong(FEditHandle, GWL_WNDPROC, LongInt(FEditInstance));
  5533.           end;
  5534.         end;
  5535.       TVN_ENDLABELEDIT:
  5536.         with PTVDispInfo(Pointer(Message.NMHdr))^ do
  5537.           Edit(item);
  5538.       TVN_ITEMEXPANDING:
  5539.         if not FManualNotify then
  5540.         begin
  5541.           with PNMTreeView(Pointer(Message.NMHdr))^ do
  5542.           begin
  5543.             Node := GetNodeFromItem(ItemNew);
  5544.             if (action = TVE_EXPAND) and not CanExpand(Node) then
  5545.               Message.Result := 1
  5546.             else if (action = TVE_COLLAPSE) and
  5547.               not CanCollapse(Node) then Message.Result := 1;
  5548.           end;
  5549.         end;
  5550.       TVN_ITEMEXPANDED:
  5551.         if not FManualNotify then
  5552.         begin
  5553.           with PNMTreeView(Pointer(Message.NMHdr))^ do
  5554.           begin
  5555.             Node := GetNodeFromItem(itemNew);
  5556.             if (action = TVE_EXPAND) then Expand(Node)
  5557.             else if (action = TVE_COLLAPSE) then Collapse(Node);
  5558.           end;
  5559.         end;
  5560.       TVN_SELCHANGING:
  5561.         with PNMTreeView(Pointer(Message.NMHdr))^ do
  5562.           if not CanChange(GetNodeFromItem(itemNew)) then
  5563.             Message.Result := 1;
  5564.       TVN_SELCHANGED:
  5565.         with PNMTreeView(Pointer(Message.NMHdr))^ do
  5566.           Change(GetNodeFromItem(itemNew));
  5567.       TVN_DELETEITEM:
  5568.         begin
  5569.           if not FStateChanging then
  5570.           begin
  5571.             with PNMTreeView(Pointer(Message.NMHdr))^ do
  5572.               Node := GetNodeFromItem(itemOld);
  5573.             if Node <> nil then
  5574.             begin
  5575.               Node.FItemId := nil;
  5576.               Items.Delete(Node);
  5577.             end;
  5578.           end;
  5579.         end;
  5580.       TVN_SETDISPINFO:
  5581.         with PTVDispInfo(Pointer(Message.NMHdr))^ do
  5582.         begin
  5583.           Node := GetNodeFromItem(item);
  5584.           if (Node <> nil) and ((item.mask and TVIF_TEXT) <> 0) then
  5585.             Node.Text := item.pszText;
  5586.         end;
  5587.       TVN_GETDISPINFO:
  5588.         with PTVDispInfo(Pointer(Message.NMHdr))^ do
  5589.         begin
  5590.           Node := GetNodeFromItem(item);
  5591.           if Node <> nil then
  5592.           begin
  5593.             if (item.mask and TVIF_TEXT) <> 0 then
  5594.               StrLCopy(item.pszText, PChar(Node.Text), item.cchTextMax);
  5595.             if (item.mask and TVIF_IMAGE) <> 0 then
  5596.             begin
  5597.               GetImageIndex(Node);
  5598.               item.iImage := Node.ImageIndex;
  5599.             end;
  5600.             if (item.mask and TVIF_SELECTEDIMAGE) <> 0 then
  5601.             begin
  5602.               GetSelectedIndex(Node);
  5603.               item.iSelectedImage := Node.SelectedIndex;
  5604.             end;
  5605.           end;
  5606.         end;
  5607.       NM_RCLICK:
  5608.         begin
  5609.           if RightClickSelect then
  5610.           begin
  5611.             GetCursorPos(MousePos);
  5612.             with PointToSmallPoint(ScreenToClient(MousePos)) do
  5613.             begin
  5614.               FRClickNode := GetNodeAt(X, Y);
  5615.               Perform(WM_RBUTTONUP, 0, MakeLong(X, Y));
  5616.             end;
  5617.           end
  5618.           else FRClickNode := Pointer(1);
  5619.         end;
  5620.     end;
  5621. end;
  5622.  
  5623. function TCustomTreeView.GetDragImages: TCustomImageList;
  5624. begin
  5625.   if FDragImage.Count > 0 then
  5626.     Result := FDragImage else
  5627.     Result := nil;
  5628. end;
  5629.  
  5630. procedure TCustomTreeView.WndProc(var Message: TMessage);
  5631. begin
  5632.   if not (csDesigning in ComponentState) and ((Message.Msg = WM_LBUTTONDOWN) or
  5633.     (Message.Msg = WM_LBUTTONDBLCLK)) and not Dragging and (DragMode = dmAutomatic) then
  5634.   begin
  5635.     if not IsControlMouseMsg(TWMMouse(Message)) then
  5636.     begin
  5637.       ControlState := ControlState + [csLButtonDown];
  5638.       Dispatch(Message);
  5639.     end;
  5640.   end
  5641.   else inherited WndProc(Message);
  5642. end;
  5643.  
  5644. procedure TCustomTreeView.DoStartDrag(var DragObject: TDragObject);
  5645. var
  5646.   ImageHandle: HImageList;
  5647.   DragNode: TTreeNode;
  5648.   P: TPoint;
  5649. begin
  5650.   inherited DoStartDrag(DragObject);
  5651.   DragNode := FDragNode;
  5652.   FLastDropTarget := nil;
  5653.   FDragNode := nil;
  5654.   if DragNode = nil then
  5655.   begin
  5656.     GetCursorPos(P);
  5657.     with ScreenToClient(P) do DragNode := GetNodeAt(X, Y);
  5658.   end;
  5659.   if DragNode <> nil then
  5660.   begin
  5661.     ImageHandle := TreeView_CreateDragImage(Handle, DragNode.ItemId);
  5662.     if ImageHandle <> 0 then
  5663.       with FDragImage do
  5664.       begin
  5665.         Handle := ImageHandle;
  5666.         SetDragImage(0, 2, 2);
  5667.       end;
  5668.   end;
  5669. end;
  5670.  
  5671. procedure TCustomTreeView.DoEndDrag(Target: TObject; X, Y: Integer);
  5672. begin
  5673.   inherited DoEndDrag(Target, X, Y);
  5674.   FLastDropTarget := nil;
  5675. end;
  5676.  
  5677. procedure TCustomTreeView.CMDrag(var Message: TCMDrag);
  5678. begin
  5679.   inherited;
  5680.   with Message, DragRec^ do
  5681.     case DragMessage of
  5682.       dmDragMove: with ScreenToClient(Pos) do DoDragOver(Source, X, Y, Message.Result<>0);
  5683.       dmDragLeave:
  5684.         begin
  5685.           TDragObject(Source).HideDragImage;
  5686.           FLastDropTarget := DropTarget;
  5687.           DropTarget := nil;
  5688.           TDragObject(Source).ShowDragImage;
  5689.         end;
  5690.       dmDragDrop: FLastDropTarget := nil;
  5691.     end;
  5692. end;
  5693.  
  5694. procedure TCustomTreeView.DoDragOver(Source: TDragObject; X, Y: Integer; CanDrop: Boolean);
  5695. var
  5696.   Node: TTreeNode;
  5697. begin
  5698.   Node := GetNodeAt(X, Y);
  5699.   if (Node <> nil) and
  5700.     ((Node <> DropTarget) or (Node = FLastDropTarget)) then
  5701.   begin
  5702.     FLastDropTarget := nil;
  5703.     TDragObject(Source).HideDragImage;
  5704.     Node.DropTarget := CanDrop;
  5705.     TDragObject(Source).ShowDragImage;
  5706.   end;
  5707. end;
  5708.  
  5709. procedure TCustomTreeView.GetImageIndex(Node: TTreeNode);
  5710. begin
  5711.   if Assigned(FOnGetImageIndex) then FOnGetImageIndex(Self, Node);
  5712. end;
  5713.  
  5714. procedure TCustomTreeView.GetSelectedIndex(Node: TTreeNode);
  5715. begin
  5716.   if Assigned(FOnGetSelectedIndex) then FOnGetSelectedIndex(Self, Node);
  5717. end;
  5718.  
  5719. function TCustomTreeView.CanChange(Node: TTreeNode): Boolean;
  5720. begin
  5721.   Result := True;
  5722.   if Assigned(FOnChanging) then FOnChanging(Self, Node, Result);
  5723. end;
  5724.  
  5725. procedure TCustomTreeView.Change(Node: TTreeNode);
  5726. begin
  5727.   if Assigned(FOnChange) then FOnChange(Self, Node);
  5728. end;
  5729.  
  5730. procedure TCustomTreeView.Expand(Node: TTreeNode);
  5731. begin
  5732.   if Assigned(FOnExpanded) then FOnExpanded(Self, Node);
  5733. end;
  5734.  
  5735. function TCustomTreeView.CanExpand(Node: TTreeNode): Boolean;
  5736. begin
  5737.   Result := True;
  5738.   if Assigned(FOnExpanding) then FOnExpanding(Self, Node, Result);
  5739. end;
  5740.  
  5741. procedure TCustomTreeView.Collapse(Node: TTreeNode);
  5742. begin
  5743.   if Assigned(FOnCollapsed) then FOnCollapsed(Self, Node);
  5744. end;
  5745.  
  5746. function TCustomTreeView.CanCollapse(Node: TTreeNode): Boolean;
  5747. begin
  5748.   Result := True;
  5749.   if Assigned(FOnCollapsing) then FOnCollapsing(Self, Node, Result);
  5750. end;
  5751.  
  5752. function TCustomTreeView.CanEdit(Node: TTreeNode): Boolean;
  5753. begin
  5754.   Result := True;
  5755.   if Assigned(FOnEditing) then FOnEditing(Self, Node, Result);
  5756. end;
  5757.  
  5758. procedure TCustomTreeView.Edit(const Item: TTVItem);
  5759. var
  5760.   S: string;
  5761.   Node: TTreeNode;
  5762. begin
  5763.   with Item do
  5764.     if pszText <> nil then
  5765.     begin
  5766.       S := pszText;
  5767.       Node := GetNodeFromItem(Item);
  5768.       if Assigned(FOnEdited) then FOnEdited(Self, Node, S);
  5769.       if Node <> nil then Node.Text := S;
  5770.     end;
  5771. end;
  5772.  
  5773. function TCustomTreeView.CreateNode: TTreeNode;
  5774. begin
  5775.   Result := TTreeNode.Create(Items);
  5776. end;
  5777.  
  5778. procedure TCustomTreeView.SetImageList(Value: HImageList; Flags: Integer);
  5779. begin
  5780.   if HandleAllocated then TreeView_SetImageList(Handle, Value, Flags);
  5781. end;
  5782.  
  5783. procedure TCustomTreeView.ImageListChange(Sender: TObject);
  5784. var
  5785.   ImageHandle: HImageList;
  5786. begin
  5787.   if HandleAllocated then
  5788.   begin
  5789.     ImageHandle := TImageList(Sender).Handle;
  5790.     if Sender = Images then
  5791.       SetImageList(ImageHandle, TVSIL_NORMAL)
  5792.     else if Sender = StateImages then
  5793.       SetImageList(ImageHandle, TVSIL_STATE);
  5794.   end;
  5795. end;
  5796.  
  5797. procedure TCustomTreeView.Notification(AComponent: TComponent;
  5798.   Operation: TOperation);
  5799. begin
  5800.   inherited Notification(AComponent, Operation);
  5801.   if Operation = opRemove then
  5802.   begin
  5803.     if AComponent = Images then Images := nil;
  5804.     if AComponent = StateImages then StateImages := nil;
  5805.   end;
  5806. end;
  5807.  
  5808. procedure TCustomTreeView.SetImages(Value: TImageList);
  5809. begin
  5810.   if Images <> nil then
  5811.     Images.UnRegisterChanges(FImageChangeLink);
  5812.   FImages := Value;
  5813.   if Images <> nil then
  5814.   begin
  5815.     Images.RegisterChanges(FImageChangeLink);
  5816.     SetImageList(Images.Handle, TVSIL_NORMAL)
  5817.   end
  5818.   else SetImageList(0, TVSIL_NORMAL);
  5819. end;
  5820.  
  5821. procedure TCustomTreeView.SetStateImages(Value: TImageList);
  5822. begin
  5823.   if StateImages <> nil then
  5824.     StateImages.UnRegisterChanges(FStateChangeLink);
  5825.   FStateImages := Value;
  5826.   if StateImages <> nil then
  5827.   begin
  5828.     StateImages.RegisterChanges(FStateChangeLink);
  5829.     SetImageList(StateImages.Handle, TVSIL_STATE)
  5830.   end
  5831.   else SetImageList(0, TVSIL_STATE);
  5832. end;
  5833.  
  5834. procedure TCustomTreeView.LoadFromFile(const FileName: string);
  5835. var
  5836.   Stream: TStream;
  5837. begin
  5838.   Stream := TFileStream.Create(FileName, fmOpenRead);
  5839.   try
  5840.     LoadFromStream(Stream);
  5841.   finally
  5842.     Stream.Free;
  5843.   end;
  5844. end;
  5845.  
  5846. procedure TCustomTreeView.LoadFromStream(Stream: TStream);
  5847. begin
  5848.   with TTreeStrings.Create(Items) do
  5849.     try
  5850.       LoadTreeFromStream(Stream);
  5851.     finally
  5852.       Free;
  5853.   end;
  5854. end;
  5855.  
  5856. procedure TCustomTreeView.SaveToFile(const FileName: string);
  5857. var
  5858.   Stream: TStream;
  5859. begin
  5860.   Stream := TFileStream.Create(FileName, fmCreate);
  5861.   try
  5862.     SaveToStream(Stream);
  5863.   finally
  5864.     Stream.Free;
  5865.   end;
  5866. end;
  5867.  
  5868. procedure TCustomTreeView.SaveToStream(Stream: TStream);
  5869. begin
  5870.   with TTreeStrings.Create(Items) do
  5871.     try
  5872.       SaveTreeToStream(Stream);
  5873.     finally
  5874.       Free;
  5875.   end;
  5876. end;
  5877.  
  5878. procedure TCustomTreeView.WMRButtonDown(var Message: TWMRButtonDown);
  5879. var
  5880.   MousePos: TPoint;
  5881. begin
  5882.   FRClickNode := nil;
  5883.   try
  5884.     if not RightClickSelect then
  5885.     begin
  5886.       inherited;
  5887.       if FRClickNode <> nil then
  5888.       begin
  5889.         GetCursorPos(MousePos);
  5890.         with PointToSmallPoint(ScreenToClient(MousePos)) do
  5891.           Perform(WM_RBUTTONUP, 0, MakeLong(X, Y));
  5892.       end;
  5893.     end
  5894.     else DefaultHandler(Message);
  5895.   finally
  5896.     FRClickNode := nil;
  5897.  
  5898.   end;
  5899. end;
  5900.  
  5901. procedure TCustomTreeView.WMRButtonUp(var Message: TWMRButtonUp);
  5902.  
  5903.   procedure DoMouseDown(var Message: TWMMouse; Button: TMouseButton;
  5904.     Shift: TShiftState);
  5905.   begin
  5906.     if not (csNoStdEvents in ControlStyle) then
  5907.       with Message do
  5908.         MouseDown(Button, KeysToShiftState(Keys) + Shift, XPos, YPos);
  5909.   end;
  5910.  
  5911. begin
  5912.   if RightClickSelect then DoMouseDown(Message, mbRight, []);
  5913.   inherited;
  5914. end;
  5915.  
  5916. procedure TCustomTreeView.WMLButtonDown(var Message: TWMLButtonDown);
  5917. var
  5918.   Node: TTreeNode;
  5919.   MousePos: TPoint;
  5920. begin
  5921.   FDragged := False;
  5922.   FDragNode := nil;
  5923.   try
  5924.     inherited;
  5925.     if DragMode = dmAutomatic then
  5926.     begin
  5927.       SetFocus;
  5928.       if not FDragged then
  5929.       begin
  5930.         GetCursorPos(MousePos);
  5931.         with PointToSmallPoint(ScreenToClient(MousePos)) do
  5932.           Perform(WM_LBUTTONUP, 0, MakeLong(X, Y));
  5933.       end
  5934.       else begin
  5935.         Node := GetNodeAt(Message.XPos, Message.YPos);
  5936.         if Node <> nil then
  5937.         begin
  5938.           Node.Focused := True;
  5939.           Node.Selected := True;
  5940.           BeginDrag(False);
  5941.         end;
  5942.       end;
  5943.     end;
  5944.   finally
  5945.     FDragNode := nil;
  5946.   end;
  5947. end;
  5948.  
  5949. procedure TCustomTreeView.WMNotify(var Message: TWMNotify);
  5950. var
  5951.   Node: TTreeNode;
  5952.   MaxTextLen: Integer;
  5953.   Pt: TPoint;
  5954. begin
  5955.   with Message do
  5956.     if NMHdr^.code = TTN_NEEDTEXTW then
  5957.     begin
  5958.       // Work around NT COMCTL32 problem with tool tips >= 80 characters
  5959.       GetCursorPos(Pt);
  5960.       Pt := ScreenToClient(Pt);
  5961.       Node := GetNodeAt(Pt.X, Pt.Y);
  5962.       if (Node = nil) or (Node.Text = '') then Exit;
  5963.       FWideText := Node.Text;
  5964.       MaxTextLen := SizeOf(PToolTipTextW(NMHdr)^.szText) div SizeOf(WideChar);
  5965.       if Length(FWideText) >= MaxTextLen then
  5966.         SetLength(FWideText, MaxTextLen - 1);
  5967.       PToolTipTextW(NMHdr)^.lpszText := PWideChar(FWideText);
  5968.       FillChar(PToolTipTextW(NMHdr)^.szText, MaxTextLen, 0);
  5969.       Move(Pointer(FWideText)^, PToolTipTextW(NMHdr)^.szText, Length(FWideText));
  5970.       PToolTipTextW(NMHdr)^.hInst := 0;
  5971.       SetWindowPos(NMHdr^.hwndFrom, HWND_TOP, 0, 0, 0, 0, SWP_NOACTIVATE or
  5972.         SWP_NOSIZE or SWP_NOMOVE);
  5973.       Result := 1;
  5974.     end
  5975.     else inherited;
  5976. end;
  5977.  
  5978. { TTrackBar }
  5979.  
  5980. constructor TTrackBar.Create(AOwner: TComponent);
  5981. begin
  5982.   inherited Create(AOwner);
  5983.   Width := 150;
  5984.   Height := 45;
  5985.   TabStop := True;
  5986.   FMin := 0;
  5987.   FMax := 10;
  5988.   FLineSize := 1;
  5989.   FPageSize := 2;
  5990.   FFrequency := 1;
  5991.   FTickMarks := tmBottomRight;
  5992.   FTickStyle := tsAuto;
  5993.   FOrientation := trHorizontal;
  5994.   ControlStyle := ControlStyle - [csDoubleClicks];
  5995. end;
  5996.  
  5997. procedure TTrackBar.CreateParams(var Params: TCreateParams);
  5998. const
  5999.   OrientationStyle: array[TTrackbarOrientation] of Longint = (TBS_HORZ, TBS_VERT);
  6000.   TickStyles: array[TTickStyle] of Longint = (TBS_NOTICKS, TBS_AUTOTICKS, 0);
  6001.   ATickMarks: array[TTickMark] of Longint = (TBS_BOTTOM, TBS_TOP, TBS_BOTH);
  6002. begin
  6003.   InitCommonControl(ICC_BAR_CLASSES);
  6004.   inherited CreateParams(Params);
  6005.   CreateSubClass(Params, TRACKBAR_CLASS);
  6006.   with Params do
  6007.   begin
  6008.     Style := Style or OrientationStyle[FOrientation] or
  6009.       TickStyles[FTickStyle] or ATickMarks[FTickMarks] or TBS_ENABLESELRANGE;
  6010.     WindowClass.style := WindowClass.style and not (CS_HREDRAW or CS_VREDRAW) or
  6011.       CS_DBLCLKS;
  6012.   end;
  6013. end;
  6014.  
  6015. procedure TTrackBar.CreateWnd;
  6016. begin
  6017.   inherited CreateWnd;
  6018.   if HandleAllocated then
  6019.   begin
  6020.     SendMessage(Handle, TBM_SETLINESIZE, 0, FLineSize);
  6021.     SendMessage(Handle, TBM_SETPAGESIZE, 0, FPageSize);
  6022.     SendMessage(Handle, TBM_SETRANGEMIN, 0, FMin);
  6023.     SendMessage(Handle, TBM_SETRANGEMAX, 0, FMax);
  6024.     UpdateSelection;
  6025.     SendMessage(Handle, TBM_SETPOS, 1, FPosition);
  6026.     SendMessage(Handle, TBM_SETTICFREQ, FFrequency, 1);
  6027.   end;
  6028. end;
  6029.  
  6030. procedure TTrackBar.DestroyWnd;
  6031. begin
  6032.   inherited DestroyWnd;
  6033. end;
  6034.  
  6035. procedure TTrackBar.CNHScroll(var Message: TWMHScroll);
  6036. begin
  6037.   inherited;
  6038.   FPosition := SendMessage(Handle, TBM_GETPOS, 0, 0);
  6039.  
  6040.   if Assigned(FOnChange) then
  6041.     FOnChange(Self);
  6042.   Message.Result := 0;
  6043. end;
  6044.  
  6045. procedure TTrackBar.CNVScroll(var Message: TWMVScroll);
  6046. begin
  6047.   inherited;
  6048.   FPosition := SendMessage(Handle, TBM_GETPOS, 0, 0);
  6049.  
  6050.   if Assigned(FOnChange) then
  6051.     FOnChange(Self);
  6052.   Message.Result := 0;
  6053. end;
  6054.  
  6055. procedure TTrackBar.SetOrientation(Value: TTrackBarOrientation);
  6056. begin
  6057.   if Value <> FOrientation then
  6058.   begin
  6059.     FOrientation := Value;
  6060.     if ComponentState * [csLoading, csUpdating] = [] then
  6061.       SetBounds(Left, Top, Height, Width);
  6062.     RecreateWnd;
  6063.   end;
  6064. end;
  6065.  
  6066. procedure TTrackBar.SetParams(APosition, AMin, AMax: Integer);
  6067. begin
  6068.   if AMax < AMin then
  6069.     raise EInvalidOperation.CreateFmt(SPropertyOutOfRange, [Self.Classname]);
  6070.   if APosition < AMin then APosition := AMin;
  6071.   if APosition > AMax then APosition := AMax;
  6072.   if (FMin <> AMin) then
  6073.   begin
  6074.     FMin := AMin;
  6075.     if HandleAllocated then
  6076.       SendMessage(Handle, TBM_SETRANGEMIN, 1, AMin);
  6077.   end;
  6078.   if (FMax <> AMax) then
  6079.   begin
  6080.     FMax := AMax;
  6081.     if HandleAllocated then
  6082.       SendMessage(Handle, TBM_SETRANGEMAX, 1, AMax);
  6083.   end;
  6084.   if FPosition <> APosition then
  6085.   begin
  6086.     FPosition := APosition;
  6087.     if HandleAllocated then
  6088.       SendMessage(Handle, TBM_SETPOS, 1, APosition);
  6089.   end;
  6090. end;
  6091.  
  6092. procedure TTrackBar.SetPosition(Value: Integer);
  6093. begin
  6094.   SetParams(Value, FMin, FMax);
  6095. end;
  6096.  
  6097. procedure TTrackBar.SetMin(Value: Integer);
  6098. begin
  6099.   SetParams(FPosition, Value, FMax);
  6100. end;
  6101.  
  6102. procedure TTrackBar.SetMax(Value: Integer);
  6103. begin
  6104.   SetParams(FPosition, FMin, Value);
  6105. end;
  6106.  
  6107. procedure TTrackBar.SetFrequency(Value: Integer);
  6108. begin
  6109.   if Value <> FFrequency then
  6110.   begin
  6111.     FFrequency := Value;
  6112.     if HandleAllocated then
  6113.       SendMessage(Handle, TBM_SETTICFREQ, FFrequency, 1);
  6114.   end;
  6115. end;
  6116.  
  6117. procedure TTrackBar.SetTick(Value: Integer);
  6118. begin
  6119.   if HandleAllocated then
  6120.     SendMessage(Handle, TBM_SETTIC, 0, Value);
  6121. end;
  6122.  
  6123. procedure TTrackBar.SetTickStyle(Value: TTickStyle);
  6124. begin
  6125.   if Value <> FTickStyle then
  6126.   begin
  6127.     FTickStyle := Value;
  6128.     RecreateWnd;
  6129.   end;
  6130. end;
  6131.  
  6132. procedure TTrackBar.SetTickMarks(Value: TTickMark);
  6133. begin
  6134.   if Value <> FTickMarks then
  6135.   begin
  6136.     FTickMarks := Value;
  6137.     RecreateWnd;
  6138.   end;
  6139. end;
  6140.  
  6141. procedure TTrackBar.SetLineSize(Value: Integer);
  6142. begin
  6143.   if Value <> FLineSize then
  6144.   begin
  6145.     FLineSize := Value;
  6146.     if HandleAllocated then
  6147.       SendMessage(Handle, TBM_SETLINESIZE, 0, FLineSize);
  6148.   end;
  6149. end;
  6150.  
  6151. procedure TTrackBar.SetPageSize(Value: Integer);
  6152. begin
  6153.   if Value <> FPageSize then
  6154.   begin
  6155.     FPageSize := Value;
  6156.     if HandleAllocated then
  6157.       SendMessage(Handle, TBM_SETPAGESIZE, 0, FPageSize);
  6158.   end;
  6159. end;
  6160.  
  6161. procedure TTrackBar.UpdateSelection;
  6162. begin
  6163.   if HandleAllocated then
  6164.   begin
  6165.     if (FSelStart = 0) and (FSelEnd = 0) then
  6166.       SendMessage(Handle, TBM_CLEARSEL, 1, 0)
  6167.     else
  6168.       SendMessage(Handle, TBM_SETSEL, Integer(True), MakeLong(FSelStart, FSelEnd));
  6169.   end;
  6170. end;
  6171.  
  6172. procedure TTrackBar.SetSelStart(Value: Integer);
  6173. begin
  6174.   if Value <> FSelStart then
  6175.   begin
  6176.     FSelStart := Value;
  6177.     UpdateSelection;
  6178.   end;
  6179. end;
  6180.  
  6181. procedure TTrackBar.SetSelEnd(Value: Integer);
  6182. begin
  6183.   if Value <> FSelEnd then
  6184.   begin
  6185.     FSelEnd := Value;
  6186.     UpdateSelection;
  6187.   end;
  6188. end;
  6189.  
  6190. { TProgressBar }
  6191.  
  6192. const
  6193.   Limit16 = 65535;
  6194.  
  6195. procedure ProgressLimitError;
  6196. begin
  6197.   raise Exception.CreateFmt(SOutOfRange, [0, Limit16]);
  6198. end;
  6199.  
  6200. constructor TProgressBar.Create(AOwner: TComponent);
  6201. begin
  6202.   F32BitMode := InitCommonControl(ICC_PROGRESS_CLASS);
  6203.   inherited Create(AOwner);
  6204.   Width := 150;
  6205.   Height := GetSystemMetrics(SM_CYVSCROLL);
  6206.   FMin := 0;
  6207.   FMax := 100;
  6208.   FStep := 10;
  6209. end;
  6210.  
  6211. procedure TProgressBar.CreateParams(var Params: TCreateParams);
  6212. begin
  6213.   if not F32BitMode then InitCommonControls;
  6214.   inherited CreateParams(Params);
  6215.   CreateSubClass(Params, PROGRESS_CLASS);
  6216. end;
  6217.  
  6218. procedure TProgressBar.CreateWnd;
  6219. begin
  6220.   inherited CreateWnd;
  6221.   if F32BitMode then SendMessage(Handle, PBM_SETRANGE32, FMin, FMax)
  6222.   else SendMessage(Handle, PBM_SETRANGE, 0, MakeLong(FMin, FMax));
  6223.   SendMessage(Handle, PBM_SETSTEP, FStep, 0);
  6224.   Position := FPosition;
  6225. end;
  6226.  
  6227. function TProgressBar.GetMin: Integer;
  6228. begin
  6229.   if HandleAllocated and F32BitMode then
  6230.     Result := SendMessage(Handle, PBM_GetRange, 1, 0)
  6231.   else
  6232.     Result := FMin;
  6233. end;
  6234.  
  6235. function TProgressBar.GetMax: Integer;
  6236. begin
  6237.   if HandleAllocated and F32BitMode then
  6238.     Result := SendMessage(Handle, PBM_GetRange, 0, 0)
  6239.   else
  6240.     Result := FMax;
  6241. end;
  6242.  
  6243. function TProgressBar.GetPosition: Integer;
  6244. begin
  6245.   if HandleAllocated then
  6246.   begin
  6247.     if F32BitMode then Result := SendMessage(Handle, PBM_GETPOS, 0, 0)
  6248.     else Result := SendMessage(Handle, PBM_DELTAPOS, 0, 0)
  6249.   end
  6250.   else Result := FPosition;
  6251. end;
  6252.  
  6253. procedure TProgressBar.SetParams(AMin, AMax: Integer);
  6254. begin
  6255.   if AMax < AMin then
  6256.     raise EInvalidOperation.CreateFmt(SPropertyOutOfRange, [Self.Classname]);
  6257.   if not F32BitMode and ((AMin < 0) or (AMin > Limit16) or (AMax < 0) or
  6258.     (AMax > Limit16)) then ProgressLimitError;
  6259.   if (FMin <> AMin) or (FMax <> AMax) then
  6260.   begin
  6261.     if HandleAllocated then
  6262.     begin
  6263.       if F32BitMode then SendMessage(Handle, PBM_SETRANGE32, AMin, AMax)
  6264.       else SendMessage(Handle, PBM_SETRANGE, 0, MakeLong(AMin, AMax));
  6265.       if FMin > AMin then // since Windows sets Position when increase Min..
  6266.         SendMessage(Handle, PBM_SETPOS, AMin, 0); // set it back if decrease
  6267.     end;
  6268.     FMin := AMin;
  6269.     FMax := AMax;
  6270.   end;
  6271. end;
  6272.  
  6273. procedure TProgressBar.SetMin(Value: Integer);
  6274. begin
  6275.   SetParams(Value, FMax);
  6276. end;
  6277.  
  6278. procedure TProgressBar.SetMax(Value: Integer);
  6279. begin
  6280.   SetParams(FMin, Value);
  6281. end;
  6282.  
  6283. procedure TProgressBar.SetPosition(Value: Integer);
  6284. begin
  6285.   if not F32BitMode and ((Value < 0) or (Value > Limit16)) then
  6286.     ProgressLimitError;
  6287.   if HandleAllocated then
  6288.     SendMessage(Handle, PBM_SETPOS, Value, 0) else
  6289.     FPosition := Value;
  6290. end;
  6291.  
  6292. procedure TProgressBar.SetStep(Value: Integer);
  6293. begin
  6294.   if Value <> FStep then
  6295.   begin
  6296.     FStep := Value;
  6297.     if HandleAllocated then
  6298.       SendMessage(Handle, PBM_SETSTEP, FStep, 0);
  6299.   end;
  6300. end;
  6301.  
  6302. procedure TProgressBar.StepIt;
  6303. begin
  6304.   if HandleAllocated then
  6305.     SendMessage(Handle, PBM_STEPIT, 0, 0);
  6306. end;
  6307.  
  6308. procedure TProgressBar.StepBy(Delta: Integer);
  6309. begin
  6310.   if HandleAllocated then
  6311.     SendMessage(Handle, PBM_DELTAPOS, Delta, 0);
  6312. end;
  6313.  
  6314. { TTextAttributes }
  6315.  
  6316. constructor TTextAttributes.Create(AOwner: TCustomRichEdit;
  6317.   AttributeType: TAttributeType);
  6318. begin
  6319.   inherited Create;
  6320.   RichEdit := AOwner;
  6321.   FType := AttributeType;
  6322. end;
  6323.  
  6324. procedure TTextAttributes.InitFormat(var Format: TCharFormat);
  6325. begin
  6326.   FillChar(Format, SizeOf(TCharFormat), 0);
  6327.   Format.cbSize := SizeOf(TCharFormat);
  6328. end;
  6329.  
  6330. function TTextAttributes.GetConsistentAttributes: TConsistentAttributes;
  6331. var
  6332.   Format: TCharFormat;
  6333. begin
  6334.   Result := [];
  6335.   if RichEdit.HandleAllocated and (FType = atSelected) then
  6336.   begin
  6337.     InitFormat(Format);
  6338.     SendMessage(RichEdit.Handle, EM_GETCHARFORMAT,
  6339.       WPARAM(FType = atSelected), LPARAM(@Format));
  6340.     with Format do
  6341.     begin
  6342.       if (dwMask and CFM_BOLD) <> 0 then Include(Result, caBold);
  6343.       if (dwMask and CFM_COLOR) <> 0 then Include(Result, caColor);
  6344.       if (dwMask and CFM_FACE) <> 0 then Include(Result, caFace);
  6345.       if (dwMask and CFM_ITALIC) <> 0 then Include(Result, caItalic);
  6346.       if (dwMask and CFM_SIZE) <> 0 then Include(Result, caSize);
  6347.       if (dwMask and CFM_STRIKEOUT) <> 0 then Include(Result, caStrikeOut);
  6348.       if (dwMask and CFM_UNDERLINE) <> 0 then Include(Result, caUnderline);
  6349.       if (dwMask and CFM_PROTECTED) <> 0 then Include(Result, caProtected);
  6350.     end;
  6351.   end;
  6352. end;
  6353.  
  6354. procedure TTextAttributes.GetAttributes(var Format: TCharFormat);
  6355. begin
  6356.   InitFormat(Format);
  6357.   if RichEdit.HandleAllocated then
  6358.     SendMessage(RichEdit.Handle, EM_GETCHARFORMAT,
  6359.       WPARAM(FType = atSelected), LPARAM(@Format));
  6360. end;
  6361.  
  6362. procedure TTextAttributes.SetAttributes(var Format: TCharFormat);
  6363. var
  6364.   Flag: Longint;
  6365. begin
  6366.   if FType = atSelected then Flag := SCF_SELECTION
  6367.   else Flag := 0;
  6368.   if RichEdit.HandleAllocated then
  6369.     SendMessage(RichEdit.Handle, EM_SETCHARFORMAT, Flag, LPARAM(@Format))
  6370. end;
  6371.  
  6372. function TTextAttributes.GetCharset: TFontCharset;
  6373. var
  6374.   Format: TCharFormat;
  6375. begin
  6376.   GetAttributes(Format);
  6377.   Result := Format.bCharset;
  6378. end;
  6379.  
  6380. procedure TTextAttributes.SetCharset(Value: TFontCharset);
  6381. var
  6382.   Format: TCharFormat;
  6383. begin
  6384.   InitFormat(Format);
  6385.   with Format do
  6386.   begin
  6387.     dwMask := CFM_CHARSET;
  6388.     bCharSet := Value;
  6389.   end;
  6390.   SetAttributes(Format);
  6391. end;
  6392.  
  6393. function TTextAttributes.GetProtected: Boolean;
  6394. var
  6395.   Format: TCharFormat;
  6396. begin
  6397.   GetAttributes(Format);
  6398.   with Format do
  6399.     if (dwEffects and CFE_PROTECTED) <> 0 then
  6400.       Result := True else
  6401.       Result := False;
  6402. end;
  6403.  
  6404. procedure TTextAttributes.SetProtected(Value: Boolean);
  6405. var
  6406.   Format: TCharFormat;
  6407. begin
  6408.   InitFormat(Format);
  6409.   with Format do
  6410.   begin
  6411.     dwMask := CFM_PROTECTED;
  6412.     if Value then dwEffects := CFE_PROTECTED;
  6413.   end;
  6414.   SetAttributes(Format);
  6415. end;
  6416.  
  6417. function TTextAttributes.GetColor: TColor;
  6418. var
  6419.   Format: TCharFormat;
  6420. begin
  6421.   GetAttributes(Format);
  6422.   with Format do
  6423.     if (dwEffects and CFE_AUTOCOLOR) <> 0 then
  6424.       Result := clWindowText else
  6425.       Result := crTextColor;
  6426. end;
  6427.  
  6428. procedure TTextAttributes.SetColor(Value: TColor);
  6429. var
  6430.   Format: TCharFormat;
  6431. begin
  6432.   InitFormat(Format);
  6433.   with Format do
  6434.   begin
  6435.     dwMask := CFM_COLOR;
  6436.     if Value = clWindowText then
  6437.       dwEffects := CFE_AUTOCOLOR else
  6438.       crTextColor := ColorToRGB(Value);
  6439.   end;
  6440.   SetAttributes(Format);
  6441. end;
  6442.  
  6443. function TTextAttributes.GetName: TFontName;
  6444. var
  6445.   Format: TCharFormat;
  6446. begin
  6447.   GetAttributes(Format);
  6448.   Result := Format.szFaceName;
  6449. end;
  6450.  
  6451. procedure TTextAttributes.SetName(Value: TFontName);
  6452. var
  6453.   Format: TCharFormat;
  6454. begin
  6455.   InitFormat(Format);
  6456.   with Format do
  6457.   begin
  6458.     dwMask := CFM_FACE;
  6459.     StrPLCopy(szFaceName, Value, SizeOf(szFaceName));
  6460.   end;
  6461.   SetAttributes(Format);
  6462. end;
  6463.  
  6464. function TTextAttributes.GetStyle: TFontStyles;
  6465. var
  6466.   Format: TCharFormat;
  6467. begin
  6468.   Result := [];
  6469.   GetAttributes(Format);
  6470.   with Format do
  6471.   begin
  6472.     if (dwEffects and CFE_BOLD) <> 0 then Include(Result, fsBold);
  6473.     if (dwEffects and CFE_ITALIC) <> 0 then Include(Result, fsItalic);
  6474.     if (dwEffects and CFE_UNDERLINE) <> 0 then Include(Result, fsUnderline);
  6475.     if (dwEffects and CFE_STRIKEOUT) <> 0 then Include(Result, fsStrikeOut);
  6476.   end;
  6477. end;
  6478.  
  6479. procedure TTextAttributes.SetStyle(Value: TFontStyles);
  6480. var
  6481.   Format: TCharFormat;
  6482. begin
  6483.   InitFormat(Format);
  6484.   with Format do
  6485.   begin
  6486.     dwMask := CFM_BOLD or CFM_ITALIC or CFM_UNDERLINE or CFM_STRIKEOUT;
  6487.     if fsBold in Value then dwEffects := dwEffects or CFE_BOLD;
  6488.     if fsItalic in Value then dwEffects := dwEffects or CFE_ITALIC;
  6489.     if fsUnderline in Value then dwEffects := dwEffects or CFE_UNDERLINE;
  6490.     if fsStrikeOut in Value then dwEffects := dwEffects or CFE_STRIKEOUT;
  6491.   end;
  6492.   SetAttributes(Format);
  6493. end;
  6494.  
  6495. function TTextAttributes.GetSize: Integer;
  6496. var
  6497.   Format: TCharFormat;
  6498. begin
  6499.   GetAttributes(Format);
  6500.   Result := Format.yHeight div 20;
  6501. end;
  6502.  
  6503. procedure TTextAttributes.SetSize(Value: Integer);
  6504. var
  6505.   Format: TCharFormat;
  6506. begin
  6507.   InitFormat(Format);
  6508.   with Format do
  6509.   begin
  6510.     dwMask := CFM_SIZE;
  6511.     yHeight := Value * 20;
  6512.   end;
  6513.   SetAttributes(Format);
  6514. end;
  6515.  
  6516. function TTextAttributes.GetHeight: Integer;
  6517. begin
  6518.   Result := MulDiv(Size, RichEdit.FScreenLogPixels, 72);
  6519. end;
  6520.  
  6521. procedure TTextAttributes.SetHeight(Value: Integer);
  6522. begin
  6523.   Size := MulDiv(Value, 72, RichEdit.FScreenLogPixels);
  6524. end;
  6525.  
  6526. function TTextAttributes.GetPitch: TFontPitch;
  6527. var
  6528.   Format: TCharFormat;
  6529. begin
  6530.   GetAttributes(Format);
  6531.   case (Format.bPitchAndFamily and $03) of
  6532.     DEFAULT_PITCH: Result := fpDefault;
  6533.     VARIABLE_PITCH: Result := fpVariable;
  6534.     FIXED_PITCH: Result := fpFixed;
  6535.   else
  6536.     Result := fpDefault;
  6537.   end;
  6538. end;
  6539.  
  6540. procedure TTextAttributes.SetPitch(Value: TFontPitch);
  6541. var
  6542.   Format: TCharFormat;
  6543. begin
  6544.   InitFormat(Format);
  6545.   with Format do
  6546.   begin
  6547.     case Value of
  6548.       fpVariable: Format.bPitchAndFamily := VARIABLE_PITCH;
  6549.       fpFixed: Format.bPitchAndFamily := FIXED_PITCH;
  6550.     else
  6551.       Format.bPitchAndFamily := DEFAULT_PITCH;
  6552.     end;
  6553.   end;
  6554.   SetAttributes(Format);
  6555. end;
  6556.  
  6557. procedure TTextAttributes.Assign(Source: TPersistent);
  6558. begin
  6559.   if Source is TFont then
  6560.   begin
  6561.     Color := TFont(Source).Color;
  6562.     Name := TFont(Source).Name;
  6563.     Charset := TFont(Source).Charset;
  6564.     Style := TFont(Source).Style;
  6565.     Size := TFont(Source).Size;
  6566.     Pitch := TFont(Source).Pitch;
  6567.   end
  6568.   else if Source is TTextAttributes then
  6569.   begin
  6570.     Color := TTextAttributes(Source).Color;
  6571.     Name := TTextAttributes(Source).Name;
  6572.     Charset := TTextAttributes(Source).Charset;
  6573.     Style := TTextAttributes(Source).Style;
  6574.     Pitch := TTextAttributes(Source).Pitch;
  6575.   end
  6576.   else inherited Assign(Source);
  6577. end;
  6578.  
  6579. procedure TTextAttributes.AssignTo(Dest: TPersistent);
  6580. begin
  6581.   if Dest is TFont then
  6582.   begin
  6583.     TFont(Dest).Color := Color;
  6584.     TFont(Dest).Name := Name;
  6585.     TFont(Dest).Charset := Charset;
  6586.     TFont(Dest).Style := Style;
  6587.     TFont(Dest).Size := Size;
  6588.     TFont(Dest).Pitch := Pitch;
  6589.   end
  6590.   else if Dest is TTextAttributes then
  6591.   begin
  6592.     TTextAttributes(Dest).Color := Color;
  6593.     TTextAttributes(Dest).Name := Name;
  6594.     TTextAttributes(Dest).Charset := Charset;
  6595.     TTextAttributes(Dest).Style := Style;
  6596.     TTextAttributes(Dest).Pitch := Pitch;
  6597.   end
  6598.   else inherited AssignTo(Dest);
  6599. end;
  6600.  
  6601. { TParaAttributes }
  6602.  
  6603. constructor TParaAttributes.Create(AOwner: TCustomRichEdit);
  6604. begin
  6605.   inherited Create;
  6606.   RichEdit := AOwner;
  6607. end;
  6608.  
  6609. procedure TParaAttributes.InitPara(var Paragraph: TParaFormat);
  6610. begin
  6611.   FillChar(Paragraph, SizeOf(TParaFormat), 0);
  6612.   Paragraph.cbSize := SizeOf(TParaFormat);
  6613. end;
  6614.  
  6615. procedure TParaAttributes.GetAttributes(var Paragraph: TParaFormat);
  6616. begin
  6617.   InitPara(Paragraph);
  6618.   if RichEdit.HandleAllocated then
  6619.     SendMessage(RichEdit.Handle, EM_GETPARAFORMAT, 0, LPARAM(@Paragraph));
  6620. end;
  6621.  
  6622. procedure TParaAttributes.SetAttributes(var Paragraph: TParaFormat);
  6623. begin
  6624.   if RichEdit.HandleAllocated then
  6625.     SendMessage(RichEdit.Handle, EM_SETPARAFORMAT, 0, LPARAM(@Paragraph))
  6626. end;
  6627.  
  6628. function TParaAttributes.GetAlignment: TAlignment;
  6629. var
  6630.   Paragraph: TParaFormat;
  6631. begin
  6632.   GetAttributes(Paragraph);
  6633.   Result := TAlignment(Paragraph.wAlignment - 1);
  6634. end;
  6635.  
  6636. procedure TParaAttributes.SetAlignment(Value: TAlignment);
  6637. var
  6638.   Paragraph: TParaFormat;
  6639. begin
  6640.   InitPara(Paragraph);
  6641.   with Paragraph do
  6642.   begin
  6643.     dwMask := PFM_ALIGNMENT;
  6644.     wAlignment := Ord(Value) + 1;
  6645.   end;
  6646.   SetAttributes(Paragraph);
  6647. end;
  6648.  
  6649. function TParaAttributes.GetNumbering: TNumberingStyle;
  6650. var
  6651.   Paragraph: TParaFormat;
  6652. begin
  6653.   GetAttributes(Paragraph);
  6654.   Result := TNumberingStyle(Paragraph.wNumbering);
  6655. end;
  6656.  
  6657. procedure TParaAttributes.SetNumbering(Value: TNumberingStyle);
  6658. var
  6659.   Paragraph: TParaFormat;
  6660. begin
  6661.   case Value of
  6662.     nsBullet: if LeftIndent < 10 then LeftIndent := 10;
  6663.     nsNone: LeftIndent := 0;
  6664.   end;
  6665.   InitPara(Paragraph);
  6666.   with Paragraph do
  6667.   begin
  6668.     dwMask := PFM_NUMBERING;
  6669.     wNumbering := Ord(Value);
  6670.   end;
  6671.   SetAttributes(Paragraph);
  6672. end;
  6673.  
  6674. function TParaAttributes.GetFirstIndent: Longint;
  6675. var
  6676.   Paragraph: TParaFormat;
  6677. begin
  6678.   GetAttributes(Paragraph);
  6679.   Result := Paragraph.dxStartIndent div 20
  6680. end;
  6681.  
  6682. procedure TParaAttributes.SetFirstIndent(Value: Longint);
  6683. var
  6684.   Paragraph: TParaFormat;
  6685. begin
  6686.   InitPara(Paragraph);
  6687.   with Paragraph do
  6688.   begin
  6689.     dwMask := PFM_STARTINDENT;
  6690.     dxStartIndent := Value * 20;
  6691.   end;
  6692.   SetAttributes(Paragraph);
  6693. end;
  6694.  
  6695. function TParaAttributes.GetLeftIndent: Longint;
  6696. var
  6697.   Paragraph: TParaFormat;
  6698. begin
  6699.   GetAttributes(Paragraph);
  6700.   Result := Paragraph.dxOffset div 20;
  6701. end;
  6702.  
  6703. procedure TParaAttributes.SetLeftIndent(Value: Longint);
  6704. var
  6705.   Paragraph: TParaFormat;
  6706. begin
  6707.   InitPara(Paragraph);
  6708.   with Paragraph do
  6709.   begin
  6710.     dwMask := PFM_OFFSET;
  6711.     dxOffset := Value * 20;
  6712.   end;
  6713.   SetAttributes(Paragraph);
  6714. end;
  6715.  
  6716. function TParaAttributes.GetRightIndent: Longint;
  6717. var
  6718.   Paragraph: TParaFormat;
  6719. begin
  6720.   GetAttributes(Paragraph);
  6721.   Result := Paragraph.dxRightIndent div 20;
  6722. end;
  6723.  
  6724. procedure TParaAttributes.SetRightIndent(Value: Longint);
  6725. var
  6726.   Paragraph: TParaFormat;
  6727. begin
  6728.   InitPara(Paragraph);
  6729.   with Paragraph do
  6730.   begin
  6731.     dwMask := PFM_RIGHTINDENT;
  6732.     dxRightIndent := Value * 20;
  6733.   end;
  6734.   SetAttributes(Paragraph);
  6735. end;
  6736.  
  6737. function TParaAttributes.GetTab(Index: Byte): Longint;
  6738. var
  6739.   Paragraph: TParaFormat;
  6740. begin
  6741.   GetAttributes(Paragraph);
  6742.   Result := Paragraph.rgxTabs[Index] div 20;
  6743. end;
  6744.  
  6745. procedure TParaAttributes.SetTab(Index: Byte; Value: Longint);
  6746. var
  6747.   Paragraph: TParaFormat;
  6748. begin
  6749.   GetAttributes(Paragraph);
  6750.   with Paragraph do
  6751.   begin
  6752.     rgxTabs[Index] := Value * 20;
  6753.     dwMask := PFM_TABSTOPS;
  6754.     if cTabCount < Index then cTabCount := Index;
  6755.     SetAttributes(Paragraph);
  6756.   end;
  6757. end;
  6758.  
  6759. function TParaAttributes.GetTabCount: Integer;
  6760. var
  6761.   Paragraph: TParaFormat;
  6762. begin
  6763.   GetAttributes(Paragraph);
  6764.   Result := Paragraph.cTabCount;
  6765. end;
  6766.  
  6767. procedure TParaAttributes.SetTabCount(Value: Integer);
  6768. var
  6769.   Paragraph: TParaFormat;
  6770. begin
  6771.   GetAttributes(Paragraph);
  6772.   with Paragraph do
  6773.   begin
  6774.     dwMask := PFM_TABSTOPS;
  6775.     cTabCount := Value;
  6776.     SetAttributes(Paragraph);
  6777.   end;
  6778. end;
  6779.  
  6780. procedure TParaAttributes.Assign(Source: TPersistent);
  6781. var
  6782.   I: Integer;
  6783. begin
  6784.   if Source is TParaAttributes then
  6785.   begin
  6786.     Alignment := TParaAttributes(Source).Alignment;
  6787.     FirstIndent := TParaAttributes(Source).FirstIndent;
  6788.     LeftIndent := TParaAttributes(Source).LeftIndent;
  6789.     RightIndent := TParaAttributes(Source).RightIndent;
  6790.     Numbering := TParaAttributes(Source).Numbering;
  6791.     for I := 0 to MAX_TAB_STOPS - 1 do
  6792.       Tab[I] := TParaAttributes(Source).Tab[I];
  6793.   end
  6794.   else inherited Assign(Source);
  6795. end;
  6796.  
  6797. { TConversion }
  6798.  
  6799. function TConversion.ConvertReadStream(Stream: TStream; Buffer: PChar; BufSize: Integer): Integer;
  6800. begin
  6801.   Result := Stream.Read(Buffer^, BufSize);
  6802. end;
  6803.  
  6804. function TConversion.ConvertWriteStream(Stream: TStream; Buffer: PChar; BufSize: Integer): Integer;
  6805. begin
  6806.   Result := Stream.Write(Buffer^, BufSize);
  6807. end;
  6808.  
  6809. { TRichEditStrings }
  6810.  
  6811. const
  6812.   ReadError = $0001;
  6813.   WriteError = $0002;
  6814.   NoError = $0000;
  6815.  
  6816. type
  6817.   TSelection = record
  6818.     StartPos, EndPos: Integer;
  6819.   end;
  6820.  
  6821.   TRichEditStrings = class(TStrings)
  6822.   private
  6823.     RichEdit: TCustomRichEdit;
  6824.     FPlainText: Boolean;
  6825.     FConverter: TConversion;
  6826.     procedure EnableChange(const Value: Boolean);
  6827.   protected
  6828.     function Get(Index: Integer): string; override;
  6829.     function GetCount: Integer; override;
  6830.     procedure Put(Index: Integer; const S: string); override;
  6831.     procedure SetUpdateState(Updating: Boolean); override;
  6832.     procedure SetTextStr(const Value: string); override;
  6833.   public
  6834.     procedure Clear; override;
  6835.     procedure AddStrings(Strings: TStrings); override;
  6836.     procedure Delete(Index: Integer); override;
  6837.     procedure Insert(Index: Integer; const S: string); override;
  6838.     procedure LoadFromFile(const FileName: string); override;
  6839.     procedure LoadFromStream(Stream: TStream); override;
  6840.     procedure SaveToFile(const FileName: string); override;
  6841.     procedure SaveToStream(Stream: TStream); override;
  6842.     property PlainText: Boolean read FPlainText write FPlainText;
  6843.   end;
  6844.  
  6845. procedure TRichEditStrings.AddStrings(Strings: TStrings);
  6846. var
  6847.   SelChange: TNotifyEvent;
  6848. begin
  6849.   SelChange := RichEdit.OnSelectionChange;
  6850.   RichEdit.OnSelectionChange := nil;
  6851.   try
  6852.     inherited AddStrings(Strings);
  6853.   finally
  6854.     RichEdit.OnSelectionChange := SelChange;
  6855.   end;
  6856. end;
  6857.  
  6858. function TRichEditStrings.GetCount: Integer;
  6859. begin
  6860.   Result := SendMessage(RichEdit.Handle, EM_GETLINECOUNT, 0, 0);
  6861.   if SendMessage(RichEdit.Handle, EM_LINELENGTH, SendMessage(RichEdit.Handle,
  6862.     EM_LINEINDEX, Result - 1, 0), 0) = 0 then Dec(Result);
  6863. end;
  6864.  
  6865. function TRichEditStrings.Get(Index: Integer): string;
  6866. var
  6867.   Text: array[0..4095] of Char;
  6868.   L: Integer;
  6869. begin
  6870.   Word((@Text)^) := SizeOf(Text);
  6871.   L := SendMessage(RichEdit.Handle, EM_GETLINE, Index, Longint(@Text));
  6872.   if (Text[L - 2] = #13) and (Text[L - 1] = #10) then Dec(L, 2);
  6873.   SetString(Result, Text, L);
  6874. end;
  6875.  
  6876. procedure TRichEditStrings.Put(Index: Integer; const S: string);
  6877. var
  6878.   Selection: TCharRange;
  6879. begin
  6880.   if Index >= 0 then
  6881.   begin
  6882.     Selection.cpMin := SendMessage(RichEdit.Handle, EM_LINEINDEX, Index, 0);
  6883.     if Selection.cpMin <> -1 then
  6884.     begin
  6885.       Selection.cpMax := Selection.cpMin +
  6886.         SendMessage(RichEdit.Handle, EM_LINELENGTH, Selection.cpMin, 0);
  6887.       SendMessage(RichEdit.Handle, EM_EXSETSEL, 0, Longint(@Selection));
  6888.       SendMessage(RichEdit.Handle, EM_REPLACESEL, 0, Longint(PChar(S)));
  6889.     end;
  6890.   end;
  6891. end;
  6892.  
  6893. procedure TRichEditStrings.Insert(Index: Integer; const S: string);
  6894. var
  6895.   L: Integer;
  6896.   Selection: TCharRange;
  6897.   Fmt: PChar;
  6898.   Str: string;
  6899. begin
  6900.   if Index >= 0 then
  6901.   begin
  6902.     Selection.cpMin := SendMessage(RichEdit.Handle, EM_LINEINDEX, Index, 0);
  6903.     if Selection.cpMin >= 0 then Fmt := '%s'#13#10
  6904.     else begin
  6905.       Selection.cpMin :=
  6906.         SendMessage(RichEdit.Handle, EM_LINEINDEX, Index - 1, 0);
  6907.       if Selection.cpMin < 0 then Exit;
  6908.       L := SendMessage(RichEdit.Handle, EM_LINELENGTH, Selection.cpMin, 0);
  6909.       if L = 0 then Exit;
  6910.       Inc(Selection.cpMin, L);
  6911.       Fmt := #13#10'%s';
  6912.     end;
  6913.     Selection.cpMax := Selection.cpMin;
  6914.     SendMessage(RichEdit.Handle, EM_EXSETSEL, 0, Longint(@Selection));
  6915.     Str := Format(Fmt, [S]);
  6916.     SendMessage(RichEdit.Handle, EM_REPLACESEL, 0, LongInt(PChar(Str)));
  6917.     if RichEdit.SelStart <> (Selection.cpMax + Length(Str)) then
  6918.       raise EOutOfResources.Create(sRichEditInsertError);
  6919.   end;
  6920. end;
  6921.  
  6922. procedure TRichEditStrings.Delete(Index: Integer);
  6923. const
  6924.   Empty: PChar = '';
  6925. var
  6926.   Selection: TCharRange;
  6927. begin
  6928.   if Index < 0 then Exit;
  6929.   Selection.cpMin := SendMessage(RichEdit.Handle, EM_LINEINDEX, Index, 0);
  6930.   if Selection.cpMin <> -1 then
  6931.   begin
  6932.     Selection.cpMax := SendMessage(RichEdit.Handle, EM_LINEINDEX, Index + 1, 0);
  6933.     if Selection.cpMax = -1 then
  6934.       Selection.cpMax := Selection.cpMin +
  6935.         SendMessage(RichEdit.Handle, EM_LINELENGTH, Selection.cpMin, 0);
  6936.     SendMessage(RichEdit.Handle, EM_EXSETSEL, 0, Longint(@Selection));
  6937.     SendMessage(RichEdit.Handle, EM_REPLACESEL, 0, Longint(Empty));
  6938.   end;
  6939. end;
  6940.  
  6941. procedure TRichEditStrings.Clear;
  6942. begin
  6943.   RichEdit.Clear;
  6944. end;
  6945.  
  6946. procedure TRichEditStrings.SetUpdateState(Updating: Boolean);
  6947. begin
  6948.   SendMessage(RichEdit.Handle, WM_SETREDRAW, Ord(not Updating), 0);
  6949.   if not Updating then begin
  6950.     RichEdit.Refresh;
  6951.     RichEdit.Perform(CM_TEXTCHANGED, 0, 0);
  6952.   end;
  6953. end;
  6954.  
  6955. procedure TRichEditStrings.EnableChange(const Value: Boolean);
  6956. var
  6957.   EventMask: Longint;
  6958. begin
  6959.   with RichEdit do
  6960.   begin
  6961.     if Value then
  6962.       EventMask := SendMessage(Handle, EM_GETEVENTMASK, 0, 0) or ENM_CHANGE
  6963.     else
  6964.       EventMask := SendMessage(Handle, EM_GETEVENTMASK, 0, 0) and not ENM_CHANGE;
  6965.     SendMessage(Handle, EM_SETEVENTMASK, 0, EventMask);
  6966.   end;
  6967. end;
  6968.  
  6969. procedure TRichEditStrings.SetTextStr(const Value: string);
  6970. begin
  6971.   EnableChange(False);
  6972.   try
  6973.     inherited SetTextStr(Value);
  6974.   finally
  6975.     EnableChange(True);
  6976.   end;
  6977. end;
  6978.  
  6979. function AdjustLineBreaks(Dest, Source: PChar): Integer; assembler;
  6980. asm
  6981.         PUSH    ESI
  6982.         PUSH    EDI
  6983.         MOV     EDI,EAX
  6984.         MOV     ESI,EDX
  6985.         MOV     EDX,EAX
  6986.         CLD
  6987. @@1:    LODSB
  6988. @@2:    OR      AL,AL
  6989.         JE      @@4
  6990.         CMP     AL,0AH
  6991.         JE      @@3
  6992.         STOSB
  6993.         CMP     AL,0DH
  6994.         JNE     @@1
  6995.         MOV     AL,0AH
  6996.         STOSB
  6997.         LODSB
  6998.         CMP     AL,0AH
  6999.         JE      @@1
  7000.         JMP     @@2
  7001. @@3:    MOV     EAX,0A0DH
  7002.         STOSW
  7003.         JMP     @@1
  7004. @@4:    STOSB
  7005.         LEA     EAX,[EDI-1]
  7006.         SUB     EAX,EDX
  7007.         POP     EDI
  7008.         POP     ESI
  7009. end;
  7010.  
  7011. function StreamSave(dwCookie: Longint; pbBuff: PByte;
  7012.   cb: Longint; var pcb: Longint): Longint; stdcall;
  7013. var
  7014.   StreamInfo: PRichEditStreamInfo;
  7015. begin
  7016.   Result := NoError;
  7017.   StreamInfo := PRichEditStreamInfo(Pointer(dwCookie));
  7018.   try
  7019.     pcb := 0;
  7020.     if StreamInfo^.Converter <> nil then
  7021.       pcb := StreamInfo^.Converter.ConvertWriteStream(StreamInfo^.Stream, PChar(pbBuff), cb);
  7022.   except
  7023.     Result := WriteError;
  7024.   end;
  7025. end;
  7026.  
  7027. function StreamLoad(dwCookie: Longint; pbBuff: PByte;
  7028.   cb: Longint; var pcb: Longint): Longint; stdcall;
  7029. var
  7030.   Buffer, pBuff: PChar;
  7031.   StreamInfo: PRichEditStreamInfo;
  7032. begin
  7033.   Result := NoError;
  7034.   StreamInfo := PRichEditStreamInfo(Pointer(dwCookie));
  7035.   Buffer := StrAlloc(cb + 1);
  7036.   try
  7037.     cb := cb div 2;
  7038.     pcb := 0;
  7039.     pBuff := Buffer + cb;
  7040.     try
  7041.       if StreamInfo^.Converter <> nil then
  7042.         pcb := StreamInfo^.Converter.ConvertReadStream(StreamInfo^.Stream, pBuff, cb);
  7043.       if pcb > 0 then
  7044.       begin
  7045.         pBuff[pcb] := #0;
  7046.         if pBuff[pcb - 1] = #13 then pBuff[pcb - 1] := #0;
  7047.         pcb := AdjustLineBreaks(Buffer, pBuff);
  7048.         Move(Buffer^, pbBuff^, pcb);
  7049.       end;
  7050.     except
  7051.       Result := ReadError;
  7052.     end;
  7053.   finally
  7054.     StrDispose(Buffer);
  7055.   end;
  7056. end;
  7057.  
  7058. procedure TRichEditStrings.LoadFromStream(Stream: TStream);
  7059. var
  7060.   EditStream: TEditStream;
  7061.   Position: Longint;
  7062.   TextType: Longint;
  7063.   StreamInfo: TRichEditStreamInfo;
  7064.   Converter: TConversion;
  7065. begin
  7066.   StreamInfo.Stream := Stream;
  7067.   if FConverter <> nil then
  7068.     Converter := FConverter else
  7069.     Converter := RichEdit.DefaultConverter.Create;
  7070.   StreamInfo.Converter := Converter;
  7071.   try
  7072.     with EditStream do
  7073.     begin
  7074.       dwCookie := LongInt(Pointer(@StreamInfo));
  7075.       pfnCallBack := @StreamLoad;
  7076.       dwError := 0;
  7077.     end;
  7078.     Position := Stream.Position;
  7079.     if PlainText then TextType := SF_TEXT
  7080.     else TextType := SF_RTF;
  7081.     SendMessage(RichEdit.Handle, EM_STREAMIN, TextType, Longint(@EditStream));
  7082.     if (TextType = SF_RTF) and (EditStream.dwError <> 0) then
  7083.     begin
  7084.       Stream.Position := Position;
  7085.       if PlainText then TextType := SF_RTF
  7086.       else TextType := SF_TEXT;
  7087.       SendMessage(RichEdit.Handle, EM_STREAMIN, TextType, Longint(@EditStream));
  7088.       if EditStream.dwError <> 0 then
  7089.         raise EOutOfResources.Create(sRichEditLoadFail);
  7090.     end;
  7091.   finally
  7092.     if FConverter = nil then Converter.Free;
  7093.   end;
  7094. end;
  7095.  
  7096. procedure TRichEditStrings.SaveToStream(Stream: TStream);
  7097. var
  7098.   EditStream: TEditStream;
  7099.   TextType: Longint;
  7100.   StreamInfo: TRichEditStreamInfo;
  7101.   Converter: TConversion;
  7102. begin
  7103.   if FConverter <> nil then
  7104.     Converter := FConverter else
  7105.     Converter := RichEdit.DefaultConverter.Create;
  7106.   StreamInfo.Stream := Stream;
  7107.   StreamInfo.Converter := Converter;
  7108.   try
  7109.     with EditStream do
  7110.     begin
  7111.       dwCookie := LongInt(Pointer(@StreamInfo));
  7112.       pfnCallBack := @StreamSave;
  7113.       dwError := 0;
  7114.     end;
  7115.     if PlainText then TextType := SF_TEXT
  7116.     else TextType := SF_RTF;
  7117.     SendMessage(RichEdit.Handle, EM_STREAMOUT, TextType, Longint(@EditStream));
  7118.     if EditStream.dwError <> 0 then
  7119.       raise EOutOfResources.Create(sRichEditSaveFail);
  7120.   finally
  7121.     if FConverter = nil then Converter.Free;
  7122.   end;
  7123. end;
  7124.  
  7125. procedure TRichEditStrings.LoadFromFile(const FileName: string);
  7126. var
  7127.   Ext: string;
  7128.   Convert: PConversionFormat;
  7129. begin
  7130.   Ext := AnsiLowerCaseFileName(ExtractFileExt(Filename));
  7131.   System.Delete(Ext, 1, 1);
  7132.   Convert := ConversionFormatList;
  7133.   while Convert <> nil do
  7134.     with Convert^ do
  7135.       if Extension <> Ext then Convert := Next
  7136.       else Break;
  7137.   if Convert = nil then
  7138.     Convert := @TextConversionFormat;
  7139.   FConverter := Convert^.ConversionClass.Create;
  7140.   try
  7141.     inherited LoadFromFile(FileName);
  7142.   except
  7143.     FConverter.Free;
  7144.     FConverter := nil;
  7145.     raise;
  7146.   end;
  7147. end;
  7148.  
  7149. procedure TRichEditStrings.SaveToFile(const FileName: string);
  7150. var
  7151.   Ext: string;
  7152.   Convert: PConversionFormat;
  7153. begin
  7154.   Ext := AnsiLowerCaseFileName(ExtractFileExt(Filename));
  7155.   System.Delete(Ext, 1, 1);
  7156.   Convert := ConversionFormatList;
  7157.   while Convert <> nil do
  7158.     with Convert^ do
  7159.       if Extension <> Ext then Convert := Next
  7160.       else Break;
  7161.   if Convert = nil then
  7162.     Convert := @TextConversionFormat;
  7163.   FConverter := Convert^.ConversionClass.Create;
  7164.   try
  7165.     inherited SaveToFile(FileName);
  7166.   except
  7167.     FConverter.Free;
  7168.     FConverter := nil;
  7169.     raise;
  7170.   end;
  7171. end;
  7172.  
  7173. { TRichEdit }
  7174.  
  7175. constructor TCustomRichEdit.Create(AOwner: TComponent);
  7176. var
  7177.   DC: HDC;
  7178. begin
  7179.   inherited Create(AOwner);
  7180.   FSelAttributes := TTextAttributes.Create(Self, atSelected);
  7181.   FDefAttributes := TTextAttributes.Create(Self, atDefaultText);
  7182.   FParagraph := TParaAttributes.Create(Self);
  7183.   FRichEditStrings := TRichEditStrings.Create;
  7184.   TRichEditStrings(FRichEditStrings).RichEdit := Self;
  7185.   TabStop := True;
  7186.   Width := 185;
  7187.   Height := 89;
  7188.   AutoSize := False;
  7189.   FHideSelection := True;
  7190.   HideScrollBars := True;
  7191.   DC := GetDC(0);
  7192.   FScreenLogPixels := GetDeviceCaps(DC, LOGPIXELSY);
  7193.   DefaultConverter := TConversion;
  7194.   ReleaseDC(0, DC);
  7195. end;
  7196.  
  7197. destructor TCustomRichEdit.Destroy;
  7198. begin
  7199.   FSelAttributes.Free;
  7200.   FDefAttributes.Free;
  7201.   FParagraph.Free;
  7202.   FRichEditStrings.Free;
  7203.   FMemStream.Free;
  7204.   inherited Destroy;
  7205. end;
  7206.  
  7207. procedure TCustomRichEdit.Clear;
  7208. begin
  7209.   inherited Clear;
  7210.   Modified := False;
  7211. end;
  7212.  
  7213. procedure TCustomRichEdit.CreateParams(var Params: TCreateParams);
  7214. const
  7215.   RichEditModuleName = 'RICHED32.DLL';
  7216.   HideScrollBars: array[Boolean] of Longint = (ES_DISABLENOSCROLL, 0);
  7217.   HideSelections: array[Boolean] of Longint = (ES_NOHIDESEL, 0);
  7218. var
  7219.   OldError: Longint;
  7220. begin
  7221.   OldError := SetErrorMode(SEM_NOOPENFILEERRORBOX);
  7222.   FLibHandle := LoadLibrary(RichEditModuleName);
  7223.   if (FLibHandle > 0) and (FLibHandle < HINSTANCE_ERROR) then FLibHandle := 0;
  7224.   SetErrorMode(OldError);
  7225.   inherited CreateParams(Params);
  7226.   CreateSubClass(Params, 'RICHEDIT');
  7227.   with Params do
  7228.   begin
  7229.     Style := Style or HideScrollBars[FHideScrollBars] or
  7230.       HideSelections[HideSelection];
  7231.     WindowClass.style := WindowClass.style and not (CS_HREDRAW or CS_VREDRAW);
  7232.   end;
  7233. end;
  7234.  
  7235. procedure TCustomRichEdit.CreateWnd;
  7236. var
  7237.   Plain, DesignMode: Boolean;
  7238. begin
  7239.   inherited CreateWnd;
  7240.   if (SysLocale.FarEast) and not (SysLocale.PriLangID = LANG_JAPANESE) then
  7241.     Font.Charset := GetDefFontCharSet;
  7242.   SendMessage(Handle, EM_SETEVENTMASK, 0,
  7243.     ENM_CHANGE or ENM_SELCHANGE or ENM_REQUESTRESIZE or
  7244.     ENM_PROTECTED);
  7245.   SendMessage(Handle, EM_SETBKGNDCOLOR, 0, ColorToRGB(Color));
  7246.   if FMemStream <> nil then
  7247.   begin
  7248.     Plain := PlainText;
  7249.     FMemStream.ReadBuffer(DesignMode, sizeof(DesignMode));
  7250.     PlainText := DesignMode;
  7251.     try
  7252.       Lines.LoadFromStream(FMemStream);
  7253.       FMemStream.Free;
  7254.       FMemStream := nil;
  7255.     finally
  7256.       PlainText := Plain;
  7257.     end;
  7258.   end;
  7259.   Modified := FModified;
  7260. end;
  7261.  
  7262. procedure TCustomRichEdit.DestroyWnd;
  7263. var
  7264.   Plain, DesignMode: Boolean;
  7265. begin
  7266.   FModified := Modified;
  7267.   FMemStream := TMemoryStream.Create;
  7268.   Plain := PlainText;
  7269.   DesignMode := (csDesigning in ComponentState);
  7270.   PlainText := DesignMode;
  7271.   FMemStream.WriteBuffer(DesignMode, sizeof(DesignMode));
  7272.   try
  7273.     Lines.SaveToStream(FMemStream);
  7274.     FMemStream.Position := 0;
  7275.   finally
  7276.     PlainText := Plain;
  7277.   end;
  7278.   inherited DestroyWnd;
  7279. end;
  7280.  
  7281. procedure TCustomRichEdit.WMNCDestroy(var Message: TWMNCDestroy);
  7282. begin
  7283.   inherited;
  7284.   if FLibHandle <> 0 then FreeLibrary(FLibHandle);
  7285. end;
  7286.  
  7287. procedure TCustomRichEdit.WMSetFont(var Message: TWMSetFont);
  7288. begin
  7289.   FDefAttributes.Assign(Font);
  7290. end;
  7291.  
  7292. procedure TCustomRichEdit.CMFontChanged(var Message: TMessage);
  7293. begin
  7294.   FDefAttributes.Assign(Font);
  7295. end;
  7296.  
  7297. procedure TCustomRichEdit.DoSetMaxLength(Value: Integer);
  7298. begin
  7299.   SendMessage(Handle, EM_EXLIMITTEXT, 0, Value);
  7300. end;
  7301.  
  7302. function TCustomRichEdit.GetSelLength: Integer;
  7303. var
  7304.   CharRange: TCharRange;
  7305. begin
  7306.   SendMessage(Handle, EM_EXGETSEL, 0, Longint(@CharRange));
  7307.   Result := CharRange.cpMax - CharRange.cpMin;
  7308. end;
  7309.  
  7310. function TCustomRichEdit.GetSelStart: Integer;
  7311. var
  7312.   CharRange: TCharRange;
  7313. begin
  7314.   SendMessage(Handle, EM_EXGETSEL, 0, Longint(@CharRange));
  7315.   Result := CharRange.cpMin;
  7316. end;
  7317.  
  7318. function TCustomRichEdit.GetSelTextBuf(Buffer: PChar; BufSize: Integer): Integer;
  7319. var
  7320.   S: string;
  7321. begin
  7322.   S := GetSelText;
  7323.   Result := Length(S);
  7324.   if BufSize < Length(S) then Result := BufSize;
  7325.   StrPLCopy(Buffer, S, Result);
  7326. end;
  7327.  
  7328. function TCustomRichEdit.GetSelText: string;
  7329. var
  7330.   Length: Integer;
  7331. begin
  7332.   SetLength(Result, GetSelLength + 1);
  7333.   Length := SendMessage(Handle, EM_GETSELTEXT, 0, Longint(PChar(Result)));
  7334.   SetLength(Result, Length);
  7335. end;
  7336.  
  7337. procedure TCustomRichEdit.SetHideScrollBars(Value: Boolean);
  7338. begin
  7339.   if HideScrollBars <> Value then
  7340.   begin
  7341.     FHideScrollBars := value;
  7342.     RecreateWnd;
  7343.   end;
  7344. end;
  7345.  
  7346. procedure TCustomRichEdit.SetHideSelection(Value: Boolean);
  7347. begin
  7348.   if HideSelection <> Value then
  7349.   begin
  7350.     FHideSelection := Value;
  7351.     SendMessage(Handle, EM_HIDESELECTION, Ord(HideSelection), LongInt(True));
  7352.   end;
  7353. end;
  7354.  
  7355. procedure TCustomRichEdit.SetSelAttributes(Value: TTextAttributes);
  7356. begin
  7357.   SelAttributes.Assign(Value);
  7358. end;
  7359.  
  7360. procedure TCustomRichEdit.SetSelLength(Value: Integer);
  7361. var
  7362.   CharRange: TCharRange;
  7363. begin
  7364.   SendMessage(Handle, EM_EXGETSEL, 0, Longint(@CharRange));
  7365.   CharRange.cpMax := CharRange.cpMin + Value;
  7366.   SendMessage(Handle, EM_EXSETSEL, 0, Longint(@CharRange));
  7367.   SendMessage(Handle, EM_SCROLLCARET, 0, 0);
  7368. end;
  7369.  
  7370. procedure TCustomRichEdit.SetDefAttributes(Value: TTextAttributes);
  7371. begin
  7372.   DefAttributes.Assign(Value);
  7373. end;
  7374.  
  7375. function TCustomRichEdit.GetPlainText: Boolean;
  7376. begin
  7377.   Result := TRichEditStrings(Lines).PlainText;
  7378. end;
  7379.  
  7380. procedure TCustomRichEdit.SetPlainText(Value: Boolean);
  7381. begin
  7382.   TRichEditStrings(Lines).PlainText := Value;
  7383. end;
  7384.  
  7385. procedure TCustomRichEdit.CMColorChanged(var Message: TMessage);
  7386. begin
  7387.   inherited;
  7388.   SendMessage(Handle, EM_SETBKGNDCOLOR, 0, ColorToRGB(Color))
  7389. end;
  7390.  
  7391. procedure TCustomRichEdit.SetRichEditStrings(Value: TStrings);
  7392. begin
  7393.   FRichEditStrings.Assign(Value);
  7394. end;
  7395.  
  7396. procedure TCustomRichEdit.SetSelStart(Value: Integer);
  7397. var
  7398.   CharRange: TCharRange;
  7399. begin
  7400.   CharRange.cpMin := Value;
  7401.   CharRange.cpMax := Value;
  7402.   SendMessage(Handle, EM_EXSETSEL, 0, Longint(@CharRange));
  7403. end;
  7404.  
  7405. procedure TCustomRichEdit.Print(const Caption: string);
  7406. var
  7407.   Range: TFormatRange;
  7408.   LastChar, MaxLen, LogX, LogY, OldMap: Integer;
  7409. begin
  7410.   FillChar(Range, SizeOf(TFormatRange), 0);
  7411.   with Printer, Range do
  7412.   begin
  7413.     Title := Caption;
  7414.     BeginDoc;
  7415.     hdc := Handle;
  7416.     hdcTarget := hdc;
  7417.     LogX := GetDeviceCaps(Handle, LOGPIXELSX);
  7418.     LogY := GetDeviceCaps(Handle, LOGPIXELSY);
  7419.     if IsRectEmpty(PageRect) then
  7420.     begin
  7421.       rc.right := PageWidth * 1440 div LogX;
  7422.       rc.bottom := PageHeight * 1440 div LogY;
  7423.     end
  7424.     else begin
  7425.       rc.left := PageRect.Left * 1440 div LogX;
  7426.       rc.top := PageRect.Top * 1440 div LogY;
  7427.       rc.right := PageRect.Right * 1440 div LogX;
  7428.       rc.bottom := PageRect.Bottom * 1440 div LogY;
  7429.     end;
  7430.     rcPage := rc;
  7431.     LastChar := 0;
  7432.     MaxLen := GetTextLen;
  7433.     chrg.cpMax := -1;
  7434.     // ensure printer DC is in text map mode
  7435.     OldMap := SetMapMode(hdc, MM_TEXT);
  7436.     SendMessage(Handle, EM_FORMATRANGE, 0, 0);    // flush buffer
  7437.     try
  7438.       repeat
  7439.         chrg.cpMin := LastChar;
  7440.         LastChar := SendMessage(Self.Handle, EM_FORMATRANGE, 1, Longint(@Range));
  7441.         if (LastChar < MaxLen) and (LastChar <> -1) then NewPage;
  7442.       until (LastChar >= MaxLen) or (LastChar = -1);
  7443.       EndDoc;
  7444.     finally
  7445.       SendMessage(Handle, EM_FORMATRANGE, 0, 0);  // flush buffer
  7446.       SetMapMode(hdc, OldMap);       // restore previous map mode
  7447.     end;
  7448.   end;
  7449. end;
  7450.  
  7451. var
  7452.   Painting: Boolean = False;
  7453.  
  7454. procedure TCustomRichEdit.WMPaint(var Message: TWMPaint);
  7455. var
  7456.   R, R1: TRect;
  7457. begin
  7458.   if GetUpdateRect(Handle, R, True) then
  7459.   begin
  7460.     with ClientRect do R1 := Rect(Right - 3, Top, Right, Bottom);
  7461.     if IntersectRect(R, R, R1) then InvalidateRect(Handle, @R1, True);
  7462.   end;
  7463.   if Painting then
  7464.     Invalidate
  7465.   else begin
  7466.     Painting := True;
  7467.     try
  7468.       inherited;
  7469.     finally
  7470.       Painting := False;
  7471.     end;
  7472.   end;
  7473. end;
  7474.  
  7475. procedure TCustomRichEdit.WMSetCursor(var Message: TWMSetCursor);
  7476. var
  7477.   P: TPoint;
  7478. begin
  7479.   inherited;
  7480.   if Message.Result = 0 then
  7481.   begin
  7482.     Message.Result := 1;
  7483.     GetCursorPos(P);
  7484.     with PointToSmallPoint(P) do
  7485.       case Perform(WM_NCHITTEST, 0, MakeLong(X, Y)) of
  7486.         HTVSCROLL,
  7487.         HTHSCROLL:
  7488.           Windows.SetCursor(Screen.Cursors[crArrow]);
  7489.         HTCLIENT:
  7490.           Windows.SetCursor(Screen.Cursors[crIBeam]);
  7491.       end;
  7492.   end;
  7493. end;
  7494.  
  7495. procedure TCustomRichEdit.CNNotify(var Message: TWMNotify);
  7496. begin
  7497.   with Message.NMHdr^ do
  7498.     case code of
  7499.       EN_SELCHANGE: SelectionChange;
  7500.       EN_REQUESTRESIZE: RequestSize(PReqSize(Pointer(Message.NMHdr))^.rc);
  7501.       EN_SAVECLIPBOARD:
  7502.         with PENSaveClipboard(Pointer(Message.NMHdr))^ do
  7503.           if not SaveClipboard(cObjectCount, cch) then Message.Result := 1;
  7504.       EN_PROTECTED:
  7505.         with PENProtected(Pointer(Message.NMHdr))^.chrg do
  7506.           if not ProtectChange(cpMin, cpMax) then Message.Result := 1;
  7507.     end;
  7508. end;
  7509.  
  7510. function TCustomRichEdit.SaveClipboard(NumObj, NumChars: Integer): Boolean;
  7511. begin
  7512.   Result := True;
  7513.   if Assigned(OnSaveClipboard) then OnSaveClipboard(Self, NumObj, NumChars, Result);
  7514. end;
  7515.  
  7516. function TCustomRichEdit.ProtectChange(StartPos, EndPos: Integer): Boolean;
  7517. begin
  7518.   Result := False;
  7519.   if Assigned(OnProtectChange) then OnProtectChange(Self, StartPos, EndPos, Result);
  7520. end;
  7521.  
  7522. procedure TCustomRichEdit.SelectionChange;
  7523. begin
  7524.   if Assigned(OnSelectionChange) then OnSelectionChange(Self);
  7525. end;
  7526.  
  7527. procedure TCustomRichEdit.RequestSize(const Rect: TRect);
  7528. begin
  7529.   if Assigned(OnResizeRequest) then OnResizeRequest(Self, Rect);
  7530. end;
  7531.  
  7532. function TCustomRichEdit.FindText(const SearchStr: string;
  7533.   StartPos, Length: Integer; Options: TSearchTypes): Integer;
  7534. var
  7535.   Find: TFindText;
  7536.   Flags: Integer;
  7537. begin
  7538.   with Find.chrg do
  7539.   begin
  7540.     cpMin := StartPos;
  7541.     cpMax := cpMin + Length;
  7542.   end;
  7543.   Flags := 0;
  7544.   if stWholeWord in Options then Flags := Flags or FT_WHOLEWORD;
  7545.   if stMatchCase in Options then Flags := Flags or FT_MATCHCASE;
  7546.   Find.lpstrText := PChar(SearchStr);
  7547.   Result := SendMessage(Handle, EM_FINDTEXT, Flags, LongInt(@Find));
  7548. end;
  7549.  
  7550. procedure AppendConversionFormat(const Ext: string; AClass: TConversionClass);
  7551. var
  7552.   NewRec: PConversionFormat;
  7553. begin
  7554.   New(NewRec);
  7555.   with NewRec^ do
  7556.   begin
  7557.     Extension := AnsiLowerCaseFileName(Ext);
  7558.     ConversionClass := AClass;
  7559.     Next := ConversionFormatList;
  7560.   end;
  7561.   ConversionFormatList := NewRec;
  7562. end;
  7563.  
  7564. class procedure TCustomRichEdit.RegisterConversionFormat(const AExtension: string;
  7565.   AConversionClass: TConversionClass);
  7566. begin
  7567.   AppendConversionFormat(AExtension, AConversionClass);
  7568. end;
  7569.  
  7570. { TUpDown }
  7571.  
  7572. constructor TCustomUpDown.Create(AOwner: TComponent);
  7573. begin
  7574.   inherited Create(AOwner);
  7575.   Width := GetSystemMetrics(SM_CXVSCROLL);
  7576.   Height := GetSystemMetrics(SM_CYVSCROLL);
  7577.   Height := Height + (Height div 2);
  7578.   FArrowKeys := True;
  7579.   FMax := 100;
  7580.   FIncrement := 1;
  7581.   FAlignButton := udRight;
  7582.   FOrientation := udVertical;
  7583.   FThousands := True;
  7584.   ControlStyle := ControlStyle - [csDoubleClicks];
  7585. end;
  7586.  
  7587. procedure TCustomUpDown.CreateParams(var Params: TCreateParams);
  7588. begin
  7589.   InitCommonControl(ICC_UPDOWN_CLASS);
  7590.   inherited CreateParams(Params);
  7591.   with Params do
  7592.   begin
  7593.     Style := Style or UDS_SETBUDDYINT;
  7594.     if FAlignButton = udRight then Style := Style or UDS_ALIGNRIGHT
  7595.     else Style := Style or UDS_ALIGNLEFT;
  7596.     if FOrientation = udHorizontal then Style := Style or UDS_HORZ;
  7597.     if FArrowKeys then Style := Style or UDS_ARROWKEYS;
  7598.     if not FThousands then Style := Style or UDS_NOTHOUSANDS;
  7599.     if FWrap then Style := Style or UDS_WRAP;
  7600.   end;
  7601.   CreateSubClass(Params, UPDOWN_CLASS);
  7602.   with Params.WindowClass do
  7603.     style := style and not (CS_HREDRAW or CS_VREDRAW) or CS_DBLCLKS;
  7604. end;
  7605.  
  7606. procedure TCustomUpDown.CreateWnd;
  7607. var
  7608.   OrigWidth: Integer;
  7609.   AccelArray: array [0..0] of TUDAccel;
  7610. begin
  7611.   OrigWidth := Width;  { control resizes width - disallowing user to set width }
  7612.   inherited CreateWnd;
  7613.   Width := OrigWidth;
  7614.  
  7615.   if FAssociate <> nil then
  7616.   begin
  7617.     UndoAutoResizing(FAssociate);
  7618.     SendMessage(Handle, UDM_SETBUDDY, FAssociate.Handle, 0);
  7619.   end;
  7620.  
  7621.   SendMessage(Handle, UDM_SETRANGE, 0, MakeLong(FMax, FMin));
  7622.   SendMessage(Handle, UDM_SETPOS, 0, MakeLong(FPosition, 0));
  7623.   SendMessage(Handle, UDM_GETACCEL, 1, Longint(@AccelArray));
  7624.   AccelArray[0].nInc := FIncrement;
  7625.   SendMessage(Handle, UDM_SETACCEL, 1, Longint(@AccelArray));
  7626. end;
  7627.  
  7628. procedure TCustomUpDown.WMVScroll(var Message: TWMVScroll);
  7629. begin
  7630.   inherited;
  7631.   if Message.ScrollCode = SB_THUMBPOSITION then
  7632.   begin
  7633.     if Message.Pos > FPosition then Click(btNext)
  7634.     else if Message.Pos < FPosition then Click(btPrev);
  7635.     FPosition := Message.Pos;
  7636.   end;
  7637. end;
  7638.  
  7639. procedure TCustomUpDown.WMSize(var Message: TWMSize);
  7640. var
  7641.   R: TRect;
  7642. begin
  7643.   inherited;
  7644.   R := ClientRect;
  7645.   InvalidateRect(Handle, @R, False);
  7646. end;
  7647.  
  7648. procedure TCustomUpDown.WMHScroll(var Message: TWMHScroll);
  7649. begin
  7650.   inherited;
  7651.   if Message.ScrollCode = SB_THUMBPOSITION then
  7652.   begin
  7653.     if Message.Pos > FPosition then Click(btNext)
  7654.     else if Message.Pos < FPosition then Click(btPrev);
  7655.     FPosition := Message.Pos;
  7656.   end;
  7657. end;
  7658.  
  7659. function TCustomUpDown.CanChange: Boolean;
  7660. begin
  7661.   Result := True;
  7662.   if Assigned(FOnChanging) then
  7663.     FOnChanging(Self, Result);
  7664. end;
  7665.  
  7666. procedure TCustomUpDown.CNNotify(var Message: TWMNotify);
  7667. begin
  7668.   with Message.NMHdr^ do
  7669.   begin
  7670.     case code of
  7671.       UDN_DELTAPOS: LongBool(Message.Result) := not CanChange;
  7672.     end;
  7673.   end;
  7674. end;
  7675.  
  7676. procedure TCustomUpDown.Click(Button: TUDBtnType);
  7677. begin
  7678.   if Assigned(FOnClick) then FOnClick(Self, Button);
  7679. end;
  7680.  
  7681. procedure TCustomUpDown.SetAssociate(Value: TWinControl);
  7682. var
  7683.   I: Integer;
  7684.  
  7685.   function IsClass(ClassType: TClass; const Name: string): Boolean;
  7686.   begin
  7687.     Result := True;
  7688.     while ClassType <> nil do
  7689.     begin
  7690.       if ClassType.ClassNameIs(Name) then Exit;
  7691.       ClassType := ClassType.ClassParent;
  7692.     end;
  7693.     Result := False;
  7694.   end;
  7695.  
  7696. begin
  7697.   if Value <> nil then
  7698.     for I := 0 to Parent.ControlCount - 1 do // is control already associated
  7699.       if (Parent.Controls[I] is TCustomUpDown) and (Parent.Controls[I] <> Self) then
  7700.         if TCustomUpDown(Parent.Controls[I]).Associate = Value then
  7701.           raise Exception.CreateFmt(sUDAssociated,
  7702.             [Value.Name, Parent.Controls[I].Name]);
  7703.  
  7704.   if FAssociate <> nil then { undo the current associate control }
  7705.   begin
  7706.     if HandleAllocated then
  7707.       SendMessage(Handle, UDM_SETBUDDY, 0, 0);
  7708.     FAssociate := nil;
  7709.   end;
  7710.  
  7711.   if (Value <> nil) and (Value.Parent = Self.Parent) and
  7712.     not (Value is TCustomUpDown) and
  7713.     not (Value is TCustomTreeView) and not (Value is TCustomListView) and
  7714.     not IsClass(Value.ClassType, 'TDBEdit') and
  7715.     not IsClass(Value.ClassType, 'TDBMemo') then
  7716.   begin
  7717.     if HandleAllocated then
  7718.     begin
  7719.       UndoAutoResizing(Value);
  7720.       SendMessage(Handle, UDM_SETBUDDY, Value.Handle, 0);
  7721.     end;
  7722.     FAssociate := Value;
  7723.     if Value is TCustomEdit then
  7724.       TCustomEdit(Value).Text := IntToStr(FPosition);
  7725.   end;
  7726. end;
  7727.  
  7728. procedure TCustomUpDown.UndoAutoResizing(Value: TWinControl);
  7729. var
  7730.   OrigWidth, NewWidth, DeltaWidth: Integer;
  7731.   OrigLeft, NewLeft, DeltaLeft: Integer;
  7732. begin
  7733.   { undo Window's auto-resizing }
  7734.   OrigWidth := Value.Width;
  7735.   OrigLeft := Value.Left;
  7736.   SendMessage(Handle, UDM_SETBUDDY, Value.Handle, 0);
  7737.   NewWidth := Value.Width;
  7738.   NewLeft := Value.Left;
  7739.   DeltaWidth := OrigWidth - NewWidth;
  7740.   DeltaLeft := NewLeft - OrigLeft;
  7741.   Value.Width := OrigWidth + DeltaWidth;
  7742.   Value.Left := OrigLeft - DeltaLeft;
  7743. end;
  7744.  
  7745. procedure TCustomUpDown.Notification(AComponent: TComponent;
  7746.   Operation: TOperation);
  7747. begin
  7748.   inherited Notification(AComponent, Operation);
  7749.   if (Operation = opRemove) and (AComponent = FAssociate) then
  7750.     if HandleAllocated then
  7751.     begin
  7752.       SendMessage(Handle, UDM_SETBUDDY, 0, 0);
  7753.       FAssociate := nil;
  7754.     end;
  7755. end;
  7756.  
  7757. function TCustomUpDown.GetPosition: SmallInt;
  7758. begin
  7759.   if HandleAllocated then
  7760.   begin
  7761.     Result := LoWord(SendMessage(Handle, UDM_GETPOS, 0, 0));
  7762.     FPosition := Result;
  7763.   end
  7764.   else Result := FPosition;
  7765. end;
  7766.  
  7767. procedure TCustomUpDown.SetMin(Value: SmallInt);
  7768. begin
  7769.   if Value <> FMin then
  7770.   begin
  7771.     FMin := Value;
  7772.     if HandleAllocated then
  7773.       SendMessage(Handle, UDM_SETRANGE, 0, MakeLong(FMax, FMin));
  7774.   end;
  7775. end;
  7776.  
  7777. procedure TCustomUpDown.SetMax(Value: SmallInt);
  7778. begin
  7779.   if Value <> FMax then
  7780.   begin
  7781.     FMax := Value;
  7782.     if HandleAllocated then
  7783.       SendMessage(Handle, UDM_SETRANGE, 0, MakeLong(FMax, FMin));
  7784.   end;
  7785. end;
  7786.  
  7787. procedure TCustomUpDown.SetIncrement(Value: Integer);
  7788. var
  7789.   AccelArray: array [0..0] of TUDAccel;
  7790. begin
  7791.   if Value <> FIncrement then
  7792.   begin
  7793.     FIncrement := Value;
  7794.     if HandleAllocated then
  7795.     begin
  7796.       SendMessage(Handle, UDM_GETACCEL, 1, Longint(@AccelArray));
  7797.       AccelArray[0].nInc := Value;
  7798.       SendMessage(Handle, UDM_SETACCEL, 1, Longint(@AccelArray));
  7799.     end;
  7800.   end;
  7801. end;
  7802.  
  7803. procedure TCustomUpDown.SetPosition(Value: SmallInt);
  7804. begin
  7805.   if Value <> FPosition then
  7806.   begin
  7807.     FPosition := Value;
  7808.     if (csDesigning in ComponentState) and (FAssociate <> nil) then
  7809.       if FAssociate is TCustomEdit then
  7810.         TCustomEdit(FAssociate).Text := IntToStr(FPosition);
  7811.     if HandleAllocated then
  7812.       SendMessage(Handle, UDM_SETPOS, 0, MakeLong(FPosition, 0));
  7813.   end;
  7814. end;
  7815.  
  7816. procedure TCustomUpDown.SetOrientation(Value: TUDOrientation);
  7817. begin
  7818.   if Value <> FOrientation then
  7819.   begin
  7820.     FOrientation := Value;
  7821.     if ComponentState * [csLoading, csUpdating] = [] then
  7822.       SetBounds(Left, Top, Height, Width);
  7823.     if HandleAllocated then
  7824.       SendMessage(Handle, UDM_SETBUDDY, 0, 0);
  7825.     RecreateWnd;
  7826.   end;
  7827. end;
  7828.  
  7829. procedure TCustomUpDown.SetAlignButton(Value: TUDAlignButton);
  7830. begin
  7831.   if Value <> FAlignButton then
  7832.   begin
  7833.     FAlignButton := Value;
  7834.     if HandleAllocated then
  7835.       SendMessage(Handle, UDM_SETBUDDY, 0, 0);
  7836.     RecreateWnd;
  7837.   end;
  7838. end;
  7839.  
  7840. procedure TCustomUpDown.SetArrowKeys(Value: Boolean);
  7841. begin
  7842.   if Value <> FArrowKeys then
  7843.   begin
  7844.     FArrowKeys := Value;
  7845.     if HandleAllocated then
  7846.       SendMessage(Handle, UDM_SETBUDDY, 0, 0);
  7847.     RecreateWnd;
  7848.   end;
  7849. end;
  7850.  
  7851. procedure TCustomUpDown.SetThousands(Value: Boolean);
  7852. begin
  7853.   if Value <> FThousands then
  7854.   begin
  7855.     FThousands := Value;
  7856.     if HandleAllocated then
  7857.       SendMessage(Handle, UDM_SETBUDDY, 0, 0);
  7858.     RecreateWnd;
  7859.   end;
  7860. end;
  7861.  
  7862. procedure TCustomUpDown.SetWrap(Value: Boolean);
  7863. begin
  7864.   if Value <> FWrap then
  7865.   begin
  7866.     FWrap := Value;
  7867.     if HandleAllocated then
  7868.       SendMessage(Handle, UDM_SETBUDDY, 0, 0);
  7869.     RecreateWnd;
  7870.   end;
  7871. end;
  7872.  
  7873. { THotKey }
  7874.  
  7875. constructor TCustomHotKey.Create(AOwner: TComponent);
  7876. begin
  7877.   inherited Create(AOwner);
  7878.   Width := 121;
  7879.   Height := 25;
  7880.   TabStop := True;
  7881.   ParentColor := False;
  7882.   FAutoSize := True;
  7883.   FInvalidKeys := [hcNone, hcShift];
  7884.   FModifiers := [hkAlt];
  7885.   FHotKey := $0041;     // default - 'Alt+A'
  7886.   AdjustHeight;
  7887. end;
  7888.  
  7889. procedure TCustomHotKey.CreateParams(var Params: TCreateParams);
  7890. begin
  7891.   InitCommonControl(ICC_HOTKEY_CLASS);
  7892.   inherited CreateParams(Params);
  7893.   CreateSubClass(Params, HOTKEYCLASS);
  7894.   with Params.WindowClass do
  7895.     style := style and not (CS_HREDRAW or CS_VREDRAW);
  7896. end;
  7897.  
  7898. procedure TCustomHotKey.CreateWnd;
  7899. begin
  7900.   inherited CreateWnd;
  7901.   SendMessage(Handle, HKM_SETRULES, Byte(FInvalidKeys), MakeLong(Byte(FModifiers), 0));
  7902.   SendMessage(Handle, HKM_SETHOTKEY, MakeWord(Byte(FHotKey), Byte(FModifiers)), 0);
  7903. end;
  7904.  
  7905. procedure TCustomHotKey.SetAutoSize(Value: Boolean);
  7906. begin
  7907.   if FAutoSize <> Value then
  7908.   begin
  7909.     FAutoSize := Value;
  7910.     UpdateHeight;
  7911.   end;
  7912. end;
  7913.  
  7914. procedure TCustomHotKey.SetModifiers(Value: THKModifiers);
  7915. begin
  7916.   if Value <> FModifiers then
  7917.   begin
  7918.     FModifiers := Value;
  7919.     SendMessage(Handle, HKM_SETRULES, Byte(FInvalidKeys), MakeLong(Byte(Value), 0));
  7920.     SendMessage(Handle, HKM_SETHOTKEY, MakeWord(Byte(FHotKey), Byte(FModifiers)), 0);
  7921.   end;
  7922. end;
  7923.  
  7924. procedure TCustomHotKey.SetInvalidKeys(Value: THKInvalidKeys);
  7925. begin
  7926.   if Value <> FInvalidKeys then
  7927.   begin
  7928.     FInvalidKeys := Value;
  7929.     SendMessage(Handle, HKM_SETRULES, Byte(Value), MakeLong(Byte(FModifiers), 0));
  7930.     SendMessage(Handle, HKM_SETHOTKEY, MakeWord(Byte(FHotKey), Byte(FModifiers)), 0);
  7931.   end;
  7932. end;
  7933.  
  7934. function TCustomHotKey.GetHotKey: TShortCut;
  7935. var
  7936.   HK: Longint;
  7937. begin
  7938.   HK := SendMessage(Handle, HKM_GETHOTKEY, 0, 0);
  7939.   Result := HotKeyToShortCut(HK);
  7940. end;
  7941.  
  7942. procedure TCustomHotKey.SetHotKey(Value: TShortCut);
  7943. begin
  7944.   ShortCutToHotKey(Value);
  7945.   SendMessage(Handle, HKM_SETHOTKEY, MakeWord(Byte(FHotKey), Byte(FModifiers)), 0);
  7946. end;
  7947.  
  7948. procedure TCustomHotKey.UpdateHeight;
  7949. begin
  7950.   if FAutoSize then
  7951.   begin
  7952.     ControlStyle := ControlStyle + [csFixedHeight];
  7953.     AdjustHeight;
  7954.   end else
  7955.     ControlStyle := ControlStyle - [csFixedHeight];
  7956. end;
  7957.  
  7958. procedure TCustomHotKey.AdjustHeight;
  7959. var
  7960.   DC: HDC;
  7961.   SaveFont: HFont;
  7962.   I: Integer;
  7963.   SysMetrics, Metrics: TTextMetric;
  7964. begin
  7965.   DC := GetDC(0);
  7966.   GetTextMetrics(DC, SysMetrics);
  7967.   SaveFont := SelectObject(DC, Font.Handle);
  7968.   GetTextMetrics(DC, Metrics);
  7969.   SelectObject(DC, SaveFont);
  7970.   ReleaseDC(0, DC);
  7971.   if NewStyleControls then
  7972.   begin
  7973.     if Ctl3D then I := 8 else I := 6;
  7974.     I := GetSystemMetrics(SM_CYBORDER) * I;
  7975.   end else
  7976.   begin
  7977.     I := SysMetrics.tmHeight;
  7978.     if I > Metrics.tmHeight then I := Metrics.tmHeight;
  7979.     I := I div 4 + GetSystemMetrics(SM_CYBORDER) * 4;
  7980.   end;
  7981.   Height := Metrics.tmHeight + I;
  7982. end;
  7983.  
  7984. procedure TCustomHotKey.ShortCutToHotKey(Value: TShortCut);
  7985. begin
  7986.   FHotKey := Value and not (scShift + scCtrl + scAlt);
  7987.   FModifiers := [];
  7988.   if Value and scShift <> 0 then Include(FModifiers, hkShift);
  7989.   if Value and scCtrl <> 0 then Include(FModifiers, hkCtrl);
  7990.   if Value and scAlt <> 0 then Include(FModifiers, hkAlt);
  7991. end;
  7992.  
  7993. function TCustomHotKey.HotKeyToShortCut(Value: Longint): TShortCut;
  7994. begin
  7995.   Byte(FModifiers) := LoWord(HiByte(Value));
  7996.   FHotKey := LoWord(LoByte(Value));
  7997.   Result := FHotKey;
  7998.   if hkShift in FModifiers then Inc(Result, scShift);
  7999.   if hkCtrl in FModifiers then Inc(Result, scCtrl);
  8000.   if hkAlt in FModifiers then Inc(Result, scAlt);
  8001. end;
  8002.  
  8003. { TListColumn }
  8004.  
  8005. constructor TListColumn.Create(Collection: TCollection);
  8006. var
  8007.   Column: TLVColumn;
  8008. begin
  8009.   inherited Create(Collection);
  8010.   FWidth := 50;
  8011.   FAlignment := taLeftJustify;
  8012.   with Column do
  8013.   begin
  8014.     mask := LVCF_FMT or LVCF_WIDTH;
  8015.     fmt := LVCFMT_LEFT;
  8016.     cx := FWidth;
  8017.   end;
  8018.   ListView_InsertColumn(TListColumns(Collection).Owner.Handle, Index, Column);
  8019. end;
  8020.  
  8021. destructor TListColumn.Destroy;
  8022. begin
  8023.   if TListColumns(Collection).Owner.HandleAllocated then
  8024.     ListView_DeleteColumn(TListColumns(Collection).Owner.Handle, Index);
  8025.   inherited Destroy;
  8026. end;
  8027.  
  8028. procedure TListColumn.DefineProperties(Filer: TFiler);
  8029. begin
  8030.   inherited DefineProperties(Filer);
  8031.   Filer.DefineProperty('WidthType', ReadData, WriteData,
  8032.     WidthType <= ColumnTextWidth);
  8033. end;
  8034.  
  8035. procedure TListColumn.ReadData(Reader: TReader);
  8036. begin
  8037.   with Reader do
  8038.   begin
  8039.     ReadListBegin;
  8040.     Width := TWidth(ReadInteger);
  8041.     ReadListEnd;
  8042.   end;
  8043. end;
  8044.  
  8045. procedure TListColumn.WriteData(Writer: TWriter);
  8046. begin
  8047.   with Writer do
  8048.   begin
  8049.     WriteListBegin;
  8050.     WriteInteger(Ord(WidthType));
  8051.     WriteListEnd;
  8052.   end;
  8053. end;
  8054.  
  8055. procedure TListColumn.DoChange;
  8056.  
  8057.   procedure WriteCols;
  8058.   var
  8059.     Writer: TWriter;
  8060.     LV: TCustomListView;
  8061.   begin
  8062.     LV := TListColumns(Collection).Owner;
  8063.     if LV.HandleAllocated or ([csLoading, csReading] * LV.ComponentState <> []) or
  8064.       LV.FReading then Exit;
  8065.     if LV.FColStream = nil then LV.FColStream := TMemoryStream.Create
  8066.     else LV.FColStream.Size := 0;
  8067.     Writer := TWriter.Create(LV.FColStream, 1024);
  8068.     try
  8069.       Writer.WriteCollection(Collection);
  8070.     finally
  8071.       Writer.Free;
  8072.       LV.FColStream.Position := 0;
  8073.     end;
  8074.   end;
  8075.  
  8076. var
  8077.   I: Integer;
  8078. begin
  8079.   for I := 0 to Collection.Count - 1 do
  8080.     if TListColumn(Collection.Items[I]).WidthType <= ColumnTextWidth then Break;
  8081.   Changed(I <> Collection.Count);
  8082.   WriteCols;
  8083. end;
  8084.  
  8085. procedure TListColumn.SetCaption(const Value: string);
  8086. begin
  8087.   if FCaption <> Value then
  8088.   begin
  8089.     FCaption := Value;
  8090.     DoChange;
  8091.   end;
  8092. end;
  8093.  
  8094. function TListColumn.GetWidth: TWidth;
  8095. var
  8096.   Column: TLVColumn;
  8097.   ListView: TCustomListView;
  8098. begin
  8099.   ListView := TListColumns(Collection).Owner;
  8100.   if ListView.HandleAllocated then
  8101.   begin
  8102.     Column.mask := LVCF_WIDTH;
  8103.     ListView_GetColumn(ListView.Handle, Index, Column);
  8104.     Result := Column.cx;
  8105.     if WidthType > ColumnTextWidth then FWidth := Result;
  8106.   end
  8107.   else Result := FWidth;
  8108. end;
  8109.  
  8110. procedure TListColumn.SetWidth(Value: TWidth);
  8111. begin
  8112.   if FWidth <> Value then
  8113.   begin
  8114.     FWidth := Value;
  8115.     DoChange;
  8116.   end;
  8117. end;
  8118.  
  8119. procedure TListColumn.SetAlignment(Value: TAlignment);
  8120. begin
  8121.   if (Alignment <> Value) and (Index <> 0) then
  8122.   begin
  8123.     FAlignment := Value;
  8124.     Changed(False);
  8125.     TListColumns(Collection).Owner.Repaint;
  8126.   end;
  8127. end;
  8128.  
  8129. procedure TListColumn.Assign(Source: TPersistent);
  8130. var
  8131.   Column: TListColumn;
  8132. begin
  8133.   if Source is TListColumn then
  8134.   begin
  8135.     Column := TListColumn(Source);
  8136.     Alignment := Column.Alignment;
  8137.     Width := Column.Width;
  8138.     Caption := Column.Caption;
  8139.   end
  8140.   else inherited Assign(Source);
  8141. end;
  8142.  
  8143. function TListColumn.GetDisplayName: string;
  8144. begin
  8145.   Result := Caption;
  8146.   if Result = '' then Result := inherited GetDisplayName;
  8147. end;
  8148.  
  8149. { TListColumns }
  8150.  
  8151. constructor TListColumns.Create(AOwner: TCustomListView);
  8152. begin
  8153.   inherited Create(TListColumn);
  8154.   FOwner := AOwner;
  8155. end;
  8156.  
  8157. function TListColumns.GetItem(Index: Integer): TListColumn;
  8158. begin
  8159.   Result := TListColumn(inherited GetItem(Index));
  8160. end;
  8161.  
  8162. procedure TListColumns.SetItem(Index: Integer; Value: TListColumn);
  8163. begin
  8164.   inherited SetItem(Index, Value);
  8165. end;
  8166.  
  8167. function TListColumns.Add: TListColumn;
  8168. begin
  8169.   Result := TListColumn(inherited Add);
  8170. end;
  8171.  
  8172. function TListColumns.GetOwner: TPersistent;
  8173. begin
  8174.   Result := FOwner;
  8175. end;
  8176.  
  8177. procedure TListColumns.Update(Item: TCollectionItem);
  8178. begin
  8179.   if Item <> nil then
  8180.     Owner.UpdateColumn(Item.Index) else
  8181.     Owner.UpdateColumns;
  8182. end;
  8183.  
  8184. { TSubItems }
  8185.  
  8186. type
  8187.   TSubItems = class(TStringList)
  8188.   private
  8189.     FOwner: TListItem;
  8190.     procedure SetColumnWidth(Index: Integer);
  8191.     procedure RefreshItem(Index: Integer);
  8192.   protected
  8193.     function GetHandle: HWND;
  8194.     function Add(const S: string): Integer; override;
  8195.     procedure Put(Index: Integer; const S: string); override;
  8196.     procedure SetUpdateState(Updating: Boolean); override;
  8197.   public
  8198.     constructor Create(AOwner: TListItem);
  8199.     procedure Insert(Index: Integer; const S: string); override;
  8200.     property Handle: HWND read GetHandle;
  8201.     property Owner: TListItem read FOwner;
  8202.   end;
  8203.  
  8204. constructor TSubItems.Create(AOwner: TListItem);
  8205. begin
  8206.   inherited Create;
  8207.   FOwner := AOwner;
  8208. end;
  8209.  
  8210. function TSubItems.Add(const S: string): Integer;
  8211. begin
  8212.   Result := inherited Add(S);
  8213.   RefreshItem(Result + 1);
  8214. end;
  8215.  
  8216. function TSubItems.GetHandle: HWND;
  8217. begin
  8218.   Result := Owner.Owner.Handle;
  8219. end;
  8220.  
  8221. procedure TSubItems.SetColumnWidth(Index: Integer);
  8222. var
  8223.   ListView: TCustomListView;
  8224. begin
  8225.   ListView := Owner.ListView;
  8226.   if ListView.ColumnsShowing and
  8227.     (ListView.Columns.Count > Index) and
  8228.     (ListView.Column[Index].WidthType = ColumnTextWidth) then
  8229.     ListView.UpdateColumn(Index);
  8230. end;
  8231.  
  8232. procedure TSubItems.Insert(Index: Integer; const S: string);
  8233. var
  8234.   i: Integer;
  8235. begin
  8236.   inherited Insert(Index, S);
  8237.   for i := Index + 1 to Count do RefreshItem(i);
  8238. end;
  8239.  
  8240. procedure TSubItems.Put(Index: Integer; const S: string);
  8241. begin
  8242.   inherited Put(Index, S);
  8243.   RefreshItem(Index + 1);
  8244. end;
  8245.  
  8246. procedure TSubItems.RefreshItem(Index: Integer);
  8247. begin
  8248.   ListView_SetItemText(Handle, Owner.Index, Index, LPSTR_TEXTCALLBACK);
  8249.   SetColumnWidth(Index);
  8250. end;
  8251.  
  8252. procedure TSubItems.SetUpdateState(Updating: Boolean);
  8253. begin
  8254.   Owner.Owner.SetUpdateState(Updating);
  8255. end;
  8256.  
  8257. { TListItem }
  8258.  
  8259. constructor TListItem.Create(AOwner: TListItems);
  8260. begin
  8261.   FOwner := AOwner;
  8262.   FSubItems := TSubItems.Create(Self);
  8263.   FOverlayIndex := -1;
  8264.   FStateIndex := -1;
  8265. end;
  8266.  
  8267. destructor TListItem.Destroy;
  8268. begin
  8269.   FDeleting := True;
  8270.   if Owner.Owner.FLastDropTarget = Self then
  8271.     Owner.Owner.FLastDropTarget := nil;
  8272.   if ListView.HandleAllocated then ListView_DeleteItem(Handle, Index);
  8273.   FSubItems.Free;
  8274.   inherited Destroy;
  8275. end;
  8276.  
  8277. function TListItem.GetListView: TCustomListView;
  8278. begin
  8279.   Result := Owner.Owner;
  8280. end;
  8281.  
  8282. procedure TListItem.Delete;
  8283. begin
  8284.   if not FDeleting then Free;
  8285. end;
  8286.  
  8287. function TListItem.GetHandle: HWND;
  8288. begin
  8289.   Result := ListView.Handle;
  8290. end;
  8291.  
  8292. procedure TListItem.MakeVisible(PartialOK: Boolean);
  8293. begin
  8294.   ListView_EnsureVisible(Handle, Index, PartialOK);
  8295. end;
  8296.  
  8297. function TListItem.GetChecked: Boolean;
  8298. begin
  8299.   with Owner.Owner do
  8300.     if HandleAllocated then
  8301.       Result := Checkboxes and (ListView_GetCheckState(Handle, Index) <> 0)
  8302.     else
  8303.       Result := Checkboxes and FChecked;
  8304. end;
  8305.  
  8306. procedure TListItem.SetChecked(Value: Boolean);
  8307. var
  8308.   Styles: DWORD;
  8309. begin
  8310.   FChecked := Value;
  8311.   if Owner.Owner.HandleAllocated then
  8312.   begin
  8313.     Owner.Owner.FCheckboxes := True;
  8314.     Styles := ListView_GetExtendedListViewStyle(Handle);
  8315.     ListView_SetExtendedListViewStyle(Handle, Styles or LVS_EX_CHECKBOXES);
  8316.     ListView_SetCheckState(Handle, Index, Value);
  8317.   end;
  8318. end;
  8319.  
  8320. function TListItem.GetLeft: Integer;
  8321. begin
  8322.   Result := GetPosition.X;
  8323. end;
  8324.  
  8325. procedure TListItem.SetLeft(Value: Integer);
  8326. begin
  8327.   SetPosition(Point(Value, 0));
  8328. end;
  8329.  
  8330. function TListItem.GetTop: Integer;
  8331. begin
  8332.   Result := GetPosition.Y;
  8333. end;
  8334.  
  8335. procedure TListItem.SetTop(Value: Integer);
  8336. begin
  8337.   SetPosition(Point(0, Value));
  8338. end;
  8339.  
  8340. procedure TListItem.Update;
  8341. begin
  8342.   ListView_Update(Handle, Index);
  8343. end;
  8344.  
  8345. procedure TListItem.SetCaption(const Value: string);
  8346. begin
  8347.   FCaption := Value;
  8348.   ListView_SetItemText(Handle, Index, 0, LPSTR_TEXTCALLBACK);
  8349.   if ListView.ColumnsShowing and
  8350.     (ListView.Columns.Count > 0) and
  8351.     (ListView.Column[0].WidthType <= ColumnTextWidth) then
  8352.     ListView.UpdateColumns;
  8353.   if ListView.SortType in [stBoth, stText] then ListView.AlphaSort;
  8354. end;
  8355.  
  8356. procedure TListItem.SetData(Value: Pointer);
  8357. begin
  8358.   FData := Value;
  8359.   if ListView.SortType in [stBoth, stData] then ListView.AlphaSort;
  8360. end;
  8361.  
  8362. function TListItem.EditCaption: Boolean;
  8363. begin
  8364.   ListView.SetFocus;
  8365.   Result := ListView_EditLabel(Handle, Index) <> 0;
  8366. end;
  8367.  
  8368. procedure TListItem.CancelEdit;
  8369. begin
  8370.   ListView_EditLabel(Handle, -1);
  8371. end;
  8372.  
  8373. function TListItem.GetState(Index: Integer): Boolean;
  8374. var
  8375.   Mask: Integer;
  8376. begin
  8377.   case Index of
  8378.     0: Mask := LVIS_CUT;
  8379.     1: Mask := LVIS_DROPHILITED;
  8380.     2: Mask := LVIS_FOCUSED;
  8381.     3: Mask := LVIS_SELECTED;
  8382.   else
  8383.     Mask := 0;
  8384.   end;
  8385.   Result := ListView_GetItemState(Handle, Self.Index, Mask) and Mask <> 0;
  8386. end;
  8387.  
  8388. procedure TListItem.SetState(Index: Integer; State: Boolean);
  8389. var
  8390.   Mask: Integer;
  8391.   Data: Integer;
  8392. begin
  8393.   case Index of
  8394.     0: Mask := LVIS_CUT;
  8395.     1: Mask := LVIS_DROPHILITED;
  8396.     2: Mask := LVIS_FOCUSED;
  8397.     3: Mask := LVIS_SELECTED;
  8398.   else
  8399.     Mask := 0;
  8400.   end;
  8401.   if State then Data := Mask
  8402.   else Data := 0;
  8403.   ListView_SetItemState(Handle, Self.Index, Data, Mask);
  8404. end;
  8405.  
  8406. procedure TListItem.SetImage(Index: Integer; Value: Integer);
  8407. var
  8408.   Item: TLVItem;
  8409. begin
  8410.   case Index of
  8411.     0:
  8412.       begin
  8413.         FImageIndex := Value;
  8414.         with Item do
  8415.         begin
  8416.           mask := LVIF_IMAGE;
  8417.           iImage := I_IMAGECALLBACK;
  8418.           iItem := Self.Index;
  8419.           iSubItem := 0;
  8420.         end;
  8421.         ListView_SetItem(Handle, Item);
  8422.       end;
  8423.     1:
  8424.       begin
  8425.         FOverlayIndex := Value;
  8426.         ListView_SetItemState(Handle, Self.Index,
  8427.           IndexToOverlayMask(OverlayIndex + 1), LVIS_OVERLAYMASK);
  8428.       end;
  8429.     2:
  8430.       begin
  8431.         FStateIndex := Value;
  8432.         ListView_SetItemState(Handle, Self.Index,
  8433.           IndexToStateImageMask(StateIndex + 1), LVIS_STATEIMAGEMASK);
  8434.       end;
  8435.   end;
  8436.   ListView.UpdateItems(Self.Index, Self.Index);
  8437. end;
  8438.  
  8439. procedure TListItem.Assign(Source: TPersistent);
  8440. begin
  8441.   if Source is TListItem then
  8442.     with Source as TListItem do
  8443.     begin
  8444.       Self.Caption := Caption;
  8445.       Self.Data := Data;
  8446.       Self.ImageIndex := ImageIndex;
  8447.       Self.OverlayIndex := OverlayIndex;
  8448.       Self.StateIndex := StateIndex;
  8449.       Self.SubItems := SubItems;
  8450.     end
  8451.   else inherited Assign(Source);
  8452. end;
  8453.  
  8454. function TListItem.IsEqual(Item: TListItem): Boolean;
  8455. begin
  8456.   Result := (Caption = Item.Caption) and (Data = Item.Data);
  8457. end;
  8458.  
  8459. procedure TListItem.SetSubItems(Value: TStrings);
  8460. begin
  8461.   if Value <> nil then FSubItems.Assign(Value);
  8462. end;
  8463.  
  8464. function TListItem.GetIndex: Integer;
  8465. begin
  8466.   Result := Owner.IndexOf(Self);
  8467. end;
  8468.  
  8469. function TListItem.GetPosition: TPoint;
  8470. begin
  8471.   ListView_GetItemPosition(Handle, Index, Result);
  8472. end;
  8473.  
  8474. procedure TListItem.SetPosition(const Value: TPoint);
  8475. begin
  8476.   if ListView.ViewStyle in [vsSmallIcon, vsIcon] then
  8477.     ListView_SetItemPosition32(Handle, Index, Value.X, Value.Y);
  8478. end;
  8479.  
  8480. function TListItem.DisplayRect(Code: TDisplayCode): TRect;
  8481. const
  8482.   Codes: array[TDisplayCode] of Longint = (LVIR_BOUNDS, LVIR_ICON, LVIR_LABEL,
  8483.     LVIR_SELECTBOUNDS);
  8484. begin
  8485.   ListView_GetItemRect(Handle, Index, Result, Codes[Code]);
  8486. end;
  8487.  
  8488. { TListItems }
  8489.  
  8490. type
  8491.   PItemHeader = ^TItemHeader;
  8492.   TItemHeader = packed record
  8493.     Size, Count: Integer;
  8494.     Items: record end;
  8495.   end;
  8496.   PItemInfo = ^TItemInfo;
  8497.   TItemInfo = packed record
  8498.     ImageIndex: Integer;
  8499.     StateIndex: Integer;
  8500.     OverlayIndex: Integer;
  8501.     SubItemCount: Integer;
  8502.     Data: Pointer;
  8503.     Caption: string[255];
  8504.   end;
  8505.   ShortStr = string[255];
  8506.   PShortStr = ^ShortStr;
  8507.  
  8508. constructor TListItems.Create(AOwner: TCustomListView);
  8509. begin
  8510.   inherited Create;
  8511.   FOwner := AOwner;
  8512. end;
  8513.  
  8514. destructor TListItems.Destroy;
  8515. begin
  8516.   Clear;
  8517.   inherited Destroy;
  8518. end;
  8519.  
  8520. function TListItems.Add: TListItem;
  8521. begin
  8522.   Result := Owner.CreateListItem;
  8523.   ListView_InsertItem(Handle, CreateItem(Count, Result));
  8524. end;
  8525.  
  8526. function TListItems.Insert(Index: Integer): TListItem;
  8527. begin
  8528.   Result := Owner.CreateListItem;
  8529.   ListView_InsertItem(Handle, CreateItem(Index, Result));
  8530. end;
  8531.  
  8532. function TListItems.GetCount: Integer;
  8533. begin
  8534.   if Owner.HandleAllocated then Result := ListView_GetItemCount(Handle)
  8535.   else Result := 0;
  8536. end;
  8537.  
  8538. function TListItems.GetHandle: HWND;
  8539. begin
  8540.   Result := Owner.Handle;
  8541. end;
  8542.  
  8543. function TListItems.GetItem(Index: Integer): TListItem;
  8544. var
  8545.   Item: TLVItem;
  8546. begin
  8547.   Result := nil;
  8548.   if Owner.HandleAllocated then
  8549.   begin
  8550.     with Item do
  8551.     begin
  8552.       mask := LVIF_PARAM;
  8553.       iItem := Index;
  8554.       iSubItem := 0;
  8555.     end;
  8556.     if ListView_GetItem(Handle, Item) then Result := TListItem(Item.lParam);
  8557.   end;
  8558. end;
  8559.  
  8560. function TListItems.IndexOf(Value: TListItem): Integer;
  8561. var
  8562.   Info: TLVFindInfo;
  8563. begin
  8564.   with Info do
  8565.   begin
  8566.     flags := LVFI_PARAM;
  8567.     lParam := Integer(Value);
  8568.   end;
  8569.   Result := ListView_FindItem(Handle, -1, Info);
  8570. end;
  8571.  
  8572. procedure TListItems.SetItem(Index: Integer; Value: TListItem);
  8573. begin
  8574.   Item[Index].Assign(Value);
  8575. end;
  8576.  
  8577. procedure TListItems.Clear;
  8578. begin
  8579.   if Owner.HandleAllocated then ListView_DeleteAllItems(Handle);
  8580. end;
  8581.  
  8582. procedure TListItems.BeginUpdate;
  8583. begin
  8584.   if FUpdateCount = 0 then SetUpdateState(True);
  8585.   Inc(FUpdateCount);
  8586. end;
  8587.  
  8588. procedure TListItems.SetUpdateState(Updating: Boolean);
  8589. var
  8590.   i: Integer;
  8591. begin
  8592.   if Updating then
  8593.   begin
  8594.     with Owner do
  8595.     begin
  8596.       FSavedSort := SortType;
  8597.       SortType := stNone;
  8598.     end;
  8599.     for i := 0 to Owner.Columns.Count - 1 do
  8600.     begin
  8601.       with Owner.Columns[i] as TListColumn do
  8602.         if WidthType < 0 then
  8603.         begin
  8604.           FPrivateWidth := WidthType;
  8605.           FWidth := Width;
  8606.           DoChange;
  8607.         end;
  8608.     end;
  8609.     SendMessage(Handle, WM_SETREDRAW, 0, 0);
  8610.     if Owner.ColumnsShowing and Owner.ValidHeaderHandle then
  8611.       SendMessage(Owner.FHeaderHandle, WM_SETREDRAW, 0, 0);
  8612.   end
  8613.   else if FUpdateCount = 0 then
  8614.   begin
  8615.     Owner.SortType := Owner.FSavedSort;
  8616.     for i := 0 to Owner.Columns.Count - 1 do
  8617.     begin
  8618.       with Owner.Columns[i] as TListColumn do
  8619.         if FPrivateWidth < 0 then
  8620.         begin
  8621.           Width := FPrivateWidth;
  8622.           FPrivateWidth := 0;
  8623.         end;
  8624.     end;
  8625.     FNoRedraw := True;
  8626.     try
  8627.       SendMessage(Handle, WM_SETREDRAW, 1, 0);
  8628.       Owner.Invalidate;
  8629.     finally
  8630.       FNoRedraw := False;
  8631.     end;
  8632.     if Owner.ColumnsShowing and Owner.ValidHeaderHandle then
  8633.       SendMessage(Owner.FHeaderHandle, WM_SETREDRAW, 1, 0);
  8634.   end;
  8635. end;
  8636.  
  8637. procedure TListItems.EndUpdate;
  8638. begin
  8639.   Dec(FUpdateCount);
  8640.   if FUpdateCount = 0 then SetUpdateState(False);
  8641. end;
  8642.  
  8643. procedure TListItems.Assign(Source: TPersistent);
  8644. var
  8645.   Items: TListItems;
  8646.   I: Integer;
  8647. begin
  8648.   if Source is TListItems then
  8649.   begin
  8650.     Clear;
  8651.     Items := TListItems(Source);
  8652.     for I := 0 to Items.Count - 1 do Add.Assign(Items[I]);
  8653.   end
  8654.   else inherited Assign(Source);
  8655. end;
  8656.  
  8657. procedure TListItems.DefineProperties(Filer: TFiler);
  8658.  
  8659.   function WriteItems: Boolean;
  8660.   var
  8661.     I: Integer;
  8662.     Items: TListItems;
  8663.   begin
  8664.     Items := TListItems(Filer.Ancestor);
  8665.     if (Items = nil) then
  8666.       Result := Count > 0
  8667.     else if (Items.Count <> Count) then
  8668.       Result := True
  8669.     else
  8670.     begin
  8671.       Result := False;
  8672.       for I := 0 to Count - 1 do
  8673.       begin
  8674.         Result := not Item[I].IsEqual(Items[I]);
  8675.         if Result then Break;
  8676.       end
  8677.     end;
  8678.   end;
  8679.  
  8680. begin
  8681.   inherited DefineProperties(Filer);
  8682.   Filer.DefineBinaryProperty('Data', ReadData, WriteData, WriteItems);
  8683. end;
  8684.  
  8685. procedure TListItems.ReadData(Stream: TStream);
  8686. var
  8687.   I, J, Size, L, Len: Integer;
  8688.   ItemHeader: PItemHeader;
  8689.   ItemInfo: PItemInfo;
  8690.   PStr: PShortStr;
  8691. begin
  8692.   Clear;
  8693.   Stream.ReadBuffer(Size, SizeOf(Integer));
  8694.   ItemHeader := AllocMem(Size);
  8695.   try
  8696.     Stream.ReadBuffer(ItemHeader^.Count, Size - SizeOf(Integer));
  8697.     ItemInfo := @ItemHeader^.Items;
  8698.     for I := 0 to ItemHeader^.Count - 1 do
  8699.     begin
  8700.       with Add do
  8701.       begin
  8702.         Caption := ItemInfo^.Caption;
  8703.         ImageIndex := ItemInfo^.ImageIndex;
  8704.         OverlayIndex := ItemInfo^.OverlayIndex;
  8705.         StateIndex := ItemInfo^.StateIndex;
  8706.         Data := ItemInfo^.Data;
  8707.         PStr := @ItemInfo^.Caption;
  8708.         Inc(Integer(PStr), Length(PStr^) + 1);
  8709.         Len := 0;
  8710.         for J := 0 to ItemInfo^.SubItemCount - 1 do
  8711.         begin
  8712.           SubItems.Add(PStr^);
  8713.           L := Length(PStr^);
  8714.           Inc(Len, L + 1);
  8715.           Inc(Integer(PStr), L + 1);
  8716.         end;
  8717.       end;
  8718.       Inc(Integer(ItemInfo), SizeOf(TItemInfo) - 255 +
  8719.         Length(ItemInfo.Caption) + Len);
  8720.     end;
  8721.   finally
  8722.     FreeMem(ItemHeader, Size);
  8723.   end;
  8724. end;
  8725.  
  8726. procedure TListItems.WriteData(Stream: TStream);
  8727. var
  8728.   I, J, Size, L, Len: Integer;
  8729.   ItemHeader: PItemHeader;
  8730.   ItemInfo: PItemInfo;
  8731.   PStr: PShortStr;
  8732.  
  8733.   function GetLength(const S: string): Integer;
  8734.   begin
  8735.     Result := Length(S);
  8736.     if Result > 255 then Result := 255;
  8737.   end;
  8738.  
  8739. begin
  8740.   Size := SizeOf(TItemHeader);
  8741.   for I := 0 to Count - 1 do
  8742.   begin
  8743.     L := GetLength(Item[I].Caption);
  8744.     for J := 0 to Item[I].SubItems.Count - 1 do
  8745.       Inc(L, GetLength(Item[I].SubItems[J]) + 1);
  8746.     Inc(Size, SizeOf(TItemInfo) - 255 + L);
  8747.   end;
  8748.   ItemHeader := AllocMem(Size);
  8749.   try
  8750.     ItemHeader^.Size := Size;
  8751.     ItemHeader^.Count := Count;
  8752.     ItemInfo := @ItemHeader^.Items;
  8753.     for I := 0 to Count - 1 do
  8754.     begin
  8755.       with Item[I] do
  8756.       begin
  8757.         ItemInfo^.Caption := Caption;
  8758.         ItemInfo^.ImageIndex := ImageIndex;
  8759.         ItemInfo^.OverlayIndex := OverlayIndex;
  8760.         ItemInfo^.StateIndex := StateIndex;
  8761.         ItemInfo^.Data := Data;
  8762.         ItemInfo^.SubItemCount := SubItems.Count;
  8763.         PStr := @ItemInfo^.Caption;
  8764.         Inc(Integer(PStr), Length(ItemInfo^.Caption) + 1);
  8765.         Len := 0;
  8766.         for J := 0 to SubItems.Count - 1 do
  8767.         begin
  8768.           PStr^ := SubItems[J];
  8769.           L := Length(PStr^);
  8770.           Inc(Len, L + 1);
  8771.           Inc(Integer(PStr), L + 1);
  8772.         end;
  8773.       end;
  8774.       Inc(Integer(ItemInfo), SizeOf(TItemInfo) - 255 +
  8775.         Length(ItemInfo^.Caption) + Len);
  8776.     end;
  8777.     Stream.WriteBuffer(ItemHeader^, Size);
  8778.   finally
  8779.     FreeMem(ItemHeader, Size);
  8780.   end;
  8781. end;
  8782.  
  8783. procedure TListItems.Delete(Index: Integer);
  8784. begin
  8785.   Item[Index].Delete;
  8786. end;
  8787.  
  8788. function TListItems.CreateItem(Index: Integer;
  8789.   ListItem: TListItem): TLVItem;
  8790. begin
  8791.   with Result do
  8792.   begin
  8793.     mask := LVIF_PARAM or LVIF_IMAGE;
  8794.     iItem := Index;
  8795.     iSubItem := 0;
  8796.     iImage := I_IMAGECALLBACK;
  8797.     lParam := Longint(ListItem);
  8798.   end;
  8799. end;
  8800.  
  8801. { TIconOptions }
  8802.  
  8803. constructor TIconOptions.Create(AOwner: TCustomListView);
  8804. begin
  8805.   inherited Create;
  8806.   if AOwner = nil then raise Exception.Create(sInvalidOwner);
  8807.   FListView := AOwner;
  8808.   Arrangement := iaTop;
  8809.   AutoArrange := False;
  8810.   WrapText := True;
  8811. end;
  8812.  
  8813. procedure TIconOptions.SetArrangement(Value: TIconArrangement);
  8814. begin
  8815.   if Value <> Arrangement then
  8816.   begin;
  8817.     FArrangement := Value;
  8818.     FListView.RecreateWnd;
  8819.   end;
  8820. end;
  8821.  
  8822. procedure TIconOptions.SetAutoArrange(Value: Boolean);
  8823. begin
  8824.   if Value <> AutoArrange then
  8825.   begin
  8826.     FAutoArrange := Value;
  8827.     FListView.RecreateWnd;
  8828.   end;
  8829. end;
  8830.  
  8831. procedure TIconOptions.SetWrapText(Value: Boolean);
  8832. begin
  8833.   if Value <> WrapText then
  8834.   begin
  8835.     FWrapText := Value;
  8836.     FListView.RecreateWnd;
  8837.   end;
  8838. end;
  8839.  
  8840. { TCustomListView }
  8841.  
  8842. function DefaultListViewSort(Item1, Item2: TListItem;
  8843.   lParam: Integer): Integer; stdcall;
  8844. begin
  8845.   with Item1 do
  8846.     if Assigned(ListView.OnCompare) then
  8847.       ListView.OnCompare(ListView, Item1, Item2, lParam, Result)
  8848.     else Result := lstrcmp(PChar(Item1.Caption), PChar(Item2.Caption));
  8849. end;
  8850.  
  8851. constructor TCustomListView.Create(AOwner: TComponent);
  8852. begin
  8853.   inherited Create(AOwner);
  8854.   ControlStyle := ControlStyle - [csCaptureMouse] + [csDisplayDragImage, csReflector];
  8855.   Width := 250;
  8856.   Height := 150;
  8857.   BorderStyle := bsSingle;
  8858.   ViewStyle := vsIcon;
  8859.   ParentColor := False;
  8860.   TabStop := True;
  8861.   HideSelection := True;
  8862.   ShowColumnHeaders := True;
  8863.   ColumnClick := True;
  8864.   FDragIndex := -1;
  8865.   FListColumns := TListColumns.Create(Self);
  8866.   FListItems := TListItems.Create(Self);
  8867.   FIconOptions := TIconOptions.Create(Self);
  8868.   FDragImage := TImageList.CreateSize(32, 32);
  8869.   FEditInstance := MakeObjectInstance(EditWndProc);
  8870.   FHeaderInstance := MakeObjectInstance(HeaderWndProc);
  8871.   FLargeChangeLink := TChangeLink.Create;
  8872.   FLargeChangeLink.OnChange := ImageListChange;
  8873.   FSmallChangeLink := TChangeLink.Create;
  8874.   FSmallChangeLink.OnChange := ImageListChange;
  8875.   FStateChangeLink := TChangeLink.Create;
  8876.   FStateChangeLink.OnChange := ImageListChange;
  8877. end;
  8878.  
  8879. destructor TCustomListView.Destroy;
  8880. begin
  8881.   DestroyWindowHandle;
  8882.   FDragImage.Free;
  8883.   FListColumns.Free;
  8884.   FListItems.Free;
  8885.   FIconOptions.Free;
  8886.   FMemStream.Free;
  8887.   FColStream.Free;
  8888.   FCheckStream.Free;
  8889.   FreeObjectInstance(FEditInstance);
  8890.   if FHeaderHandle <> 0 then
  8891.     SetWindowLong(FHeaderHandle, GWL_WNDPROC, LongInt(FDefHeaderProc));
  8892.   FreeObjectInstance(FHeaderInstance);
  8893.   FLargeChangeLink.Free;
  8894.   FSmallChangeLink.Free;
  8895.   FStateChangeLink.Free;
  8896.   inherited Destroy;
  8897. end;
  8898.  
  8899. procedure TCustomListView.CreateParams(var Params: TCreateParams);
  8900. const
  8901.   BorderStyles: array[TBorderStyle] of Integer = (0, WS_BORDER);
  8902.   EditStyles: array[Boolean] of Integer = (LVS_EDITLABELS, 0);
  8903.   MultiSelections: array[Boolean] of Integer = (LVS_SINGLESEL, 0);
  8904.   HideSelections: array[Boolean] of Integer = (LVS_SHOWSELALWAYS, 0);
  8905.   Arrangements: array[TIconArrangement] of Integer = (LVS_ALIGNTOP,
  8906.     LVS_ALIGNLEFT);
  8907.   AutoArrange: array[Boolean] of Integer = (0, LVS_AUTOARRANGE);
  8908.   WrapText: array[Boolean] of Integer = (LVS_NOLABELWRAP, 0);
  8909.   ViewStyles: array[TViewStyle] of Integer = (LVS_ICON, LVS_SMALLICON,
  8910.     LVS_LIST, LVS_REPORT);
  8911.   ShowColumns: array[Boolean] of Integer = (LVS_NOCOLUMNHEADER, 0);
  8912.   ColumnClicks: array[Boolean] of Integer = (LVS_NOSORTHEADER, 0);
  8913. begin
  8914.   InitCommonControl(ICC_LISTVIEW_CLASSES);
  8915.   inherited CreateParams(Params);
  8916.   CreateSubClass(Params, WC_LISTVIEW);
  8917.   with Params do
  8918.   begin
  8919.     Style := Style or WS_CLIPCHILDREN or ViewStyles[ViewStyle] or
  8920.       BorderStyles[BorderStyle] or Arrangements[IconOptions.Arrangement] or
  8921.       EditStyles[ReadOnly] or MultiSelections[MultiSelect] or
  8922.       HideSelections[HideSelection] or
  8923.       AutoArrange[IconOptions.AutoArrange] or
  8924.       WrapText[IconOptions.WrapText] or
  8925.       ShowColumns[ShowColumnHeaders] or
  8926.       ColumnClicks[ColumnClick] or
  8927.       LVS_SHAREIMAGELISTS;
  8928.     if Ctl3D and NewStyleControls and (FBorderStyle = bsSingle) then
  8929.     begin
  8930.       Style := Style and not WS_BORDER;
  8931.       ExStyle := Params.ExStyle or WS_EX_CLIENTEDGE;
  8932.     end;
  8933.     WindowClass.style := WindowClass.style and not (CS_HREDRAW or CS_VREDRAW);
  8934.   end;
  8935. end;
  8936.  
  8937. procedure TCustomListView.CreateWnd;
  8938.  
  8939.   procedure ReadCols;
  8940.   var
  8941.     Reader: TReader;
  8942.   begin
  8943.     if FColStream = nil then Exit;
  8944.     Columns.Clear;
  8945.     Reader := TReader.Create(FColStream, 1024);
  8946.     try
  8947.       Reader.ReadValue;
  8948.       Reader.ReadCollection(Columns);
  8949.     finally
  8950.       Reader.Free;
  8951.     end;
  8952.     FColStream.Destroy;
  8953.     FColStream := nil;
  8954.   end;
  8955.  
  8956. begin
  8957.   inherited CreateWnd;
  8958.   ResetExStyles;
  8959.   SetTextBKColor(Color);
  8960.   SetTextColor(Font.Color);
  8961.   SetAllocBy(AllocBy);
  8962.   if FMemStream <> nil then
  8963.   begin
  8964.     Items.BeginUpdate;
  8965.     FReading := True;
  8966.     try
  8967.       Columns.Clear;
  8968.       FMemStream.ReadComponent(Self);
  8969.       FMemStream.Destroy;
  8970.       FMemStream := nil;
  8971.       if FCheckboxes then RestoreChecks;
  8972.       ReadCols;
  8973.       Font := Font;
  8974.     finally
  8975.       Items.EndUpdate;
  8976.       FReading := False;
  8977.     end;
  8978.   end;
  8979.   if (LargeImages <> nil) and LargeImages.HandleAllocated then
  8980.     SetImageList(LargeImages.Handle, LVSIL_NORMAL);
  8981.   if (SmallImages <> nil) and SmallImages.HandleAllocated then
  8982.     SetImageList(SmallImages.Handle, LVSIL_SMALL);
  8983.   if (StateImages <> nil) and StateImages.HandleAllocated then
  8984.     SetImageList(StateImages.Handle, LVSIL_STATE);
  8985. end;
  8986.  
  8987. procedure TCustomListView.DestroyWnd;
  8988. begin
  8989.   if FMemStream = nil then FMemStream := TMemoryStream.Create
  8990.   else FMemStream.Size := 0;
  8991.   FMemStream.WriteComponent(Self);
  8992.   FMemStream.Position := 0;
  8993.   if FCheckboxes then SaveChecks;
  8994.   inherited DestroyWnd;
  8995. end;
  8996.  
  8997. procedure TCustomListView.SetImageList(Value: HImageList; Flags: Integer);
  8998. begin
  8999.   if HandleAllocated then ListView_SetImageList(Handle, Value, Flags);
  9000. end;
  9001.  
  9002. procedure TCustomListView.ImageListChange(Sender: TObject);
  9003. var
  9004.   ImageHandle: HImageList;
  9005. begin
  9006.   if HandleAllocated then
  9007.   begin
  9008.     ImageHandle := TImageList(Sender).Handle;
  9009.     if Sender = LargeImages then SetImageList(ImageHandle, LVSIL_NORMAL)
  9010.     else if Sender = SmallImages then SetImageList(ImageHandle, LVSIL_SMALL)
  9011.     else if Sender = StateImages then SetImageList(ImageHandle, LVSIL_STATE);
  9012.   end;
  9013. end;
  9014.  
  9015. procedure TCustomListView.Notification(AComponent: TComponent;
  9016.   Operation: TOperation);
  9017. begin
  9018.   inherited Notification(AComponent, Operation);
  9019.   if Operation = opRemove then
  9020.   begin
  9021.     if AComponent = LargeImages then LargeImages := nil;
  9022.     if AComponent = SmallImages then SmallImages := nil;
  9023.     if AComponent = StateImages then StateImages := nil;
  9024.   end;
  9025. end;
  9026.  
  9027. procedure TCustomListView.HeaderWndProc(var Message: TMessage);
  9028. begin
  9029.   try
  9030.     with Message do
  9031.     begin
  9032.       case Msg of
  9033.         WM_NCHITTEST:
  9034.           with TWMNCHitTest(Message) do
  9035.             if csDesigning in ComponentState then
  9036.             begin
  9037.               Result := Windows.HTTRANSPARENT;
  9038.               Exit;
  9039.             end;
  9040.         WM_NCDESTROY:
  9041.           begin
  9042.             Result := CallWindowProc(FDefHeaderProc, FHeaderHandle, Msg, WParam, LParam);
  9043.             FHeaderHandle := 0;
  9044.             FDefHeaderProc := nil;
  9045.             Exit;
  9046.           end;
  9047.       end;
  9048.       Result := CallWindowProc(FDefHeaderProc, FHeaderHandle, Msg, WParam, LParam);
  9049.     end;
  9050.   except
  9051.     Application.HandleException(Self);
  9052.   end;
  9053. end;
  9054.  
  9055. procedure TCustomListView.EditWndProc(var Message: TMessage);
  9056. begin
  9057.   try
  9058.     with Message do
  9059.     begin
  9060.       case Msg of
  9061.         WM_KEYDOWN,
  9062.         WM_SYSKEYDOWN: if DoKeyDown(TWMKey(Message)) then Exit;
  9063.         WM_CHAR: if DoKeyPress(TWMKey(Message)) then Exit;
  9064.         WM_KEYUP,
  9065.         WM_SYSKEYUP: if DoKeyUp(TWMKey(Message)) then Exit;
  9066.         CN_KEYDOWN,
  9067.         CN_CHAR, CN_SYSKEYDOWN,
  9068.         CN_SYSCHAR:
  9069.           begin
  9070.             WndProc(Message);
  9071.             Exit;
  9072.           end;
  9073.       end;
  9074.       Result := CallWindowProc(FDefEditProc, FEditHandle, Msg, WParam, LParam);
  9075.     end;
  9076.   except
  9077.     Application.HandleException(Self);
  9078.   end;
  9079. end;
  9080.  
  9081. procedure TCustomListView.UpdateItems(FirstIndex, LastIndex: Integer);
  9082. begin
  9083.   ListView_RedrawItems(Handle, FirstIndex, LastIndex);
  9084. end;
  9085.  
  9086. procedure TCustomListView.ResetExStyles;
  9087. var
  9088.   Styles: DWORD;
  9089. begin
  9090.   Styles := 0;
  9091.   if FCheckboxes then Styles := LVS_EX_CHECKBOXES;
  9092.   if FGridLines then Styles := Styles or LVS_EX_GRIDLINES;
  9093.   if FHotTrack then Styles := Styles or LVS_EX_TRACKSELECT;
  9094.   if FRowSelect then Styles := Styles or LVS_EX_FULLROWSELECT;
  9095.   ListView_SetExtendedListViewStyle(Handle, Styles);
  9096. end;
  9097.  
  9098. procedure TCustomListView.RestoreChecks;
  9099. var
  9100.   i: Integer;
  9101.   Value: Boolean;
  9102. begin
  9103.   for i := 0 to Items.Count - 1 do
  9104.   begin
  9105.     if FCheckStream <> nil then
  9106.     begin
  9107.       FCheckStream.Read(Value, SizeOf(Value));
  9108.       Items[i].Checked := Value;
  9109.     end
  9110.     else
  9111.       Items[i].Checked := False;
  9112.   end;
  9113.   FCheckStream.Free;
  9114.   FCheckStream := nil;
  9115. end;
  9116.  
  9117. procedure TCustomListView.SaveChecks;
  9118. var
  9119.   i: Integer;
  9120.   Value: Boolean;
  9121. begin
  9122.   if FCheckStream = nil then FCheckStream := TMemoryStream.Create
  9123.   else FCheckStream.Size := 0;
  9124.   for i := 0 to Items.Count - 1 do
  9125.   begin
  9126.     Value := Items[i].Checked;
  9127.     FCheckStream.Write(Value, SizeOf(Value));
  9128.   end;
  9129.   FCheckStream.Position := 0;
  9130. end;
  9131.  
  9132. procedure TCustomListView.SetCheckboxes(Value: Boolean);
  9133. begin
  9134.   if FCheckboxes <> Value then
  9135.   begin
  9136.     FCheckboxes := Value;
  9137.     ResetExStyles;
  9138.     if FCheckboxes then RestoreChecks;
  9139.   end;
  9140. end;
  9141.  
  9142. procedure TCustomListView.SetGridLines(Value: Boolean);
  9143. begin
  9144.   if FGridLines <> Value then
  9145.   begin
  9146.     FGridLines := Value;
  9147.     ResetExStyles;
  9148.   end;
  9149. end;
  9150.  
  9151. procedure TCustomListView.SetHotTrack(Value: Boolean);
  9152. begin
  9153.   if FHotTrack <> Value then
  9154.   begin
  9155.     FHotTrack := Value;
  9156.     ResetExStyles;
  9157.   end;
  9158. end;
  9159.  
  9160. procedure TCustomListView.SetRowSelect(Value: Boolean);
  9161. begin
  9162.   if FRowSelect <> Value then
  9163.   begin
  9164.     FRowSelect := Value;
  9165.     ResetExStyles;
  9166.   end;
  9167. end;
  9168.  
  9169. procedure TCustomListView.SetBorderStyle(Value: TBorderStyle);
  9170. begin
  9171.   if BorderStyle <> Value then
  9172.   begin
  9173.     FBorderStyle := Value;
  9174.     RecreateWnd;
  9175.   end;
  9176. end;
  9177.  
  9178. procedure TCustomListView.SetColumnClick(Value: Boolean);
  9179. begin
  9180.   if ColumnClick <> Value then
  9181.   begin
  9182.     FColumnClick := Value;
  9183.     RecreateWnd;
  9184.   end;
  9185. end;
  9186.  
  9187. procedure TCustomListView.SetMultiSelect(Value: Boolean);
  9188. begin
  9189.   if Value <> MultiSelect then
  9190.   begin
  9191.     FMultiSelect := Value;
  9192.     RecreateWnd;
  9193.   end;
  9194. end;
  9195.  
  9196. procedure TCustomListView.SetColumnHeaders(Value: Boolean);
  9197. begin
  9198.   if Value <> ShowColumnHeaders then
  9199.   begin
  9200.     FShowColumnHeaders := Value;
  9201.     RecreateWnd;
  9202.   end;
  9203. end;
  9204.  
  9205. procedure TCustomListView.SetTextColor(Value: TColor);
  9206. begin
  9207.   ListView_SetTextColor(Handle, ColorToRGB(Font.Color));
  9208. end;
  9209.  
  9210. procedure TCustomListView.SetTextBkColor(Value: TColor);
  9211. begin
  9212.   ListView_SetTextBkColor(Handle, ColorToRGB(Color));
  9213. end;
  9214.  
  9215. procedure TCustomListView.SetAllocBy(Value: Integer);
  9216. begin
  9217.   if AllocBy <> Value then
  9218.   begin
  9219.     FAllocBy := Value;
  9220.     if HandleAllocated then ListView_SetItemCount(Handle, Value);
  9221.   end;
  9222. end;
  9223.  
  9224. procedure TCustomListView.CMColorChanged(var Message: TMessage);
  9225. begin
  9226.   inherited;
  9227.   SetTextBkColor(Color);
  9228. end;
  9229.  
  9230. procedure TCustomListView.CMCtl3DChanged(var Message: TMessage);
  9231. begin
  9232.   if FBorderStyle = bsSingle then RecreateWnd;
  9233.   inherited;
  9234. end;
  9235.  
  9236. procedure TCustomListView.WMNotify(var Message: TWMNotify);
  9237. begin
  9238.   inherited;
  9239.   if ValidHeaderHandle then
  9240.     with Message.NMHdr^ do
  9241.       if (hWndFrom = FHeaderHandle) and (code = HDN_BEGINTRACK) then
  9242.         with PHDNotify(Pointer(Message.NMHdr))^, PItem^ do
  9243.           if (Mask and HDI_WIDTH) <> 0 then
  9244.             Column[Item].Width := cxy;
  9245. end;
  9246.  
  9247. function TCustomListView.ColumnsShowing: Boolean;
  9248. begin
  9249.   Result := (ViewStyle = vsReport);
  9250. end;
  9251.  
  9252. function TCustomListView.ValidHeaderHandle: Boolean;
  9253. begin
  9254.   Result := FHeaderHandle <> 0;
  9255. end;
  9256.  
  9257. procedure TCustomListView.CMFontChanged(var Message: TMessage);
  9258. begin
  9259.   inherited;
  9260.   if HandleAllocated then
  9261.   begin
  9262.     SetTextColor(Font.Color);
  9263.     if ValidHeaderHandle then
  9264.       InvalidateRect(FHeaderHandle, nil, True);
  9265.   end;
  9266. end;
  9267.  
  9268. procedure TCustomListView.SetHideSelection(Value: Boolean);
  9269. begin
  9270.   if Value <> HideSelection then
  9271.   begin
  9272.     FHideSelection := Value;
  9273.     RecreateWnd;
  9274.   end;
  9275. end;
  9276.  
  9277. procedure TCustomListView.SetReadOnly(Value: Boolean);
  9278. begin
  9279.   if Value <> ReadOnly then
  9280.   begin
  9281.     FReadOnly := Value;
  9282.     RecreateWnd;
  9283.   end;
  9284. end;
  9285.  
  9286. procedure TCustomListView.SetIconOptions(Value: TIconOptions);
  9287. begin
  9288.   with FIconOptions do
  9289.   begin
  9290.     Arrangement := Value.Arrangement;
  9291.     AutoArrange := Value.AutoArrange;
  9292.     WrapText := Value.WrapText;
  9293.   end;
  9294. end;
  9295.  
  9296. procedure TCustomListView.SetViewStyle(Value: TViewStyle);
  9297. const
  9298.   ViewStyles: array[TViewStyle] of Integer = (LVS_ICON, LVS_SMALLICON,
  9299.     LVS_LIST, LVS_REPORT);
  9300. var
  9301.   Style: Longint;
  9302. begin
  9303.   if Value <> FViewStyle then
  9304.   begin
  9305.     FViewStyle := Value;
  9306.     if HandleAllocated then
  9307.     begin
  9308.       Style := GetWindowLong(Handle, GWL_STYLE);
  9309.       Style := Style and (not LVS_TYPEMASK);
  9310.       Style := Style or ViewStyles[FViewStyle];
  9311.       SetWindowLong(Handle, GWL_STYLE, Style);
  9312.       UpdateColumns;
  9313.       case ViewStyle of
  9314.         vsIcon,
  9315.         vsSmallIcon:
  9316.           if IconOptions.Arrangement = iaTop then
  9317.             Arrange(arAlignTop) else
  9318.             Arrange(arAlignLeft);
  9319.       end;
  9320.     end;
  9321.   end;
  9322. end;
  9323.  
  9324. procedure TCustomListView.WMParentNotify(var Message: TWMParentNotify);
  9325. begin
  9326.   with Message do
  9327.     if (Event = WM_CREATE) and (FHeaderHandle = 0) then
  9328.     begin
  9329.       FHeaderHandle := ChildWnd;
  9330.       FDefHeaderProc := Pointer(GetWindowLong(FHeaderHandle, GWL_WNDPROC));
  9331.       SetWindowLong(FHeaderHandle, GWL_WNDPROC, LongInt(FHeaderInstance));
  9332.     end;
  9333.   inherited;
  9334. end;
  9335.  
  9336. function TCustomListView.GetItemIndex(Value: TListItem): Integer;
  9337. var
  9338.   I: Integer;
  9339. begin
  9340.   Result := -1;
  9341.   for I := 0 to Items.Count - 1 do if Items[I] = Value then Break;
  9342.   if I < Items.Count then Result := I;
  9343. end;
  9344.  
  9345. function TCustomListView.CreateListItem: TListItem;
  9346. begin
  9347.   Result := TListItem.Create(Items);
  9348. end;
  9349.  
  9350. function TCustomListView.GetItem(Value: TLVItem): TListItem;
  9351. begin
  9352.   with Value do
  9353.     if (mask and LVIF_PARAM) <> 0 then Result := TListItem(lParam)
  9354.     else Result := Items[IItem];
  9355. end;
  9356.  
  9357. function TCustomListView.GetSelCount: Integer;
  9358. begin
  9359.   Result := ListView_GetSelectedCount(Handle);
  9360. end;
  9361.  
  9362. procedure TCustomListView.CNNotify(var Message: TWMNotify);
  9363. var
  9364.   Item: TListItem;
  9365.   I: Integer;
  9366. begin
  9367.   with Message.NMHdr^ do
  9368.     case code of
  9369.       LVN_BEGINDRAG:
  9370.         with PNMListView(Pointer(Message.NMHdr))^ do
  9371.           FDragIndex := iItem;
  9372.       LVN_DELETEITEM:
  9373.         with PNMListView(Pointer(Message.NMHdr))^ do
  9374.           Delete(TListItem(lParam));
  9375.       LVN_DELETEALLITEMS:
  9376.         for I := Items.Count - 1 downto 0 do Delete(Items[I]);
  9377.       LVN_GETDISPINFO:
  9378.         begin
  9379.           Item := GetItem(PLVDispInfo(Pointer(Message.NMHdr))^.item);
  9380.           with PLVDispInfo(Pointer(Message.NMHdr))^.item do
  9381.           begin
  9382.             if (mask and LVIF_TEXT) <> 0 then
  9383.               if iSubItem = 0 then
  9384.                 StrPLCopy(pszText, Item.Caption, cchTextMax)
  9385.               else
  9386.                 with Item.SubItems do
  9387.                   if iSubItem <= Count then
  9388.                     StrPLCopy(pszText, Strings[iSubItem - 1], cchTextMax)
  9389.                   else pszText[0] := #0;
  9390.             if (mask and LVIF_IMAGE) <> 0 then iImage := Item.ImageIndex;
  9391.           end;
  9392.         end;
  9393.       LVN_BEGINLABELEDIT:
  9394.         begin
  9395.           Item := GetItem(PLVDispInfo(Pointer(Message.NMHdr))^.item);
  9396.           if not CanEdit(Item) then Message.Result := 1;
  9397.           if Message.Result = 0 then
  9398.           begin
  9399.             FEditHandle := ListView_GetEditControl(Handle);
  9400.             FDefEditProc := Pointer(GetWindowLong(FEditHandle, GWL_WNDPROC));
  9401.             SetWindowLong(FEditHandle, GWL_WNDPROC, LongInt(FEditInstance));
  9402.           end;
  9403.         end;
  9404.       LVN_ENDLABELEDIT:
  9405.         with PLVDispInfo(Pointer(Message.NMHdr))^ do
  9406.           if (item.pszText <> nil) and (item.IItem <> -1) then
  9407.             Edit(item);
  9408.       LVN_COLUMNCLICK:
  9409.         with PNMListView(Pointer(Message.NMHdr))^ do
  9410.           ColClick(Column[iSubItem]);
  9411.       LVN_INSERTITEM:
  9412.         with PNMListView(Pointer(Message.NMHdr))^ do
  9413.           InsertItem(Items[iItem]);
  9414.       LVN_ITEMCHANGING:
  9415.         with PNMListView(Pointer(Message.NMHdr))^ do
  9416.           if not CanChange(Items[iItem], uChanged) then Message.Result := 1;
  9417.       LVN_ITEMCHANGED:
  9418.         with PNMListView(Pointer(Message.NMHdr))^ do
  9419.           Change(Items[iItem], uChanged);
  9420.       NM_CLICK: FClicked := True;
  9421.       NM_RCLICK: FRClicked := True;
  9422.     end;
  9423. end;
  9424.  
  9425. procedure TCustomListView.ColClick(Column: TListColumn);
  9426. begin
  9427.   if Assigned(FOnColumnClick) then FOnColumnClick(Self, Column);
  9428. end;
  9429.  
  9430. procedure TCustomListView.InsertItem(Item: TListItem);
  9431. begin
  9432.   if Assigned(FOnInsert) then FOnInsert(Self, Item);
  9433. end;
  9434.  
  9435. function TCustomListView.CanChange(Item: TListItem; Change: Integer): Boolean;
  9436. var
  9437.   ItemChange: TItemChange;
  9438. begin
  9439.   Result := True;
  9440.   case Change of
  9441.     LVIF_TEXT: ItemChange := ctText;
  9442.     LVIF_IMAGE: ItemChange := ctImage;
  9443.     LVIF_STATE: ItemChange := ctState;
  9444.   else
  9445.     Exit;
  9446.   end;
  9447.   if Assigned(FOnChanging) then FOnChanging(Self, Item, ItemChange, Result);
  9448. end;
  9449.  
  9450. procedure TCustomListView.Change(Item: TListItem; Change: Integer);
  9451. var
  9452.   ItemChange: TItemChange;
  9453. begin
  9454.   case Change of
  9455.     LVIF_TEXT: ItemChange := ctText;
  9456.     LVIF_IMAGE: ItemChange := ctImage;
  9457.     LVIF_STATE: ItemChange := ctState;
  9458.   else
  9459.     Exit;
  9460.   end;
  9461.   if Assigned(FOnChange) then FOnChange(Self, Item, ItemChange);
  9462. end;
  9463.  
  9464. procedure TCustomListView.Delete(Item: TListItem);
  9465. begin
  9466.   if (Item <> nil) and not Item.FProcessedDeleting then
  9467.   begin
  9468.     if Assigned(FOnDeletion) then FOnDeletion(Self, Item);
  9469.     Item.FProcessedDeleting := True;
  9470.     Item.Delete;
  9471.   end;
  9472. end;
  9473.  
  9474. function TCustomListView.CanEdit(Item: TListItem): Boolean;
  9475. begin
  9476.   Result := True;
  9477.   if Assigned(FOnEditing) then FOnEditing(Self, Item, Result);
  9478. end;
  9479.  
  9480. procedure TCustomListView.Edit(const Item: TLVItem);
  9481. var
  9482.   S: string;
  9483.   EditItem: TListItem;
  9484. begin
  9485.   with Item do
  9486.   begin
  9487.     S := pszText;
  9488.     EditItem := GetItem(Item);
  9489.     if Assigned(FOnEdited) then FOnEdited(Self, EditItem, S);
  9490.     if EditItem <> nil then EditItem.Caption := S;
  9491.   end;
  9492. end;
  9493.  
  9494. function TCustomListView.IsEditing: Boolean;
  9495. var
  9496.   ControlHand: HWnd;
  9497. begin
  9498.   ControlHand := ListView_GetEditControl(Handle);
  9499.   Result := (ControlHand <> 0) and IsWindowVisible(ControlHand);
  9500. end;
  9501.  
  9502. function TCustomListView.GetDragImages: TCustomImageList;
  9503. begin
  9504.   if SelCount = 1 then
  9505.     Result := FDragImage else
  9506.     Result := nil;
  9507. end;
  9508.  
  9509. procedure TCustomListView.WndProc(var Message: TMessage);
  9510. begin
  9511.   if not (csDesigning in ComponentState) and ((Message.Msg = WM_LBUTTONDOWN) or
  9512.     (Message.Msg = WM_LBUTTONDBLCLK)) and not Dragging and (DragMode = dmAutomatic) then
  9513.   begin
  9514.     if not IsControlMouseMsg(TWMMouse(Message)) then
  9515.     begin
  9516.       ControlState := ControlState + [csLButtonDown];
  9517.       Dispatch(Message);
  9518.     end;
  9519.   end
  9520.   else if not (((Message.Msg = WM_PAINT) or (Message.Msg = WM_ERASEBKGND)) and
  9521.     Items.FNoRedraw) then
  9522.     inherited WndProc(Message);
  9523. end;
  9524.  
  9525. procedure TCustomListView.DoStartDrag(var DragObject: TDragObject);
  9526. var
  9527.   P, P1: TPoint;
  9528.   ImageHandle: HImageList;
  9529.   DragItem: TListItem;
  9530. begin
  9531.   inherited DoStartDrag(DragObject);
  9532.   FLastDropTarget := nil;
  9533.   GetCursorPos(P);
  9534.   P := ScreenToClient(P);
  9535.   if FDragIndex <> -1 then
  9536.     DragItem := Items[FDragIndex]
  9537.     else DragItem := nil;
  9538.   FDragIndex := -1;
  9539.   if DragItem = nil then
  9540.     with P do DragItem := GetItemAt(X, Y);
  9541.   if DragItem <> nil then
  9542.   begin
  9543.     ImageHandle := ListView_CreateDragImage(Handle, DragItem.Index, P1);
  9544.     if ImageHandle <> 0 then
  9545.       with FDragImage do
  9546.       begin
  9547.         Handle := ImageHandle;
  9548.         with P, DragItem.DisplayRect(drBounds) do
  9549.           SetDragImage(0, X - Left , Y - Top);
  9550.       end;
  9551.   end;
  9552. end;
  9553.  
  9554. procedure TCustomListView.DoEndDrag(Target: TObject; X, Y: Integer);
  9555. begin
  9556.   inherited DoEndDrag(Target, X, Y);
  9557.   FLastDropTarget := nil;
  9558. end;
  9559.  
  9560. procedure TCustomListView.CMDrag(var Message: TCMDrag);
  9561. begin
  9562.   inherited;
  9563.   with Message, DragRec^ do
  9564.     case DragMessage of
  9565.       dmDragMove: with ScreenToClient(Pos) do DoDragOver(Source, X, Y, Message.Result <> 0);
  9566.       dmDragLeave:
  9567.         begin
  9568.           TDragObject(Source).HideDragImage;
  9569.           FLastDropTarget := DropTarget;
  9570.           DropTarget := nil;
  9571.           Update;
  9572.           TDragObject(Source).ShowDragImage;
  9573.         end;
  9574.       dmDragDrop: FLastDropTarget := nil;
  9575.     end
  9576. end;
  9577.  
  9578. procedure TCustomListView.DoDragOver(Source: TDragObject; X, Y: Integer; CanDrop: Boolean);
  9579. var
  9580.   Item: TListItem;
  9581.   Target: TListItem;
  9582. begin
  9583.   Item := GetItemAt(X, Y);
  9584.   if Item <> nil then
  9585.   begin
  9586.     Target := DropTarget;
  9587.     if (Item <> Target) or (Item = FLastDropTarget) then
  9588.     begin
  9589.       FLastDropTarget := nil;
  9590.       TDragObject(Source).HideDragImage;
  9591.       Update;
  9592.       if Target <> nil then
  9593.         Target.DropTarget := False;
  9594.       Item.DropTarget := CanDrop;
  9595.       Update;
  9596.       TDragObject(Source).ShowDragImage;
  9597.     end;
  9598.   end;
  9599. end;
  9600.  
  9601. procedure TCustomListView.SetItems(Value: TListItems);
  9602. begin
  9603.   FListItems.Assign(Value);
  9604. end;
  9605.  
  9606. procedure TCustomListView.SetListColumns(Value: TListColumns);
  9607. begin
  9608.   FListColumns.Assign(Value);
  9609. end;
  9610.  
  9611. function TCustomListView.CustomSort(SortProc: TLVCompare; lParam: Longint): Boolean;
  9612. begin
  9613.   Result := False;
  9614.   if HandleAllocated then
  9615.   begin
  9616.     if not Assigned(SortProc) then SortProc := @DefaultListViewSort;
  9617.     Result := ListView_SortItems(Handle, SortProc, lParam);
  9618.   end;
  9619. end;
  9620.  
  9621. function TCustomListView.AlphaSort: Boolean;
  9622. begin
  9623.   if HandleAllocated then
  9624.     Result := ListView_SortItems(Handle, @DefaultListViewSort, 0)
  9625.   else Result := False;
  9626. end;
  9627.  
  9628. procedure TCustomListView.SetSortType(Value: TSortType);
  9629. begin
  9630.   if SortType <> Value then
  9631.   begin
  9632.     FSortType := Value;
  9633.     if ((SortType in [stData, stBoth]) and Assigned(OnCompare)) or
  9634.       (SortType in [stText, stBoth]) then
  9635.       AlphaSort;
  9636.   end;
  9637. end;
  9638.  
  9639. function TCustomListView.GetVisibleRowCount: Integer;
  9640. begin
  9641.   if ViewStyle in [vsReport, vsList] then
  9642.     Result := ListView_GetCountPerPage(Handle)
  9643.   else Result := 0;
  9644. end;
  9645.  
  9646. function TCustomListView.GetViewOrigin: TPoint;
  9647. begin
  9648.   ListView_GetOrigin(Handle, Result);
  9649. end;
  9650.  
  9651. function TCustomListView.GetTopItem: TListItem;
  9652. var
  9653.   Index: Integer;
  9654. begin
  9655.   Result := nil;
  9656.   if not (ViewStyle in [vsSmallIcon, vsIcon]) then
  9657.   begin
  9658.     Index := ListView_GetTopIndex(Handle);
  9659.     if Index <> -1 then Result := Items[Index];
  9660.   end;
  9661. end;
  9662.  
  9663. function TCustomListView.GetBoundingRect: TRect;
  9664. begin
  9665.   ListView_GetViewRect(Handle, Result);
  9666. end;
  9667.  
  9668. procedure TCustomListView.Scroll(DX, DY: Integer);
  9669. begin
  9670.   ListView_Scroll(Handle, DX, DY);
  9671. end;
  9672.  
  9673. procedure TCustomListView.SetLargeImages(Value: TImageList);
  9674. begin
  9675.   if LargeImages <> nil then
  9676.     LargeImages.UnRegisterChanges(FLargeChangeLink);
  9677.   FLargeImages := Value;
  9678.   if LargeImages <> nil then
  9679.   begin
  9680.     LargeImages.RegisterChanges(FLargeChangeLink);
  9681.     SetImageList(LargeImages.Handle, LVSIL_NORMAL)
  9682.   end
  9683.   else SetImageList(0, LVSIL_NORMAL);
  9684. end;
  9685.  
  9686. procedure TCustomListView.SetSmallImages(Value: TImageList);
  9687. begin
  9688.   if SmallImages <> nil then
  9689.     SmallImages.UnRegisterChanges(FSmallChangeLink);
  9690.   FSmallImages := Value;
  9691.   if SmallImages <> nil then
  9692.   begin
  9693.     SmallImages.RegisterChanges(FSmallChangeLink);
  9694.     SetImageList(SmallImages.Handle, LVSIL_SMALL)
  9695.   end
  9696.   else SetImageList(0, LVSIL_SMALL);
  9697. end;
  9698.  
  9699. procedure TCustomListView.SetStateImages(Value: TImageList);
  9700. begin
  9701.   if StateImages <> nil then
  9702.     StateImages.UnRegisterChanges(FStateChangeLink);
  9703.   FStateImages := Value;
  9704.   if StateImages <> nil then
  9705.   begin
  9706.     StateImages.RegisterChanges(FStateChangeLink);
  9707.     SetImageList(StateImages.Handle, LVSIL_STATE)
  9708.   end
  9709.   else SetImageList(0, LVSIL_STATE);
  9710. end;
  9711.  
  9712. function TCustomListView.GetColumnFromIndex(Index: Integer): TListColumn;
  9713. begin
  9714.   Result := FListColumns[Index];
  9715. end;
  9716.  
  9717. function TCustomListView.FindCaption(StartIndex: Integer; Value: string;
  9718.   Partial, Inclusive, Wrap: Boolean): TListItem;
  9719. const
  9720.   FullString: array[Boolean] of Integer = (0, LVFI_PARTIAL);
  9721.   Wraps: array[Boolean] of Integer = (0, LVFI_WRAP);
  9722. var
  9723.   Info: TLVFindInfo;
  9724.   Index: Integer;
  9725. begin
  9726.   with Info do
  9727.   begin
  9728.     flags := LVFI_STRING or FullString[Partial] or Wraps[Wrap];
  9729.     psz := PChar(Value);
  9730.   end;
  9731.   if Inclusive then Dec(StartIndex);
  9732.   Index := ListView_FindItem(Handle, StartIndex, Info);
  9733.   if Index <> -1 then Result := Items[Index]
  9734.   else Result := nil;
  9735. end;
  9736.  
  9737. function TCustomListView.FindData(StartIndex: Integer; Value: Pointer;
  9738.   Inclusive, Wrap: Boolean): TListItem;
  9739. var
  9740.   I: Integer;
  9741. begin
  9742.   Result := nil;
  9743.   if Inclusive then Dec(StartIndex);
  9744.   for I := StartIndex + 1 to Items.Count - 1 do
  9745.     if Items[I].Data = Value then Break;
  9746.   if I <= Items.Count - 1 then Result := Items[I]
  9747.   else if Wrap then
  9748.   begin
  9749.     if Inclusive then Inc(StartIndex);
  9750.     for I := 0 to StartIndex - 1 do
  9751.       if Items[I].Data = Value then Break;
  9752.     if I <= StartIndex then Result := Items[I];
  9753.   end;
  9754. end;
  9755.  
  9756. function TCustomListView.GetSelection: TListItem;
  9757. begin
  9758.   Result := GetNextItem(nil, sdAll, [isSelected]);
  9759. end;
  9760.  
  9761. procedure TCustomListView.SetSelection(Value: TListItem);
  9762. var
  9763.   I: Integer;
  9764. begin
  9765.   if Value <> nil then Value.Selected := True
  9766.   else begin
  9767.     Value := Selected;
  9768.     for I := 0 to SelCount - 1 do
  9769.       if Value <> nil then
  9770.       begin
  9771.         Value.Selected := False;
  9772.         Value := GetNextItem(Value, sdAll, [isSelected]);
  9773.       end;
  9774.   end;
  9775. end;
  9776.  
  9777. function TCustomListView.GetDropTarget: TListItem;
  9778. begin
  9779.   Result := GetNextItem(nil, sdAll, [isDropHilited]);
  9780.   if Result = nil then Result := FLastDropTarget;
  9781. end;
  9782.  
  9783. procedure TCustomListView.SetDropTarget(Value: TListItem);
  9784. begin
  9785.   if HandleAllocated then
  9786.     if Value <> nil then Value.DropTarget := True
  9787.     else begin
  9788.       Value := DropTarget;
  9789.       if Value <> nil then Value.DropTarget := False;
  9790.     end;
  9791. end;
  9792.  
  9793. function TCustomListView.GetFocused: TListItem;
  9794. begin
  9795.   Result := GetNextItem(nil, sdAll, [isFocused]);
  9796. end;
  9797.  
  9798. procedure TCustomListView.SetFocused(Value: TListItem);
  9799. begin
  9800.   if HandleAllocated then
  9801.     if Value <> nil then Value.Focused := True
  9802.     else begin
  9803.       Value := ItemFocused;
  9804.       if Value <> nil then Value.Focused := False;
  9805.     end;
  9806. end;
  9807.  
  9808. function TCustomListView.GetNextItem(StartItem: TListItem;
  9809.   Direction: TSearchDirection; States: TItemStates): TListItem;
  9810. var
  9811.   Flags, Index: Integer;
  9812. begin
  9813.   Result := nil;
  9814.   if HandleAllocated then
  9815.   begin
  9816.     Flags := 0;
  9817.     case Direction of
  9818.       sdAbove: Flags := LVNI_ABOVE;
  9819.       sdBelow: Flags := LVNI_BELOW;
  9820.       sdLeft: Flags := LVNI_TOLEFT;
  9821.       sdRight: Flags := LVNI_TORIGHT;
  9822.       sdAll: Flags := LVNI_ALL;
  9823.     end;
  9824.     if StartItem <> nil then Index := StartItem.Index
  9825.     else Index := -1;
  9826.     if isCut in States then Flags := Flags or LVNI_CUT;
  9827.     if isDropHilited in States then Flags := Flags or LVNI_DROPHILITED;
  9828.     if isFocused in States then Flags := Flags or LVNI_FOCUSED;
  9829.     if isSelected in States then Flags := Flags or LVNI_SELECTED;
  9830.     Index := ListView_GetNextItem(Handle, Index, Flags);
  9831.     if Index <> -1 then Result := Items[Index];
  9832.   end;
  9833. end;
  9834.  
  9835. function TCustomListView.GetNearestItem(Point: TPoint;
  9836.   Direction: TSearchDirection): TListItem;
  9837. const
  9838.   Directions: array[TSearchDirection] of Integer = (VK_LEFT, VK_RIGHT,
  9839.     VK_UP, VK_DOWN, 0);
  9840. var
  9841.   Info: TLVFindInfo;
  9842.   Index: Integer;
  9843. begin
  9844.   with Info do
  9845.   begin
  9846.     flags := LVFI_NEARESTXY;
  9847.     pt := Point;
  9848.     vkDirection := Directions[Direction];
  9849.   end;
  9850.   Index := ListView_FindItem(Handle, -1, Info);
  9851.   if Index <> -1 then Result := Items[Index]
  9852.   else Result := nil;
  9853. end;
  9854.  
  9855. function TCustomListView.GetItemAt(X, Y: Integer): TListItem;
  9856. var
  9857.   Info: TLVHitTestInfo;
  9858. var
  9859.   Index: Integer;
  9860. begin
  9861.   Result := nil;
  9862.   if HandleAllocated then
  9863.   begin
  9864.     Info.pt := Point(X, Y);
  9865.     Index := ListView_HitTest(Handle, Info);
  9866.     if Index <> -1 then Result := Items[Index];
  9867.   end;
  9868. end;
  9869.  
  9870. procedure TCustomListView.Arrange(Code: TListArrangement);
  9871. const
  9872.   Codes: array[TListArrangement] of Longint = (LVA_ALIGNBOTTOM, LVA_ALIGNLEFT,
  9873.     LVA_ALIGNRIGHT, LVA_ALIGNTOP, LVA_DEFAULT, LVA_SNAPTOGRID);
  9874. begin
  9875.   ListView_Arrange(Handle, Codes[Code]);
  9876. end;
  9877.  
  9878. function TCustomListView.StringWidth(S: string): Integer;
  9879. begin
  9880.   Result := ListView_GetStringWidth(Handle, PChar(S));
  9881. end;
  9882.  
  9883. procedure TCustomListView.UpdateColumns;
  9884. var
  9885.   I: Integer;
  9886. begin
  9887.   if HandleAllocated then
  9888.     for I := 0 to Columns.Count - 1 do UpdateColumn(I);
  9889. end;
  9890.  
  9891. procedure TCustomListView.UpdateColumn(Index: Integer);
  9892. var
  9893.   Column: TLVColumn;
  9894. begin
  9895.   if HandleAllocated then
  9896.     with Column, Columns.Items[Index] do
  9897.     begin
  9898.       mask := LVCF_TEXT or LVCF_FMT;
  9899.       pszText := PChar(Caption);
  9900.       if Index <> 0 then
  9901.         case Alignment of
  9902.           taLeftJustify: fmt := LVCFMT_LEFT;
  9903.           taCenter: fmt := LVCFMT_CENTER;
  9904.           taRightJustify: fmt := LVCFMT_RIGHT;
  9905.         end
  9906.       else fmt := LVCFMT_LEFT;
  9907.       if WidthType > ColumnTextWidth then
  9908.       begin
  9909.         mask := mask or LVCF_WIDTH;
  9910.         cx := FWidth;
  9911.         ListView_SetColumn(Handle, Index, Column);
  9912.       end
  9913.       else begin
  9914.         ListView_SetColumn(Handle, Index, Column);
  9915.         if ViewStyle = vsList then
  9916.           ListView_SetColumnWidth(Handle, -1, WidthType)
  9917.         else if ViewStyle = vsReport then
  9918.           ListView_SetColumnWidth(Handle, Index, WidthType);
  9919.       end;
  9920.     end;
  9921. end;
  9922.  
  9923. procedure TCustomListView.WMRButtonDown(var Message: TWMRButtonDown);
  9924. var
  9925.   MousePos: TPoint;
  9926. begin
  9927.   FRClicked := False;
  9928.   inherited;
  9929.   if FRClicked then
  9930.   begin
  9931.     GetCursorPos(MousePos);
  9932.     with PointToSmallPoint(ScreenToClient(MousePos)) do
  9933.       Perform(WM_RBUTTONUP, 0, MakeLong(X, Y));
  9934.   end;
  9935. end;
  9936.  
  9937. procedure TCustomListView.WMLButtonDown(var Message: TWMLButtonDown);
  9938. var
  9939.   Item: TListItem;
  9940.   MousePos: TPoint;
  9941.   ShiftState: TShiftState;
  9942. begin
  9943.   SetFocus;
  9944.   ShiftState := KeysToShiftState(Message.Keys);
  9945.   FClicked := False;
  9946.   FDragIndex := -1;
  9947.   inherited;
  9948.   if (DragMode = dmAutomatic) and MultiSelect then
  9949.   begin
  9950.     if not (ssShift in ShiftState) and not (ssCtrl in ShiftState) then
  9951.     begin
  9952.       if not FClicked then
  9953.       begin
  9954.         Item := GetItemAt(Message.XPos, Message.YPos);
  9955.         if (Item <> nil) and Item.Selected then
  9956.         begin
  9957.           BeginDrag(False);
  9958.           Exit;
  9959.         end;
  9960.       end;
  9961.     end;
  9962.   end;
  9963.   if FClicked then
  9964.   begin
  9965.     GetCursorPos(MousePos);
  9966.     with PointToSmallPoint(ScreenToClient(MousePos)) do
  9967.       if not Dragging then Perform(WM_LBUTTONUP, 0, MakeLong(X, Y))
  9968.       else SendMessage(GetCapture, WM_LBUTTONUP, 0, MakeLong(X, Y));
  9969.   end
  9970.   else if (DragMode = dmAutomatic) and not (MultiSelect and
  9971.     ((ssShift in ShiftState) or (ssCtrl in ShiftState))) then
  9972.   begin
  9973.     Item := GetItemAt(Message.XPos, Message.YPos);
  9974.     if (Item <> nil) and Item.Selected then
  9975.       BeginDrag(False);
  9976.   end;
  9977. end;
  9978.  
  9979. function TCustomListView.GetSearchString: string;
  9980. var
  9981.   Buffer: array[0..1023] of char;
  9982. begin
  9983.   Result := '';
  9984.   if HandleAllocated and ListView_GetISearchString(Handle, Buffer) then
  9985.     Result := Buffer;
  9986. end;
  9987.  
  9988. { TAnimate }
  9989.  
  9990. type
  9991.   TAnimateParams = record
  9992.     FileName: string;
  9993.     CommonAVI: TCommonAVI;
  9994.     ResHandle: THandle;
  9995.     ResName: string;
  9996.     ResId: Integer;
  9997.   end;
  9998.  
  9999. constructor TAnimate.Create(AOwner: TComponent);
  10000. begin
  10001.   inherited Create(AOwner);
  10002.   ControlStyle := [csReflector];
  10003.   Width := 100;
  10004.   Height := 80;
  10005.   FAutoSize := True;
  10006.   FCenter := True;
  10007.   FStartFrame := 1;
  10008.   FTransparent := True;
  10009. end;
  10010.  
  10011. procedure TAnimate.CreateParams(var Params: TCreateParams);
  10012. const
  10013.   ShellModuleName = 'shell32.dll';
  10014.   CenterStyles: array[Boolean] of Integer = (0, ACS_CENTER);
  10015.   TimerStyles: array[Boolean] of Integer = (0, ACS_TIMER);
  10016.   TransparentStyles: array[Boolean] of Integer = (0, ACS_TRANSPARENT);
  10017. var
  10018.   OldError: Longint;
  10019. begin
  10020.   if (FCommonAVI <> aviNone) then
  10021.   begin
  10022.     OldError := SetErrorMode(SEM_NOOPENFILEERRORBOX);
  10023.     ShellModule := GetModuleHandle(ShellModuleName);
  10024.     if ShellModule < HINSTANCE_ERROR then
  10025.       ShellModule := LoadLibrary(ShellModuleName);
  10026.     if (ShellModule > 0) and (ShellModule < HINSTANCE_ERROR) then
  10027.       ShellModule := 0;
  10028.     SetErrorMode(OldError);
  10029.   end;
  10030.   InitCommonControl(ICC_ANIMATE_CLASS);
  10031.   inherited CreateParams(Params);
  10032.   { The ANIMATE common control requires that it be created in the same
  10033.     instance address space as the AVI resource. }
  10034.   Params.WindowClass.hInstance := GetActualResHandle;
  10035.   CreateSubClass(Params, ANIMATE_CLASS);
  10036.   with Params do
  10037.   begin
  10038.     Style := Style or CenterStyles[FCenter] or TimerStyles[FTimers] or
  10039.       TransparentStyles[FTransparent];
  10040.     WindowClass.style := WindowClass.style and not (CS_HREDRAW or CS_VREDRAW);
  10041.     { Make sure window class is unique per instance. }
  10042.     StrFmt(WinClassName, '%s.%.8X:%.8X', [ClassName, HInstance, GetCurrentThreadID]);
  10043.   end;
  10044. end;
  10045.  
  10046. procedure TAnimate.CreateWnd;
  10047. begin
  10048.   FRecreateNeeded := False;
  10049.   FOpen := False;
  10050.   inherited CreateWnd;
  10051.   UpdateActiveState;
  10052. end;
  10053.  
  10054. procedure TAnimate.DestroyWnd;
  10055. var
  10056.   OldActive, OldOpen: Boolean;
  10057. begin
  10058.   OldActive := FActive;
  10059.   OldOpen := FOpen;
  10060.   SetOpen(False);
  10061.   inherited DestroyWnd;
  10062.   FOpen := OldOpen;
  10063.   FActive := OldActive;
  10064. end;
  10065.  
  10066. procedure TAnimate.UpdateActiveState;
  10067. begin
  10068.   if not (csLoading in ComponentState) then
  10069.   begin
  10070.     { Attempt to open AVI and set active if applicable }
  10071.     SetOpen(True);
  10072.     if FActive then
  10073.     begin
  10074.       FActive := False;
  10075.       SetActive(True);
  10076.     end;
  10077.   end;
  10078. end;
  10079.  
  10080. procedure TAnimate.AdjustSize;
  10081. begin
  10082.   if not (csLoading in ComponentState) and HandleAllocated then
  10083.     SetWindowPos(Handle, 0, 0, 0, Width, Height, SWP_NOACTIVATE or SWP_NOMOVE or
  10084.       SWP_NOZORDER);
  10085. end;
  10086.  
  10087. procedure TAnimate.WMNCCalcSize(var Message: TWMNCCalcSize);
  10088. begin
  10089.   if csDesigning in ComponentState then
  10090.     with Message.CalcSize_Params^ do
  10091.       InflateRect(rgrc[0], -1, -1);
  10092.   inherited;
  10093. end;
  10094.  
  10095. procedure TAnimate.WMNCHitTest(var Message: TWMNCHitTest);
  10096. begin
  10097.   with Message do
  10098.     if not (csDesigning in ComponentState) then
  10099.       Result := HTCLIENT
  10100.     else
  10101.       inherited;
  10102. end;
  10103.  
  10104. procedure TAnimate.WMNCPaint(var Message: TMessage);
  10105. var
  10106.   DC: HDC;
  10107.   R: TRect;
  10108.   Pen, SavePen: HPEN;
  10109. begin
  10110.   if csDesigning in ComponentState then
  10111.   begin
  10112.     { Get window DC that is clipped to the non-client area }
  10113.     DC := GetDCEx(Handle, 0, DCX_WINDOW or DCX_CACHE or DCX_CLIPSIBLINGS);
  10114.     try
  10115.       GetWindowRect(Handle, R);
  10116.       OffsetRect(R, -R.Left, -R.Top);
  10117.       with R do
  10118.       begin
  10119.         ExcludeClipRect(DC, Left+1, Top+1, Right-1, Bottom-1);
  10120.         Pen := CreatePen(PS_DASH, 1, clBlack);
  10121.         SavePen := SelectObject(DC, Pen);
  10122.         SetBkColor(DC, ColorToRGB(Color));
  10123.         Rectangle(DC, R.Left, R.Top, R.Right, R.Bottom);
  10124.         if SavePen <> 0 then SelectObject(DC, SavePen);
  10125.         DeleteObject(Pen);
  10126.       end;
  10127.     finally
  10128.       ReleaseDC(Handle, DC);
  10129.     end;
  10130.   end
  10131.   else inherited;
  10132. end;
  10133.  
  10134. procedure TAnimate.WMSize(var Message: TWMSize);
  10135. begin
  10136.   inherited;
  10137.   RequestAlign;
  10138. end;
  10139.  
  10140. procedure TAnimate.WMWindowPosChanged(var Message: TWMWindowPosChanged);
  10141. var
  10142.   R: TRect;
  10143. begin
  10144.   inherited;
  10145.   InvalidateRect(Handle, nil, True);
  10146.   R := Rect(0, 0, FrameWidth, FrameHeight);
  10147.   if Center then
  10148.     OffsetRect(R, (ClientWidth - (R.Right - R.Left)) div 2,
  10149.       (ClientHeight - (R.Bottom - R.Top)) div 2);
  10150.   ValidateRect(Handle, @R);
  10151.   UpdateWindow(Handle);
  10152.   InvalidateRect(Handle, @R, False);
  10153. end;
  10154.  
  10155. procedure TAnimate.WMWindowPosChanging(var Message: TWMWindowPosChanging);
  10156. begin
  10157.   if FAutoSize and Open and (Message.WindowPos^.flags and SWP_NOSIZE = 0) then
  10158.     with Message.WindowPos^ do
  10159.       case Align of
  10160.         alNone:
  10161.           begin
  10162.             cx := FrameWidth;
  10163.             cy := FrameHeight;
  10164.           end;
  10165.         alLeft, alRight: cx := FrameWidth;
  10166.         alTop, alBottom: cy := FrameHeight;
  10167.       end;
  10168.   inherited;
  10169. end;
  10170.  
  10171. procedure TAnimate.CMColorChanged(var Message: TMessage);
  10172. begin
  10173.   inherited;
  10174.   if not (csLoading in ComponentState) then
  10175.     RecreateWnd;
  10176. end;
  10177.  
  10178. procedure TAnimate.CNCommand(var Message: TWMCommand);
  10179. begin
  10180.   inherited;
  10181.   case Message.NotifyCode of
  10182.     ACN_START: DoStart;
  10183.     ACN_STOP:
  10184.       if FStopCount = 0 then
  10185.         DoStop
  10186.       else
  10187.         Dec(FStopCount);
  10188.   end;
  10189. end;
  10190.  
  10191. procedure TAnimate.DoOpen;
  10192. begin
  10193.   if Assigned(FOnOpen) then FOnOpen(Self);
  10194. end;
  10195.  
  10196. procedure TAnimate.DoClose;
  10197. begin
  10198.   if Assigned(FOnClose) then FOnClose(Self);
  10199. end;
  10200.  
  10201. procedure TAnimate.DoStart;
  10202. begin
  10203.   if Assigned(FOnStart) then FOnStart(Self);
  10204. end;
  10205.  
  10206. procedure TAnimate.DoStop;
  10207. begin
  10208.   if Assigned(FOnStop) then FOnStop(Self);
  10209.   FActive := False;
  10210. end;
  10211.  
  10212. procedure TAnimate.Loaded;
  10213. begin
  10214.   inherited Loaded;
  10215.   if FStreamedActive then SetActive(True);
  10216.   AdjustSize;
  10217. end;
  10218.  
  10219. procedure TAnimate.GetAnimateParams(var Params);
  10220. begin
  10221.   with TAnimateParams(Params) do
  10222.   begin
  10223.     FileName := FFileName;
  10224.     CommonAVI := FCommonAVI;
  10225.     ResHandle := FResHandle;
  10226.     ResName := FResName;
  10227.     ResId := FResId;
  10228.   end;
  10229. end;
  10230.  
  10231. procedure TAnimate.SetAnimateParams(const Params);
  10232. begin
  10233.   with TAnimateParams(Params) do
  10234.   begin
  10235.     FFileName := FileName;
  10236.     FCommonAVI := CommonAVI;
  10237.     FResHandle := ResHandle;
  10238.     FResName := ResName;
  10239.     FResId := ResId;
  10240.   end;
  10241. end;
  10242.  
  10243. function TAnimate.GetActualResHandle: Integer;
  10244. begin
  10245.   if FCommonAVI <> aviNone then Result := ShellModule
  10246.   else if FResHandle <> 0 then Result := FResHandle
  10247.   else if MainInstance <> 0 then Result := MainInstance
  10248.   else Result := HInstance;
  10249. end;
  10250.  
  10251. function TAnimate.GetActualResId: Integer;
  10252. const
  10253.   CommonAVIId: array[TCommonAVI] of Integer = (0, 150, 151, 152, 160, 161, 162,
  10254.     163, 164);
  10255. begin
  10256.   if FCommonAVI <> aviNone then Result := CommonAVIId[FCommonAVI]
  10257.   else if FFileName <> '' then Result := Integer(FFileName)
  10258.   else if FResName <> '' then Result := Integer(FResName)
  10259.   else Result := FResId;
  10260. end;
  10261.  
  10262. procedure TAnimate.GetFrameInfo;
  10263.  
  10264.   function CreateResStream: TStream;
  10265.   const
  10266.     ResType = 'AVI';
  10267.   var
  10268.     Instance: THandle;
  10269.   begin
  10270.     { AVI is from a file }
  10271.     if FFileName <> '' then
  10272.       Result := TFileStream.Create(FFileName, fmShareDenyNone)
  10273.     else
  10274.     begin
  10275.       { AVI is from a resource }
  10276.       Instance := GetActualResHandle;
  10277.       if FResName <> '' then
  10278.         Result := TResourceStream.Create(Instance, FResName, ResType)
  10279.       else Result := TResourceStream.CreateFromID(Instance, GetActualResId, ResType);
  10280.     end;
  10281.   end;
  10282.  
  10283. const
  10284.   CountOffset = 48;
  10285.   WidthOffset = 64;
  10286.   HeightOffset = 68;
  10287. begin
  10288.   with CreateResStream do
  10289.   try
  10290.     if Seek(CountOffset, soFromBeginning) = CountOffset then
  10291.       ReadBuffer(FFrameCount, SizeOf(FFrameCount));
  10292.     if Seek(WidthOffset, soFromBeginning) = WidthOffset then
  10293.       ReadBuffer(FFrameWidth, SizeOf(FFrameWidth));
  10294.     if Seek(HeightOffset, soFromBeginning) = HeightOffset then
  10295.       ReadBuffer(FFrameHeight, SizeOf(FFrameHeight));
  10296.   finally
  10297.     Free;
  10298.   end;
  10299. end;
  10300.  
  10301. procedure TAnimate.SetActive(Value: Boolean);
  10302. begin
  10303.   if (csReading in ComponentState) then
  10304.   begin
  10305.     if Value then FStreamedActive := True;
  10306.   end
  10307.   else
  10308.   begin
  10309.     if FActive <> Value then
  10310.     begin
  10311.       if Value then
  10312.         Play(FStartFrame, FStopFrame, FRepetitions)
  10313.       else
  10314.         Stop;
  10315.     end;
  10316.   end;
  10317. end;
  10318.  
  10319. procedure TAnimate.SetAutoSize(Value: Boolean);
  10320. begin
  10321.   if FAutoSize <> Value then
  10322.   begin
  10323.     FAutoSize := Value;
  10324.     if Value then AdjustSize;
  10325.   end;
  10326. end;
  10327.  
  10328. procedure TAnimate.SetCenter(Value: Boolean);
  10329. begin
  10330.   if FCenter <> Value then
  10331.   begin
  10332.     FCenter := Value;
  10333.     RecreateWnd;
  10334.   end;
  10335. end;
  10336.  
  10337. procedure TAnimate.SetCommonAVI(Value: TCommonAVI);
  10338. begin
  10339.   if FCommonAVI <> Value then
  10340.   begin
  10341.     FRecreateNeeded := (FCommonAVI = aviNone);
  10342.     FCommonAVI := Value;
  10343.     FFileName := '';
  10344.     FResHandle := 0;
  10345.     FResName := '';
  10346.     FResId := 0;
  10347.     if Value = aviNone then SetOpen(False) else Reset;
  10348.   end;
  10349. end;
  10350.  
  10351. procedure TAnimate.SetFileName(Value: string);
  10352. var
  10353.   Save: TAnimateParams;
  10354. begin
  10355.   if AnsiCompareText(FFileName, Value) <> 0 then
  10356.   begin
  10357.     GetAnimateParams(Save);
  10358.     try
  10359.       FFileName := Value;
  10360.       FCommonAVI := aviNone;
  10361.       FResHandle := 0;
  10362.       FResName := '';
  10363.       FResId := 0;
  10364.       if FFileName = '' then SetOpen(False) else Reset;
  10365.     except
  10366.       SetAnimateParams(Save);
  10367.       raise;
  10368.     end;
  10369.   end;
  10370. end;
  10371.  
  10372. procedure TAnimate.SetOpen(Value: Boolean);
  10373. begin
  10374.   if (FOpen <> Value) then
  10375.     if Value then
  10376.     begin
  10377.       FOpen := InternalOpen;
  10378.       if AutoSize then AdjustSize;
  10379.     end
  10380.     else FOpen := InternalClose;
  10381. end;
  10382.  
  10383. procedure TAnimate.SetRepetitions(Value: Integer);
  10384. begin
  10385.   if FRepetitions <> Value then
  10386.   begin
  10387.     FRepetitions := Value;
  10388.     if not (csLoading in ComponentState) then Stop;
  10389.   end;
  10390. end;
  10391.  
  10392. procedure TAnimate.SetResHandle(Value: THandle);
  10393. begin
  10394.   if FResHandle <> Value then
  10395.   begin
  10396.     FResHandle := Value;
  10397.     FRecreateNeeded := True;
  10398.     FCommonAVI := aviNone;
  10399.     FFileName := '';
  10400.     if FResHandle = 0 then SetOpen(False) else Reset;
  10401.   end;
  10402. end;
  10403.  
  10404. procedure TAnimate.SetResId(Value: Integer);
  10405. begin
  10406.   if FResId <> Value then
  10407.   begin
  10408.     FResId := Value;
  10409.     FRecreateNeeded := (FCommonAVI <> aviNone) or (FFileName <> '');
  10410.     FCommonAVI := aviNone;
  10411.     FFileName := '';
  10412.     FResName := '';
  10413.     if Value = 0 then SetOpen(False) else Reset;
  10414.   end;
  10415. end;
  10416.  
  10417. procedure TAnimate.SetResName(Value: string);
  10418. begin
  10419.   if FResName <> Value then
  10420.   begin
  10421.     FResName := Value;
  10422.     FRecreateNeeded := (FCommonAVI <> aviNone) or (FFileName <> '');
  10423.     FCommonAVI := aviNone;
  10424.     FFileName := '';
  10425.     FResId := 0;
  10426.     if Value = '' then SetOpen(False) else Reset;
  10427.   end;
  10428. end;
  10429.  
  10430. procedure TAnimate.SetStartFrame(Value: Smallint);
  10431. begin
  10432.   if FStartFrame <> Value then
  10433.   begin
  10434.     FStartFrame := Value;
  10435.     if not (csLoading in ComponentState) then
  10436.     begin
  10437.       Stop;
  10438.       Seek(Value);
  10439.     end;
  10440.   end;
  10441. end;
  10442.  
  10443. procedure TAnimate.SetStopFrame(Value: Smallint);
  10444. begin
  10445.   if FStopFrame <> Value then
  10446.   begin
  10447.     FStopFrame := Value;
  10448.     if not (csLoading in ComponentState) then Stop;
  10449.   end;
  10450. end;
  10451.  
  10452. procedure TAnimate.SetTimers(Value: Boolean);
  10453. begin
  10454.   if FTimers <> Value then
  10455.   begin
  10456.     FTimers := Value;
  10457.     RecreateWnd;
  10458.   end;
  10459. end;
  10460.  
  10461. procedure TAnimate.SetTransparent(Value: Boolean);
  10462. begin
  10463.   if FTransparent <> Value then
  10464.   begin
  10465.     FTransparent := Value;
  10466.     RecreateWnd;
  10467.   end;
  10468. end;
  10469.  
  10470. procedure TAnimate.CheckOpen;
  10471. begin
  10472.   SetOpen(True);
  10473.   if not Open then raise Exception.Create(SCannotOpenAVI);
  10474. end;
  10475.  
  10476. function TAnimate.InternalOpen: Boolean;
  10477. var
  10478.   R: TRect;
  10479. begin
  10480.   if FRecreateNeeded then RecreateWnd;
  10481.   HandleNeeded;
  10482.   { Preserve dimensions to prevent auto sizing }
  10483.   if not Center then R := BoundsRect;
  10484.   Result := Perform(ACM_OPEN, 0, GetActualResId) <> 0;
  10485.   { Restore dimensions in case control was resized }
  10486.   if not Center then BoundsRect := R;
  10487.   if Result then
  10488.   begin
  10489.     GetFrameInfo;
  10490.     FStartFrame := 1;
  10491.     FStopFrame := FFrameCount;
  10492.     DoOpen;
  10493.   end;
  10494. end;
  10495.  
  10496. function TAnimate.InternalClose: Boolean;
  10497. begin
  10498.   if FActive then Stop;
  10499.   Result := SendMessage(Handle, ACM_OPEN, 0, 0) <> 0;
  10500.   DoClose;
  10501.   Invalidate;
  10502. end;
  10503.  
  10504. procedure TAnimate.Play(FromFrame, ToFrame: Word; Count: Integer);
  10505. begin
  10506.   HandleNeeded;
  10507.   CheckOpen;
  10508.   FActive := True;
  10509.   { ACM_PLAY excpects -1 for repeated animations }
  10510.   if Count = 0 then Count := -1;
  10511.   if Perform(ACM_PLAY, Count, MakeLong(FromFrame - 1, ToFrame - 1)) <> 1 then
  10512.     FActive := False;
  10513. end;
  10514.  
  10515. procedure TAnimate.Reset;
  10516. begin
  10517.   if not (csLoading in ComponentState) then
  10518.   begin
  10519.     SetOpen(False);
  10520.     Seek(1);
  10521.   end;
  10522. end;
  10523.  
  10524. procedure TAnimate.Seek(Frame: Smallint);
  10525. begin
  10526.   CheckOpen;
  10527.   SendMessage(Handle, ACM_PLAY, 1, MakeLong(Frame - 1, Frame - 1));
  10528. end;
  10529.  
  10530. procedure TAnimate.Stop;
  10531. begin
  10532.   { Seek to first frame }
  10533.   SendMessage(Handle, ACM_PLAY, 1, MakeLong(StartFrame - 1, StartFrame - 1));
  10534.   FActive := False;
  10535.   Inc(FStopCount);
  10536.   DoStop;
  10537. end;
  10538.  
  10539. { TToolButton }
  10540.  
  10541. constructor TToolButton.Create(AOwner: TComponent);
  10542. begin
  10543.   inherited Create(AOwner);
  10544.   ControlStyle := [csCaptureMouse, csSetCaption];
  10545.   Width := 23;
  10546.   Height := 22;
  10547.   FStyle := tbsButton;
  10548. end;
  10549.  
  10550. procedure TToolButton.MouseDown(Button: TMouseButton; Shift: TShiftState;
  10551.   X, Y: Integer);
  10552. begin
  10553.   if (Style = tbsDropDown) and (Button = mbLeft) and Enabled then
  10554.     Down := not Down;
  10555.   inherited MouseDown(Button, Shift, X, Y);
  10556. end;
  10557.  
  10558. procedure TToolButton.MouseMove(Shift: TShiftState; X, Y: Integer);
  10559. begin
  10560.   inherited MouseMove(Shift, X, Y);
  10561.   if (Style = tbsDropDown) and MouseCapture then
  10562.     Down := (X >= 0) and (X < ClientWidth) and (Y >= 0) and (Y <= ClientHeight);
  10563. end;
  10564.  
  10565. procedure TToolButton.MouseUp(Button: TMouseButton; Shift: TShiftState;
  10566.   X, Y: Integer);
  10567. begin
  10568.   inherited MouseUp(Button, Shift, X, Y);
  10569.   if (Button = mbLeft) and (X >= 0) and (X < ClientWidth) and (Y >= 0) and
  10570.     (Y <= ClientHeight) then
  10571.   begin
  10572.     if Style = tbsDropDown then Down := False;
  10573.     Click;
  10574.   end;
  10575. end;
  10576.  
  10577. procedure TToolButton.Click;
  10578. begin
  10579.   inherited Click;
  10580. end;
  10581.  
  10582. procedure TToolButton.Notification(AComponent: TComponent;
  10583.   Operation: TOperation);
  10584. begin
  10585.   inherited Notification(AComponent, Operation);
  10586.   if (AComponent = DropdownMenu) and (Operation = opRemove) then
  10587.     DropdownMenu := nil;
  10588. end;
  10589.  
  10590. procedure TToolButton.CMTextChanged(var Message: TMessage);
  10591. begin
  10592.   inherited;
  10593.   UpdateControl;
  10594.   if Assigned(FToolBar) and FToolBar.ShowCaptions then
  10595.     FToolBar.RecreateButtons;
  10596. end;
  10597.  
  10598. procedure TToolButton.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);
  10599. var
  10600.   Pos: Integer;
  10601.   Reordered, NeedsUpdate: Boolean;
  10602.   ResizeWidth, ResizeHeight: Boolean;
  10603. begin
  10604.   if (FUpdateCount = 0) and not (csLoading in ComponentState) and
  10605.     Assigned(FToolBar) then
  10606.   begin
  10607.     Pos := Index;
  10608.     Reordered := FToolBar.ReorderButton(Index, ALeft, ATop);
  10609.     if Reordered then
  10610.     begin
  10611.       NeedsUpdate := False;
  10612.       if Index < Pos then Pos := Index
  10613.     end
  10614.     else
  10615.     begin
  10616.       NeedsUpdate := (Style in [tbsSeparator, tbsDivider]) and (AWidth <> Width);
  10617.       Reordered := NeedsUpdate;
  10618.     end;
  10619.     if not FToolBar.Flat and (Style = tbsDropDown) then
  10620.       AWidth := Width * 2 div 3 + Width mod 3 + AWidth - Width;
  10621.     ResizeWidth := not (Style in [tbsSeparator, tbsDivider]) and
  10622.       (AWidth <> FToolBar.ButtonWidth);
  10623.     ResizeHeight := AHeight <> FToolBar.ButtonHeight;
  10624.     if NeedsUpdate then inherited SetBounds(ALeft, ATop, AWidth, AHeight);
  10625.     if csDesigning in ComponentState then
  10626.     begin
  10627.       if ResizeWidth then FToolBar.ButtonWidth := AWidth;
  10628.       if ResizeHeight then FToolBar.ButtonHeight := AHeight;
  10629.     end;
  10630.     if Reordered and not ResizeWidth and not ResizeHeight then
  10631.     begin
  10632.       if NeedsUpdate then FToolBar.UpdateButton(Pos);
  10633.       FToolBar.ResizeButtons;
  10634.       FToolBar.RepositionButtons(0);
  10635.     end
  10636.     else
  10637.       FToolBar.RepositionButton(Pos);
  10638.   end
  10639.   else inherited SetBounds(ALeft, ATop, AWidth, AHeight);
  10640. end;
  10641.  
  10642. procedure TToolButton.Paint;
  10643. var
  10644.   R: TRect;
  10645. begin
  10646.   if not Assigned(FToolBar) then Exit;
  10647.   if Style = tbsDivider then
  10648.     with Canvas do
  10649.     begin
  10650.       R := Rect(Width div 2 - 1, 0, Width, Height);
  10651.       DrawEdge(Handle, R, EDGE_ETCHED, BF_LEFT)
  10652.     end;
  10653.   if csDesigning in ComponentState then
  10654.     { Draw separator outline }
  10655.     if Style in [tbsSeparator, tbsDivider] then
  10656.       with Canvas do
  10657.       begin
  10658.         Pen.Style := psDot;
  10659.         Pen.Color := clBtnShadow;
  10660.         Brush.Style := bsClear;
  10661.         Rectangle(0, 0, ClientWidth, ClientHeight);
  10662.       end
  10663.     { Draw Flat button face }
  10664.     else if FToolBar.Flat and not Down then
  10665.       with Canvas do
  10666.       begin
  10667.         R := Rect(0, 0, Width, Height);
  10668.         DrawEdge(Handle, R, BDR_RAISEDINNER, BF_RECT);
  10669.       end;
  10670. end;
  10671.  
  10672. const
  10673.   ButtonStates: array[TToolButtonState] of Word = (TBSTATE_CHECKED,
  10674.     TBSTATE_PRESSED, TBSTATE_ENABLED, TBSTATE_HIDDEN, TBSTATE_INDETERMINATE,
  10675.     TBSTATE_WRAP);
  10676.  
  10677.   ButtonStyles: array[TToolButtonStyle] of Word = (TBSTYLE_BUTTON, TBSTYLE_CHECK,
  10678.     TBSTYLE_DROPDOWN, TBSTYLE_SEP, TBSTYLE_SEP);
  10679.  
  10680. function TToolButton.GetButtonState: Byte;
  10681. begin
  10682.   Result := 0;
  10683.   if FDown then
  10684.     if Style = tbsCheck then
  10685.       Result := Result or ButtonStates[tbsChecked]
  10686.     else
  10687.       Result := Result or ButtonStates[tbsPressed];
  10688.   if Enabled and (not Assigned(FToolBar) or FToolBar.Enabled) then
  10689.     Result := Result or ButtonStates[tbsEnabled];
  10690.   if not Visible and not (csDesigning in ComponentState) then
  10691.     Result := Result or ButtonStates[tbsHidden];
  10692.   if FIndeterminate then Result := Result or ButtonStates[tbsIndeterminate];
  10693.   if FWrap then Result := Result or ButtonStates[tbsWrap];
  10694. end;
  10695.  
  10696. procedure TToolButton.SetButtonState(State: Byte);
  10697. begin
  10698.   FDown := State and (TBSTATE_CHECKED or TBSTATE_PRESSED) <> 0;
  10699.   Enabled := State and TBSTATE_ENABLED <> 0;
  10700.   Visible := (csDesigning in ComponentState) or (State and TBSTATE_HIDDEN = 0);
  10701.   FIndeterminate := not FDown and (State and TBSTATE_INDETERMINATE <> 0);
  10702.   FWrap := State and TBSTATE_WRAP <> 0;
  10703. end;
  10704.  
  10705. procedure TToolButton.SetToolBar(AToolBar: TToolBar);
  10706. begin
  10707.   if FToolBar <> AToolBar then
  10708.   begin
  10709.     if FToolBar <> nil then FToolBar.RemoveButton(Self);
  10710.     Parent := AToolBar;
  10711.     if AToolBar <> nil then AToolBar.InsertButton(Self);
  10712.   end;
  10713. end;
  10714.  
  10715. procedure TToolButton.CMVisibleChanged(var Message: TMessage);
  10716. begin
  10717.   if not (csDesigning in ComponentState) and Assigned(FToolBar) then
  10718.   begin
  10719.     UpdateControl;
  10720.     if Assigned(FToolBar) then
  10721.       with FToolBar do
  10722.       begin
  10723.         Perform(TB_HIDEBUTTON, Index, Longint(Ord(Visible)));
  10724.         RepositionButtons(Index);
  10725.         { Force a resize to occur }
  10726.         if AutoSize then AdjustSize;
  10727.       end;
  10728.   end;
  10729. end;
  10730.  
  10731. procedure TToolButton.CMEnabledChanged(var Message: TMessage);
  10732. begin
  10733.   if Assigned(FToolBar) then
  10734.     FToolBar.Perform(TB_ENABLEBUTTON, Index, Longint(Ord(Enabled)));
  10735. end;
  10736.  
  10737. procedure TToolButton.SetDown(Value: Boolean);
  10738. const
  10739.   DownMessage: array[Boolean] of Integer = (TB_PRESSBUTTON, TB_CHECKBUTTON);
  10740. begin
  10741.   if Value <> FDown then
  10742.   begin
  10743.     FDown := Value;
  10744.     if Assigned(FToolBar) then
  10745.     begin
  10746.       FToolBar.Perform(DownMessage[Style = tbsCheck], Index, MakeLong(Ord(Value), 0));
  10747.       FToolBar.UpdateButtonStates;
  10748.     end;
  10749.   end;
  10750. end;
  10751.  
  10752. procedure TToolButton.SetDropdownMenu(Value: TPopupMenu);
  10753. begin
  10754.   if Value <> FDropdownMenu then
  10755.   begin
  10756.     FDropdownMenu := Value;
  10757.     if Value <> nil then Value.FreeNotification(Self);
  10758.   end;
  10759. end;
  10760.  
  10761. procedure TToolButton.SetGrouped(Value: Boolean);
  10762. begin
  10763.   if FGrouped <> Value then
  10764.   begin
  10765.     FGrouped := Value;
  10766.     UpdateControl;
  10767.   end;
  10768. end;
  10769.  
  10770. procedure TToolButton.SetImageIndex(Value: Integer);
  10771. begin
  10772.   if FImageIndex <> Value then
  10773.   begin
  10774.     FImageIndex := Value;
  10775.     if Assigned(FToolBar) then
  10776.     begin
  10777.       FToolBar.Perform(TB_CHANGEBITMAP, Index, Value);
  10778.       if FToolBar.Flat then Invalidate;
  10779.     end;
  10780.   end;
  10781. end;
  10782.  
  10783. procedure TToolButton.SetIndeterminate(Value: Boolean);
  10784. begin
  10785.   if FIndeterminate <> Value then
  10786.   begin
  10787.     if Value then SetDown(False);
  10788.     FIndeterminate := Value;
  10789.     if Assigned(FToolBar) then
  10790.       FToolBar.Perform(TB_INDETERMINATE, Index, Longint(Ord(Value)));
  10791.   end;
  10792. end;
  10793.  
  10794. procedure TToolButton.SetStyle(Value: TToolButtonStyle);
  10795. begin
  10796.   if FStyle <> Value then
  10797.   begin
  10798.     FStyle := Value;
  10799.     Invalidate;
  10800.     if Assigned(FToolBar) then
  10801.     begin
  10802.       UpdateControl;
  10803.       FToolBar.ResizeButtons;
  10804.       FToolBar.RepositionButtons(Index);
  10805.     end;
  10806.   end;
  10807. end;
  10808.  
  10809. procedure TToolButton.SetWrap(Value: Boolean);
  10810. begin
  10811.   if FWrap <> Value then
  10812.   begin
  10813.     FWrap := Value;
  10814.     if Assigned(FToolBar) then
  10815.     begin
  10816.       UpdateControl;
  10817.       with FToolBar do
  10818.       begin
  10819.         RepositionButtons(Index);
  10820.         { Force a resize to occur }
  10821.         if AutoSize then AdjustSize;
  10822.       end;
  10823.     end;
  10824.   end;
  10825. end;
  10826.  
  10827. procedure TToolButton.BeginUpdate;
  10828. begin
  10829.   Inc(FUpdateCount);
  10830. end;
  10831.  
  10832. procedure TToolButton.EndUpdate;
  10833. begin
  10834.   Dec(FUpdateCount);
  10835. end;
  10836.  
  10837. function TToolButton.GetIndex: Integer;
  10838. begin
  10839.   if Assigned(FToolBar) then
  10840.     Result := FToolBar.FButtons.IndexOf(Self)
  10841.   else
  10842.     Result := -1;
  10843. end;
  10844.  
  10845. procedure TToolButton.UpdateControl;
  10846. begin
  10847.   if Assigned(FToolBar) then FToolBar.UpdateButton(Index);
  10848. end;
  10849.  
  10850. function TToolButton.CheckMenuDropdown: Boolean;
  10851. begin
  10852.   Result := False;
  10853.   if not (csDesigning in ComponentState) and Assigned(DropdownMenu) and
  10854.     DropdownMenu.AutoPopup then
  10855.   begin
  10856.     SendCancelMode(nil);
  10857.     DropdownMenu.PopupComponent := Self;
  10858.     with ClientToScreen(Point(0, ClientHeight)) do DropdownMenu.Popup(X, Y);
  10859.     Result := True;
  10860.   end;
  10861. end;
  10862.  
  10863. { TToolBar }
  10864.  
  10865. constructor TToolBar.Create(AOwner: TComponent);
  10866. begin
  10867.   inherited Create(AOwner);
  10868.   ControlStyle := [csAcceptsControls, csCaptureMouse, csClickEvents,
  10869.     csDoubleClicks];
  10870.   Height := 32;
  10871.   Align := alTop;
  10872.   EdgeBorders := [ebTop];
  10873.   FButtonWidth := 23;
  10874.   FButtonHeight := 22;
  10875.   FNewStyle := True;
  10876.   FWrapable := True;
  10877.   FButtons := TList.Create;
  10878.   FImageChangeLink := TChangeLink.Create;
  10879.   FImageChangeLink.OnChange := ImageListChange;
  10880.   FDisabledImageChangeLink := TChangeLink.Create;
  10881.   FDisabledImageChangeLink.OnChange := DisabledImageListChange;
  10882.   FHotImageChangeLink := TChangeLink.Create;
  10883.   FHotImageChangeLink.OnChange := HotImageListChange;
  10884.   FNullBitmap := TBitmap.Create;
  10885.   with FNullBitmap do
  10886.   begin
  10887.     Width := 1;
  10888.     Height := 1;
  10889.     Canvas.Brush.Color := clBtnFace;
  10890.     Canvas.FillRect(Rect(0,0,1,1));
  10891.   end;
  10892. end;
  10893.  
  10894. destructor TToolBar.Destroy;
  10895. var
  10896.   I: Integer;
  10897. begin
  10898.   FNullBitmap.Free;
  10899.   FHotImageChangeLink.Free;
  10900.   FDisabledImageChangeLink.Free;
  10901.   FImageChangeLink.Free;
  10902.   for I := 0 to FButtons.Count - 1 do
  10903.     if TControl(FButtons[I]) is TToolButton then
  10904.       TToolButton(FButtons[I]).FToolBar := nil;
  10905.   FButtons.Free;
  10906.   inherited Destroy;
  10907. end;
  10908.  
  10909. procedure TToolBar.CreateParams(var Params: TCreateParams);
  10910. const
  10911.   DefaultStyles = CCS_NOPARENTALIGN or CCS_NOMOVEY or CCS_NORESIZE or CCS_NODIVIDER;
  10912.   ListStyles: array[Boolean] of Integer = (0, TBSTYLE_LIST);
  10913.   FlatStyles: array[Boolean] of Integer = (0, TBSTYLE_FLAT);
  10914. begin
  10915.   FNewStyle := InitCommonControl(ICC_BAR_CLASSES);
  10916.   inherited CreateParams(Params);
  10917.   CreateSubClass(Params, TOOLBARCLASSNAME);
  10918.   with Params do
  10919.   begin
  10920.     Style := Style or DefaultStyles or FlatStyles[FFlat] or ListStyles[FList];
  10921.     WindowClass.style := WindowClass.style and not (CS_HREDRAW or CS_VREDRAW);
  10922.   end;
  10923. end;
  10924.  
  10925. procedure TToolBar.CreateWnd;
  10926. var
  10927.   DisplayDC: HDC;
  10928.   SaveFont, StockFont: HFONT;
  10929.   TxtMetric: TTextMetric;
  10930. begin
  10931.   inherited CreateWnd;
  10932.   FOldHandle := 0;
  10933.   StockFont := GetStockObject(SYSTEM_FONT);
  10934.   if StockFont <> 0 then
  10935.   begin
  10936.     DisplayDC := GetDC(0);
  10937.     if (DisplayDC <> 0) then
  10938.     begin
  10939.       SaveFont := SelectObject(DisplayDC, StockFont);
  10940.       if (GetTextMetrics(DisplayDC, TxtMetric)) then
  10941.         with TxtMetric do
  10942.           FHeightMargin := tmHeight - tmInternalLeading - tmExternalLeading + 1;
  10943.       SelectObject(DisplayDC, SaveFont);
  10944.       ReleaseDC(0, DisplayDC);
  10945.     end;
  10946.   end;
  10947.   RecreateButtons;
  10948.   Invalidate;
  10949. end;
  10950.  
  10951. procedure TToolBar.CreateButtons(NewWidth, NewHeight: Integer);
  10952. var
  10953.   ImageWidth, ImageHeight: Integer;
  10954. begin
  10955.   BeginUpdate;
  10956.   try
  10957.     HandleNeeded;
  10958.     Perform(TB_BUTTONSTRUCTSIZE, SizeOf(TTBButton), 0);
  10959.     Perform(TB_SETINDENT, FIndent, 0);
  10960.     if Assigned(FImages) then
  10961.     begin
  10962.       ImageWidth := FImages.Width;
  10963.       ImageHeight := FImages.Height;
  10964.     end
  10965.     else if Assigned(FDisabledImages) then
  10966.     begin
  10967.       ImageWidth := FDisabledImages.Width;
  10968.       ImageHeight := FDisabledImages.Height;
  10969.     end
  10970.     else if Assigned(FHotImages) then
  10971.     begin
  10972.       ImageWidth := FHotImages.Width;
  10973.       ImageHeight := FHotImages.Height;
  10974.     end
  10975.     else
  10976.     begin
  10977.       ImageWidth := 0;
  10978.       ImageHeight := 0;
  10979.     end;
  10980.     Perform(TB_SETBITMAPSIZE, 0, MakeLParam(ImageWidth, ImageHeight));
  10981.     if ShowCaptions then Dec(NewHeight, FHeightMargin);
  10982.     { Prevent toolbar from setting default button size }
  10983.     if NewWidth <= 0 then NewWidth := 1;
  10984.     if NewHeight <= 0 then NewHeight := 1;
  10985.     Perform(TB_SETBUTTONSIZE, 0, MakeLParam(NewWidth, NewHeight));
  10986.   finally
  10987.     EndUpdate;
  10988.   end;
  10989.   { Retrieve current button sizes }
  10990.   UpdateButtons;
  10991.   UpdateImages;
  10992.   GetButtonSize(FButtonWidth, FButtonHeight);
  10993. end;
  10994.  
  10995. procedure TToolBar.AdjustSize;
  10996. begin
  10997.   if not (csLoading in ComponentState) and HandleAllocated then
  10998.     SetWindowPos(Handle, 0, 0, 0, Width, Height, SWP_NOACTIVATE or SWP_NOMOVE or
  10999.       SWP_NOZORDER);
  11000. end;
  11001.  
  11002. procedure TToolBar.RepositionButton(Index: Integer);
  11003. var
  11004.   TBButton: TTBButton;
  11005.   Button: TControl;
  11006.   R: TRect;
  11007.   AdjustY: Integer;
  11008. begin
  11009.   if (csLoading in ComponentState) or
  11010.     (Perform(TB_GETBUTTON, Index, Longint(@TBButton)) = 0) then
  11011.     Exit;
  11012.   Button := TControl(TBButton.dwData);
  11013.   if Button is TToolButton then TToolButton(Button).BeginUpdate;
  11014.   try
  11015.     Perform(TB_GETITEMRECT, Index, Longint(@R));
  11016.     if (Button is TWinControl) then
  11017.       with TWinControl(Button) do
  11018.       begin
  11019.         HandleNeeded;
  11020.         { Check for a control that doesn't size and center it }
  11021.         BoundsRect := R;
  11022.         if Height < R.Bottom - R.Top then
  11023.         begin
  11024.           AdjustY := (R.Bottom - R.Top - Height) div 2;
  11025.           SetBounds(R.Left, R.Top + AdjustY, R.Right - R.Left, Height);
  11026.         end;
  11027.       end
  11028.     else
  11029.       Button.BoundsRect := R;
  11030.   finally
  11031.     if Button is TToolButton then TToolButton(Button).EndUpdate;
  11032.   end;
  11033. end;
  11034.  
  11035. procedure TToolBar.RepositionButtons(Index: Integer);
  11036. var
  11037.   I: Integer;
  11038. begin
  11039.   if (csLoading in ComponentState) or (FUpdateCount > 0) then Exit;
  11040.   BeginUpdate;
  11041.   try
  11042.     for I := InternalButtonCount - 1 downto Index do RepositionButton(I);
  11043.   finally
  11044.     EndUpdate;
  11045.   end;
  11046. end;
  11047.  
  11048. procedure TToolBar.GetButtonSize(var AWidth, AHeight: Integer);
  11049. var
  11050.   LastIndex: Integer;
  11051.   R: TRect;
  11052.   TBButton: TTBButton;
  11053. begin
  11054.   if HandleAllocated then
  11055.   begin
  11056.     LastIndex := InternalButtonCount - 1;
  11057.     if LastIndex < 0 then Exit;
  11058.     while (LastIndex >= 0) and
  11059.       (Perform(TB_GETBUTTON, LastIndex, Integer(@TBButton)) <> 0) and
  11060.       (TBButton.fsStyle and TBSTYLE_SEP <> 0) do
  11061.       Dec(LastIndex);
  11062.     if LastIndex < 0 then
  11063.     begin
  11064.       if Perform(TB_GETITEMRECT, 0, Longint(@R)) <> 0 then
  11065.         AHeight := R.Bottom - R.Top;
  11066.       Exit;
  11067.     end;
  11068.     if Perform(TB_GETITEMRECT, LastIndex, Longint(@R)) <> 0 then
  11069.     begin
  11070.       AHeight := R.Bottom - R.Top;
  11071.       { Adjust size for drop-down and separator buttons }
  11072.       if not Flat and (TBButton.fsStyle and TBSTYLE_DROPDOWN <> 0) then
  11073.         AWidth := (R.Right - R.Left) * 2 div 3 + (R.Right - R.Left) mod 3
  11074.       else
  11075.         AWidth := R.Right - R.Left;
  11076.     end;
  11077.   end;
  11078. end;
  11079.  
  11080. procedure TToolBar.SetButtonHeight(Value: Integer);
  11081. begin
  11082.   if Value <> FButtonHeight then
  11083.   begin
  11084.     FButtonHeight := Value;
  11085.     RecreateButtons;
  11086.   end;
  11087. end;
  11088.  
  11089. procedure TToolBar.SetButtonWidth(Value: Integer);
  11090. begin
  11091.   if Value <> FButtonWidth then
  11092.   begin
  11093.     FButtonWidth := Value;
  11094.     RecreateButtons;
  11095.   end;
  11096. end;
  11097.  
  11098. procedure TToolBar.InsertButton(Control: TControl);
  11099. var
  11100.   Pos: Integer;
  11101. begin
  11102.   if Control is TToolButton then TToolButton(Control).FToolBar := Self;
  11103.   Pos := FButtons.Add(Control);
  11104.   UpdateButton(Pos);
  11105.   ResizeButtons;
  11106.   if Wrapable then
  11107.     RepositionButtons(0)
  11108.   else
  11109.     RepositionButtons(Pos);
  11110. end;
  11111.  
  11112. procedure TToolBar.RemoveButton(Control: TControl);
  11113. var
  11114.   I, Pos: Integer;
  11115. begin
  11116.   I := FButtons.IndexOf(Control);
  11117.   if I >= 0 then
  11118.   begin
  11119.     if Control is TToolButton then TToolButton(Control).FToolBar := nil;
  11120.     Pos := FButtons.Remove(Control);
  11121.     Perform(TB_DELETEBUTTON, Pos, 0);
  11122.     ResizeButtons;
  11123.     if Wrapable then
  11124.       RepositionButtons(0)
  11125.     else
  11126.       RepositionButtons(Pos);
  11127.   end;
  11128. end;
  11129.  
  11130. procedure TToolBar.UpdateItem(Message, FromIndex, ToIndex: Integer);
  11131. var
  11132.   Control: TControl;
  11133.   Button: TTBButton;
  11134.   Buffer: array[0..4095] of Char;
  11135. begin
  11136.   Control := TControl(FButtons[FromIndex]);
  11137.   if Control is TToolButton then
  11138.     with TToolButton(Control) do
  11139.     begin
  11140.       FillChar(Button, SizeOf(Button), 0);
  11141.       if Style in [tbsSeparator, tbsDivider] then
  11142.       begin
  11143.         Button.iBitmap := Width;
  11144.         Button.idCommand := -1;
  11145.       end
  11146.       else
  11147.       begin
  11148.         Button.iBitmap := ImageIndex;
  11149.         Button.idCommand := FromIndex;
  11150.       end;
  11151.       Button.fsStyle := ButtonStyles[Style];
  11152.       Button.fsState := GetButtonState;
  11153.       if FGrouped then Button.fsStyle := Button.fsStyle or TBSTYLE_GROUP;
  11154.       Button.dwData := Longint(Control);
  11155.       if ShowCaptions then
  11156.       begin
  11157.         StrPCopy(Buffer, Caption);
  11158.         { TB_ADDSTRING requires two null terminators }
  11159.         Buffer[Length(Caption) + 1] := #0;
  11160.         Button.iString := Self.Perform(TB_ADDSTRING, 0, Longint(@Buffer));
  11161.       end
  11162.       else
  11163.         Button.iString := -1;
  11164.     end
  11165.   else
  11166.   begin
  11167.     FillChar(Button, SizeOf(Button), 0);
  11168.     Button.fsStyle := ButtonStyles[tbsSeparator];
  11169.     Button.iBitmap := Control.Width;
  11170.     Button.idCommand := -1;
  11171.     Button.dwData := Longint(Control);
  11172.     Button.iString := -1;
  11173.   end;
  11174.   Self.Perform(Message, ToIndex, Integer(@Button));
  11175. end;
  11176.  
  11177. procedure TToolBar.UpdateButton(Index: Integer);
  11178. var
  11179.   Style: Longint;
  11180. begin
  11181.   if FUpdateCount > 0 then Exit;
  11182.   BeginUpdate;
  11183.   try
  11184.     HandleNeeded;
  11185.     Style := GetWindowLong(Handle, GWL_STYLE);
  11186.     SetWindowLong(Handle, GWL_STYLE, Style and not WS_VISIBLE);
  11187.     try
  11188.       if Perform(TB_DELETEBUTTON, Index, 0) = 1 then
  11189.         UpdateItem(TB_INSERTBUTTON, Index, Index)
  11190.       else
  11191.         UpdateItem(TB_ADDBUTTONS, Index, 1)
  11192.     finally
  11193.       SetWindowLong(Handle, GWL_STYLE, Style);
  11194.     end;
  11195.   finally
  11196.     EndUpdate;
  11197.   end;
  11198. end;
  11199.  
  11200. procedure TToolBar.UpdateButtons;
  11201. var
  11202.   I: Integer;
  11203.   Style: Longint;
  11204. begin
  11205.   if FUpdateCount > 0 then Exit;
  11206.   BeginUpdate;
  11207.   try
  11208.     HandleNeeded;
  11209.     Style := GetWindowLong(Handle, GWL_STYLE);
  11210.     SetWindowLong(Handle, GWL_STYLE, Style and not WS_VISIBLE);
  11211.     try
  11212.       for I := 0 to InternalButtonCount - 1 do Perform(TB_DELETEBUTTON, 0, 0);
  11213.       for I := 0 to FButtons.Count - 1 do UpdateItem(TB_ADDBUTTONS, I, 1);
  11214.     finally
  11215.       SetWindowLong(Handle, GWL_STYLE, Style);
  11216.     end;
  11217.   finally
  11218.     EndUpdate;
  11219.   end;
  11220.   RepositionButtons(0);
  11221. end;
  11222.  
  11223. procedure TToolBar.UpdateButtonState(Index: Integer);
  11224. var
  11225.   TBButton: TTBButton;
  11226. begin
  11227.   if (Perform(TB_GETBUTTON, Index, Integer(@TBButton)) <> 0) then
  11228.     with TToolButton(TBButton.dwData) do
  11229.     begin
  11230.       SetButtonState(TBButton.fsState);
  11231.       Self.Perform(TB_SETSTATE, Index, MakeLong(GetButtonState, 0));
  11232.     end;
  11233. end;
  11234.  
  11235. procedure TToolBar.UpdateButtonStates;
  11236. var
  11237.   I: Integer;
  11238. begin
  11239.   for I := 0 to FButtons.Count - 1 do
  11240.     if TControl(FButtons[I]) is TToolButton then
  11241.       UpdateButtonState(I);
  11242. end;
  11243.  
  11244. procedure TToolBar.SetAutoSize(Value: Boolean);
  11245. begin
  11246.   if FAutoSize <> Value then
  11247.   begin
  11248.     FAutoSize := Value;
  11249.     if Value then AdjustSize;
  11250.   end;
  11251. end;
  11252.  
  11253. procedure TToolBar.SetShowCaptions(Value: Boolean);
  11254. begin
  11255.   if FShowCaptions <> Value then
  11256.   begin
  11257.     FShowCaptions := Value;
  11258.     RecreateWnd;
  11259.   end;
  11260. end;
  11261.  
  11262. function TToolBar.GetButton(Index: Integer): TToolButton;
  11263. begin
  11264.   Result := FButtons[Index];
  11265. end;
  11266.  
  11267. function TToolBar.GetButtonCount: Integer;
  11268. begin
  11269.   Result := FButtons.Count;
  11270. end;
  11271.  
  11272. function TToolBar.GetRowCount: Integer;
  11273. begin
  11274.   Result := Perform(TB_GETROWS, 0, 0);
  11275. end;
  11276.  
  11277. procedure TToolBar.SetList(Value: Boolean);
  11278. begin
  11279.   if FList <> Value then
  11280.   begin
  11281.     FList := Value;
  11282.     RecreateWnd;
  11283.   end;
  11284. end;
  11285.  
  11286. procedure TToolBar.SetFlat(Value: Boolean);
  11287. begin
  11288.   if FFlat <> Value then
  11289.   begin
  11290.     FFlat := Value;
  11291.     RecreateWnd;
  11292.   end;
  11293. end;
  11294.  
  11295. procedure TToolBar.SetWrapable(Value: Boolean);
  11296. begin
  11297.   if FWrapable <> Value then
  11298.   begin
  11299.     FWrapable := Value;
  11300.     if Value then AdjustSize;
  11301.   end;
  11302. end;
  11303.  
  11304. procedure TToolBar.Resize;
  11305. begin
  11306.   if Assigned(FOnResize) then FOnResize(Self);
  11307. end;
  11308.  
  11309. procedure TToolBar.Notification(AComponent: TComponent;
  11310.   Operation: TOperation);
  11311. begin
  11312.   inherited Notification(AComponent, Operation);
  11313.   if Operation = opRemove then
  11314.   begin
  11315.     if AComponent = FImages then Images := nil;
  11316.     if AComponent = FHotImages then HotImages := nil;
  11317.     if AComponent = FDisabledImages then DisabledImages := nil;
  11318.   end;
  11319. end;
  11320.  
  11321. procedure TToolBar.LoadImages(AImages: TImageList);
  11322. var
  11323.   AddBitmap: TTBAddBitmap;
  11324.   ReplaceBitmap: TTBReplaceBitmap;
  11325.   NewHandle: HBITMAP;
  11326.  
  11327.   function GetImageBitmap(ImageList: TImageList): HBITMAP;
  11328.   var
  11329.     I: Integer;
  11330.     Bitmap: TBitmap;
  11331.     R: TRect;
  11332.   begin
  11333.     Bitmap := TBitmap.Create;
  11334.     try
  11335.       Bitmap.Width := ImageList.Width * ImageList.Count;
  11336.       Bitmap.Height := ImageList.Height;
  11337.       R := Rect(0,0,Width,Height);
  11338.       with Bitmap.Canvas do
  11339.       begin
  11340.         Brush.Color := clBtnFace;
  11341.         FillRect(R);
  11342.       end;
  11343.       for I := 0 to ImageList.Count - 1 do
  11344.         ImageList_Draw(ImageList.Handle, I, Bitmap.Canvas.Handle,
  11345.           I * ImageList.Width, 0, ILD_TRANSPARENT);
  11346.       Result := Bitmap.ReleaseHandle;
  11347.     finally
  11348.       Bitmap.Free;
  11349.     end;
  11350.   end;
  11351.  
  11352. begin
  11353.   if Assigned(AImages) then
  11354.     NewHandle := GetImageBitmap(AImages)
  11355.   else
  11356.     with TBitmap.Create do
  11357.     try
  11358.       Assign(FNullBitmap);
  11359.       NewHandle := ReleaseHandle;
  11360.     finally
  11361.       Free;
  11362.     end;
  11363.   if FOldHandle = 0 then
  11364.   begin
  11365.     AddBitmap.hInst := 0;
  11366.     AddBitmap.nID := NewHandle;
  11367.     Perform(TB_ADDBITMAP, ButtonCount, Longint(@AddBitmap));
  11368.   end
  11369.   else
  11370.   begin
  11371.     with ReplaceBitmap do
  11372.     begin
  11373.       hInstOld := 0;
  11374.       nIDOld := FOldHandle;
  11375.       hInstNew := 0;
  11376.       nIDNew := NewHandle;
  11377.       nButtons := ButtonCount;
  11378.     end;
  11379.     Perform(TB_REPLACEBITMAP, 0, Longint(@ReplaceBitmap));
  11380.     if FOldHandle <> 0 then DeleteObject(FOldHandle);
  11381.   end;
  11382.   FOldHandle := NewHandle;
  11383. end;
  11384.  
  11385. procedure TToolBar.UpdateImages;
  11386. begin
  11387.   if FNewStyle then
  11388.   begin
  11389.     if FImages <> nil then SetImageList(FImages.Handle);
  11390.     if FDisabledImages <> nil then SetDisabledImageList(FDisabledImages.Handle);
  11391.     if FHotImages <> nil then SetHotImageList(FHotImages.Handle);
  11392.   end
  11393.   else
  11394.     if HandleAllocated then LoadImages(FImages);
  11395. end;
  11396.  
  11397. procedure TToolBar.ImageListChange(Sender: TObject);
  11398. begin
  11399.   if HandleAllocated and (Sender = Images) then RecreateButtons;
  11400. end;
  11401.  
  11402. procedure TToolBar.SetImageList(Value: HImageList);
  11403. begin
  11404.   if HandleAllocated then Perform(TB_SETIMAGELIST, 0, Value);
  11405.   Invalidate;
  11406. end;
  11407.  
  11408. procedure TToolBar.SetImages(Value: TImageList);
  11409. begin
  11410.   if FImages <> nil then FImages.UnRegisterChanges(FImageChangeLink);
  11411.   FImages := Value;
  11412.   if FImages <> nil then
  11413.     FImages.RegisterChanges(FImageChangeLink)
  11414.   else
  11415.     SetImageList(0);
  11416.   RecreateButtons;
  11417. end;
  11418.  
  11419. procedure TToolBar.DisabledImageListChange(Sender: TObject);
  11420. begin
  11421.   if HandleAllocated and (Sender = DisabledImages) then RecreateButtons;
  11422. end;
  11423.  
  11424. procedure TToolBar.SetDisabledImageList(Value: HImageList);
  11425. begin
  11426.   if HandleAllocated then Perform(TB_SETDISABLEDIMAGELIST, 0, Value);
  11427.   Invalidate;
  11428. end;
  11429.  
  11430. procedure TToolBar.SetDisabledImages(Value: TImageList);
  11431. begin
  11432.   if FDisabledImages <> nil then FDisabledImages.UnRegisterChanges(FDisabledImageChangeLink);
  11433.   FDisabledImages := Value;
  11434.   if FDisabledImages <> nil then
  11435.     FDisabledImages.RegisterChanges(FDisabledImageChangeLink)
  11436.   else
  11437.     SetDisabledImageList(0);
  11438.   RecreateButtons;
  11439. end;
  11440.  
  11441. procedure TToolBar.HotImageListChange(Sender: TObject);
  11442. begin
  11443.   if HandleAllocated and (Sender = HotImages) then RecreateButtons;
  11444. end;
  11445.  
  11446. procedure TToolBar.SetHotImageList(Value: HImageList);
  11447. begin
  11448.   if HandleAllocated then Perform(TB_SETHOTIMAGELIST, 0, Value);
  11449.   Invalidate;
  11450. end;
  11451.  
  11452. procedure TToolBar.SetHotImages(Value: TImageList);
  11453. begin
  11454.   if FHotImages <> nil then FHotImages.UnRegisterChanges(FHotImageChangeLink);
  11455.   FHotImages := Value;
  11456.   if FHotImages <> nil then
  11457.     FHotImages.RegisterChanges(FHotImageChangeLink)
  11458.   else
  11459.     SetHotImageList(0);
  11460.   RecreateButtons;
  11461. end;
  11462.  
  11463. procedure TToolBar.SetIndent(Value: Integer);
  11464. begin
  11465.   if FIndent <> Value then
  11466.   begin
  11467.     FIndent := Value;
  11468.     RecreateWnd;
  11469.   end;
  11470. end;
  11471.  
  11472. procedure TToolBar.RecreateButtons;
  11473. begin
  11474.   if not (csLoading in ComponentState) or HandleAllocated then
  11475.   begin
  11476.     CreateButtons(FButtonWidth, FButtonHeight);
  11477.     ResizeButtons;
  11478.   end;
  11479. end;
  11480.  
  11481. procedure TToolBar.GetChildren(Proc: TGetChildProc; Root: TComponent);
  11482. var
  11483.   I: Integer;
  11484.   Control: TControl;
  11485. begin
  11486.   for I := 0 to FButtons.Count - 1 do Proc(TComponent(FButtons[I]));
  11487.   for I := 0 to ControlCount - 1 do
  11488.   begin
  11489.     Control := Controls[I];
  11490.     if (Control.Owner = Root) and (FButtons.IndexOf(Control) = -1) then Proc(Control);
  11491.   end;
  11492. end;
  11493.  
  11494. procedure TToolBar.Loaded;
  11495. begin
  11496.   inherited Loaded;
  11497.   ResizeButtons;
  11498.   RepositionButtons(0);
  11499.   AdjustSize;
  11500. end;
  11501.  
  11502. procedure TToolBar.BeginUpdate;
  11503. begin
  11504.   Inc(FUpdateCount);
  11505. end;
  11506.  
  11507. procedure TToolBar.EndUpdate;
  11508. begin
  11509.   Dec(FUpdateCount);
  11510. end;
  11511.  
  11512. procedure TToolBar.ResizeButtons;
  11513. begin
  11514.   if Wrapable and not (csLoading in ComponentState) and HandleAllocated then
  11515.   begin
  11516.     Perform(TB_AUTOSIZE, 0, 0);
  11517.     if AutoSize then AdjustSize;
  11518.   end;
  11519. end;
  11520.  
  11521. function TToolBar.InternalButtonCount: Integer;
  11522. begin
  11523.   Result := Perform(TB_BUTTONCOUNT, 0, 0);
  11524. end;
  11525.  
  11526. function TToolBar.ButtonIndex(OldIndex, ALeft, ATop: Integer): Integer;
  11527. var
  11528.   Dist, Tmp, Head, Tail: Integer;
  11529.   Control: TControl;
  11530. begin
  11531.   if FButtons.Count <= 1 then
  11532.   begin
  11533.     Result := OldIndex;
  11534.     Exit;
  11535.   end;
  11536.   { Find row closest to ATop }
  11537.   Tmp := 0;
  11538.   Head := 0;
  11539.   Tail := 0;
  11540.   Result := 0;
  11541.   Dist := MaxInt;
  11542.   while (Dist > 0) and (Result < FButtons.Count) do
  11543.   begin
  11544.     Control := TControl(FButtons[Result]);
  11545.     if (Control is TToolButton) and TToolButton(Control).Wrap or
  11546.       (Result = FButtons.Count - 1) then
  11547.     begin
  11548.       if Abs(ATop - Control.Top) < Dist then
  11549.       begin
  11550.         Dist := Abs(ATop - Control.Top);
  11551.         Head := Tmp;
  11552.         Tail := Result;
  11553.       end;
  11554.       Tmp := Result + 1;
  11555.     end;
  11556.     Inc(Result);
  11557.   end;
  11558.   { Find button on Row closest to ALeft }
  11559.   for Result := Head to Tail do
  11560.     if (Result <> OldIndex) and (ALeft <= TControl(FButtons[Result]).Left) then
  11561.       Break;
  11562.   { Return old position if new position is last on the row and old position
  11563.     was already the last on the row. }
  11564.   if (Result = OldIndex + 1) and (OldIndex in [Head..Tail]) then
  11565.     Result := OldIndex;
  11566. end;
  11567.  
  11568. function TToolBar.ReorderButton(OldIndex, ALeft, ATop: Integer): Boolean;
  11569. var
  11570.   NewIndex: Integer;
  11571.   Control: TControl;
  11572. begin
  11573.   Result := False;
  11574.   NewIndex := ButtonIndex(OldIndex, ALeft, ATop);
  11575.   if NewIndex <> OldIndex then
  11576.   begin
  11577.     { If we are inserting to the right of our deletion then account for shift }
  11578.     if OldIndex < NewIndex then Dec(NewIndex);
  11579.     Control := FButtons[OldIndex];
  11580.     FButtons.Delete(OldIndex);
  11581.     FButtons.Insert(NewIndex, Control);
  11582.     BeginUpdate;
  11583.     try
  11584.       Perform(TB_DELETEBUTTON, OldIndex, 0);
  11585.       UpdateItem(TB_INSERTBUTTON, NewIndex, NewIndex);
  11586.     finally
  11587.       EndUpdate;
  11588.     end;
  11589.     Result := True;
  11590.   end;
  11591. end;
  11592.  
  11593. procedure TToolBar.AdjustControl(Control: TControl);
  11594. var
  11595.   I, Pos: Integer;
  11596.   R: TRect;
  11597.   Reordered, NeedsUpdate: Boolean;
  11598. begin
  11599.   Pos := FButtons.IndexOf(Control);
  11600.   if Pos = -1 then Exit;
  11601.   Reordered := ReorderButton(Pos, Control.Left, Control.Top);
  11602.   NeedsUpdate := False;
  11603.   if Reordered then
  11604.   begin
  11605.     I := FButtons.IndexOf(Control);
  11606.     if I < Pos then Pos := I;
  11607.   end
  11608.   else if Perform(TB_GETITEMRECT, Pos, Longint(@R)) <> 0 then
  11609.   begin
  11610.     NeedsUpdate := Control.Width <> R.Right - R.Left;
  11611.     Reordered := NeedsUpdate;
  11612.   end;
  11613.   if (csDesigning in ComponentState) and (Control.Height <> ButtonHeight) then
  11614.     ButtonHeight := Control.Height
  11615.   else
  11616.     if Reordered then
  11617.     begin
  11618.       if NeedsUpdate then UpdateButton(Pos);
  11619.       ResizeButtons;
  11620.       RepositionButtons(0);
  11621.     end
  11622.     else
  11623.       RepositionButton(Pos);
  11624. end;
  11625.  
  11626. procedure TToolBar.AlignControls(AControl: TControl; var Rect: TRect);
  11627. begin
  11628.   if FUpdateCount > 0 then Exit;
  11629.   if Assigned(AControl) and not (AControl is TToolButton) then
  11630.     AdjustControl(AControl);
  11631. end;
  11632.  
  11633. procedure TToolBar.WMEraseBkgnd(var Message: TWMEraseBkgnd);
  11634. begin
  11635.   DefaultHandler(Message);
  11636. end;
  11637.  
  11638. procedure TToolBar.WMNotifyFormat(var Message: TMessage);
  11639. begin
  11640.   with Message do
  11641.     Result := DefWindowProc(Handle, Msg, WParam, LParam);
  11642. end;
  11643.  
  11644. procedure TToolBar.WMSize(var Message: TWMSize);
  11645. begin
  11646.   inherited;
  11647.   if not (csLoading in ComponentState) then Resize;
  11648. end;
  11649.  
  11650. procedure TToolBar.WMWindowPosChanged(var Message: TWMWindowPosChanged);
  11651. begin
  11652.   inherited;
  11653. end;
  11654.  
  11655. procedure TToolBar.WMWindowPosChanging(var Message: TWMWindowPosChanging);
  11656. const
  11657.   BackgroundValid = SWP_NOSIZE or SWP_NOMOVE;
  11658.   IndexMask = $7FFFFFFF;
  11659. var
  11660.   Index, NcX, NcY: Integer;
  11661.   Vertical, Resized: Boolean;
  11662.   PrevSize, CurrSize: TPoint;
  11663.   R: TRect;
  11664.  
  11665.   function WrapButtons(CX: Integer): Integer;
  11666.   var
  11667.     I, J, X: Integer;
  11668.     Control: TControl;
  11669.     Found: Boolean;
  11670.   begin
  11671.     Result := 1;
  11672.     X := Indent;
  11673.     I := 0;
  11674.     while I < FButtons.Count do
  11675.     begin
  11676.       Control := TControl(FButtons[I]);
  11677.       if Control is TToolButton then
  11678.         TToolButton(Control).FWrap := False;
  11679.       if (csDesigning in ComponentState) or Control.Visible then
  11680.       begin
  11681.         if X + Control.Width > CX then
  11682.         begin
  11683.           Found := False;
  11684.           for J := I downto 0 do
  11685.             if TControl(FButtons[J]) is TToolButton then
  11686.               with TToolButton(FButtons[J]) do
  11687.                 if ((csDesigning in ComponentState) or Visible) and
  11688.                   (Style in [tbsSeparator, tbsDivider]) then
  11689.                 begin
  11690.                   if not FWrap then
  11691.                   begin
  11692.                     Found := True;
  11693.                     I := J;
  11694.                     X := Indent;
  11695.                     FWrap := True;
  11696.                     Inc(Result);
  11697.                   end;
  11698.                   Break;
  11699.                 end;
  11700.           if not Found then
  11701.           begin
  11702.             for J := I - 1 downto 0 do
  11703.               if TControl(FButtons[J]) is TToolButton then
  11704.                 with TToolButton(FButtons[J]) do
  11705.                   if (csDesigning in ComponentState) or Visible then
  11706.                   begin
  11707.                     if not FWrap then
  11708.                     begin
  11709.                       Found := True;
  11710.                       I := J;
  11711.                       X := Indent;
  11712.                       FWrap := True;
  11713.                       Inc(Result);
  11714.                     end;
  11715.                     Break;
  11716.                   end;
  11717.             if not Found then
  11718.               Inc(X, Control.Width);
  11719.           end;
  11720.         end
  11721.         else
  11722.           Inc(X, Control.Width);
  11723.       end;
  11724.       Inc(I);
  11725.     end;
  11726.   end;
  11727.  
  11728.   procedure CalcSize(var CX, CY: Integer);
  11729.   var
  11730.     IsWrapped: Boolean;
  11731.     I, Tmp, X, Y: Integer;
  11732.     Control: TControl;
  11733.   begin
  11734.     CX := 0;
  11735.     CY := 0;
  11736.     X := Indent;
  11737.     Y := 0;
  11738.     for I := 0 to FButtons.Count - 1 do
  11739.     begin
  11740.       Control := TControl(FButtons[I]);
  11741.       if (csDesigning in ComponentState) or Control.Visible then
  11742.       begin
  11743.         IsWrapped := (Control is TToolButton) and (TToolButton(Control).Wrap);
  11744.         if Control is TToolButton and
  11745.           (TToolButton(Control).Style in [tbsSeparator, tbsDivider]) then
  11746.         begin
  11747.           if I < FButtons.Count - 1 then
  11748.             if IsWrapped then
  11749.             begin
  11750.               Tmp := Y + Control.Height + Control.Width * 2 div 3;
  11751.               if Tmp > CY then
  11752.                 CY := Tmp;
  11753.             end
  11754.             else
  11755.             begin
  11756.               Tmp := X + Control.Width;
  11757.               if Tmp > CX then
  11758.                 CX := Tmp;
  11759.             end
  11760.         end
  11761.         else
  11762.         begin
  11763.           Tmp := X + Control.Width;
  11764.           if Tmp > CX then
  11765.             CX := Tmp;
  11766.           Tmp := Y + Control.Height;
  11767.           if Tmp > CY then
  11768.             CY := Tmp;
  11769.         end;
  11770.         if IsWrapped then
  11771.         begin
  11772.           X := Indent;
  11773.           Inc(Y, Control.Height);
  11774.           if TToolButton(Control).Style in [tbsSeparator, tbsDivider] then
  11775.             Inc(Y, Control.Width * 2 div 3);
  11776.         end
  11777.         else
  11778.           Inc(X, Control.Width);
  11779.       end;
  11780.     end;
  11781.     { Adjust for 2 pixel top margin when not flat style buttons }
  11782.     if (CY > 0) and not Flat then Inc(CY, 2);
  11783.   end;
  11784.  
  11785.   function WrapSizeVert(var CX, CY: Integer): Integer;
  11786.   var
  11787.     HorzSize, VertSize, Size: TPoint;
  11788.   begin
  11789.     Result := 0;
  11790.     WrapButtons(0);
  11791.     CalcSize(VertSize.X, VertSize.Y);
  11792.     WrapButtons(MaxInt);
  11793.     CalcSize(HorzSize.X, HorzSize.Y);
  11794.     while VertSize.X < HorzSize.X do
  11795.     begin
  11796.       Size.X := (VertSize.X + HorzSize.X) div 2;
  11797.       Result := WrapButtons(Size.X);
  11798.       CalcSize(Size.X, Size.Y);
  11799.       if CY < Size.Y then
  11800.       begin
  11801.         if (VertSize.X = Size.X) and (VertSize.Y = Size.Y) then
  11802.         begin
  11803.           Result := WrapButtons(HorzSize.X);
  11804.           Break;
  11805.         end;
  11806.         VertSize := Size;
  11807.       end
  11808.       else if CY > Size.Y then
  11809.         HorzSize := Size
  11810.       else
  11811.         Break;
  11812.     end;
  11813.   end;
  11814.  
  11815.   function WrapSizeHorz(var CX, CY: Integer): Integer;
  11816.   var
  11817.     HorzRows, VertRows, Min, Mid, Max: Integer;
  11818.     HorzSize: TPoint;
  11819.   begin
  11820.     Result := 0;
  11821.     Min := 0;
  11822.     Max := CX;
  11823.     HorzRows := WrapButtons(Max);
  11824.     VertRows := WrapButtons(0);
  11825.     if HorzRows <> VertRows then
  11826.       while Min < Max do
  11827.       begin
  11828.         Mid := (Min + Max) div 2;
  11829.         VertRows := WrapButtons(Mid);
  11830.         if VertRows = HorzRows then
  11831.           Max := Mid
  11832.         else
  11833.         begin
  11834.           if Min = Mid then
  11835.           begin
  11836.             WrapButtons(Max);
  11837.             Break;
  11838.           end;
  11839.           Min := Mid;
  11840.         end;
  11841.       end;
  11842.     CalcSize(HorzSize.X, HorzSize.Y);
  11843.     WrapButtons(HorzSize.X);
  11844.   end;
  11845.  
  11846. begin
  11847.   { Invalidate old background when toolbar is flat and is about to be moved }
  11848.   if Flat and (Message.WindowPos^.flags and BackgroundValid <> BackgroundValid) and
  11849.     Assigned(Parent) and Parent.HandleAllocated then
  11850.   begin
  11851.     R := BoundsRect;
  11852.     InvalidateRect(Parent.Handle, @R, True);
  11853.   end;
  11854.   if HandleAllocated then
  11855.   begin
  11856.     Index := InternalButtonCount - 1;
  11857.     if ((Index >= 0) or not (csDesigning in ComponentState)) and
  11858.       (Message.WindowPos^.flags and SWP_NOSIZE = 0) then
  11859.     begin
  11860.       PrevSize.X := ClientWidth;
  11861.       PrevSize.Y := ClientHeight;
  11862.       { Calculate non-client border size }
  11863.       NcX := Width - PrevSize.X;
  11864.       NcY := Height - PrevSize.Y;
  11865.       { Remember previous size for comparison }
  11866.       R.BottomRight := PrevSize;
  11867.       CalcSize(PrevSize.X, PrevSize.Y);
  11868.       { Get current window size minus the non-client borders }
  11869.       with Message.WindowPos^ do
  11870.         CurrSize := Point(cx - NcX, cy - NcY);
  11871.       { Decide best way to calculate layout }
  11872.       if Align <> alNone then
  11873.         Vertical := Align in [alLeft, alRight]
  11874.       else
  11875.         Vertical := Abs(CurrSize.X - R.Right) < Abs(CurrSize.Y - R.Bottom);
  11876.       if Wrapable then
  11877.       begin
  11878.         if Vertical then
  11879.           WrapSizeVert(CurrSize.X, CurrSize.Y)
  11880.         else
  11881.           WrapSizeHorz(CurrSize.X, CurrSize.Y);
  11882.         { CurrSize now has optimium dimensions }
  11883.         CalcSize(CurrSize.X, CurrSize.Y);
  11884.         Resized := (Vertical or (Align = alNone)) and (CurrSize.X <> PrevSize.X) or
  11885.           (CurrSize.Y <> PrevSize.Y);
  11886.         if Resized then
  11887.           { Enforce changes to Wrap property }
  11888.           UpdateButtons
  11889.         else
  11890.           { Overwrite any changes to buttons' Wrap property }
  11891.           UpdateButtonStates;
  11892.       end
  11893.       else
  11894.       begin
  11895.         { CurrSize now has optimium dimensions }
  11896.         CalcSize(CurrSize.X, CurrSize.Y);
  11897.         Resized := (Vertical or (Align = alNone)) and (CurrSize.X <> PrevSize.X) or
  11898.           (CurrSize.Y <> PrevSize.Y);
  11899.       end;
  11900.       if AutoSize and (Align <> alClient) then
  11901.         with Message.WindowPos^ do
  11902.         begin
  11903.           if Vertical or (Align = alNone) then
  11904.             cx := CurrSize.X + NcX;
  11905.           if not Vertical or (Align = alNone) then
  11906.             cy := CurrSize.Y + NcY;
  11907.           if Resized then PostMessage(Handle, CN_REQUESTALIGN, 0, 0);
  11908.         end;
  11909.     end;
  11910.   end;
  11911.   inherited;
  11912. end;
  11913.  
  11914. procedure TToolBar.WndProc(var Message: TMessage);
  11915. var
  11916.   Control: TControl;
  11917.   CapControl: TControl;
  11918.  
  11919.   function IsToolButtonMouseMsg(var Message: TWMMouse): Boolean;
  11920.   begin
  11921.     if GetCapture = Handle then
  11922.     begin
  11923.       CapControl := GetCaptureControl;
  11924.       if Assigned(CapControl) and (CapControl.Parent <> Self) then
  11925.         CapControl := nil;
  11926.     end;
  11927.     Control := ControlAtPos(SmallPointToPoint(Message.Pos), False);
  11928.     Result := Assigned(Control) and (Control is TToolButton) and
  11929.       not Control.Dragging;
  11930.   end;
  11931.  
  11932.   procedure DialogChar(Button: TToolButton);
  11933.   begin
  11934.     with TCMDialogChar(Message) do
  11935.       if IsAccel(CharCode, Button.Caption) and Button.Enabled then
  11936.       begin
  11937.         Button.Click;
  11938.         Result := 1;
  11939.       end;
  11940.   end;
  11941.  
  11942.   procedure BroadcastDialogChar;
  11943.   var
  11944.     I: Integer;
  11945.   begin
  11946.     for I := 0 to FButtons.Count - 1 do
  11947.       if TControl(FButtons[I]) is TToolButton then
  11948.       begin
  11949.         DialogChar(TToolButton(FButtons[I]));
  11950.         if TMessage(Message).Result <> 0 then Exit;
  11951.       end;
  11952.   end;
  11953.  
  11954. begin
  11955.   if not (csDesigning in ComponentState) then
  11956.     case Message.Msg of
  11957.       WM_MOUSEMOVE:
  11958.         if Flat then
  11959.         begin
  11960.           { Default hit-test for flat style buttons in toolbar is off by 1
  11961.             pixel in x and y. Adjust here so that default painting will occur
  11962.             for tool buttons. }
  11963.           Inc(Message.LParamLo);
  11964.           Inc(Message.LParamHi);
  11965.           DefaultHandler(Message);
  11966.           Dec(Message.LParamLo);
  11967.           Dec(Message.LParamHi);
  11968.         end
  11969.         else DefaultHandler(Message);
  11970.       WM_LBUTTONUP:
  11971.         if IsToolButtonMouseMsg(TWMMouse(Message)) and (CapControl = Control) then
  11972.         begin
  11973.           DefaultHandler(Message);
  11974.           with TToolButton(Control) do
  11975.             if Down and Grouped and AllowAllUp and (Style = tbsCheck) then
  11976.               Down := False;
  11977.           UpdateButtonStates;
  11978.         end;
  11979.       WM_LBUTTONDOWN, WM_LBUTTONDBLCLK:
  11980.         if IsToolButtonMouseMsg(TWMMouse(Message)) then
  11981.         begin
  11982.           inherited WndProc(Message);
  11983.           if not Control.Dragging then
  11984.           begin
  11985.             DefaultHandler(Message);
  11986.             if TToolButton(Control).CheckMenuDropDown then
  11987.             begin
  11988.               Message.Msg := WM_LBUTTONUP;
  11989.               DefaultHandler(Message);
  11990.               inherited WndProc(Message);
  11991.             end;
  11992.           end;
  11993.           Exit;
  11994.         end;
  11995.       CM_DIALOGCHAR: BroadcastDialogChar;
  11996.     end;
  11997.   inherited WndProc(Message);
  11998. end;
  11999.  
  12000. procedure TToolBar.CMControlChange(var Message: TCMControlChange);
  12001. begin
  12002.   with Message do
  12003.     if Inserting then
  12004.       InsertButton(Control)
  12005.     else
  12006.       RemoveButton(Control);
  12007. end;
  12008.  
  12009. procedure TToolBar.CMEnabledChanged(var Message: TMessage);
  12010. begin
  12011.   inherited;
  12012.   Broadcast(Message);
  12013. end;
  12014.  
  12015. procedure TToolBar.CMColorChanged(var Message: TMessage);
  12016. begin
  12017.   inherited;
  12018.   RecreateWnd;
  12019. end;
  12020.  
  12021. procedure TToolBar.CMSysFontChanged(var Message: TMessage);
  12022. begin
  12023.   inherited;
  12024.   RecreateWnd;
  12025. end;
  12026.  
  12027. procedure TToolBar.CNRequestAlign(var Message: TMessage);
  12028. begin
  12029.   RequestAlign;
  12030. end;
  12031.  
  12032. { TCoolBand }
  12033.  
  12034. constructor TCoolBand.Create(Collection: TCollection);
  12035. begin
  12036.   FWidth := 40;
  12037.   FBreak := True;
  12038.   FColor := clBtnFace;
  12039.   FFixedBackground := True;
  12040.   FImageIndex := -1;
  12041.   FMinHeight := 25;
  12042.   FParentColor := True;
  12043.   FParentBitmap := True;
  12044.   FBitmap := TBitmap.Create;
  12045.   FBitmap.OnChange := BitmapChanged;
  12046.   FVisible := True;
  12047.   FDDB := TBitmap.Create;
  12048.   inherited Create(Collection);
  12049.   ParentColorChanged;
  12050.   ParentBitmapChanged;
  12051. end;
  12052.  
  12053. destructor TCoolBand.Destroy;
  12054. var
  12055.   AControl: TWinControl;
  12056. begin
  12057.   FDDB.Free;
  12058.   FBitmap.Free;
  12059.   AControl := Control;
  12060.   FControl := nil;
  12061.   inherited Destroy;
  12062.   if Assigned(AControl) and not (csDestroying in AControl.ComponentState) and
  12063.     AControl.HandleAllocated then
  12064.   begin
  12065.     AControl.BringToFront;
  12066.     AControl.Perform(CM_SHOWINGCHANGED, 0, 0);
  12067.   end;
  12068. end;
  12069.  
  12070. procedure TCoolBand.Assign(Source: TPersistent);
  12071.  
  12072.   function FindControl(AControl: TWinControl): TWinControl;
  12073.   begin
  12074.     if Assigned(AControl) then
  12075.       Result := CoolBar.Owner.FindComponent(AControl.Name) as TWinControl
  12076.     else 
  12077.       Result := nil;
  12078.   end;
  12079.  
  12080. begin
  12081.   if Source is TCoolBand then
  12082.   begin
  12083.     Bitmap := TCoolBand(Source).Bitmap;
  12084.     Break := TCoolBand(Source).Break;
  12085.     Color := TCoolBand(Source).Color;
  12086.     FixedBackground := TCoolBand(Source).FixedBackground;
  12087.     FixedSize := TCoolBand(Source).FixedSize;
  12088.     HorizontalOnly := TCoolBand(Source).HorizontalOnly;
  12089.     ImageIndex := TCoolBand(Source).ImageIndex;
  12090.     MinHeight := TCoolBand(Source).MinHeight;
  12091.     MinWidth := TCoolBand(Source).MinWidth;
  12092.     ParentBitmap := TCoolBand(Source).ParentBitmap;
  12093.     ParentColor := TCoolBand(Source).ParentColor;
  12094.     Text := TCoolBand(Source).Text;
  12095.     Visible := TCoolBand(Source).Visible;
  12096.     Width := TCoolBand(Source).Width;
  12097.     Control := FindControl(TCoolBand(Source).Control);
  12098.   end
  12099.   else inherited Assign(Source);
  12100. end;
  12101.  
  12102. function TCoolBand.GetDisplayName: string;
  12103. begin
  12104.   Result := FText;
  12105.   if Result = '' then Result := inherited GetDisplayName;
  12106. end;
  12107.  
  12108. function TCoolBand.GetVisible: Boolean;
  12109. begin
  12110.   Result := FVisible and (not CoolBar.Vertical or not FHorizontalOnly);
  12111. end;
  12112.  
  12113. function TCoolBand.CoolBar: TCoolBar;
  12114. begin
  12115.   Result := TCoolBands(Collection).FCoolBar;
  12116. end;
  12117.  
  12118. procedure TCoolBand.ParentColorChanged;
  12119. begin
  12120.   if FParentColor then
  12121.   begin
  12122.     SetColor(CoolBar.Color);
  12123.     FParentColor := True;
  12124.   end;
  12125. end;
  12126.  
  12127. procedure TCoolBand.ParentBitmapChanged;
  12128. begin
  12129.   BitmapChanged(Self);
  12130. end;
  12131.  
  12132. procedure TCoolBand.BitmapChanged(Sender: TObject);
  12133. begin
  12134.   if not ParentBitmap then
  12135.   begin
  12136.     FDDB.Assign(FBitmap);
  12137.     if not FDDB.Empty then FDDB.HandleType := bmDDB;
  12138.   end
  12139.   else
  12140.     FDDB.Assign(nil);
  12141.   Changed(False);
  12142. end;
  12143.  
  12144. procedure TCoolBand.SetBitmap(Value: TBitmap);
  12145. begin
  12146.   FParentBitmap := False;
  12147.   FBitmap.Assign(Value);
  12148.   Changed(True);
  12149. end;
  12150.  
  12151. function TCoolBand.GetHeight: Integer;
  12152. begin
  12153.   Result := CoolBar.GetRowHeight(Index);
  12154. end;
  12155.  
  12156. procedure TCoolBand.SetBorderStyle(Value: TBorderStyle);
  12157. begin
  12158.   if FBorderStyle <> Value then
  12159.   begin
  12160.     FBorderStyle := Value;
  12161.     Changed(False);
  12162.   end;
  12163. end;
  12164.  
  12165. procedure TCoolBand.SetBreak(Value: Boolean);
  12166. begin
  12167.   if FBreak <> Value then
  12168.   begin
  12169.     FBreak := Value;
  12170.     Changed(False);
  12171.   end;
  12172. end;
  12173.  
  12174. procedure TCoolBand.SetFixedSize(Value: Boolean);
  12175. begin
  12176.   if FFixedSize <> Value then
  12177.   begin
  12178.     if Value then
  12179.     begin
  12180.       FBreak := False;
  12181.       FFixedSize := True;
  12182.       Changed(True);
  12183.     end
  12184.     else
  12185.     begin
  12186.       FFixedSize := False;
  12187.       Changed(False);
  12188.     end;
  12189.   end;
  12190. end;
  12191.  
  12192. procedure TCoolBand.SetMinHeight(Value: Integer);
  12193. begin
  12194.   if FMinHeight <> Value then
  12195.   begin
  12196.     FMinHeight := Value;
  12197.     Changed(False);
  12198.   end;
  12199. end;
  12200.  
  12201. procedure TCoolBand.SetMinWidth(Value: Integer);
  12202. begin
  12203.   if FMinWidth <> Value then
  12204.   begin
  12205.     FMinWidth := Value;
  12206.     Changed(FixedSize);
  12207.   end;
  12208. end;
  12209.  
  12210. procedure TCoolBand.SetVisible(Value: Boolean);
  12211. begin
  12212.   if FVisible <> Value then
  12213.   begin
  12214.     FVisible := Value;
  12215.     Changed(True);
  12216.   end;
  12217. end;
  12218.  
  12219. procedure TCoolBand.SetHorizontalOnly(Value: Boolean);
  12220. begin
  12221.   if FHorizontalOnly <> Value then
  12222.   begin
  12223.     FHorizontalOnly := Value;
  12224.     Changed(CoolBar.Vertical);
  12225.   end;
  12226. end;
  12227.  
  12228. procedure TCoolBand.SetImageIndex(Value: Integer);
  12229. begin
  12230.   if FImageIndex <> Value then
  12231.   begin
  12232.     FImageIndex := Value;
  12233.     Changed(False);
  12234.   end;
  12235. end;
  12236.  
  12237. procedure TCoolBand.SetFixedBackground(Value: Boolean);
  12238. begin
  12239.   if FFixedBackground <> Value then
  12240.   begin
  12241.     FFixedBackground := Value;
  12242.     Changed(False);
  12243.   end;
  12244. end;
  12245.  
  12246. procedure TCoolBand.SetColor(Value: TColor);
  12247. begin
  12248.   if FColor <> Value then
  12249.   begin
  12250.     FColor := Value;
  12251.     FParentColor := False;
  12252.     Changed(False);
  12253.   end;
  12254. end;
  12255.  
  12256. procedure TCoolBand.SetControl(Value: TWinControl);
  12257. var
  12258.   Band: TCoolBand;
  12259.   PrevControl: TWinControl;
  12260. begin
  12261.   if FControl <> Value then
  12262.   begin
  12263.     if Assigned(Value) then
  12264.     begin
  12265.       Band := TCoolBands(Collection).FindBand(Value);
  12266.       if Assigned(Band) and (Band <> Self) then Band.SetControl(nil);
  12267.     end;
  12268.     PrevControl := FControl;
  12269.     FControl := Value;
  12270.     Changed(True);
  12271.     if Assigned(PrevControl) then PrevControl.Perform(CM_SHOWINGCHANGED, 0, 0);
  12272.   end;
  12273. end;
  12274.  
  12275. procedure TCoolBand.SetText(const Value: string);
  12276. begin
  12277.   if FText <> Value then
  12278.   begin
  12279.     FText := Value;
  12280.     Changed(True);
  12281.   end;
  12282. end;
  12283.  
  12284. function TCoolBand.IsColorStored: Boolean;
  12285. begin
  12286.   Result := not ParentColor;
  12287. end;
  12288.  
  12289. procedure TCoolBand.SetParentColor(Value: Boolean);
  12290. begin
  12291.   if FParentColor <> Value then
  12292.   begin
  12293.     FParentColor := Value;
  12294.     Changed(False);
  12295.   end;
  12296. end;
  12297.  
  12298. function TCoolBand.IsBitmapStored: Boolean;
  12299. begin
  12300.   Result := not ParentBitmap;
  12301. end;
  12302.  
  12303. procedure TCoolBand.SetParentBitmap(Value: Boolean);
  12304. begin
  12305.   if FParentBitmap <> Value then
  12306.   begin
  12307.     FParentBitmap := Value;
  12308.     ParentBitmapChanged;
  12309.   end;
  12310. end;
  12311.  
  12312. procedure TCoolBand.SetWidth(Value: Integer);
  12313. begin
  12314.   if FWidth <> Value then
  12315.   begin
  12316.     FWidth := Value;
  12317.     Changed(False);
  12318.   end;
  12319. end;
  12320.  
  12321. { TCoolBands }
  12322.  
  12323. constructor TCoolBands.Create(CoolBar: TCoolBar);
  12324. begin
  12325.   inherited Create(TCoolBand);
  12326.   FCoolBar := CoolBar;
  12327. end;
  12328.  
  12329. function TCoolBands.Add: TCoolBand;
  12330. begin
  12331.   Result := TCoolBand(inherited Add);
  12332. end;
  12333.  
  12334. function TCoolBands.FindBand(AControl: TControl): TCoolBand;
  12335. var
  12336.   I: Integer;
  12337. begin
  12338.   for I := 0 to Count - 1 do
  12339.   begin
  12340.     Result := TCoolBand(inherited GetItem(I));
  12341.     if Result.FControl = AControl then Exit;
  12342.   end;
  12343.   Result := nil;
  12344. end;
  12345.  
  12346. function TCoolBands.HaveGraphic: Boolean;
  12347. var
  12348.   I: Integer;
  12349. begin
  12350.   Result := False;
  12351.   for I := 0 to Count - 1 do
  12352.     if not Items[I].FDDB.Empty then
  12353.     begin
  12354.       Result := True;
  12355.       Exit;
  12356.     end;
  12357. end;
  12358.  
  12359. function TCoolBands.GetItem(Index: Integer): TCoolBand;
  12360. begin
  12361.   Result := TCoolBand(inherited GetItem(Index));
  12362. end;
  12363.  
  12364. function TCoolBands.GetOwner: TPersistent;
  12365. begin
  12366.   Result := FCoolBar;
  12367. end;
  12368.  
  12369. procedure TCoolBands.SetItem(Index: Integer; Value: TCoolBand);
  12370. begin
  12371.   inherited SetItem(Index, Value);
  12372. end;
  12373.  
  12374. procedure TCoolBands.Update(Item: TCollectionItem);
  12375. begin
  12376.   if (Item <> nil) then
  12377.     FCoolBar.UpdateBand(Item.Index)
  12378.   else
  12379.     FCoolBar.UpdateBands;
  12380. end;
  12381.  
  12382. { TCoolBar }
  12383.  
  12384. const
  12385.   GripSize = 8;
  12386.   ControlMargin = 4;
  12387.   BandBorderSize = 2;
  12388.   IDMask = $7FFFFFFF;
  12389.   SoftBreakMask = $80000000;
  12390.   { Results for PtInGripRect }
  12391.   grNone = 0;
  12392.   grGrip = 1;
  12393.   grCaption = 2;
  12394.  
  12395. constructor TCoolBar.Create(AOwner: TComponent);
  12396. begin
  12397.   CheckCommonControl(ICC_COOL_CLASSES);
  12398.   inherited Create(AOwner);
  12399.   FComponentStyle := ComponentStyle - [csInheritable];
  12400.   ControlStyle := [csAcceptsControls, csCaptureMouse, csClickEvents, csOpaque,
  12401.     csDoubleClicks];
  12402.   Height := 75;
  12403.   Align := alTop;
  12404.   ParentColor := True;
  12405.   ParentFont := True;
  12406.   FBandBorderStyle := bsSingle;
  12407.   FBitmap := TBitmap.Create;
  12408.   FBitmap.OnChange := BitmapChanged;
  12409.   FCaptionFont := TFont.Create;
  12410.   FShowText := True;
  12411.   FDoubleBuffered := True;
  12412.   FDDB := TBitmap.Create;
  12413.   FBands := TCoolBands.Create(Self);
  12414.   FImageChangeLink := TChangeLink.Create;
  12415.   FImageChangeLink.OnChange := ImageListChange;
  12416. end;
  12417.  
  12418. destructor TCoolBar.Destroy;
  12419. begin
  12420.   FBands.Free;
  12421.   FImageChangeLink.Free;
  12422.   FDDB.Free;
  12423.   FCaptionFont.Free;
  12424.   FBitmap.Free;
  12425.   inherited Destroy;
  12426. end;
  12427.  
  12428. procedure TCoolBar.CreateParams(var Params: TCreateParams);
  12429. const
  12430.   DefaultStyles = CCS_NOPARENTALIGN or CCS_NOMOVEY or CCS_NORESIZE or CCS_NODIVIDER;
  12431.   BandBorderStyles: array[TBorderStyle] of Integer = (0, RBS_BANDBORDERS);
  12432.   FixedStyles: array[Boolean] of Integer = (0, RBS_FIXEDORDER);
  12433.   HeightStyles: array[Boolean] of Integer = (RBS_VARHEIGHT, 0);
  12434.   VerticalStyles: array[Boolean] of Integer = (0, CCS_VERT);
  12435. begin
  12436.   inherited CreateParams(Params);
  12437.   CreateSubClass(Params, REBARCLASSNAME);
  12438.   with Params do
  12439.   begin
  12440.     Style := Style or DefaultStyles or BandBorderStyles[FBandBorderStyle] or
  12441.       FixedStyles[FFixedOrder] or HeightStyles[FFixedSize] or
  12442.       VerticalStyles[FVertical];
  12443.     WindowClass.style := WindowClass.style and not (CS_HREDRAW or CS_VREDRAW) or
  12444.       CS_DBLCLKS;
  12445.   end;
  12446. end;
  12447.  
  12448. procedure TCoolBar.CreateWnd;
  12449. begin
  12450.   inherited CreateWnd;
  12451.   FCaptionFont.Handle := GetCaptionFont;
  12452.   FCaptionFontHeight := GetCaptionFontHeight;
  12453.   if not (csLoading in ComponentState) then UpdateBands;
  12454. end;
  12455.  
  12456. procedure TCoolBar.AdjustSize;
  12457. begin
  12458.   if not (csLoading in ComponentState) and HandleAllocated then
  12459.     Perform(WM_SIZE, SIZE_RESTORED, Word(ClientWidth) or Word(ClientHeight) shl 16);
  12460. end;
  12461.  
  12462. procedure TCoolBar.Loaded;
  12463. begin
  12464.   inherited Loaded;
  12465.   UpdateBands;
  12466.   AdjustSize;
  12467. end;
  12468.  
  12469. procedure TCoolBar.AlignControls(AControl: TControl; var Rect: TRect);
  12470. var
  12471.   Band: TCoolBand;
  12472.   NewWidth, NewMinHeight, CaptionSize, W, H: Integer;
  12473.   DoUpdate: Boolean;
  12474.  
  12475.   function IsBandCurrent: Boolean;
  12476.   var
  12477.     BandInfo: TReBarBandInfo;
  12478.   begin
  12479.     BandInfo.cbSize := SizeOf(TReBarBandInfo);
  12480.     BandInfo.fMask := RBBIM_CHILD;
  12481.     Result := TWinControl(AControl).HandleAllocated and
  12482.       (Perform(RB_GETBANDINFO, Band.FID and IDMask, Integer(@BandInfo)) <> 0) and
  12483.       (BandInfo.hwndChild = TWinControl(AControl).Handle);
  12484.   end;
  12485.  
  12486. begin
  12487.   if not (csDestroying in ComponentState) and (not Assigned(AControl) or
  12488.     (AControl is TWinControl)) and (FUpdateCount = 0) then
  12489.   begin
  12490.     { Refresh bands if any control changed }
  12491.     if Assigned(AControl) then
  12492.     begin
  12493.       ReadBands;
  12494.       Band := FBands.FindBand(AControl as TWinControl);
  12495.       if Assigned(Band) then
  12496.       begin
  12497.         BeginUpdate;
  12498.         try
  12499.           CaptionSize := GetCaptionSize(Band);
  12500.           if Vertical then
  12501.           begin
  12502.             W := AControl.Height;
  12503.             H := AControl.Width;
  12504.           end
  12505.           else
  12506.           begin
  12507.             W := AControl.Width;
  12508.             H := AControl.Height;
  12509.           end;
  12510.           NewWidth := W + CaptionSize + ControlMargin;
  12511.           NewMinHeight := H;
  12512.           if (NewWidth <> Band.Width) or (NewMinHeight <> Band.MinHeight) or
  12513.             not IsBandCurrent then
  12514.           begin
  12515.             DoUpdate := True;
  12516.             if Band.FixedSize or FixedOrder and (Band.FID and IDMask = 0) then
  12517.               Dec(NewWidth, ControlMargin);
  12518.             Band.Width := NewWidth;
  12519.             Band.MinHeight := NewMinHeight;
  12520.           end
  12521.           else DoUpdate := False;
  12522.         finally
  12523.           EndUpdate;
  12524.         end;
  12525.         if DoUpdate then
  12526.         begin
  12527.           Bands.Update(Band);
  12528.           ReadBands;
  12529.         end
  12530.         else AdjustSize;
  12531.       end;
  12532.     end;
  12533.   end;
  12534. end;
  12535.  
  12536. procedure TCoolBar.Change;
  12537. var
  12538.   Form: TCustomForm;
  12539. begin
  12540.   if csDesigning in ComponentState then
  12541.   begin
  12542.     Form := GetParentForm(Self);
  12543.     if (Form <> nil) and (Form.Designer <> nil) then Form.Designer.Modified;
  12544.   end;
  12545.   if Assigned(FOnChange) then FOnChange(Self);
  12546. end;
  12547.  
  12548. procedure TCoolBar.Resize;
  12549. begin
  12550.   if Assigned(FOnResize) then FOnResize(Self);
  12551. end;
  12552.  
  12553. function TCoolBar.GetAlign: TAlign;
  12554. begin
  12555.   Result := inherited Align;
  12556. end;
  12557.  
  12558. { Coolbars take their text font from Windows' caption font minus any bold
  12559.   characteristics it may have. }
  12560. function TCoolBar.GetCaptionFont: HFONT;
  12561. var
  12562.   NonClientMetrics: TNonClientMetrics;
  12563. begin
  12564.   with NonClientMetrics do
  12565.   begin
  12566.     cbSize := sizeof(TNonClientMetrics);
  12567.     if not SystemParametersInfo(SPI_GETNONCLIENTMETRICS, 0, @NonClientMetrics, 0) then
  12568.       GetObject(GetStockObject(SYSTEM_FONT), SizeOf(lfCaptionFont), @lfCaptionFont);
  12569.     { Remove any bold styles }
  12570.     lfCaptionFont.lfWeight := FW_NORMAL;
  12571.     Result := CreateFontIndirect(lfCaptionFont)
  12572.   end;
  12573. end;
  12574.  
  12575. function TCoolBar.GetCaptionFontHeight: Integer;
  12576. var
  12577.   TxtMetric: TTextMetric;
  12578. begin
  12579.   Result := 0;
  12580.   if HandleAllocated then
  12581.     with TControlCanvas.Create do
  12582.     try
  12583.       Control := Self;
  12584.       Font := FCaptionFont;
  12585.       if (GetTextMetrics(Handle, TxtMetric)) then
  12586.         Result := TxtMetric.tmHeight;
  12587.     finally
  12588.       Free;
  12589.     end;
  12590. end;
  12591.  
  12592. { Return height/width (depending on Vertical property) of coolbar grip area }
  12593. function TCoolBar.GetCaptionSize(Band: TCoolBand): Integer;
  12594. var
  12595.   Text: string;
  12596.   Adjust, DesignText: Boolean;
  12597. begin
  12598.   Result := 0;
  12599.   Adjust := False;
  12600.   if Assigned(Band) and ((csDesigning in ComponentState) or Band.Visible) then
  12601.   begin
  12602.     DesignText := (csDesigning in ComponentState) and
  12603.       not Assigned(Band.Control) and (Band.Text = '');
  12604.     if ShowText or DesignText then
  12605.     begin
  12606.       if DesignText then
  12607.         Text := Band.DisplayName
  12608.       else
  12609.         Text := Band.Text;
  12610.       if Text <> '' then
  12611.       begin
  12612.         Adjust := True;
  12613.         if Vertical then
  12614.           Result := FCaptionFontHeight
  12615.         else
  12616.           with TControlCanvas.Create do
  12617.           try
  12618.             Control := Self;
  12619.             Font := FCaptionFont;
  12620.             Result := TextWidth(Text)
  12621.           finally
  12622.             Free;
  12623.           end;
  12624.       end;
  12625.     end;
  12626.     if Band.ImageIndex >= 0 then
  12627.     begin
  12628.       if Adjust then Inc(Result, 2);
  12629.       if Assigned(FImages) then
  12630.       begin
  12631.         Adjust := True;
  12632.         if Vertical then
  12633.           Inc(Result, FImages.Height)
  12634.         else
  12635.           Inc(Result, FImages.Width)
  12636.       end
  12637.       else if not Adjust then
  12638.         Inc(Result, GripSize div 2);
  12639.     end;
  12640.     if Adjust then Inc(Result, GripSize div 2);
  12641.     if (not FixedOrder or (Band.FID and IDMask > 0)) and not Band.FixedSize then
  12642.       Inc(Result, GripSize + ControlMargin);
  12643.   end;
  12644. end;
  12645.  
  12646. procedure TCoolBar.SetAlign(Value: TAlign);
  12647. var
  12648.   PrevAlign, NewAlign: TAlign;
  12649. begin
  12650.   PrevAlign := inherited Align;
  12651.   inherited Align := Value;
  12652.   NewAlign := inherited Align;
  12653.   if NewAlign <> PrevAlign then
  12654.     case NewAlign of
  12655.       alLeft, alRight: Vertical := True;
  12656.       alTop, alBottom: Vertical := False;
  12657.     end;
  12658.   if IsAutoSized then AdjustSize;
  12659. end;
  12660.  
  12661. procedure TCoolBar.SetAutoSize(Value: Boolean);
  12662. begin
  12663.   if FAutoSize <> Value then
  12664.   begin
  12665.     FAutoSize := Value;
  12666.     if Value then AdjustSize;
  12667.   end;
  12668. end;
  12669.  
  12670. procedure TCoolBar.SetBands(Value: TCoolBands);
  12671. begin
  12672.   FBands.Assign(Value);
  12673. end;
  12674.  
  12675. procedure TCoolBar.SetBandBorderStyle(Value: TBorderStyle);
  12676. begin
  12677.   if FBandBorderStyle <> Value then
  12678.   begin
  12679.     FBandBorderStyle := Value;
  12680.     RecreateWnd;
  12681.   end;
  12682. end;
  12683.  
  12684. procedure TCoolBar.SetFixedSize(Value: Boolean);
  12685. begin
  12686.   if FFixedSize <> Value then
  12687.   begin
  12688.     FFixedSize := Value;
  12689.     RecreateWnd;
  12690.   end;
  12691. end;
  12692.  
  12693. procedure TCoolBar.SetFixedOrder(Value: Boolean);
  12694. begin
  12695.   if FFixedOrder <> Value then
  12696.   begin
  12697.     FFixedOrder := Value;
  12698.     RecreateWnd;
  12699.   end;
  12700. end;
  12701.  
  12702. procedure TCoolBar.ImageListChange(Sender: TObject);
  12703. begin
  12704.   if HandleAllocated and (Sender = Images) then
  12705.     SetImageList(Images.Handle);
  12706. end;
  12707.  
  12708. procedure TCoolBar.SetImageList(Value: HImageList);
  12709. var
  12710.   BarInfo: TReBarInfo;
  12711. begin
  12712.   if HandleAllocated then
  12713.   begin
  12714.     if Value = 0 then
  12715.       RecreateWnd
  12716.     else
  12717.     begin
  12718.       BarInfo.cbSize := SizeOf(TReBarInfo);
  12719.       BarInfo.fMask := RBIM_IMAGELIST;
  12720.       BarInfo.himl := Value;
  12721.       Perform(RB_SETBARINFO, 0, Integer(@BarInfo));
  12722.       Invalidate;
  12723.     end;
  12724.   end;
  12725. end;
  12726.  
  12727. procedure TCoolBar.SetImages(Value: TImageList);
  12728. begin
  12729.   if FImages <> nil then FImages.UnRegisterChanges(FImageChangeLink);
  12730.   FImages := Value;
  12731.   if FImages <> nil then
  12732.   begin
  12733.     FImages.RegisterChanges(FImageChangeLink);
  12734.     SetImageList(FImages.Handle);
  12735.   end
  12736.   else SetImageList(0);
  12737. end;
  12738.  
  12739. procedure TCoolBar.SetShowText(Value: Boolean);
  12740. begin
  12741.   if FShowText <> Value then
  12742.   begin
  12743.     FShowText := Value;
  12744.     if not (csLoading in ComponentState) then UpdateBands;
  12745.   end;
  12746. end;
  12747.  
  12748. procedure TCoolBar.Notification(AComponent: TComponent;
  12749.   Operation: TOperation);
  12750. var
  12751.   Band: TCoolBand;
  12752. begin
  12753.   inherited Notification(AComponent, Operation);
  12754.   if not (csDestroying in ComponentState) and (Operation = opRemove) then
  12755.   begin
  12756.     if (AComponent is TWinControl) then
  12757.     begin
  12758.       Band := Bands.FindBand(TControl(AComponent));
  12759.       if Assigned(Band) then Band.FControl := nil;
  12760.     end
  12761.     else if AComponent = FImages then Images := nil;
  12762.   end;
  12763. end;
  12764.  
  12765. function TCoolBar.GetPalette: HPALETTE;
  12766. begin
  12767.   if not FDDB.Empty then
  12768.     Result := FDDB.Palette
  12769.   else
  12770.     Result := inherited GetPalette;
  12771. end;
  12772.  
  12773. procedure TCoolBar.BitmapChanged(Sender: TObject);
  12774. var
  12775.   I: Integer;
  12776. begin
  12777.   FDDB.Assign(FBitmap);
  12778.   if not FDDB.Empty then FDDB.HandleType := bmDDB;
  12779.   for I := 0 to FBands.Count - 1 do Bands[I].ParentBitmapChanged;
  12780.   if HandleAllocated then
  12781.     RedrawWindow(Handle, nil, 0, RDW_INVALIDATE or RDW_ERASE or RDW_ALLCHILDREN);
  12782. end;
  12783.  
  12784. procedure TCoolBar.BeginUpdate;
  12785. begin
  12786.   Inc(FUpdateCount);
  12787. end;
  12788.  
  12789. procedure TCoolBar.EndUpdate;
  12790. begin
  12791.   Dec(FUpdateCount);
  12792. end;
  12793.  
  12794. function TCoolBar.IsAutoSized: Boolean;
  12795. begin
  12796.   Result := FAutoSize and ((FVertical and (Align in [alNone, alLeft, alRight])) or
  12797.     not FVertical and (Align in [alNone, alTop, alBottom]));
  12798. end;
  12799.  
  12800. function TCoolBar.IsBackgroundDirty: Boolean;
  12801. begin
  12802.   Result := HandleAllocated and not IsAutoSized;
  12803. end;
  12804.  
  12805. procedure TCoolBar.SetBitmap(Value: TBitmap);
  12806. begin
  12807.   FBitmap.Assign(Value);
  12808. end;
  12809.  
  12810. procedure TCoolBar.SetVertical(Value: Boolean);
  12811. begin
  12812.   if FVertical <> Value then
  12813.   begin
  12814.     FVertical := Value;
  12815.     RecreateWnd;
  12816.     if not (csLoading in ComponentState) then
  12817.     begin
  12818.       AdjustSize;
  12819.       if HandleAllocated then
  12820.         RedrawWindow(Handle, nil, 0, RDW_FRAME or RDW_ERASE or RDW_INVALIDATE);
  12821.     end;
  12822.   end;
  12823. end;
  12824.  
  12825. procedure TCoolBar.DisableBands;
  12826. var
  12827.   I: Integer;
  12828.   BandInfo: TReBarBandInfo;
  12829. begin
  12830.   if HandleAllocated then
  12831.   begin
  12832.     BandInfo.cbSize := SizeOf(TReBarBandInfo);
  12833.     BandInfo.fMask := RBBIM_CHILD;
  12834.     BandInfo.hwndChild := 0;
  12835.     for I := 0 to FBands.FVisibleCount - 1 do
  12836.       Perform(RB_SETBANDINFO, I, Integer(@BandInfo));
  12837.   end;
  12838. end;
  12839.  
  12840. function TCoolBar.UpdateItem(Message, FromIndex, ToIndex: Integer): Boolean;
  12841. const
  12842.   BorderStyles: array[TBorderStyle] of Integer = (0, RBBS_CHILDEDGE);
  12843.   BreakStyles: array[Boolean] of Integer = (0, RBBS_BREAK);
  12844.   FixedBmpStyles: array[Boolean] of Integer = (0, RBBS_FIXEDBMP);
  12845.   FixedSizeStyles: array[Boolean] of Integer = (0, RBBS_FIXEDSIZE);
  12846. var
  12847.   BandInfo: TReBarBandInfo;
  12848.   Band: TCoolBand;
  12849.   WasFocused, DesignText: Boolean;
  12850.   Text: string;
  12851. begin
  12852.   Result := False;
  12853.   if HandleAllocated then
  12854.   begin
  12855.     Band := Bands[FromIndex];
  12856.     { Make sure child control is properly parented by coolbar and visible
  12857.       according to band's visible property }
  12858.     if Assigned(Band.Control) then
  12859.       with Band.Control do
  12860.       begin
  12861.         WasFocused := Focused;
  12862.         BeginUpdate;
  12863.         try
  12864.           Parent := Self;
  12865.         finally
  12866.           EndUpdate;
  12867.         end;
  12868.         if not (csDesigning in Self.ComponentState) then
  12869.           Visible := Band.Visible;
  12870.       end
  12871.     else
  12872.       WasFocused := False;
  12873.     if not (csDesigning in ComponentState) and not Band.Visible then Exit;
  12874.     FillChar(BandInfo, SizeOf(BandInfo), 0);
  12875.     with BandInfo do
  12876.     begin
  12877.       cbSize := SizeOf(TReBarBandInfo);
  12878.       wID := Integer(Band);
  12879.       { Assign background color }
  12880.       if Band.ParentColor then
  12881.         clrBack := ColorToRGB(Color)
  12882.       else
  12883.         clrBack := ColorToRGB(Band.Color);
  12884.       { Assign basic styles }
  12885.       with Band do
  12886.         fStyle := BreakStyles[Break] or FixedSizeStyles[FixedSize] or
  12887.           BorderStyles[BorderStyle] or FixedBmpStyles[FixedBackground];
  12888.       fMask := RBBIM_STYLE or RBBIM_COLORS or RBBIM_SIZE or RBBIM_BACKGROUND or
  12889.          RBBIM_IMAGE or RBBIM_ID;
  12890.       { Assign background bitmap }
  12891.       if Band.ParentBitmap then
  12892.         hbmBack := FDDB.Handle
  12893.       else
  12894.         hbmBack := Band.FDDB.Handle;
  12895.       iImage := Band.ImageIndex;
  12896.       { Assign child control }
  12897.       if Assigned(Band.Control) and
  12898.         (Band.Control.Visible or (csDesigning in ComponentState)) then
  12899.         hwndChild := Band.Control.Handle;
  12900.       cx := Band.Width;
  12901.       { Assign minimum child width from child control's current width if band
  12902.         is fixed in size and a MinWidth value hasn't already been set }
  12903.       if Band.FixedSize and (Band.MinWidth <= 0) and Assigned(Band.Control) then
  12904.         if Vertical then
  12905.           cxMinChild := Band.Control.Height
  12906.         else
  12907.           cxMinChild := Band.Control.Width
  12908.       else
  12909.         cxMinChild := Band.MinWidth;
  12910.       cyMinChild := Band.MinHeight;
  12911.       fMask := fMask or RBBIM_CHILD or RBBIM_CHILDSIZE;
  12912.       { Assign text to band }
  12913.       DesignText := (csDesigning in ComponentState) and
  12914.         not Assigned(Band.Control) and (Band.Text = '');
  12915.       if ShowText or DesignText then
  12916.       begin
  12917.         if DesignText then
  12918.           Text := Band.DisplayName
  12919.         else
  12920.           Text := Band.Text;
  12921.         lpText := PChar(Text);
  12922.         fMask := fMask or RBBIM_TEXT;
  12923.       end;
  12924.     end;
  12925.     { Add/insert band }
  12926.     Result := Perform(Message, ToIndex, Integer(@BandInfo)) <> 0;
  12927.     { Update focus }
  12928.     if WasFocused then
  12929.       with Band.Control do
  12930.         if Handle <> 0 then Windows.SetFocus(Handle);
  12931.   end;
  12932. end;
  12933.  
  12934. function TCoolBar.ReadBands: Boolean;
  12935. var
  12936.   I, NewWidth, NewIndex: Integer;
  12937.   ClientSize, RowSize, BorderSize: Integer;
  12938.   BandInfo: TReBarBandInfo;
  12939.   NewBreak: Boolean;
  12940. begin
  12941.   Result := False;
  12942.   if HandleAllocated and (FUpdateCount = 0) then
  12943.   begin
  12944.     { Retrieve current band settings }
  12945.     BandInfo.cbSize := SizeOf(TReBarBandInfo);
  12946.     BandInfo.fMask := RBBIM_STYLE or RBBIM_SIZE or RBBIM_ID;
  12947.     BeginUpdate;
  12948.     try
  12949.       I := 0;
  12950.       NewIndex := 0;
  12951.       if BandBorderStyle = bsSingle then
  12952.         BorderSize := BandBorderSize
  12953.       else
  12954.         BorderSize := 0;
  12955.       { Compute row size vs. client size as we iterate to determine "soft"
  12956.         breaks between rows }
  12957.       if Vertical then
  12958.         ClientSize := ClientHeight
  12959.       else
  12960.         ClientSize := ClientWidth;
  12961.       RowSize := 0;
  12962.       while (I < FBands.FVisibleCount) and (NewIndex < FBands.Count) do
  12963.       begin
  12964.         { Get info from coolbar about visible band }
  12965.         if (Perform(RB_GETBANDINFO, I, Integer(@BandInfo)) <> 0) and
  12966.           (BandInfo.wID <> 0) then
  12967.         begin
  12968.           { Find opening for visible band }
  12969.           if not (csDesigning in ComponentState) then
  12970.             for NewIndex := NewIndex to FBands.Count - 1 do
  12971.               if FBands[NewIndex].Visible then Break;
  12972.           with BandInfo, TCoolBand(wID) do
  12973.           begin
  12974.             NewBreak := fStyle and RBBS_BREAK <> 0;
  12975.             NewWidth := cx;
  12976.             if NewBreak or (I = 0) then
  12977.               RowSize := cx
  12978.             else
  12979.               Inc(RowSize, cx + BorderSize);
  12980.             if RowSize > ClientSize then
  12981.             begin
  12982.               RowSize := cx;
  12983.               FID := SoftBreakMask or I;
  12984.             end
  12985.             else
  12986.               FID := I;
  12987.             if (Break <> NewBreak) or (Index <> NewIndex) or (Width <> NewWidth) then
  12988.             begin
  12989.               Result := True;
  12990.               Break := NewBreak;
  12991.               { Exchange bands }
  12992.               FBands[NewIndex].Index := Index;
  12993.               Index := NewIndex;
  12994.               Width := NewWidth;
  12995.             end;
  12996.           end;
  12997.         end;
  12998.         Inc(I);
  12999.         Inc(NewIndex);
  13000.       end;
  13001.     finally
  13002.       EndUpdate;
  13003.     end;
  13004.   end;
  13005. end;
  13006.  
  13007. procedure TCoolBar.UpdateBand(Index: Integer);
  13008. begin
  13009.   if HandleAllocated and (FUpdateCount = 0) then
  13010.     UpdateItem(RB_SETBANDINFO, Index, Bands[Index].FID and IDMask)
  13011. end;
  13012.  
  13013. procedure TCoolBar.UpdateBands;
  13014. var
  13015.   I: Integer;
  13016.   WindowLocked: Boolean;
  13017. begin
  13018.   if HandleAllocated and (FUpdateCount = 0) then
  13019.   begin
  13020.     BeginUpdate;
  13021.     WindowLocked := LockWindowUpdate(GetDesktopWindow);
  13022.     try
  13023.       DisableBands;
  13024.       for I := 0 to Perform(RB_GETBANDCOUNT, 0, 0) - 1 do
  13025.         Perform(RB_DELETEBAND, 0, 0);
  13026.       if FixedOrder then
  13027.         { Add bands from first to last }
  13028.         for I := 0 to Bands.Count - 1 do
  13029.           UpdateItem(RB_INSERTBAND, I, -1)
  13030.       else
  13031.         { Add bands from last to first }
  13032.         for I := Bands.Count - 1 downto 0 do
  13033.           UpdateItem(RB_INSERTBAND, I, 0);
  13034.       if Assigned(FImages) then SetImageList(FImages.Handle);
  13035.     finally
  13036.       if WindowLocked then LockWindowUpdate(0);
  13037.       EndUpdate;
  13038.     end;
  13039.     FBands.FVisibleCount := Perform(RB_GETBANDCOUNT, 0, 0);
  13040.     ReadBands;
  13041.     if IsAutoSized then AdjustSize;
  13042.   end;
  13043. end;
  13044.  
  13045. { Return height of row for given band }
  13046. function TCoolBar.GetRowHeight(Index: Integer): Integer;
  13047. const
  13048.   ChildEdgeSize = 4;
  13049. var
  13050.   Last, I, Size, TmpSize: Integer;
  13051.   DesignText: Boolean;
  13052.   Band: TCoolBand;
  13053.   Text: string;
  13054. begin
  13055.   Result := 0;
  13056.   Last := FBands.Count - 1;
  13057.   if FixedSize then
  13058.     Index := 0
  13059.   else
  13060.   begin
  13061.     { Find last band in row }
  13062.     I := Index;
  13063.     while I < Last do
  13064.       if ((csDesigning in ComponentState) or FBands[I+1].Visible) and
  13065.         (FBands[I+1].Break or (FBands[I+1].FID and SoftBreakMask <> 0)) then
  13066.         Break
  13067.       else
  13068.         Inc(I);
  13069.     Last := I;
  13070.     { Find first band in row }
  13071.     while Index > 0 do
  13072.       if ((csDesigning in ComponentState) or FBands[Index].Visible) and
  13073.         (FBands[Index].Break or (FBands[Index].FID and SoftBreakMask <> 0)) then
  13074.         Break
  13075.       else
  13076.         Dec(Index);
  13077.   end;
  13078.   { Compute maximum band size between Index and Last }
  13079.   for I := Index to Last do
  13080.   begin
  13081.     Band := FBands[I];
  13082.     if (csDesigning in ComponentState) or Band.Visible then
  13083.     begin
  13084.       { Calc control size }
  13085.       if Assigned(Band.Control) then
  13086.       begin
  13087.         Size := Band.MinHeight;
  13088.         if Band.BorderStyle = bsNone then Dec(Size, ChildEdgeSize);
  13089.       end
  13090.       else Size := 0;
  13091.       { Calc text size }
  13092.       DesignText := (csDesigning in ComponentState) and
  13093.         not Assigned(Band.Control) and (Band.Text = '');
  13094.       if ShowText or DesignText then
  13095.       begin
  13096.         if DesignText then
  13097.           Text := Band.DisplayName
  13098.         else
  13099.           Text := Band.Text;
  13100.         if Text <> '' then
  13101.           if Vertical then
  13102.               with TControlCanvas.Create do
  13103.               try
  13104.                 Control := Self;
  13105.                 Font := FCaptionFont;
  13106.                 TmpSize := TextWidth(Text);
  13107.               finally
  13108.                 Free;
  13109.               end
  13110.           else
  13111.             TmpSize := FCaptionFontHeight
  13112.         else
  13113.           TmpSize := 0;
  13114.         if TmpSize > Size then
  13115.           Size := TmpSize;
  13116.       end;
  13117.       { Calc image size }
  13118.       if Assigned(Images) and (Band.ImageIndex >= 0) then
  13119.       begin
  13120.         if Vertical then
  13121.           TmpSize := Images.Height
  13122.         else
  13123.           TmpSize := Images.Width;
  13124.         if TmpSize > Size then
  13125.           Size := TmpSize;
  13126.       end;
  13127.       { Adjust for child edges }
  13128.       Inc(Size, ChildEdgeSize);
  13129.       { Remember max value }
  13130.       if Size > Result then
  13131.         Result := Size;
  13132.     end;
  13133.   end;
  13134. end;
  13135.  
  13136. function TCoolBar.PtInGripRect(const Pos: TPoint): Integer;
  13137. var
  13138.   I, PosX, PosY, X, Y: Integer;
  13139.   PrevWidth, RowHeight, BorderSize: Integer;
  13140.   Band: TCoolBand;
  13141. begin
  13142.   if FBands.FVisibleCount > 0 then
  13143.   begin
  13144.     if Vertical then
  13145.     begin
  13146.       PosX := Pos.Y;
  13147.       PosY := Pos.X;
  13148.     end
  13149.     else
  13150.     begin
  13151.       PosX := Pos.X;
  13152.       PosY := Pos.Y;
  13153.     end;
  13154.     X := 0;
  13155.     Y := 0;
  13156.     PrevWidth := 0;
  13157.     RowHeight := 0;
  13158.     if BandBorderStyle = bsSingle then
  13159.       BorderSize := BandBorderSize
  13160.     else
  13161.       BorderSize := 0;
  13162.     for I := 0 to FBands.Count - 1 do
  13163.     begin
  13164.       Band := FBands[I];
  13165.       if (csDesigning in ComponentState) or Band.Visible then
  13166.       begin
  13167.         if (Band.FID and IDMask = 0) or (Band.Break or
  13168.           (Band.FID and SoftBreakMask <> 0)) then
  13169.         begin
  13170.           X := 0;
  13171.           if Band.FID and IDMask > 0 then
  13172.             Inc(Y, RowHeight + BorderSize);
  13173.           RowHeight := GetRowHeight(I);
  13174.         end
  13175.         else
  13176.           Inc(X, PrevWidth);
  13177.         PrevWidth := Band.Width + BorderSize;
  13178.         if (PosX < X) or (PosX > X + Band.Width) or (PosY < Y) or
  13179.           (PosY > Y + RowHeight) then Continue;
  13180.         { Find hittest area }
  13181.         if not Band.FixedSize and (not FixedOrder or
  13182.           (Band.FID and IDMask > 0)) and (PosX <= X + GetCaptionSize(Band)) then
  13183.         begin
  13184.           if PosX > X + GripSize then
  13185.             Result := grCaption
  13186.           else
  13187.             Result := grGrip;
  13188.           Exit;
  13189.         end
  13190.         else
  13191.           System.Break;
  13192.       end;
  13193.     end;  
  13194.   end;
  13195.   Result := grNone;
  13196. end;
  13197.  
  13198. procedure TCoolBar.WMCaptureChanged(var Message: TMessage);
  13199. begin
  13200.   inherited;
  13201.   { Synchronize band properties - something may have changed }
  13202.   if not (csClicked in ControlState) then
  13203.     PostMessage(Handle, CN_BANDCHANGE + 1, 0, 0)
  13204. end;
  13205.  
  13206. procedure TCoolBar.WMEraseBkgnd(var Message: TWMEraseBkgnd);
  13207. begin
  13208.   if IsBackgroundDirty or (IsAutoSized and (Bands.Count = 0)) then
  13209.     inherited;
  13210.   DefaultHandler(Message);
  13211. end;
  13212.  
  13213. procedure TCoolBar.WMLButtonDown(var Message: TWMLButtonDown);
  13214. begin
  13215.   if (PtInGripRect(SmallPointToPoint(Message.Pos)) = grNone) then
  13216.     inherited
  13217.   else
  13218.   begin
  13219.     FTrackDrag := Message.Pos;
  13220.     DefaultHandler(Message);
  13221.   end;
  13222. end;
  13223.  
  13224. procedure TCoolBar.WMLButtonUp(var Message: TWMLButtonUp);
  13225. begin
  13226.   if not (csDesigning in ComponentState) or (csClicked in ControlState) or
  13227.     ((FTrackDrag.X < Message.XPos - 1) and (FTrackDrag.X > Message.XPos + 1) and
  13228.     (FTrackDrag.Y < Message.YPos - 1) and (FTrackDrag.Y > Message.YPos + 1)) then
  13229.     inherited
  13230.   else
  13231.     MouseCapture := False;
  13232. end;
  13233.  
  13234. procedure TCoolBar.WMNotifyFormat(var Message: TMessage);
  13235. begin
  13236.   with Message do
  13237.     Result := DefWindowProc(Handle, Msg, WParam, LParam);
  13238. end;
  13239.  
  13240. procedure TCoolBar.WMSetCursor(var Message: TWMSetCursor);
  13241. var
  13242.   P: TPoint;
  13243.   Grip: Integer;
  13244.   MsgPos: Longint;
  13245. begin
  13246.   { Ignore default processing since it's flawed when coolbar is vertical }
  13247.   with Message do
  13248.     if (CursorWnd = Handle) and (Smallint(HitTest) = HTCLIENT) then
  13249.     begin
  13250.       Result := 1;
  13251.       MsgPos := GetMessagePos;
  13252.       P.X := MsgPos and $FFFF;
  13253.       P.Y := MsgPos shr 16;
  13254.       Windows.ScreenToClient(CursorWnd, P);
  13255.       Grip := PtInGripRect(P);
  13256.       if Grip <> grNone then
  13257.       begin
  13258.         if Grip = grCaption then
  13259.           Windows.SetCursor(Screen.Cursors[crHandPoint])
  13260.         else if Vertical then
  13261.           Windows.SetCursor(Screen.Cursors[crSizeNS])
  13262.         else Windows.SetCursor(Screen.Cursors[crSizeWE]);
  13263.       end
  13264.       else Windows.SetCursor(Screen.Cursors[crDefault]);
  13265.     end
  13266.     else inherited;
  13267. end;
  13268.  
  13269. procedure TCoolBar.WMSize(var Message: TWMSize);
  13270. var
  13271.   R: TRect;
  13272.   CX, CY: Integer;
  13273.  
  13274.   function CalcNewSize: Boolean;
  13275.   var
  13276.     OldSize: Integer;
  13277.  
  13278.     function GetDisplaySize: Integer;
  13279.     var
  13280.       I, RowCount: Integer;
  13281.     begin
  13282.       Result := 0;
  13283.       RowCount := 0;
  13284.       for I := 0 to FBands.Count - 1 do
  13285.         with FBands[I] do
  13286.           if ((csDesigning in ComponentState) or Visible) and
  13287.             ((FID and IDMask = 0) or (Break or (FID and SoftBreakMask <> 0))) then
  13288.           begin
  13289.             Inc(RowCount);
  13290.             Inc(Result, GetRowHeight(I));
  13291.           end;
  13292.       if (RowCount > 1) and (BandBorderStyle = bsSingle) then
  13293.         Inc(Result, (RowCount - 1) * BandBorderSize);
  13294.     end;
  13295.  
  13296.   begin
  13297.     if IsAutoSized and ((FBands.Count > 0) or not (csDesigning in ComponentState)) then
  13298.       if Vertical and (Align in [alNone, AlLeft, alRight]) then
  13299.       begin
  13300.         OldSize := CX;
  13301.         CX := GetDisplaySize;
  13302.         Result := CX <> OldSize;
  13303.       end
  13304.       else if not Vertical and (Align in [alNone, alTop, alBottom]) then
  13305.       begin
  13306.         OldSize := CY;
  13307.         CY := GetDisplaySize;
  13308.         Result := CY <> OldSize;
  13309.       end
  13310.       else Result := False
  13311.     else Result := False;
  13312.   end;
  13313.  
  13314. begin
  13315.   if HandleAllocated then
  13316.   begin
  13317.     R := ClientRect;
  13318.     CX := R.Right;
  13319.     CY := R.Bottom;
  13320.     if CalcNewSize then
  13321.     begin
  13322.       { Add non-client size }
  13323.       Inc(CX, Width - R.Right);
  13324.       Inc(CY, Height - R.Bottom);
  13325.       if ((CX < R.Right) or (CY < R.Bottom)) and
  13326.         Assigned(Parent) and Parent.HandleAllocated then
  13327.       begin
  13328.         R := BoundsRect;
  13329.         InvalidateRect(Parent.Handle, @R, True);
  13330.       end;
  13331.       SetWindowPos(Handle, 0, 0, 0, CX, CY, SWP_NOACTIVATE or SWP_NOMOVE or
  13332.         SWP_NOZORDER);
  13333.       inherited;
  13334.       PostMessage(Handle, CN_REQUESTALIGN, 0, 0);
  13335.     end
  13336.     else inherited;
  13337.     ReadBands;
  13338.   end
  13339.   else inherited;
  13340. end;
  13341.  
  13342. procedure TCoolBar.WMWindowPosChanged(var Message: TWMWindowPosChanged);
  13343. begin
  13344.   inherited;
  13345.   if not (csLoading in ComponentState) and
  13346.     (Message.WindowPos^.flags and SWP_NOSIZE = 0) then
  13347.     Resize;
  13348. end;
  13349.  
  13350. procedure TCoolBar.WndProc(var Message: TMessage);
  13351. begin
  13352.   if (csDesigning in ComponentState) then
  13353.     case Message.Msg of
  13354.       WM_MOUSEMOVE, WM_LBUTTONDBLCLK, WM_RBUTTONDBLCLK:
  13355.         begin
  13356.           { Enabled csDesignInteractive temporarily so that we may handle the
  13357.             design-time dragging of bands }
  13358.           ControlStyle := ControlStyle + [csDesignInteractive];
  13359.           try
  13360.             inherited WndProc(Message);
  13361.           finally
  13362.             ControlStyle := ControlStyle - [csDesignInteractive];
  13363.           end;
  13364.           Exit;
  13365.         end;
  13366.       { We just dragged a band - disable any drag events }
  13367.       WM_LBUTTONUP: MouseCapture := False;
  13368.     end;
  13369.   case Message.Msg of
  13370.     CN_REQUESTALIGN:
  13371.       begin
  13372.         RequestAlign;
  13373.         RedrawWindow(Handle, nil, 0, RDW_INVALIDATE or RDW_ALLCHILDREN or RDW_FRAME);
  13374.         Exit;
  13375.       end;
  13376.     CN_BANDCHANGE + 1:
  13377.       Message.Msg := CN_BANDCHANGE;
  13378.   end;
  13379.   inherited WndProc(Message);
  13380. end;
  13381.  
  13382. procedure TCoolBar.CMColorChanged(var Message: TMessage);
  13383. var
  13384.   I: Integer;
  13385. begin
  13386.   inherited;
  13387.   if Assigned(FBands) then
  13388.     for I := 0 to FBands.Count - 1 do Bands[I].ParentColorChanged;
  13389.   if HandleAllocated then
  13390.     RedrawWindow(Handle, nil, 0, RDW_INVALIDATE or RDW_ERASE or RDW_FRAME);
  13391. end;
  13392.  
  13393. procedure TCoolBar.CMControlChange(var Message: TCMControlChange);
  13394. var
  13395.   Band: TCoolBand;
  13396. begin
  13397.   if FUpdateCount = 0 then
  13398.   begin
  13399.     { Can only accept TWinControl descendants }
  13400.     if not (csLoading in ComponentState) and (Message.Control is TWinControl) then
  13401.       if Message.Inserting then
  13402.         with TCoolBand(Bands.Add) do SetControl(TWinControl(Message.Control))
  13403.       else
  13404.       begin
  13405.         Band := Bands.FindBand(Message.Control);
  13406.         if Assigned(Band) then Band.Free;
  13407.       end;
  13408.   end;
  13409. end;
  13410.  
  13411. procedure TCoolBar.CMDesignHitTest(var Message: TCMDesignHitTest);
  13412. begin
  13413.   if not (csDesignInteractive in ControlStyle) and
  13414.     (PtInGripRect(SmallPointToPoint(Message.Pos)) <> grNone) then
  13415.     Message.Result := 1
  13416.   else
  13417.     inherited;
  13418. end;
  13419.  
  13420. procedure TCoolBar.CMSysColorChange(var Message: TMessage);
  13421. begin
  13422.   inherited;
  13423.   if not (csLoading in ComponentState) then
  13424.   begin
  13425.     Message.Msg := WM_SYSCOLORCHANGE;
  13426.     DefaultHandler(Message);
  13427.   end;
  13428. end;
  13429.  
  13430. procedure TCoolBar.CMSysFontChanged(var Message: TMessage);
  13431. begin
  13432.   inherited;
  13433.   RecreateWnd;
  13434. end;
  13435.  
  13436. procedure TCoolBar.CMWinIniChange(var Message: TWMWinIniChange);
  13437. begin
  13438.   inherited;
  13439.   FCaptionFont.Handle := GetCaptionFont;
  13440.   FCaptionFontHeight := GetCaptionFontHeight;
  13441. end;
  13442.  
  13443. procedure TCoolBar.CNBandChange(var Message: TMessage);
  13444. begin
  13445.   if ReadBands then Change;
  13446. end;
  13447.  
  13448. procedure TCoolBar.CNNotify(var Message: TWMNotify);
  13449. begin
  13450.   if (Message.NMHdr^.code = RBN_HEIGHTCHANGE) then
  13451.     if IsAutoSized and (ComponentState * [csLoading, csDestroying] = []) then
  13452.     begin
  13453.       ReadBands;
  13454.       BeginUpdate;
  13455.       try
  13456.         AdjustSize;
  13457.       finally
  13458.         EndUpdate;
  13459.       end;
  13460.     end
  13461.     else if IsBackgroundDirty then
  13462.       Invalidate;
  13463. end;
  13464.  
  13465. { TDateTimeColors }
  13466.  
  13467. const
  13468.   ColorIndex: array[0..5] of Integer = (MCSC_BACKGROUND, MCSC_TEXT,
  13469.     MCSC_TITLEBK, MCSC_TITLETEXT, MCSC_MONTHBK, MCSC_TRAILINGTEXT);
  13470.  
  13471. constructor TDateTimeColors.Create(AOwner: TDateTimePicker);
  13472. begin
  13473.   Owner := AOwner;
  13474.   FBackColor := clWindow;
  13475.   FTextColor := clWindowText;
  13476.   FTitleBackColor := clActiveCaption;
  13477.   FTitleTextColor := clWhite;
  13478.   FMonthBackColor := clWhite;
  13479.   FTrailingTextColor := clInactiveCaptionText;
  13480. end;
  13481.  
  13482. procedure TDateTimeColors.Assign(Source: TPersistent);
  13483. var
  13484.   SourceName: string;
  13485. begin
  13486.   if Source = nil then SourceName := 'nil'
  13487.   else SourceName := Source.ClassName;
  13488.   if (Source = nil) or not (Source is TDateTimeColors) then
  13489.     raise EConvertError.CreateFmt(SAssignError, [SourceName, ClassName]);
  13490.   FBackColor := TDateTimeColors(Source).BackColor;
  13491.   FTextColor := TDateTimeColors(Source).TextColor;
  13492.   FTitleBackColor := TDateTimeColors(Source).TitleBackColor;
  13493.   FTitleTextColor := TDateTimeColors(Source).TitleTextColor;
  13494.   FMonthBackColor := TDateTimeColors(Source).MonthBackColor;
  13495.   FTrailingTextColor := TDateTimeColors(Source).TrailingTextColor;
  13496. end;
  13497.  
  13498. procedure TDateTimeColors.SetColor(Index: Integer; Value: TColor);
  13499. begin
  13500.   DateTime_SetMonthCalColor(Owner.Handle, ColorIndex[Index], ColorToRGB(Value));
  13501.   case Index of
  13502.     0: FBackColor := Value;
  13503.     1: FTextColor := Value;
  13504.     2: FTitleBackColor := Value;
  13505.     3: FTitleTextColor := Value;
  13506.     4: FMonthBackColor := Value;
  13507.     5: FTrailingTextColor := Value;
  13508.   end;
  13509. end;
  13510.  
  13511. procedure TDateTimeColors.SetAllColors;
  13512. begin
  13513.   SetColor(0, FBackColor);
  13514.   SetColor(1, FTextColor);
  13515.   SetColor(2, FTitleBackColor);
  13516.   SetColor(3, FTitleTextColor);
  13517.   SetColor(4, FMonthBackColor);
  13518.   SetColor(5, FTrailingTextColor);
  13519. end;
  13520.  
  13521. { TDateTimePicker }
  13522.  
  13523. constructor TDateTimePicker.Create(AOwner: TComponent);
  13524. begin
  13525.   CheckCommonControl(ICC_DATE_CLASSES);
  13526.   FCalColors := TDateTimeColors.Create(Self);
  13527.   FDateTime := Now;
  13528.   FShowCheckbox := False;
  13529.   FChecked := True;
  13530.   inherited Create(AOwner);
  13531.   ControlStyle := [csOpaque, csClickEvents, csDoubleClicks, csFixedHeight,
  13532.     csReflector];
  13533.   Color := clWindow;
  13534.   ParentColor := False;
  13535.   TabStop := True;
  13536.   Width := 186;
  13537.   AdjustHeight;
  13538. end;
  13539.  
  13540. destructor TDateTimePicker.Destroy;
  13541. begin
  13542.   FCalColors.Free;
  13543.   inherited Destroy;
  13544. end;
  13545.  
  13546. procedure TDateTimePicker.CreateParams(var Params: TCreateParams);
  13547. const
  13548.   Formats: array[TDTDateFormat] of Integer = (DTS_SHORTDATEFORMAT,
  13549.     DTS_LONGDATEFORMAT);
  13550. begin
  13551.   inherited CreateParams(Params);
  13552.   CreateSubClass(Params, DATETIMEPICK_CLASS);
  13553.   with Params do
  13554.   begin
  13555.     Style := Style or Formats[FDateFormat];
  13556.     if FDateMode = dmUpDown then Style := Style or DTS_UPDOWN;
  13557.     if FKind = dtkTime then Style := Style or DTS_TIMEFORMAT;
  13558.     if FCalAlignment = dtaRight then Style := Style or DTS_RIGHTALIGN;
  13559.     if FParseInput then Style := Style or DTS_APPCANPARSE;
  13560.     if FShowCheckbox then Style := Style or DTS_SHOWNONE;
  13561.     WindowClass.Style := WindowClass.Style and not (CS_HREDRAW or CS_VREDRAW) or
  13562.       CS_DBLCLKS;
  13563.   end;
  13564. end;
  13565.  
  13566. procedure TDateTimePicker.CreateWnd;
  13567. begin
  13568.   inherited CreateWnd;
  13569.   SetDateTime(FDateTime);
  13570.   FCalColors.SetAllColors;
  13571.   SetChecked(FChecked);
  13572. end;
  13573.  
  13574. procedure TDateTimePicker.CMColorChanged(var Message: TMessage);
  13575. begin
  13576.   inherited;
  13577.   InvalidateRect(Handle, nil, True);
  13578. end;
  13579.  
  13580. procedure TDateTimePicker.CMFontChanged(var Message: TMessage);
  13581. begin
  13582.   inherited;
  13583.   AdjustHeight;
  13584.   InvalidateRect(Handle, nil, True);
  13585. end;
  13586.  
  13587. procedure TDateTimePicker.CNNotify(var Message: TWMNotify);
  13588.  
  13589.   function IsBlankSysTime(ST: TSystemTime): Boolean;
  13590.   begin
  13591.     with ST do
  13592.       Result := (wYear = 0) and (wMonth = 0) and (wDayOfWeek = 0) and
  13593.         (wDay = 0) and (wHour = 0) and (wMinute = 0) and (wSecond = 0) and
  13594.         (wMilliseconds = 0);
  13595.   end;
  13596.  
  13597. var
  13598.   DT: TDateTime;
  13599.   AllowChange: Boolean;
  13600. begin
  13601.   with Message, Message.NMHdr^ do
  13602.   begin
  13603.     Result := 0;
  13604.     case code of
  13605.       DTN_CLOSEUP:
  13606.         begin
  13607.           SetDateTime(FDateTime);
  13608.           if Assigned(FOnCloseUp) then FOnCloseUp(Self);
  13609.         end;
  13610.       DTN_DATETIMECHANGE:
  13611.         begin
  13612.           if FShowCheckbox and IsBlankSysTime(PNMDateTimeChange(NMHdr)^.st) then
  13613.             FChecked := False
  13614.           else begin
  13615.             DT := SystemTimeToDateTime(PNMDateTimeChange(NMHdr)^.st);
  13616.             if Kind = dtkDate then SetDate(DT)
  13617.             else SetTime(DT);
  13618.             if FShowCheckbox then FChecked := True;
  13619.           end;
  13620.           if Assigned(FOnChange) then FOnChange(Self);
  13621.         end;
  13622.       DTN_DROPDOWN:
  13623.         if Assigned(FOnDropDown) then FOnDropDown(Self);
  13624.       DTN_USERSTRING:
  13625.         begin
  13626.           AllowChange := Assigned(FOnUserInput);
  13627.           with PNMDateTimeString(NMHdr)^ do
  13628.           begin
  13629.             if AllowChange then
  13630.             begin
  13631.               DT := 0.0;
  13632.               FOnUserInput(Self, pszUserString, DT, AllowChange);
  13633.               DateTimeToSystemTime(DT, st);
  13634.             end;
  13635.             dwFlags := Ord(not AllowChange);
  13636.           end;
  13637.         end;
  13638.     else
  13639.       inherited;
  13640.     end;
  13641.   end;
  13642. end;
  13643.  
  13644. procedure TDateTimePicker.AdjustHeight;
  13645. var
  13646.   DC: HDC;
  13647.   SaveFont: HFont;
  13648.   SysMetrics, Metrics: TTextMetric;
  13649. begin
  13650.   DC := GetDC(0);
  13651.   try
  13652.     GetTextMetrics(DC, SysMetrics);
  13653.     SaveFont := SelectObject(DC, Font.Handle);
  13654.     GetTextMetrics(DC, Metrics);
  13655.     SelectObject(DC, SaveFont);
  13656.   finally
  13657.     ReleaseDC(0, DC);
  13658.   end;
  13659.   Height := Metrics.tmHeight + (GetSystemMetrics(SM_CYBORDER) * 8);
  13660. end;
  13661.  
  13662. function TDateTimePicker.GetDate: TDate;
  13663. begin
  13664.   Result := TDate(FDateTime);
  13665. end;
  13666.  
  13667. function TDateTimePicker.GetTime: TTime;
  13668. begin
  13669.   Result := TTime(FDateTime);
  13670. end;
  13671.  
  13672. procedure TDateTimePicker.SetCalAlignment(Value: TDTCalAlignment);
  13673. begin
  13674.   if FCalAlignment <> Value then
  13675.   begin
  13676.     FCalAlignment := Value;
  13677.     if not (csDesigning in ComponentState) then RecreateWnd;
  13678.   end;
  13679. end;
  13680.  
  13681. procedure TDateTimePicker.SetCalColors(Value: TDateTimeColors);
  13682. begin
  13683.   if FCalColors <> Value then FCalColors.Assign(Value);
  13684. end;
  13685.  
  13686. procedure TDateTimePicker.SetChecked(Value: Boolean);
  13687. var
  13688.   ST: TSystemTime;
  13689. begin
  13690.   FChecked := Value;
  13691.   if FShowCheckbox then
  13692.   begin
  13693.     if Value then SetDateTime(FDateTime)
  13694.     else DateTime_SetSystemTime(Handle, GDT_NONE, ST);
  13695.     Invalidate;
  13696.   end;
  13697. end;
  13698.  
  13699. procedure TDateTimePicker.SetDate(Value: TDate);
  13700. begin
  13701.   if Trunc(FDateTime) <> Trunc(Value) then
  13702.   begin
  13703.     Value := Trunc(Value) + Frac(FDateTime);
  13704.     if Value = 0.0 then
  13705.     begin
  13706.       if not FShowCheckbox then raise EDateTimeError.Create(SNeedAllowNone);
  13707.       FChecked := False;
  13708.       Invalidate;
  13709.     end
  13710.     else begin
  13711.       try
  13712.         if (FMaxDate <> 0.0) and (Value > FMaxDate) then
  13713.           raise EDateTimeError.CreateFmt(SDateTimeMax, [DateToStr(FMaxDate)]);
  13714.         if (FMinDate <> 0.0) and (Value < FMinDate) then
  13715.           raise EDateTimeError.CreateFmt(SDateTimeMin, [DateToStr(FMinDate)]);
  13716.         SetDateTime(Value);
  13717.       except
  13718.         SetDateTime(FDateTime);
  13719.         raise;
  13720.       end;
  13721.     end;
  13722.   end;
  13723. end;
  13724.  
  13725. procedure TDateTimePicker.SetDateTime(Value: TDateTime);
  13726. var
  13727.   ST: TSystemTime;
  13728. begin
  13729.   DateTimeToSystemTime(Value, ST);
  13730.   if DateTime_SetSystemTime(Handle, GDT_VALID, ST) then
  13731.     FDateTime := Value;
  13732. end;
  13733.  
  13734. procedure TDateTimePicker.SetMaxDate(Value: TDate);
  13735. begin
  13736.   if Value < FMinDate then
  13737.     raise EDateTimeError.CreateFmt(SDateTimeMin, [DateToStr(FMinDate)]);
  13738.   if FMaxDate <> Value then
  13739.   begin
  13740.     SetRange(FMinDate, Value);
  13741.     FMaxDate := Value;
  13742.   end;
  13743. end;
  13744.  
  13745. procedure TDateTimePicker.SetMinDate(Value: TDate);
  13746. begin
  13747.   if Value > FMaxDate then
  13748.     raise EDateTimeError.CreateFmt(SDateTimeMin, [DateToStr(FMaxDate)]);
  13749.   if FMinDate <> Value then
  13750.   begin
  13751.     SetRange(Value, FMaxDate);
  13752.     FMinDate := Value;
  13753.   end;
  13754. end;
  13755.  
  13756. procedure TDateTimePicker.SetRange(MinVal, MaxVal: TDateTime);
  13757. var
  13758.   STA: packed array[1..2] of TSystemTime;
  13759.   Flags: DWORD;
  13760. begin
  13761.   Flags := 0;
  13762.   if Double(MinVal) <> 0.0 then
  13763.   begin
  13764.     Flags := Flags or GDTR_MIN;
  13765.     DateTimeToSystemTime(MinVal, STA[1]);
  13766.   end;
  13767.   if Double(MaxVal) <> 0.0 then
  13768.   begin
  13769.     Flags := Flags or GDTR_MIN;
  13770.     DateTimeToSystemTime(MaxVal, STA[2]);
  13771.   end;
  13772.   if Flags <> 0 then DateTime_SetRange(Handle, Flags, @STA[1]);
  13773. end;
  13774.  
  13775. procedure TDateTimePicker.SetDateFormat(Value: TDTDateFormat);
  13776. begin
  13777.   if FDateFormat <> Value then
  13778.   begin
  13779.     FDateFormat := Value;
  13780.     RecreateWnd;
  13781.   end;
  13782. end;
  13783.  
  13784. procedure TDateTimePicker.SetDateMode(Value: TDTDateMode);
  13785. begin
  13786.   if FDateMode <> Value then
  13787.   begin
  13788.     FDateMode := Value;
  13789.     RecreateWnd;
  13790.   end;
  13791. end;
  13792.  
  13793. procedure TDateTimePicker.SetKind(Value: TDateTimeKind);
  13794. begin
  13795.   if FKind <> Value then
  13796.   begin
  13797.     FKind := Value;
  13798.     RecreateWnd;
  13799.   end;
  13800. end;
  13801.  
  13802. procedure TDateTimePicker.SetParseInput(Value: Boolean);
  13803. begin
  13804.   if FParseInput <> Value then
  13805.   begin
  13806.     FParseInput := Value;
  13807.     if not (csDesigning in ComponentState) then RecreateWnd;
  13808.   end;
  13809. end;
  13810.  
  13811. procedure TDateTimePicker.SetShowCheckbox(Value: Boolean);
  13812. begin
  13813.   if FShowCheckbox <> Value then
  13814.   begin
  13815.     FShowCheckbox := Value;
  13816.     RecreateWnd;
  13817.   end;
  13818. end;
  13819.  
  13820. procedure TDateTimePicker.SetTime(Value: TTime);
  13821. begin
  13822.   if Frac(FDateTime) <> Frac(Value) then
  13823.   begin
  13824.     Value := Trunc(FDateTime) + Frac(Value);
  13825.     if Value = 0.0 then
  13826.     begin
  13827.       if not FShowCheckbox then raise EDateTimeError.Create(SNeedAllowNone);
  13828.       FChecked := False;
  13829.       Invalidate;
  13830.     end
  13831.     else
  13832.       SetDateTime(Value);
  13833.   end;
  13834. end;
  13835.  
  13836. initialization
  13837.  
  13838. finalization
  13839.   if ShellModule <> 0 then FreeLibrary(ShellModule);
  13840.  
  13841. end.
  13842.