unit VirtualTrees;



// The contents of this file are subject to the Mozilla Public License

// Version 1.1 (the "License"); you may not use this file except in compliance

// with the License. You may obtain a copy of the License at http://www.mozilla.org/MPL/

//

// Alternatively, you may redistribute this library, use and/or modify it under the terms of the

// GNU Lesser General Public License as published by the Free Software Foundation;

// either version 2.1 of the License, or (at your option) any later version.

// You may obtain a copy of the LGPL at http://www.gnu.org/copyleft/.

//

// Software distributed under the License is distributed on an "AS IS" basis,

// WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for the

// specific language governing rights and limitations under the License.

//

// The original code is VirtualTrees.pas, released September 30, 2000.

//

// The initial developer of the original code is digital publishing AG (Munich, Germany, www.digitalpublishing.de),

// written by Mike Lischke (public@soft-gems.net, www.soft-gems.net).

//

// Portions created by digital publishing AG are Copyright

// (C) 1999-2001 digital publishing AG. All Rights Reserved.

//----------------------------------------------------------------------------------------------------------------------

//

// For a list of recent changes please see file CHANGES.TXT

//

// Credits for their valuable assistance and code donations go to:

//   Freddy Ertl, Marian Aldenhövel, Thomas Bogenrieder, Jim Kuenemann, Werner Lehmann, Jens Treichler,

//   Paul Gallagher (IBO tree), Ondrej Kelle, Ronaldo Melo Ferraz, Heri Bender, Roland Bedürftig (BCB)

//   Anthony Mills, Alexander Egorushkin (BCB), Mathias Torell (BCB), Frank van den Bergh, Vadim Sedulin, Peter Evans,

//   Milan Vandrovec (BCB), Steve Moss, Joe White, David Clark, Anders Thomsen, Igor Afanasyev, Eugene Programmer,

//   Corbin Dunn, Richard Pringle, Uli Gerhardt, Azza, Igor Savkic, Daniel Bauten, Timo Tegtmeier, Dmitry Zegebart,

//   Andreas Hausladen, Joachim Marder

// Beta testers:

//   Freddy Ertl, Hans-Jürgen Schnorrenberg, Werner Lehmann, Jim Kueneman, Vadim Sedulin, Moritz Franckenstein,

//   Wim van der Vegt, Franc v/d Westelaken

// Indirect contribution (via publicly accessible work of those persons):

//   Alex Denissov, Hiroyuki Hori (MMXAsm expert)

// Documentation:

//   Markus Spoettl and toolsfactory GbR (http://www.doc-o-matic.com/, sponsoring Soft Gems development

//   with a free copy of the Doc-O-Matic help authoring system), Sven H. (Step by step tutorial)

// CLX:

//   Dmitri Dmitrienko (initial developer)

// Source repository:

//   https://code.google.com/p/virtual-treeview/source/

// Accessability implementation:

//   Marco Zehe (with help from Sebastian Modersohn)

//----------------------------------------------------------------------------------------------------------------------



interface



{$booleval off} // Use fastest possible boolean evaluation

 

{.$define TntSupport} // Added by Igor Afanasyev to support unicode-aware inplace editors. This implementation uses

                      // Troy Wolbrink's TNT controls, meanwhile available as TMS Unicode components



// For some things to work we need code, which is classified as being unsafe for .NET.

{$WARN UNSAFE_TYPE OFF}

{$WARN UNSAFE_CAST OFF}

{$WARN UNSAFE_CODE OFF}



{$IF CompilerVersion >= 24}

  {$LEGACYIFEND ON}

{$IFEND}



{$if CompilerVersion >= 20}

  {$WARN IMPLICIT_STRING_CAST       OFF}

  {$WARN IMPLICIT_STRING_CAST_LOSS  OFF}

{$ifend}



{$HPPEMIT '#include <objidl.h>'}

{$HPPEMIT '#include <oleidl.h>'}

{$HPPEMIT '#include <oleacc.h>'}

{$HPPEMIT '#include <ShlObj.hpp>'}

{$HPPEMIT '#pragma link "VirtualTreesR.lib"'}



uses

  Windows,

  {$if CompilerVersion >= 18}

    oleacc,   // MSAA support in Delphi 2006 or higher

  {$ifend}

  Messages, SysUtils, Graphics, Controls, Forms, ImgList, ActiveX, StdCtrls, Classes, Menus, Printers, Types,

  CommCtrl, // image lists, common controls tree structures

  Themes, UxTheme, ShlObj

  {$ifdef TntSupport}

    , TntStdCtrls       // Unicode aware inplace editor.

  {$endif TntSupport}

  {$IF CompilerVersion >= 24}

  ,UITypes

  {$IFEND}

  ;



const

  VTVersion = '5.5.3';



{$if CompilerVersion < 20}

type

  UnicodeString = WideString;

  RawByteString = AnsiString;

  PByte = PAnsiChar;

{$ifend}



{$if CompilerVersion < 18}

  //MSAA interfaces not included in Delphi 7

  {$WARN BOUNDS_ERROR OFF}

  IAccessible = interface(IDispatch)

    ['{618736E0-3C3D-11CF-810C-00AA00389B71}']

    function Get_accParent(out ppdispParent: IDispatch): HResult; stdcall;

    function Get_accChildCount(out pcountChildren: Integer): HResult; stdcall;

    function Get_accChild(varChild: OleVariant; out ppdispChild: IDispatch): HResult; stdcall;

    function Get_accName(varChild: OleVariant; out pszName: WideString): HResult; stdcall;

    function Get_accValue(varChild: OleVariant; out pszValue: WideString): HResult; stdcall;

    function Get_accDescription(varChild: OleVariant; out pszDescription: WideString): HResult; stdcall;

    function Get_accRole(varChild: OleVariant; out pvarRole: OleVariant): HResult; stdcall;

    function Get_accState(varChild: OleVariant; out pvarState: OleVariant): HResult; stdcall;

    function Get_accHelp(varChild: OleVariant; out pszHelp: WideString): HResult; stdcall;

    function Get_accHelpTopic(out pszHelpFile: WideString; varChild: OleVariant;

                              out pidTopic: Integer): HResult; stdcall;

    function Get_accKeyboardShortcut(varChild: OleVariant; out pszKeyboardShortcut: WideString): HResult; stdcall;

    function Get_accFocus(out pvarChild: OleVariant): HResult; stdcall;

    function Get_accSelection(out pvarChildren: OleVariant): HResult; stdcall;

    function Get_accDefaultAction(varChild: OleVariant; out pszDefaultAction: WideString): HResult; stdcall;

    function accSelect(flagsSelect: Integer; varChild: OleVariant): HResult; stdcall;

    function accLocation(out pxLeft: Integer; out pyTop: Integer; out pcxWidth: Integer;

                         out pcyHeight: Integer; varChild: OleVariant): HResult; stdcall;

    function accNavigate(navDir: Integer; varStart: OleVariant; out pvarEndUpAt: OleVariant): HResult; stdcall;

    function accHitTest(xLeft: Integer; yTop: Integer; out pvarChild: OleVariant): HResult; stdcall;

    function accDoDefaultAction(varChild: OleVariant): HResult; stdcall;

    function Set_accName(varChild: OleVariant; const pszName: WideString): HResult; stdcall;

    function Set_accValue(varChild: OleVariant; const pszValue: WideString): HResult; stdcall;

  end;

{$ifend}



const

  VTTreeStreamVersion = 2;

  VTHeaderStreamVersion = 6;    // The header needs an own stream version to indicate changes only relevant to the header.



  CacheThreshold = 2000;        // Number of nodes a tree must at least have to start caching and at the same

                                // time the maximum number of nodes between two cache entries.

  FadeAnimationStepCount = 255; // Number of animation steps for hint fading (0..255).

  ShadowSize = 5;               // Size in pixels of the hint shadow. This value has no influence on Win2K and XP systems

                                // as those OSes have native shadow support.



  // Special identifiers for columns.

  NoColumn = -1;

  InvalidColumn = -2;



  // Indices for check state images used for checking.

  ckEmpty                  =  0;  // an empty image used as place holder

  // radio buttons

  ckRadioUncheckedNormal   =  1;

  ckRadioUncheckedHot      =  2;

  ckRadioUncheckedPressed  =  3;

  ckRadioUncheckedDisabled =  4;

  ckRadioCheckedNormal     =  5;

  ckRadioCheckedHot        =  6;

  ckRadioCheckedPressed    =  7;

  ckRadioCheckedDisabled   =  8;

  // check boxes

  ckCheckUncheckedNormal   =  9;

  ckCheckUncheckedHot      = 10;

  ckCheckUncheckedPressed  = 11;

  ckCheckUncheckedDisabled = 12;

  ckCheckCheckedNormal     = 13;

  ckCheckCheckedHot        = 14;

  ckCheckCheckedPressed    = 15;

  ckCheckCheckedDisabled   = 16;

  ckCheckMixedNormal       = 17;

  ckCheckMixedHot          = 18;

  ckCheckMixedPressed      = 19;

  ckCheckMixedDisabled     = 20;

  // simple button

  ckButtonNormal           = 21;

  ckButtonHot              = 22;

  ckButtonPressed          = 23;

  ckButtonDisabled         = 24;



  // Instead using a TTimer class for each of the various events I use Windows timers with messages

  // as this is more economical.

  ExpandTimer = 1;

  EditTimer = 2;

  HeaderTimer = 3;

  ScrollTimer = 4;

  ChangeTimer = 5;

  StructureChangeTimer = 6;

  SearchTimer = 7;

  ThemeChangedTimer = 8;



  ThemeChangedTimerDelay = 500;



  // Need to use this message to release the edit link interface asynchronously.

  WM_CHANGESTATE = WM_APP + 32;



  // Virtual Treeview does not need to be subclassed by an eventual Theme Manager instance as it handles

  // Windows XP theme painting itself. Hence the special message is used to prevent subclassing.

  CM_DENYSUBCLASSING = CM_BASE + 2000;



  // Decoupling message for auto-adjusting the internal edit window.

  CM_AUTOADJUST = CM_BASE + 2005;





  CM_UPDATE_VCLSTYLE_SCROLLBARS = CM_BASE + 2050;



  // VT's own clipboard formats,

  // Note: The reference format is used internally to allow to link to a tree reference

  //       to implement optimized moves and other back references.

  CFSTR_VIRTUALTREE = 'Virtual Tree Data';

  CFSTR_VTREFERENCE = 'Virtual Tree Reference';

  CFSTR_HTML = 'HTML Format';

  CFSTR_RTF = 'Rich Text Format';

  CFSTR_RTFNOOBJS = 'Rich Text Format Without Objects';

  CFSTR_CSV = 'CSV';



  // Drag image helpers for Windows 2000 and up.

  IID_IDropTargetHelper: TGUID = (D1: $4657278B; D2: $411B; D3: $11D2; D4: ($83, $9A, $00, $C0, $4F, $D9, $18, $D0));

  IID_IDragSourceHelper: TGUID = (D1: $DE5BF786; D2: $477A; D3: $11D2; D4: ($83, $9D, $00, $C0, $4F, $D9, $18, $D0));

  IID_IDropTarget: TGUID = (D1: $00000122; D2: $0000; D3: $0000; D4: ($C0, $00, $00, $00, $00, $00, $00, $46));



{$if CompilerVersion < 21}

  CLSID_DragDropHelper: TGUID = (D1: $4657278A; D2: $411B; D3: $11D2; D4: ($83, $9A, $00, $C0, $4F, $D9, $18, $D0));

  DSH_ALLOWDROPDESCRIPTIONTEXT = $1;



  SID_IDropTargetHelper = '{4657278B-411B-11D2-839A-00C04FD918D0}';

  SID_IDragSourceHelper = '{DE5BF786-477A-11D2-839D-00C04FD918D0}';

  SID_IDragSourceHelper2 = '{83E07D0D-0C5F-4163-BF1A-60B274051E40}';

  SID_IDropTarget = '{00000122-0000-0000-C000-000000000046}';

{$ifend}



  // Help identifiers for exceptions. Application developers are responsible to link them with actual help topics.

  hcTFEditLinkIsNil      = 2000;

  hcTFWrongMoveError     = 2001;

  hcTFWrongStreamFormat  = 2002;

  hcTFWrongStreamVersion = 2003;

  hcTFStreamTooSmall     = 2004;

  hcTFCorruptStream1     = 2005;

  hcTFCorruptStream2     = 2006;

  hcTFClipboardFailed    = 2007;

  hcTFCannotSetUserData  = 2008;



  // Header standard split cursor.

  crHeaderSplit = TCursor(63);



  // Height changing cursor.

  crVertSplit = TCursor(62);



  UtilityImageSize = 16; // Needed by descendants for hittests.



var // Clipboard format IDs used in OLE drag'n drop and clipboard transfers.

  CF_VIRTUALTREE,

  CF_VTREFERENCE,

  CF_VRTF,

  CF_VRTFNOOBJS,   // Unfortunately CF_RTF* is already defined as being

                   // registration strings so I have to use different identifiers.

  CF_HTML,

  CF_CSV: Word;



  MMXAvailable: Boolean; // necessary to know because the blend code uses MMX instructions

  IsWinVistaOrAbove: Boolean;



  {$MinEnumSize 1, make enumerations as small as possible}



type

  // The exception used by the trees.

  EVirtualTreeError = class(Exception);



  PCardinal = ^Cardinal;



  // Limits the speed interval which can be used for auto scrolling (milliseconds).

  TAutoScrollInterval = 1..1000;



  // Need to declare the correct WMNCPaint record as the VCL (D5-) doesn't.

  {$if CompilerVersion >= 23}

  TRealWMNCPaint = TWMNCPaint;

  {$else}

  TRealWMNCPaint = packed record

    Msg: UINT;

    Rgn: HRGN;

    lParam: LPARAM;

    Result: LRESULT;

  end;



  // The next two message records are not declared in Delphi 6 and lower.

  TWMPrint = packed record

    Msg: UINT;

    DC: HDC;

    Flags: LPARAM;

    Result: LRESULT;

  end;



  TWMPrintClient = TWMPrint;

  {$ifend}



  // Be careful when adding new states as this might change the size of the type which in turn

  // changes the alignment in the node record as well as the stream chunks.

  // Do not reorder the states and always add new states at the end of this enumeration in order to avoid

  // breaking existing code.

  TVirtualNodeState = (

    vsInitialized,       // Set after the node has been initialized.

    vsChecking,          // Node's check state is changing, avoid propagation.

    vsCutOrCopy,         // Node is selected as cut or copy and paste source.

    vsDisabled,          // Set if node is disabled.

    vsDeleting,          // Set when the node is about to be freed.

    vsExpanded,          // Set if the node is expanded.

    vsHasChildren,       // Indicates the presence of child nodes without actually setting them.

    vsVisible,           // Indicate whether the node is visible or not (independant of the expand states of its parents).

    vsSelected,          // Set if the node is in the current selection.

    vsOnFreeNodeCallRequired,   // Set if user data has been set which requires OnFreeNode.

    vsAllChildrenHidden, // Set if vsHasChildren is set and no child node has the vsVisible flag set.

    vsClearing,          // A node's children are being deleted. Don't register structure change event.

    vsMultiline,         // Node text is wrapped at the cell boundaries instead of being shorted.

    vsHeightMeasured,    // Node height has been determined and does not need a recalculation.

    vsToggling,          // Set when a node is expanded/collapsed to prevent recursive calls.

    vsFiltered           // Indicates that the node should not be painted (without effecting its children).

  );

  TVirtualNodeStates = set of TVirtualNodeState;



  // States used in InitNode to indicate states a node shall initially have.

  TVirtualNodeInitState = (

    ivsDisabled,

    ivsExpanded,

    ivsHasChildren,

    ivsMultiline,

    ivsSelected,

    ivsFiltered,

    ivsReInit

  );

  TVirtualNodeInitStates = set of TVirtualNodeInitState;



  TScrollBarStyle = (

    sbmRegular,

    sbm3D

  );



  // Options per column.

  TVTColumnOption = (

    coAllowClick,            // Column can be clicked (must be enabled too).

    coDraggable,             // Column can be dragged.

    coEnabled,               // Column is enabled.

    coParentBidiMode,        // Column uses the parent's bidi mode.

    coParentColor,           // Column uses the parent's background color.

    coResizable,             // Column can be resized.

    coShowDropMark,          // Column shows the drop mark if it is currently the drop target.

    coVisible,               // Column is shown.

    coAutoSpring,            // Column takes part in the auto spring feature of the header (must be resizable too).

    coFixed,                 // Column is fixed and can not be selected or scrolled etc.

    coSmartResize,           // Column is resized to its largest entry which is in view (instead of its largest

                             // visible entry).

    coAllowFocus,            // Column can be focused.

    coDisableAnimatedResize, // Column resizing is not animated.

    coWrapCaption,           // Caption could be wrapped across several header lines to fit columns width.

    coUseCaptionAlignment,   // Column's caption has its own aligment.

    coEditable               // Column can be edited

  );

  TVTColumnOptions = set of TVTColumnOption;



  // These flags are used to indicate where a click in the header happened.

  TVTHeaderHitPosition = (

    hhiNoWhere,         // No column is involved (possible only if the tree is smaller than the client area).

    hhiOnColumn,        // On a column.

    hhiOnIcon,          // On the bitmap associated with a column.

    hhiOnCheckbox       // On the checkbox if enabled.

  );

  TVTHeaderHitPositions = set of TVTHeaderHitPosition;



  // These flags are returned by the hit test method.

  THitPosition = (

    hiAbove,             // above the client area (if relative) or the absolute tree area

    hiBelow,             // below the client area (if relative) or the absolute tree area

    hiNowhere,           // no node is involved (possible only if the tree is not as tall as the client area)

    hiOnItem,            // on the bitmaps/buttons or label associated with an item

    hiOnItemButton,      // on the button associated with an item

    hiOnItemButtonExact, // exactly on the button associated with an item

    hiOnItemCheckbox,    // on the checkbox if enabled

    hiOnItemIndent,      // in the indentation area in front of a node

    hiOnItemLabel,       // on the normal text area associated with an item

    hiOnItemLeft,        // in the area to the left of a node's text area (e.g. when right aligned or centered)

    hiOnItemRight,       // in the area to the right of a node's text area (e.g. if left aligned or centered)

    hiOnNormalIcon,      // on the "normal" image

    hiOnStateIcon,       // on the state image

    hiToLeft,            // to the left of the client area (if relative) or the absolute tree area

    hiToRight,           // to the right of the client area (if relative) or the absolute tree area

    hiUpperSplitter,     // in the upper splitter area of a node

    hiLowerSplitter      // in the lower splitter area of a node

  );

  THitPositions = set of THitPosition;



  TCheckType = (

    ctNone,

    ctTriStateCheckBox,

    ctCheckBox,

    ctRadioButton,

    ctButton

  );



  // The check states include both, transient and fluent (temporary) states. The only temporary state defined so

  // far is the pressed state.

  TCheckState = (

    csUncheckedNormal,  // unchecked and not pressed

    csUncheckedPressed, // unchecked and pressed

    csCheckedNormal,    // checked and not pressed

    csCheckedPressed,   // checked and pressed

    csMixedNormal,      // 3-state check box and not pressed

    csMixedPressed      // 3-state check box and pressed

  );



  TCheckImageKind = (

    ckLightCheck,     // gray cross

    ckDarkCheck,      // black cross

    ckLightTick,      // gray tick mark

    ckDarkTick,       // black tick mark

    ckFlat,           // flat images (no 3D border)

    ckXP,             // Windows XP style

    ckCustom,         // application defined check images

    ckSystemFlat,     // Flat system defined check images.

    ckSystemDefault   // Uses the system check images, theme aware.

  );



  // mode to describe a move action

  TVTNodeAttachMode = (

    amNoWhere,        // just for simplified tests, means to ignore the Add/Insert command

    amInsertBefore,   // insert node just before destination (as sibling of destination)

    amInsertAfter,    // insert node just after destionation (as sibling of destination)

    amAddChildFirst,  // add node as first child of destination

    amAddChildLast    // add node as last child of destination

  );



  // modes to determine drop position further

  TDropMode = (

    dmNowhere,

    dmAbove,

    dmOnNode,

    dmBelow

  );



  // operations basically allowed during drag'n drop

  TDragOperation = (

    doCopy,

    doMove,

    doLink

  );

  TDragOperations = set of TDragOperation;



  TVTImageKind = (

    ikNormal,

    ikSelected,

    ikState,

    ikOverlay

  );



  TVTHintMode = (

    hmDefault,            // show the hint of the control

    hmHint,               // show node specific hint string returned by the application

    hmHintAndDefault,     // same as hmHint but show the control's hint if no node is concerned

    hmTooltip             // show the text of the node if it isn't already fully shown

  );



  // Indicates how to format a tooltip.

  TVTTooltipLineBreakStyle = (

    hlbDefault,           // Use multi-line style of the node.

    hlbForceSingleLine,   // Use single line hint.

    hlbForceMultiLine     // Use multi line hint.

  );



  TMouseButtons = set of TMouseButton;



  // Used to describe the action to do when using the OnBeforeItemErase event.

  TItemEraseAction = (

    eaColor,   // Use the provided color to erase the background instead the one of the tree.

    eaDefault, // The tree should erase the item's background (bitmap or solid).

    eaNone     // Do nothing. Let the application paint the background.

  );





  // There is a heap of switchable behavior in the tree. Since published properties may never exceed 4 bytes,

  // which limits sets to at most 32 members, and because for better overview tree options are splitted

  // in various sub-options and are held in a commom options class.

  //

  // Options to customize tree appearance:

  TVTPaintOption = (

    toHideFocusRect,           // Avoid drawing the dotted rectangle around the currently focused node.

    toHideSelection,           // Selected nodes are drawn as unselected nodes if the tree is unfocused.

    toHotTrack,                // Track which node is under the mouse cursor.

    toPopupMode,               // Paint tree as would it always have the focus (useful for tree combo boxes etc.)

    toShowBackground,          // Use the background image if there's one.

    toShowButtons,             // Display collapse/expand buttons left to a node.

    toShowDropmark,            // Show the dropmark during drag'n drop operations.

    toShowHorzGridLines,       // Display horizontal lines to simulate a grid.

    toShowRoot,                // Show lines also at top level (does not show the hidden/internal root node).

    toShowTreeLines,           // Display tree lines to show hierarchy of nodes.

    toShowVertGridLines,       // Display vertical lines (depending on columns) to simulate a grid.

    toThemeAware,              // Draw UI elements (header, tree buttons etc.) according to the current theme if

                               // enabled (Windows XP+ only, application must be themed).

    toUseBlendedImages,        // Enable alpha blending for ghosted nodes or those which are being cut/copied.

    toGhostedIfUnfocused,      // Ghosted images are still shown as ghosted if unfocused (otherwise the become non-ghosted

                               // images).

    toFullVertGridLines,       // Display vertical lines over the full client area, not only the space occupied by nodes.

                               // This option only has an effect if toShowVertGridLines is enabled too.

    toAlwaysHideSelection,     // Do not draw node selection, regardless of focused state.

    toUseBlendedSelection,     // Enable alpha blending for node selections.

    toStaticBackground,        // Show simple static background instead of a tiled one.

    toChildrenAbove,           // Display child nodes above their parent.

    toFixedIndent,             // Draw the tree with a fixed indent.

    toUseExplorerTheme,        // Use the explorer theme if run under Windows Vista (or above).

    toHideTreeLinesIfThemed,   // Do not show tree lines if theming is used.

    toShowFilteredNodes        // Draw nodes even if they are filtered out.

  );

  TVTPaintOptions = set of TVTPaintOption;



  // Options to toggle animation support:

  TVTAnimationOption = (

    toAnimatedToggle,          // Expanding and collapsing a node is animated (quick window scroll).

    toAdvancedAnimatedToggle   // Do some advanced animation effects when toggling a node.

  );

  TVTAnimationOptions = set of TVTAnimationOption;



  // Options which toggle automatic handling of certain situations:

  TVTAutoOption = (

    toAutoDropExpand,           // Expand node if it is the drop target for more than a certain time.

    toAutoExpand,               // Nodes are expanded (collapsed) when getting (losing) the focus.

    toAutoScroll,               // Scroll if mouse is near the border while dragging or selecting.

    toAutoScrollOnExpand,       // Scroll as many child nodes in view as possible after expanding a node.

    toAutoSort,                 // Sort tree when Header.SortColumn or Header.SortDirection change or sort node if

                                // child nodes are added.

    toAutoSpanColumns,          // Large entries continue into next column(s) if there's no text in them (no clipping).

    toAutoTristateTracking,     // Checkstates are automatically propagated for tri state check boxes.

    toAutoHideButtons,          // Node buttons are hidden when there are child nodes, but all are invisible.

    toAutoDeleteMovedNodes,     // Delete nodes which where moved in a drag operation (if not directed otherwise).

    toDisableAutoscrollOnFocus, // Disable scrolling a node or column into view if it gets focused.

    toAutoChangeScale,          // Change default node height automatically if the system's font scale is set to big fonts.

    toAutoFreeOnCollapse,       // Frees any child node after a node has been collapsed (HasChildren flag stays there).

    toDisableAutoscrollOnEdit,  // Do not center a node horizontally when it is edited.

    toAutoBidiColumnOrdering    // When set then columns (if any exist) will be reordered from lowest index to highest index

                                // and vice versa when the tree's bidi mode is changed.

  );

  TVTAutoOptions = set of TVTAutoOption;



  // Options which determine the tree's behavior when selecting nodes:

  TVTSelectionOption = (

    toDisableDrawSelection,    // Prevent user from selecting with the selection rectangle in multiselect mode.

    toExtendedFocus,           // Entries other than in the main column can be selected, edited etc.

    toFullRowSelect,           // Hit test as well as selection highlight are not constrained to the text of a node.

    toLevelSelectConstraint,   // Constrain selection to the same level as the selection anchor.

    toMiddleClickSelect,       // Allow selection, dragging etc. with the middle mouse button. This and toWheelPanning

                               // are mutual exclusive.

    toMultiSelect,             // Allow more than one node to be selected.

    toRightClickSelect,        // Allow selection, dragging etc. with the right mouse button.

    toSiblingSelectConstraint, // Constrain selection to nodes with same parent.

    toCenterScrollIntoView,    // Center nodes vertically in the client area when scrolling into view.

    toSimpleDrawSelection,     // Simplifies draw selection, so a node's caption does not need to intersect with the

                               // selection rectangle.

    toAlwaysSelectNode,        // If this flag is set to true, the tree view tries to always have a node selected.

                               // This behavior is closer to the Windows TreeView and useful in Windows Explorer style applications.

    toRestoreSelection         // Set to true if upon refill the previously selected nodes should be selected again.

                               // The nodes will be identified by its caption only.

  );

  TVTSelectionOptions = set of TVTSelectionOption;



  // Options which do not fit into any of the other groups:

  TVTMiscOption = (

    toAcceptOLEDrop,            // Register tree as OLE accepting drop target

    toCheckSupport,             // Show checkboxes/radio buttons.

    toEditable,                 // Node captions can be edited.

    toFullRepaintOnResize,      // Fully invalidate the tree when its window is resized (CS_HREDRAW/CS_VREDRAW).

    toGridExtensions,           // Use some special enhancements to simulate and support grid behavior.

    toInitOnSave,               // Initialize nodes when saving a tree to a stream.

    toReportMode,               // Tree behaves like TListView in report mode.

    toToggleOnDblClick,         // Toggle node expansion state when it is double clicked.

    toWheelPanning,             // Support for mouse panning (wheel mice only). This option and toMiddleClickSelect are

                                // mutal exclusive, where panning has precedence.

    toReadOnly,                 // The tree does not allow to be modified in any way. No action is executed and

                                // node editing is not possible.

    toVariableNodeHeight,       // When set then GetNodeHeight will trigger OnMeasureItem to allow variable node heights.

    toFullRowDrag,              // Start node dragging by clicking anywhere in it instead only on the caption or image.

                                // Must be used together with toDisableDrawSelection.

    toNodeHeightResize,         // Allows changing a node's height via mouse.

    toNodeHeightDblClickResize, // Allows to reset a node's height to FDefaultNodeHeight via a double click.

    toEditOnClick,              // Editing mode can be entered with a single click

    toEditOnDblClick,           // Editing mode can be entered with a double click

    toReverseFullExpandHotKey   // Used to define Ctrl+'+' instead of Ctrl+Shift+'+' for full expand (and similar for collapsing)

  );

  TVTMiscOptions = set of TVTMiscOption;



  // Options to control data export

  TVTExportMode = (

    emAll,        // export all records (regardless checked state)

    emChecked,    // export checked records only

    emUnchecked,   // export unchecked records only

    emVisibleDueToExpansion, //Do not export nodes that are not visible because their parent is not expanded

    emSelected // export selected nodes only

  );



  // Kinds of operations

  TVTOperationKind = (

    okAutoFitColumns,

    okGetMaxColumnWidth,

    okSortNode,

    okSortTree

  );

  TVTOperationKinds = set of TVTOperationKind;



const

  DefaultPaintOptions = [toShowButtons, toShowDropmark, toShowTreeLines, toShowRoot, toThemeAware, toUseBlendedImages];

  DefaultAnimationOptions = [];

  DefaultAutoOptions = [toAutoDropExpand, toAutoTristateTracking, toAutoScrollOnExpand, toAutoDeleteMovedNodes, toAutoChangeScale, toAutoSort];

  DefaultSelectionOptions = [];

  DefaultMiscOptions = [toAcceptOLEDrop, toFullRepaintOnResize, toInitOnSave, toToggleOnDblClick, toWheelPanning,

    toEditOnClick];

  DefaultColumnOptions = [coAllowClick, coDraggable, coEnabled, coParentColor, coParentBidiMode, coResizable,

    coShowDropmark, coVisible, coAllowFocus, coEditable];



type

  TBaseVirtualTree = class;

  TVirtualTreeClass = class of TBaseVirtualTree;



  PVirtualNode = ^TVirtualNode;



  TColumnIndex = type Integer;

  TColumnPosition = type Cardinal;



  // This record must already be defined here and not later because otherwise BCB users will not be able

  // to compile (conversion done by BCB is wrong).

  TCacheEntry = record

    Node: PVirtualNode;

    AbsoluteTop: Cardinal;

  end;



  TCache = array of TCacheEntry;

  TNodeArray = array of PVirtualNode;



  TCustomVirtualTreeOptions = class(TPersistent)

  private

    FOwner: TBaseVirtualTree;

    FPaintOptions: TVTPaintOptions;

    FAnimationOptions: TVTAnimationOptions;

    FAutoOptions: TVTAutoOptions;

    FSelectionOptions: TVTSelectionOptions;

    FMiscOptions: TVTMiscOptions;

    FExportMode: TVTExportMode;

    procedure SetAnimationOptions(const Value: TVTAnimationOptions);

    procedure SetAutoOptions(const Value: TVTAutoOptions);

    procedure SetMiscOptions(const Value: TVTMiscOptions);

    procedure SetPaintOptions(const Value: TVTPaintOptions);

    procedure SetSelectionOptions(const Value: TVTSelectionOptions);

  protected

    property AnimationOptions: TVTAnimationOptions read FAnimationOptions write SetAnimationOptions

      default DefaultAnimationOptions;

    property AutoOptions: TVTAutoOptions read FAutoOptions write SetAutoOptions default DefaultAutoOptions;

    property ExportMode: TVTExportMode read FExportMode write FExportMode default emAll;

    property MiscOptions: TVTMiscOptions read FMiscOptions write SetMiscOptions default DefaultMiscOptions;

    property PaintOptions: TVTPaintOptions read FPaintOptions write SetPaintOptions default DefaultPaintOptions;

    property SelectionOptions: TVTSelectionOptions read FSelectionOptions write SetSelectionOptions

      default DefaultSelectionOptions;

  public

    constructor Create(AOwner: TBaseVirtualTree); virtual;



    procedure AssignTo(Dest: TPersistent); override;



    property Owner: TBaseVirtualTree read FOwner;

  end;



  TTreeOptionsClass = class of TCustomVirtualTreeOptions;



  TVirtualTreeOptions = class(TCustomVirtualTreeOptions)

  published

    property AnimationOptions;

    property AutoOptions;

    property ExportMode;

    property MiscOptions;

    property PaintOptions;

    property SelectionOptions;

  end;



  // Used in the CF_VTREFERENCE clipboard format.

  PVTReference = ^TVTReference;

  TVTReference = record

    Process: Cardinal;

    Tree: TBaseVirtualTree;

  end;



  TVirtualNode = packed record

    Index,                   // index of node with regard to its parent

    ChildCount: Cardinal;    // number of child nodes

    NodeHeight: Word;        // height in pixels

    States: TVirtualNodeStates; // states describing various properties of the node (expanded, initialized etc.)

    Align: Byte;             // line/button alignment

    CheckState: TCheckState; // indicates the current check state (e.g. checked, pressed etc.)

    CheckType: TCheckType;   // indicates which check type shall be used for this node

    Dummy: Byte;             // dummy value to fill DWORD boundary

    TotalCount,              // sum of this node, all of its child nodes and their child nodes etc.

    TotalHeight: Cardinal;   // height in pixels this node covers on screen including the height of all of its

                             // children

    // Note: Some copy routines require that all pointers (as well as the data area) in a node are

    //       located at the end of the node! Hence if you want to add new member fields (except pointers to internal

    //       data) then put them before field Parent.

    Parent,                  // reference to the node's parent (for the root this contains the treeview)

    PrevSibling,             // link to the node's previous sibling or nil if it is the first node

    NextSibling,             // link to the node's next sibling or nil if it is the last node

    FirstChild,              // link to the node's first child...

    LastChild: PVirtualNode; // link to the node's last child...

    Data: record end;        // this is a placeholder, each node gets extra data determined by NodeDataSize

  end;



  // Structure used when info about a certain position in the header is needed.

  TVTHeaderHitInfo = record

    X,

    Y: Integer;

    Button: TMouseButton;

    Shift: TShiftState;

    Column: TColumnIndex;

    HitPosition: TVTHeaderHitPositions;

  end;



  // Structure used when info about a certain position in the tree is needed.

  THitInfo = record

    HitNode: PVirtualNode;

    HitPositions: THitPositions;

    HitColumn: TColumnIndex;

    HitPoint: TPoint;

  end;



  // auto scroll directions

  TScrollDirections = set of (

    sdLeft,

    sdUp,

    sdRight,

    sdDown

  );



  // OLE drag'n drop support

  TFormatEtcArray = array of TFormatEtc;

  TFormatArray = array of Word;



  // IDataObject.SetData support

  TInternalStgMedium = packed record

    Format: TClipFormat;

    Medium: TStgMedium;

  end;

  TInternalStgMediumArray = array of TInternalStgMedium;



  TEnumFormatEtc = class(TInterfacedObject, IEnumFormatEtc)

  private

    FTree: TBaseVirtualTree;

    FFormatEtcArray: TFormatEtcArray;

    FCurrentIndex: Integer;

  public

    constructor Create(Tree: TBaseVirtualTree; AFormatEtcArray: TFormatEtcArray);



    function Clone(out Enum: IEnumFormatEtc): HResult; stdcall;

    function Next(celt: Integer; out elt; pceltFetched: PLongint): HResult; stdcall;

    function Reset: HResult; stdcall;

    function Skip(celt: Integer): HResult; stdcall;

  end;



  // ----- OLE drag'n drop handling



{$if CompilerVersion < 21}

  {$EXTERNALSYM IDropTargetHelper}



  IDropTargetHelper = interface(IUnknown)

    [SID_IDropTargetHelper]

    function DragEnter(hwndTarget: HWND; pDataObject: IDataObject; var ppt: TPoint; dwEffect: Integer): HRESULT; stdcall;

    function DragLeave: HRESULT; stdcall;

    function DragOver(var ppt: TPoint; dwEffect: Integer): HRESULT; stdcall;

    function Drop(pDataObject: IDataObject; var ppt: TPoint; dwEffect: Integer): HRESULT; stdcall;

    function Show(fShow: Boolean): HRESULT; stdcall;

  end;



  PSHDragImage = ^TSHDragImage;

  TSHDragImage = packed record

    sizeDragImage: TSize;

    ptOffset: TPoint;

    hbmpDragImage: HBITMAP;

    crColorKey: TColorRef;

  end;



  IDragSourceHelper = interface(IUnknown)

    [SID_IDragSourceHelper]

    function InitializeFromBitmap(SHDragImage: PSHDragImage; pDataObject: IDataObject): HRESULT; stdcall;

    function InitializeFromWindow(Window: HWND; var ppt: TPoint; pDataObject: IDataObject): HRESULT; stdcall;

  end;

  {$EXTERNALSYM IDragSourceHelper}



    IDragSourceHelper2 = interface(IDragSourceHelper)

  [SID_IDragSourceHelper2]

    function SetFlags(dwFlags: DWORD): HRESULT; stdcall;

  end;

  {$EXTERNALSYM IDragSourceHelper2}

{$ifend}



  IVTDragManager = interface(IUnknown)

    ['{C4B25559-14DA-446B-8901-0C879000EB16}']

    procedure ForceDragLeave; stdcall;

    function GetDataObject: IDataObject; stdcall;

    function GetDragSource: TBaseVirtualTree; stdcall;

    function GetDropTargetHelperSupported: Boolean; stdcall;

    function GetIsDropTarget: Boolean; stdcall;



    property DataObject: IDataObject read GetDataObject;

    property DragSource: TBaseVirtualTree read GetDragSource;

    property DropTargetHelperSupported: Boolean read GetDropTargetHelperSupported;

    property IsDropTarget: Boolean read GetIsDropTarget;

  end;



  // This data object is used in two different places. One is for clipboard operations and the other while dragging.

  TVTDataObject = class(TInterfacedObject, IDataObject)

  private

    FOwner: TBaseVirtualTree;          // The tree which provides clipboard or drag data.

    FForClipboard: Boolean;            // Determines which data to render with GetData.

    FFormatEtcArray: TFormatEtcArray;

    FInternalStgMediumArray: TInternalStgMediumArray;  // The available formats in the DataObject

    FAdviseHolder: IDataAdviseHolder;  // Reference to an OLE supplied implementation for advising.

  protected

    function CanonicalIUnknown(TestUnknown: IUnknown): IUnknown;

    function EqualFormatEtc(FormatEtc1, FormatEtc2: TFormatEtc): Boolean;

    function FindFormatEtc(TestFormatEtc: TFormatEtc; const FormatEtcArray: TFormatEtcArray): integer;

    function FindInternalStgMedium(Format: TClipFormat): PStgMedium;

    function HGlobalClone(HGlobal: THandle): THandle;

    function RenderInternalOLEData(const FormatEtcIn: TFormatEtc; var Medium: TStgMedium; var OLEResult: HResult): Boolean;

    function StgMediumIncRef(const InStgMedium: TStgMedium; var OutStgMedium: TStgMedium;

      CopyInMedium: Boolean; DataObject: IDataObject): HRESULT;



    property ForClipboard: Boolean read FForClipboard;

    property FormatEtcArray: TFormatEtcArray read FFormatEtcArray write FFormatEtcArray;

    property InternalStgMediumArray: TInternalStgMediumArray read FInternalStgMediumArray write FInternalStgMediumArray;

    property Owner: TBaseVirtualTree read FOwner;

  public

    constructor Create(AOwner: TBaseVirtualTree; ForClipboard: Boolean); virtual;

    destructor Destroy; override;



    function DAdvise(const FormatEtc: TFormatEtc; advf: Integer; const advSink: IAdviseSink; out dwConnection: Integer):

      HResult; virtual; stdcall;

    function DUnadvise(dwConnection: Integer): HResult; virtual; stdcall;

    function EnumDAdvise(out enumAdvise: IEnumStatData): HResult; virtual; stdcall;

    function EnumFormatEtc(Direction: Integer; out EnumFormatEtc: IEnumFormatEtc): HResult; virtual; stdcall;

    function GetCanonicalFormatEtc(const FormatEtc: TFormatEtc; out FormatEtcOut: TFormatEtc): HResult; virtual; stdcall;

    function GetData(const FormatEtcIn: TFormatEtc; out Medium: TStgMedium): HResult; virtual; stdcall;

    function GetDataHere(const FormatEtc: TFormatEtc; out Medium: TStgMedium): HResult; virtual; stdcall;

    function QueryGetData(const FormatEtc: TFormatEtc): HResult; virtual; stdcall;

    function SetData(const FormatEtc: TFormatEtc; var Medium: TStgMedium; DoRelease: BOOL): HResult; virtual; stdcall;

  end;



  // TVTDragManager is a class to manage drag and drop in a Virtual Treeview.

  TVTDragManager = class(TInterfacedObject, IVTDragManager, IDropSource, IDropTarget)

  private

    FOwner,                            // The tree which is responsible for drag management.

    FDragSource: TBaseVirtualTree;     // Reference to the source tree if the source was a VT, might be different than

                                       // the owner tree.

    FIsDropTarget: Boolean;            // True if the owner is currently the drop target.

    FDataObject: IDataObject;          // A reference to the data object passed in by DragEnter (only used when the owner

                                       // tree is the current drop target).

    FDropTargetHelper: IDropTargetHelper; // Win2k > Drag image support

    FFullDragging: BOOL;               // True, if full dragging is currently enabled in the system.



    function GetDataObject: IDataObject; stdcall;

    function GetDragSource: TBaseVirtualTree; stdcall;

    function GetDropTargetHelperSupported: Boolean; stdcall;

    function GetIsDropTarget: Boolean; stdcall;

  public

    constructor Create(AOwner: TBaseVirtualTree); virtual;

    destructor Destroy; override;



    function DragEnter(const DataObject: IDataObject; KeyState: Integer; Pt: TPoint;

      var Effect: Longint): HResult; stdcall;

    function DragLeave: HResult; stdcall;

    function DragOver(KeyState: Integer; Pt: TPoint; var Effect: LongInt): HResult; stdcall;

    function Drop(const DataObject: IDataObject; KeyState: Integer; Pt: TPoint; var Effect: Integer): HResult; stdcall;

    procedure ForceDragLeave; stdcall;

    function GiveFeedback(Effect: Integer): HResult; stdcall;

    function QueryContinueDrag(EscapePressed: BOOL; KeyState: Integer): HResult; stdcall;

  end;



  PVTHintData = ^TVTHintData;

  TVTHintData = record

    Tree: TBaseVirtualTree;

    Node: PVirtualNode;

    Column: TColumnIndex;

    HintRect: TRect;            // used for draw trees only, string trees get the size from the hint string

    DefaultHint: UnicodeString; // used only if there is no node specific hint string available

                                // or a header hint is about to appear

    HintText: UnicodeString;    // set when size of the hint window is calculated

    BidiMode: TBidiMode;

    Alignment: TAlignment;

    LineBreakStyle: TVTToolTipLineBreakStyle;

  end;



  // Determines the kind of animation when a hint is activated.

  THintAnimationType = (

    hatNone,                 // no animation at all, just display hint/tooltip

    hatFade,                 // fade in the hint/tooltip, like in Windows 2000

    hatSlide,                // slide in the hint/tooltip, like in Windows 98

    hatSystemDefault         // use what the system is using (slide for Win9x, slide/fade for Win2K+, depends on settings)

  );



  // The trees need an own hint window class because of Unicode output and adjusted font.

  TVirtualTreeHintWindow = class(THintWindow)

  private

    FHintData: TVTHintData;

    FBackground,

    FDrawBuffer,

    FTarget: TBitmap;

    FTextHeight: Integer;

    function AnimationCallback(Step, StepSize: Integer; Data: Pointer): Boolean;

    procedure CMTextChanged(var Message: TMessage); message CM_TEXTCHANGED;

    function GetHintWindowDestroyed: Boolean;

    procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND;

    procedure WMNCPaint(var Message: TMessage); message WM_NCPAINT;

    procedure WMShowWindow(var Message: TWMShowWindow); message WM_SHOWWINDOW;

  protected

    procedure CreateParams(var Params: TCreateParams); override;

    procedure InternalPaint(Step, StepSize: Integer);

    procedure Paint; override;



    property Background: TBitmap read FBackground;

    property DrawBuffer: TBitmap read FDrawBuffer;

    property HintData: TVTHintData read FHintData;

    property HintWindowDestroyed: Boolean read GetHintWindowDestroyed;

    property Target: TBitmap read FTarget;

    property TextHeight: Integer read FTextHeight;

  public

    constructor Create(AOwner: TComponent); override;

    destructor Destroy; override;



    procedure ActivateHint(Rect: TRect; const AHint: string); override;

    function CalcHintRect(MaxWidth: Integer; const AHint: string; AData: Pointer): TRect; override;

    function IsHintMsg(var Msg: TMsg): Boolean; override;

  end;



  // Drag image support for the tree.

  TVTTransparency = 0..255;

  TVTBias = -128..127;



  // Simple move limitation for the drag image.

  TVTDragMoveRestriction = (

    dmrNone,

    dmrHorizontalOnly,

    dmrVerticalOnly

  );



  TVTDragImageStates = set of (

    disHidden,          // Internal drag image is currently hidden (always hidden if drag image helper interfaces are used).

    disInDrag,          // Drag image class is currently being used.

    disPrepared,        // Drag image class is prepared.

    disSystemSupport    // Running on Windows 2000 or higher. System supports drag images natively.

  );



  // Class to manage header and tree drag image during a drag'n drop operation.

  TVTDragImage = class

  private

    FOwner: TBaseVirtualTree;

    FBackImage,                        // backup of overwritten screen area

    FAlphaImage,                       // target for alpha blending

    FDragImage: TBitmap;               // the actual drag image to blend to screen

    FImagePosition,                    // position of image (upper left corner) in screen coordinates

    FLastPosition: TPoint;             // last mouse position in screen coordinates

    FTransparency: TVTTransparency;    // alpha value of the drag image (0 - fully transparent, 255 - fully opaque)

    FPreBlendBias,                     // value to darken or lighten the drag image before it is blended

    FPostBlendBias: TVTBias;           // value to darken or lighten the alpha blend result

    FFade: Boolean;                    // determines whether to fade the drag image from center to borders or not

    FRestriction: TVTDragMoveRestriction;  // determines in which directions the drag image can be moved

    FColorKey: TColor;                 // color to make fully transparent regardless of any other setting

    FStates: TVTDragImageStates;       // Determines the states of the drag image class.

    function GetVisible: Boolean;      // True if the drag image is currently hidden (used only when dragging)

  protected

    procedure InternalShowDragImage(ScreenDC: HDC);

    procedure MakeAlphaChannel(Source, Target: TBitmap);

  public

    constructor Create(AOwner: TBaseVirtualTree);

    destructor Destroy; override;



    function DragTo(P: TPoint; ForceRepaint: Boolean): Boolean;

    procedure EndDrag;

    function GetDragImageRect: TRect;

    procedure HideDragImage;

    procedure PrepareDrag(DragImage: TBitmap; ImagePosition, HotSpot: TPoint; const DataObject: IDataObject);

    procedure RecaptureBackground(Tree: TBaseVirtualTree; R: TRect; VisibleRegion: HRGN; CaptureNCArea,

      ReshowDragImage: Boolean);

    procedure ShowDragImage;

    function WillMove(P: TPoint): Boolean;



    property ColorKey: TColor read FColorKey write FColorKey default clWindow;

    property Fade: Boolean read FFade write FFade default False;

    property MoveRestriction: TVTDragMoveRestriction read FRestriction write FRestriction default dmrNone;

    property PostBlendBias: TVTBias read FPostBlendBias write FPostBlendBias default 0;

    property PreBlendBias: TVTBias read FPreBlendBias write FPreBlendBias default 0;

    property Transparency: TVTTransparency read FTransparency write FTransparency default 128;

    property Visible: Boolean read GetVisible;

  end;



  // tree columns implementation

  TVirtualTreeColumns = class;

  TVTHeader = class;



  TVirtualTreeColumnStyle = (

    vsText,

    vsOwnerDraw

  );



  TVTHeaderColumnLayout = (

    blGlyphLeft,

    blGlyphRight,

    blGlyphTop,

    blGlyphBottom

  );



  TSortDirection = (

    sdAscending,

    sdDescending

  );



  TVirtualTreeColumn = class(TCollectionItem)

  private

    FText,

    FHint: UnicodeString;

    FLeft,

    FWidth: Integer;

    FPosition: TColumnPosition;

    FMinWidth: Integer;

    FMaxWidth: Integer;

    FStyle: TVirtualTreeColumnStyle;

    FImageIndex: TImageIndex;

    FBiDiMode: TBiDiMode;

    FLayout: TVTHeaderColumnLayout;

    FMargin,

    FSpacing: Integer;

    FOptions: TVTColumnOptions;

    FTag: NativeInt;

    FAlignment: TAlignment;

    FCaptionAlignment: TAlignment;     // Alignment of the caption.

    FLastWidth: Integer;

    FColor: TColor;

    FBonusPixel: Boolean;

    FSpringRest: Single;               // Accumulator for width adjustment when auto spring option is enabled.

    FCaptionText: UnicodeString;

    FCheckBox: Boolean;

    FCheckType: TCheckType;

    FCheckState: TCheckState;

    FImageRect: TRect;

    FHasImage: Boolean;

    FDefaultSortDirection: TSortDirection;

    function GetCaptionAlignment: TAlignment;

    function GetLeft: Integer;

    function IsBiDiModeStored: Boolean;

    function IsCaptionAlignmentStored: Boolean;

    function IsColorStored: Boolean;

    procedure SetAlignment(const Value: TAlignment);

    procedure SetBiDiMode(Value: TBiDiMode);

    procedure SetCaptionAlignment(const Value: TAlignment);

    procedure SetCheckBox(Value: Boolean);

    procedure SetCheckState(Value: TCheckState);

    procedure SetCheckType(Value: TCheckType);

    procedure SetColor(const Value: TColor);

    procedure SetImageIndex(Value: TImageIndex);

    procedure SetLayout(Value: TVTHeaderColumnLayout);

    procedure SetMargin(Value: Integer);

    procedure SetMaxWidth(Value: Integer);

    procedure SetMinWidth(Value: Integer);

    procedure SetOptions(Value: TVTColumnOptions);

    procedure SetPosition(Value: TColumnPosition);

    procedure SetSpacing(Value: Integer);

    procedure SetStyle(Value: TVirtualTreeColumnStyle);

    procedure SetWidth(Value: Integer);

  protected

    procedure ComputeHeaderLayout(DC: HDC; Client: TRect; UseHeaderGlyph, UseSortGlyph: Boolean;

      var HeaderGlyphPos, SortGlyphPos: TPoint; var SortGlyphSize: TSize; var TextBounds: TRect; DrawFormat: Cardinal;

      CalculateTextRect: Boolean = False);

    procedure DefineProperties(Filer: TFiler); override;

    procedure GetAbsoluteBounds(var Left, Right: Integer);

    function GetDisplayName: string; override;

    function GetText: UnicodeString; virtual; // [IPK]

    procedure SetText(const Value: UnicodeString); virtual; // [IPK] private to protected & virtual

    function GetOwner: TVirtualTreeColumns; reintroduce;

    procedure ReadHint(Reader: TReader);

    procedure ReadText(Reader: TReader);

    procedure WriteHint(Writer: TWriter);

    procedure WriteText(Writer: TWriter);

    property HasImage: Boolean read FHasImage;

    property ImageRect: TRect read FImageRect;

  public

    constructor Create(Collection: TCollection); override;

    destructor Destroy; override;



    procedure Assign(Source: TPersistent); override;

{$if CompilerVersion >= 20}

   function Equals(OtherColumnObj: TObject): Boolean; override;

{$else}

   function Equals(OtherColumnObj: TObject): Boolean; virtual; 

{$ifend}

    function GetRect: TRect; virtual;

    procedure LoadFromStream(const Stream: TStream; Version: Integer);

    procedure ParentBiDiModeChanged;

    procedure ParentColorChanged;

    procedure RestoreLastWidth;

    procedure SaveToStream(const Stream: TStream);

    function UseRightToLeftReading: Boolean;



    property Left: Integer read GetLeft;

    property Owner: TVirtualTreeColumns read GetOwner;

  published

    property Alignment: TAlignment read FAlignment write SetAlignment default taLeftJustify;

    property BiDiMode: TBiDiMode read FBiDiMode write SetBiDiMode stored IsBiDiModeStored;

    property CaptionAlignment: TAlignment read GetCaptionAlignment write SetCaptionAlignment

      stored IsCaptionAlignmentStored default taLeftJustify;

    property CaptionText: UnicodeString read FCaptionText stored False;

    property CheckType: TCheckType read FCheckType write SetCheckType default ctCheckBox;

    property CheckState: TCheckState read FCheckState write SetCheckState default csUncheckedNormal;

    property CheckBox: Boolean read FCheckBox write SetCheckBox default False;

    property Color: TColor read FColor write SetColor stored IsColorStored;

    property DefaultSortDirection: TSortDirection read FDefaultSortDirection write FDefaultSortDirection default sdAscending;

    property Hint: UnicodeString read FHint write FHint stored False;

    property ImageIndex: TImageIndex read FImageIndex write SetImageIndex default -1;

    property Layout: TVTHeaderColumnLayout read FLayout write SetLayout default blGlyphLeft;

    property Margin: Integer read FMargin write SetMargin default 4;

    property MaxWidth: Integer read FMaxWidth write SetMaxWidth default 10000;

    property MinWidth: Integer read FMinWidth write SetMinWidth default 10;

    property Options: TVTColumnOptions read FOptions write SetOptions default DefaultColumnOptions;

    property Position: TColumnPosition read FPosition write SetPosition;

    property Spacing: Integer read FSpacing write SetSpacing default 3;

    property Style: TVirtualTreeColumnStyle read FStyle write SetStyle default vsText;

    property Tag: NativeInt read FTag write FTag default 0;

    property Text: UnicodeString read GetText write SetText stored False; // Never let the VCL store the wide string,  // [IPK] FText changed to GetText

                                                                     // it is simply unable to write it correctly.

                                                                     // We use DefineProperties here.

    property Width: Integer read FWidth write SetWidth default 50;

  end;



  TVirtualTreeColumnClass = class of TVirtualTreeColumn;



  TColumnsArray = array of TVirtualTreeColumn;

  TCardinalArray = array of Cardinal;

  TIndexArray = array of TColumnIndex;



  TVirtualTreeColumns = class(TCollection)

  private

    FHeader: TVTHeader;

    FHeaderBitmap: TBitmap;               // backbuffer for drawing

    FHoverIndex,                          // currently "hot" column

    FDownIndex,                           // Column on which a mouse button is held down.

    FTrackIndex: TColumnIndex;            // Index of column which is currently being resized.

    FClickIndex: TColumnIndex;            // Index of the last clicked column.

    FCheckBoxHit: Boolean;                // True if the last click was on a header checkbox.

    FPositionToIndex: TIndexArray;

    FDefaultWidth: Integer;               // the width columns are created with

    FNeedPositionsFix: Boolean;           // True if FixPositions must still be called after DFM loading or Bidi mode change.

    FClearing: Boolean;                   // True if columns are being deleted entirely.



    function GetCount: Integer;

    function GetItem(Index: TColumnIndex): TVirtualTreeColumn;

    function GetNewIndex(P: TPoint; var OldIndex: TColumnIndex): Boolean;

    procedure SetDefaultWidth(Value: Integer);

    procedure SetItem(Index: TColumnIndex; Value: TVirtualTreeColumn);

  protected

    // drag support

    FDragIndex: TColumnIndex;             // index of column currently being dragged

    FDropTarget: TColumnIndex;            // current target column (index) while dragging

    FDropBefore: Boolean;                 // True if drop position is in the left half of a column, False for the right

                                          // side to drop the dragged column to



    procedure AdjustAutoSize(CurrentIndex: TColumnIndex; Force: Boolean = False);

    function AdjustDownColumn(P: TPoint): TColumnIndex;

    function AdjustHoverColumn(P: TPoint): Boolean;

    procedure AdjustPosition(Column: TVirtualTreeColumn; Position: Cardinal);

    function CanSplitterResize(P: TPoint; Column: TColumnIndex): Boolean;

    procedure DoCanSplitterResize(P: TPoint; Column: TColumnIndex; var Allowed: Boolean); virtual;

    procedure DrawButtonText(DC: HDC; Caption: UnicodeString; Bounds: TRect; Enabled, Hot: Boolean; DrawFormat: Cardinal;

      WrapCaption: Boolean);

    procedure FixPositions;

    function GetColumnAndBounds(P: TPoint; var ColumnLeft, ColumnRight: Integer; Relative: Boolean = True): Integer;

    function GetOwner: TPersistent; override;

    procedure HandleClick(P: TPoint; Button: TMouseButton; Force, DblClick: Boolean); virtual;

    procedure IndexChanged(OldIndex, NewIndex: Integer);

    procedure InitializePositionArray;

    procedure Notify(Item: TCollectionItem; Action: TCollectionNotification); override;

    procedure ReorderColumns(RTL: Boolean);

    procedure Update(Item: TCollectionItem); override;

    procedure UpdatePositions(Force: Boolean = False);



    property HeaderBitmap: TBitmap read FHeaderBitmap;

    property PositionToIndex: TIndexArray read FPositionToIndex;

    property HoverIndex: TColumnIndex read FHoverIndex;

    property DownIndex: TColumnIndex read FDownIndex;

    property CheckBoxHit: Boolean read FCheckBoxHit;

  public

    constructor Create(AOwner: TVTHeader); virtual;

    destructor Destroy; override;



    function Add: TVirtualTreeColumn; virtual;

    procedure AnimatedResize(Column: TColumnIndex; NewWidth: Integer);

    procedure Assign(Source: TPersistent); override;

    procedure Clear; virtual;

    function ColumnFromPosition(P: TPoint; Relative: Boolean = True): TColumnIndex; overload; virtual;

    function ColumnFromPosition(PositionIndex: TColumnPosition): TColumnIndex; overload; virtual;

{$if CompilerVersion >= 20}

   function Equals(OtherColumnsObj: TObject): Boolean; override;

{$else}

   function Equals(OtherColumnsObj: TObject): Boolean;

{$ifend}

    procedure GetColumnBounds(Column: TColumnIndex; var Left, Right: Integer);

    function GetFirstVisibleColumn(ConsiderAllowFocus: Boolean = False): TColumnIndex;

    function GetLastVisibleColumn(ConsiderAllowFocus: Boolean = False): TColumnIndex;

    function GetFirstColumn: TColumnIndex;

    function GetNextColumn(Column: TColumnIndex): TColumnIndex;

    function GetNextVisibleColumn(Column: TColumnIndex; ConsiderAllowFocus: Boolean = False): TColumnIndex;

    function GetPreviousColumn(Column: TColumnIndex): TColumnIndex;

    function GetPreviousVisibleColumn(Column: TColumnIndex; ConsiderAllowFocus: Boolean = False): TColumnIndex;

    function GetScrollWidth: Integer;

    function GetVisibleColumns: TColumnsArray;

    function GetVisibleFixedWidth: Integer;

    function IsValidColumn(Column: TColumnIndex): Boolean;

    procedure LoadFromStream(const Stream: TStream; Version: Integer);

    procedure PaintHeader(DC: HDC; R: TRect; HOffset: Integer); overload; virtual;

    procedure PaintHeader(TargetCanvas: TCanvas; R: TRect; const Target: TPoint;

      RTLOffset: Integer = 0); overload; virtual;

    procedure SaveToStream(const Stream: TStream);

    function TotalWidth: Integer;



    property Count: Integer read GetCount;

    property ClickIndex: TColumnIndex read FClickIndex;

    property DefaultWidth: Integer read FDefaultWidth write SetDefaultWidth default 50;

    property Items[Index: TColumnIndex]: TVirtualTreeColumn read GetItem write SetItem; default;

    property Header: TVTHeader read FHeader;

    property TrackIndex: TColumnIndex read FTrackIndex;

  end;



  TVirtualTreeColumnsClass = class of TVirtualTreeColumns;



  TVTConstraintPercent = 0..100;

  TVTFixedAreaConstraints = class(TPersistent)

  private

    FHeader: TVTHeader;

    FMaxHeightPercent,

    FMaxWidthPercent,

    FMinHeightPercent,

    FMinWidthPercent: TVTConstraintPercent;

    FOnChange: TNotifyEvent;

    procedure SetConstraints(Index: Integer; Value: TVTConstraintPercent);

  protected

    procedure Change;

    property Header: TVTHeader read FHeader;

  public

    constructor Create(AOwner: TVTHeader);



    procedure Assign(Source: TPersistent); override;

    property OnChange: TNotifyEvent read FOnChange write FOnChange;

  published

    property MaxHeightPercent: TVTConstraintPercent index 0 read FMaxHeightPercent write SetConstraints default 0;

    property MaxWidthPercent: TVTConstraintPercent index 1 read FMaxWidthPercent write SetConstraints default 0;

    property MinHeightPercent: TVTConstraintPercent index 2 read FMinHeightPercent write SetConstraints default 0;

    property MinWidthPercent: TVTConstraintPercent index 3 read FMinWidthPercent write SetConstraints default 0;

  end;



  TVTHeaderStyle = (

    hsThickButtons,    // TButton look and feel

    hsFlatButtons,     // flatter look than hsThickButton, like an always raised flat TToolButton

    hsPlates          // flat TToolButton look and feel (raise on hover etc.)

  );



  TVTHeaderOption = (

    hoAutoResize,            // Adjust a column so that the header never exceeds the client width of the owner control.

    hoColumnResize,          // Resizing columns with the mouse is allowed.

    hoDblClickResize,        // Allows a column to resize itself to its largest entry.

    hoDrag,                  // Dragging columns is allowed.

    hoHotTrack,              // Header captions are highlighted when mouse is over a particular column.

    hoOwnerDraw,             // Header items with the owner draw style can be drawn by the application via event.

    hoRestrictDrag,          // Header can only be dragged horizontally.

    hoShowHint,              // Show application defined header hint.

    hoShowImages,            // Show header images.

    hoShowSortGlyphs,        // Allow visible sort glyphs.

    hoVisible,               // Header is visible.

    hoAutoSpring,            // Distribute size changes of the header to all columns, which are sizable and have the

                             // coAutoSpring option enabled.

    hoFullRepaintOnResize,   // Fully invalidate the header (instead of subsequent columns only) when a column is resized.

    hoDisableAnimatedResize, // Disable animated resize for all columns.

    hoHeightResize,          // Allow resizing header height via mouse.

    hoHeightDblClickResize,  // Allow the header to resize itself to its default height.

    hoHeaderClickAutoSort    // Clicks on the header will make the clicked column the SortColumn or toggle sort direction if

                             // it already was the sort column

  );

  TVTHeaderOptions = set of TVTHeaderOption;



  THeaderState = (

    hsAutoSizing,              // auto size chain is in progess, do not trigger again on WM_SIZE

    hsDragging,                // header dragging is in progress (only if enabled)

    hsDragPending,             // left button is down, user might want to start dragging a column

    hsLoading,                 // The header currently loads from stream, so updates are not necessary.

    hsColumnWidthTracking,     // column resizing is in progress

    hsColumnWidthTrackPending, // left button is down, user might want to start resize a column

    hsHeightTracking,          // height resizing is in progress

    hsHeightTrackPending,      // left button is down, user might want to start changing height

    hsResizing,                // multi column resizing in progress

    hsScaling,                 // the header is scaled after a change of FixedAreaConstraints or client size

    hsNeedScaling              // the header needs to be scaled

  );

  THeaderStates = set of THeaderState;





  TSmartAutoFitType = (

    smaAllColumns,      // consider nodes in view only for all columns

    smaNoColumn,        // consider nodes in view only for no column

    smaUseColumnOption  // use coSmartResize of the corresponding column

  );  // describes the used column resize behaviour for AutoFitColumns





  TChangeReason = (

    crIgnore,       // used as placeholder

    crAccumulated,  // used for delayed changes

    crChildAdded,   // one or more child nodes have been added

    crChildDeleted, // one or more child nodes have been deleted

    crNodeAdded,    // a node has been added

    crNodeCopied,   // a node has been duplicated

    crNodeMoved     // a node has been moved to a new place

  ); // desribes what made a structure change event happen



  TVTHeader = class(TPersistent)

  private

    FOwner: TBaseVirtualTree;

    FColumns: TVirtualTreeColumns;

    FHeight: Integer;

    FFont: TFont;

    FParentFont: Boolean;

    FOptions: TVTHeaderOptions;

    FStyle: TVTHeaderStyle;            // button style

    FBackground: TColor;

    FAutoSizeIndex: TColumnIndex;

    FPopupMenu: TPopupMenu;

    FMainColumn: TColumnIndex;         // the column which holds the tree

    FMaxHeight: Integer;

    FMinHeight: Integer;

    FDefaultHeight: Integer;

    FFixedAreaConstraints: TVTFixedAreaConstraints; // Percentages for the fixed area (header, fixed columns).

    FImages: TCustomImageList;

    FImageChangeLink: TChangeLink;     // connections to the image list to get notified about changes

    FSortColumn: TColumnIndex;

    FSortDirection: TSortDirection;

    FDragImage: TVTDragImage;          // drag image management during header drag

    FLastWidth: Integer;               // Used to adjust spring columns. This is the width of all visible columns,

                                       // not the header rectangle.

    procedure FontChanged(Sender: TObject);

    function GetMainColumn: TColumnIndex;

    function GetUseColumns: Boolean;

    function IsFontStored: Boolean;

    procedure SetAutoSizeIndex(Value: TColumnIndex);

    procedure SetBackground(Value: TColor);

    procedure SetColumns(Value: TVirtualTreeColumns);

    procedure SetDefaultHeight(Value: Integer);

    procedure SetFont(const Value: TFont);

    procedure SetHeight(Value: Integer);

    procedure SetImages(const Value: TCustomImageList);

    procedure SetMainColumn(Value: TColumnIndex);

    procedure SetMaxHeight(Value: Integer);

    procedure SetMinHeight(Value: Integer);

    procedure SetOptions(Value: TVTHeaderOptions);

    procedure SetParentFont(Value: Boolean);

    procedure SetSortColumn(Value: TColumnIndex);

    procedure SetSortDirection(const Value: TSortDirection);

    procedure SetStyle(Value: TVTHeaderStyle);

  protected

    FStates: THeaderStates;            // Used to keep track of internal states the header can enter.

    FDragStart: TPoint;                // initial mouse drag position

    FTrackStart: TPoint;               // client coordinates of the tracking start point

    FTrackPoint: TPoint;               // Client coordinate where the tracking started.

    

    function CanSplitterResize(P: TPoint): Boolean;

    function CanWriteColumns: Boolean; virtual;

    procedure ChangeScale(M, D: Integer); virtual;

    function DetermineSplitterIndex(P: TPoint): Boolean; virtual;

    procedure DoAfterAutoFitColumn(Column: TColumnIndex); virtual;

    procedure DoAfterColumnWidthTracking(Column: TColumnIndex); virtual;

    procedure DoAfterHeightTracking; virtual;

    function DoBeforeAutoFitColumn(Column: TColumnIndex; SmartAutoFitType: TSmartAutoFitType): Boolean; virtual;

    procedure DoBeforeColumnWidthTracking(Column: TColumnIndex; Shift: TShiftState); virtual;

    procedure DoBeforeHeightTracking(Shift: TShiftState); virtual;

    procedure DoCanSplitterResize(P: TPoint; var Allowed: Boolean); virtual;

    function DoColumnWidthDblClickResize(Column: TColumnIndex; P: TPoint; Shift: TShiftState): Boolean; virtual;

    function DoColumnWidthTracking(Column: TColumnIndex; Shift: TShiftState; var TrackPoint: TPoint; P: TPoint): Boolean; virtual;

    function DoGetPopupMenu(Column: TColumnIndex; Position: TPoint): TPopupMenu; virtual;

    function DoHeightTracking(var P: TPoint; Shift: TShiftState): Boolean; virtual;

    function DoHeightDblClickResize(var P: TPoint; Shift: TShiftState): Boolean; virtual;

    procedure DoSetSortColumn(Value: TColumnIndex); virtual;

    procedure DragTo(P: TPoint);

    procedure FixedAreaConstraintsChanged(Sender: TObject);

    function GetColumnsClass: TVirtualTreeColumnsClass; virtual;

    function GetOwner: TPersistent; override;

    function GetShiftState: TShiftState;

    function HandleHeaderMouseMove(var Message: TWMMouseMove): Boolean;

    function HandleMessage(var Message: TMessage): Boolean; virtual;

    procedure ImageListChange(Sender: TObject);

    procedure PrepareDrag(P, Start: TPoint);

    procedure ReadColumns(Reader: TReader);

    procedure RecalculateHeader; virtual;

    procedure RescaleHeader;

    procedure UpdateMainColumn;

    procedure UpdateSpringColumns;

    procedure WriteColumns(Writer: TWriter);

  public

    constructor Create(AOwner: TBaseVirtualTree); virtual;

    destructor Destroy; override;



    function AllowFocus(ColumnIndex: TColumnIndex): Boolean;

    procedure Assign(Source: TPersistent); override;

    procedure AutoFitColumns(Animated: Boolean = True; SmartAutoFitType: TSmartAutoFitType = smaUseColumnOption;

      RangeStartCol: Integer = NoColumn; RangeEndCol: Integer = NoColumn); virtual;

    function InHeader(P: TPoint): Boolean; virtual;

    function InHeaderSplitterArea(P: TPoint): Boolean; virtual;

    procedure Invalidate(Column: TVirtualTreeColumn; ExpandToBorder: Boolean = False);

    procedure LoadFromStream(const Stream: TStream); virtual;

    function ResizeColumns(ChangeBy: Integer; RangeStartCol: TColumnIndex; RangeEndCol: TColumnIndex;

      Options: TVTColumnOptions = [coVisible]): Integer;

    procedure RestoreColumns;

    procedure SaveToStream(const Stream: TStream); virtual;



    property DragImage: TVTDragImage read FDragImage;

    property States: THeaderStates read FStates;

    property Treeview: TBaseVirtualTree read FOwner;

    property UseColumns: Boolean read GetUseColumns;

  published

    property AutoSizeIndex: TColumnIndex read FAutoSizeIndex write SetAutoSizeIndex;

    property Background: TColor read FBackground write SetBackground default clBtnFace;

    property Columns: TVirtualTreeColumns read FColumns write SetColumns stored False; // Stored by the owner tree to support VFI.

    property DefaultHeight: Integer read FDefaultHeight write SetDefaultHeight default 19;

    property Font: TFont read FFont write SetFont stored IsFontStored;

    property FixedAreaConstraints: TVTFixedAreaConstraints read FFixedAreaConstraints write FFixedAreaConstraints;

    property Height: Integer read FHeight write SetHeight default 19;

    property Images: TCustomImageList read FImages write SetImages;

    property MainColumn: TColumnIndex read GetMainColumn write SetMainColumn default 0;

    property MaxHeight: Integer read FMaxHeight write SetMaxHeight default 10000;

    property MinHeight: Integer read FMinHeight write SetMinHeight default 10;

    property Options: TVTHeaderOptions read FOptions write SetOptions default [hoColumnResize, hoDrag, hoShowSortGlyphs];

    property ParentFont: Boolean read FParentFont write SetParentFont default False;

    property PopupMenu: TPopupMenu read FPopupMenu write FPopupMenu;

    property SortColumn: TColumnIndex read FSortColumn write SetSortColumn default NoColumn;

    property SortDirection: TSortDirection read FSortDirection write SetSortDirection default sdAscending;

    property Style: TVTHeaderStyle read FStyle write SetStyle default hsThickButtons;

  end;



  TVTHeaderClass = class of TVTHeader;



  // Communication interface between a tree editor and the tree itself (declared as using stdcall in case it

  // is implemented in a (C/C++) DLL). The GUID is not nessecary in Delphi but important for BCB users

  // to allow QueryInterface and _uuidof calls.

  IVTEditLink = interface

    ['{2BE3EAFA-5ACB-45B4-9D9A-B58BCC496E17}']

    function BeginEdit: Boolean; stdcall;                  // Called when editing actually starts.

    function CancelEdit: Boolean; stdcall;                 // Called when editing has been cancelled by the tree.

    function EndEdit: Boolean; stdcall;                    // Called when editing has been finished by the tree.

    function PrepareEdit(Tree: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex): Boolean; stdcall;

                                                           // Called after creation to allow a setup.

    function GetBounds: TRect; stdcall;                    // Called to get the current size of the edit window

                                                           // (only important if the edit resizes itself).

    procedure ProcessMessage(var Message: TMessage); stdcall;

                                                           // Used to forward messages to the edit window(s)-

    procedure SetBounds(R: TRect); stdcall;                // Called to place the editor.

  end;



  // Indicates in the OnUpdating event what state the tree is currently in.

  TVTUpdateState = (

    usBegin,       // The tree just entered the update state (BeginUpdate call for the first time).

    usBeginSynch,  // The tree just entered the synch update state (BeginSynch call for the first time).

    usSynch,       // Begin/EndSynch has been called but the tree did not change the update state.

    usUpdate,      // Begin/EndUpdate has been called but the tree did not change the update state.

    usEnd,         // The tree just left the update state (EndUpdate called for the last level).

    usEndSynch     // The tree just left the synch update state (EndSynch called for the last level).

  );



  // Used during owner draw of the header to indicate which drop mark for the column must be drawn.

  TVTDropMarkMode = (

    dmmNone,

    dmmLeft,

    dmmRight

  );



  // This structure carries all important information about header painting and is used in the advanced header painting.

  THeaderPaintInfo = record

    TargetCanvas: TCanvas;

    Column: TVirtualTreeColumn;

    PaintRectangle: TRect;

    TextRectangle: TRect;

    IsHoverIndex,

    IsDownIndex,

    IsEnabled,

    ShowHeaderGlyph,

    ShowSortGlyph,

    ShowRightBorder: Boolean;

    DropMark: TVTDropMarkMode;

    GlyphPos,

    SortGlyphPos: TPoint;

  end;



  // These elements are used both to query the application, which of them it wants to draw itself and to tell it during

  // painting, which elements must be drawn during the advanced custom draw events.

  THeaderPaintElements = set of (

    hpeBackground,

    hpeDropMark,

    hpeHeaderGlyph,

    hpeSortGlyph,

    hpeText

  );



  // Various events must be handled at different places than they were initiated or need

  // a persistent storage until they are reset.

  TVirtualTreeStates = set of (

    tsCancelHintAnimation,    // Set when a new hint is about to show but an old hint is still being animated.

    tsChangePending,          // A selection change is pending.

    tsCheckPropagation,       // Set during automatic check state propagation.

    tsCollapsing,             // A full collapse operation is in progress.

    tsToggleFocusedSelection, // Node selection was modifed using Ctrl-click. Change selection state on next mouse up.

    tsClearPending,           // Need to clear the current selection on next mouse move.

    tsClipboardFlushing,      // Set during flushing the clipboard to avoid freeing the content.

    tsCopyPending,            // Indicates a pending copy operation which needs to be finished.

    tsCutPending,             // Indicates a pending cut operation which needs to be finished.

    tsDrawSelPending,         // Multiselection only. User held down the left mouse button on a free

                              // area and might want to start draw selection.

    tsDrawSelecting,          // Multiselection only. Draw selection has actually started.

    tsEditing,                // Indicates that an edit operation is currently in progress.

    tsEditPending,            // An mouse up start edit if dragging has not started.

    tsExpanding,              // A full expand operation is in progress.

    tsNodeHeightTracking,     // A node height changing operation is in progress.

    tsNodeHeightTrackPending, // left button is down, user might want to start changing a node's height.

    tsHint,                   // Set when our hint is visible or soon will be.

    tsInAnimation,            // Set if the tree is currently in an animation loop.

    tsIncrementalSearching,   // Set when the user starts incremental search.

    tsIncrementalSearchPending, // Set in WM_KEYDOWN to tell to use the char in WM_CHAR for incremental search.

    tsIterating,              // Set when IterateSubtree is currently in progress.

    tsKeyCheckPending,        // A check operation is under way, initiated by a key press (space key). Ignore mouse.

    tsLeftButtonDown,         // Set when the left mouse button is down.

    tsLeftDblClick,           // Set when the left mouse button was doubly clicked.

    tsMouseCheckPending,      // A check operation is under way, initiated by a mouse click. Ignore space key.

    tsMiddleButtonDown,       // Set when the middle mouse button is down.

    tsMiddleDblClick,         // Set when the middle mouse button was doubly clicked.

    tsNeedRootCountUpdate,    // Set if while loading a root node count is set.

    tsOLEDragging,            // OLE dragging in progress.

    tsOLEDragPending,         // User has requested to start delayed dragging.

    tsPainting,               // The tree is currently painting itself.

    tsRightButtonDown,        // Set when the right mouse button is down.

    tsRightDblClick,          // Set when the right mouse button was doubly clicked.

    tsPopupMenuShown,         // The user clicked the right mouse button, which might cause a popup menu to appear.

    tsScrolling,              // Set when autoscrolling is active.

    tsScrollPending,          // Set when waiting for the scroll delay time to elapse.

    tsSizing,                 // Set when the tree window is being resized. This is used to prevent recursive calls

                              // due to setting the scrollbars when sizing.

    tsStopValidation,         // Cache validation can be stopped (usually because a change has occured meanwhile).

    tsStructureChangePending, // The structure of the tree has been changed while the update was locked.

    tsSynchMode,              // Set when the tree is in synch mode, where no timer events are triggered.

    tsThumbTracking,          // Stop updating the horizontal scroll bar while dragging the vertical thumb and vice versa.

    tsToggling,               // A toggle operation (for some node) is in progress.

    tsUpdateHiddenChildrenNeeded, // Pending update for the hidden children flag after massive visibility changes.

    tsUpdating,               // The tree does currently not update its window because a BeginUpdate has not yet ended.

    tsUseCache,               // The tree's node caches are validated and non-empty.

    tsUserDragObject,         // Signals that the application created an own drag object in OnStartDrag.

    tsUseThemes,              // The tree runs under WinXP+, is theme aware and themes are enabled.

    tsValidating,             // The tree's node caches are currently validated.

    tsPreviouslySelectedLocked,// The member FPreviouslySelected should not be changed

    tsValidationNeeded,       // Something in the structure of the tree has changed. The cache needs validation.

    tsVCLDragging,            // VCL drag'n drop in progress.

    tsVCLDragPending,         // One-shot flag to avoid clearing the current selection on implicit mouse up for VCL drag.

    tsVCLDragFinished,        // Flag to avoid triggering the OnColumnClick event twice

    tsWheelPanning,           // Wheel mouse panning is active or soon will be.

    tsWheelScrolling,         // Wheel mouse scrolling is active or soon will be.

    tsWindowCreating,         // Set during window handle creation to avoid frequent unnecessary updates.

    tsUseExplorerTheme        // The tree runs under WinVista+ and is using the explorer theme

  );



  TChangeStates = set of (

    csStopValidation,         // Cache validation can be stopped (usually because a change has occured meanwhile).

    csUseCache,               // The tree's node caches are validated and non-empty.

    csValidating,             // The tree's node caches are currently validated.

    csValidationNeeded        // Something in the structure of the tree has changed. The cache needs validation.

  );



  // determines whether and how the drag image is to show

  TVTDragImageKind = (

    diComplete,       // show a complete drag image with all columns, only visible columns are shown

    diMainColumnOnly, // show only the main column (the tree column)

    diNoImage         // don't show a drag image at all

  );



  // Switch for OLE and VCL drag'n drop. Because it is not possible to have both simultanously.

  TVTDragType = (

    dtOLE,

    dtVCL

  );



  // options which determine what to draw in PaintTree

  TVTInternalPaintOption = (

    poBackground,       // draw background image if there is any and it is enabled

    poColumnColor,      // erase node's background with the column's color

    poDrawFocusRect,    // draw focus rectangle around the focused node

    poDrawSelection,    // draw selected nodes with the normal selection color

    poDrawDropMark,     // draw drop mark if a node is currently the drop target

    poGridLines,        // draw grid lines if enabled

    poMainOnly,         // draw only the main column

    poSelectedOnly,     // draw only selected nodes

    poUnbuffered        // draw directly onto the target canvas; especially useful when printing

  );

  TVTInternalPaintOptions = set of TVTInternalPaintOption;



  // Determines the look of a tree's lines.

  TVTLineStyle = (

    lsCustomStyle,           // application provides a line pattern

    lsDotted,                // usual dotted lines (default)

    lsSolid                  // simple solid lines

  );



  // TVTLineType is used during painting a tree

  TVTLineType = (

    ltNone,          // no line at all

    ltBottomRight,   // a line from bottom to the center and from there to the right

    ltTopDown,       // a line from top to bottom

    ltTopDownRight,  // a line from top to bottom and from center to the right

    ltRight,         // a line from center to the right

    ltTopRight,      // a line from bottom to center and from there to the right

    // special styles for alternative drawings of tree lines

    ltLeft,          // a line from top to bottom at the left

    ltLeftBottom     // a combination of ltLeft and a line at the bottom from left to right

  );



  // Determines how to draw tree lines.

  TVTLineMode = (

    lmNormal,        // usual tree lines (as in TTreeview)

    lmBands          // looks similar to a Nassi-Schneidermann diagram

  );



  // A collection of line type IDs which is used while painting a node.

  TLineImage = array of TVTLineType;



  TVTScrollIncrement = 1..10000;



  // Export type

  TVTExportType = (

    etRTF,   // contentToRTF

    etHTML,  // contentToHTML

    etText,  // contentToText

    etExcel, // supported by external tools

    etWord,  // supported by external tools

    etCustom // supported by external tools

  );



  TVTNodeExportEvent   = function (Sender: TBaseVirtualTree; aExportType: TVTExportType; Node: PVirtualNode): Boolean of object;

  TVTColumnExportEvent = procedure (Sender: TBaseVirtualTree; aExportType: TVTExportType; Column: TVirtualTreeColumn) of object;

  TVTTreeExportEvent   = procedure(Sender: TBaseVirtualTree; aExportType: TVTExportType) of object;



  // A class to manage scroll bar aspects.

  TScrollBarOptions = class(TPersistent)

  private

    FAlwaysVisible: Boolean;

    FOwner: TBaseVirtualTree;

    FScrollBars: TScrollStyle;                   // used to hide or show vertical and/or horizontal scrollbar

    FScrollBarStyle: TScrollBarStyle;            // kind of scrollbars to use

    FIncrementX,

    FIncrementY: TVTScrollIncrement;             // number of pixels to scroll in one step (when auto scrolling)

    procedure SetAlwaysVisible(Value: Boolean);

    procedure SetScrollBars(Value: TScrollStyle);

    procedure SetScrollBarStyle(Value: TScrollBarStyle);

  protected

    function GetOwner: TPersistent; override;

  public

    constructor Create(AOwner: TBaseVirtualTree);



    procedure Assign(Source: TPersistent); override;

  published

    property AlwaysVisible: Boolean read FAlwaysVisible write SetAlwaysVisible default False;

    property HorizontalIncrement: TVTScrollIncrement read FIncrementX write FIncrementX default 20;

    property ScrollBars: TScrollStyle read FScrollBars write SetScrollBars default ssBoth;

    property ScrollBarStyle: TScrollBarStyle read FScrollBarStyle write SetScrollBarStyle default sbmRegular;

    property VerticalIncrement: TVTScrollIncrement read FIncrementY write FIncrementY default 20;

  end;



  // class to collect all switchable colors into one place

  TVTColors = class(TPersistent)

  private

    FOwner: TBaseVirtualTree;

    FColors: array[0..16] of TColor; // [IPK] 15 -> 16

    function GetColor(const Index: Integer): TColor;

    procedure SetColor(const Index: Integer; const Value: TColor);

    function GetBackgroundColor: TColor;

    function GetHeaderFontColor: TColor;

    function GetNodeFontColor: TColor;

  public

    constructor Create(AOwner: TBaseVirtualTree);



    procedure Assign(Source: TPersistent); override;

    property BackGroundColor: TColor read GetBackgroundColor;

    property HeaderFontColor: TColor read  GetHeaderFontColor;

    property NodeFontColor: TColor read GetNodeFontColor;

  published

    property BorderColor: TColor index 7 read GetColor write SetColor default clBtnFace;

    property DisabledColor: TColor index 0 read GetColor write SetColor default clBtnShadow;

    property DropMarkColor: TColor index 1 read GetColor write SetColor default clHighlight;

    property DropTargetColor: TColor index 2 read GetColor write SetColor default clHighLight;

    property DropTargetBorderColor: TColor index 11 read GetColor write SetColor default clHighLight;

    property FocusedSelectionColor: TColor index 3 read GetColor write SetColor default clHighLight;

    property FocusedSelectionBorderColor: TColor index 9 read GetColor write SetColor default clHighLight;

    property GridLineColor: TColor index 4 read GetColor write SetColor default clBtnFace;

    property HeaderHotColor: TColor index 14 read GetColor write SetColor default clBtnShadow;

    property HotColor: TColor index 8 read GetColor write SetColor default clWindowText;

    property SelectionRectangleBlendColor: TColor index 12 read GetColor write SetColor default clHighlight;

    property SelectionRectangleBorderColor: TColor index 13 read GetColor write SetColor default clHighlight;

    property SelectionTextColor: TColor index 15 read GetColor write SetColor default clHighlightText;

    property TreeLineColor: TColor index 5 read GetColor write SetColor default clBtnShadow;

    property UnfocusedColor: TColor index 16 read GetColor write SetColor default clBtnFace; // [IPK] Added

    property UnfocusedSelectionColor: TColor index 6 read GetColor write SetColor default clBtnFace;

    property UnfocusedSelectionBorderColor: TColor index 10 read GetColor write SetColor default clBtnFace;

  end;



  // For painting a node and its columns/cells a lot of information must be passed frequently around.

  TVTImageInfo = record

    Index: Integer;           // Index in the associated image list.

    XPos,                     // Horizontal position in the current target canvas.

    YPos: Integer;            // Vertical position in the current target canvas.

    Ghosted: Boolean;         // Flag to indicate that the image must be drawn slightly lighter.

    Images: TCustomImageList; // The image list to be used for painting.

  end;



  TVTImageInfoIndex = (

    iiNormal,

    iiState,

    iiCheck,

    iiOverlay

  );



  // Options which are used when modifying the scroll offsets.

  TScrollUpdateOptions = set of (

    suoRepaintHeader,        // if suoUpdateNCArea is also set then invalidate the header

    suoRepaintScrollBars,    // if suoUpdateNCArea is also set then repaint both scrollbars after updating them

    suoScrollClientArea,     // scroll and invalidate the proper part of the client area

    suoUpdateNCArea          // update non-client area (scrollbars, header)

  );



  // Determines the look of a tree's buttons.

  TVTButtonStyle = (

    bsRectangle,             // traditional Windows look (plus/minus buttons)

    bsTriangle               // traditional Macintosh look

  );



  // TButtonFillMode is only used when the button style is bsRectangle and determines how to fill the interior.

  TVTButtonFillMode = (

    fmTreeColor,             // solid color, uses the tree's background color

    fmWindowColor,           // solid color, uses clWindow

    fmShaded,                // color gradient, Windows XP style (legacy code, use toThemeAware on Windows XP instead)

    fmTransparent            // transparent color, use the item's background color

  );



  TVTPaintInfo = record

    Canvas: TCanvas;              // the canvas to paint on

    PaintOptions: TVTInternalPaintOptions;  // a copy of the paint options passed to PaintTree

    Node: PVirtualNode;           // the node to paint

    Column: TColumnIndex;         // the node's column index to paint

    Position: TColumnPosition;    // the column position of the node

    CellRect,                     // the node cell

    ContentRect: TRect;           // the area of the cell used for the node's content

    NodeWidth: Integer;           // the actual node width

    Alignment: TAlignment;        // how to align within the node rectangle

    CaptionAlignment: TAlignment; // how to align text within the caption rectangle

    BidiMode: TBidiMode;          // directionality to be used for painting

    BrushOrigin: TPoint;          // the alignment for the brush used to draw dotted lines

    ImageInfo: array[TVTImageInfoIndex] of TVTImageInfo; // info about each possible node image

  end;



  // Method called by the Animate routine for each animation step.

  TVTAnimationCallback = function(Step, StepSize: Integer; Data: Pointer): Boolean of object;



  TVTIncrementalSearch = (

    isAll,                   // search every node in tree, initialize if necessary

    isNone,                  // disable incremental search

    isInitializedOnly,       // search only initialized nodes, skip others

    isVisibleOnly            // search only visible nodes, initialize if necessary

  );



  // Determines which direction to use when advancing nodes during an incremental search.

  TVTSearchDirection = (

    sdForward,

    sdBackward

  );



  // Determines where to start incremental searching for each key press.

  TVTSearchStart = (

    ssAlwaysStartOver,       // always use the first/last node (depending on direction) to search from

    ssLastHit,               // use the last found node

    ssFocusedNode            // use the currently focused node

  );



  // Determines how to use the align member of a node.

  TVTNodeAlignment = (

    naFromBottom,            // the align member specifies amount of units (usually pixels) from top border of the node

    naFromTop,               // align is to be measured from bottom

    naProportional           // align is to be measure in percent of the entire node height and relative to top

  );



  // Determines how to draw the selection rectangle used for draw selection.

  TVTDrawSelectionMode = (

    smDottedRectangle,       // same as DrawFocusRect

    smBlendedRectangle       // alpha blending, uses special colors (see TVTColors)

  );



  // Determines for which purpose the cell paint event is called.

  TVTCellPaintMode = (

    cpmPaint,                // painting the cell

    cpmGetContentMargin      // getting cell content margin

  );



  // Determines which sides of the cell content margin should be considered.

  TVTCellContentMarginType = (

    ccmtAllSides,            // consider all sides

    ccmtTopLeftOnly,         // consider top margin and left margin only

    ccmtBottomRightOnly      // consider bottom margin and right margin only

  );



  TClipboardFormats = class(TStringList)

  private

    FOwner: TBaseVirtualTree;

  public

    constructor Create(AOwner: TBaseVirtualTree); virtual;



    function Add(const S: string): Integer; override;

    procedure Insert(Index: Integer; const S: string); override;

    property Owner: TBaseVirtualTree read FOwner;

  end;



  // ----- Event prototypes:



  // node enumeration

  {$if CompilerVersion >= 20}

  TVTGetNodeProc = reference to procedure(Sender: TBaseVirtualTree; Node: PVirtualNode; Data: Pointer; var Abort: Boolean);

  {$else}

  TVTGetNodeProc = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode; Data: Pointer; var Abort: Boolean) of object;

  {$ifend}

  // node events

  TVTChangingEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode; var Allowed: Boolean) of object;

  TVTCheckChangingEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode; var NewState: TCheckState;

    var Allowed: Boolean) of object;

  TVTChangeEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode) of object;

  TVTStructureChangeEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode; Reason: TChangeReason) of object;

  TVTEditCancelEvent = procedure(Sender: TBaseVirtualTree; Column: TColumnIndex) of object;

  TVTEditChangingEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex;

    var Allowed: Boolean) of object;

  TVTEditChangeEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex) of object;

  TVTFreeNodeEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode) of object;

  TVTFocusChangingEvent = procedure(Sender: TBaseVirtualTree; OldNode, NewNode: PVirtualNode; OldColumn,

    NewColumn: TColumnIndex; var Allowed: Boolean) of object;

  TVTFocusChangeEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex) of object;

  TVTAddToSelectionEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode) of object;

  TVTRemoveFromSelectionEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode) of object;

  TVTGetImageEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode; Kind: TVTImageKind; Column: TColumnIndex;

    var Ghosted: Boolean; var ImageIndex: Integer) of object;

  TVTGetImageExEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode; Kind: TVTImageKind; Column: TColumnIndex;

    var Ghosted: Boolean; var ImageIndex: Integer; var ImageList: TCustomImageList) of object;

  TVTGetImageTextEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode; Kind: TVTImageKind; Column: TColumnIndex;

    var ImageText: UnicodeString) of object;

  TVTHotNodeChangeEvent = procedure(Sender: TBaseVirtualTree; OldNode, NewNode: PVirtualNode) of object;

  TVTInitChildrenEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode; var ChildCount: Cardinal) of object;

  TVTInitNodeEvent = procedure(Sender: TBaseVirtualTree; ParentNode, Node: PVirtualNode;

    var InitialStates: TVirtualNodeInitStates) of object;

  TVTPopupEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; const P: TPoint;

    var AskParent: Boolean; var PopupMenu: TPopupMenu) of object;

  TVTHelpContextEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex;

    var HelpContext: Integer) of object;

  TVTCreateEditorEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex;

    out EditLink: IVTEditLink) of object;

  TVTSaveTreeEvent = procedure(Sender: TBaseVirtualTree; Stream: TStream) of object;

  TVTSaveNodeEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode; Stream: TStream) of object;



  // header/column events

  TVTHeaderClickEvent = procedure(Sender: TVTHeader; HitInfo: TVTHeaderHitInfo) of object;

  TVTHeaderMouseEvent = procedure(Sender: TVTHeader; Button: TMouseButton; Shift: TShiftState; X, Y: Integer) of object;

  TVTHeaderMouseMoveEvent = procedure(Sender: TVTHeader; Shift: TShiftState; X, Y: Integer) of object;

  TVTBeforeHeaderHeightTrackingEvent = procedure(Sender: TVTHeader; Shift: TShiftState) of object;

  TVTAfterHeaderHeightTrackingEvent = procedure(Sender: TVTHeader) of object;

  TVTHeaderHeightTrackingEvent = procedure(Sender: TVTHeader; var P: TPoint; Shift: TShiftState; var Allowed: Boolean) of object;

  TVTHeaderHeightDblClickResizeEvent = procedure(Sender: TVTHeader; var P: TPoint; Shift: TShiftState; var Allowed: Boolean) of object;

  TVTHeaderNotifyEvent = procedure(Sender: TVTHeader; Column: TColumnIndex) of object;

  TVTHeaderDraggingEvent = procedure(Sender: TVTHeader; Column: TColumnIndex; var Allowed: Boolean) of object;

  TVTHeaderDraggedEvent = procedure(Sender: TVTHeader; Column: TColumnIndex; OldPosition: Integer) of object;

  TVTHeaderDraggedOutEvent = procedure(Sender: TVTHeader; Column: TColumnIndex; DropPosition: TPoint) of object;

  TVTHeaderPaintEvent = procedure(Sender: TVTHeader; HeaderCanvas: TCanvas; Column: TVirtualTreeColumn; R: TRect; Hover,

    Pressed: Boolean; DropMark: TVTDropMarkMode) of object;

  TVTHeaderPaintQueryElementsEvent = procedure(Sender: TVTHeader; var PaintInfo: THeaderPaintInfo;

    var Elements: THeaderPaintElements) of object;

  TVTAdvancedHeaderPaintEvent = procedure(Sender: TVTHeader; var PaintInfo: THeaderPaintInfo;

    const Elements: THeaderPaintElements) of object;

  TVTBeforeAutoFitColumnsEvent = procedure(Sender: TVTHeader; var SmartAutoFitType: TSmartAutoFitType) of object;

  TVTBeforeAutoFitColumnEvent = procedure(Sender: TVTHeader; Column: TColumnIndex; var SmartAutoFitType: TSmartAutoFitType;

    var Allowed: Boolean) of object;

  TVTAfterAutoFitColumnEvent = procedure(Sender: TVTHeader; Column: TColumnIndex) of object;

  TVTAfterAutoFitColumnsEvent = procedure(Sender: TVTHeader) of object;

  TVTColumnClickEvent = procedure (Sender: TBaseVirtualTree; Column: TColumnIndex; Shift: TShiftState) of object;

  TVTColumnDblClickEvent = procedure (Sender: TBaseVirtualTree; Column: TColumnIndex; Shift: TShiftState) of object;

  TVTColumnWidthDblClickResizeEvent = procedure(Sender: TVTHeader; Column: TColumnIndex; Shift: TShiftState; P: TPoint;

    var Allowed: Boolean) of object;

  TVTBeforeColumnWidthTrackingEvent = procedure(Sender: TVTHeader; Column: TColumnIndex; Shift: TShiftState) of object;

  TVTAfterColumnWidthTrackingEvent = procedure(Sender: TVTHeader; Column: TColumnIndex) of object;

  TVTColumnWidthTrackingEvent = procedure(Sender: TVTHeader; Column: TColumnIndex; Shift: TShiftState; var TrackPoint: TPoint; P: TPoint;

    var Allowed: Boolean) of object;

  TVTGetHeaderCursorEvent = procedure(Sender: TVTHeader; var Cursor: HCURSOR) of object;

  TVTBeforeGetMaxColumnWidthEvent = procedure(Sender: TVTHeader; Column: TColumnIndex; var UseSmartColumnWidth: Boolean) of object;

  TVTAfterGetMaxColumnWidthEvent = procedure(Sender: TVTHeader; Column: TColumnIndex; var MaxWidth: Integer) of object;

  TVTCanSplitterResizeColumnEvent = procedure(Sender: TVTHeader; P: TPoint; Column: TColumnIndex; var Allowed: Boolean) of object;

  TVTCanSplitterResizeHeaderEvent = procedure(Sender: TVTHeader; P: TPoint; var Allowed: Boolean) of object;



  // move, copy and node tracking events

  TVTNodeMovedEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode) of object;

  TVTNodeMovingEvent = procedure(Sender: TBaseVirtualTree; Node, Target: PVirtualNode;

    var Allowed: Boolean) of object;

  TVTNodeCopiedEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode) of object;

  TVTNodeCopyingEvent = procedure(Sender: TBaseVirtualTree; Node, Target: PVirtualNode;

    var Allowed: Boolean) of object;

  TVTNodeClickEvent = procedure(Sender: TBaseVirtualTree; const HitInfo: THitInfo) of object;

  TVTNodeHeightTrackingEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; Shift: TShiftState;

    var TrackPoint: TPoint; P: TPoint; var Allowed: Boolean) of object;

  TVTNodeHeightDblClickResizeEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex;

    Shift: TShiftState; P: TPoint; var Allowed: Boolean) of object;

  TVTCanSplitterResizeNodeEvent = procedure(Sender: TBaseVirtualTree; P: TPoint; Node: PVirtualNode;

    Column: TColumnIndex; var Allowed: Boolean) of object;



  // drag'n drop/OLE events

  TVTCreateDragManagerEvent = procedure(Sender: TBaseVirtualTree; out DragManager: IVTDragManager) of object;

  TVTCreateDataObjectEvent = procedure(Sender: TBaseVirtualTree; out IDataObject: IDataObject) of object;

  TVTDragAllowedEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex;

    var Allowed: Boolean) of object;

  TVTDragOverEvent = procedure(Sender: TBaseVirtualTree; Source: TObject; Shift: TShiftState; State: TDragState;

    Pt: TPoint; Mode: TDropMode; var Effect: Integer; var Accept: Boolean) of object;

  TVTDragDropEvent = procedure(Sender: TBaseVirtualTree; Source: TObject; DataObject: IDataObject;

    Formats: TFormatArray; Shift: TShiftState; Pt: TPoint; var Effect: Integer; Mode: TDropMode) of object;

  TVTRenderOLEDataEvent = procedure(Sender: TBaseVirtualTree; const FormatEtcIn: TFormatEtc; out Medium: TStgMedium;

    ForClipboard: Boolean; var Result: HRESULT) of object;

  TVTGetUserClipboardFormatsEvent = procedure(Sender: TBaseVirtualTree; var Formats: TFormatEtcArray) of object;



  // paint events

  TVTBeforeItemEraseEvent = procedure(Sender: TBaseVirtualTree; TargetCanvas: TCanvas; Node: PVirtualNode; ItemRect: TRect;

    var ItemColor: TColor; var EraseAction: TItemEraseAction) of object;

  TVTAfterItemEraseEvent = procedure(Sender: TBaseVirtualTree; TargetCanvas: TCanvas; Node: PVirtualNode;

    ItemRect: TRect) of object;

  TVTBeforeItemPaintEvent = procedure(Sender: TBaseVirtualTree; TargetCanvas: TCanvas; Node: PVirtualNode;

    ItemRect: TRect; var CustomDraw: Boolean) of object;

  TVTAfterItemPaintEvent = procedure(Sender: TBaseVirtualTree; TargetCanvas: TCanvas; Node: PVirtualNode;

    ItemRect: TRect) of object;

  TVTBeforeCellPaintEvent = procedure(Sender: TBaseVirtualTree; TargetCanvas: TCanvas; Node: PVirtualNode;

    Column: TColumnIndex; CellPaintMode: TVTCellPaintMode; CellRect: TRect; var ContentRect: TRect) of object;

  TVTAfterCellPaintEvent = procedure(Sender: TBaseVirtualTree; TargetCanvas: TCanvas; Node: PVirtualNode;

    Column: TColumnIndex; CellRect: TRect) of object;

  TVTPaintEvent = procedure(Sender: TBaseVirtualTree; TargetCanvas: TCanvas) of object;

  TVTBackgroundPaintEvent = procedure(Sender: TBaseVirtualTree; TargetCanvas: TCanvas; R: TRect;

    var Handled: Boolean) of object;

  TVTGetLineStyleEvent = procedure(Sender: TBaseVirtualTree; var Bits: Pointer) of object;

  TVTMeasureItemEvent = procedure(Sender: TBaseVirtualTree; TargetCanvas: TCanvas; Node: PVirtualNode;

    var NodeHeight: Integer) of object;



  // search, sort

  TVTCompareEvent = procedure(Sender: TBaseVirtualTree; Node1, Node2: PVirtualNode; Column: TColumnIndex;

    var Result: Integer) of object;

  TVTIncrementalSearchEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode; const SearchText: UnicodeString;

    var Result: Integer) of object;



  // operations

  TVTOperationEvent = procedure(Sender: TBaseVirtualTree; OperationKind: TVTOperationKind) of object;



  TVTHintKind = (vhkText, vhkOwnerDraw);

  TVTHintKindEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; var Kind: TVTHintKind) of object;

  TVTDrawHintEvent = procedure(Sender: TBaseVirtualTree; HintCanvas: TCanvas; Node: PVirtualNode; R: TRect; Column: TColumnIndex) of object;

  TVTGetHintSizeEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; var R: TRect) of object;



  // miscellaneous

  TVTBeforeDrawLineImageEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode; Level: Integer; var PosX: Integer) of object;

  TVTGetNodeDataSizeEvent = procedure(Sender: TBaseVirtualTree; var NodeDataSize: Integer) of object;

  TVTKeyActionEvent = procedure(Sender: TBaseVirtualTree; var CharCode: Word; var Shift: TShiftState;

    var DoDefault: Boolean) of object;

  TVTScrollEvent = procedure(Sender: TBaseVirtualTree; DeltaX, DeltaY: Integer) of object;

  TVTUpdatingEvent = procedure(Sender: TBaseVirtualTree; State: TVTUpdateState) of object;

  TVTGetCursorEvent = procedure(Sender: TBaseVirtualTree; var Cursor: TCursor) of object;

  TVTStateChangeEvent = procedure(Sender: TBaseVirtualTree; Enter, Leave: TVirtualTreeStates) of object;

  TVTGetCellIsEmptyEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex;

    var IsEmpty: Boolean) of object;

  TVTScrollBarShowEvent = procedure(Sender: TBaseVirtualTree; Bar: Integer; Show: Boolean) of object;



  // Helper types for node iterations.

  TGetFirstNodeProc = function: PVirtualNode of object;

  TGetNextNodeProc = function(Node: PVirtualNode; ConsiderChildrenAbove: Boolean = False): PVirtualNode of object;



  TVZVirtualNodeEnumerationMode = (

    vneAll,

    vneChecked,

    vneChild,

    vneCutCopy,

    vneInitialized,

    vneLeaf,

    vneLevel,

    vneNoInit,

    vneSelected,

    vneVisible,

    vneVisibleChild,

    vneVisibleNoInitChild,

    vneVisibleNoInit

  );



  PVTVirtualNodeEnumeration = ^TVTVirtualNodeEnumeration;



  TVTVirtualNodeEnumerator = {$if CompilerVersion >= 18}record{$else}class{$ifend}

  private

    FNode: PVirtualNode;

    FCanModeNext: Boolean;

    FEnumeration: PVTVirtualNodeEnumeration;

    function GetCurrent: PVirtualNode; {$if CompilerVersion >= 18}inline;{$ifend}

  public

    function MoveNext: Boolean; {$if CompilerVersion >= 18}inline;{$ifend}

    property Current: PVirtualNode read GetCurrent;

  end;



  TVTVirtualNodeEnumeration = {$if CompilerVersion >= 18}record{$else}object{$ifend}

  private

    FMode: TVZVirtualNodeEnumerationMode;

    FTree: TBaseVirtualTree;

    // GetNextXxx parameters:

    FConsiderChildrenAbove: Boolean;

    FNode: PVirtualNode;

    FNodeLevel: Cardinal;

    FState: TCheckState;

    FIncludeFiltered: Boolean;

  public

    function GetEnumerator: TVTVirtualNodeEnumerator;

  private

    function GetNext(Node: PVirtualNode): PVirtualNode;

  end;





  // XE2+ VCL Style

{$if CompilerVersion >= 23 }

  TVclStyleScrollBarsHook = class(TMouseTrackControlStyleHook)

  strict private type

  {$REGION 'TVclStyleScrollBarWindow'}

      TVclStyleScrollBarWindow = class(TWinControl)strict private FScrollBarWindowOwner: TVclStyleScrollBarsHook;

    FScrollBarVertical: Boolean;

    FScrollBarVisible: Boolean;

    FScrollBarEnabled: Boolean;

    procedure WMNCHitTest(var Msg: TWMNCHitTest); message WM_NCHITTEST;

    procedure WMEraseBkgnd(var Msg: TMessage); message WM_ERASEBKGND;

    procedure WMPaint(var Msg: TWMPaint); message WM_PAINT;

  strict protected

    procedure CreateParams(var Params: TCreateParams);

    override;

  public

    constructor Create(AOwner: TComponent);

    override;

    property ScrollBarWindowOwner: TVclStyleScrollBarsHook read FScrollBarWindowOwner write FScrollBarWindowOwner;

    property ScrollBarVertical: Boolean read FScrollBarVertical write FScrollBarVertical;

    property ScrollBarVisible: Boolean read FScrollBarVisible write FScrollBarVisible;

    property ScrollBarEnabled: Boolean read FScrollBarEnabled write FScrollBarEnabled;

    end;

  {$ENDREGION}

  private

    FHorzScrollBarDownButtonRect: TRect;

    FHorzScrollBarDownButtonState: TThemedScrollBar;

    FHorzScrollBarRect: TRect;

    FHorzScrollBarSliderState: TThemedScrollBar;

    FHorzScrollBarSliderTrackRect: TRect;

    FHorzScrollBarUpButtonRect: TRect;

    FHorzScrollBarUpButtonState: TThemedScrollBar;

    FHorzScrollBarWindow: TVclStyleScrollBarWindow;

    FLeftMouseButtonDown: Boolean;

    FPrevScrollPos: Integer;

    FScrollPos: Single;

    FVertScrollBarDownButtonRect: TRect;

    FVertScrollBarDownButtonState: TThemedScrollBar;

    FVertScrollBarRect: TRect;

    FVertScrollBarSliderState: TThemedScrollBar;

    FVertScrollBarSliderTrackRect: TRect;

    FVertScrollBarUpButtonRect: TRect;

    FVertScrollBarUpButtonState: TThemedScrollBar;

    FVertScrollBarWindow: TVclStyleScrollBarWindow;



    procedure CMUpdateVclStyleScrollBars(var Message: TMessage); message CM_UPDATE_VCLSTYLE_SCROLLBARS;

    procedure WMKeyDown(var Msg: TMessage); message WM_KEYDOWN;

    procedure WMKeyUp(var Msg: TMessage); message WM_KEYUP;

    procedure WMLButtonDown(var Msg: TWMMouse);  message WM_LBUTTONDOWN;

    procedure WMLButtonUp(var Msg: TWMMouse); message WM_LBUTTONUP;

    procedure WMNCLButtonDown(var Msg: TWMMouse); message WM_NCLBUTTONDOWN;

    procedure WMNCMouseMove(var Msg: TWMMouse); message WM_NCMOUSEMOVE;

    procedure WMNCLButtonUp(var Msg: TWMMouse); message WM_NCLBUTTONUP;

    procedure WMNCPaint(var Msg: TMessage); message WM_NCPAINT;

    procedure WMMouseMove(var Msg: TWMMouse); message WM_MOUSEMOVE;

    procedure WMMouseWheel(var Msg: TMessage); message WM_MOUSEWHEEL;

    procedure WMVScroll(var Msg: TMessage); message WM_VSCROLL;

    procedure WMHScroll(var Msg: TMessage); message WM_HSCROLL;

    procedure WMCaptureChanged(var Msg: TMessage); message WM_CAPTURECHANGED;

    procedure WMNCLButtonDblClk(var Msg: TWMMouse); message WM_NCLBUTTONDBLCLK;

    procedure WMSize(var Msg: TMessage); message WM_SIZE;

    procedure WMMove(var Msg: TMessage); message WM_MOVE;

    procedure WMPosChanged(var Msg: TMessage); message WM_WINDOWPOSCHANGED;

  protected

    procedure CalcScrollBarsRect; virtual;

    procedure DrawHorzScrollBar(DC: HDC); virtual;

    procedure DrawVertScrollBar(DC: HDC); virtual;

    function GetHorzScrollBarSliderRect: TRect;

    function GetVertScrollBarSliderRect: TRect;

    procedure MouseLeave; override;

    procedure PaintScrollBars; virtual;

    function PointInTreeHeader(const P: TPoint): Boolean;

    procedure UpdateScrollBarWindow;

  public

    constructor Create(AControl: TWinControl); override;

    destructor Destroy; override;

  end;

{$ifend}





  // ----- TBaseVirtualTree

  TBaseVirtualTree = class(TCustomControl)

  private

    FBorderStyle: TBorderStyle;

    FHeader: TVTHeader;

    FRoot: PVirtualNode;

    FDefaultNodeHeight,

    FIndent: Cardinal;

    FOptions: TCustomVirtualTreeOptions;

    FUpdateCount: Cardinal;                      // update stopper, updates of the tree control are only done if = 0

    FSynchUpdateCount: Cardinal;                 // synchronizer, causes all events which are usually done via timers

                                                 // to happen immediately, regardless of the normal update state

    FNodeDataSize: Integer;                      // number of bytes to allocate with each node (in addition to its base

                                                 // structure and the internal data), if -1 then do callback

    FStates: TVirtualTreeStates;                 // various active/pending states the tree needs to consider

    FLastSelected,

    FFocusedNode: PVirtualNode;

    FEditColumn,                                 // column to be edited (focused node)

    FFocusedColumn: TColumnIndex;                // NoColumn if no columns are active otherwise the last hit column of

                                                 // the currently focused node

    FHeightTrackPoint: TPoint;                   // Starting point of a node's height changing operation.

    FHeightTrackNode: PVirtualNode;              // Node which height is being changed.

    FHeightTrackColumn: TColumnIndex;            // Initial column where the height changing operation takes place.

    FScrollDirections: TScrollDirections;        // directions to scroll client area into depending on mouse position

    FLastStructureChangeReason: TChangeReason;   // Used for delayed structure change event.

    FLastStructureChangeNode,                    // dito

    FLastChangedNode,                            // used for delayed change event

    FCurrentHotNode: PVirtualNode;               // Node over which the mouse is hovering.

    FCurrentHotColumn: TColumnIndex;             // Column over which the mouse is hovering.

    FHotNodeButtonHit: Boolean;                  // Indicates wether the mouse is hovering over the hot node's button.

    FLastSelRect,

    FNewSelRect: TRect;                          // used while doing draw selection

    FHotCursor: TCursor;                         // can be set to additionally indicate the current hot node

    FAnimationType: THintAnimationType;          // none, fade in, slide in animation (just like those animations used

                                                 // in Win98 (slide) and Windows 2000 (fade))

    FHintMode: TVTHintMode;                      // determines the kind of the hint window

    FHintData: TVTHintData;                      // used while preparing the hint window

    FChangeDelay: Cardinal;                      // used to delay OnChange event

    FEditDelay: Cardinal;                        // determines time to elapse before a node goes into edit mode

    FPositionCache: TCache;                      // array which stores node references ordered by vertical positions

                                                 // (see also DoValidateCache for more information)

    FVisibleCount: Cardinal;                     // number of currently visible nodes

    FStartIndex: Cardinal;                       // index to start validating cache from

    FSelection: TNodeArray;                      // list of currently selected nodes

    FSelectionCount: Integer;                    // number of currently selected nodes (size of FSelection might differ)

    FSelectionLocked: Boolean;                   // prevents the tree from changing the selection 

    FRangeAnchor: PVirtualNode;                  // anchor node for selection with the keyboard, determines start of a

                                                 // selection range

    FCheckNode: PVirtualNode;                    // node which "captures" a check event

    FPendingCheckState: TCheckState;             // the new state the check node will get if all went fine

    FCheckPropagationCount: Cardinal;            // nesting level of check propagation (WL, 05.02.2004)

    FLastSelectionLevel: Integer;                // keeps the last node level for constrained multiselection

    FDrawSelShiftState: TShiftState;             // keeps the initial shift state when the user starts selection with

                                                 // the mouse

    FEditLink: IVTEditLink;                      // used to comunicate with an application defined editor

    FTempNodeCache: TNodeArray;                  // used at various places to hold temporarily a bunch of node refs.

    FTempNodeCount: Cardinal;                    // number of nodes in FTempNodeCache

    FBackground: TPicture;                       // A background image loadable at design and runtime.

    FMargin: Integer;                            // horizontal border distance

    FTextMargin: Integer;                        // space between the node's text and its horizontal bounds

    FBackgroundOffsetX,

    FBackgroundOffsetY: Integer;                 // used to fine tune the position of the background image

    FAnimationDuration: Cardinal;                // specifies how long an animation shall take (expanding, hint)

    FWantTabs: Boolean;                          // If True then the tree also consumes the tab key.

    FNodeAlignment: TVTNodeAlignment;            // determines how to interpret the align member of a node

    FHeaderRect: TRect;                          // Space which the header currently uses in the control (window coords).

    FLastHintRect: TRect;                        // Area which the mouse must leave to reshow a hint.

    FUpdateRect: TRect;

    FEmptyListMessage: UnicodeString;            // Optional message that will be displayed if no nodes exist in the control.



    // paint support and images

    FPlusBM,

    FMinusBM,                                    // small bitmaps used for tree buttons

    FHotPlusBM,

    FHotMinusBM: TBitmap;                        // small bitmaps used for hot tree buttons 

    FImages,                                     // normal images in the tree

    FStateImages,                                // state images in the tree

    FCustomCheckImages: TCustomImageList;        // application defined check images

    FCheckImageKind: TCheckImageKind;            // light or dark, cross marks or tick marks

    FCheckImages: TCustomImageList;              // Reference to global image list to be used for the check images.

    FImageChangeLink,

    FStateChangeLink,

    FCustomCheckChangeLink: TChangeLink;         // connections to the image lists

    FOldFontChange: TNotifyEvent;                // helper method pointer for tracking font changes in the off screen buffer

    FColors: TVTColors;                          // class comprising all customizable colors in the tree

    FButtonStyle: TVTButtonStyle;                // style of the tree buttons

    FButtonFillMode: TVTButtonFillMode;          // for rectangular tree buttons only: how to fill them

    FLineStyle: TVTLineStyle;                    // style of the tree lines

    FLineMode: TVTLineMode;                      // tree lines or bands etc.

    FDottedBrush: HBRUSH;                        // used to paint dotted lines without special pens

    FSelectionCurveRadius: Cardinal;             // radius for rounded selection rectangles

    FSelectionBlendFactor: Byte;                 // Determines the factor by which the selection rectangle is to be

                                                 // faded if enabled.

    FDrawSelectionMode: TVTDrawSelectionMode;    // determines the paint mode for draw selection



    // alignment and directionality support

    FAlignment: TAlignment;                      // default alignment of the tree if no columns are shown



    // drag'n drop and clipboard support

    FDragImageKind: TVTDragImageKind;            // determines whether or not and what to show in the drag image

    FDragOperations: TDragOperations;            // determines which operations are allowed during drag'n drop

    FDragThreshold: Integer;                     // used to determine when to actually start a drag'n drop operation

    FDragManager: IVTDragManager;                // drag'n drop, cut'n paste

    FDropTargetNode: PVirtualNode;               // node currently selected as drop target

    FLastDropMode: TDropMode;                    // set while dragging and used to track changes

    FDragSelection: TNodeArray;                  // temporary copy of FSelection used during drag'n drop

    FLastDragEffect: LongInt;                    // The last executed drag effect

    FDragType: TVTDragType;                      // used to switch between OLE and VCL drag'n drop

    FDragImage: TVTDragImage;                    // drag image management

    FDragWidth,

    FDragHeight: Integer;                        // size of the drag image, the larger the more CPU power is needed

    FClipboardFormats: TClipboardFormats;        // a list of clipboard format descriptions enabled for this tree

    FLastVCLDragTarget: PVirtualNode;            // A node cache for VCL drag'n drop (keywords: DragLeave on DragDrop).

    FVCLDragEffect: Integer;                     // A cache for VCL drag'n drop to keep the current drop effect.



    // scroll support

    FScrollBarOptions: TScrollBarOptions;        // common properties of horizontal and vertical scrollbar

    FAutoScrollInterval: TAutoScrollInterval;    // determines speed of auto scrolling

    FAutoScrollDelay: Cardinal;                  // amount of milliseconds to wait until autoscrolling becomes active

    FAutoExpandDelay: Cardinal;                  // amount of milliseconds to wait until a node is expanded if it is the

                                                 // drop target

    FOffsetX: Integer;

    FOffsetY: Integer;                           // Determines left and top scroll offset.

    FEffectiveOffsetX: Integer;                  // Actual position of the horizontal scroll bar (varies depending on bidi mode).

    FRangeX,

    FRangeY: Cardinal;                           // current virtual width and height of the tree

    FBottomSpace: Cardinal;                      // Extra space below the last node.



    FDefaultPasteMode: TVTNodeAttachMode;        // Used to determine where to add pasted nodes to.

    FSingletonNodeArray: TNodeArray;             // Contains only one element for quick addition of single nodes

                                                 // to the selection.

    FDragScrollStart: Cardinal;                  // Contains the start time when a tree does auto scrolling as drop target.



    // search

    FIncrementalSearch: TVTIncrementalSearch;    // Used to determine whether and how incremental search is to be used.

    FSearchTimeout: Cardinal;                    // Number of milliseconds after which to stop incremental searching.

    FSearchBuffer: UnicodeString;                 // Collects a sequence of keypresses used to do incremental searching.

    FLastSearchNode: PVirtualNode;               // Reference to node which was last found as search fit.

    FSearchDirection: TVTSearchDirection;        // Direction to incrementally search the tree.

    FSearchStart: TVTSearchStart;                // Where to start iteration on each key press.



    // miscellanous

    FTotalInternalDataSize: Cardinal;            // Cache of the sum of the necessary internal data size for all tree

                                                 // classes derived from this base class.

    FPanningWindow: HWND;                        // Helper window for wheel panning

    FPanningCursor: HCURSOR;                     // Current wheel panning cursor.

    FPanningImage: TBitmap;                      // A little 32x32 bitmap to indicate the panning reference point.

    FLastClickPos: TPoint;                       // Used for retained drag start and wheel mouse scrolling.

    FOperationCount: Cardinal;                   // Counts how many nested long-running operations are in progress.

    FOperationCanceled: Boolean;                 // Used to indicate that a long-running operation should be canceled.

    FChangingTheme: Boolean;                     // Used to indicate that a theme change is goi ng on

    FNextNodeToSelect: PVirtualNode;             // Next tree node that we would like to select if the current one gets deleted or looses selection for other reasons.



    // MSAA support

    FAccessible: IAccessible;                    // The IAccessible interface to the window itself.

    FAccessibleItem: IAccessible;                // The IAccessible to the item that currently has focus.

    FAccessibleName: string;                     // The name the window is given for screen readers.



    // export

    FOnBeforeNodeExport: TVTNodeExportEvent;     // called before exporting a node

    FOnNodeExport: TVTNodeExportEvent;

    FOnAfterNodeExport: TVTNodeExportEvent;      // called after exporting a node

    FOnBeforeColumnExport: TVTColumnExportEvent; // called before exporting a column

    FOnColumnExport: TVTColumnExportEvent;

    FOnAfterColumnExport: TVTColumnExportEvent;  // called after  exporting a column

    FOnBeforeTreeExport: TVTTreeExportEvent;     // called before starting the export

    FOnAfterTreeExport: TVTTreeExportEvent;      // called after finishing the export

    FOnBeforeHeaderExport: TVTTreeExportEvent;   // called before exporting the header

    FOnAfterHeaderExport: TVTTreeExportEvent;    // called after exporting the header



    // common events

    FOnChange: TVTChangeEvent;                   // selection change

    FOnStructureChange: TVTStructureChangeEvent; // structural change like adding nodes etc.

    FOnInitChildren: TVTInitChildrenEvent;       // called when a node's children are needed (expanding etc.)

    FOnInitNode: TVTInitNodeEvent;               // called when a node needs to be initialized (child count etc.)

    FOnFreeNode: TVTFreeNodeEvent;               // called when a node is about to be destroyed, user data can and should

                                                 // be freed in this event

    FOnGetImage: TVTGetImageEvent;               // Used to retrieve the image index of a given node.

    FOnGetImageEx: TVTGetImageExEvent;           // Used to retrieve the image index of a given node along with a custom

                                                 // image list.

    FOnGetImageText: TVTGetImageTextEvent;       // Used to retrieve the image alternative text of a given node.

                                                 // Used by the accessibility interface to provide useful text for status images.

    FOnHotChange: TVTHotNodeChangeEvent;         // called when the current "hot" node (that is, the node under the mouse)

                                                 // changes and hot tracking is enabled

    FOnExpanding,                                // called just before a node is expanded

    FOnCollapsing: TVTChangingEvent;             // called just before a node is collapsed

    FOnChecking: TVTCheckChangingEvent;          // called just before a node's check state is changed

    FOnExpanded,                                 // called after a node has been expanded

    FOnCollapsed,                                // called after a node has been collapsed

    FOnChecked: TVTChangeEvent;                  // called after a node's check state has been changed

    FOnResetNode: TVTChangeEvent;                // called when a node is set to be uninitialized

    FOnNodeMoving: TVTNodeMovingEvent;           // called just before a node is moved from one parent node to another

                                                 // (this can be cancelled)

    FOnNodeMoved: TVTNodeMovedEvent;             // called after a node and its children have been moved to another

                                                 // parent node (probably another tree, but within the same application)

    FOnNodeCopying: TVTNodeCopyingEvent;         // called when a node is copied to another parent node (probably in

                                                 // another tree, but within the same application, can be cancelled)

    FOnNodeClick: TVTNodeClickEvent;             // called when the user clicks on a node

    FOnNodeDblClick: TVTNodeClickEvent;          // called when the user double clicks on a node

    FOnCanSplitterResizeNode: TVTCanSplitterResizeNodeEvent;       // called to query the application wether resizing a node is allowed

    FOnNodeHeightTracking: TVTNodeHeightTrackingEvent;             // called when a node's height is being changed via mouse

    FOnNodeHeightDblClickResize: TVTNodeHeightDblClickResizeEvent; // called when a node's vertical splitter is double clicked

    FOnNodeCopied: TVTNodeCopiedEvent;           // call after a node has been copied

    FOnEditing: TVTEditChangingEvent;            // called just before a node goes into edit mode

    FOnEditCancelled: TVTEditCancelEvent;        // called when editing has been cancelled

    FOnEdited: TVTEditChangeEvent;               // called when editing has successfully been finished

    FOnFocusChanging: TVTFocusChangingEvent;     // called when the focus is about to go to a new node and/or column

                                                 // (can be cancelled)

    FOnFocusChanged: TVTFocusChangeEvent;        // called when the focus goes to a new node and/or column

    FOnAddToSelection: TVTAddToSelectionEvent;           // called when a node is added to the selection

    FOnRemoveFromSelection: TVTRemoveFromSelectionEvent; // called when a node is removed from the selection

    FOnGetPopupMenu: TVTPopupEvent;              // called when the popup for a node or the header needs to be shown

    FOnGetHelpContext: TVTHelpContextEvent;      // called when a node specific help theme should be called

    FOnCreateEditor: TVTCreateEditorEvent;       // called when a node goes into edit mode, this allows applications

                                                 // to supply their own editor

    FOnLoadNode,                                 // called after a node has been loaded from a stream (file, clipboard,

                                                 // OLE drag'n drop) to allow an application to load their own data

                                                 // saved in OnSaveNode

    FOnSaveNode: TVTSaveNodeEvent;               // called when a node needs to be serialized into a stream

                                                 // (see OnLoadNode) to give the application the opportunity to save

                                                 // their node specific, persistent data (note: never save memory

                                                 // references)

    FOnLoadTree,                                 // called after the tree has been loaded from a stream to allow an

                                                 // application to load their own data saved in OnSaveTree

    FOnSaveTree: TVTSaveTreeEvent;               // called after the tree has been saved to a stream to allow an

                                                 // application to save its own data



    // header/column mouse events

    FOnAfterAutoFitColumn: TVTAfterAutoFitColumnEvent;

    FOnAfterAutoFitColumns: TVTAfterAutoFitColumnsEvent;

    FOnBeforeAutoFitColumns: TVTBeforeAutoFitColumnsEvent;

    FOnBeforeAutoFitColumn: TVTBeforeAutoFitColumnEvent;

    FOnHeaderClick: TVTHeaderClickEvent;

    FOnHeaderDblClick: TVTHeaderClickEvent;

    FOnAfterHeaderHeightTracking: TVTAfterHeaderHeightTrackingEvent;

    FOnBeforeHeaderHeightTracking: TVTBeforeHeaderHeightTrackingEvent;

    FOnHeaderHeightTracking: TVTHeaderHeightTrackingEvent;

    FOnHeaderHeightDblClickResize: TVTHeaderHeightDblClickResizeEvent;

    FOnHeaderMouseDown,

    FOnHeaderMouseUp: TVTHeaderMouseEvent;

    FOnHeaderMouseMove: TVTHeaderMouseMoveEvent;

    FOnAfterGetMaxColumnWidth: TVTAfterGetMaxColumnWidthEvent;

    FOnBeforeGetMaxColumnWidth: TVTBeforeGetMaxColumnWidthEvent;

    FOnColumnClick: TVTColumnClickEvent;

    FOnColumnDblClick: TVTColumnDblClickEvent;

    FOnColumnResize: TVTHeaderNotifyEvent;

    FOnColumnWidthDblClickResize: TVTColumnWidthDblClickResizeEvent;

    FOnAfterColumnWidthTracking: TVTAfterColumnWidthTrackingEvent;

    FOnBeforeColumnWidthTracking: TVTBeforeColumnWidthTrackingEvent;

    FOnColumnWidthTracking: TVTColumnWidthTrackingEvent;

    FOnGetHeaderCursor: TVTGetHeaderCursorEvent; // triggered to allow the app. to use customized cursors for the header

    FOnCanSplitterResizeColumn: TVTCanSplitterResizeColumnEvent;

    FOnCanSplitterResizeHeader: TVTCanSplitterResizeHeaderEvent;



    // paint events

    FOnAfterPaint,                               // triggered when the tree has entirely been painted

    FOnBeforePaint: TVTPaintEvent;               // triggered when the tree is about to be painted

    FOnAfterItemPaint: TVTAfterItemPaintEvent;   // triggered after an item has been painted

    FOnBeforeItemPaint: TVTBeforeItemPaintEvent; // triggered when an item is about to be painted

    FOnBeforeItemErase: TVTBeforeItemEraseEvent; // triggered when an item's background is about to be erased

    FOnAfterItemErase: TVTAfterItemEraseEvent;   // triggered after an item's background has been erased

    FOnAfterCellPaint: TVTAfterCellPaintEvent;   // triggered after a column of an item has been painted

    FOnBeforeCellPaint: TVTBeforeCellPaintEvent; // triggered when a column of an item is about to be painted

    FOnHeaderDraw: TVTHeaderPaintEvent;          // Used when owner draw is enabled for the header and a column is set

                                                 // to owner draw mode.

    FOnHeaderDrawQueryElements: TVTHeaderPaintQueryElementsEvent; // Used for advanced header painting to query the

                                                 // application for the elements, which are drawn by it and which should

                                                 // be drawn by the tree.

    FOnAdvancedHeaderDraw: TVTAdvancedHeaderPaintEvent; // Used when owner draw is enabled for the header and a column

                                                 // is set to owner draw mode. But only if OnHeaderDrawQueryElements

                                                 // returns at least one element to be drawn by the application.

                                                 // In this case OnHeaderDraw is not used.

    FOnGetLineStyle: TVTGetLineStyleEvent;       // triggered when a custom line style is used and the pattern brush

                                                 // needs to be build

    FOnPaintBackground: TVTBackgroundPaintEvent; // triggered if a part of the tree's background must be erased which is

                                                 // not covered by any node

    FOnMeasureItem: TVTMeasureItemEvent;         // Triggered when a node is about to be drawn and its height was not yet

                                                 // determined by the application.



    // drag'n drop events

    FOnCreateDragManager: TVTCreateDragManagerEvent; // called to allow for app./descendant defined drag managers

    FOnCreateDataObject: TVTCreateDataObjectEvent; // called to allow for app./descendant defined data objects

    FOnDragAllowed: TVTDragAllowedEvent;         // used to get permission for manual drag in mouse down

    FOnDragOver: TVTDragOverEvent;               // called for every mouse move

    FOnDragDrop: TVTDragDropEvent;               // called on release of mouse button (if drop was allowed)

    FOnHeaderDragged: TVTHeaderDraggedEvent;     // header (column) drag'n drop

    FOnHeaderDraggedOut: TVTHeaderDraggedOutEvent; // header (column) drag'n drop, which did not result in a valid drop.

    FOnHeaderDragging: TVTHeaderDraggingEvent;   // header (column) drag'n drop

    FOnRenderOLEData: TVTRenderOLEDataEvent;     // application/descendant defined clipboard formats

    FOnGetUserClipboardFormats: TVTGetUserClipboardFormatsEvent; // gives application/descendants the opportunity to

                                                 // add own clipboard formats on the fly



    // miscellanous events

    FOnGetNodeDataSize: TVTGetNodeDataSizeEvent; // Called if NodeDataSize is -1.

    FOnBeforeDrawLineImage: TVTBeforeDrawLineImageEvent; // Called to allow adjusting the indention of treelines.

    FOnKeyAction: TVTKeyActionEvent;             // Used to selectively prevent key actions (full expand on Ctrl+'+' etc.).

    FOnScroll: TVTScrollEvent;                   // Called when one or both paint offsets changed.

    FOnUpdating: TVTUpdatingEvent;               // Called from BeginUpdate, EndUpdate, BeginSynch and EndSynch.

    FOnGetCursor: TVTGetCursorEvent;             // Called to allow the app. to set individual cursors.

    FOnStateChange: TVTStateChangeEvent;         // Called whenever a state in the tree changes.

    FOnGetCellIsEmpty: TVTGetCellIsEmptyEvent;   // Called when the tree needs to know if a cell is empty.

    FOnShowScrollBar: TVTScrollBarShowEvent;     // Called when a scrollbar is changed in its visibility.



    // search, sort

    FOnCompareNodes: TVTCompareEvent;            // used during sort

    FOnDrawHint: TVTDrawHintEvent;

    FOnGetHintSize: TVTGetHintSizeEvent;

    FOnGetHintKind: TVTHintKindEvent;

    FOnIncrementalSearch: TVTIncrementalSearchEvent; // triggered on every key press (not key down)

    FOnMouseEnter: TNotifyEvent;

    FOnMouseLeave: TNotifyEvent;



    // operations

    FOnStartOperation: TVTOperationEvent;        // Called when an operation starts

    FOnEndOperation: TVTOperationEvent;          // Called when an operation ends



    FVclStyleEnabled: Boolean;



    {$if CompilerVersion >= 23 }

    FSavedBevelKind: TBevelKind;

    FSavedBorderWidth: Integer;

    FSetOrRestoreBevelKindAndBevelWidth: Boolean;

    procedure CMStyleChanged(var Message: TMessage); message CM_STYLECHANGED;

    procedure CMBorderChanged(var Message: TMessage); message CM_BORDERCHANGED;

    procedure CMParentDoubleBufferedChange(var Message: TMessage); message CM_PARENTDOUBLEBUFFEREDCHANGED;

    {$ifend}



    procedure AdjustCoordinatesByIndent(var PaintInfo: TVTPaintInfo; Indent: Integer);

    procedure AdjustTotalCount(Node: PVirtualNode; Value: Integer; Relative: Boolean = False);

    procedure AdjustTotalHeight(Node: PVirtualNode; Value: Integer; Relative: Boolean = False);

    function CalculateCacheEntryCount: Integer;

    procedure CalculateVerticalAlignments(ShowImages, ShowStateImages: Boolean; Node: PVirtualNode; var VAlign,

      VButtonAlign: Integer);

    function ChangeCheckState(Node: PVirtualNode; Value: TCheckState): Boolean;

    function CollectSelectedNodesLTR(MainColumn, NodeLeft, NodeRight: Integer; Alignment: TAlignment; OldRect,

      NewRect: TRect): Boolean;

    function CollectSelectedNodesRTL(MainColumn, NodeLeft, NodeRight: Integer; Alignment: TAlignment; OldRect,

      NewRect: TRect): Boolean;

    procedure ClearNodeBackground(const PaintInfo: TVTPaintInfo; UseBackground, Floating: Boolean; R: TRect);

    function CompareNodePositions(Node1, Node2: PVirtualNode; ConsiderChildrenAbove: Boolean = False): Integer;

    procedure DrawLineImage(const PaintInfo: TVTPaintInfo; X, Y, H, VAlign: Integer; Style: TVTLineType; Reverse: Boolean);

    function FindInPositionCache(Node: PVirtualNode; var CurrentPos: Cardinal): PVirtualNode; overload;

    function FindInPositionCache(Position: Cardinal; var CurrentPos: Cardinal): PVirtualNode; overload;

    procedure FixupTotalCount(Node: PVirtualNode);

    procedure FixupTotalHeight(Node: PVirtualNode);

    function GetBottomNode: PVirtualNode;

    function GetCheckedCount: Integer;

    function GetCheckState(Node: PVirtualNode): TCheckState;

    function GetCheckType(Node: PVirtualNode): TCheckType;

    function GetChildCount(Node: PVirtualNode): Cardinal;

    function GetChildrenInitialized(Node: PVirtualNode): Boolean;

    function GetCutCopyCount: Integer;

    function GetDisabled(Node: PVirtualNode): Boolean;

    function GetDragManager: IVTDragManager;

    function GetExpanded(Node: PVirtualNode): Boolean;

    function GetFiltered(Node: PVirtualNode): Boolean;

    function GetFullyVisible(Node: PVirtualNode): Boolean;

    function GetHasChildren(Node: PVirtualNode): Boolean;

    function GetMultiline(Node: PVirtualNode): Boolean;

    function GetNodeHeight(Node: PVirtualNode): Cardinal;

    function GetNodeParent(Node: PVirtualNode): PVirtualNode;

    function GetOffsetXY: TPoint;

    function GetRootNodeCount: Cardinal;

    function GetSelected(Node: PVirtualNode): Boolean;

    function GetTopNode: PVirtualNode;

    function GetTotalCount: Cardinal;

    function GetVerticalAlignment(Node: PVirtualNode): Byte;

    function GetVisible(Node: PVirtualNode): Boolean;

    function GetVisiblePath(Node: PVirtualNode): Boolean;

    procedure HandleClickSelection(LastFocused, NewNode: PVirtualNode; Shift: TShiftState; DragPending: Boolean);

    function HandleDrawSelection(X, Y: Integer): Boolean;

    function HasVisibleNextSibling(Node: PVirtualNode): Boolean;

    function HasVisiblePreviousSibling(Node: PVirtualNode): Boolean;

    procedure ImageListChange(Sender: TObject);

    procedure InitializeFirstColumnValues(var PaintInfo: TVTPaintInfo);

    procedure InitRootNode(OldSize: Cardinal = 0);

    procedure InterruptValidation;

    function IsFirstVisibleChild(Parent, Node: PVirtualNode): Boolean;

    function IsLastVisibleChild(Parent, Node: PVirtualNode): Boolean;

    function MakeNewNode: PVirtualNode;

    function PackArray({*}const TheArray: TNodeArray; Count: Integer): Integer;

    procedure PrepareBitmaps(NeedButtons, NeedLines: Boolean);

    procedure ReadOldOptions(Reader: TReader);

    procedure SetAlignment(const Value: TAlignment);

    procedure SetAnimationDuration(const Value: Cardinal);

    procedure SetBackground(const Value: TPicture);

    procedure SetBackgroundOffset(const Index, Value: Integer);

    procedure SetBorderStyle(Value: TBorderStyle);

    procedure SetBottomNode(Node: PVirtualNode);

    procedure SetBottomSpace(const Value: Cardinal);

    procedure SetButtonFillMode(const Value: TVTButtonFillMode);

    procedure SetButtonStyle(const Value: TVTButtonStyle);

    procedure SetCheckImageKind(Value: TCheckImageKind);

    procedure SetCheckState(Node: PVirtualNode; Value: TCheckState);

    procedure SetCheckType(Node: PVirtualNode; Value: TCheckType);

    procedure SetChildCount(Node: PVirtualNode; NewChildCount: Cardinal);

    procedure SetClipboardFormats(const Value: TClipboardFormats);

    procedure SetColors(const Value: TVTColors);

    procedure SetCustomCheckImages(const Value: TCustomImageList);

    procedure SetDefaultNodeHeight(Value: Cardinal);

    procedure SetDisabled(Node: PVirtualNode; Value: Boolean);

    procedure SetEmptyListMessage(const Value: UnicodeString);

    procedure SetExpanded(Node: PVirtualNode; Value: Boolean);

    procedure SetFocusedColumn(Value: TColumnIndex);

    procedure SetFocusedNode(Value: PVirtualNode);

    procedure SetFullyVisible(Node: PVirtualNode; Value: Boolean);

    procedure SetHasChildren(Node: PVirtualNode; Value: Boolean);

    procedure SetHeader(const Value: TVTHeader);

    procedure SetFiltered(Node: PVirtualNode; Value: Boolean);

    procedure SetImages(const Value: TCustomImageList);

    procedure SetIndent(Value: Cardinal);

    procedure SetLineMode(const Value: TVTLineMode);

    procedure SetLineStyle(const Value: TVTLineStyle);

    procedure SetMargin(Value: Integer);

    procedure SetMultiline(Node: PVirtualNode; const Value: Boolean);

    procedure SetNodeAlignment(const Value: TVTNodeAlignment);

    procedure SetNodeDataSize(Value: Integer);

    procedure SetNodeHeight(Node: PVirtualNode; Value: Cardinal);

    procedure SetNodeParent(Node: PVirtualNode; const Value: PVirtualNode);

    procedure SetOffsetX(const Value: Integer);

    procedure SetOffsetXY(const Value: TPoint);

    procedure SetOffsetY(const Value: Integer);

    procedure SetOptions(const Value: TCustomVirtualTreeOptions);

    procedure SetRootNodeCount(Value: Cardinal);

    procedure SetScrollBarOptions(Value: TScrollBarOptions);

    procedure SetSearchOption(const Value: TVTIncrementalSearch);

    procedure SetSelected(Node: PVirtualNode; Value: Boolean);

    procedure SetSelectionCurveRadius(const Value: Cardinal);

    procedure SetStateImages(const Value: TCustomImageList);

    procedure SetTextMargin(Value: Integer);

    procedure SetTopNode(Node: PVirtualNode);

    procedure SetUpdateState(Updating: Boolean);

    procedure SetVerticalAlignment(Node: PVirtualNode; Value: Byte);

    procedure SetVisible(Node: PVirtualNode; Value: Boolean);

    procedure SetVisiblePath(Node: PVirtualNode; Value: Boolean);

    procedure StaticBackground(Source: TBitmap; Target: TCanvas; OffsetPosition: TPoint; R: TRect);

    procedure StopTimer(ID: Integer);

    procedure SetWindowTheme(Theme: UnicodeString);

    procedure TileBackground(Source: TBitmap; Target: TCanvas; Offset: TPoint; R: TRect);

    function ToggleCallback(Step, StepSize: Integer; Data: Pointer): Boolean;



    procedure CMColorChange(var Message: TMessage); message CM_COLORCHANGED;

    procedure CMCtl3DChanged(var Message: TMessage); message CM_CTL3DCHANGED;

    procedure CMBiDiModeChanged(var Message: TMessage); message CM_BIDIMODECHANGED;

    procedure CMDenySubclassing(var Message: TMessage); message CM_DENYSUBCLASSING;

    procedure CMDrag(var Message: TCMDrag); message CM_DRAG;

    procedure CMEnabledChanged(var Message: TMessage); message CM_ENABLEDCHANGED;

    procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;

    procedure CMHintShow(var Message: TCMHintShow); message CM_HINTSHOW;

    procedure CMHintShowPause(var Message: TCMHintShowPause); message CM_HINTSHOWPAUSE;

    procedure CMMouseEnter(var Message: TMessage); message CM_MOUSEENTER;

    procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE;

    procedure CMMouseWheel(var Message: TCMMouseWheel); message CM_MOUSEWHEEL;

    procedure CMSysColorChange(var Message: TMessage); message CM_SYSCOLORCHANGE;

    procedure TVMGetItem(var Message: TMessage); message TVM_GETITEM;

    procedure TVMGetItemRect(var Message: TMessage); message TVM_GETITEMRECT;

    procedure TVMGetNextItem(var Message: TMessage); message TVM_GETNEXTITEM;

    procedure WMCancelMode(var Message: TWMCancelMode); message WM_CANCELMODE;

    procedure WMChangeState(var Message: TMessage); message WM_CHANGESTATE;

    procedure WMChar(var Message: TWMChar); message WM_CHAR;

    procedure WMContextMenu(var Message: TWMContextMenu); message WM_CONTEXTMENU;

    procedure WMCopy(var Message: TWMCopy); message WM_COPY;

    procedure WMCut(var Message: TWMCut); message WM_CUT;

    procedure WMEnable(var Message: TWMEnable); message WM_ENABLE;

    procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND;

    procedure WMGetDlgCode(var Message: TWMGetDlgCode); message WM_GETDLGCODE;

    procedure WMGetObject(var Message: TMessage); message WM_GETOBJECT;

    procedure WMHScroll(var Message: TWMHScroll); message WM_HSCROLL;

    procedure WMKeyDown(var Message: TWMKeyDown); message WM_KEYDOWN;

    procedure WMKeyUp(var Message: TWMKeyUp); message WM_KEYUP;

    procedure WMKillFocus(var Msg: TWMKillFocus); message WM_KILLFOCUS;

    procedure WMLButtonDblClk(var Message: TWMLButtonDblClk); message WM_LBUTTONDBLCLK;

    procedure WMLButtonDown(var Message: TWMLButtonDown); message WM_LBUTTONDOWN;

    procedure WMLButtonUp(var Message: TWMLButtonUp); message WM_LBUTTONUP;

    procedure WMMButtonDblClk(var Message: TWMMButtonDblClk); message WM_MBUTTONDBLCLK;

    procedure WMMButtonDown(var Message: TWMMButtonDown); message WM_MBUTTONDOWN;

    procedure WMMButtonUp(var Message: TWMMButtonUp); message WM_MBUTTONUP;

    procedure WMNCCalcSize(var Message: TWMNCCalcSize); message WM_NCCALCSIZE;

    procedure WMNCDestroy(var Message: TWMNCDestroy); message WM_NCDESTROY;

    procedure WMNCHitTest(var Message: TWMNCHitTest); message WM_NCHITTEST;

    procedure WMNCPaint(var Message: TRealWMNCPaint); message WM_NCPAINT;

    procedure WMPaint(var Message: TWMPaint); message WM_PAINT;

    procedure WMPaste(var Message: TWMPaste); message WM_PASTE;

    procedure WMPrint(var Message: TWMPrint); message WM_PRINT;

    procedure WMPrintClient(var Message: TWMPrintClient); message WM_PRINTCLIENT;

    procedure WMRButtonDblClk(var Message: TWMRButtonDblClk); message WM_RBUTTONDBLCLK;

    procedure WMRButtonDown(var Message: TWMRButtonDown); message WM_RBUTTONDOWN;

    procedure WMRButtonUp(var Message: TWMRButtonUp); message WM_RBUTTONUP;

    procedure WMSetCursor(var Message: TWMSetCursor); message WM_SETCURSOR;

    procedure WMSetFocus(var Msg: TWMSetFocus); message WM_SETFOCUS;

    procedure WMSize(var Message: TWMSize); message WM_SIZE;

    procedure WMTimer(var Message: TWMTimer); message WM_TIMER;

    procedure WMThemeChanged(var Message: TMessage); message WM_THEMECHANGED;

    procedure WMVScroll(var Message: TWMVScroll); message WM_VSCROLL;

    function GetRangeX: Cardinal;

    function GetDoubleBuffered: Boolean;

    procedure SetDoubleBuffered(const Value: Boolean);

    procedure ChangeTreeStatesAsync(EnterStates, LeaveStates: TChangeStates);

  protected

    FFontChanged: Boolean;                       // flag for keeping informed about font changes in the off screen buffer   // [IPK] - private to protected

    procedure AutoScale(); virtual;

    procedure AddToSelection(Node: PVirtualNode); overload; virtual;

    procedure AddToSelection(const NewItems: TNodeArray; NewLength: Integer; ForceInsert: Boolean = False); overload; virtual;

    procedure AdjustImageBorder(Images: TCustomImageList; BidiMode: TBidiMode; VAlign: Integer; var R: TRect;

      var ImageInfo: TVTImageInfo); virtual;

    procedure AdjustPaintCellRect(var PaintInfo: TVTPaintInfo; var NextNonEmpty: TColumnIndex); virtual;

    procedure AdjustPanningCursor(X, Y: Integer); virtual;

    procedure AdviseChangeEvent(StructureChange: Boolean; Node: PVirtualNode; Reason: TChangeReason); virtual;

    function AllocateInternalDataArea(Size: Cardinal): Cardinal; virtual;

    procedure Animate(Steps, Duration: Cardinal; Callback: TVTAnimationCallback; Data: Pointer); virtual;

    function CalculateSelectionRect(X, Y: Integer): Boolean; virtual;

    function CanAutoScroll: Boolean; virtual;

    function CanShowDragImage: Boolean; virtual;

    function CanSplitterResizeNode(P: TPoint; Node: PVirtualNode; Column: TColumnIndex): Boolean;

    procedure Change(Node: PVirtualNode); virtual;

    procedure ChangeScale(M, D: Integer); override;

    function CheckParentCheckState(Node: PVirtualNode; NewCheckState: TCheckState): Boolean; virtual;

    procedure ClearTempCache; virtual;

    function ColumnIsEmpty(Node: PVirtualNode; Column: TColumnIndex): Boolean; virtual;

    function ComputeRTLOffset(ExcludeScrollBar: Boolean = False): Integer; virtual;

    function CountLevelDifference(Node1, Node2: PVirtualNode): Integer; virtual;

    function CountVisibleChildren(Node: PVirtualNode): Cardinal; virtual;

    procedure CreateParams(var Params: TCreateParams); override;

    procedure CreateWnd; override;

    procedure DefineProperties(Filer: TFiler); override;

    function DetermineDropMode(const P: TPoint; var HitInfo: THitInfo; var NodeRect: TRect): TDropMode; virtual;

    procedure DetermineHiddenChildrenFlag(Node: PVirtualNode); virtual;

    procedure DetermineHiddenChildrenFlagAllNodes; virtual;

    procedure DetermineHitPositionLTR(var HitInfo: THitInfo; Offset, Right: Integer; Alignment: TAlignment); virtual;

    procedure DetermineHitPositionRTL(var HitInfo: THitInfo; Offset, Right: Integer; Alignment: TAlignment); virtual;

    function DetermineLineImageAndSelectLevel(Node: PVirtualNode; var LineImage: TLineImage): Integer; virtual;

    function DetermineNextCheckState(CheckType: TCheckType; CheckState: TCheckState): TCheckState; virtual;

    function DetermineScrollDirections(X, Y: Integer): TScrollDirections; virtual;

    procedure DoAdvancedHeaderDraw(var PaintInfo: THeaderPaintInfo; const Elements: THeaderPaintElements); virtual;

    procedure DoAfterCellPaint(Canvas: TCanvas; Node: PVirtualNode; Column: TColumnIndex; CellRect: TRect); virtual;

    procedure DoAfterItemErase(Canvas: TCanvas; Node: PVirtualNode; ItemRect: TRect); virtual;

    procedure DoAfterItemPaint(Canvas: TCanvas; Node: PVirtualNode; ItemRect: TRect); virtual;

    procedure DoAfterPaint(Canvas: TCanvas); virtual;

    procedure DoAutoScroll(X, Y: Integer); virtual;

    function DoBeforeDrag(Node: PVirtualNode; Column: TColumnIndex): Boolean; virtual;

    procedure DoBeforeCellPaint(Canvas: TCanvas; Node: PVirtualNode; Column: TColumnIndex;

      CellPaintMode: TVTCellPaintMode; CellRect: TRect; var ContentRect: TRect); virtual;

    procedure DoBeforeItemErase(Canvas: TCanvas; Node: PVirtualNode; ItemRect: TRect; var Color: TColor;

      var EraseAction: TItemEraseAction); virtual;

    function DoBeforeItemPaint(Canvas: TCanvas; Node: PVirtualNode; ItemRect: TRect): Boolean; virtual;

    procedure DoBeforePaint(Canvas: TCanvas); virtual;

    function DoCancelEdit: Boolean; virtual;

    procedure DoCanEdit(Node: PVirtualNode; Column: TColumnIndex; var Allowed: Boolean); virtual;

    procedure DoCanSplitterResizeNode(P: TPoint; Node: PVirtualNode; Column: TColumnIndex;

      var Allowed: Boolean); virtual;

    procedure DoChange(Node: PVirtualNode); virtual;

    procedure DoCheckClick(Node: PVirtualNode; NewCheckState: TCheckState); virtual;

    procedure DoChecked(Node: PVirtualNode); virtual;

    function DoChecking(Node: PVirtualNode; var NewCheckState: TCheckState): Boolean; virtual;

    procedure DoCollapsed(Node: PVirtualNode); virtual;

    function DoCollapsing(Node: PVirtualNode): Boolean; virtual;

    procedure DoColumnClick(Column: TColumnIndex; Shift: TShiftState); virtual;

    procedure DoColumnDblClick(Column: TColumnIndex; Shift: TShiftState); virtual;

    procedure DoColumnResize(Column: TColumnIndex); virtual;

    function DoCompare(Node1, Node2: PVirtualNode; Column: TColumnIndex): Integer; virtual;

    function DoCreateDataObject: IDataObject; virtual;

    function DoCreateDragManager: IVTDragManager; virtual;

    function DoCreateEditor(Node: PVirtualNode; Column: TColumnIndex): IVTEditLink; virtual;

    procedure DoDragging(P: TPoint); virtual;

    procedure DoDragExpand; virtual;

    procedure DoBeforeDrawLineImage(Node: PVirtualNode; Level: Integer; var XPos: Integer); virtual;

    function DoDragOver(Source: TObject; Shift: TShiftState; State: TDragState; Pt: TPoint; Mode: TDropMode;

      var Effect: Integer): Boolean; virtual;

    procedure DoDragDrop(Source: TObject; DataObject: IDataObject; Formats: TFormatArray; Shift: TShiftState; Pt: TPoint;

      var Effect: Integer; Mode: TDropMode); virtual;

    procedure DoDrawHint(Canvas: TCanvas; Node: PVirtualNode; R: TRect; Column:

        TColumnIndex);

    procedure DoEdit; virtual;

    procedure DoEndDrag(Target: TObject; X, Y: Integer); override;

    function DoEndEdit: Boolean; virtual;

    procedure DoEndOperation(OperationKind: TVTOperationKind); virtual;

    procedure DoEnter(); override;

    procedure DoExpanded(Node: PVirtualNode); virtual;

    function DoExpanding(Node: PVirtualNode): Boolean; virtual;

    procedure DoFocusChange(Node: PVirtualNode; Column: TColumnIndex); virtual;

    function DoFocusChanging(OldNode, NewNode: PVirtualNode; OldColumn, NewColumn: TColumnIndex): Boolean; virtual;

    procedure DoFocusNode(Node: PVirtualNode; Ask: Boolean); virtual;

    procedure DoFreeNode(Node: PVirtualNode); virtual;

    function DoGetAnimationType: THintAnimationType; virtual;

    function DoGetCellContentMargin(Node: PVirtualNode; Column: TColumnIndex;

      CellContentMarginType: TVTCellContentMarginType = ccmtAllSides; Canvas: TCanvas = nil): TPoint; virtual;

    procedure DoGetCursor(var Cursor: TCursor); virtual;

    procedure DoGetHeaderCursor(var Cursor: HCURSOR); virtual;

    procedure DoGetHintSize(Node: PVirtualNode; Column: TColumnIndex; var R:

        TRect); virtual;

    procedure DoGetHintKind(Node: PVirtualNode; Column: TColumnIndex; var Kind:

        TVTHintKind);

    function DoGetImageIndex(Node: PVirtualNode; Kind: TVTImageKind; Column: TColumnIndex;

      var Ghosted: Boolean; var Index: Integer): TCustomImageList; virtual;

    procedure DoGetImageText(Node: PVirtualNode; Kind: TVTImageKind; Column: TColumnIndex;

      var ImageText: UnicodeString); virtual;

    procedure DoGetLineStyle(var Bits: Pointer); virtual;

    function DoGetNodeHint(Node: PVirtualNode; Column: TColumnIndex; var LineBreakStyle: TVTTooltipLineBreakStyle): UnicodeString; virtual;

    function DoGetNodeTooltip(Node: PVirtualNode; Column: TColumnIndex; var LineBreakStyle: TVTTooltipLineBreakStyle): UnicodeString; virtual;

    function DoGetNodeExtraWidth(Node: PVirtualNode; Column: TColumnIndex; Canvas: TCanvas = nil): Integer; virtual;

    function DoGetNodeWidth(Node: PVirtualNode; Column: TColumnIndex; Canvas: TCanvas = nil): Integer; virtual;

    function DoGetPopupMenu(Node: PVirtualNode; Column: TColumnIndex; Position: TPoint): TPopupMenu; virtual;

    procedure DoGetUserClipboardFormats(var Formats: TFormatEtcArray); virtual;

    procedure DoHeaderClick(HitInfo: TVTHeaderHitInfo); virtual;

    procedure DoHeaderDblClick(HitInfo: TVTHeaderHitInfo); virtual;

    procedure DoHeaderDragged(Column: TColumnIndex; OldPosition: TColumnPosition); virtual;

    procedure DoHeaderDraggedOut(Column: TColumnIndex; DropPosition: TPoint); virtual;

    function DoHeaderDragging(Column: TColumnIndex): Boolean; virtual;

    procedure DoHeaderDraw(Canvas: TCanvas; Column: TVirtualTreeColumn; R: TRect; Hover, Pressed: Boolean;

      DropMark: TVTDropMarkMode); virtual;

    procedure DoHeaderDrawQueryElements(var PaintInfo: THeaderPaintInfo; var Elements: THeaderPaintElements); virtual;

    procedure DoHeaderMouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); virtual;

    procedure DoHeaderMouseMove(Shift: TShiftState; X, Y: Integer); virtual;

    procedure DoHeaderMouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); virtual;

    procedure DoHotChange(Old, New: PVirtualNode); virtual;

    function DoIncrementalSearch(Node: PVirtualNode; const Text: UnicodeString): Integer; virtual;

    function DoInitChildren(Node: PVirtualNode; var ChildCount: Cardinal): Boolean; virtual;

    procedure DoInitNode(Parent, Node: PVirtualNode; var InitStates: TVirtualNodeInitStates); virtual;

    function DoKeyAction(var CharCode: Word; var Shift: TShiftState): Boolean; virtual;

    procedure DoLoadUserData(Node: PVirtualNode; Stream: TStream); virtual;

    procedure DoMeasureItem(TargetCanvas: TCanvas; Node: PVirtualNode; var NodeHeight: Integer); virtual;

    procedure DoMouseEnter(); virtual;

    procedure DoMouseLeave(); virtual;

    procedure DoNodeCopied(Node: PVirtualNode); virtual;

    function DoNodeCopying(Node, NewParent: PVirtualNode): Boolean; virtual;

    procedure DoNodeClick(const HitInfo: THitInfo); virtual;

    procedure DoNodeDblClick(const HitInfo: THitInfo); virtual;

    function DoNodeHeightDblClickResize(Node: PVirtualNode; Column: TColumnIndex; Shift: TShiftState;

      P: TPoint): Boolean; virtual;

    function DoNodeHeightTracking(Node: PVirtualNode; Column: TColumnIndex;  Shift: TShiftState;

      var TrackPoint: TPoint; P: TPoint): Boolean; virtual;

    procedure DoNodeMoved(Node: PVirtualNode); virtual;

    function DoNodeMoving(Node, NewParent: PVirtualNode): Boolean; virtual;

    function DoPaintBackground(Canvas: TCanvas; R: TRect): Boolean; virtual;

    procedure DoPaintDropMark(Canvas: TCanvas; Node: PVirtualNode; R: TRect); virtual;

    procedure DoPaintNode(var PaintInfo: TVTPaintInfo); virtual;

    procedure DoPopupMenu(Node: PVirtualNode; Column: TColumnIndex; Position: TPoint); virtual;

    procedure DoRemoveFromSelection(Node: PVirtualNode); virtual;

    function DoRenderOLEData(const FormatEtcIn: TFormatEtc; out Medium: TStgMedium;

      ForClipboard: Boolean): HRESULT; virtual;

    procedure DoReset(Node: PVirtualNode); virtual;

    procedure DoSaveUserData(Node: PVirtualNode; Stream: TStream); virtual;

    procedure DoScroll(DeltaX, DeltaY: Integer); virtual;

    function DoSetOffsetXY(Value: TPoint; Options: TScrollUpdateOptions; ClipRect: PRect = nil): Boolean; virtual;

    procedure DoShowScrollBar(Bar: Integer; Show: Boolean); virtual;

    procedure DoStartDrag(var DragObject: TDragObject); override;

    procedure DoStartOperation(OperationKind: TVTOperationKind); virtual;

    procedure DoStateChange(Enter: TVirtualTreeStates; Leave: TVirtualTreeStates = []); virtual;

    procedure DoStructureChange(Node: PVirtualNode; Reason: TChangeReason); virtual;

    procedure DoTimerScroll; virtual;

    procedure DoUpdating(State: TVTUpdateState); virtual;

    function DoValidateCache: Boolean; virtual;

    procedure DragAndDrop(AllowedEffects: DWord; DataObject: IDataObject;

      var DragEffect: LongInt); virtual;

    procedure DragCanceled; override;

    function DragDrop(const DataObject: IDataObject; KeyState: Integer; Pt: TPoint;

      var Effect: Integer): HResult; reintroduce; virtual;

    function DragEnter(KeyState: Integer; Pt: TPoint; var Effect: Integer): HResult; virtual;

    procedure DragFinished; virtual;

    procedure DragLeave; virtual;

    function DragOver(Source: TObject; KeyState: Integer; DragState: TDragState; Pt: TPoint;

      var Effect: LongInt): HResult; reintroduce; virtual;

    procedure DrawDottedHLine(const PaintInfo: TVTPaintInfo; Left, Right, Top: Integer); virtual;

    procedure DrawDottedVLine(const PaintInfo: TVTPaintInfo; Top, Bottom, Left: Integer; UseSelectedBkColor: Boolean = False); virtual;

    procedure EndOperation(OperationKind: TVTOperationKind);

    procedure EnsureNodeFocused(); virtual;

    function FindNodeInSelection(P: PVirtualNode; var Index: Integer; LowBound, HighBound: Integer): Boolean; virtual;

    procedure FinishChunkHeader(Stream: TStream; StartPos, EndPos: Integer); virtual;

    procedure FontChanged(AFont: TObject); virtual;

    function GetBorderDimensions: TSize; virtual;

    function GetCheckImage(Node: PVirtualNode; ImgCheckType: TCheckType = ctNone;

      ImgCheckState: TCheckState = csUncheckedNormal; ImgEnabled: Boolean = True): Integer; virtual;

    class function GetCheckImageListFor(Kind: TCheckImageKind): TCustomImageList; virtual;

    function GetColumnClass: TVirtualTreeColumnClass; virtual;

    function GetDefaultHintKind: TVTHintKind; virtual;

    function GetHeaderClass: TVTHeaderClass; virtual;

    function GetHintWindowClass: THintWindowClass; virtual;

    procedure GetImageIndex(var Info: TVTPaintInfo; Kind: TVTImageKind; InfoIndex: TVTImageInfoIndex;

      DefaultImages: TCustomImageList); virtual;

    function GetNodeImageSize(Node: PVirtualNode): TSize; virtual;

    function GetMaxRightExtend: Cardinal; virtual;

    procedure GetNativeClipboardFormats(var Formats: TFormatEtcArray); virtual;

    function GetOperationCanceled: Boolean;

    function GetOptionsClass: TTreeOptionsClass; virtual;

    function GetTreeFromDataObject(const DataObject: IDataObject): TBaseVirtualTree; virtual;

    procedure HandleHotTrack(X, Y: Integer); virtual;

    procedure HandleIncrementalSearch(CharCode: Word); virtual;

    procedure HandleMouseDblClick(var Message: TWMMouse; const HitInfo: THitInfo); virtual;

    procedure HandleMouseDown(var Message: TWMMouse; var HitInfo: THitInfo); virtual;

    procedure HandleMouseUp(var Message: TWMMouse; const HitInfo: THitInfo); virtual;

    function HasImage(Node: PVirtualNode; Kind: TVTImageKind; Column: TColumnIndex): Boolean; virtual;

    function HasPopupMenu(Node: PVirtualNode; Column: TColumnIndex; Pos: TPoint): Boolean; virtual;

    procedure InitChildren(Node: PVirtualNode); virtual;

    procedure InitNode(Node: PVirtualNode); virtual;

    procedure InternalAddFromStream(Stream: TStream; Version: Integer; Node: PVirtualNode); virtual;

    function InternalAddToSelection(Node: PVirtualNode; ForceInsert: Boolean): Boolean; overload;

    function InternalAddToSelection(const NewItems: TNodeArray; NewLength: Integer;

      ForceInsert: Boolean): Boolean; overload;

    procedure InternalCacheNode(Node: PVirtualNode); virtual;

    procedure InternalClearSelection; virtual;

    procedure InternalConnectNode(Node, Destination: PVirtualNode; Target: TBaseVirtualTree; Mode: TVTNodeAttachMode); virtual;

    function InternalData(Node: PVirtualNode): Pointer;

    procedure InternalDisconnectNode(Node: PVirtualNode; KeepFocus: Boolean; Reindex: Boolean = True); virtual;

    procedure InternalRemoveFromSelection(Node: PVirtualNode); virtual;

    procedure InvalidateCache;

    procedure Loaded; override;

    procedure MainColumnChanged; virtual;

    procedure MarkCutCopyNodes; virtual;

    procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;

    procedure Notification(AComponent: TComponent; Operation: TOperation); override;

    procedure OriginalWMNCPaint(DC: HDC); virtual;

    procedure Paint; override;

    procedure PaintCheckImage(Canvas: TCanvas; const ImageInfo: TVTImageInfo; Selected: Boolean); virtual;

    procedure PaintImage(var PaintInfo: TVTPaintInfo; ImageInfoIndex: TVTImageInfoIndex; DoOverlay: Boolean); virtual;

    procedure PaintNodeButton(Canvas: TCanvas; Node: PVirtualNode; Column: TColumnIndex; const R: TRect; ButtonX,

      ButtonY: Integer; BidiMode: TBiDiMode); virtual;

    procedure PaintTreeLines(const PaintInfo: TVTPaintInfo; VAlignment, IndentSize: Integer;

      LineImage: TLineImage); virtual;

    procedure PaintSelectionRectangle(Target: TCanvas; WindowOrgX: Integer; const SelectionRect: TRect;

      TargetRect: TRect); virtual;

    procedure PanningWindowProc(var Message: TMessage); virtual;

    procedure PrepareCell(var PaintInfo: TVTPaintInfo; WindowOrgX, MaxWidth: Integer); virtual;

    function ReadChunk(Stream: TStream; Version: Integer; Node: PVirtualNode; ChunkType,

      ChunkSize: Integer): Boolean; virtual;

    procedure ReadNode(Stream: TStream; Version: Integer; Node: PVirtualNode); virtual;

    procedure RedirectFontChangeEvent(Canvas: TCanvas); virtual;

    procedure RemoveFromSelection(Node: PVirtualNode); virtual;

    procedure UpdateNextNodeToSelect(Node: PVirtualNode); virtual;

    function RenderOLEData(const FormatEtcIn: TFormatEtc; out Medium: TStgMedium; ForClipboard: Boolean): HResult; virtual;

    procedure ResetRangeAnchor; virtual;

    procedure RestoreFontChangeEvent(Canvas: TCanvas); virtual;

    procedure SelectNodes(StartNode, EndNode: PVirtualNode; AddOnly: Boolean); virtual;

    procedure SetFocusedNodeAndColumn(Node: PVirtualNode; Column: TColumnIndex); virtual;

    procedure SkipNode(Stream: TStream); virtual;

    procedure StartOperation(OperationKind: TVTOperationKind);

    procedure StartWheelPanning(Position: TPoint); virtual;

    procedure StopWheelPanning; virtual;

    procedure StructureChange(Node: PVirtualNode; Reason: TChangeReason); virtual;

    function SuggestDropEffect(Source: TObject; Shift: TShiftState; Pt: TPoint; AllowedEffects: Integer): Integer; virtual;

    procedure ToggleSelection(StartNode, EndNode: PVirtualNode); virtual;

    procedure UnselectNodes(StartNode, EndNode: PVirtualNode); virtual;

    procedure UpdateColumnCheckState(Col: TVirtualTreeColumn);

    procedure UpdateDesigner; virtual;

    procedure UpdateEditBounds; virtual;

    procedure UpdateHeaderRect; virtual;

    procedure UpdateWindowAndDragImage(const Tree: TBaseVirtualTree; TreeRect: TRect; UpdateNCArea,

      ReshowDragImage: Boolean); virtual;

    procedure ValidateCache; virtual;

    procedure ValidateNodeDataSize(var Size: Integer); virtual;

    procedure WndProc(var Message: TMessage); override;

    procedure WriteChunks(Stream: TStream; Node: PVirtualNode); virtual;

    procedure WriteNode(Stream: TStream; Node: PVirtualNode); virtual;



    procedure VclStyleChanged;

    property VclStyleEnabled: Boolean read FVclStyleEnabled;



    property Alignment: TAlignment read FAlignment write SetAlignment default taLeftJustify;

    property AnimationDuration: Cardinal read FAnimationDuration write SetAnimationDuration default 200;

    property AutoExpandDelay: Cardinal read FAutoExpandDelay write FAutoExpandDelay default 1000;

    property AutoScrollDelay: Cardinal read FAutoScrollDelay write FAutoScrollDelay default 1000;

    property AutoScrollInterval: TAutoScrollInterval read FAutoScrollInterval write FAutoScrollInterval default 1;

    property Background: TPicture read FBackground write SetBackground;

    property BackgroundOffsetX: Integer index 0 read FBackgroundOffsetX write SetBackgroundOffset default 0;

    property BackgroundOffsetY: Integer index 1 read FBackgroundOffsetY write SetBackgroundOffset default 0;

    property BorderStyle: TBorderStyle read FBorderStyle write SetBorderStyle default bsSingle;

    property BottomSpace: Cardinal read FBottomSpace write SetBottomSpace default 0;

    property ButtonFillMode: TVTButtonFillMode read FButtonFillMode write SetButtonFillMode default fmTreeColor;

    property ButtonStyle: TVTButtonStyle read FButtonStyle write SetButtonStyle default bsRectangle;

    property ChangeDelay: Cardinal read FChangeDelay write FChangeDelay default 0;

    property CheckImageKind: TCheckImageKind read FCheckImageKind write SetCheckImageKind default ckSystemDefault;

    property ClipboardFormats: TClipboardFormats read FClipboardFormats write SetClipboardFormats;

    property Colors: TVTColors read FColors write SetColors;

    property CustomCheckImages: TCustomImageList read FCustomCheckImages write SetCustomCheckImages;

    property DefaultHintKind: TVTHintKind read GetDefaultHintKind;

    property DefaultNodeHeight: Cardinal read FDefaultNodeHeight write SetDefaultNodeHeight default 18;

    property DefaultPasteMode: TVTNodeAttachMode read FDefaultPasteMode write FDefaultPasteMode default amAddChildLast;

    property DragHeight: Integer read FDragHeight write FDragHeight default 350;

    property DragImageKind: TVTDragImageKind read FDragImageKind write FDragImageKind default diComplete;

    property DragOperations: TDragOperations read FDragOperations write FDragOperations default [doCopy, doMove];

    property DragSelection: TNodeArray read FDragSelection;

    property LastDragEffect: LongInt read FLastDragEffect;

    property DragType: TVTDragType read FDragType write FDragType default dtOLE;

    property DragWidth: Integer read FDragWidth write FDragWidth default 200;

    property DrawSelectionMode: TVTDrawSelectionMode read FDrawSelectionMode write FDrawSelectionMode

      default smDottedRectangle;

    property EditColumn: TColumnIndex read FEditColumn write FEditColumn;

    property EditDelay: Cardinal read FEditDelay write FEditDelay default 1000;

    property EffectiveOffsetX: Integer read FEffectiveOffsetX;

    property Header: TVTHeader read FHeader write SetHeader;

    property HeaderRect: TRect read FHeaderRect;

    property HintAnimation: THintAnimationType read FAnimationType write FAnimationType default hatSystemDefault;

    property HintMode: TVTHintMode read FHintMode write FHintMode default hmDefault;

    property HintData: TVTHintData read FHintData write FHintData;

    property HotCursor: TCursor read FHotCursor write FHotCursor default crDefault;

    property Images: TCustomImageList read FImages write SetImages;

    property IncrementalSearch: TVTIncrementalSearch read FIncrementalSearch write SetSearchOption default isNone;

    property IncrementalSearchDirection: TVTSearchDirection read FSearchDirection write FSearchDirection default sdForward;

    property IncrementalSearchStart: TVTSearchStart read FSearchStart write FSearchStart default ssFocusedNode;

    property IncrementalSearchTimeout: Cardinal read FSearchTimeout write FSearchTimeout default 1000;

    property Indent: Cardinal read FIndent write SetIndent default 18;

    property LastClickPos: TPoint read FLastClickPos write FLastClickPos;

    property LastDropMode: TDropMode read FLastDropMode write FLastDropMode;

    property LastHintRect: TRect read FLastHintRect write FLastHintRect;

    property LineMode: TVTLineMode read FLineMode write SetLineMode default lmNormal;

    property LineStyle: TVTLineStyle read FLineStyle write SetLineStyle default lsDotted;

    property Margin: Integer read FMargin write SetMargin default 4;

    property NextNodeToSelect: PVirtualNode read FNextNodeToSelect; // Next tree node that we would like to select if the current one gets deleted

    property NodeAlignment: TVTNodeAlignment read FNodeAlignment write SetNodeAlignment default naProportional;

    property NodeDataSize: Integer read FNodeDataSize write SetNodeDataSize default -1;

    property OperationCanceled: Boolean read GetOperationCanceled;

    property HotMinusBM: TBitmap read FHotMinusBM;

    property HotPlusBM: TBitmap read FHotPlusBM;

    property MinusBM: TBitmap read FMinusBM;

    property PlusBM: TBitmap read FPlusBM;

    property RangeX: Cardinal read GetRangeX;// Returns the width of the virtual tree in pixels, (not ClientWidth). If there are columns it returns the total width of all of them; otherwise it returns the maximum of the all the line's data widths.

    property RangeY: Cardinal read FRangeY;

    property RootNodeCount: Cardinal read GetRootNodeCount write SetRootNodeCount default 0;

    property ScrollBarOptions: TScrollBarOptions read FScrollBarOptions write SetScrollBarOptions;

    property SelectionBlendFactor: Byte read FSelectionBlendFactor write FSelectionBlendFactor default 128;

    property SelectionCurveRadius: Cardinal read FSelectionCurveRadius write SetSelectionCurveRadius default 0;

    property StateImages: TCustomImageList read FStateImages write SetStateImages;

    property TextMargin: Integer read FTextMargin write SetTextMargin default 4;

    property TotalInternalDataSize: Cardinal read FTotalInternalDataSize;

    property TreeOptions: TCustomVirtualTreeOptions read FOptions write SetOptions;

    property WantTabs: Boolean read FWantTabs write FWantTabs default False;



    property OnAddToSelection: TVTAddToSelectionEvent read FOnAddToSelection write FOnAddToSelection;

    property OnAdvancedHeaderDraw: TVTAdvancedHeaderPaintEvent read FOnAdvancedHeaderDraw write FOnAdvancedHeaderDraw;

    property OnAfterAutoFitColumn: TVTAfterAutoFitColumnEvent read FOnAfterAutoFitColumn write FOnAfterAutoFitColumn;

    property OnAfterAutoFitColumns: TVTAfterAutoFitColumnsEvent read FOnAfterAutoFitColumns write FOnAfterAutoFitColumns;

    property OnAfterCellPaint: TVTAfterCellPaintEvent read FOnAfterCellPaint write FOnAfterCellPaint;

    property OnAfterColumnExport : TVTColumnExportEvent read FOnAfterColumnExport write FOnAfterColumnExport;

    property OnAfterColumnWidthTracking: TVTAfterColumnWidthTrackingEvent read FOnAfterColumnWidthTracking write FOnAfterColumnWidthTracking;

    property OnAfterGetMaxColumnWidth: TVTAfterGetMaxColumnWidthEvent read FOnAfterGetMaxColumnWidth write FOnAfterGetMaxColumnWidth;

    property OnAfterHeaderExport: TVTTreeExportEvent read FOnAfterHeaderExport write FOnAfterHeaderExport;

    property OnAfterHeaderHeightTracking: TVTAfterHeaderHeightTrackingEvent read FOnAfterHeaderHeightTracking

      write FOnAfterHeaderHeightTracking;

    property OnAfterItemErase: TVTAfterItemEraseEvent read FOnAfterItemErase write FOnAfterItemErase;

    property OnAfterItemPaint: TVTAfterItemPaintEvent read FOnAfterItemPaint write FOnAfterItemPaint;

    property OnAfterNodeExport: TVTNodeExportEvent read FOnAfterNodeExport write FOnAfterNodeExport;

    property OnAfterPaint: TVTPaintEvent read FOnAfterPaint write FOnAfterPaint;

    property OnAfterTreeExport: TVTTreeExportEvent read FOnAfterTreeExport write FOnAfterTreeExport;

    property OnBeforeAutoFitColumn: TVTBeforeAutoFitColumnEvent read FOnBeforeAutoFitColumn write FOnBeforeAutoFitColumn;

    property OnBeforeAutoFitColumns: TVTBeforeAutoFitColumnsEvent read FOnBeforeAutoFitColumns write FOnBeforeAutoFitColumns;

    property OnBeforeCellPaint: TVTBeforeCellPaintEvent read FOnBeforeCellPaint write FOnBeforeCellPaint;

    property OnBeforeColumnExport: TVTColumnExportEvent read FOnBeforeColumnExport write FOnBeforeColumnExport;

    property OnBeforeColumnWidthTracking: TVTBeforeColumnWidthTrackingEvent read FOnBeforeColumnWidthTracking

      write FOnBeforeColumnWidthTracking;

    property OnBeforeDrawTreeLine: TVTBeforeDrawLineImageEvent read FOnBeforeDrawLineImage write FOnBeforeDrawLineImage;

    property OnBeforeGetMaxColumnWidth: TVTBeforeGetMaxColumnWidthEvent read FOnBeforeGetMaxColumnWidth write FOnBeforeGetMaxColumnWidth;

    property OnBeforeHeaderExport: TVTTreeExportEvent read FOnBeforeHeaderExport write FOnBeforeHeaderExport;

    property OnBeforeHeaderHeightTracking: TVTBeforeHeaderHeightTrackingEvent read FOnBeforeHeaderHeightTracking

      write FOnBeforeHeaderHeightTracking;

    property OnBeforeItemErase: TVTBeforeItemEraseEvent read FOnBeforeItemErase write FOnBeforeItemErase;

    property OnBeforeItemPaint: TVTBeforeItemPaintEvent read FOnBeforeItemPaint write FOnBeforeItemPaint;

    property OnBeforeNodeExport: TVTNodeExportEvent read FOnBeforeNodeExport write FOnBeforeNodeExport;

    property OnBeforePaint: TVTPaintEvent read FOnBeforePaint write FOnBeforePaint;

    property OnBeforeTreeExport: TVTTreeExportEvent read FOnBeforeTreeExport write FOnBeforeTreeExport;

    property OnCanSplitterResizeColumn: TVTCanSplitterResizeColumnEvent read FOnCanSplitterResizeColumn write FOnCanSplitterResizeColumn;

    property OnCanSplitterResizeHeader: TVTCanSplitterResizeHeaderEvent read FOnCanSplitterResizeHeader write FOnCanSplitterResizeHeader;

    property OnCanSplitterResizeNode: TVTCanSplitterResizeNodeEvent read FOnCanSplitterResizeNode write FOnCanSplitterResizeNode;

    property OnChange: TVTChangeEvent read FOnChange write FOnChange;

    property OnChecked: TVTChangeEvent read FOnChecked write FOnChecked;

    property OnChecking: TVTCheckChangingEvent read FOnChecking write FOnChecking;

    property OnCollapsed: TVTChangeEvent read FOnCollapsed write FOnCollapsed;

    property OnCollapsing: TVTChangingEvent read FOnCollapsing write FOnCollapsing;

    property OnColumnClick: TVTColumnClickEvent read FOnColumnClick write FOnColumnClick;

    property OnColumnDblClick: TVTColumnDblClickEvent read FOnColumnDblClick write FOnColumnDblClick;

    property OnColumnExport : TVTColumnExportEvent read FOnColumnExport write FOnColumnExport;

    property OnColumnResize: TVTHeaderNotifyEvent read FOnColumnResize write FOnColumnResize;

    property OnColumnWidthDblClickResize: TVTColumnWidthDblClickResizeEvent read FOnColumnWidthDblClickResize

      write FOnColumnWidthDblClickResize;

    property OnColumnWidthTracking: TVTColumnWidthTrackingEvent read FOnColumnWidthTracking write FOnColumnWidthTracking;

    property OnCompareNodes: TVTCompareEvent read FOnCompareNodes write FOnCompareNodes;

    property OnCreateDataObject: TVTCreateDataObjectEvent read FOnCreateDataObject write FOnCreateDataObject;

    property OnCreateDragManager: TVTCreateDragManagerEvent read FOnCreateDragManager write FOnCreateDragManager;

    property OnCreateEditor: TVTCreateEditorEvent read FOnCreateEditor write FOnCreateEditor;

    property OnDragAllowed: TVTDragAllowedEvent read FOnDragAllowed write FOnDragAllowed;

    property OnDragOver: TVTDragOverEvent read FOnDragOver write FOnDragOver;

    property OnDragDrop: TVTDragDropEvent read FOnDragDrop write FOnDragDrop;

    property OnDrawHint: TVTDrawHintEvent read FOnDrawHint write FOnDrawHint;

    property OnEditCancelled: TVTEditCancelEvent read FOnEditCancelled write FOnEditCancelled;

    property OnEditing: TVTEditChangingEvent read FOnEditing write FOnEditing;

    property OnEdited: TVTEditChangeEvent read FOnEdited write FOnEdited;

    property OnEndOperation: TVTOperationEvent read FOnEndOperation write FOnEndOperation;

    property OnExpanded: TVTChangeEvent read FOnExpanded write FOnExpanded;

    property OnExpanding: TVTChangingEvent read FOnExpanding write FOnExpanding;

    property OnFocusChanged: TVTFocusChangeEvent read FOnFocusChanged write FOnFocusChanged;

    property OnFocusChanging: TVTFocusChangingEvent read FOnFocusChanging write FOnFocusChanging;

    property OnFreeNode: TVTFreeNodeEvent read FOnFreeNode write FOnFreeNode;

    property OnGetCellIsEmpty: TVTGetCellIsEmptyEvent read FOnGetCellIsEmpty write FOnGetCellIsEmpty;

    property OnGetCursor: TVTGetCursorEvent read FOnGetCursor write FOnGetCursor;

    property OnGetHeaderCursor: TVTGetHeaderCursorEvent read FOnGetHeaderCursor write FOnGetHeaderCursor;

    property OnGetHelpContext: TVTHelpContextEvent read FOnGetHelpContext write FOnGetHelpContext;

    property OnGetHintSize: TVTGetHintSizeEvent read FOnGetHintSize write

        FOnGetHintSize;

    property OnGetHintKind: TVTHintKindEvent read FOnGetHintKind write

        FOnGetHintKind;

    property OnGetImageIndex: TVTGetImageEvent read FOnGetImage write FOnGetImage;

    property OnGetImageIndexEx: TVTGetImageExEvent read FOnGetImageEx write FOnGetImageEx;

    property OnGetImageText: TVTGetImageTextEvent read FOnGetImageText write FOnGetImageText;

    property OnGetLineStyle: TVTGetLineStyleEvent read FOnGetLineStyle write FOnGetLineStyle;

    property OnGetNodeDataSize: TVTGetNodeDataSizeEvent read FOnGetNodeDataSize write FOnGetNodeDataSize;

    property OnGetPopupMenu: TVTPopupEvent read FOnGetPopupMenu write FOnGetPopupMenu;

    property OnGetUserClipboardFormats: TVTGetUserClipboardFormatsEvent read FOnGetUserClipboardFormats

      write FOnGetUserClipboardFormats;

    property OnHeaderClick: TVTHeaderClickEvent read FOnHeaderClick write FOnHeaderClick;

    property OnHeaderDblClick: TVTHeaderClickEvent read FOnHeaderDblClick write FOnHeaderDblClick;

    property OnHeaderDragged: TVTHeaderDraggedEvent read FOnHeaderDragged write FOnHeaderDragged;

    property OnHeaderDraggedOut: TVTHeaderDraggedOutEvent read FOnHeaderDraggedOut write FOnHeaderDraggedOut;

    property OnHeaderDragging: TVTHeaderDraggingEvent read FOnHeaderDragging write FOnHeaderDragging;

    property OnHeaderDraw: TVTHeaderPaintEvent read FOnHeaderDraw write FOnHeaderDraw;

    property OnHeaderDrawQueryElements: TVTHeaderPaintQueryElementsEvent read FOnHeaderDrawQueryElements

      write FOnHeaderDrawQueryElements;

    property OnHeaderHeightTracking: TVTHeaderHeightTrackingEvent read FOnHeaderHeightTracking

      write FOnHeaderHeightTracking;

    property OnHeaderHeightDblClickResize: TVTHeaderHeightDblClickResizeEvent read FOnHeaderHeightDblClickResize

      write FOnHeaderHeightDblClickResize;

    property OnHeaderMouseDown: TVTHeaderMouseEvent read FOnHeaderMouseDown write FOnHeaderMouseDown;

    property OnHeaderMouseMove: TVTHeaderMouseMoveEvent read FOnHeaderMouseMove write FOnHeaderMouseMove;

    property OnHeaderMouseUp: TVTHeaderMouseEvent read FOnHeaderMouseUp write FOnHeaderMouseUp;

    property OnHotChange: TVTHotNodeChangeEvent read FOnHotChange write FOnHotChange;

    property OnIncrementalSearch: TVTIncrementalSearchEvent read FOnIncrementalSearch write FOnIncrementalSearch;

    property OnInitChildren: TVTInitChildrenEvent read FOnInitChildren write FOnInitChildren;

    property OnInitNode: TVTInitNodeEvent read FOnInitNode write FOnInitNode;

    property OnKeyAction: TVTKeyActionEvent read FOnKeyAction write FOnKeyAction;

    property OnLoadNode: TVTSaveNodeEvent read FOnLoadNode write FOnLoadNode;

    property OnLoadTree: TVTSaveTreeEvent read FOnLoadTree write FOnLoadTree;

    property OnMeasureItem: TVTMeasureItemEvent read FOnMeasureItem write FOnMeasureItem;

    property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter;

    property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave;

    property OnNodeClick: TVTNodeClickEvent read FOnNodeClick write FOnNodeClick;

    property OnNodeCopied: TVTNodeCopiedEvent read FOnNodeCopied write FOnNodeCopied;

    property OnNodeCopying: TVTNodeCopyingEvent read FOnNodeCopying write FOnNodeCopying;

    property OnNodeDblClick: TVTNodeClickEvent read FOnNodeDblClick write FOnNodeDblClick;

    property OnNodeExport: TVTNodeExportEvent read FOnNodeExport write FOnNodeExport;

    property OnNodeHeightTracking: TVTNodeHeightTrackingEvent read FOnNodeHeightTracking write FOnNodeHeightTracking;

    property OnNodeHeightDblClickResize: TVTNodeHeightDblClickResizeEvent read FOnNodeHeightDblClickResize

      write FOnNodeHeightDblClickResize;

    property OnNodeMoved: TVTNodeMovedEvent read FOnNodeMoved write FOnNodeMoved;

    property OnNodeMoving: TVTNodeMovingEvent read FOnNodeMoving write FOnNodeMoving;

    property OnPaintBackground: TVTBackgroundPaintEvent read FOnPaintBackground write FOnPaintBackground;

    property OnRemoveFromSelection: TVTRemoveFromSelectionEvent read FOnRemoveFromSelection write FOnRemoveFromSelection;

    property OnRenderOLEData: TVTRenderOLEDataEvent read FOnRenderOLEData write FOnRenderOLEData;

    property OnResetNode: TVTChangeEvent read FOnResetNode write FOnResetNode;

    property OnSaveNode: TVTSaveNodeEvent read FOnSaveNode write FOnSaveNode;

    property OnSaveTree: TVTSaveTreeEvent read FOnSaveTree write FOnSaveTree;

    property OnScroll: TVTScrollEvent read FOnScroll write FOnScroll;

    property OnShowScrollBar: TVTScrollBarShowEvent read FOnShowScrollBar write FOnShowScrollBar;

    property OnStartOperation: TVTOperationEvent read FOnStartOperation write FOnStartOperation;

    property OnStateChange: TVTStateChangeEvent read FOnStateChange write FOnStateChange;

    property OnStructureChange: TVTStructureChangeEvent read FOnStructureChange write FOnStructureChange;

    property OnUpdating: TVTUpdatingEvent read FOnUpdating write FOnUpdating;

  public

    constructor Create(AOwner: TComponent); override;

    destructor Destroy; override;



    function AbsoluteIndex(Node: PVirtualNode): Cardinal;

    function AddChild(Parent: PVirtualNode; UserData: Pointer = nil): PVirtualNode; virtual;

    procedure AddFromStream(Stream: TStream; TargetNode: PVirtualNode);

    procedure AfterConstruction; override;

    procedure Assign(Source: TPersistent); override;

    procedure BeginDrag(Immediate: Boolean; Threshold: Integer = -1);

    procedure BeginSynch;

    procedure BeginUpdate; virtual;

    procedure CancelCutOrCopy;

    function CancelEditNode: Boolean;

    procedure CancelOperation;

    function CanEdit(Node: PVirtualNode; Column: TColumnIndex): Boolean; virtual;

    function CanFocus: Boolean; override;

    procedure Clear; virtual;

    procedure ClearChecked;

    procedure ClearSelection;

    function CopyTo(Source: PVirtualNode; Tree: TBaseVirtualTree; Mode: TVTNodeAttachMode;

      ChildrenOnly: Boolean): PVirtualNode; overload;

    function CopyTo(Source, Target: PVirtualNode; Mode: TVTNodeAttachMode;

      ChildrenOnly: Boolean): PVirtualNode; overload;

    procedure CopyToClipboard; virtual;

    procedure CutToClipboard; virtual;

    procedure DeleteChildren(Node: PVirtualNode; ResetHasChildren: Boolean = False);

    procedure DeleteNode(Node: PVirtualNode; Reindex: Boolean = True);

    procedure DeleteSelectedNodes; virtual;

    function Dragging: Boolean;

    function EditNode(Node: PVirtualNode; Column: TColumnIndex): Boolean; virtual;

    function EndEditNode: Boolean;

    procedure EndSynch;

    procedure EndUpdate; virtual;

    procedure EnsureNodeSelected(); virtual;

    function ExecuteAction(Action: TBasicAction): Boolean; override;

    procedure FinishCutOrCopy;

    procedure FlushClipboard;

    procedure FullCollapse(Node: PVirtualNode = nil);  virtual;

    procedure FullExpand(Node: PVirtualNode = nil); virtual;

    function GetControlsAlignment: TAlignment; override;

    function GetDisplayRect(Node: PVirtualNode; Column: TColumnIndex; TextOnly: Boolean; Unclipped: Boolean = False;

      ApplyCellContentMargin: Boolean = False): TRect;

    function GetEffectivelyFiltered(Node: PVirtualNode): Boolean;

    function GetEffectivelyVisible(Node: PVirtualNode): Boolean;

    function GetFirst(ConsiderChildrenAbove: Boolean = False): PVirtualNode;

    function GetFirstChecked(State: TCheckState = csCheckedNormal; ConsiderChildrenAbove: Boolean = False): PVirtualNode;

    function GetFirstChild(Node: PVirtualNode): PVirtualNode;

    function GetFirstChildNoInit(Node: PVirtualNode): PVirtualNode;

    function GetFirstCutCopy(ConsiderChildrenAbove: Boolean = False): PVirtualNode;

    function GetFirstInitialized(ConsiderChildrenAbove: Boolean = False): PVirtualNode;

    function GetFirstLeaf: PVirtualNode;

    function GetFirstLevel(NodeLevel: Cardinal): PVirtualNode;

    function GetFirstNoInit(ConsiderChildrenAbove: Boolean = False): PVirtualNode;

    function GetFirstSelected(ConsiderChildrenAbove: Boolean = False): PVirtualNode;

    function GetFirstVisible(Node: PVirtualNode = nil; ConsiderChildrenAbove: Boolean = True;

      IncludeFiltered: Boolean = False): PVirtualNode;

    function GetFirstVisibleChild(Node: PVirtualNode; IncludeFiltered: Boolean = False): PVirtualNode;

    function GetFirstVisibleChildNoInit(Node: PVirtualNode; IncludeFiltered: Boolean = False): PVirtualNode;

    function GetFirstVisibleNoInit(Node: PVirtualNode = nil; ConsiderChildrenAbove: Boolean = True;

      IncludeFiltered: Boolean = False): PVirtualNode;

    procedure GetHitTestInfoAt(X, Y: Integer; Relative: Boolean; var HitInfo: THitInfo); virtual;

    function GetLast(Node: PVirtualNode = nil; ConsiderChildrenAbove: Boolean = False): PVirtualNode;

    function GetLastInitialized(Node: PVirtualNode = nil; ConsiderChildrenAbove: Boolean = False): PVirtualNode;

    function GetLastNoInit(Node: PVirtualNode = nil; ConsiderChildrenAbove: Boolean = False): PVirtualNode;

    function GetLastChild(Node: PVirtualNode): PVirtualNode;

    function GetLastChildNoInit(Node: PVirtualNode): PVirtualNode;

    function GetLastVisible(Node: PVirtualNode = nil; ConsiderChildrenAbove: Boolean = True;

      IncludeFiltered: Boolean = False): PVirtualNode;

    function GetLastVisibleChild(Node: PVirtualNode; IncludeFiltered: Boolean = False): PVirtualNode;

    function GetLastVisibleChildNoInit(Node: PVirtualNode; IncludeFiltered: Boolean = False): PVirtualNode;

    function GetLastVisibleNoInit(Node: PVirtualNode = nil; ConsiderChildrenAbove: Boolean = True;

      IncludeFiltered: Boolean = False): PVirtualNode;

    function GetMaxColumnWidth(Column: TColumnIndex; UseSmartColumnWidth: Boolean = False): Integer; virtual;

    function GetNext(Node: PVirtualNode; ConsiderChildrenAbove: Boolean = False): PVirtualNode;

    function GetNextChecked(Node: PVirtualNode; State: TCheckState = csCheckedNormal;

      ConsiderChildrenAbove: Boolean = False): PVirtualNode; overload;

    function GetNextChecked(Node: PVirtualNode; ConsiderChildrenAbove: Boolean): PVirtualNode; overload;

    function GetNextCutCopy(Node: PVirtualNode; ConsiderChildrenAbove: Boolean = False): PVirtualNode;

    function GetNextInitialized(Node: PVirtualNode; ConsiderChildrenAbove: Boolean = False): PVirtualNode;

    function GetNextLeaf(Node: PVirtualNode): PVirtualNode;

    function GetNextLevel(Node: PVirtualNode; NodeLevel: Cardinal): PVirtualNode;

    function GetNextNoInit(Node: PVirtualNode; ConsiderChildrenAbove: Boolean = False): PVirtualNode;

    function GetNextSelected(Node: PVirtualNode; ConsiderChildrenAbove: Boolean = False): PVirtualNode;

    function GetNextSibling(Node: PVirtualNode): PVirtualNode;

    function GetNextSiblingNoInit(Node: PVirtualNode): PVirtualNode;

    function GetNextVisible(Node: PVirtualNode; ConsiderChildrenAbove: Boolean = True): PVirtualNode;

    function GetNextVisibleNoInit(Node: PVirtualNode; ConsiderChildrenAbove: Boolean = True): PVirtualNode;

    function GetNextVisibleSibling(Node: PVirtualNode; IncludeFiltered: Boolean = False): PVirtualNode;

    function GetNextVisibleSiblingNoInit(Node: PVirtualNode; IncludeFiltered: Boolean = False): PVirtualNode;

    function GetNodeAt(const P: TPoint): PVirtualNode; overload; {$if CompilerVersion >= 18}inline;{$ifend}

    function GetNodeAt(X, Y: Integer): PVirtualNode; overload;

    function GetNodeAt(X, Y: Integer; Relative: Boolean; var NodeTop: Integer): PVirtualNode; overload;

    function GetNodeData(Node: PVirtualNode): Pointer;

    function GetNodeLevel(Node: PVirtualNode): Cardinal;

    function GetPrevious(Node: PVirtualNode; ConsiderChildrenAbove: Boolean = False): PVirtualNode;

    function GetPreviousChecked(Node: PVirtualNode; State: TCheckState = csCheckedNormal;

      ConsiderChildrenAbove: Boolean = False): PVirtualNode;

    function GetPreviousCutCopy(Node: PVirtualNode; ConsiderChildrenAbove: Boolean = False): PVirtualNode;

    function GetPreviousInitialized(Node: PVirtualNode; ConsiderChildrenAbove: Boolean = False): PVirtualNode;

    function GetPreviousLeaf(Node: PVirtualNode): PVirtualNode;

    function GetPreviousLevel(Node: PVirtualNode; NodeLevel: Cardinal): PVirtualNode;

    function GetPreviousNoInit(Node: PVirtualNode; ConsiderChildrenAbove: Boolean = False): PVirtualNode;

    function GetPreviousSelected(Node: PVirtualNode; ConsiderChildrenAbove: Boolean = False): PVirtualNode;

    function GetPreviousSibling(Node: PVirtualNode): PVirtualNode;

    function GetPreviousSiblingNoInit(Node: PVirtualNode): PVirtualNode;

    function GetPreviousVisible(Node: PVirtualNode; ConsiderChildrenAbove: Boolean = True): PVirtualNode;

    function GetPreviousVisibleNoInit(Node: PVirtualNode; ConsiderChildrenAbove: Boolean = True): PVirtualNode;

    function GetPreviousVisibleSibling(Node: PVirtualNode; IncludeFiltered: Boolean = False): PVirtualNode;

    function GetPreviousVisibleSiblingNoInit(Node: PVirtualNode; IncludeFiltered: Boolean = False): PVirtualNode;

    function GetSortedCutCopySet(Resolve: Boolean): TNodeArray;

    function GetSortedSelection(Resolve: Boolean): TNodeArray;

    procedure GetTextInfo(Node: PVirtualNode; Column: TColumnIndex; const AFont: TFont; var R: TRect;

      var Text: UnicodeString); virtual;

    function GetTreeRect: TRect;

    function GetVisibleParent(Node: PVirtualNode; IncludeFiltered: Boolean = False): PVirtualNode;

    function HasAsParent(Node, PotentialParent: PVirtualNode): Boolean;

    function InsertNode(Node: PVirtualNode; Mode: TVTNodeAttachMode; UserData: Pointer = nil): PVirtualNode;

    procedure InvalidateChildren(Node: PVirtualNode; Recursive: Boolean);

    procedure InvalidateColumn(Column: TColumnIndex);

    function InvalidateNode(Node: PVirtualNode): TRect; virtual;

    procedure InvalidateToBottom(Node: PVirtualNode);

    procedure InvertSelection(VisibleOnly: Boolean);

    function IsEditing: Boolean;

    function IsMouseSelecting: Boolean;

    function IsEmpty: Boolean;

    function IterateSubtree(Node: PVirtualNode; Callback: TVTGetNodeProc; Data: Pointer; Filter: TVirtualNodeStates = [];

      DoInit: Boolean = False; ChildNodesOnly: Boolean = False): PVirtualNode;

    procedure LoadFromFile(const FileName: TFileName); virtual;

    procedure LoadFromStream(Stream: TStream); virtual;

    procedure MeasureItemHeight(const Canvas: TCanvas; Node: PVirtualNode); virtual;

    procedure MoveTo(Source, Target: PVirtualNode; Mode: TVTNodeAttachMode; ChildrenOnly: Boolean); overload;

    procedure MoveTo(Node: PVirtualNode; Tree: TBaseVirtualTree; Mode: TVTNodeAttachMode;

      ChildrenOnly: Boolean); overload;

    procedure PaintTree(TargetCanvas: TCanvas; Window: TRect; Target: TPoint; PaintOptions: TVTInternalPaintOptions;

      PixelFormat: TPixelFormat = pfDevice); virtual;

    function PasteFromClipboard: Boolean; virtual;

    procedure PrepareDragImage(HotSpot: TPoint; const DataObject: IDataObject);

    procedure Print(Printer: TPrinter; PrintHeader: Boolean);

    function ProcessDrop(DataObject: IDataObject; TargetNode: PVirtualNode; var Effect: Integer; Mode:

      TVTNodeAttachMode): Boolean;

    function ProcessOLEData(Source: TBaseVirtualTree; DataObject: IDataObject; TargetNode: PVirtualNode;

      Mode: TVTNodeAttachMode; Optimized: Boolean): Boolean;

    procedure RepaintNode(Node: PVirtualNode);

    procedure ReinitChildren(Node: PVirtualNode; Recursive: Boolean); virtual;

    procedure ReinitNode(Node: PVirtualNode; Recursive: Boolean); virtual;

    procedure ResetNode(Node: PVirtualNode); virtual;

    procedure SaveToFile(const FileName: TFileName);

    procedure SaveToStream(Stream: TStream; Node: PVirtualNode = nil); virtual;

    function ScrollIntoView(Node: PVirtualNode; Center: Boolean; Horizontally: Boolean = False): Boolean; overload;

    function ScrollIntoView(Column: TColumnIndex; Center: Boolean; Node: PVirtualNode = nil): Boolean; overload;

    procedure SelectAll(VisibleOnly: Boolean);

    procedure Sort(Node: PVirtualNode; Column: TColumnIndex; Direction: TSortDirection; DoInit: Boolean = True); virtual;

    procedure SortTree(Column: TColumnIndex; Direction: TSortDirection; DoInit: Boolean = True); virtual;

    procedure ToggleNode(Node: PVirtualNode);

    function UpdateAction(Action: TBasicAction): Boolean; override;

    procedure UpdateHorizontalRange;

    procedure UpdateHorizontalScrollBar(DoRepaint: Boolean);

    procedure UpdateRanges;

    procedure UpdateScrollBars(DoRepaint: Boolean); virtual;

    procedure UpdateVerticalRange;

    procedure UpdateVerticalScrollBar(DoRepaint: Boolean);

    function UseRightToLeftReading: Boolean;

    procedure ValidateChildren(Node: PVirtualNode; Recursive: Boolean);

    procedure ValidateNode(Node: PVirtualNode; Recursive: Boolean);



    { Enumerations }

    function Nodes(ConsiderChildrenAbove: Boolean = False): TVTVirtualNodeEnumeration;

    function CheckedNodes(State: TCheckState = csCheckedNormal; ConsiderChildrenAbove: Boolean = False): TVTVirtualNodeEnumeration;

    function ChildNodes(Node: PVirtualNode): TVTVirtualNodeEnumeration;

    function CutCopyNodes(ConsiderChildrenAbove: Boolean = False): TVTVirtualNodeEnumeration;

    function InitializedNodes(ConsiderChildrenAbove: Boolean = False): TVTVirtualNodeEnumeration;

    function LeafNodes: TVTVirtualNodeEnumeration;

    function LevelNodes(NodeLevel: Cardinal): TVTVirtualNodeEnumeration;

    function NoInitNodes(ConsiderChildrenAbove: Boolean = False): TVTVirtualNodeEnumeration;

    function SelectedNodes(ConsiderChildrenAbove: Boolean = False): TVTVirtualNodeEnumeration;

    function VisibleNodes(Node: PVirtualNode = nil; ConsiderChildrenAbove: Boolean = True;

      IncludeFiltered: Boolean = False): TVTVirtualNodeEnumeration;

    function VisibleChildNodes(Node: PVirtualNode; IncludeFiltered: Boolean = False): TVTVirtualNodeEnumeration;

    function VisibleChildNoInitNodes(Node: PVirtualNode; IncludeFiltered: Boolean = False): TVTVirtualNodeEnumeration;

    function VisibleNoInitNodes(Node: PVirtualNode = nil; ConsiderChildrenAbove: Boolean = True;

      IncludeFiltered: Boolean = False): TVTVirtualNodeEnumeration;



    property Accessible: IAccessible read FAccessible write FAccessible;

    property AccessibleItem: IAccessible read FAccessibleItem write FAccessibleItem;

    property AccessibleName: string read FAccessibleName write FAccessibleName;

    property BottomNode: PVirtualNode read GetBottomNode write SetBottomNode;

    property CheckedCount: Integer read GetCheckedCount;

    property CheckImages: TCustomImageList read FCheckImages;

    property CheckState[Node: PVirtualNode]: TCheckState read GetCheckState write SetCheckState;

    property CheckType[Node: PVirtualNode]: TCheckType read GetCheckType write SetCheckType;

    property ChildCount[Node: PVirtualNode]: Cardinal read GetChildCount write SetChildCount;

    property ChildrenInitialized[Node: PVirtualNode]: Boolean read GetChildrenInitialized;

    property CutCopyCount: Integer read GetCutCopyCount;

    property DragImage: TVTDragImage read FDragImage;

    property DragManager: IVTDragManager read GetDragManager;

    property DropTargetNode: PVirtualNode read FDropTargetNode write FDropTargetNode;

    property EditLink: IVTEditLink read FEditLink;

    property EmptyListMessage: UnicodeString read FEmptyListMessage write SetEmptyListMessage;

    property Expanded[Node: PVirtualNode]: Boolean read GetExpanded write SetExpanded;

    property FocusedColumn: TColumnIndex read FFocusedColumn write SetFocusedColumn default InvalidColumn;

    property FocusedNode: PVirtualNode read FFocusedNode write SetFocusedNode;

    property Font;

    property FullyVisible[Node: PVirtualNode]: Boolean read GetFullyVisible write SetFullyVisible;

    property HasChildren[Node: PVirtualNode]: Boolean read GetHasChildren write SetHasChildren;

    property HotNode: PVirtualNode read FCurrentHotNode;

    property IsDisabled[Node: PVirtualNode]: Boolean read GetDisabled write SetDisabled;

    property IsEffectivelyFiltered[Node: PVirtualNode]: Boolean read GetEffectivelyFiltered;

    property IsEffectivelyVisible[Node: PVirtualNode]: Boolean read GetEffectivelyVisible;

    property IsFiltered[Node: PVirtualNode]: Boolean read GetFiltered write SetFiltered;

    property IsVisible[Node: PVirtualNode]: Boolean read GetVisible write SetVisible;

    property MultiLine[Node: PVirtualNode]: Boolean read GetMultiline write SetMultiline;

    property NodeHeight[Node: PVirtualNode]: Cardinal read GetNodeHeight write SetNodeHeight;

    property NodeParent[Node: PVirtualNode]: PVirtualNode read GetNodeParent write SetNodeParent;

    property OffsetX: Integer read FOffsetX write SetOffsetX;

    property OffsetXY: TPoint read GetOffsetXY write SetOffsetXY;

    property OffsetY: Integer read FOffsetY write SetOffsetY;

    property OperationCount: Cardinal read FOperationCount;

    property RootNode: PVirtualNode read FRoot;

    property SearchBuffer: UnicodeString read FSearchBuffer;

    property Selected[Node: PVirtualNode]: Boolean read GetSelected write SetSelected;

    property SelectionLocked: Boolean read FSelectionLocked write FSelectionLocked;

    property TotalCount: Cardinal read GetTotalCount;

    property TreeStates: TVirtualTreeStates read FStates write FStates;

    property SelectedCount: Integer read FSelectionCount;

    property TopNode: PVirtualNode read GetTopNode write SetTopNode;

    property VerticalAlignment[Node: PVirtualNode]: Byte read GetVerticalAlignment write SetVerticalAlignment;

    property VisibleCount: Cardinal read FVisibleCount;

    property VisiblePath[Node: PVirtualNode]: Boolean read GetVisiblePath write SetVisiblePath;

    property UpdateCount: Cardinal read FUpdateCount;

    property DoubleBuffered: Boolean read GetDoubleBuffered write SetDoubleBuffered default True;

  end;





  // --------- TCustomVirtualStringTree



  // Options regarding strings (useful only for the string tree and descendants):

  TVTStringOption = (

    toSaveCaptions,          // If set then the caption is automatically saved with the tree node, regardless of what is

                             // saved in the user data.

    toShowStaticText,        // Show static text in a caption which can be differently formatted than the caption

                             // but cannot be edited.

    toAutoAcceptEditChange   // Automatically accept changes during edit if the user finishes editing other then

                             // VK_RETURN or ESC. If not set then changes are cancelled.

  );

  TVTStringOptions = set of TVTStringOption;



const

  DefaultStringOptions = [toSaveCaptions, toAutoAcceptEditChange];



type

  TCustomStringTreeOptions = class(TCustomVirtualTreeOptions)

  private

    FStringOptions: TVTStringOptions;

    procedure SetStringOptions(const Value: TVTStringOptions);

  protected

    property StringOptions: TVTStringOptions read FStringOptions write SetStringOptions default DefaultStringOptions;

  public

    constructor Create(AOwner: TBaseVirtualTree); override;



    procedure AssignTo(Dest: TPersistent); override;

  end;



  TStringTreeOptions = class(TCustomStringTreeOptions)

  published

    property AnimationOptions;

    property AutoOptions;

    property ExportMode;

    property MiscOptions;

    property PaintOptions;

    property SelectionOptions;

    property StringOptions;

  end;



  TCustomVirtualStringTree = class;



  // Edit support classes.

  TStringEditLink = class;



  {$ifdef TntSupport}

    TVTEdit = class(TTntEdit)

  {$else}

    TVTEdit = class(TCustomEdit)

  {$endif TntSupport}

  private

    procedure CMAutoAdjust(var Message: TMessage); message CM_AUTOADJUST;

    procedure CMExit(var Message: TMessage); message CM_EXIT;

    procedure CMRelease(var Message: TMessage); message CM_RELEASE;

    procedure CNCommand(var Message: TWMCommand); message CN_COMMAND;

    procedure WMChar(var Message: TWMChar); message WM_CHAR;

    procedure WMDestroy(var Message: TWMDestroy); message WM_DESTROY;

    procedure WMGetDlgCode(var Message: TWMGetDlgCode); message WM_GETDLGCODE;

    procedure WMKeyDown(var Message: TWMKeyDown); message WM_KEYDOWN;

  protected

    FRefLink: IVTEditLink;

    FLink: TStringEditLink;

    procedure AutoAdjustSize; virtual;

    procedure CreateParams(var Params: TCreateParams); override;

  public

    constructor Create(Link: TStringEditLink); reintroduce;



    procedure Release; virtual;



    property AutoSelect;

    property AutoSize;

    property BorderStyle;

    property CharCase;

    property HideSelection;

    property MaxLength;

    property OEMConvert;

    property PasswordChar;

  end;



  TStringEditLink = class(TInterfacedObject, IVTEditLink)

  private

    FEdit: TVTEdit;                  // A normal custom edit control.

  protected

    FTree: TCustomVirtualStringTree; // A back reference to the tree calling.

    FNode: PVirtualNode;             // The node to be edited.

    FColumn: TColumnIndex;           // The column of the node.

    FAlignment: TAlignment;

    FTextBounds: TRect;              // Smallest rectangle around the text.

    FStopping: Boolean;              // Set to True when the edit link requests stopping the edit action.

    procedure SetEdit(const Value: TVTEdit); // Setter for the FEdit member;

  public

    constructor Create; virtual;

    destructor Destroy; override;

    property Node  : PVirtualNode read FNode; // [IPK] Make FNode accessible

    property Column: TColumnIndex read FColumn; // [IPK] Make Column(Index) accessible 



    function BeginEdit: Boolean; virtual; stdcall;

    function CancelEdit: Boolean; virtual; stdcall;

    property Edit: TVTEdit read FEdit write SetEdit;

    function EndEdit: Boolean; virtual; stdcall;

    function GetBounds: TRect; virtual; stdcall;

    function PrepareEdit(Tree: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex): Boolean; virtual; stdcall;

    procedure ProcessMessage(var Message: TMessage); virtual; stdcall;

    procedure SetBounds(R: TRect); virtual; stdcall;

  end;



  // Describes the type of text to return in the text and draw info retrival events.

  TVSTTextType = (

    ttNormal,      // normal label of the node, this is also the text which can be edited

    ttStatic       // static (non-editable) text after the normal text

  );



  // Describes the source to use when converting a string tree into a string for clipboard etc.

  TVSTTextSourceType = (

    tstAll,             // All nodes are rendered. Initialization is done on the fly.

    tstInitialized,     // Only initialized nodes are rendered.

    tstSelected,        // Only selected nodes are rendered.

    tstCutCopySet,      // Only nodes currently marked as being in the cut/copy clipboard set are rendered.

    tstVisible,         // Only visible nodes are rendered.

    tstChecked          // Only checked nodes are rendered

  );



  TVTPaintText = procedure(Sender: TBaseVirtualTree; const TargetCanvas: TCanvas; Node: PVirtualNode; Column: TColumnIndex;

    TextType: TVSTTextType) of object;

  TVSTGetTextEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex;

    TextType: TVSTTextType; var CellText: UnicodeString) of object;

  TVSTGetHintEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex;

    var LineBreakStyle: TVTTooltipLineBreakStyle; var HintText: UnicodeString) of object;

  // New text can only be set for variable caption.

  TVSTNewTextEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex;

    NewText: UnicodeString) of object;

  TVSTShortenStringEvent = procedure(Sender: TBaseVirtualTree; TargetCanvas: TCanvas; Node: PVirtualNode;

    Column: TColumnIndex; const S: UnicodeString; TextSpace: Integer; var Result: UnicodeString;

    var Done: Boolean) of object;

  TVTMeasureTextEvent = procedure(Sender: TBaseVirtualTree; TargetCanvas: TCanvas; Node: PVirtualNode;

    Column: TColumnIndex; const Text: UnicodeString; var Extent: Integer) of object;

  TVTDrawTextEvent = procedure(Sender: TBaseVirtualTree; TargetCanvas: TCanvas; Node: PVirtualNode;

    Column: TColumnIndex; const Text: UnicodeString; const CellRect: TRect; var DefaultDraw: Boolean) of object;



  TCustomVirtualStringTree = class(TBaseVirtualTree)

  private

    FDefaultText: UnicodeString;                   // text to show if there's no OnGetText event handler (e.g. at design time)

    FTextHeight: Integer;                          // true size of the font

    FEllipsisWidth: Integer;                       // width of '...' for the current font

    FInternalDataOffset: Cardinal;                 // offset to the internal data of the string tree



    FOnPaintText: TVTPaintText;                    // triggered before either normal or fixed text is painted to allow

                                                   // even finer customization (kind of sub cell painting)

    FOnGetText: TVSTGetTextEvent;                  // used to retrieve the string to be displayed for a specific node

    FOnGetHint: TVSTGetHintEvent;                  // used to retrieve the hint to be displayed for a specific node

    FOnNewText: TVSTNewTextEvent;                  // used to notify the application about an edited node caption

    FOnShortenString: TVSTShortenStringEvent;      // used to allow the application a customized string shortage

    FOnMeasureTextWidth: TVTMeasureTextEvent;      // used to adjust the width of the cells

    FOnMeasureTextHeight: TVTMeasureTextEvent;

    FOnDrawText: TVTDrawTextEvent;                 // used to custom draw the node text



    function GetImageText(Node: PVirtualNode; Kind: TVTImageKind;

      Column: TColumnIndex): UnicodeString;

    procedure GetRenderStartValues(Source: TVSTTextSourceType; var Node: PVirtualNode;

      var NextNodeProc: TGetNextNodeProc);

    function GetOptions: TCustomStringTreeOptions;

    function GetStaticText(Node: PVirtualNode; Column: TColumnIndex): UnicodeString;

    function GetText(Node: PVirtualNode; Column: TColumnIndex): UnicodeString;

    procedure ReadText(Reader: TReader);

    procedure SetDefaultText(const Value: UnicodeString);

    procedure SetOptions(const Value: TCustomStringTreeOptions);

    procedure SetText(Node: PVirtualNode; Column: TColumnIndex; const Value: UnicodeString);

    procedure WriteText(Writer: TWriter);



    procedure WMSetFont(var Msg: TWMSetFont); message WM_SETFONT;

    procedure GetDataFromGrid(const AStrings : TStringList; const IncludeHeading : Boolean = True);

  protected

    FPreviouslySelected: TStringList;

    procedure InitializeTextProperties(var PaintInfo: TVTPaintInfo); // [IPK] - private to protected

    procedure PaintNormalText(var PaintInfo: TVTPaintInfo; TextOutFlags: Integer; Text: UnicodeString); virtual; // [IPK] - private to protected

    procedure PaintStaticText(const PaintInfo: TVTPaintInfo; TextOutFlags: Integer; const Text: UnicodeString); virtual; // [IPK] - private to protected

    procedure AdjustPaintCellRect(var PaintInfo: TVTPaintInfo; var NextNonEmpty: TColumnIndex); override;

    function CanExportNode(Node: PVirtualNode): Boolean;

    function CalculateStaticTextWidth(Canvas: TCanvas; Node: PVirtualNode; Column: TColumnIndex; Text: UnicodeString): Integer; virtual;

    function CalculateTextWidth(Canvas: TCanvas; Node: PVirtualNode; Column: TColumnIndex; Text: UnicodeString): Integer; virtual;

    function ColumnIsEmpty(Node: PVirtualNode; Column: TColumnIndex): Boolean; override;

    procedure DefineProperties(Filer: TFiler); override;

    function DoCreateEditor(Node: PVirtualNode; Column: TColumnIndex): IVTEditLink; override;

    function DoGetNodeHint(Node: PVirtualNode; Column: TColumnIndex; var LineBreakStyle: TVTTooltipLineBreakStyle): UnicodeString; override;

    function DoGetNodeTooltip(Node: PVirtualNode; Column: TColumnIndex; var LineBreakStyle: TVTTooltipLineBreakStyle): UnicodeString; override;

    function DoGetNodeExtraWidth(Node: PVirtualNode; Column: TColumnIndex; Canvas: TCanvas = nil): Integer; override;

    function DoGetNodeWidth(Node: PVirtualNode; Column: TColumnIndex; Canvas: TCanvas = nil): Integer; override;

    procedure DoGetText(Node: PVirtualNode; Column: TColumnIndex; TextType: TVSTTextType;

      var Text: UnicodeString); virtual;

    function DoIncrementalSearch(Node: PVirtualNode; const Text: UnicodeString): Integer; override;

    procedure DoNewText(Node: PVirtualNode; Column: TColumnIndex; Text: UnicodeString); virtual;

    procedure DoPaintNode(var PaintInfo: TVTPaintInfo); override;

    procedure DoPaintText(Node: PVirtualNode; const Canvas: TCanvas; Column: TColumnIndex;

      TextType: TVSTTextType); virtual;

    function DoShortenString(Canvas: TCanvas; Node: PVirtualNode; Column: TColumnIndex; const S: UnicodeString; Width: Integer;

      EllipsisWidth: Integer = 0): UnicodeString; virtual;

    procedure DoTextDrawing(var PaintInfo: TVTPaintInfo; Text: UnicodeString; CellRect: TRect; DrawFormat: Cardinal); virtual;

    function DoTextMeasuring(Canvas: TCanvas; Node: PVirtualNode; Column: TColumnIndex; Text: UnicodeString): TSize; virtual;

    function GetOptionsClass: TTreeOptionsClass; override;

    function InternalData(Node: PVirtualNode): Pointer;

    procedure MainColumnChanged; override;

    function ReadChunk(Stream: TStream; Version: Integer; Node: PVirtualNode; ChunkType,

      ChunkSize: Integer): Boolean; override;

    procedure ReadOldStringOptions(Reader: TReader);

    function RenderOLEData(const FormatEtcIn: TFormatEtc; out Medium: TStgMedium; ForClipboard: Boolean): HResult; override;

    procedure WriteChunks(Stream: TStream; Node: PVirtualNode); override;



    property DefaultText: UnicodeString read FDefaultText write SetDefaultText stored False;

    property EllipsisWidth: Integer read FEllipsisWidth;

    property TreeOptions: TCustomStringTreeOptions read GetOptions write SetOptions;



    property OnGetHint: TVSTGetHintEvent read FOnGetHint write FOnGetHint;

    property OnGetText: TVSTGetTextEvent read FOnGetText write FOnGetText;

    property OnNewText: TVSTNewTextEvent read FOnNewText write FOnNewText;

    property OnPaintText: TVTPaintText read FOnPaintText write FOnPaintText;

    property OnShortenString: TVSTShortenStringEvent read FOnShortenString write FOnShortenString;

    property OnMeasureTextWidth: TVTMeasureTextEvent read FOnMeasureTextWidth write FOnMeasureTextWidth;

    property OnMeasureTextHeight: TVTMeasureTextEvent read FOnMeasureTextHeight write FOnMeasureTextHeight;

    property OnDrawText: TVTDrawTextEvent read FOnDrawText write FOnDrawText;

  public

    constructor Create(AOwner: TComponent); override;

    destructor Destroy(); override;

    function AddChild(Parent: PVirtualNode; UserData: Pointer = nil): PVirtualNode; override;

    function ComputeNodeHeight(Canvas: TCanvas; Node: PVirtualNode; Column: TColumnIndex; S: UnicodeString = ''): Integer; virtual;

    function ContentToClipboard(Format: Word; Source: TVSTTextSourceType): HGLOBAL;

    procedure ContentToCustom(Source: TVSTTextSourceType);

    function ContentToHTML(Source: TVSTTextSourceType; Caption: UnicodeString = ''): RawByteString;

    function ContentToRTF(Source: TVSTTextSourceType): RawByteString;

    function ContentToText(Source: TVSTTextSourceType; Separator: Char): AnsiString; overload;

    function ContentToText(Source: TVSTTextSourceType; const Separator: AnsiString): AnsiString; overload;

    function ContentToUnicode(Source: TVSTTextSourceType; Separator: WideChar): UnicodeString; overload;

    function ContentToUnicode(Source: TVSTTextSourceType; const Separator: UnicodeString): UnicodeString; overload;

    procedure GetTextInfo(Node: PVirtualNode; Column: TColumnIndex; const AFont: TFont; var R: TRect;

      var Text: UnicodeString); override;

    function InvalidateNode(Node: PVirtualNode): TRect; override;

    function Path(Node: PVirtualNode; Column: TColumnIndex; TextType: TVSTTextType; Delimiter: WideChar): UnicodeString;

    procedure ReinitNode(Node: PVirtualNode; Recursive: Boolean); override;

    procedure AddToSelection(Node: PVirtualNode); override;

    procedure RemoveFromSelection(Node: PVirtualNode); override;

    function SaveToCSVFile(const FileNameWithPath : TFileName; const IncludeHeading : Boolean) : Boolean;

    property ImageText[Node: PVirtualNode; Kind: TVTImageKind; Column: TColumnIndex]: UnicodeString read GetImageText;

    property StaticText[Node: PVirtualNode; Column: TColumnIndex]: UnicodeString read GetStaticText;

    property Text[Node: PVirtualNode; Column: TColumnIndex]: UnicodeString read GetText write SetText;

  end;



  TVirtualStringTree = class(TCustomVirtualStringTree)

  private

    function GetOptions: TStringTreeOptions;

    procedure SetOptions(const Value: TStringTreeOptions);

  protected

    function GetOptionsClass: TTreeOptionsClass; override;

    {$if CompilerVersion >= 23}

    class constructor Create();

    {$ifend}

  public

    property Canvas;

    property RangeX;

    property LastDragEffect;

  published

    property AccessibleName;

    property Action;

    property Align;

    property Alignment;

    property Anchors;

    property AnimationDuration;

    property AutoExpandDelay;

    property AutoScrollDelay;

    property AutoScrollInterval;

    property Background;

    property BackgroundOffsetX;

    property BackgroundOffsetY;

    property BiDiMode;

    property BevelEdges;

    property BevelInner;

    property BevelOuter;

    property BevelKind;

    property BevelWidth;

    property BorderStyle;

    property BottomSpace;

    property ButtonFillMode;

    property ButtonStyle;

    property BorderWidth;

    property ChangeDelay;

    property CheckImageKind;

    property ClipboardFormats;

    property Color;

    property Colors;

    property Constraints;

    property Ctl3D;

    property CustomCheckImages;

    property DefaultNodeHeight;

    property DefaultPasteMode;

    property DefaultText;

    property DragCursor;

    property DragHeight;

    property DragKind;

    property DragImageKind;

    property DragMode;

    property DragOperations;

    property DragType;

    property DragWidth;

    property DrawSelectionMode;

    property EditDelay;

    property EmptyListMessage;

    property Enabled;

    property Font;

    property Header;

    property HintAnimation;

    property HintMode;

    property HotCursor;

    property Images;

    property IncrementalSearch;

    property IncrementalSearchDirection;

    property IncrementalSearchStart;

    property IncrementalSearchTimeout;

    property Indent;

    property LineMode;

    property LineStyle;

    property Margin;

    property NodeAlignment;

    property NodeDataSize;

    property OperationCanceled;

    property ParentBiDiMode;

    property ParentColor default False;

    property ParentCtl3D;

    property ParentFont;

    property ParentShowHint;

    property PopupMenu;

    property RootNodeCount;

    property ScrollBarOptions;

    property SelectionBlendFactor;

    property SelectionCurveRadius;

    property ShowHint;

    property StateImages;

    {$if CompilerVersion >= 24}

    property StyleElements;

    {$ifend}

    property TabOrder;

    property TabStop default True;

    property TextMargin;

    property TreeOptions: TStringTreeOptions read GetOptions write SetOptions;

    property Visible;

    property WantTabs;



    property OnAddToSelection;

    property OnAdvancedHeaderDraw;

    property OnAfterAutoFitColumn;

    property OnAfterAutoFitColumns;

    property OnAfterCellPaint;

    property OnAfterColumnExport;

    property OnAfterColumnWidthTracking;

    property OnAfterGetMaxColumnWidth;

    property OnAfterHeaderExport;

    property OnAfterHeaderHeightTracking;

    property OnAfterItemErase;

    property OnAfterItemPaint;

    property OnAfterNodeExport;

    property OnAfterPaint;

    property OnAfterTreeExport;

    property OnBeforeAutoFitColumn;

    property OnBeforeAutoFitColumns;

    property OnBeforeCellPaint;

    property OnBeforeColumnExport;

    property OnBeforeColumnWidthTracking;

    property OnBeforeDrawTreeLine;

    property OnBeforeGetMaxColumnWidth;

    property OnBeforeHeaderExport;

    property OnBeforeHeaderHeightTracking;

    property OnBeforeItemErase;

    property OnBeforeItemPaint;

    property OnBeforeNodeExport;

    property OnBeforePaint;

    property OnBeforeTreeExport;

    property OnCanSplitterResizeColumn;

    property OnCanSplitterResizeHeader;

    property OnCanSplitterResizeNode;

    property OnChange;

    property OnChecked;

    property OnChecking;

    property OnClick;

    property OnCollapsed;

    property OnCollapsing;

    property OnColumnClick;

    property OnColumnDblClick;

    property OnColumnExport;

    property OnColumnResize;

    property OnColumnWidthDblClickResize;

    property OnColumnWidthTracking;

    property OnCompareNodes;

    property OnContextPopup;

    property OnCreateDataObject;

    property OnCreateDragManager;

    property OnCreateEditor;

    property OnDblClick;

    property OnDragAllowed;

    property OnDragOver;

    property OnDragDrop;

    property OnDrawHint;

    property OnDrawText;

    property OnEditCancelled;

    property OnEdited;

    property OnEditing;

    property OnEndDock;

    property OnEndDrag;

    property OnEndOperation;

    property OnEnter;

    property OnExit;

    property OnExpanded;

    property OnExpanding;

    property OnFocusChanged;

    property OnFocusChanging;

    property OnFreeNode;

    property OnGetCellIsEmpty;

    property OnGetCursor;

    property OnGetHeaderCursor;

    property OnGetText;

    property OnPaintText;

    property OnGetHelpContext;

    property OnGetHintKind;

    property OnGetHintSize;

    property OnGetImageIndex;

    property OnGetImageIndexEx;

    property OnGetImageText;

    property OnGetHint;

    property OnGetLineStyle;

    property OnGetNodeDataSize;

    property OnGetPopupMenu;

    property OnGetUserClipboardFormats;

    property OnHeaderClick;

    property OnHeaderDblClick;

    property OnHeaderDragged;

    property OnHeaderDraggedOut;

    property OnHeaderDragging;

    property OnHeaderDraw;

    property OnHeaderDrawQueryElements;

    property OnHeaderHeightDblClickResize;

    property OnHeaderHeightTracking;

    property OnHeaderMouseDown;

    property OnHeaderMouseMove;

    property OnHeaderMouseUp;

    property OnHotChange;

    property OnIncrementalSearch;

    property OnInitChildren;

    property OnInitNode;

    property OnKeyAction;

    property OnKeyDown;

    property OnKeyPress;

    property OnKeyUp;

    property OnLoadNode;

    property OnLoadTree;

    property OnMeasureItem;

    property OnMeasureTextWidth;

    property OnMeasureTextHeight;

    property OnMouseDown;

    property OnMouseMove;

    property OnMouseUp;

    property OnMouseWheel;

    property OnMouseEnter;

    property OnMouseLeave;

    property OnNewText;

    property OnNodeClick;

    property OnNodeCopied;

    property OnNodeCopying;

    property OnNodeDblClick;

    property OnNodeExport;

    property OnNodeHeightDblClickResize;

    property OnNodeHeightTracking;

    property OnNodeMoved;

    property OnNodeMoving;

    property OnPaintBackground;

    property OnRemoveFromSelection;

    property OnRenderOLEData;

    property OnResetNode;

    property OnResize;

    property OnSaveNode;

    property OnSaveTree;

    property OnScroll;

    property OnShortenString;

    property OnShowScrollBar;

    property OnStartDock;

    property OnStartDrag;

    property OnStartOperation;

    property OnStateChange;

    property OnStructureChange;

    property OnUpdating;

    {$if CompilerVersion >= 22}

    property OnCanResize;

    property OnGesture;

    property Touch;

    {$ifend}

  end;



  TVTDrawNodeEvent = procedure(Sender: TBaseVirtualTree; const PaintInfo: TVTPaintInfo) of object;

  TVTGetCellContentMarginEvent = procedure(Sender: TBaseVirtualTree; HintCanvas: TCanvas; Node: PVirtualNode;

    Column: TColumnIndex; CellContentMarginType: TVTCellContentMarginType; var CellContentMargin: TPoint) of object;

  TVTGetNodeWidthEvent = procedure(Sender: TBaseVirtualTree; HintCanvas: TCanvas; Node: PVirtualNode;

    Column: TColumnIndex; var NodeWidth: Integer) of object;



  // Tree descendant to let an application draw its stuff itself.

  TCustomVirtualDrawTree = class(TBaseVirtualTree)

  private

    FOnDrawNode: TVTDrawNodeEvent;

    FOnGetCellContentMargin: TVTGetCellContentMarginEvent;

    FOnGetNodeWidth: TVTGetNodeWidthEvent;

  protected

    function DoGetCellContentMargin(Node: PVirtualNode; Column: TColumnIndex;

      CellContentMarginType: TVTCellContentMarginType = ccmtAllSides; Canvas: TCanvas = nil): TPoint; override;

    function DoGetNodeWidth(Node: PVirtualNode; Column: TColumnIndex; Canvas: TCanvas = nil): Integer; override;

    procedure DoPaintNode(var PaintInfo: TVTPaintInfo); override;

    function GetDefaultHintKind: TVTHintKind; override;



    property OnDrawNode: TVTDrawNodeEvent read FOnDrawNode write FOnDrawNode;

    property OnGetCellContentMargin: TVTGetCellContentMarginEvent read FOnGetCellContentMargin write FOnGetCellContentMargin;

    property OnGetNodeWidth: TVTGetNodeWidthEvent read FOnGetNodeWidth write FOnGetNodeWidth;

  end;



  TVirtualDrawTree = class(TCustomVirtualDrawTree)

  private

    function GetOptions: TVirtualTreeOptions;

    procedure SetOptions(const Value: TVirtualTreeOptions);

  protected

    function GetOptionsClass: TTreeOptionsClass; override;

    {$if CompilerVersion >= 23}

    class constructor Create();

    {$ifend}

  public

    property Canvas;

    property LastDragEffect;

  published

    property Action;

    property Align;

    property Alignment;

    property Anchors;

    property AnimationDuration;

    property AutoExpandDelay;

    property AutoScrollDelay;

    property AutoScrollInterval;

    property Background;

    property BackgroundOffsetX;

    property BackgroundOffsetY;

    property BiDiMode;

    property BevelEdges;

    property BevelInner;

    property BevelOuter;

    property BevelKind;

    property BevelWidth;

    property BorderStyle;

    property BottomSpace;

    property ButtonFillMode;

    property ButtonStyle;

    property BorderWidth;

    property ChangeDelay;

    property CheckImageKind;

    property ClipboardFormats;

    property Color;

    property Colors;

    property Constraints;

    property Ctl3D;

    property CustomCheckImages;

    property DefaultNodeHeight;

    property DefaultPasteMode;

    property DragCursor;

    property DragHeight;

    property DragKind;

    property DragImageKind;

    property DragMode;

    property DragOperations;

    property DragType;

    property DragWidth;

    property DrawSelectionMode;

    property EditDelay;

    property Enabled;

    property Font;

    property Header;

    property HintAnimation;

    property HintMode;

    property HotCursor;

    property Images;

    property IncrementalSearch;

    property IncrementalSearchDirection;

    property IncrementalSearchStart;

    property IncrementalSearchTimeout;

    property Indent;

    property LineMode;

    property LineStyle;

    property Margin;

    property NodeAlignment;

    property NodeDataSize;

    property OperationCanceled;

    property ParentBiDiMode;

    property ParentColor default False;

    property ParentCtl3D;

    property ParentFont;

    property ParentShowHint;

    property PopupMenu;

    property RootNodeCount;

    property ScrollBarOptions;

    property SelectionBlendFactor;

    property SelectionCurveRadius;

    property ShowHint;

    property StateImages;

    property TabOrder;

    property TabStop default True;

    property TextMargin;

    property TreeOptions: TVirtualTreeOptions read GetOptions write SetOptions;

    property Visible;

    property WantTabs;



    property OnAddToSelection;

    property OnAdvancedHeaderDraw;

    property OnAfterAutoFitColumn;

    property OnAfterAutoFitColumns;

    property OnAfterCellPaint;

    property OnAfterColumnExport;

    property OnAfterColumnWidthTracking;

    property OnAfterGetMaxColumnWidth;

    property OnAfterHeaderExport;

    property OnAfterHeaderHeightTracking;

    property OnAfterItemErase;

    property OnAfterItemPaint;

    property OnAfterNodeExport;

    property OnAfterPaint;

    property OnAfterTreeExport;

    property OnBeforeAutoFitColumn;

    property OnBeforeAutoFitColumns;

    property OnBeforeCellPaint;

    property OnBeforeColumnExport;

    property OnBeforeColumnWidthTracking;

    property OnBeforeDrawTreeLine;

    property OnBeforeGetMaxColumnWidth;

    property OnBeforeHeaderExport;

    property OnBeforeHeaderHeightTracking;

    property OnBeforeItemErase;

    property OnBeforeItemPaint;

    property OnBeforeNodeExport;

    property OnBeforePaint;

    property OnBeforeTreeExport;

    property OnCanSplitterResizeColumn;

    property OnCanSplitterResizeHeader;

    property OnCanSplitterResizeNode;

    property OnChange;

    property OnChecked;

    property OnChecking;

    property OnClick;

    property OnCollapsed;

    property OnCollapsing;

    property OnColumnClick;

    property OnColumnDblClick;

    property OnColumnExport;

    property OnColumnResize;

    property OnColumnWidthDblClickResize;

    property OnColumnWidthTracking;

    property OnCompareNodes;

    property OnContextPopup;

    property OnCreateDataObject;

    property OnCreateDragManager;

    property OnCreateEditor;

    property OnDblClick;

    property OnDragAllowed;

    property OnDragOver;

    property OnDragDrop;

    property OnDrawHint;

    property OnDrawNode;

    property OnEdited;

    property OnEditing;

    property OnEndDock;

    property OnEndDrag;

    property OnEndOperation;

    property OnEnter;

    property OnExit;

    property OnExpanded;

    property OnExpanding;

    property OnFocusChanged;

    property OnFocusChanging;

    property OnFreeNode;

    property OnGetCellIsEmpty;

    property OnGetCursor;

    property OnGetHeaderCursor;

    property OnGetHelpContext;

    property OnGetHintKind;

    property OnGetHintSize;

    property OnGetImageIndex;

    property OnGetImageIndexEx;

    property OnGetLineStyle;

    property OnGetNodeDataSize;

    property OnGetNodeWidth;

    property OnGetPopupMenu;

    property OnGetUserClipboardFormats;

    property OnHeaderClick;

    property OnHeaderDblClick;

    property OnHeaderDragged;

    property OnHeaderDraggedOut;

    property OnHeaderDragging;

    property OnHeaderDraw;

    property OnHeaderDrawQueryElements;

    property OnHeaderHeightTracking;

    property OnHeaderHeightDblClickResize;

    property OnHeaderMouseDown;

    property OnHeaderMouseMove;

    property OnHeaderMouseUp;

    property OnHotChange;

    property OnIncrementalSearch;

    property OnInitChildren;

    property OnInitNode;

    property OnKeyAction;

    property OnKeyDown;

    property OnKeyPress;

    property OnKeyUp;

    property OnLoadNode;

    property OnLoadTree;

    property OnMeasureItem;

    property OnMouseDown;

    property OnMouseMove;

    property OnMouseUp;

    property OnMouseWheel;

    property OnNodeClick;

    property OnNodeCopied;

    property OnNodeCopying;

    property OnNodeDblClick;

    property OnNodeExport;

    property OnNodeHeightTracking;

    property OnNodeHeightDblClickResize;

    property OnNodeMoved;

    property OnNodeMoving;

    property OnPaintBackground;

    property OnRemoveFromSelection;

    property OnRenderOLEData;

    property OnResetNode;

    property OnResize;

    property OnSaveNode;

    property OnSaveTree;

    property OnScroll;

    property OnShowScrollBar;

    property OnStartDock;

    property OnStartDrag;

    property OnStartOperation;

    property OnStateChange;

    property OnStructureChange;

    property OnUpdating;

    {$if CompilerVersion >= 22}

    property OnCanResize;

    property OnGesture;

    property Touch;

    {$ifend}

    {$if CompilerVersion >= 24}

    property StyleElements;

    {$ifend}

  end;



type

  // Describes the mode how to blend pixels.

  TBlendMode = (

    bmConstantAlpha,         // apply given constant alpha

    bmPerPixelAlpha,         // use alpha value of the source pixel

    bmMasterAlpha,           // use alpha value of source pixel and multiply it with the constant alpha value

    bmConstantAlphaAndColor  // blend the destination color with the given constant color und the constant alpha value

  );



// OLE Clipboard and drag'n drop helper

procedure EnumerateVTClipboardFormats(TreeClass: TVirtualTreeClass; const List: TStrings); overload;

procedure EnumerateVTClipboardFormats(TreeClass: TVirtualTreeClass; var Formats: TFormatEtcArray); overload;

function GetVTClipboardFormatDescription(AFormat: Word): string;

procedure RegisterVTClipboardFormat(AFormat: Word; TreeClass: TVirtualTreeClass; Priority: Cardinal); overload;

function RegisterVTClipboardFormat(Description: string; TreeClass: TVirtualTreeClass; Priority: Cardinal;

  tymed: Integer = TYMED_HGLOBAL; ptd: PDVTargetDevice = nil; dwAspect: Integer = DVASPECT_CONTENT;

  lindex: Integer = -1): Word; overload;



// utility routines

procedure AlphaBlend(Source, Destination: HDC; R: TRect; Target: TPoint; Mode: TBlendMode; ConstantAlpha, Bias: Integer);

procedure PrtStretchDrawDIB(Canvas: TCanvas; DestRect: TRect; ABitmap: TBitmap);

function ShortenString(DC: HDC; const S: UnicodeString; Width: Integer; EllipsisWidth: Integer = 0): UnicodeString;

function TreeFromNode(Node: PVirtualNode): TBaseVirtualTree;

procedure GetStringDrawRect(DC: HDC; const S: UnicodeString; var Bounds: TRect; DrawFormat: Cardinal);

function WrapString(DC: HDC; const S: UnicodeString; const Bounds: TRect; RTL: Boolean;

  DrawFormat: Cardinal): UnicodeString;



function GetUtilityImages: TCustomImageList;

procedure ShowError(Msg: UnicodeString; HelpContext: Integer);  // [IPK] Surface this to interface



//----------------------------------------------------------------------------------------------------------------------



implementation



{$R VirtualTrees.res}



uses

  Consts, Math,

  AxCtrls,                 // TOLEStream

  MMSystem,                // for animation timer (does not include further resources)

  TypInfo,                 // for migration stuff

  ActnList,

  StdActns,                // for standard action support

  {$ifdef UNICODE}

  AnsiStrings,

  {$endif UNICODE}

  StrUtils,

  VTAccessibilityFactory, GraphUtil;  // accessibility helper class



resourcestring

  // Localizable strings.

  SEditLinkIsNil = 'Edit link must not be nil.';

  SWrongMoveError = 'Target node cannot be a child node of the node to be moved.';

  SWrongStreamFormat = 'Unable to load tree structure, the format is wrong.';

  SWrongStreamVersion = 'Unable to load tree structure, the version is unknown.';

  SStreamTooSmall = 'Unable to load tree structure, not enough data available.';

  SCorruptStream1 = 'Stream data corrupt. A node''s anchor chunk is missing.';

  SCorruptStream2 = 'Stream data corrupt. Unexpected data after node''s end position.';

  SClipboardFailed = 'Clipboard operation failed.';

  SCannotSetUserData = 'Cannot set initial user data because there is not enough user data space allocated.';



const

  ClipboardStates = [tsCopyPending, tsCutPending];

  DefaultScrollUpdateFlags = [suoRepaintHeader, suoRepaintScrollBars, suoScrollClientArea, suoUpdateNCArea];

  TreeNodeSize = (SizeOf(TVirtualNode) + (SizeOf(Pointer) - 1)) and not (SizeOf(Pointer) - 1); // used for node allocation and access to internal data



  // Lookup to quickly convert a specific check state into its pressed counterpart and vice versa.

  PressedState: array[TCheckState] of TCheckState = (

    csUncheckedPressed, csUncheckedPressed, csCheckedPressed, csCheckedPressed, csMixedPressed, csMixedPressed

  );

  UnpressedState: array[TCheckState] of TCheckState = (

    csUncheckedNormal, csUncheckedNormal, csCheckedNormal, csCheckedNormal, csMixedNormal, csMixedNormal

  );

  MouseButtonDown = [tsLeftButtonDown, tsMiddleButtonDown, tsRightButtonDown];



  // Do not modify the copyright in any way! Usage of this unit is prohibited without the copyright notice

  // in the compiled binary file.

  Copyright: string = 'Virtual Treeview Š 1999, 2010 Mike Lischke';



var

  StandardOLEFormat: TFormatEtc = (

    // Format must later be set.

    cfFormat: 0;

    // No specific target device to render on.

    ptd: nil;

    // Normal content to render.

    dwAspect: DVASPECT_CONTENT;

    // No specific page of multipage data (we don't use multipage data by default).

    lindex: -1;

    // Acceptable storage formats are IStream and global memory. The first is preferred.

    tymed: TYMED_ISTREAM or TYMED_HGLOBAL;

  );



  {$if CompilerVersion < 23}

type

  TElementEdge = (

    eeRaisedOuter

  );



  TElementEdges = set of TElementEdge;



  TElementEdgeFlag = (

    efRect

  );



  TElementEdgeFlags = set of TElementEdgeFlag;



  // For compatibility with Delphi XE and earlier, prevents deprecated warnings in Delphi XE2 and higher

  StyleServices = class

    class function Enabled: Boolean;

    class function DrawEdge(DC: HDC; Details: TThemedElementDetails; const R: TRect;

      Edges: TElementEdges; Flags: TElementEdgeFlags; ContentRect: PRect = nil): Boolean;

    class function DrawElement(DC: HDC; Details: TThemedElementDetails; const R: TRect; ClipRect: PRect = nil): Boolean;

    class function GetElementDetails(Detail: TThemedHeader): TThemedElementDetails; overload;

    class function GetElementDetails(Detail: TThemedToolTip): TThemedElementDetails; overload;

    class function GetElementDetails(Detail: TThemedWindow): TThemedElementDetails; overload;

    class function GetElementDetails(Detail: TThemedButton): TThemedElementDetails; overload;

    class procedure PaintBorder(Control: TWinControl; EraseLRCorner: Boolean);

  end;



  class function StyleServices.Enabled: Boolean;

  begin

    Result := ThemeServices.ThemesEnabled;

  end;



  class function StyleServices.DrawEdge(DC: HDC; Details: TThemedElementDetails; const R: TRect;

    Edges: TElementEdges; Flags: TElementEdgeFlags; ContentRect: PRect = nil): Boolean;

  begin

    Assert((Edges = [eeRaisedOuter]) and (Flags = [efRect]));

    ThemeServices.DrawEdge(DC, Details, R, BDR_RAISEDOUTER, BF_RECT);

    Result := Enabled;

  end;



  class function StyleServices.DrawElement(DC: HDC; Details: TThemedElementDetails; const R: TRect; ClipRect: PRect = nil): Boolean;

  begin

    ThemeServices.DrawElement(DC, Details, R, ClipRect);

    Result := Enabled;

  end;



  class function StyleServices.GetElementDetails(Detail: TThemedHeader): TThemedElementDetails;

  begin

    Result := ThemeServices.GetElementDetails(Detail);

  end;



  class function StyleServices.GetElementDetails(Detail: TThemedToolTip): TThemedElementDetails;

  begin

    Result := ThemeServices.GetElementDetails(Detail);

  end;



  class function StyleServices.GetElementDetails(Detail: TThemedWindow): TThemedElementDetails;

  begin

    Result := ThemeServices.GetElementDetails(Detail);

  end;



  class function StyleServices.GetElementDetails(Detail: TThemedButton): TThemedElementDetails;

  begin

    Result := ThemeServices.GetElementDetails(Detail);

  end;



  class procedure StyleServices.PaintBorder(Control: TWinControl; EraseLRCorner: Boolean);

  begin

    ThemeServices.PaintBorder(Control, EraseLRCorner);

  end;

  {$ifend}



type

  // protection against TRect record method that cause problems with with-statements

  TWithSafeRect = record

    case Integer of

      0: (Left, Top, Right, Bottom: Longint);

      1: (TopLeft, BottomRight: TPoint);

  end;



type // streaming support

  TMagicID = array[0..5] of WideChar;



  TChunkHeader = record

    ChunkType,

    ChunkSize: Integer;      // contains the size of the chunk excluding the header

  end;



  // base information about a node

  TBaseChunkBody = packed record

    ChildCount,

    NodeHeight: Cardinal;

    States: TVirtualNodeStates;

    Align: Byte;

    CheckState: TCheckState;

    CheckType: TCheckType;

    Reserved: Cardinal;

  end;



  TBaseChunk = packed record

    Header: TChunkHeader;

    Body: TBaseChunkBody;

  end;



  // Toggle animation modes.

  TToggleAnimationMode = (

    tamScrollUp,

    tamScrollDown,

    tamNoScroll

  );



  // Internally used data for animations.

  TToggleAnimationData = record

    Window: HWND;                 // copy of the tree's window handle

    DC: HDC;                      // the DC of the window to erase uncovered parts

    Brush: HBRUSH;                // the brush to be used to erase uncovered parts

    R1,

    R2: TRect;                    // animation rectangles

    Mode1,

    Mode2: TToggleAnimationMode;  // animation modes

    ScaleFactor: Double;          // the factor between the missing step size when doing two animations

    MissedSteps: Double;

  end;



  TCanvasEx = class(TCanvas);



const

  MagicID: TMagicID = (#$2045, 'V', 'T', WideChar(VTTreeStreamVersion), ' ', #$2046);



  // chunk IDs

  NodeChunk = 1;

  BaseChunk = 2;        // chunk containing node state, check state, child node count etc.

                        // this chunk is immediately followed by all child nodes

  CaptionChunk = 3;     // used by the string tree to store a node's caption

  UserChunk = 4;        // used for data supplied by the application



  {$if CompilerVersion < 19}

    const

      TVP_HOTGLYPH = 4;

  {$ifend}



  RTLFlag: array[Boolean] of Integer = (0, ETO_RTLREADING);

  AlignmentToDrawFlag: array[TAlignment] of Cardinal = (DT_LEFT, DT_RIGHT, DT_CENTER);



  WideNull = WideChar(#0);

  WideCR = WideChar(#13);

  WideLF = WideChar(#10);

  WideLineSeparator = WideChar(#2028);



type

  TCriticalSection = class(TObject)

  protected

    FSection: TRTLCriticalSection;

  public

    constructor Create;

    destructor Destroy; override;



    procedure Enter;

    procedure Leave;

  end;



  // internal worker thread

  TWorkerThread = class(TThread)

  private

    FCurrentTree: TBaseVirtualTree;

    FWaiterList: TThreadList;

    FRefCount: Cardinal;

  protected

    procedure CancelValidation(Tree: TBaseVirtualTree);

    procedure Execute; override;

  public

    constructor Create(CreateSuspended: Boolean);

    destructor Destroy; override;



    procedure AddTree(Tree: TBaseVirtualTree);

    procedure RemoveTree(Tree: TBaseVirtualTree);



    property CurrentTree: TBaseVirtualTree read FCurrentTree;

  end;



  // Helper classes to speed up rendering text formats for clipboard and drag'n drop transfers.

  TBufferedAnsiString = class

  private

    FStart,

    FPosition,

    FEnd: PAnsiChar;

    function GetAsString: RawByteString;

  public

    destructor Destroy; override;



    procedure Add(const S: RawByteString);

    procedure AddNewLine;



    property AsString: RawByteString read GetAsString;

  end;



  TWideBufferedString = class

  private

    FStart,

    FPosition,

    FEnd: PWideChar;

    function GetAsString: UnicodeString;

  public

    destructor Destroy; override;



    procedure Add(const S: UnicodeString);

    procedure AddNewLine;



    property AsString: UnicodeString read GetAsString;

  end;



var

  WorkerThread: TWorkerThread;

  WorkEvent: THandle;

  Watcher: TCriticalSection;

  LightCheckImages,                    // global light check images

  DarkCheckImages,                     // global heavy check images

  LightTickImages,                     // global light tick images

  DarkTickImages,                      // global heavy check images

  FlatImages,                          // global flat check images

  XPImages,                            // global XP style check images

  UtilityImages,                       // some small additional images (e.g for header dragging)

  SystemCheckImages,                   // global system check images

  SystemFlatCheckImages: TImageList;   // global flat system check images

  Initialized: Boolean;                // True if global structures have been initialized.

  NeedToUnitialize: Boolean;           // True if the OLE subsystem could be initialized successfully.



//----------------- TClipboardFormats ----------------------------------------------------------------------------------



type

  PClipboardFormatListEntry = ^TClipboardFormatListEntry;

  TClipboardFormatListEntry = record

    Description: string;               // The string used to register the format with Windows.

    TreeClass: TVirtualTreeClass;      // The tree class which supports rendering this format.

    Priority: Cardinal;                // Number which determines the order of formats used in IDataObject.

    FormatEtc: TFormatEtc;             // The definition of the format in the IDataObject.

  end;



  TClipboardFormatList = class

  private

    FList: TList;

    procedure Sort;

  public

    constructor Create;

    destructor Destroy; override;



    procedure Add(FormatString: string; AClass: TVirtualTreeClass; Priority: Cardinal; AFormatEtc: TFormatEtc);

    procedure Clear;

    procedure EnumerateFormats(TreeClass: TVirtualTreeClass; var Formats: TFormatEtcArray;

      const AllowedFormats: TClipboardFormats = nil); overload;

    procedure EnumerateFormats(TreeClass: TVirtualTreeClass; const Formats: TStrings); overload;

    function FindFormat(FormatString: string): PClipboardFormatListEntry; overload;

    function FindFormat(FormatString: string; var Fmt: Word): TVirtualTreeClass; overload;

    function FindFormat(Fmt: Word; var Description: string): TVirtualTreeClass; overload;

  end;



var

  InternalClipboardFormats: TClipboardFormatList;



//----------------------------------------------------------------------------------------------------------------------



constructor TClipboardFormatList.Create;



begin

  FList := TList.Create;

end;



//----------------------------------------------------------------------------------------------------------------------



destructor TClipboardFormatList.Destroy;



begin

  Clear;

  FList.Free;

  inherited;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TClipboardFormatList.Sort;



// Sorts all entry for priority (increasing priority value).



  //--------------- local function --------------------------------------------



  procedure QuickSort(L, R: Integer);



  var

    I, J: Integer;

    P, T: PClipboardFormatListEntry;



  begin

    repeat

      I := L;

      J := R;

      P := FList[(L + R) shr 1];

      repeat

        while PClipboardFormatListEntry(FList[I]).Priority < P.Priority do

          Inc(I);

        while PClipboardFormatListEntry(FList[J]).Priority > P.Priority do

          Dec(J);

        if I <= J then

        begin

          T := FList[I];

          FList[I] := FList[J];

          FList[J] := T;

          Inc(I);

          Dec(J);

        end;

      until I > J;

      if L < J then

        QuickSort(L, J);

      L := I;

    until I >= R;

  end;



  //--------------- end local function ----------------------------------------



begin

  if FList.Count > 1 then

    QuickSort(0, FList.Count - 1);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TClipboardFormatList.Add(FormatString: string; AClass: TVirtualTreeClass; Priority: Cardinal;

  AFormatEtc: TFormatEtc);



// Adds the given data to the internal list. The priority value is used to sort formats for importance. Larger priority

// values mean less priority.



var

  Entry: PClipboardFormatListEntry;



begin

  New(Entry);

  Entry.Description := FormatString;

  Entry.TreeClass := AClass;

  Entry.Priority := Priority;

  Entry.FormatEtc := AFormatEtc;

  FList.Add(Entry);



  Sort;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TClipboardFormatList.Clear;



var

  I: Integer;



begin

  for I := 0 to FList.Count - 1 do

    Dispose(PClipboardFormatListEntry(FList[I]));

  FList.Clear;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TClipboardFormatList.EnumerateFormats(TreeClass: TVirtualTreeClass; var Formats: TFormatEtcArray;

  const AllowedFormats: TClipboardFormats = nil);



// Returns a list of format records for the given class. If assigned the AllowedFormats is used to limit the

// enumerated formats to those described in the list.



var

  I, Count: Integer;

  Entry: PClipboardFormatListEntry;



begin

  SetLength(Formats, FList.Count);

  Count := 0;

  for I := 0 to FList.Count - 1 do

  begin

    Entry := FList[I];

    // Does the tree class support this clipboard format?

    if TreeClass.InheritsFrom(Entry.TreeClass) then

    begin

      // Is this format allowed to be included?

      if (AllowedFormats = nil) or (AllowedFormats.IndexOf(Entry.Description) > -1) then

      begin

        // The list could change before we use the FormatEtc so it is best not to pass a pointer to the true FormatEtc

        // structure. Instead make a copy and send that.

        Formats[Count] := Entry.FormatEtc;

        Inc(Count);

      end;

    end;

  end;

  SetLength(Formats, Count);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TClipboardFormatList.EnumerateFormats(TreeClass: TVirtualTreeClass; const Formats: TStrings);



// Returns a list of format descriptions for the given class.



var

  I: Integer;

  Entry: PClipboardFormatListEntry;



begin

  for I := 0 to FList.Count - 1 do

  begin

    Entry := FList[I];

    if TreeClass.InheritsFrom(Entry.TreeClass) then

      Formats.Add(Entry.Description);

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



function TClipboardFormatList.FindFormat(FormatString: string): PClipboardFormatListEntry;



var

  I: Integer;

  Entry: PClipboardFormatListEntry;



begin

  Result := nil;

  for I := FList.Count - 1 downto 0 do

  begin

    Entry := FList[I];

    if CompareText(Entry.Description, FormatString) = 0 then

    begin

      Result := Entry;

      Break;

    end;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



function TClipboardFormatList.FindFormat(FormatString: string; var Fmt: Word): TVirtualTreeClass;



var

  I: Integer;

  Entry: PClipboardFormatListEntry;



begin

  Result := nil;

  for I := FList.Count - 1 downto 0 do

  begin

    Entry := FList[I];

    if CompareText(Entry.Description, FormatString) = 0 then

    begin

      Result := Entry.TreeClass;

      Fmt := Entry.FormatEtc.cfFormat;

      Break;

    end;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



function TClipboardFormatList.FindFormat(Fmt: Word; var Description: string): TVirtualTreeClass;



var

  I: Integer;

  Entry: PClipboardFormatListEntry;



begin

  Result := nil;

  for I := FList.Count - 1 downto 0 do

  begin

    Entry := FList[I];

    if Entry.FormatEtc.cfFormat = Fmt then

    begin

      Result := Entry.TreeClass;

      Description := Entry.Description;

      Break;

    end;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



type

  TClipboardFormatEntry = record

    ID: Word;

    Description: string;

  end;



var

  ClipboardDescriptions: array [1..CF_MAX - 1] of TClipboardFormatEntry = (

    (ID: CF_TEXT; Description: 'Plain text'), // Do not localize

    (ID: CF_BITMAP; Description: 'Windows bitmap'), // Do not localize

    (ID: CF_METAFILEPICT; Description: 'Windows metafile'), // Do not localize

    (ID: CF_SYLK; Description: 'Symbolic link'), // Do not localize

    (ID: CF_DIF; Description: 'Data interchange format'), // Do not localize

    (ID: CF_TIFF; Description: 'Tiff image'), // Do not localize

    (ID: CF_OEMTEXT; Description: 'OEM text'), // Do not localize

    (ID: CF_DIB; Description: 'DIB image'), // Do not localize

    (ID: CF_PALETTE; Description: 'Palette data'), // Do not localize

    (ID: CF_PENDATA; Description: 'Pen data'), // Do not localize

    (ID: CF_RIFF; Description: 'Riff audio data'), // Do not localize

    (ID: CF_WAVE; Description: 'Wav audio data'), // Do not localize

    (ID: CF_UNICODETEXT; Description: 'Unicode text'), // Do not localize

    (ID: CF_ENHMETAFILE; Description: 'Enhanced metafile image'), // Do not localize

    (ID: CF_HDROP; Description: 'File name(s)'), // Do not localize

    (ID: CF_LOCALE; Description: 'Locale descriptor') // Do not localize

    {$if CompilerVersion >= 23}

    ,(ID: CF_DIBV5; Description: 'DIB image V5') // Do not localize

    {$ifend}

  );



//----------------------------------------------------------------------------------------------------------------------



procedure EnumerateVTClipboardFormats(TreeClass: TVirtualTreeClass; const List: TStrings);



begin

  if InternalClipboardFormats = nil then

    InternalClipboardFormats := TClipboardFormatList.Create;

  InternalClipboardFormats.EnumerateFormats(TreeClass, List);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure EnumerateVTClipboardFormats(TreeClass: TVirtualTreeClass; var Formats: TFormatEtcArray);



begin

  if InternalClipboardFormats = nil then

    InternalClipboardFormats := TClipboardFormatList.Create;

  InternalClipboardFormats.EnumerateFormats(TreeClass, Formats);

end;



//----------------------------------------------------------------------------------------------------------------------



function GetVTClipboardFormatDescription(AFormat: Word): string;



begin

  if InternalClipboardFormats = nil then

    InternalClipboardFormats := TClipboardFormatList.Create;

  if InternalClipboardFormats.FindFormat(AFormat, Result) = nil then

    Result := '';

end;



//----------------------------------------------------------------------------------------------------------------------



procedure RegisterVTClipboardFormat(AFormat: Word; TreeClass: TVirtualTreeClass; Priority: Cardinal);



// Registers the given clipboard format for the given TreeClass.



var

  I: Integer;

  Buffer: array[0..2048] of Char;

  FormatEtc: TFormatEtc;



begin

  if InternalClipboardFormats = nil then

    InternalClipboardFormats := TClipboardFormatList.Create;



  // Assumes a HGlobal format.

  FormatEtc.cfFormat := AFormat;

  FormatEtc.ptd := nil;

  FormatEtc.dwAspect := DVASPECT_CONTENT;

  FormatEtc.lindex := -1;

  FormatEtc.tymed := TYMED_HGLOBAL;



  // Determine description string of the given format. For predefined formats we need the lookup table because they

  // don't have a description string. For registered formats the description string is the string which was used

  // to register them.

  if AFormat < CF_MAX then

  begin

    for I := 1 to High(ClipboardDescriptions) do

      if ClipboardDescriptions[I].ID = AFormat then

      begin

        InternalClipboardFormats.Add(ClipboardDescriptions[I].Description, TreeClass, Priority, FormatEtc);

        Break;

      end;

  end

  else

  begin

    GetClipboardFormatName(AFormat, Buffer, Length(Buffer));

    InternalClipboardFormats.Add(Buffer, TreeClass, Priority, FormatEtc);

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



function RegisterVTClipboardFormat(Description: string; TreeClass: TVirtualTreeClass; Priority: Cardinal;

  tymed: Integer = TYMED_HGLOBAL; ptd: PDVTargetDevice = nil; dwAspect: Integer = DVASPECT_CONTENT;

  lindex: Integer = -1): Word;



// Alternative method to register a certain clipboard format for a given tree class. Registration with the

// clipboard is done here too and the assigned ID returned by the function.

// tymed may contain or'ed TYMED constants which allows to register several storage formats for one clipboard format.



var

  FormatEtc: TFormatEtc;



begin

  if InternalClipboardFormats = nil then

    InternalClipboardFormats := TClipboardFormatList.Create;

  Result := RegisterClipboardFormat(PChar(Description));

  FormatEtc.cfFormat := Result;

  FormatEtc.ptd := ptd;

  FormatEtc.dwAspect := dwAspect;

  FormatEtc.lindex := lindex;

  FormatEtc.tymed := tymed;

  InternalClipboardFormats.Add(Description, TreeClass, Priority, FormatEtc);

end;



//----------------- utility functions ----------------------------------------------------------------------------------



function GetUtilityImages: TCustomImageList; // [IPK]



begin

  Result := UtilityImages; 

end; 



//----------------------------------------------------------------------------------------------------------------------



procedure ShowError(Msg: UnicodeString; HelpContext: Integer);



begin

  raise EVirtualTreeError.CreateHelp(Msg, HelpContext);

end;



//----------------------------------------------------------------------------------------------------------------------



function TreeFromNode(Node: PVirtualNode): TBaseVirtualTree;



// Returns the tree the node currently belongs to or nil if the node is not attached to a tree.



begin

  Assert(Assigned(Node), 'Node must not be nil.');



  // The root node is marked by having its NextSibling (and PrevSibling) pointing to itself.

  while Assigned(Node) and (Node.NextSibling <> Node) do

    Node := Node.Parent;

  if Assigned(Node) then

    Result := TBaseVirtualTree(Node.Parent)

  else

    Result := nil;

end;



//----------------------------------------------------------------------------------------------------------------------



function OrderRect(const R: TRect): TRect;



// Converts the incoming rectangle so that left and top are always less than or equal to right and bottom.



begin

  if R.Left < R.Right then

  begin

    Result.Left := R.Left;

    Result.Right := R.Right;

  end

  else

  begin

    Result.Left := R.Right;

    Result.Right := R.Left;

  end;

  if R.Top < R.Bottom then

  begin

    Result.Top := R.Top;

    Result.Bottom := R.Bottom;

  end

  else

  begin

    Result.Top := R.Bottom;

    Result.Bottom := R.Top;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure QuickSort(const TheArray: TNodeArray; L, R: Integer);



var

  I, J: Integer;

  P, T: Pointer;



begin

  repeat

    I := L;

    J := R;

    P := TheArray[(L + R) shr 1];

    repeat

      while PAnsiChar(TheArray[I]) < PAnsiChar(P) do

        Inc(I);

      while PAnsiChar(TheArray[J]) > PAnsiChar(P) do

        Dec(J);

      if I <= J then

      begin

        T := TheArray[I];

        TheArray[I] := TheArray[J];

        TheArray[J] := T;

        Inc(I);

        Dec(J);

      end;

    until I > J;

    if L < J then

      QuickSort(TheArray, L, J);

    L := I;

  until I >= R;

end;





//----------------------------------------------------------------------------------------------------------------------



function ShortenString(DC: HDC; const S: UnicodeString; Width: Integer; EllipsisWidth: Integer = 0): UnicodeString;



// Adjusts the given string S so that it fits into the given width. EllipsisWidth gives the width of

// the three points to be added to the shorted string. If this value is 0 then it will be determined implicitely.

// For higher speed (and multiple entries to be shorted) specify this value explicitely.

// Note: It is assumed that the string really needs shortage. Check this in advance.



var

  Size: TSize;

  Len: Integer;

  L, H, N, W: Integer;



begin

  Len := Length(S);

  if (Len = 0) or (Width <= 0) then

    Result := ''

  else

  begin

    // Determine width of triple point using the current DC settings (if not already done).

    if EllipsisWidth = 0 then

    begin

      GetTextExtentPoint32W(DC, '...', 3, Size);

      EllipsisWidth := Size.cx;

    end;



    if Width <= EllipsisWidth then

      Result := ''

    else

    begin

      // Do a binary search for the optimal string length which fits into the given width.

      L := 0;

      H := Len - 1;

      while L < H do

      begin

        N := (L + H + 1) shr 1;

        GetTextExtentPoint32W(DC, PWideChar(S), N, Size);

        W := Size.cx + EllipsisWidth;

        if W <= Width then

          L := N

        else

          H := N - 1;

      end;

      Result := Copy(S, 1, L) + '...';

    end;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



function WrapString(DC: HDC; const S: UnicodeString; const Bounds: TRect; RTL: Boolean;

  DrawFormat: Cardinal): UnicodeString;



// Wrap the given string S so that it fits into a space of given width.

// RTL determines if right-to-left reading is active.



var

  Width,

  Len,

  WordCounter,

  WordsInLine,

  I, W: Integer;

  Buffer,

  Line: UnicodeString;

  Words: array of UnicodeString;

  R: TRect;



begin

  Result := '';

  // Leading and trailing are ignored.

  Buffer := Trim(S);

  Len := Length(Buffer);

  if Len < 1 then

    Exit;



  Width := Bounds.Right - Bounds.Left;

  R := Rect(0, 0, 0, 0);



  // Count the words in the string.

  WordCounter := 1;

  for I := 1 to Len do

    if Buffer[I] = ' ' then

      Inc(WordCounter);

  SetLength(Words, WordCounter);



  if RTL then

  begin

    // At first we split the string into words with the last word being the

    // first element in Words.

    W := 0;

    for I := 1 to Len do

      if Buffer[I] = ' ' then

        Inc(W)

      else

        Words[W] := Words[W] + Buffer[I];



    // Compose Result.

    while WordCounter > 0 do

    begin

      WordsInLine := 0;

      Line := '';



      while WordCounter > 0 do

      begin

        GetStringDrawRect(DC, Line + IfThen(WordsInLine > 0, ' ', '') + Words[WordCounter - 1], R, DrawFormat);

        if R.Right > Width then

        begin

          // If at least one word fits into this line then continue with the next line.

          if WordsInLine > 0 then

            Break;



          Buffer := Words[WordCounter - 1];

          if Len > 1 then

          begin

            for Len := Length(Buffer) - 1 downto 2 do

            begin

              GetStringDrawRect(DC, RightStr(Buffer, Len), R, DrawFormat);

              if R.Right <= Width then

                Break;

            end;

          end

          else

            Len := Length(Buffer);



          Line := Line + RightStr(Buffer, Max(Len, 1));

          Words[WordCounter - 1] := LeftStr(Buffer, Length(Buffer) - Max(Len, 1));

          if Words[WordCounter - 1] = '' then

            Dec(WordCounter);

          Break;

        end

        else

        begin

          Dec(WordCounter);

          Line := Words[WordCounter] + IfThen(WordsInLine > 0, ' ', '') + Line;

          Inc(WordsInLine);

        end;

      end;



      Result := Result + Line + WideLF;

    end;

  end

  else

  begin

    // At first we split the string into words with the last word being the

    // first element in Words.

    W := WordCounter - 1;

    for I := 1 to Len do

      if Buffer[I] = ' ' then

        Dec(W)

      else

        Words[W] := Words[W] + Buffer[I];



    // Compose Result.

    while WordCounter > 0 do

    begin

      WordsInLine := 0;

      Line := '';



      while WordCounter > 0 do

      begin

        GetStringDrawRect(DC, Line + IfThen(WordsInLine > 0, ' ', '') + Words[WordCounter - 1], R, DrawFormat);

        if R.Right > Width then

        begin

          // If at least one word fits into this line then continue with the next line.

          if WordsInLine > 0 then

            Break;



          Buffer := Words[WordCounter - 1];

          if Len > 1 then

          begin

            for Len := Length(Buffer) - 1 downto 2 do

            begin

              GetStringDrawRect(DC, LeftStr(Buffer, Len), R, DrawFormat);

              if R.Right <= Width then

                Break;

            end;

          end

          else

            Len := Length(Buffer);



          Line := Line + LeftStr(Buffer, Max(Len, 1));

          Words[WordCounter - 1] := RightStr(Buffer, Length(Buffer) - Max(Len, 1));

          if Words[WordCounter - 1] = '' then

            Dec(WordCounter);

          Break;

        end

        else

        begin

          Dec(WordCounter);

          Line := Line + IfThen(WordsInLine > 0, ' ', '') + Words[WordCounter];

          Inc(WordsInLine);

        end;

      end;



      Result := Result + Line + WideLF;

    end;

  end;



  Len := Length(Result);

  if Result[Len] = WideLF then

    SetLength(Result, Len - 1);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure GetStringDrawRect(DC: HDC; const S: UnicodeString; var Bounds: TRect; DrawFormat: Cardinal);



// Calculates bounds of a drawing rectangle for the given string



begin

  Bounds.Right := Bounds.Left + 1;

  Bounds.Bottom := Bounds.Top + 1;



  Windows.DrawTextW(DC, PWideChar(S), Length(S), Bounds, DrawFormat or DT_CALCRECT);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure FillDragRectangles(DragWidth, DragHeight, DeltaX, DeltaY: Integer; var RClip, RScroll, RSamp1, RSamp2, RDraw1,

  RDraw2: TRect);



// Fills the given rectangles with values which can be used while dragging around an image

// (used in DragMove of the drag manager and DragTo of the header columns).



begin

  // ScrollDC limits

  RClip := Rect(0, 0, DragWidth, DragHeight);

  if DeltaX > 0 then

  begin

    // move to the left

    if DeltaY = 0 then

    begin

      // move only to the left

      // background movement

      RScroll := Rect(0, 0, DragWidth - DeltaX, DragHeight);

      RSamp1 := Rect(0, 0, DeltaX, DragHeight);

      RDraw1 := Rect(DragWidth - DeltaX, 0, DeltaX, DragHeight);

    end

    else

      if DeltaY < 0 then

      begin

        // move to bottom left

        RScroll := Rect(0, -DeltaY, DragWidth - DeltaX, DragHeight);

        RSamp1 := Rect(0, 0, DeltaX, DragHeight);

        RSamp2 := Rect(DeltaX, DragHeight + DeltaY, DragWidth - DeltaX, -DeltaY);

        RDraw1 := Rect(0, 0, DragWidth - DeltaX, -DeltaY);

        RDraw2 := Rect(DragWidth - DeltaX, 0, DeltaX, DragHeight);

      end

      else

      begin

        // move to upper left

        RScroll := Rect(0, 0, DragWidth - DeltaX, DragHeight - DeltaY);

        RSamp1 := Rect(0, 0, DeltaX, DragHeight);

        RSamp2 := Rect(DeltaX, 0, DragWidth - DeltaX, DeltaY);

        RDraw1 := Rect(0, DragHeight - DeltaY, DragWidth - DeltaX, DeltaY);

        RDraw2 := Rect(DragWidth - DeltaX, 0, DeltaX, DragHeight);

      end;

  end

  else

    if DeltaX = 0 then

    begin

      // vertical movement only

      if DeltaY < 0 then

      begin

        // move downwards

        RScroll := Rect(0, -DeltaY, DragWidth, DragHeight);

        RSamp2 := Rect(0, DragHeight + DeltaY, DragWidth, -DeltaY);

        RDraw2 := Rect(0, 0, DragWidth, -DeltaY);

      end

      else

      begin

        // move upwards

        RScroll := Rect(0, 0, DragWidth, DragHeight - DeltaY);

        RSamp2 := Rect(0, 0, DragWidth, DeltaY);

        RDraw2 := Rect(0, DragHeight - DeltaY, DragWidth, DeltaY);

      end;

    end

    else

    begin

      // move to the right

      if DeltaY > 0 then

      begin

        // move up right

        RScroll := Rect(-DeltaX, 0, DragWidth, DragHeight);

        RSamp1 := Rect(0, 0, DragWidth + DeltaX, DeltaY);

        RSamp2 := Rect(DragWidth + DeltaX, 0, -DeltaX, DragHeight);

        RDraw1 := Rect(0, 0, -DeltaX, DragHeight);

        RDraw2 := Rect(-DeltaX, DragHeight - DeltaY, DragWidth + DeltaX, DeltaY);

      end

      else

        if DeltaY = 0 then

        begin

          // to the right only

          RScroll := Rect(-DeltaX, 0, DragWidth, DragHeight);

          RSamp1 := Rect(DragWidth + DeltaX, 0, -DeltaX, DragHeight);

          RDraw1 := Rect(0, 0, -DeltaX, DragHeight);

        end

        else

        begin

          // move down right

          RScroll := Rect(-DeltaX, -DeltaY, DragWidth, DragHeight);

          RSamp1 := Rect(0, DragHeight + DeltaY, DragWidth + DeltaX, -DeltaY);

          RSamp2 := Rect(DragWidth + DeltaX, 0, -DeltaX, DragHeight);

          RDraw1 := Rect(0, 0, -DeltaX, DragHeight);

          RDraw2 := Rect(-DeltaX, 0, DragWidth + DeltaX, -DeltaY);

        end;

    end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure AlphaBlendLineConstant(Source, Destination: Pointer; Count: Integer; ConstantAlpha, Bias: Integer);



// Blends a line of Count pixels from Source to Destination using a constant alpha value.

// The layout of a pixel must be BGRA where A is ignored (but is calculated as the other components).

// ConstantAlpha must be in the range 0..255 where 0 means totally transparent (destination pixel only)

// and 255 totally opaque (source pixel only).

// Bias is an additional value which gets added to every component and must be in the range -128..127

//

{$ifdef CPUX64}

// RCX contains Source

// RDX contains Destination

// R8D contains Count

// R9D contains ConstantAlpha

// Bias is on the stack



asm

        //.NOFRAME



        // Load XMM3 with the constant alpha value (replicate it for every component).

        // Expand it to word size.

        MOVD        XMM3, R9D  // ConstantAlpha

        PUNPCKLWD   XMM3, XMM3

        PUNPCKLDQ   XMM3, XMM3



        // Load XMM5 with the bias value.

        MOVD        XMM5, [Bias]

        PUNPCKLWD   XMM5, XMM5

        PUNPCKLDQ   XMM5, XMM5



        // Load XMM4 with 128 to allow for saturated biasing.

        MOV         R10D, 128

        MOVD        XMM4, R10D

        PUNPCKLWD   XMM4, XMM4

        PUNPCKLDQ   XMM4, XMM4



@1:     // The pixel loop calculates an entire pixel in one run.

        // Note: The pixel byte values are expanded into the higher bytes of a word due

        //       to the way unpacking works. We compensate for this with an extra shift.

        MOVD        XMM1, DWORD PTR [RCX]   // data is unaligned

        MOVD        XMM2, DWORD PTR [RDX]   // data is unaligned

        PXOR        XMM0, XMM0    // clear source pixel register for unpacking

        PUNPCKLBW   XMM0, XMM1{[RCX]}    // unpack source pixel byte values into words

        PSRLW       XMM0, 8       // move higher bytes to lower bytes

        PXOR        XMM1, XMM1    // clear target pixel register for unpacking

        PUNPCKLBW   XMM1, XMM2{[RDX]}    // unpack target pixel byte values into words

        MOVQ        XMM2, XMM1    // make a copy of the shifted values, we need them again

        PSRLW       XMM1, 8       // move higher bytes to lower bytes



        // calculation is: target = (alpha * (source - target) + 256 * target) / 256

        PSUBW       XMM0, XMM1    // source - target

        PMULLW      XMM0, XMM3    // alpha * (source - target)

        PADDW       XMM0, XMM2    // add target (in shifted form)

        PSRLW       XMM0, 8       // divide by 256



        // Bias is accounted for by conversion of range 0..255 to -128..127,

        // doing a saturated add and convert back to 0..255.

        PSUBW     XMM0, XMM4

        PADDSW    XMM0, XMM5

        PADDW     XMM0, XMM4

        PACKUSWB  XMM0, XMM0      // convert words to bytes with saturation

        MOVD      DWORD PTR [RDX], XMM0     // store the result

@3:

        ADD       RCX, 4

        ADD       RDX, 4

        DEC       R8D

        JNZ       @1

end;

{$else}

// EAX contains Source

// EDX contains Destination

// ECX contains Count

// ConstantAlpha and Bias are on the stack



asm

        PUSH    ESI                    // save used registers

        PUSH    EDI



        MOV     ESI, EAX               // ESI becomes the actual source pointer

        MOV     EDI, EDX               // EDI becomes the actual target pointer



        // Load MM6 with the constant alpha value (replicate it for every component).

        // Expand it to word size.

        MOV     EAX, [ConstantAlpha]

        DB      $0F, $6E, $F0          /// MOVD      MM6, EAX

        DB      $0F, $61, $F6          /// PUNPCKLWD MM6, MM6

        DB      $0F, $62, $F6          /// PUNPCKLDQ MM6, MM6



        // Load MM5 with the bias value.

        MOV     EAX, [Bias]

        DB      $0F, $6E, $E8          /// MOVD      MM5, EAX

        DB      $0F, $61, $ED          /// PUNPCKLWD MM5, MM5

        DB      $0F, $62, $ED          /// PUNPCKLDQ MM5, MM5



        // Load MM4 with 128 to allow for saturated biasing.

        MOV     EAX, 128

        DB      $0F, $6E, $E0          /// MOVD      MM4, EAX

        DB      $0F, $61, $E4          /// PUNPCKLWD MM4, MM4

        DB      $0F, $62, $E4          /// PUNPCKLDQ MM4, MM4



@1:     // The pixel loop calculates an entire pixel in one run.

        // Note: The pixel byte values are expanded into the higher bytes of a word due

        //       to the way unpacking works. We compensate for this with an extra shift.

        DB      $0F, $EF, $C0          /// PXOR      MM0, MM0,   clear source pixel register for unpacking

        DB      $0F, $60, $06          /// PUNPCKLBW MM0, [ESI], unpack source pixel byte values into words

        DB      $0F, $71, $D0, $08     /// PSRLW     MM0, 8,     move higher bytes to lower bytes

        DB      $0F, $EF, $C9          /// PXOR      MM1, MM1,   clear target pixel register for unpacking

        DB      $0F, $60, $0F          /// PUNPCKLBW MM1, [EDI], unpack target pixel byte values into words

        DB      $0F, $6F, $D1          /// MOVQ      MM2, MM1,   make a copy of the shifted values, we need them again

        DB      $0F, $71, $D1, $08     /// PSRLW     MM1, 8,     move higher bytes to lower bytes



        // calculation is: target = (alpha * (source - target) + 256 * target) / 256

        DB      $0F, $F9, $C1          /// PSUBW     MM0, MM1,   source - target

        DB      $0F, $D5, $C6          /// PMULLW    MM0, MM6,   alpha * (source - target)

        DB      $0F, $FD, $C2          /// PADDW     MM0, MM2,   add target (in shifted form)

        DB      $0F, $71, $D0, $08     /// PSRLW     MM0, 8,     divide by 256



        // Bias is accounted for by conversion of range 0..255 to -128..127,

        // doing a saturated add and convert back to 0..255.

        DB      $0F, $F9, $C4          /// PSUBW     MM0, MM4

        DB      $0F, $ED, $C5          /// PADDSW    MM0, MM5

        DB      $0F, $FD, $C4          /// PADDW     MM0, MM4

        DB      $0F, $67, $C0          /// PACKUSWB  MM0, MM0,   convert words to bytes with saturation

        DB      $0F, $7E, $07          /// MOVD      [EDI], MM0, store the result

@3:

        ADD     ESI, 4

        ADD     EDI, 4

        DEC     ECX

        JNZ     @1

        POP     EDI

        POP     ESI

end;

{$endif CPUX64}



//----------------------------------------------------------------------------------------------------------------------



procedure AlphaBlendLinePerPixel(Source, Destination: Pointer; Count, Bias: Integer);



// Blends a line of Count pixels from Source to Destination using the alpha value of the source pixels.

// The layout of a pixel must be BGRA.

// Bias is an additional value which gets added to every component and must be in the range -128..127

//

{$ifdef CPUX64}

// RCX contains Source

// RDX contains Destination

// R8D contains Count

// R9D contains Bias



asm

        //.NOFRAME



        // Load XMM5 with the bias value.

        MOVD        XMM5, R9D   // Bias

        PUNPCKLWD   XMM5, XMM5

        PUNPCKLDQ   XMM5, XMM5



        // Load XMM4 with 128 to allow for saturated biasing.

        MOV         R10D, 128

        MOVD        XMM4, R10D

        PUNPCKLWD   XMM4, XMM4

        PUNPCKLDQ   XMM4, XMM4



@1:     // The pixel loop calculates an entire pixel in one run.

        // Note: The pixel byte values are expanded into the higher bytes of a word due

        //       to the way unpacking works. We compensate for this with an extra shift.

        MOVD        XMM1, DWORD PTR [RCX]   // data is unaligned

        MOVD        XMM2, DWORD PTR [RDX]   // data is unaligned

        PXOR        XMM0, XMM0    // clear source pixel register for unpacking

        PUNPCKLBW   XMM0, XMM1{[RCX]}    // unpack source pixel byte values into words

        PSRLW       XMM0, 8       // move higher bytes to lower bytes

        PXOR        XMM1, XMM1    // clear target pixel register for unpacking

        PUNPCKLBW   XMM1, XMM2{[RDX]}    // unpack target pixel byte values into words

        MOVQ        XMM2, XMM1    // make a copy of the shifted values, we need them again

        PSRLW       XMM1, 8       // move higher bytes to lower bytes



        // Load XMM3 with the source alpha value (replicate it for every component).

        // Expand it to word size.

        MOVQ        XMM3, XMM0

        PUNPCKHWD   XMM3, XMM3

        PUNPCKHDQ   XMM3, XMM3



        // calculation is: target = (alpha * (source - target) + 256 * target) / 256

        PSUBW       XMM0, XMM1    // source - target

        PMULLW      XMM0, XMM3    // alpha * (source - target)

        PADDW       XMM0, XMM2    // add target (in shifted form)

        PSRLW       XMM0, 8       // divide by 256



        // Bias is accounted for by conversion of range 0..255 to -128..127,

        // doing a saturated add and convert back to 0..255.

        PSUBW       XMM0, XMM4

        PADDSW      XMM0, XMM5

        PADDW       XMM0, XMM4

        PACKUSWB    XMM0, XMM0    // convert words to bytes with saturation

        MOVD        DWORD PTR [RDX], XMM0   // store the result

@3:

        ADD         RCX, 4

        ADD         RDX, 4

        DEC         R8D

        JNZ         @1

end;

{$else}

// EAX contains Source

// EDX contains Destination

// ECX contains Count

// Bias is on the stack



asm

        PUSH    ESI                    // save used registers

        PUSH    EDI



        MOV     ESI, EAX               // ESI becomes the actual source pointer

        MOV     EDI, EDX               // EDI becomes the actual target pointer



        // Load MM5 with the bias value.

        MOV     EAX, [Bias]

        DB      $0F, $6E, $E8          /// MOVD      MM5, EAX

        DB      $0F, $61, $ED          /// PUNPCKLWD MM5, MM5

        DB      $0F, $62, $ED          /// PUNPCKLDQ MM5, MM5



        // Load MM4 with 128 to allow for saturated biasing.

        MOV     EAX, 128

        DB      $0F, $6E, $E0          /// MOVD      MM4, EAX

        DB      $0F, $61, $E4          /// PUNPCKLWD MM4, MM4

        DB      $0F, $62, $E4          /// PUNPCKLDQ MM4, MM4



@1:     // The pixel loop calculates an entire pixel in one run.

        // Note: The pixel byte values are expanded into the higher bytes of a word due

        //       to the way unpacking works. We compensate for this with an extra shift.

        DB      $0F, $EF, $C0          /// PXOR      MM0, MM0,   clear source pixel register for unpacking

        DB      $0F, $60, $06          /// PUNPCKLBW MM0, [ESI], unpack source pixel byte values into words

        DB      $0F, $71, $D0, $08     /// PSRLW     MM0, 8,     move higher bytes to lower bytes

        DB      $0F, $EF, $C9          /// PXOR      MM1, MM1,   clear target pixel register for unpacking

        DB      $0F, $60, $0F          /// PUNPCKLBW MM1, [EDI], unpack target pixel byte values into words

        DB      $0F, $6F, $D1          /// MOVQ      MM2, MM1,   make a copy of the shifted values, we need them again

        DB      $0F, $71, $D1, $08     /// PSRLW     MM1, 8,     move higher bytes to lower bytes



        // Load MM6 with the source alpha value (replicate it for every component).

        // Expand it to word size.

        DB      $0F, $6F, $F0          /// MOVQ MM6, MM0

        DB      $0F, $69, $F6          /// PUNPCKHWD MM6, MM6

        DB      $0F, $6A, $F6          /// PUNPCKHDQ MM6, MM6



        // calculation is: target = (alpha * (source - target) + 256 * target) / 256

        DB      $0F, $F9, $C1          /// PSUBW     MM0, MM1,   source - target

        DB      $0F, $D5, $C6          /// PMULLW    MM0, MM6,   alpha * (source - target)

        DB      $0F, $FD, $C2          /// PADDW     MM0, MM2,   add target (in shifted form)

        DB      $0F, $71, $D0, $08     /// PSRLW     MM0, 8,     divide by 256



        // Bias is accounted for by conversion of range 0..255 to -128..127,

        // doing a saturated add and convert back to 0..255.

        DB      $0F, $F9, $C4          /// PSUBW     MM0, MM4

        DB      $0F, $ED, $C5          /// PADDSW    MM0, MM5

        DB      $0F, $FD, $C4          /// PADDW     MM0, MM4

        DB      $0F, $67, $C0          /// PACKUSWB  MM0, MM0,   convert words to bytes with saturation

        DB      $0F, $7E, $07          /// MOVD      [EDI], MM0, store the result

@3:

        ADD     ESI, 4

        ADD     EDI, 4

        DEC     ECX

        JNZ     @1

        POP     EDI

        POP     ESI

end;

{$endif CPUX64}



//----------------------------------------------------------------------------------------------------------------------



procedure AlphaBlendLineMaster(Source, Destination: Pointer; Count: Integer; ConstantAlpha, Bias: Integer);



// Blends a line of Count pixels from Source to Destination using the source pixel and a constant alpha value.

// The layout of a pixel must be BGRA.

// ConstantAlpha must be in the range 0..255.

// Bias is an additional value which gets added to every component and must be in the range -128..127

//

{$ifdef CPUX64}

// RCX contains Source

// RDX contains Destination

// R8D contains Count

// R9D contains ConstantAlpha

// Bias is on the stack



asm

        .SAVENV XMM6



        // Load XMM3 with the constant alpha value (replicate it for every component).

        // Expand it to word size.

        MOVD        XMM3, R9D    // ConstantAlpha

        PUNPCKLWD   XMM3, XMM3

        PUNPCKLDQ   XMM3, XMM3



        // Load XMM5 with the bias value.

        MOV         R10D, [Bias]

        MOVD        XMM5, R10D

        PUNPCKLWD   XMM5, XMM5

        PUNPCKLDQ   XMM5, XMM5



        // Load XMM4 with 128 to allow for saturated biasing.

        MOV         R10D, 128

        MOVD        XMM4, R10D

        PUNPCKLWD   XMM4, XMM4

        PUNPCKLDQ   XMM4, XMM4



@1:     // The pixel loop calculates an entire pixel in one run.

        // Note: The pixel byte values are expanded into the higher bytes of a word due

        //       to the way unpacking works. We compensate for this with an extra shift.

        MOVD        XMM1, DWORD PTR [RCX]   // data is unaligned

        MOVD        XMM2, DWORD PTR [RDX]   // data is unaligned

        PXOR        XMM0, XMM0    // clear source pixel register for unpacking

        PUNPCKLBW   XMM0, XMM1{[RCX]}     // unpack source pixel byte values into words

        PSRLW       XMM0, 8       // move higher bytes to lower bytes

        PXOR        XMM1, XMM1    // clear target pixel register for unpacking

        PUNPCKLBW   XMM1, XMM2{[RCX]}     // unpack target pixel byte values into words

        MOVQ        XMM2, XMM1    // make a copy of the shifted values, we need them again

        PSRLW       XMM1, 8       // move higher bytes to lower bytes



        // Load XMM6 with the source alpha value (replicate it for every component).

        // Expand it to word size.

        MOVQ        XMM6, XMM0

        PUNPCKHWD   XMM6, XMM6

        PUNPCKHDQ   XMM6, XMM6

        PMULLW      XMM6, XMM3    // source alpha * master alpha

        PSRLW       XMM6, 8       // divide by 256



        // calculation is: target = (alpha * master alpha * (source - target) + 256 * target) / 256

        PSUBW       XMM0, XMM1    // source - target

        PMULLW      XMM0, XMM6    // alpha * (source - target)

        PADDW       XMM0, XMM2    // add target (in shifted form)

        PSRLW       XMM0, 8       // divide by 256



        // Bias is accounted for by conversion of range 0..255 to -128..127,

        // doing a saturated add and convert back to 0..255.

        PSUBW       XMM0, XMM4

        PADDSW      XMM0, XMM5

        PADDW       XMM0, XMM4

        PACKUSWB    XMM0, XMM0    // convert words to bytes with saturation

        MOVD        DWORD PTR [RDX], XMM0   // store the result

@3:

        ADD         RCX, 4

        ADD         RDX, 4

        DEC         R8D

        JNZ         @1

end;

{$else}

// EAX contains Source

// EDX contains Destination

// ECX contains Count

// ConstantAlpha and Bias are on the stack



asm

        PUSH    ESI                    // save used registers

        PUSH    EDI



        MOV     ESI, EAX               // ESI becomes the actual source pointer

        MOV     EDI, EDX               // EDI becomes the actual target pointer



        // Load MM6 with the constant alpha value (replicate it for every component).

        // Expand it to word size.

        MOV     EAX, [ConstantAlpha]

        DB      $0F, $6E, $F0          /// MOVD      MM6, EAX

        DB      $0F, $61, $F6          /// PUNPCKLWD MM6, MM6

        DB      $0F, $62, $F6          /// PUNPCKLDQ MM6, MM6



        // Load MM5 with the bias value.

        MOV     EAX, [Bias]

        DB      $0F, $6E, $E8          /// MOVD      MM5, EAX

        DB      $0F, $61, $ED          /// PUNPCKLWD MM5, MM5

        DB      $0F, $62, $ED          /// PUNPCKLDQ MM5, MM5



        // Load MM4 with 128 to allow for saturated biasing.

        MOV     EAX, 128

        DB      $0F, $6E, $E0          /// MOVD      MM4, EAX

        DB      $0F, $61, $E4          /// PUNPCKLWD MM4, MM4

        DB      $0F, $62, $E4          /// PUNPCKLDQ MM4, MM4



@1:     // The pixel loop calculates an entire pixel in one run.

        // Note: The pixel byte values are expanded into the higher bytes of a word due

        //       to the way unpacking works. We compensate for this with an extra shift.

        DB      $0F, $EF, $C0          /// PXOR      MM0, MM0,   clear source pixel register for unpacking

        DB      $0F, $60, $06          /// PUNPCKLBW MM0, [ESI], unpack source pixel byte values into words

        DB      $0F, $71, $D0, $08     /// PSRLW     MM0, 8,     move higher bytes to lower bytes

        DB      $0F, $EF, $C9          /// PXOR      MM1, MM1,   clear target pixel register for unpacking

        DB      $0F, $60, $0F          /// PUNPCKLBW MM1, [EDI], unpack target pixel byte values into words

        DB      $0F, $6F, $D1          /// MOVQ      MM2, MM1,   make a copy of the shifted values, we need them again

        DB      $0F, $71, $D1, $08     /// PSRLW     MM1, 8,     move higher bytes to lower bytes



        // Load MM7 with the source alpha value (replicate it for every component).

        // Expand it to word size.

        DB      $0F, $6F, $F8          /// MOVQ      MM7, MM0

        DB      $0F, $69, $FF          /// PUNPCKHWD MM7, MM7

        DB      $0F, $6A, $FF          /// PUNPCKHDQ MM7, MM7

        DB      $0F, $D5, $FE          /// PMULLW    MM7, MM6,   source alpha * master alpha

        DB      $0F, $71, $D7, $08     /// PSRLW     MM7, 8,     divide by 256



        // calculation is: target = (alpha * master alpha * (source - target) + 256 * target) / 256

        DB      $0F, $F9, $C1          /// PSUBW     MM0, MM1,   source - target

        DB      $0F, $D5, $C7          /// PMULLW    MM0, MM7,   alpha * (source - target)

        DB      $0F, $FD, $C2          /// PADDW     MM0, MM2,   add target (in shifted form)

        DB      $0F, $71, $D0, $08     /// PSRLW     MM0, 8,     divide by 256



        // Bias is accounted for by conversion of range 0..255 to -128..127,

        // doing a saturated add and convert back to 0..255.

        DB      $0F, $F9, $C4          /// PSUBW     MM0, MM4

        DB      $0F, $ED, $C5          /// PADDSW    MM0, MM5

        DB      $0F, $FD, $C4          /// PADDW     MM0, MM4

        DB      $0F, $67, $C0          /// PACKUSWB  MM0, MM0,   convert words to bytes with saturation

        DB      $0F, $7E, $07          /// MOVD      [EDI], MM0, store the result

@3:

        ADD     ESI, 4

        ADD     EDI, 4

        DEC     ECX

        JNZ     @1

        POP     EDI

        POP     ESI

end;

{$endif CPUX64}



//----------------------------------------------------------------------------------------------------------------------



procedure AlphaBlendLineMasterAndColor(Destination: Pointer; Count: Integer; ConstantAlpha, Color: Integer);



// Blends a line of Count pixels in Destination against the given color using a constant alpha value.

// The layout of a pixel must be BGRA and Color must be rrggbb00 (as stored by a COLORREF).

// ConstantAlpha must be in the range 0..255.

//

{$ifdef CPUX64}

// RCX contains Destination

// EDX contains Count

// R8D contains ConstantAlpha

// R9D contains Color



asm

        //.NOFRAME



        // The used formula is: target = (alpha * color + (256 - alpha) * target) / 256.

        // alpha * color (factor 1) and 256 - alpha (factor 2) are constant values which can be calculated in advance.

        // The remaining calculation is therefore: target = (F1 + F2 * target) / 256



        // Load XMM3 with the constant alpha value (replicate it for every component).

        // Expand it to word size. (Every calculation here works on word sized operands.)

        MOVD        XMM3, R8D   // ConstantAlpha

        PUNPCKLWD   XMM3, XMM3

        PUNPCKLDQ   XMM3, XMM3



        // Calculate factor 2.

        MOV         R10D, $100

        MOVD        XMM2, R10D

        PUNPCKLWD   XMM2, XMM2

        PUNPCKLDQ   XMM2, XMM2

        PSUBW       XMM2, XMM3             // XMM2 contains now: 255 - alpha = F2



        // Now calculate factor 1. Alpha is still in XMM3, but the r and b components of Color must be swapped.

        BSWAP       R9D  // Color

        ROR         R9D, 8

        MOVD        XMM1, R9D              // Load the color and convert to word sized values.

        PXOR        XMM4, XMM4

        PUNPCKLBW   XMM1, XMM4

        PMULLW      XMM1, XMM3             // XMM1 contains now: color * alpha = F1



@1:     // The pixel loop calculates an entire pixel in one run.

        MOVD        XMM0, DWORD PTR [RCX]

        PUNPCKLBW   XMM0, XMM4



        PMULLW      XMM0, XMM2             // calculate F1 + F2 * target

        PADDW       XMM0, XMM1

        PSRLW       XMM0, 8                // divide by 256



        PACKUSWB    XMM0, XMM0             // convert words to bytes with saturation

        MOVD        DWORD PTR [RCX], XMM0            // store the result



        ADD         RCX, 4

        DEC         EDX

        JNZ         @1

end;

{$else}

// EAX contains Destination

// EDX contains Count

// ECX contains ConstantAlpha

// Color is passed on the stack



asm

        // The used formula is: target = (alpha * color + (256 - alpha) * target) / 256.

        // alpha * color (factor 1) and 256 - alpha (factor 2) are constant values which can be calculated in advance.

        // The remaining calculation is therefore: target = (F1 + F2 * target) / 256



        // Load MM3 with the constant alpha value (replicate it for every component).

        // Expand it to word size. (Every calculation here works on word sized operands.)

        DB      $0F, $6E, $D9          /// MOVD      MM3, ECX

        DB      $0F, $61, $DB          /// PUNPCKLWD MM3, MM3

        DB      $0F, $62, $DB          /// PUNPCKLDQ MM3, MM3



        // Calculate factor 2.

        MOV     ECX, $100

        DB      $0F, $6E, $D1          /// MOVD      MM2, ECX

        DB      $0F, $61, $D2          /// PUNPCKLWD MM2, MM2

        DB      $0F, $62, $D2          /// PUNPCKLDQ MM2, MM2

        DB      $0F, $F9, $D3          /// PSUBW     MM2, MM3             // MM2 contains now: 255 - alpha = F2



        // Now calculate factor 1. Alpha is still in MM3, but the r and b components of Color must be swapped.

        MOV     ECX, [Color]

        BSWAP   ECX

        ROR     ECX, 8

        DB      $0F, $6E, $C9          /// MOVD      MM1, ECX             // Load the color and convert to word sized values.

        DB      $0F, $EF, $E4          /// PXOR      MM4, MM4

        DB      $0F, $60, $CC          /// PUNPCKLBW MM1, MM4

        DB      $0F, $D5, $CB          /// PMULLW    MM1, MM3             // MM1 contains now: color * alpha = F1



@1:     // The pixel loop calculates an entire pixel in one run.

        DB      $0F, $6E, $00          /// MOVD      MM0, [EAX]

        DB      $0F, $60, $C4          /// PUNPCKLBW MM0, MM4



        DB      $0F, $D5, $C2          /// PMULLW    MM0, MM2             // calculate F1 + F2 * target

        DB      $0F, $FD, $C1          /// PADDW     MM0, MM1

        DB      $0F, $71, $D0, $08     /// PSRLW     MM0, 8               // divide by 256



        DB      $0F, $67, $C0          /// PACKUSWB  MM0, MM0             // convert words to bytes with saturation

        DB      $0F, $7E, $00          /// MOVD      [EAX], MM0           // store the result



        ADD     EAX, 4

        DEC     EDX

        JNZ     @1

end;

{$endif CPUX64}



//----------------------------------------------------------------------------------------------------------------------



procedure EMMS;



// Reset MMX state to use the FPU for other tasks again.



{$ifdef CPUX64}

  inline;

begin

end;

{$else}

asm

        DB      $0F, $77               /// EMMS

end;

{$endif CPUX64}



//----------------------------------------------------------------------------------------------------------------------



function GetBitmapBitsFromDeviceContext(DC: HDC; var Width, Height: Integer): Pointer;



// Helper function used to retrieve the bitmap selected into the given device context. If there is a bitmap then

// the function will return a pointer to its bits otherwise nil is returned.

// Additionally the dimensions of the bitmap are returned.



var

  Bitmap: HBITMAP;

  DIB: TDIBSection;



begin

  Result := nil;

  Width := 0;

  Height := 0;



  Bitmap := GetCurrentObject(DC, OBJ_BITMAP);

  if Bitmap <> 0 then

  begin

    if GetObject(Bitmap, SizeOf(DIB), @DIB) = SizeOf(DIB) then

    begin

      Assert(DIB.dsBm.bmPlanes * DIB.dsBm.bmBitsPixel = 32, 'Alpha blending error: bitmap must use 32 bpp.');

      Result := DIB.dsBm.bmBits;

      Width := DIB.dsBmih.biWidth;

      Height := DIB.dsBmih.biHeight;

    end;

  end;

  Assert(Result <> nil, 'Alpha blending DC error: no bitmap available.');

end;



//----------------------------------------------------------------------------------------------------------------------



function CalculateScanline(Bits: Pointer; Width, Height, Row: Integer): Pointer;



// Helper function to calculate the start address for the given row.



begin

  if Height > 0 then  // bottom-up DIB

    Row := Height - Row - 1;

  // Return DWORD aligned address of the requested scanline.

  Result := PAnsiChar(Bits) + Row * ((Width * 32 + 31) and not 31) div 8;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure AlphaBlend(Source, Destination: HDC; R: TRect; Target: TPoint; Mode: TBlendMode; ConstantAlpha, Bias: Integer);



// Optimized alpha blend procedure using MMX instructions to perform as quick as possible.

// For this procedure to work properly it is important that both source and target bitmap use the 32 bit color format.

// R describes the source rectangle to work on.

// Target is the place (upper left corner) in the target bitmap where to blend to. Note that source width + X offset

// must be less or equal to the target width. Similar for the height.

// If Mode is bmConstantAlpha then the blend operation uses the given ConstantAlpha value for all pixels.

// If Mode is bmPerPixelAlpha then each pixel is blended using its individual alpha value (the alpha value of the source).

// If Mode is bmMasterAlpha then each pixel is blended using its individual alpha value multiplied by ConstantAlpha.

// If Mode is bmConstantAlphaAndColor then each destination pixel is blended using ConstantAlpha but also a constant

// color which will be obtained from Bias. In this case no offset value is added, otherwise Bias is used as offset.

// Blending of a color into target only (bmConstantAlphaAndColor) ignores Source (the DC) and Target (the position).

// CAUTION: This procedure does not check whether MMX instructions are actually available! Call it only if MMX is really

//          usable.



var

  Y: Integer;

  SourceRun,

  TargetRun: PByte;



  SourceBits,

  DestBits: Pointer;

  SourceWidth,

  SourceHeight,

  DestWidth,

  DestHeight: Integer;



begin

  if not IsRectEmpty(R) then

  begin

    // Note: it is tempting to optimize the special cases for constant alpha 0 and 255 by just ignoring soure

    //       (alpha = 0) or simply do a blit (alpha = 255). But this does not take the bias into account.

    case Mode of

      bmConstantAlpha:

        begin

          // Get a pointer to the bitmap bits for the source and target device contexts.

          // Note: this supposes that both contexts do actually have bitmaps assigned!

          SourceBits := GetBitmapBitsFromDeviceContext(Source, SourceWidth, SourceHeight);

          DestBits := GetBitmapBitsFromDeviceContext(Destination, DestWidth, DestHeight);

          if Assigned(SourceBits) and Assigned(DestBits) then

          begin

            for Y := 0 to R.Bottom - R.Top - 1 do

            begin

              SourceRun := CalculateScanline(SourceBits, SourceWidth, SourceHeight, Y + R.Top);

              Inc(SourceRun, 4 * R.Left);

              TargetRun := CalculateScanline(DestBits, DestWidth, DestHeight, Y + Target.Y);

              Inc(TargetRun, 4 * Target.X);

              AlphaBlendLineConstant(SourceRun, TargetRun, R.Right - R.Left, ConstantAlpha, Bias);

            end;

          end;

          EMMS;

        end;

      bmPerPixelAlpha:

        begin

          SourceBits := GetBitmapBitsFromDeviceContext(Source, SourceWidth, SourceHeight);

          DestBits := GetBitmapBitsFromDeviceContext(Destination, DestWidth, DestHeight);

          if Assigned(SourceBits) and Assigned(DestBits) then

          begin

            for Y := 0 to R.Bottom - R.Top - 1 do

            begin

              SourceRun := CalculateScanline(SourceBits, SourceWidth, SourceHeight, Y + R.Top);

              Inc(SourceRun, 4 * R.Left);

              TargetRun := CalculateScanline(DestBits, DestWidth, DestHeight, Y + Target.Y);

              Inc(TargetRun, 4 * Target.X);

              AlphaBlendLinePerPixel(SourceRun, TargetRun, R.Right - R.Left, Bias);

            end;

          end;

          EMMS;

        end;

      bmMasterAlpha:

        begin

          SourceBits := GetBitmapBitsFromDeviceContext(Source, SourceWidth, SourceHeight);

          DestBits := GetBitmapBitsFromDeviceContext(Destination, DestWidth, DestHeight);

          if Assigned(SourceBits) and Assigned(DestBits) then

          begin

            for Y := 0 to R.Bottom - R.Top - 1 do

            begin

              SourceRun := CalculateScanline(SourceBits, SourceWidth, SourceHeight, Y + R.Top);

              Inc(SourceRun, 4 * Target.X);

              TargetRun := CalculateScanline(DestBits, DestWidth, DestHeight, Y + Target.Y);

              AlphaBlendLineMaster(SourceRun, TargetRun, R.Right - R.Left, ConstantAlpha, Bias);

            end;

          end;

          EMMS;

        end;

      bmConstantAlphaAndColor:

        begin

          // Source is ignored since there is a constant color value.

          DestBits := GetBitmapBitsFromDeviceContext(Destination, DestWidth, DestHeight);

          if Assigned(DestBits) then

          begin

            for Y := 0 to R.Bottom - R.Top - 1 do

            begin

              TargetRun := CalculateScanline(DestBits, DestWidth, DestHeight, Y + R.Top);

              Inc(TargetRun, 4 * R.Left);

              AlphaBlendLineMasterAndColor(TargetRun, R.Right - R.Left, ConstantAlpha, Bias);

            end;

          end;

          EMMS;

        end;

    end;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



function GetRGBColor(Value: TColor): DWORD;



// Little helper to convert a Delphi color to an image list color.



begin

  Result := ColorToRGB(Value);

  case Result of

    clNone:

      Result := CLR_NONE;

    clDefault:

      Result := CLR_DEFAULT;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



const

  Grays: array[0..3] of TColor = (clWhite, clSilver, clGray, clBlack);

  SysGrays: array[0..3] of TColor = (clWindow, clBtnFace, clBtnShadow, clBtnText);



procedure ConvertImageList(IL: TImageList; const ImageName: string; ColorRemapping: Boolean = True);



// Loads a bunch of images given by ImageName into IL. If ColorRemapping = True then a mapping of gray values to

// system colors is performed.



var

  Images,

  OneImage: TBitmap;

  I: Integer;

  MaskColor: TColor;

  Source,

  Dest: TRect;



begin

  Watcher.Enter;

  try

    // Since we want the image list appearing in the correct system colors, we have to remap its colors.

    Images := TBitmap.Create;

    OneImage := TBitmap.Create;

    if ColorRemapping then

      Images.Handle := CreateMappedRes(FindClassHInstance(TBaseVirtualTree), PChar(ImageName), Grays, SysGrays)

    else

      Images.Handle := LoadBitmap(FindClassHInstance(TBaseVirtualTree), PChar(ImageName));



    try

      Assert(Images.Height > 0, 'Internal image "' + ImageName + '" is missing or corrupt.');

      if Images.Height = 0 then

        Exit;// This should never happen, it prevents a division by zero exception below in the for loop, which we have seen in a few cases

      // It is assumed that the image height determines also the width of one entry in the image list.

      IL.Clear;

      IL.Height := Images.Height;

      IL.Width := Images.Height;

      OneImage.Width := IL.Width;

      OneImage.Height := IL.Height;

      MaskColor := Images.Canvas.Pixels[0, 0]; // this is usually clFuchsia

      Dest := Rect(0, 0, IL.Width, IL.Height);

      for I := 0 to (Images.Width div Images.Height) - 1 do

      begin

        Source := Rect(I * IL.Width, 0, (I + 1) * IL.Width, IL.Height);

        OneImage.Canvas.CopyRect(Dest, Images.Canvas, Source);

        IL.AddMasked(OneImage, MaskColor);

      end;

    finally

      Images.Free;

      OneImage.Free;

    end;

  finally

    Watcher.Leave;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure CreateSystemImageSet(var IL: TImageList; Flags: Cardinal; Flat: Boolean);



// Creates a system check image set.

// Note: the DarkCheckImages and FlatImages image lists must already be filled, as some images from them are copied here.



const

  MaskColor: TColor = clRed;



var

  BM: TBitmap;



  //--------------- local functions -------------------------------------------



  procedure AddNodeImages(IL: TImageList);



  var

    I: Integer;

    OffsetX,

    OffsetY: Integer;



  begin

    // The offsets are used to center the node images in case the sizes differ.

    OffsetX := (IL.Width - DarkCheckImages.Width) div 2;

    OffsetY := (IL.Height - DarkCheckImages.Height) div 2;

    for I := 21 to 24 do

    begin

      BM.Canvas.FillRect(Rect(0, 0, BM.Width, BM.Height));

      if Flat then

        FlatImages.Draw(BM.Canvas, OffsetX, OffsetY, I)

      else

        DarkCheckImages.Draw(BM.Canvas, OffsetX, OffsetY, I);

      IL.AddMasked(BM, MaskColor);

    end;

  end;



  //---------------------------------------------------------------------------



  procedure AddSystemImage(IL: TImageList; Index: Integer);



  var

    ButtonState: Cardinal;

    ButtonType: Cardinal;



  begin

    BM.Canvas.FillRect(Rect(0, 0, BM.Width, BM.Height));

    if Index < 8 then

      ButtonType := DFCS_BUTTONRADIO

    else

      ButtonType := DFCS_BUTTONCHECK;

    if Index >= 16 then

      ButtonType := ButtonType or DFCS_BUTTON3STATE;



    case Index mod 4 of

      0:

        ButtonState := 0;

      1:

        ButtonState := DFCS_HOT;

      2:

        ButtonState := DFCS_PUSHED;

      else

        ButtonState := DFCS_INACTIVE;

    end;

    if Index in [4..7, 12..19] then

      ButtonState := ButtonState or DFCS_CHECKED;

    if Flat then

      ButtonState := ButtonState or DFCS_FLAT;

    DrawFrameControl(BM.Canvas.Handle, Rect(1, 2, BM.Width - 2, BM.Height - 1), DFC_BUTTON, ButtonType or ButtonState);

    IL.AddMasked(BM, MaskColor);

  end;



  //--------------- end local functions ---------------------------------------



var

  I, Width, Height: Integer;



begin

  Width := GetSystemMetrics(SM_CXMENUCHECK) + 3;

  Height := GetSystemMetrics(SM_CYMENUCHECK) + 3;

  IL := TImageList.CreateSize(Width, Height);

  with IL do

    Handle := ImageList_Create(Width, Height, Flags, 0, AllocBy);

  IL.Masked := True;

  IL.BkColor := clWhite;



  // Create a temporary bitmap, which holds the intermediate images.

  BM := TBitmap.Create;

  try

    // Make the bitmap the same size as the image list is to avoid problems when adding.

    BM.Width := IL.Width;

    BM.Height := IL.Height;

    BM.Canvas.Brush.Color := MaskColor;

    BM.Canvas.Brush.Style := bsSolid;

    BM.Canvas.FillRect(Rect(0, 0, BM.Width, BM.Height));

    IL.AddMasked(BM, MaskColor);



    // Add the 20 system checkbox and radiobutton images.

    for I := 0 to 19 do

      AddSystemImage(IL, I);

    // Add the 4 node images from the dark check set.

    AddNodeImages(IL);



  finally

    BM.Free;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



function HasMMX: Boolean;



// Helper method to determine whether the current processor supports MMX.



{$ifdef CPUX64}

begin

  // We use SSE2 in the "MMX-functions"

  Result := True;

end;

{$else}

asm

        PUSH    EBX

        XOR     EAX, EAX     // Result := False

        PUSHFD               // determine if the processor supports the CPUID command

        POP     EDX

        MOV     ECX, EDX

        XOR     EDX, $200000

        PUSH    EDX

        POPFD

        PUSHFD

        POP     EDX

        XOR     ECX, EDX

        JZ      @1           // no CPUID support so we can't even get to the feature information

        PUSH    EDX

        POPFD



        MOV     EAX, 1

        DW      $A20F        // CPUID, EAX contains now version info and EDX feature information

        MOV     EBX, EAX     // free EAX to get the result value

        XOR     EAX, EAX     // Result := False

        CMP     EBX, $50

        JB      @1           // if processor family is < 5 then it is not a Pentium class processor

        TEST    EDX, $800000

        JZ      @1           // if the MMX bit is not set then we don't have MMX

        INC     EAX          // Result := True

@1:

        POP     EBX

end;

{$endif CPUX64}



//----------------------------------------------------------------------------------------------------------------------



procedure PrtStretchDrawDIB(Canvas: TCanvas; DestRect: TRect; ABitmap: TBitmap);



// Stretch draw on to the new canvas.



var

  Header,

  Bits: Pointer;

  HeaderSize,

  BitsSize: Cardinal;



begin

  GetDIBSizes(ABitmap.Handle, HeaderSize, BitsSize);



  GetMem(Header, HeaderSize);

  GetMem(Bits, BitsSize);

  try

    GetDIB(ABitmap.Handle, ABitmap.Palette, Header^, Bits^);

    StretchDIBits(Canvas.Handle, DestRect.Left, DestRect.Top, DestRect.Right - DestRect.Left, DestRect.Bottom -

      DestRect.Top, 0, 0, ABitmap.Width, ABitmap.Height, Bits, TBitmapInfo(Header^), DIB_RGB_COLORS, SRCCOPY);

  finally

    FreeMem(Header);

    FreeMem(Bits);

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure ClipCanvas(Canvas: TCanvas; ClipRect: TRect; VisibleRegion: HRGN = 0);



// Clip a given canvas to ClipRect while transforming the given rect to device coordinates.



var

  ClipRegion: HRGN;



begin

  // Regions expect their coordinates in device coordinates, hence we have to transform the region rectangle.

  LPtoDP(Canvas.Handle, ClipRect, 2);

  ClipRegion := CreateRectRgnIndirect(ClipRect);

  if VisibleRegion <> 0 then

    CombineRgn(ClipRegion, ClipRegion, VisibleRegion, RGN_AND);

  SelectClipRgn(Canvas.Handle, ClipRegion);

  DeleteObject(ClipRegion);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure SetCanvasOrigin(Canvas: TCanvas; X, Y: Integer);



// Set the coordinate space origin of a given canvas.



var

  P: TPoint;



begin

  // Reset origin as otherwise we would accumulate the origin shifts when calling LPtoDP.

  SetWindowOrgEx(Canvas.Handle, 0, 0, nil);



  // The shifting is expected in physical points, so we have to transform them accordingly.

  P := Point(X, Y);

  LPtoDP(Canvas.Handle, P, 1);



  // Do the shift.

  SetWindowOrgEx(Canvas.Handle, P.X, P.Y, nil);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure SetBrushOrigin(Canvas: TCanvas; X, Y: Integer);



// Set the brush origin of a given canvas.



var

  P: TPoint;



begin

  P := Point(X, Y);

  LPtoDP(Canvas.Handle, P, 1);

  SetBrushOrgEx(Canvas.Handle, P.X, P.Y, nil);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure InitializeGlobalStructures;



// initialization of stuff global to the unit



var

  Flags: Cardinal;



begin

  Initialized := True;



  // For the drag image a fast MMX blend routine is used. We have to make sure MMX is available.

  MMXAvailable := HasMMX;

  IsWinVistaOrAbove := (Win32MajorVersion >= 6);



  // Initialize OLE subsystem for drag'n drop and clipboard operations.

  NeedToUnitialize := not IsLibrary and Succeeded(OleInitialize(nil));



  // Register the tree reference clipboard format. Others will be handled in InternalClipboarFormats.

  CF_VTREFERENCE := RegisterClipboardFormat(CFSTR_VTREFERENCE);



  // Load all internal image lists and convert their colors to current desktop color scheme.

  // In order to use high color images we have to create the image list handle ourselves.

  Flags := ILC_COLOR32 or ILC_MASK;

  LightCheckImages := TImageList.Create(nil);

  with LightCheckImages do

    Handle := ImageList_Create(16, 16, Flags, 0, AllocBy);

  ConvertImageList(LightCheckImages, 'VT_CHECK_LIGHT');



  DarkCheckImages := TImageList.CreateSize(16, 16);

  with DarkCheckImages do

    Handle := ImageList_Create(16, 16, Flags, 0, AllocBy);

  ConvertImageList(DarkCheckImages, 'VT_CHECK_DARK');



  LightTickImages := TImageList.CreateSize(16, 16);

  with LightTickImages do

    Handle := ImageList_Create(16, 16, Flags, 0, AllocBy);

  ConvertImageList(LightTickImages, 'VT_TICK_LIGHT');



  DarkTickImages := TImageList.CreateSize(16, 16);

  with DarkTickImages do

    Handle := ImageList_Create(16, 16, Flags, 0, AllocBy);

  ConvertImageList(DarkTickImages, 'VT_TICK_DARK');



  FlatImages := TImageList.CreateSize(16, 16);

  with FlatImages do

    Handle := ImageList_Create(16, 16, Flags, 0, AllocBy);

  ConvertImageList(FlatImages, 'VT_FLAT');



  XPImages := TImageList.CreateSize(16, 16);

  with XPImages do

    Handle := ImageList_Create(16, 16, Flags, 0, AllocBy);

  ConvertImageList(XPImages, 'VT_XP', False);



  UtilityImages := TImageList.CreateSize(UtilityImageSize, UtilityImageSize);

  with UtilityImages do

    Handle := ImageList_Create(UtilityImageSize, UtilityImageSize, Flags, 0, AllocBy);

  ConvertImageList(UtilityImages, 'VT_UTILITIES');



  CreateSystemImageSet(SystemCheckImages, Flags, False);

  CreateSystemImageSet(SystemFlatCheckImages, Flags, True);



  // Delphi (at least version 6 and lower) does not provide a standard split cursor.

  // Hence we have to load our own.

  Screen.Cursors[crHeaderSplit] := LoadCursor(HInstance, 'VT_HEADERSPLIT');

  Screen.Cursors[crVertSplit] := LoadCursor(HInstance, 'VT_VERTSPLIT');



  // Clipboard format registration.

  // Native clipboard format. Needs a new identifier and has an average priority to allow other formats to take over.

  // This format is supposed to use the IStream storage format but unfortunately this does not work when

  // OLEFlushClipboard is used. Hence it is disabled until somebody finds a solution.

  CF_VIRTUALTREE := RegisterVTClipboardFormat(CFSTR_VIRTUALTREE, TBaseVirtualTree, 50, TYMED_HGLOBAL {or TYMED_ISTREAM});

  // Specialized string tree formats.

  CF_HTML := RegisterVTClipboardFormat(CFSTR_HTML, TCustomVirtualStringTree, 80);

  CF_VRTFNOOBJS := RegisterVTClipboardFormat(CFSTR_RTFNOOBJS, TCustomVirtualStringTree, 84);

  CF_VRTF := RegisterVTClipboardFormat(CFSTR_RTF, TCustomVirtualStringTree, 85);

  CF_CSV := RegisterVTClipboardFormat(CFSTR_CSV, TCustomVirtualStringTree, 90);

  // Predefined clipboard formats. Just add them to the internal list.

  RegisterVTClipboardFormat(CF_TEXT, TCustomVirtualStringTree, 100);

  RegisterVTClipboardFormat(CF_UNICODETEXT, TCustomVirtualStringTree, 95);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure FinalizeGlobalStructures;



var

  HintWasEnabled: Boolean;



begin

  LightCheckImages.Free;

  LightCheckImages := nil;

  DarkCheckImages.Free;

  DarkCheckImages := nil;

  LightTickImages.Free;

  LightTickImages := nil;

  DarkTickImages.Free;

  DarkTickImages := nil;

  FlatImages.Free;

  FlatImages := nil;

  XPImages.Free;

  XPImages := nil;

  UtilityImages.Free;

  UtilityImages := nil;

  SystemCheckImages.Free;

  SystemCheckImages := nil;

  SystemFlatCheckImages.Free;

  SystemFlatCheckImages := nil;



  if NeedToUnitialize then

    OleUninitialize;



  // If VT is used in a package and its special hint window was used then the last instance of this

  // window is not freed correctly (bug in the VCL). We explicitely tell the application to free it

  // otherwise an AV is raised due to access to an invalid memory area.

  if ModuleIsPackage then

  begin

    HintWasEnabled := Application.ShowHint;

    Application.ShowHint := False;

    if HintWasEnabled then

      Application.ShowHint := True;

  end;

end;



//----------------- TCriticalSection -----------------------------------------------------------------------------------



constructor TCriticalSection.Create;



begin

  inherited Create;

  InitializeCriticalSection(FSection);

end;



//----------------------------------------------------------------------------------------------------------------------



destructor TCriticalSection.Destroy;



begin

  DeleteCriticalSection(FSection);



  inherited Destroy;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TCriticalSection.Enter;



begin

  EnterCriticalSection(FSection);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TCriticalSection.Leave;



begin

  LeaveCriticalSection(FSection);

end;



//----------------- TWorkerThread --------------------------------------------------------------------------------------



procedure AddThreadReference;

begin

  if not Assigned(WorkerThread) then

  begin

    // Create an event used to trigger our worker thread when something is to do.

    WorkEvent := CreateEvent(nil, False, False, nil);

    if WorkEvent = 0 then

      RaiseLastOSError;



    // Create worker thread, initialize it and send it to its wait loop.

    WorkerThread := TWorkerThread.Create(False);

  end;

  Inc(WorkerThread.FRefCount);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure ReleaseThreadReference(Tree: TBaseVirtualTree);



begin

  if Assigned(WorkerThread) then

  begin

    Dec(WorkerThread.FRefCount);



    // Make sure there is no reference remaining to the releasing tree.

    Tree.InterruptValidation;



    if WorkerThread.FRefCount = 0 then

    begin

      with WorkerThread do

      begin

        Terminate;

        SetEvent(WorkEvent);

      end;

      FreeAndNil(WorkerThread);

      CloseHandle(WorkEvent);

    end;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



constructor TWorkerThread.Create(CreateSuspended: Boolean);



begin

  inherited Create(CreateSuspended);

  FWaiterList := TThreadList.Create;

end;



//----------------------------------------------------------------------------------------------------------------------



destructor TWorkerThread.Destroy;



begin

  // First let the ancestor stop the thread before freeing our resources.

  inherited;



  FWaiterList.Free;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TWorkerThread.CancelValidation(Tree: TBaseVirtualTree);



var

  Msg: TMsg;



begin

  // Wait for any references to this tree to be released.

  // Pump WM_CHANGESTATE messages so the thread doesn't block on SendMessage calls.

  while FCurrentTree = Tree do

  begin

    if Tree.HandleAllocated and PeekMessage(Msg, Tree.Handle, WM_CHANGESTATE, WM_CHANGESTATE, PM_REMOVE) then

    begin

      TranslateMessage(Msg);

      DispatchMessage(Msg);

      Continue;

    end;

    if (toVariableNodeHeight in Tree.TreeOptions.MiscOptions) then

      CheckSynchronize(); // We need to call CheckSynchronize here because we are using TThread.Synchronize in TBaseVirtualTree.MeasureItemHeight()

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TWorkerThread.Execute;



// Does some background tasks, like validating tree caches.



var

  EnterStates,

  LeaveStates: TChangeStates;

  lCurrentTree: TBaseVirtualTree;



begin

  {$if CompilerVersion >= 21} TThread.NameThreadForDebugging('VirtualTrees.TWorkerThread');{$ifend}

  while not Terminated do

  begin

    WaitForSingleObject(WorkEvent, INFINITE);

    if not Terminated then

    begin

      // Get the next waiting tree.

      with FWaiterList.LockList do

      try

        if Count > 0 then

        begin

          FCurrentTree := Items[0];

          // Remove this tree from waiter list.

          Delete(0);

          // If there is yet another tree to work on then set the work event to keep looping.

          if Count > 0 then

            SetEvent(WorkEvent);

        end

        else

          FCurrentTree := nil;

      finally

        FWaiterList.UnlockList;

      end;



      // Something to do?

      if Assigned(FCurrentTree) then

      begin

        try

          FCurrentTree.ChangeTreeStatesAsync([csValidating], [csUseCache, csValidationNeeded]);

          EnterStates := [];

          if not (tsStopValidation in FCurrentTree.FStates) and FCurrentTree.DoValidateCache then

            EnterStates := [csUseCache];



        finally

          LeaveStates := [csValidating, csStopValidation];

          FCurrentTree.ChangeTreeStatesAsync(EnterStates, LeaveStates);

          lCurrentTree := FCurrentTree; // Save reference in a local variable for later use

          FCurrentTree := nil; //Clear variable to prevent deadlock in CancelValidation. See #434

          {$if CompilerVersion < 20}Synchronize{$else}Queue{$ifend}(lCurrentTree.UpdateEditBounds);

        end;

      end;

    end;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TWorkerThread.AddTree(Tree: TBaseVirtualTree);



begin

  Assert(Assigned(Tree), 'Tree must not be nil.');



  // Remove validation stop flag, just in case it is still set.

  Tree.DoStateChange([], [tsStopValidation]);

  with FWaiterList.LockList do

  try

    if IndexOf(Tree) = -1 then

      Add(Tree);

  finally

    FWaiterList.UnlockList;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TWorkerThread.RemoveTree(Tree: TBaseVirtualTree);



begin

  Assert(Assigned(Tree), 'Tree must not be nil.');



  with FWaiterList.LockList do

  try

    Remove(Tree);

  finally

    FWaiterList.UnlockList; // Seen several AVs in this line, was called from TWorkerThrea.Destroy. Joachim Marder.

  end;

  CancelValidation(Tree);

end;



//----------------- TBufferedAnsiString ------------------------------------------------------------------------------------



const

  AllocIncrement = 2 shl 11;  // Must be a power of 2.



destructor TBufferedAnsiString.Destroy;



begin

  FreeMem(FStart);

  inherited;

end;



//----------------------------------------------------------------------------------------------------------------------



function TBufferedAnsiString.GetAsString: RawByteString;



begin

  SetString(Result, FStart, FPosition - FStart);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBufferedAnsiString.Add(const S: RawByteString);



var

  NewLen,

  LastOffset,

  Len: NativeInt;



begin

  Len := Length(S);

  // Make room for the new string.

  if FEnd - FPosition <= Len then

  begin

    // Round up NewLen so it is always a multiple of AllocIncrement.

    NewLen := FEnd - FStart + (Len + AllocIncrement - 1) and not (AllocIncrement - 1);

    // Keep last offset to restore it correctly in the case that FStart gets a new memory block assigned.

    LastOffset := FPosition - FStart;

    ReallocMem(FStart, NewLen);

    FPosition := FStart + LastOffset;

    FEnd := FStart + NewLen;

  end;

  Move(PAnsiChar(S)^, FPosition^, Len);

  Inc(FPosition, Len);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBufferedAnsiString.AddNewLine;



var

  NewLen,

  LastOffset: NativeInt;



begin

  // Make room for the CR/LF characters.

  if FEnd - FPosition <= 2 then

  begin

    // Round up NewLen so it is always a multiple of AllocIncrement.

    NewLen := FEnd - FStart + (2 + AllocIncrement - 1) and not (AllocIncrement - 1);

    // Keep last offset to restore it correctly in the case that FStart gets a new memory block assigned.

    LastOffset := FPosition - FStart;

    ReallocMem(FStart, NewLen);

    FPosition := FStart + LastOffset;

    FEnd := FStart + NewLen;

  end;

  FPosition^ := #13;

  Inc(FPosition);

  FPosition^ := #10;

  Inc(FPosition);

end;



//----------------- TWideBufferedString --------------------------------------------------------------------------------



destructor TWideBufferedString.Destroy;



begin

  FreeMem(FStart);

  inherited;

end;



//----------------------------------------------------------------------------------------------------------------------



function TWideBufferedString.GetAsString: UnicodeString;



begin

  SetString(Result, FStart, FPosition - FStart);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TWideBufferedString.Add(const S: UnicodeString);



var

  NewLen,

  LastOffset,

  Len: Integer;



begin

  Len := Length(S);

  // Make room for the new string.

  if FEnd - FPosition <= Len then

  begin

    // Round up NewLen so it is always a multiple of AllocIncrement.

    NewLen := FEnd - FStart + (Len + AllocIncrement - 1) and not (AllocIncrement - 1);

    // Keep last offset to restore it correctly in the case that FStart gets a new memory block assigned.

    LastOffset := FPosition - FStart;

    ReallocMem(FStart, 2 * NewLen);

    FPosition := FStart + LastOffset;

    FEnd := FStart + NewLen;

  end;

  Move(PWideChar(S)^, FPosition^, 2 * Len);

  Inc(FPosition, Len);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TWideBufferedString.AddNewLine;



var

  NewLen,

  LastOffset: Integer;



begin

  // Make room for the CR/LF characters.

  if FEnd - FPosition <= 4 then

  begin

    // Round up NewLen so it is always a multiple of AllocIncrement.

    NewLen := FEnd - FStart + (2 + AllocIncrement - 1) and not (AllocIncrement - 1);

    // Keep last offset to restore it correctly in the case that FStart gets a new memory block assigned.

    LastOffset := FPosition - FStart;

    ReallocMem(FStart, 2 * NewLen);

    FPosition := FStart + LastOffset;

    FEnd := FStart + NewLen;

  end;

  FPosition^ := #13;

  Inc(FPosition);

  FPosition^ := #10;

  Inc(FPosition);

end;



//----------------- TCustomVirtualTreeOptions --------------------------------------------------------------------------



constructor TCustomVirtualTreeOptions.Create(AOwner: TBaseVirtualTree);



begin

  FOwner := AOwner;



  FPaintOptions := DefaultPaintOptions;

  FAnimationOptions := DefaultAnimationOptions;

  FAutoOptions := DefaultAutoOptions;

  FSelectionOptions := DefaultSelectionOptions;

  FMiscOptions := DefaultMiscOptions;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TCustomVirtualTreeOptions.SetAnimationOptions(const Value: TVTAnimationOptions);



begin

  FAnimationOptions := Value;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TCustomVirtualTreeOptions.SetAutoOptions(const Value: TVTAutoOptions);



var

  ChangedOptions: TVTAutoOptions;



begin

  if FAutoOptions <> Value then

  begin

    // Exclusive ORing to get all entries wich are in either set but not in both.

    ChangedOptions := FAutoOptions + Value - (FAutoOptions * Value);

    FAutoOptions := Value;

    with FOwner do

      if (toAutoSpanColumns in ChangedOptions) and not (csLoading in ComponentState) and HandleAllocated then

        Invalidate;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TCustomVirtualTreeOptions.SetMiscOptions(const Value: TVTMiscOptions);



var

  ToBeSet,

  ToBeCleared: TVTMiscOptions;



begin

  if FMiscOptions <> Value then

  begin

    ToBeSet := Value - FMiscOptions;

    ToBeCleared := FMiscOptions - Value;

    FMiscOptions := Value;



    with FOwner do

      if not (csLoading in ComponentState) and HandleAllocated then

      begin

        if toCheckSupport in ToBeSet + ToBeCleared then

          Invalidate;

        if not (csDesigning in ComponentState) then

        begin

          if toFullRepaintOnResize in ToBeSet + ToBeCleared then

            RecreateWnd;

          if toAcceptOLEDrop in ToBeSet then

            RegisterDragDrop(Handle, DragManager as IDropTarget);

          if toAcceptOLEDrop in ToBeCleared then

            RevokeDragDrop(Handle);

        end;

      end;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TCustomVirtualTreeOptions.SetPaintOptions(const Value: TVTPaintOptions);



var

  ToBeSet,

  ToBeCleared: TVTPaintOptions;

  Run: PVirtualNode;

  HandleWasAllocated: Boolean;



begin

  if FPaintOptions <> Value then

  begin

    ToBeSet := Value - FPaintOptions;

    ToBeCleared := FPaintOptions - Value;

    FPaintOptions := Value;

    if (toFixedIndent in ToBeSet) then

    begin

      // Fixes issue #388

      Include(FPaintOptions, toShowRoot);

      Include(ToBeSet, toShowRoot);

    end;//if

    with FOwner do

    begin

      HandleWasAllocated := HandleAllocated;



      if not (csLoading in ComponentState) and (toShowFilteredNodes in ToBeSet + ToBeCleared) then

      begin

        if HandleWasAllocated then

          BeginUpdate;

        InterruptValidation;

        Run := GetFirstNoInit;

        while Assigned(Run) do

        begin

          if (vsFiltered in Run.States) then

          begin

            if FullyVisible[Run] then

            begin

              if toShowFilteredNodes in ToBeSet then

                Inc(FVisibleCount)

              else

                Dec(FVisibleCount);

            end;

            if toShowFilteredNodes in ToBeSet then

              AdjustTotalHeight(Run, Run.NodeHeight, True)

            else

              AdjustTotalHeight(Run, -Run.NodeHeight, True);

          end;

          Run := GetNextNoInit(Run);

        end;

        if HandleWasAllocated then

          EndUpdate;

      end;



      if HandleAllocated then

      begin

        if IsWinVistaOrAbove and ((tsUseThemes in FStates) or

           ((toThemeAware in ToBeSet) and StyleServices.Enabled)) and

           (toUseExplorerTheme in (ToBeSet + ToBeCleared)) and not VclStyleEnabled then

          if (toUseExplorerTheme in ToBeSet) then

          begin

            SetWindowTheme('explorer');

            DoStateChange([tsUseExplorerTheme]);

          end

          else

            if toUseExplorerTheme in ToBeCleared then

            begin

              SetWindowTheme('');

              DoStateChange([], [tsUseExplorerTheme]);

            end;



        if not (csLoading in ComponentState) then

        begin

          if ((toThemeAware in ToBeSet + ToBeCleared) or (toUseExplorerTheme in ToBeSet + ToBeCleared) or VclStyleEnabled) then

          begin

            if ((toThemeAware in ToBeSet) and StyleServices.Enabled) or VclStyleEnabled then

              DoStateChange([tsUseThemes])

            else

              if (toThemeAware in ToBeCleared) then

              DoStateChange([], [tsUseThemes]);



            PrepareBitmaps(True, False);

            RedrawWindow(Handle, nil, 0, RDW_INVALIDATE or RDW_VALIDATE or RDW_FRAME);

          end;



          if toChildrenAbove in ToBeSet + ToBeCleared then

          begin

            InvalidateCache;

            if FUpdateCount = 0 then

            begin

              ValidateCache;

              Invalidate;

            end;

          end;



          Invalidate;

        end;

      end;

    end;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TCustomVirtualTreeOptions.SetSelectionOptions(const Value: TVTSelectionOptions);



var

  ToBeSet,

  ToBeCleared: TVTSelectionOptions;



begin

  if FSelectionOptions <> Value then

  begin

    ToBeSet := Value - FSelectionOptions;

    ToBeCleared := FSelectionOptions - Value;

    FSelectionOptions := Value;



    with FOwner do

    begin

      if (toMultiSelect in (ToBeCleared + ToBeSet)) or

        ([toLevelSelectConstraint, toSiblingSelectConstraint] * ToBeSet <> []) then

        ClearSelection;



      if (toExtendedFocus in ToBeCleared) and (FFocusedColumn > 0) and HandleAllocated then

      begin

        FFocusedColumn := FHeader.MainColumn;

        Invalidate;

      end;



      if not (toExtendedFocus in FSelectionOptions) then

        FFocusedColumn := FHeader.MainColumn;

    end;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TCustomVirtualTreeOptions.AssignTo(Dest: TPersistent);



begin

  if Dest is TCustomVirtualTreeOptions then

  begin

    with Dest as TCustomVirtualTreeOptions do

    begin

      PaintOptions := Self.PaintOptions;

      AnimationOptions := Self.AnimationOptions;

      AutoOptions := Self.AutoOptions;

      SelectionOptions := Self.SelectionOptions;

      MiscOptions := Self.MiscOptions;

    end;

  end

  else

    inherited;

end;



//----------------------------------------------------------------------------------------------------------------------



// OLE drag and drop support classes

// This is quite heavy stuff (compared with the VCL implementation) but is much better suited to fit the needs

// of DD'ing various kinds of virtual data and works also between applications.



//----------------- TEnumFormatEtc -------------------------------------------------------------------------------------



constructor TEnumFormatEtc.Create(Tree: TBaseVirtualTree; AFormatEtcArray: TFormatEtcArray);



var

  I: Integer;



begin

  inherited Create;



  FTree := Tree;

  // Make a local copy of the format data.

  SetLength(FFormatEtcArray, Length(AFormatEtcArray));

  for I := 0 to High(AFormatEtcArray) do

    FFormatEtcArray[I] := AFormatEtcArray[I];

end;



//----------------------------------------------------------------------------------------------------------------------



function TEnumFormatEtc.Clone(out Enum: IEnumFormatEtc): HResult;



var

  AClone: TEnumFormatEtc;



begin

  Result := S_OK;

  try

    AClone := TEnumFormatEtc.Create(nil, FFormatEtcArray);

    AClone.FCurrentIndex := FCurrentIndex;

    Enum := AClone as IEnumFormatEtc;

  except

    Result := E_FAIL;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



function TEnumFormatEtc.Next(celt: Integer; out elt; pceltFetched: PLongint): HResult;



var

  CopyCount: Integer;



begin

  Result := S_FALSE;

  CopyCount := Length(FFormatEtcArray) - FCurrentIndex;

  if celt < CopyCount then

    CopyCount := celt;

  if CopyCount > 0 then

  begin

    Move(FFormatEtcArray[FCurrentIndex], elt, CopyCount * SizeOf(TFormatEtc));

    Inc(FCurrentIndex, CopyCount);

    Result := S_OK;

  end;

  if Assigned(pceltFetched) then

    pceltFetched^ := CopyCount;

end;



//----------------------------------------------------------------------------------------------------------------------



function TEnumFormatEtc.Reset: HResult;



begin

  FCurrentIndex := 0;

  Result := S_OK;

end;



//----------------------------------------------------------------------------------------------------------------------



function TEnumFormatEtc.Skip(celt: Integer): HResult;



begin

  if FCurrentIndex + celt < High(FFormatEtcArray) then

  begin

    Inc(FCurrentIndex, celt);

    Result := S_Ok;

  end

  else

    Result := S_FALSE;

end;



//----------------- TVTDataObject --------------------------------------------------------------------------------------



constructor TVTDataObject.Create(AOwner: TBaseVirtualTree; ForClipboard: Boolean);



begin

  inherited Create;



  FOwner := AOwner;

  FForClipboard := ForClipboard;

  FOwner.GetNativeClipboardFormats(FFormatEtcArray);

end;



//----------------------------------------------------------------------------------------------------------------------



destructor TVTDataObject.Destroy;



var

  I: Integer;

  StgMedium: PStgMedium;



begin

  // Cancel a pending clipboard operation if this data object was created for the clipboard and

  // is freed because something else is placed there.

  if FForClipboard and not (tsClipboardFlushing in FOwner.FStates) then

    FOwner.CancelCutOrCopy;



  // Release any internal clipboard formats

  for I := 0 to High(FormatEtcArray) do

  begin

    StgMedium := FindInternalStgMedium(FormatEtcArray[I].cfFormat);

    if Assigned(StgMedium) then

      ReleaseStgMedium(StgMedium^);

  end;



  FormatEtcArray := nil;

  inherited;

end;



//----------------------------------------------------------------------------------------------------------------------



function TVTDataObject.CanonicalIUnknown(TestUnknown: IUnknown): IUnknown;



// Uses COM object identity: An explicit call to the IUnknown::QueryInterface method, requesting the IUnknown

// interface, will always return the same pointer.



begin

  if Assigned(TestUnknown) then

  begin

    if TestUnknown.QueryInterface(IUnknown, Result) = 0 then

      Result._Release // Don't actually need it just need the pointer value

    else

      Result := TestUnknown;

  end

  else

    Result := TestUnknown;

end;



//----------------------------------------------------------------------------------------------------------------------



function TVTDataObject.EqualFormatEtc(FormatEtc1, FormatEtc2: TFormatEtc): Boolean;



begin

  Result := (FormatEtc1.cfFormat = FormatEtc2.cfFormat) and (FormatEtc1.ptd = FormatEtc2.ptd) and

    (FormatEtc1.dwAspect = FormatEtc2.dwAspect) and (FormatEtc1.lindex = FormatEtc2.lindex) and

    (FormatEtc1.tymed and FormatEtc2.tymed <> 0);

end;



//----------------------------------------------------------------------------------------------------------------------



function TVTDataObject.FindFormatEtc(TestFormatEtc: TFormatEtc; const FormatEtcArray: TFormatEtcArray): integer;



var

  I: integer;



begin

  Result := -1;

  for I := 0 to High(FormatEtcArray) do

  begin

    if EqualFormatEtc(TestFormatEtc, FormatEtcArray[I]) then

    begin

      Result := I;

      Break;

    end;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



function TVTDataObject.FindInternalStgMedium(Format: TClipFormat): PStgMedium;



var

  I: integer;

begin

  Result := nil;

  for I := 0 to High(InternalStgMediumArray) do

  begin

    if Format = InternalStgMediumArray[I].Format then

    begin

      Result := @InternalStgMediumArray[I].Medium;

      Break;

    end;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



function TVTDataObject.HGlobalClone(HGlobal: THandle): THandle;



// Returns a global memory block that is a copy of the passed memory block.



var

  Size: Cardinal;

  Data,

  NewData: PByte;



begin

  Size := GlobalSize(HGlobal);

  Result := GlobalAlloc(GPTR, Size);

  Data := GlobalLock(hGlobal);

  try

    NewData := GlobalLock(Result);

    try

      Move(Data^, NewData^, Size);

    finally

      GlobalUnLock(Result);

    end;

  finally

    GlobalUnLock(hGlobal);

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



function TVTDataObject.RenderInternalOLEData(const FormatEtcIn: TFormatEtc; var Medium: TStgMedium;

  var OLEResult: HResult): Boolean;



// Tries to render one of the formats which have been stored via the SetData method.

// Since this data is already there it is just copied or its reference count is increased (depending on storage medium).



var

  InternalMedium: PStgMedium;



begin

  Result := True;

  InternalMedium := FindInternalStgMedium(FormatEtcIn.cfFormat);

  if Assigned(InternalMedium) then

    OLEResult := StgMediumIncRef(InternalMedium^, Medium, False, Self as IDataObject)

  else

    Result := False;

end;



//----------------------------------------------------------------------------------------------------------------------



function TVTDataObject.StgMediumIncRef(const InStgMedium: TStgMedium; var OutStgMedium: TStgMedium;

  CopyInMedium: Boolean; DataObject: IDataObject): HRESULT;



// InStgMedium is the data that is requested, OutStgMedium is the data that we are to return either a copy of or

// increase the IDataObject's reference and send ourselves back as the data (unkForRelease). The InStgMedium is usually

// the result of a call to find a particular FormatEtc that has been stored locally through a call to SetData.

// If CopyInMedium is not true we already have a local copy of the data when the SetData function was called (during

// that call the CopyInMedium must be true). Then as the caller asks for the data through GetData we do not have to make

// copy of the data for the caller only to have them destroy it then need us to copy it again if necessary.

// This way we increase the reference count to ourselves and pass the STGMEDIUM structure initially stored in SetData.

// This way when the caller frees the structure it sees the unkForRelease is not nil and calls Release on the object

// instead of destroying the actual data.



var

  Len: Integer;



begin

  Result := S_OK;



  // Simply copy all fields to start with.

  OutStgMedium := InStgMedium;

  // The data handled here always results from a call of SetData we got. This ensures only one storage format

  // is indicated and hence the case statement below is safe (IDataObject.GetData can optionally use several

  // storage formats).

  case InStgMedium.tymed of

    TYMED_HGLOBAL:

      begin

        if CopyInMedium then

        begin

          // Generate a unique copy of the data passed

          OutStgMedium.hGlobal := HGlobalClone(InStgMedium.hGlobal);

          if OutStgMedium.hGlobal = 0 then

            Result := E_OUTOFMEMORY;

        end

        else

          // Don't generate a copy just use ourselves and the copy previously saved.

          OutStgMedium.unkForRelease := Pointer(DataObject); // Does not increase RefCount.

      end;

    TYMED_FILE:

      begin

        Len := lstrLenW(InStgMedium.lpszFileName) + 1; // Don't forget the terminating null character.

        OutStgMedium.lpszFileName := CoTaskMemAlloc(2 * Len);

        Move(InStgMedium.lpszFileName^, OutStgMedium.lpszFileName^, 2 * Len);

      end;

    TYMED_ISTREAM:

      IUnknown(OutStgMedium.stm)._AddRef;

    TYMED_ISTORAGE:

      IUnknown(OutStgMedium.stg)._AddRef;

    TYMED_GDI:

      if not CopyInMedium then

        // Don't generate a copy just use ourselves and the previously saved data.

        OutStgMedium.unkForRelease := Pointer(DataObject) // Does not increase RefCount.

      else

        Result := DV_E_TYMED; // Don't know how to copy GDI objects right now.

    TYMED_MFPICT:

      if not CopyInMedium then

        // Don't generate a copy just use ourselves and the previously saved data.

        OutStgMedium.unkForRelease := Pointer(DataObject) // Does not increase RefCount.

      else

        Result := DV_E_TYMED; // Don't know how to copy MetaFile objects right now.

    TYMED_ENHMF:

      if not CopyInMedium then

        // Don't generate a copy just use ourselves and the previously saved data.

        OutStgMedium.unkForRelease := Pointer(DataObject) // Does not increase RefCount.

      else

        Result := DV_E_TYMED; // Don't know how to copy enhanced metafiles objects right now.

  else

    Result := DV_E_TYMED;

  end;



  if (Result = S_OK) and Assigned(OutStgMedium.unkForRelease) then

    IUnknown(OutStgMedium.unkForRelease)._AddRef;

end;



//----------------------------------------------------------------------------------------------------------------------



function TVTDataObject.DAdvise(const FormatEtc: TFormatEtc; advf: Integer; const advSink: IAdviseSink;

  out dwConnection: Integer): HResult;



// Advise sink management is greatly simplified by the IDataAdviseHolder interface.

// We use this interface and forward all concerning calls to it.



begin

  Result := S_OK;

  if FAdviseHolder = nil then

    Result := CreateDataAdviseHolder(FAdviseHolder);

  if Result = S_OK then

    Result := FAdviseHolder.Advise(Self as IDataObject, FormatEtc, advf, advSink, dwConnection);

end;



//----------------------------------------------------------------------------------------------------------------------



function TVTDataObject.DUnadvise(dwConnection: Integer): HResult;



begin

  if FAdviseHolder = nil then

    Result := E_NOTIMPL

  else

    Result := FAdviseHolder.Unadvise(dwConnection);

end;



//----------------------------------------------------------------------------------------------------------------------



function TVTDataObject.EnumDAdvise(out enumAdvise: IEnumStatData): HResult;



begin

  if FAdviseHolder = nil then

    Result := OLE_E_ADVISENOTSUPPORTED

  else

    Result := FAdviseHolder.EnumAdvise(enumAdvise);

end;



//----------------------------------------------------------------------------------------------------------------------



function TVTDataObject.EnumFormatEtc(Direction: Integer; out EnumFormatEtc: IEnumFormatEtc): HResult;



var

  NewList: TEnumFormatEtc;



begin

  Result := E_FAIL;

  if Direction = DATADIR_GET then

  begin

    NewList := TEnumFormatEtc.Create(FOwner, FormatEtcArray);

    EnumFormatEtc := NewList as IEnumFormatEtc;

    Result := S_OK;

  end

  else

    EnumFormatEtc := nil;

  if EnumFormatEtc = nil then

    Result := OLE_S_USEREG;

end;



//----------------------------------------------------------------------------------------------------------------------



function TVTDataObject.GetCanonicalFormatEtc(const FormatEtc: TFormatEtc; out FormatEtcOut: TFormatEtc): HResult;



begin

  Result := DATA_S_SAMEFORMATETC;

end;



//----------------------------------------------------------------------------------------------------------------------



function TVTDataObject.GetData(const FormatEtcIn: TFormatEtc; out Medium: TStgMedium): HResult;



// Data is requested by clipboard or drop target. This method dispatchs the call

// depending on the data being requested.



var

  I: Integer;

  Data: PVTReference;



begin

  // The tree reference format is always supported and returned from here.

  if FormatEtcIn.cfFormat = CF_VTREFERENCE then

  begin

    // Note: this format is not used while flushing the clipboard to avoid a dangling reference

    //       when the owner tree is destroyed before the clipboard data is replaced with something else.

    if tsClipboardFlushing in FOwner.FStates then

      Result := E_FAIL

    else

    begin

      Medium.hGlobal := GlobalAlloc(GHND or GMEM_SHARE, SizeOf(TVTReference));

      Data := GlobalLock(Medium.hGlobal);

      Data.Process := GetCurrentProcessID;

      Data.Tree := FOwner;

      GlobalUnlock(Medium.hGlobal);

      Medium.tymed := TYMED_HGLOBAL;

      Medium.unkForRelease := nil;

      Result := S_OK;

    end;

  end

  else

  begin

    try

      // See if we accept this type and if not get the correct return value.

      Result := QueryGetData(FormatEtcIn);

      if Result = S_OK then

      begin

        for I := 0 to High(FormatEtcArray) do

        begin

          if EqualFormatEtc(FormatEtcIn, FormatEtcArray[I]) then

          begin

            if not RenderInternalOLEData(FormatEtcIn, Medium, Result) then

              Result := FOwner.RenderOLEData(FormatEtcIn, Medium, FForClipboard);

            Break;

          end;

        end;

      end;

    except

      ZeroMemory (@Medium, SizeOf(Medium));

      Result := E_FAIL;

    end;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



function TVTDataObject.GetDataHere(const FormatEtc: TFormatEtc; out Medium: TStgMedium): HResult;



begin

  Result := E_NOTIMPL;

end;



//----------------------------------------------------------------------------------------------------------------------



function TVTDataObject.QueryGetData(const FormatEtc: TFormatEtc): HResult;



var

  I: Integer;



begin

  Result := DV_E_CLIPFORMAT;

  for I := 0 to High(FFormatEtcArray) do

  begin

    if FormatEtc.cfFormat = FFormatEtcArray[I].cfFormat then

    begin

      if (FormatEtc.tymed and FFormatEtcArray[I].tymed) <> 0 then

      begin

        if FormatEtc.dwAspect = FFormatEtcArray[I].dwAspect then

        begin

          if FormatEtc.lindex = FFormatEtcArray[I].lindex then

          begin

            Result := S_OK;

            Break;

          end

          else

            Result := DV_E_LINDEX;

        end

        else

          Result := DV_E_DVASPECT;

      end

      else

        Result := DV_E_TYMED;

    end;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



function TVTDataObject.SetData(const FormatEtc: TFormatEtc; var Medium: TStgMedium; DoRelease: BOOL): HResult;



// Allows dynamic adding to the IDataObject during its existance. Most noteably it is used to implement

// IDropSourceHelper and allows to set a special format for optimized moves during a shell transfer.



var

  Index: Integer;

  LocalStgMedium: PStgMedium;



begin

  // See if we already have a format of that type available.

  Index := FindFormatEtc(FormatEtc, FormatEtcArray);

  if Index > - 1 then

  begin

    // Just use the TFormatEct in the array after releasing the data.

    LocalStgMedium := FindInternalStgMedium(FormatEtcArray[Index].cfFormat);

    if Assigned(LocalStgMedium) then

    begin

      ReleaseStgMedium(LocalStgMedium^);

      ZeroMemory(LocalStgMedium, SizeOf(LocalStgMedium^));

    end;

  end

  else

  begin

    // It is a new format so create a new TFormatCollectionItem, copy the

    // FormatEtc parameter into the new object and and put it in the list.

    SetLength(FFormatEtcArray, Length(FormatEtcArray) + 1);

    FormatEtcArray[High(FormatEtcArray)] := FormatEtc;



    // Create a new InternalStgMedium and initialize it and associate it with the format.

    SetLength(FInternalStgMediumArray, Length(InternalStgMediumArray) + 1);

    InternalStgMediumArray[High(InternalStgMediumArray)].Format := FormatEtc.cfFormat;

    LocalStgMedium := @InternalStgMediumArray[High(InternalStgMediumArray)].Medium;

    ZeroMemory(LocalStgMedium, SizeOf(LocalStgMedium^));

  end;



  if DoRelease then

  begin

    // We are simply being given the data and we take control of it.

    LocalStgMedium^ := Medium;

    Result := S_OK;

  end

  else

  begin

    // We need to reference count or copy the data and keep our own references to it.

    Result := StgMediumIncRef(Medium, LocalStgMedium^, True, Self as IDataObject);



    // Can get a circular reference if the client calls GetData then calls SetData with the same StgMedium.

    // Because the unkForRelease for the IDataObject can be marshalled it is necessary to get pointers that

    // can be correctly compared. See the IDragSourceHelper article by Raymond Chen at MSDN.

    if Assigned(LocalStgMedium.unkForRelease) then

    begin

      if CanonicalIUnknown(Self) = CanonicalIUnknown(IUnknown(LocalStgMedium.unkForRelease)) then

        IUnknown(LocalStgMedium.unkForRelease) := nil; // release the interface

    end;

  end;



  // Tell all registered advice sinks about the data change.

  if Assigned(FAdviseHolder) then

    FAdviseHolder.SendOnDataChange(Self as IDataObject, 0, 0);

end;



//----------------- TVTDragManager -------------------------------------------------------------------------------------



constructor TVTDragManager.Create(AOwner: TBaseVirtualTree);



begin

  inherited Create;

  FOwner := AOwner;



  // Create an instance  of the drop target helper interface. This will fail but not harm on systems which do

  // not support this interface (everything below Windows 2000);

  CoCreateInstance(CLSID_DragDropHelper, nil, CLSCTX_INPROC_SERVER, IID_IDropTargetHelper, FDropTargetHelper);

end;



//----------------------------------------------------------------------------------------------------------------------



destructor TVTDragManager.Destroy;



begin

  // Set the owner's reference to us to nil otherwise it will access an invalid pointer

  // after our desctruction is complete.

  Pointer(FOwner.FDragManager) := nil;

  inherited;

end;



//----------------------------------------------------------------------------------------------------------------------



function TVTDragManager.GetDataObject: IDataObject;



begin

  // When the owner tree starts a drag operation then it gets a data object here to pass it to the OLE subsystem.

  // In this case there is no local reference to a data object and one is created (but not stored).

  // If there is a local reference then the owner tree is currently the drop target and the stored interface is

  // that of the drag initiator.

  if Assigned(FDataObject) then

    Result := FDataObject

  else

  begin

    Result := FOwner.DoCreateDataObject;

    if Result = nil then

      Result := TVTDataObject.Create(FOwner, False) as IDataObject;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



function TVTDragManager.GetDragSource: TBaseVirtualTree;



begin

  Result := FDragSource;

end;



//----------------------------------------------------------------------------------------------------------------------



function TVTDragManager.GetDropTargetHelperSupported: Boolean;



begin

  Result := Assigned(FDropTargetHelper);

end;



//----------------------------------------------------------------------------------------------------------------------



function TVTDragManager.GetIsDropTarget: Boolean;



begin

  Result := FIsDropTarget;

end;



//----------------------------------------------------------------------------------------------------------------------



function TVTDragManager.DragEnter(const DataObject: IDataObject; KeyState: Integer; Pt: TPoint;

  var Effect: Integer): HResult;



begin

  FDataObject := DataObject;

  FIsDropTarget := True;



  SystemParametersInfo(SPI_GETDRAGFULLWINDOWS, 0, @FFullDragging, 0);

  // If full dragging of window contents is disabled in the system then our tree windows will be locked

  // and cannot be updated during a drag operation. With the following call painting is again enabled.

  if not FFullDragging then

    LockWindowUpdate(0);

  if Assigned(FDropTargetHelper) and FFullDragging then

    FDropTargetHelper.DragEnter(FOwner.Handle, DataObject, Pt, Effect);



  FDragSource := FOwner.GetTreeFromDataObject(DataObject);

  Result := FOwner.DragEnter(KeyState, Pt, Effect);

end;



//----------------------------------------------------------------------------------------------------------------------



function TVTDragManager.DragLeave: HResult;



begin

  if Assigned(FDropTargetHelper) and FFullDragging then

    FDropTargetHelper.DragLeave;



  FOwner.DragLeave;

  FIsDropTarget := False;

  FDragSource := nil;

  FDataObject := nil;

  Result := NOERROR;

end;



//----------------------------------------------------------------------------------------------------------------------



function TVTDragManager.DragOver(KeyState: Integer; Pt: TPoint; var Effect: LongInt): HResult;



begin

  if Assigned(FDropTargetHelper) and FFullDragging then

    FDropTargetHelper.DragOver(Pt, Effect);



  Result := FOwner.DragOver(FDragSource, KeyState, dsDragMove, Pt, Effect);

end;



//----------------------------------------------------------------------------------------------------------------------



function TVTDragManager.Drop(const DataObject: IDataObject; KeyState: Integer; Pt: TPoint;

  var Effect: Integer): HResult;



begin

  if Assigned(FDropTargetHelper) and FFullDragging then

    FDropTargetHelper.Drop(DataObject, Pt, Effect);



  Result := FOwner.DragDrop(DataObject, KeyState, Pt, Effect);

  FIsDropTarget := False;

  FDataObject := nil;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TVTDragManager.ForceDragLeave;



// Some drop targets, e.g. Internet Explorer leave a drag image on screen instead removing it when they receive

// a drop action. This method calls the drop target helper's DragLeave method to ensure it removes the drag image from

// screen. Unfortunately, sometimes not even this does help (e.g. when dragging text from VT to a text field in IE).



begin

  if Assigned(FDropTargetHelper) and FFullDragging then

    FDropTargetHelper.DragLeave;

end;



//----------------------------------------------------------------------------------------------------------------------



function TVTDragManager.GiveFeedback(Effect: Integer): HResult;



begin

  Result := DRAGDROP_S_USEDEFAULTCURSORS;

end;



//----------------------------------------------------------------------------------------------------------------------



function TVTDragManager.QueryContinueDrag(EscapePressed: BOOL; KeyState: Integer): HResult;



var

  RButton,

  LButton: Boolean;



begin

  LButton := (KeyState and MK_LBUTTON) <> 0;

  RButton := (KeyState and MK_RBUTTON) <> 0;



  // Drag'n drop canceled by pressing both mouse buttons or Esc?

  if (LButton and RButton) or EscapePressed then

    Result := DRAGDROP_S_CANCEL

  else

    // Drag'n drop finished?

    if not (LButton or RButton) then

      Result := DRAGDROP_S_DROP

    else

      Result := S_OK;

end;



//----------------- TVirtualTreeHintWindow -----------------------------------------------------------------------------



var

  // This variable is necessary to coordinate the complex interaction between different hints in the application

  // and animated hints in our own class. Under certain conditions it can happen that our hint window is destroyed

  // while it is still in the animation loop.

  FHintWindowDestroyed: Boolean = True;



constructor TVirtualTreeHintWindow.Create(AOwner: TComponent);



begin

  inherited;



  FBackground := TBitmap.Create;

  FBackground.PixelFormat := pf32Bit;

  FDrawBuffer := TBitmap.Create;

  FDrawBuffer.PixelFormat := pf32Bit;

  FTarget := TBitmap.Create;

  FTarget.PixelFormat := pf32Bit;



  DoubleBuffered := False; // we do our own buffering

  FHintWindowDestroyed := False;

end;



//----------------------------------------------------------------------------------------------------------------------



destructor TVirtualTreeHintWindow.Destroy;



begin

  FHintWindowDestroyed := True;



  FTarget.Free;

  FDrawBuffer.Free;

  FBackground.Free;

  inherited;

end;



//----------------------------------------------------------------------------------------------------------------------



function TVirtualTreeHintWindow.AnimationCallback(Step, StepSize: Integer; Data: Pointer): Boolean;



begin

  Result := not FHintWindowDestroyed and HandleAllocated and IsWindowVisible(Handle) and

    Assigned(FHintData.Tree) and not (tsCancelHintAnimation in FHintData.Tree.FStates);

  if Result then

  begin

    InternalPaint(Step, StepSize);

    // We have to allow certain messages to be processed normally for various reasons.

    // This introduces another problem however if this hint window is destroyed

    // while it is still in the animation loop. A global variable keeps track of

    // that case. This is reliable because we can only have one (internal) hint window.

    Application.ProcessMessages;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TVirtualTreeHintWindow.CMTextChanged(var Message: TMessage);



begin

  // swallow this message to prevent the ancestor from resizing the window (we don't use the caption anyway)

end;



//----------------------------------------------------------------------------------------------------------------------



function TVirtualTreeHintWindow.GetHintWindowDestroyed;



// This function exists to inform descendants if the hint window has been destroyed.



begin

  Result := FHintWindowDestroyed;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TVirtualTreeHintWindow.WMEraseBkgnd(var Message: TWMEraseBkgnd);



// The control is fully painted by own code so don't erase its background as this causes flickering.



begin

  Message.Result := 1;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TVirtualTreeHintWindow.WMNCPaint(var Message: TMessage);



// The control is fully painted by own code so don't paint any borders.



begin

  Message.Result := 0;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TVirtualTreeHintWindow.WMShowWindow(var Message: TWMShowWindow);



// Clear hint data when the window becomes hidden.



begin

  if not Message.Show then

  begin

    // Don't touch the last hint rectangle stored in the associated tree to avoid flickering in certain situations.

    Finalize(FHintData);

    ZeroMemory (@FHintData, SizeOf(FHintData));



    // If the hint window destruction flag to stop any hint window animation was set by a tree

    // during its destruction then reset it here to allow other tree instances to still use

    // this hint window.

    FHintWindowDestroyed := False;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TVirtualTreeHintWindow.CreateParams(var Params: TCreateParams);



begin

  inherited CreateParams(Params);



  with Params do

  begin

    Style := WS_POPUP;

    ExStyle := ExStyle and not WS_EX_CLIENTEDGE;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TVirtualTreeHintWindow.InternalPaint(Step, StepSize: Integer);



  //--------------- local functions -------------------------------------------



  procedure DoShadowBlend(DC: HDC; R: TRect; Alpha: Integer);



  // Helper routine for shadow blending to shorten the parameter list in frequent calls.



  begin

    AlphaBlend(0, DC, R, Point(0, 0), bmConstantAlphaAndColor,  Alpha, clBlack);

  end;



  //---------------------------------------------------------------------------



  procedure DrawHintShadow(Canvas: TCanvas; ShadowSize: Integer);



  var

    R: TRect;



  begin

    // Bottom shadow.

    R := Rect(ShadowSize, Height - ShadowSize, Width, Height);

    DoShadowBlend(Canvas.Handle, R, 5);

    Inc(R.Left);

    Dec(R.Right);

    Dec(R.Bottom);

    DoShadowBlend(Canvas.Handle, R, 10);

    Inc(R.Left);

    Dec(R.Right);

    Dec(R.Bottom);

    DoShadowBlend(Canvas.Handle, R, 20);

    Inc(R.Left);

    Dec(R.Right);

    Dec(R.Bottom);

    DoShadowBlend(Canvas.Handle, R, 35);

    Inc(R.Left);

    Dec(R.Right);

    Dec(R.Bottom);

    DoShadowBlend(Canvas.Handle, R, 50);

    // Right shadow.

    R := Rect(Width - ShadowSize, ShadowSize, Width, Height - ShadowSize);

    DoShadowBlend(Canvas.Handle, R, 5);

    Inc(R.Top);

    Dec(R.Right);

    DoShadowBlend(Canvas.Handle, R, 10);

    Inc(R.Top);

    Dec(R.Right);

    DoShadowBlend(Canvas.Handle, R, 20);

    Inc(R.Top);

    Dec(R.Right);

    DoShadowBlend(Canvas.Handle, R, 35);

    Inc(R.Top);

    Dec(R.Right);

    DoShadowBlend(Canvas.Handle, R, 50);

  end;



  //--------------- end local functions ---------------------------------------



var

  R: TRect;

  Y: Integer;

  S: UnicodeString;

  DrawFormat: Cardinal;

  Shadow: Integer;

  HintKind: TVTHintKind;

  LClipRect: TRect;



  {$IF CompilerVersion >= 23 }

  LColor: TColor;

  LDetails: TThemedElementDetails;

  LGradientStart: TColor;

  LGradientEnd: TColor;

  {$IFEND}



begin

  Shadow := 0;



  with FHintData, FDrawBuffer do

  begin

    // Do actual painting only in the very first run.

    if Step = 0 then

    begin

      // If the given node is nil then we have to display a header hint.

      if (Node = nil) or (Tree.FHintMode <> hmToolTip) then

      begin

        Canvas.Font := Screen.HintFont;

        Y := 2;

      end

      else

      begin

        Tree.GetTextInfo(Node, Column, Canvas.Font, R, S);

        if LineBreakStyle = hlbForceMultiLine then

          Y := 1

        else

          Y := (R.Top - R.Bottom - Shadow + Self.Height) div 2;

      end;



      R := Rect(0, 0, Width - Shadow, Height - Shadow);



      HintKind := vhkText;

      if Assigned(Node) then

        Tree.DoGetHintKind(Node, Column, HintKind);



      if HintKind = vhkOwnerDraw then

      begin

        Tree.DoDrawHint(Canvas, Node, R, Column);

      end

      else

        with Canvas do

        begin

          {$IF CompilerVersion >= 23 }

          if Tree.VclStyleEnabled  then

          begin

            LDetails := StyleServices.GetElementDetails(thHintNormal);

            if StyleServices.GetElementColor(LDetails, ecGradientColor1, LColor) and (LColor <> clNone) then

              LGradientStart := LColor

            else

              LGradientStart := clInfoBk;

            if StyleServices.GetElementColor(LDetails, ecGradientColor2, LColor) and (LColor <> clNone) then

              LGradientEnd := LColor

            else

              LGradientEnd := clInfoBk;

            if StyleServices.GetElementColor(LDetails, ecTextColor, LColor) and (LColor <> clNone) then

              Font.Color := LColor

            else

              Font.Color := Screen.HintFont.Color;

            GradientFillCanvas(Canvas, LGradientStart, LGradientEnd, R, gdVertical);

          end

          else

          {$IFEND}

            begin

            // Still force tooltip back and text color.

            Font.Color := clInfoText;

            Pen.Color := clBlack;

            Brush.Color := clInfoBk;

            if IsWinVistaOrAbove and StyleServices.Enabled and ((toThemeAware in Tree.TreeOptions.PaintOptions) or

               (toUseExplorerTheme in Tree.TreeOptions.PaintOptions)) then

            begin

              if toUseExplorerTheme in Tree.TreeOptions.PaintOptions then // ToolTip style

                StyleServices.DrawElement(Canvas.Handle, StyleServices.GetElementDetails(tttStandardNormal), R)

              else

                begin // Hint style

                  LClipRect := R;

                  InflateRect(R, 4, 4);

                  StyleServices.DrawElement(Handle, StyleServices.GetElementDetails(tttStandardNormal), R, @LClipRect);

                  R := LClipRect;

                  StyleServices.DrawEdge(Handle, StyleServices.GetElementDetails(twWindowRoot), R, [eeRaisedOuter], [efRect]);

                end;

            end

            else

              if Tree.VclStyleEnabled then

                StyleServices.DrawElement(Canvas.Handle, StyleServices.GetElementDetails(tttStandardNormal), R)

              else

                Rectangle(R);

          end;

          // Determine text position and don't forget the border.

          InflateRect(R, -1, -1);

          DrawFormat := DT_TOP or DT_NOPREFIX;

          SetBkMode(Handle, Windows.TRANSPARENT);

          R.Top := Y;

          R.Left := R.Left + 3; // Make the text more centered

          if Assigned(Node) and (LineBreakStyle = hlbForceMultiLine) then

            DrawFormat := DrawFormat or DT_WORDBREAK;

          Windows.DrawTextW(Handle, PWideChar(HintText), Length(HintText), R, DrawFormat);

        end;

    end;

  end;





    if StepSize > 0 then

      begin

        if FHintData.Tree.DoGetAnimationType = hatFade then

        begin

          with FTarget do

            BitBlt(Canvas.Handle, 0, 0, Width, Height, FBackground.Canvas.Handle, 0, 0, SRCCOPY);

          // Main image.

          AlphaBlend(FDrawBuffer.Canvas.Handle, FTarget.Canvas.Handle, Rect(0, 0, Width - Shadow, Height - Shadow),

            Point(0, 0), bmConstantAlpha,  MulDiv(Step, 256, FadeAnimationStepCount), 0);



          if Shadow > 0 then

            DrawHintShadow(FTarget.Canvas, Shadow);

          BitBlt(Canvas.Handle, 0, 0, Width, Height, FTarget.Canvas.Handle, 0, 0, SRCCOPY);

        end

        else

        begin

          // Slide is done by blitting "step" lines of the lower part of the hint window

          // and fill the rest with the screen background.



          // 1) blit hint bitmap to the hint canvas

          BitBlt(Canvas.Handle, 0, 0, Width - Shadow, Step, FDrawBuffer.Canvas.Handle, 0, Height - Step, SRCCOPY);

          // 2) blit background rest to hint canvas

          if Step <= Shadow then

            Step := 0

          else

            Dec(Step, Shadow);

          BitBlt(Canvas.Handle, 0, Step, Width, Height - Step, FBackground.Canvas.Handle, 0, Step, SRCCOPY);

        end;

      end

      else

        // Last step during slide or the only step without animation.

        if FHintData.Tree.DoGetAnimationType <> hatFade then

        begin

          if Shadow > 0 then

          begin

            with FBackground do

              BitBlt(Canvas.Handle, 0, 0, Width - Shadow, Height - Shadow, FDrawBuffer.Canvas.Handle, 0, 0, SRCCOPY);



            DrawHintShadow(FBackground.Canvas, Shadow);

            BitBlt(Canvas.Handle, 0, 0, Width, Height, FBackground.Canvas.Handle, 0, 0, SRCCOPY);

          end

          else

            BitBlt(Canvas.Handle, 0, 0, Width, Height, FDrawBuffer.Canvas.Handle, 0, 0, SRCCOPY);

        end;



end;



//----------------------------------------------------------------------------------------------------------------------



procedure TVirtualTreeHintWindow.Paint;



begin

  InternalPaint(0, 0);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TVirtualTreeHintWindow.ActivateHint(Rect: TRect; const AHint: string);



var

  DC: HDC;

  StopLastAnimation: Boolean;

  lCursorPos: TPoint;

begin

  if IsRectEmpty(Rect) or not Assigned(FHintData.Tree) or

     not GetCursorPos(lCursorPos) or not PtInRect(FHintData.Tree.FLastHintRect, FHintData.Tree.ScreenToClient(lCursorPos))

  then

    Application.CancelHint

  else

  begin

    // There is already an animation. Start a new one but do not continue the old one once we are finished here.

    StopLastAnimation := (tsInAnimation in FHintData.Tree.FStates);

    if StopLastAnimation then

      FHintData.Tree.DoStateChange([], [tsInAnimation]);



    SetWindowPos(Handle, 0, Rect.Left, Rect.Top, Width, Height, SWP_HIDEWINDOW or SWP_NOACTIVATE or SWP_NOZORDER);

    UpdateBoundsRect(Rect);



    // Make sure the whole hint is visible on the monitor. Don't forget multi-monitor systems with the

    // primary monitor not being at the top-left corner.

    if Rect.Top - Screen.DesktopTop + Height > Screen.DesktopHeight then

      Rect.Top := Screen.DesktopHeight - Height + Screen.DesktopTop;

    if Rect.Left - Screen.DesktopLeft + Width > Screen.DesktopWidth then

      Rect.Left := Screen.DesktopWidth - Width + Screen.DesktopLeft;

    if Rect.Bottom - Screen.DesktopTop < Screen.DesktopTop then

      Rect.Bottom := Screen.DesktopTop + Screen.DesktopTop;

    if Rect.Left - Screen.DesktopLeft < Screen.DesktopLeft then

      Rect.Left := Screen.DesktopLeft + Screen.DesktopLeft;



    // adjust sizes of bitmaps

    FDrawBuffer.Width := Width;

    FDrawBuffer.Height := Height;

    FBackground.Width := Width;

    FBackground.Height := Height;

    FTarget.Width := Width;

    FTarget.Height := Height;



    FHintData.Tree.Update;



    // capture screen

    DC := GetDC(0);

    try

      with TWithSafeRect(Rect) do

        BitBlt(FBackground.Canvas.Handle, 0, 0, Width, Height, DC, Left, Top, SRCCOPY);

    finally

      ReleaseDC(0, DC);

    end;



    SetWindowPos(Handle, HWND_TOPMOST, Rect.Left, Rect.Top, Width, Height, SWP_SHOWWINDOW or SWP_NOACTIVATE);

    with FHintData.Tree do

      case DoGetAnimationType of

        hatNone:

          InvalidateRect(Self.Handle, nil, False);

        hatFade:

          begin

            // Make sure the window is not drawn unanimated.

            ValidateRect(Self.Handle, nil);

            // Empirically determined animation duration shows that fading needs about twice as much time as

            // sliding to show a comparable visual effect.

            Animate(FadeAnimationStepCount, 2 * FAnimationDuration, AnimationCallback, nil);

          end;

        hatSlide:

          begin

            // Make sure the window is not drawn unanimated.

            ValidateRect(Self.Handle, nil);

            Animate(Self.Height, FAnimationDuration, AnimationCallback, nil);

          end;

      end;

    if not FHintWindowDestroyed and StopLastAnimation and Assigned(FHintData.Tree) then

      FHintData.Tree.DoStateChange([tsCancelHintAnimation]);

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



function TVirtualTreeHintWindow.CalcHintRect(MaxWidth: Integer; const AHint: string; AData: Pointer): TRect;



var

  TM: TTextMetric;

  R: TRect;



begin

  if AData = nil then

    // Defensive approach, it *can* happen that AData is nil. Maybe when several user defined hint classes are used.

    Result := Rect(0, 0, 0, 0)

  else

  begin

    // The hint window does not need any bidi mode setting but the caller of this method (TApplication.ActivateHint)

    // does some unneccessary actions if the hint window is not left-to-right.

    // The text alignment is based on the bidi mode passed in the hint data, hence we can

    // simply set the window's mode to left-to-right (it might have been modified by the caller, if the

    // tree window is right-to-left aligned).

    BidiMode := bdLeftToRight;



    FHintData := PVTHintData(AData)^;



    with FHintData do

    begin

      // The draw tree gets its hint size by the application (but only if not a header hint is about to show).      // If the user will be drawing the hint, it gets its hint size by the application

      // (but only if not a header hint is about to show).

      // This size has already been determined in CMHintShow.

      if Assigned(Node) and (not IsRectEmpty(HintRect)) then

        Result := HintRect

      else

      begin

        if Column <= NoColumn then

        begin

          BidiMode := Tree.BidiMode;

          Alignment := Tree.Alignment;

        end

        else

        begin

          BidiMode := Tree.Header.Columns[Column].BidiMode;

          Alignment := Tree.Header.Columns[Column].Alignment;

        end;



        if BidiMode <> bdLeftToRight then

          ChangeBidiModeAlignment(Alignment);



        if (Node = nil) or (Tree.FHintMode <> hmToolTip) then

          Canvas.Font := Screen.HintFont

        else

        begin

          Canvas.Font := Tree.Font;

          if Tree is TCustomVirtualStringTree then

            with TCustomVirtualStringTree(Tree) do

              DoPaintText(Node, Self.Canvas, Column, ttNormal);

        end;



        GetTextMetrics(Canvas.Handle, TM);

        FTextHeight := TM.tmHeight;

        LineBreakStyle := hlbDefault;



        if Length(DefaultHint) > 0 then

          HintText := DefaultHint

        else

          if Tree.HintMode = hmToolTip then

            HintText := Tree.DoGetNodeToolTip(Node, Column, LineBreakStyle)

          else

            HintText := Tree.DoGetNodeHint(Node, Column, LineBreakStyle);



        if Length(HintText) = 0 then

          Result := Rect(0, 0, 0, 0)

        else

        begin

          if Assigned(Node) and (Tree.FHintMode = hmToolTip) then

          begin

            // Determine actual line break style depending on what was returned by the methods and what's in the node.

            if LineBreakStyle = hlbDefault then

              if vsMultiline in Node.States then

                LineBreakStyle := hlbForceMultiLine

              else

                LineBreakStyle := hlbForceSingleLine;



            // Hint for a node.

            if LineBreakStyle = hlbForceMultiLine then

            begin

              // Multiline tooltips use the columns width but extend the bottom border to fit the whole caption.

              Result := Tree.GetDisplayRect(Node, Column, True, False);

              R := Result;



              // On Windows NT/2K/XP the behavior of the tooltip is slightly different to that on Windows 9x/Me.

              // We don't have Unicode word wrap on the latter so the tooltip gets as wide as the largest line

              // in the caption (limited by carriage return), which results in unoptimal overlay of the tooltip.

              Windows.DrawTextW(Canvas.Handle, PWideChar(HintText), Length(HintText), R, DT_CALCRECT or DT_WORDBREAK);

              if BidiMode = bdLeftToRight then

                Result.Right := R.Right + Tree.FTextMargin

              else

                Result.Left := R.Left - Tree.FTextMargin + 1;

              Result.Bottom := R.Bottom;



              Inc(Result.Right);



              // If the node height and the column width are both already large enough to cover the entire text,

              // then we don't need the hint, though.

              // However if the text is partially scrolled out of the client area then a hint is useful as well.

              if (Tree.Header.Columns.Count > 0) and ((Integer(Tree.NodeHeight[Node]) + 2) >= (Result.Bottom - Result.Top)) and

                 ((Tree.Header.Columns[Column].Width + 2) >= (Result.Right - Result.Left)) and not

                 ((Result.Left < 0) or (Result.Right > Tree.ClientWidth + 3) or

                  (Result.Top < 0) or (Result.Bottom > Tree.ClientHeight + 3)) then

              begin

                Result := Rect(0, 0, 0, 0);

                Exit;

              end;

            end

            else

            begin

              Result := Tree.FLastHintRect; // = Tree.GetDisplayRect(Node, Column, True, True, True); see TBaseVirtualTree.CMHintShow

              if toShowHorzGridLines in Tree.TreeOptions.PaintOptions then

                Dec(Result.Bottom);

            end;



            // Include a one pixel border.

            InflateRect(Result, 1, 1);



            // Make the coordinates relative. They will again be offset by the caller code.

            OffsetRect(Result, -Result.Left - 1, -Result.Top - 1);

          end

          else

          begin

            // Hint for a header or non-tooltip hint.



            // Start with the base size of the hint in client coordinates.

            Result := Rect(0, 0, MaxWidth, FTextHeight);

            // Calculate the true size of the text rectangle.

            Windows.DrawTextW(Canvas.Handle, PWideChar(HintText), Length(HintText), Result, DT_CALCRECT or DT_TOP or DT_NOPREFIX or DT_WORDBREAK);

            // The height of the text plus 2 pixels vertical margin plus the border determine the hint window height.

            Inc(Result.Bottom, 6);

            // The text is centered horizontally with usual text margin for left and right borders (plus border).

            if not Assigned(Tree) then

              Exit; // Workaround, because we have seen several exceptions here caught by Eurekalog. Submitted as issue #114 to http://code.google.com/p/virtual-treeview/

            Inc(Result.Right, Tree.FTextMargin + FTextHeight); // We are extending the width here, but the text height scales with the text width and has a similar value as AveCharWdith * 2.

          end;

        end;

      end;

    end;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



function TVirtualTreeHintWindow.IsHintMsg(var Msg: TMsg): Boolean;



// The VCL is a bit too generous when telling that an existing hint can be cancelled. Need to specify further here.



begin

  Result := inherited IsHintMsg(Msg) and HandleAllocated and IsWindowVisible(Handle);

  // Avoid that mouse moves over the non-client area or key presses cancel the current hint.

  if Result and ((Msg.Message = WM_NCMOUSEMOVE) or ((Msg.Message >= WM_KEYFIRST) and (Msg.Message <= WM_KEYLAST))) then

    Result := False

  else

    // Work around problems with keypresses while doing hint animation.

    if HandleAllocated and IsWindowVisible(Handle) and (Msg.Message >= WM_KEYFIRST) and (Msg.Message <= WM_KEYLAST) and

      (tsInAnimation in FHintData.Tree.FStates) and TranslateMessage(Msg) then

      DispatchMessage(Msg);

end;



//----------------- TVTDragImage ---------------------------------------------------------------------------------------



constructor TVTDragImage.Create(AOwner: TBaseVirtualTree);



begin

  FOwner := AOwner;

  FTransparency := 128;

  FPreBlendBias := 0;

  FPostBlendBias := 0;

  FFade := False;

  FRestriction := dmrNone;

  FColorKey := clNone;

end;



//----------------------------------------------------------------------------------------------------------------------



destructor TVTDragImage.Destroy;



begin

  EndDrag;



  inherited;

end;



//----------------------------------------------------------------------------------------------------------------------



function TVTDragImage.GetVisible: Boolean;



// Returns True if the internal drag image is used (i.e. the system does not natively support drag images) and

// the internal image is currently visible on screen.



begin

  Result := FStates * [disHidden, disInDrag, disPrepared, disSystemSupport] = [disInDrag, disPrepared];

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TVTDragImage.InternalShowDragImage(ScreenDC: HDC);



// Frequently called helper routine to actually do the blend and put it onto the screen.

// Only used if the system does not support drag images.



var

  BlendMode: TBlendMode;



begin

  with FAlphaImage do

    BitBlt(Canvas.Handle, 0, 0, Width, Height, FBackImage.Canvas.Handle, 0, 0, SRCCOPY);

  if not FFade and (FColorKey = clNone) then

    BlendMode := bmConstantAlpha

  else

    BlendMode := bmMasterAlpha;

  with FDragImage do

    AlphaBlend(Canvas.Handle, FAlphaImage.Canvas.Handle, Rect(0, 0, Width, Height), Point(0, 0), BlendMode,

      FTransparency, FPostBlendBias);



  with FAlphaImage do

    BitBlt(ScreenDC, FImagePosition.X, FImagePosition.Y, Width, Height, Canvas.Handle, 0, 0, SRCCOPY);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TVTDragImage.MakeAlphaChannel(Source, Target: TBitmap);



// Helper method to create a proper alpha channel in Target (which must be in 32 bit pixel format), depending

// on the settings for the drag image and the color values in Source.

// Only used if the system does not support drag images.



type

  PBGRA = ^TBGRA;

  TBGRA = packed record

    case Boolean of

      False:

        (Color: Cardinal);

      True:

        (BGR: array[0..2] of Byte;

         Alpha: Byte);

  end;



var

  Color,

  ColorKeyRef: COLORREF;

  UseColorKey: Boolean;

  SourceRun,

  TargetRun: PBGRA;

  X, Y,

  MaxDimension,

  HalfWidth,

  HalfHeight: Integer;

  T: Extended;



begin

  UseColorKey := ColorKey <> clNone;

  ColorKeyRef := ColorToRGB(ColorKey) and $FFFFFF;

  // Color values are in the form BGR (red on LSB) while bitmap colors are in the form ARGB (blue on LSB)

  // hence we have to swap red and blue in the color key.

  with TBGRA(ColorKeyRef) do

  begin

    X := BGR[0];

    BGR[0] := BGR[2];

    BGR[2] := X;

  end;



  with Target do

  begin

    MaxDimension := Max(Width, Height);



    HalfWidth := Width div 2;

    HalfHeight := Height div 2;

    for Y := 0 to Height - 1 do

    begin

      TargetRun := Scanline[Y];

      SourceRun := Source.Scanline[Y];

      for X := 0 to Width - 1 do

      begin

        Color := SourceRun.Color and $FFFFFF;

        if UseColorKey and (Color = ColorKeyRef) then

          TargetRun.Alpha := 0

        else

        begin

          // If the color is not the given color key (or none is used) then do full calculation of a bell curve.

          T := Exp(-8 * Sqrt(Sqr((X - HalfWidth) / MaxDimension) + Sqr((Y - HalfHeight) / MaxDimension)));

          TargetRun.Alpha := Round(255 * T);

        end;

        Inc(SourceRun);

        Inc(TargetRun);

      end;

    end;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



function TVTDragImage.DragTo(P: TPoint; ForceRepaint: Boolean): Boolean;



// Moves the drag image to a new position, which is determined from the passed point P and the previous

// mouse position.

// ForceRepaint is True if something on the screen changed and the back image must be refreshed.



var

  ScreenDC: HDC;

  DeltaX,

  DeltaY: Integer;



  // optimized drag image move support

  RSamp1,

  RSamp2,       // newly added parts from screen which will be overwritten

  RDraw1,

  RDraw2,       // parts to be restored to screen

  RScroll,

  RClip: TRect; // ScrollDC of the existent background



begin

  // Determine distances to move the drag image. Take care for restrictions.

  case FRestriction of

    dmrHorizontalOnly:

      begin

        DeltaX := FLastPosition.X - P.X;

        DeltaY := 0;

      end;

    dmrVerticalOnly:

      begin

        DeltaX := 0;

        DeltaY := FLastPosition.Y - P.Y;

      end;

  else // dmrNone

    DeltaX := FLastPosition.X - P.X;

    DeltaY := FLastPosition.Y - P.Y;

  end;



  Result := (DeltaX <> 0) or (DeltaY <> 0) or ForceRepaint;

  if Result then

  begin

    if Visible then

    begin

      // All this stuff is only called if we have to handle the drag image ourselves. If the system supports

      // drag image then this is all never executed.

      ScreenDC := GetDC(0);

      try

        if (Abs(DeltaX) >= FDragImage.Width) or (Abs(DeltaY) >= FDragImage.Height) or ForceRepaint then

        begin

          // If moved more than image size then just restore old screen and blit image to new position.

          BitBlt(ScreenDC, FImagePosition.X, FImagePosition.Y, FBackImage.Width, FBackImage.Height,

            FBackImage.Canvas.Handle, 0, 0, SRCCOPY);



          if ForceRepaint then

            UpdateWindow(FOwner.Handle);



          Inc(FImagePosition.X, -DeltaX);

          Inc(FImagePosition.Y, -DeltaY);



          BitBlt(FBackImage.Canvas.Handle, 0, 0, FBackImage.Width, FBackImage.Height, ScreenDC, FImagePosition.X,

            FImagePosition.Y, SRCCOPY);

        end

        else

        begin

          // overlapping copy

          FillDragRectangles(FDragImage.Width, FDragImage.Height, DeltaX, DeltaY, RClip, RScroll, RSamp1, RSamp2, RDraw1,

            RDraw2);



          with FBackImage.Canvas do

          begin

            // restore uncovered areas of the screen

            if DeltaX = 0 then

            begin

              with TWithSafeRect(RDraw2) do

                BitBlt(ScreenDC, FImagePosition.X + Left, FImagePosition.Y + Top, Right, Bottom, Handle, Left, Top,

                  SRCCOPY);

            end

            else

            begin

              if DeltaY = 0 then

              begin

                with TWithSafeRect(RDraw1) do

                  BitBlt(ScreenDC, FImagePosition.X + Left, FImagePosition.Y + Top, Right, Bottom, Handle, Left, Top,

                    SRCCOPY);

              end

              else

              begin

                with TWithSafeRect(RDraw1) do

                  BitBlt(ScreenDC, FImagePosition.X + Left, FImagePosition.Y + Top, Right, Bottom, Handle, Left, Top,

                    SRCCOPY);

                with TWithSafeRect(RDraw2) do

                  BitBlt(ScreenDC, FImagePosition.X + Left, FImagePosition.Y + Top, Right, Bottom, Handle, Left, Top,

                    SRCCOPY);

              end;

            end;



            // move existent background

            ScrollDC(Handle, DeltaX, DeltaY, RScroll, RClip, 0, nil);



            Inc(FImagePosition.X, -DeltaX);

            Inc(FImagePosition.Y, -DeltaY);



            // Get first and second additional rectangle from screen.

            if DeltaX = 0 then

            begin

              with TWithSafeRect(RSamp2) do

                BitBlt(Handle, Left, Top, Right, Bottom, ScreenDC, FImagePosition.X + Left, FImagePosition.Y + Top,

                  SRCCOPY);

            end

            else

              if DeltaY = 0 then

              begin

                with TWithSafeRect(RSamp1) do

                  BitBlt(Handle, Left, Top, Right, Bottom, ScreenDC, FImagePosition.X + Left, FImagePosition.Y + Top,

                    SRCCOPY);

              end

              else

              begin

                with TWithSafeRect(RSamp1) do

                  BitBlt(Handle, Left, Top, Right, Bottom, ScreenDC, FImagePosition.X + Left, FImagePosition.Y + Top,

                    SRCCOPY);

                with TWithSafeRect(RSamp2) do

                  BitBlt(Handle, Left, Top, Right, Bottom, ScreenDC, FImagePosition.X + Left, FImagePosition.Y + Top,

                    SRCCOPY);

              end;

          end;

        end;

        InternalShowDragImage(ScreenDC);

      finally

        ReleaseDC(0, ScreenDC);

      end;

    end;

    FLastPosition.X := P.X;

    FLastPosition.Y := P.Y;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TVTDragImage.EndDrag;



begin

  HideDragImage;

  FStates := FStates - [disInDrag, disPrepared];



  FBackImage.Free;

  FBackImage := nil;

  FDragImage.Free;

  FDragImage := nil;

  FAlphaImage.Free;

  FAlphaImage := nil;

end;



//----------------------------------------------------------------------------------------------------------------------



function TVTDragImage.GetDragImageRect: TRect;



// Returns the current size and position of the drag image (screen coordinates).



begin

  if Visible then

  begin

    with FBackImage do

      Result := Rect(FImagePosition.X, FImagePosition.Y, FImagePosition.X + Width, FImagePosition.Y + Height);

  end

  else

    Result := Rect(0, 0, 0, 0);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TVTDragImage.HideDragImage;



var

  ScreenDC: HDC;



begin

  if Visible then

  begin

    Include(FStates, disHidden);

    ScreenDC := GetDC(0);

    try

      // restore screen

      with FBackImage do

        BitBlt(ScreenDC, FImagePosition.X, FImagePosition.Y, Width, Height, Canvas.Handle, 0, 0, SRCCOPY);

    finally

      ReleaseDC(0, ScreenDC);

    end;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TVTDragImage.PrepareDrag(DragImage: TBitmap; ImagePosition, HotSpot: TPoint; const DataObject: IDataObject);



// Creates all necessary structures to do alpha blended dragging using the given image.

// ImagePostion and HotSpot are given in screen coordinates. The first determines where to place the drag image while

// the second is the initial mouse position.

// This method also determines whether the system supports drag images natively. If so then only minimal structures

// are created.



var

  Width,

  Height: Integer;

  DragSourceHelper: IDragSourceHelper;

  DragInfo: TSHDragImage;

  lDragSourceHelper2: IDragSourceHelper2;// Needed to get Windows Vista+ style drag hints.

  lNullPoint: TPoint;

begin

  Width := DragImage.Width;

  Height := DragImage.Height;



  // Determine whether the system supports the drag helper interfaces.

  if Assigned(DataObject) and Succeeded(CoCreateInstance(CLSID_DragDropHelper, nil, CLSCTX_INPROC_SERVER,

    IDragSourceHelper, DragSourceHelper)) then

  begin

    Include(FStates, disSystemSupport);

    lNullPoint := Point(0,0);

    if Supports(DragSourceHelper, IDragSourceHelper2, lDragSourceHelper2) then

      lDragSourceHelper2.SetFlags(DSH_ALLOWDROPDESCRIPTIONTEXT);// Show description texts

    // First let the system try to initialze the DragSourceHelper, this works fine for file system objects (CF_HDROP)

    StandardOLEFormat.cfFormat := CF_HDROP;

    if not Succeeded(DataObject.QueryGetData(StandardOLEFormat)) or not Succeeded(DragSourceHelper.InitializeFromWindow(0, lNullPoint, DataObject)) then

    begin

      // Supply the drag source helper with our drag image.

      DragInfo.sizeDragImage.cx := Width;

      DragInfo.sizeDragImage.cy := Height;

      DragInfo.ptOffset.x := Width div 2;

      DragInfo.ptOffset.y := Height div 2;

      DragInfo.hbmpDragImage := CopyImage(DragImage.Handle, IMAGE_BITMAP, Width, Height, LR_COPYRETURNORG);

      DragInfo.crColorKey := ColorToRGB(FColorKey);

      if not Succeeded(DragSourceHelper.InitializeFromBitmap(@DragInfo, DataObject)) then

      begin

        DeleteObject(DragInfo.hbmpDragImage);

        Exclude(FStates, disSystemSupport);

      end;

    end;

  end

  else

    Exclude(FStates, disSystemSupport);



  if MMXAvailable and not (disSystemSupport in FStates) then

  begin

    FLastPosition := HotSpot;



    FDragImage := TBitmap.Create;

    FDragImage.PixelFormat := pf32Bit;

    FDragImage.Width := Width;

    FDragImage.Height := Height;



    FAlphaImage := TBitmap.Create;

    FAlphaImage.PixelFormat := pf32Bit;

    FAlphaImage.Width := Width;

    FAlphaImage.Height := Height;



    FBackImage := TBitmap.Create;

    FBackImage.PixelFormat := pf32Bit;

    FBackImage.Width := Width;

    FBackImage.Height := Height;



    // Copy the given drag image and apply pre blend bias if required.

    if FPreBlendBias = 0 then

      with FDragImage do

        BitBlt(Canvas.Handle, 0, 0, Width, Height, DragImage.Canvas.Handle, 0, 0, SRCCOPY)

    else

      AlphaBlend(DragImage.Canvas.Handle, FDragImage.Canvas.Handle, Rect(0, 0, Width, Height), Point(0, 0),

        bmConstantAlpha, 255, FPreBlendBias);



    // Create a proper alpha channel also if no fading is required (transparent parts).

    MakeAlphaChannel(DragImage, FDragImage);



    FImagePosition := ImagePosition;



    // Initially the drag image is hidden and will be shown during the immediately following DragEnter event.

    FStates := FStates + [disInDrag, disHidden, disPrepared];

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TVTDragImage.RecaptureBackground(Tree: TBaseVirtualTree; R: TRect; VisibleRegion: HRGN;

  CaptureNCArea, ReshowDragImage: Boolean);



// Notification by the drop target tree to update the background image because something in the tree has changed.

// Note: The passed rectangle is given in client coordinates of the current drop target tree (given in Tree).

//       The caller does not check if the given rectangle is actually within the drag image. Hence this method must do

//       all the checks.

// This method does nothing if the system manages the drag image.



var

  DragRect,

  ClipRect: TRect;

  PaintTarget: TPoint;

  PaintOptions: TVTInternalPaintOptions;

  ScreenDC: HDC;



begin

  // Recapturing means we want the tree to paint the new part into our back bitmap instead to the screen.

  if Visible then

  begin

    // Create the minimum rectangle to be recaptured.

    MapWindowPoints(Tree.Handle, 0, R, 2);

    DragRect := GetDragImageRect;

    IntersectRect(R, R, DragRect);



    OffsetRgn(VisibleRegion, -DragRect.Left, -DragRect.Top);



    // The target position for painting in the drag image is relative and can be determined from screen coordinates too.

    PaintTarget.X := R.Left - DragRect.Left;

    PaintTarget.Y := R.Top - DragRect.Top;



    // The source rectangle is determined by the offsets in the tree.

    MapWindowPoints(0, Tree.Handle, R, 2);

    OffsetRect(R, -Tree.FOffsetX, -Tree.FOffsetY);



    // Finally let the tree paint the relevant part and upate the drag image on screen.

    PaintOptions := [poBackground, poColumnColor, poDrawFocusRect, poDrawDropMark, poDrawSelection, poGridLines];

    with FBackImage do

    begin

      ClipRect.TopLeft := PaintTarget;

      ClipRect.Right := ClipRect.Left + R.Right - R.Left;

      ClipRect.Bottom := ClipRect.Top + R.Bottom - R.Top;

      ClipCanvas(Canvas, ClipRect, VisibleRegion);

      Tree.PaintTree(Canvas, R, PaintTarget, PaintOptions);



      if CaptureNCArea then

      begin

        // For the non-client area we only need the visible region of the window as limit for painting.

        SelectClipRgn(Canvas.Handle, VisibleRegion);

        // Since WM_PRINT cannot be given a position where to draw we simply move the window origin and

        // get the same effect.

        GetWindowRect(Tree.Handle, ClipRect);

        SetCanvasOrigin(Canvas, DragRect.Left - ClipRect.Left, DragRect.Top - ClipRect.Top);

        Tree.Perform(WM_PRINT, WPARAM(Canvas.Handle), PRF_NONCLIENT);

        SetCanvasOrigin(Canvas, 0, 0);

      end;

      SelectClipRgn(Canvas.Handle, 0);



      if ReshowDragImage then

      begin

        GDIFlush;

        ScreenDC := GetDC(0);

        try

          InternalShowDragImage(ScreenDC);

        finally

          ReleaseDC(0, ScreenDC);

        end;

      end;

    end;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TVTDragImage.ShowDragImage;



// Shows the drag image after it has been hidden by HideDragImage.

// Note: there might be a new background now.

// Also this method does nothing if the system manages the drag image.



var

  ScreenDC: HDC;



begin

  if FStates * [disInDrag, disHidden, disPrepared, disSystemSupport] = [disInDrag, disHidden, disPrepared] then

  begin

    Exclude(FStates, disHidden);



    GDIFlush;

    ScreenDC := GetDC(0);

    try

      BitBlt(FBackImage.Canvas.Handle, 0, 0, FBackImage.Width, FBackImage.Height, ScreenDC, FImagePosition.X,

        FImagePosition.Y, SRCCOPY);



      InternalShowDragImage(ScreenDC);

    finally

      ReleaseDC(0, ScreenDC);

    end;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



function TVTDragImage.WillMove(P: TPoint): Boolean;



// This method determines whether the drag image would "physically" move when DragTo would be called with the same

// target point.

// Always returns False if the system drag image support is available.



begin

  Result := Visible;

  if Result then

  begin

    // Determine distances to move the drag image. Take care for restrictions.

    case FRestriction of

      dmrHorizontalOnly:

        Result := FLastPosition.X <> P.X;

      dmrVerticalOnly:

        Result := FLastPosition.Y <> P.Y;

    else // dmrNone

      Result := (FLastPosition.X <> P.X) or (FLastPosition.Y <> P.Y);

    end;

  end;

end;



//----------------- TVTVirtualNodeEnumerator ---------------------------------------------------------------------------



function TVTVirtualNodeEnumerator.GetCurrent: PVirtualNode;



begin

  Result := FNode;

end;



//----------------------------------------------------------------------------------------------------------------------



function TVTVirtualNodeEnumerator.MoveNext: Boolean;



begin

  Result := FCanModeNext;

  if Result then

  begin

    FNode := FEnumeration.GetNext(FNode);

    Result := FNode <> nil;

    FCanModeNext := Result;

  end;

end;



//----------------- TVTVirtualNodeEnumeration --------------------------------------------------------------------------



function TVTVirtualNodeEnumeration.GetEnumerator: TVTVirtualNodeEnumerator;



begin

  {$if CompilerVersion >= 18}

  {$else}

  Result := TVTVirtualNodeEnumerator.Create;

  {$ifend}

  Result.FNode := nil;

  Result.FCanModeNext := True;

  Result.FEnumeration := @Self;

end;



//----------------------------------------------------------------------------------------------------------------------



function TVTVirtualNodeEnumeration.GetNext(Node: PVirtualNode): PVirtualNode;

begin

  case FMode of

    vneAll:

      if Node = nil then

        Result := FTree.GetFirst(FConsiderChildrenAbove)

      else

        Result := FTree.GetNext(Node, FConsiderChildrenAbove);



    vneChecked:

      if Node = nil then

        Result := FTree.GetFirstChecked(FState, FConsiderChildrenAbove)

      else

        Result := FTree.GetNextChecked(Node, FState, FConsiderChildrenAbove);



    vneChild:

      if Node = nil then

        Result := FTree.GetFirstChild(FNode)

      else

        Result := FTree.GetNextSibling(Node);



    vneCutCopy:

      if Node = nil then

        Result := FTree.GetFirstCutCopy(FConsiderChildrenAbove)

      else

        Result := FTree.GetNextCutCopy(Node, FConsiderChildrenAbove);



    vneInitialized:

      if Node = nil then

        Result := FTree.GetFirstInitialized(FConsiderChildrenAbove)

      else

        Result := FTree.GetNextInitialized(Node, FConsiderChildrenAbove);



    vneLeaf:

      if Node = nil then

        Result := FTree.GetFirstLeaf

      else

        Result := FTree.GetNextLeaf(Node);



    vneLevel:

      if Node = nil then

        Result := FTree.GetFirstLevel(FNodeLevel)

      else

        Result := FTree.GetNextLevel(Node, FNodeLevel);



    vneNoInit:

      if Node = nil then

        Result := FTree.GetFirstNoInit(FConsiderChildrenAbove)

      else

        Result := FTree.GetNextNoInit(Node, FConsiderChildrenAbove);



    vneSelected:

      if Node = nil then

        Result := FTree.GetFirstSelected(FConsiderChildrenAbove)

      else

        Result := FTree.GetNextSelected(Node, FConsiderChildrenAbove);



    vneVisible:

      begin

        if Node = nil then

        begin

          Result := FTree.GetFirstVisible(FNode, FConsiderChildrenAbove, FIncludeFiltered);

          if FIncludeFiltered or not FTree.IsEffectivelyFiltered[Result] then

            Exit;

        end;

        repeat

          Result := FTree.GetNextVisible(Node{, FConsiderChildrenAbove});

        until not Assigned(Result) or FIncludeFiltered or not FTree.IsEffectivelyFiltered[Result];

      end;



    vneVisibleChild:

      if Node = nil then

        Result := FTree.GetFirstVisibleChild(FNode, FIncludeFiltered)

      else

        Result := FTree.GetNextVisibleSibling(Node, FIncludeFiltered);



    vneVisibleNoInitChild:

      if Node = nil then

        Result := FTree.GetFirstVisibleChildNoInit(FNode, FIncludeFiltered)

      else

        Result := FTree.GetNextVisibleSiblingNoInit(Node, FIncludeFiltered);



    vneVisibleNoInit:

      begin

        if Node = nil then

        begin

          Result := FTree.GetFirstVisibleNoInit(FNode, FConsiderChildrenAbove, FIncludeFiltered);

          if FIncludeFiltered or not FTree.IsEffectivelyFiltered[Result] then

            Exit;

        end;

        repeat

          Result := FTree.GetNextVisibleNoInit(Node, FConsiderChildrenAbove);

        until not Assigned(Result) or FIncludeFiltered or not FTree.IsEffectivelyFiltered[Result];

      end;

  else

    Result := nil;

  end;

end;



//----------------- TVirtualTreeColumn ---------------------------------------------------------------------------------



constructor TVirtualTreeColumn.Create(Collection: TCollection);



begin

  FMinWidth := 10;

  FMaxWidth := 10000;

  FImageIndex := -1;

  FMargin := 4;

  FSpacing := 3;

  FText := '';

  FOptions := DefaultColumnOptions;

  FAlignment := taLeftJustify;

  FBiDiMode := bdLeftToRight;

  FColor := clWindow;

  FLayout := blGlyphLeft;

  FBonusPixel := False;

  FCaptionAlignment := taLeftJustify;

  FCheckType := ctCheckBox;

  FCheckState := csUncheckedNormal;

  FCheckBox := False;

  FHasImage := False;

  FDefaultSortDirection := sdAscending;



  inherited Create(Collection);



  FWidth := Owner.FDefaultWidth;

  FLastWidth := Owner.FDefaultWidth;

  FPosition := Owner.Count - 1;

  // Read parent bidi mode and color values as default values.

  ParentBiDiModeChanged;

  ParentColorChanged;

end;



//----------------------------------------------------------------------------------------------------------------------



destructor TVirtualTreeColumn.Destroy;



var

  I: Integer;



  //--------------- local function ---------------------------------------------



  procedure AdjustColumnIndex(var ColumnIndex: TColumnIndex);



  begin

    if Index = ColumnIndex then

      ColumnIndex := NoColumn

    else

      if Index < ColumnIndex then

        Dec(ColumnIndex);

  end;



  //--------------- end local function -----------------------------------------



begin

  // Check if this column is somehow referenced by its collection parent or the header.

  with Owner do

  begin

    // If the columns collection object is currently deleting all columns

    // then we don't need to check the various cached indices individually.

    if not FClearing then

    begin

      Header.Treeview.CancelEditNode;

      IndexChanged(Index, -1);



      AdjustColumnIndex(FHoverIndex);

      AdjustColumnIndex(FDownIndex);

      AdjustColumnIndex(FTrackIndex);

      AdjustColumnIndex(FClickIndex);



      with Header do

      begin

        AdjustColumnIndex(FAutoSizeIndex);

        if Index = FMainColumn then

        begin

          // If the current main column is about to be destroyed then we have to find a new main column.

          FMainColumn := NoColumn;

          for I := 0 to Count - 1 do

            if I <> Index then

            begin

              FMainColumn := I;

              Break;

            end;

        end;

        AdjustColumnIndex(FSortColumn);

      end;

    end;

  end;



  inherited;

end;



//----------------------------------------------------------------------------------------------------------------------



function TVirtualTreeColumn.GetCaptionAlignment: TAlignment;



begin

  if coUseCaptionAlignment in FOptions then

    Result := FCaptionAlignment

  else

    Result := FAlignment;

end;



//----------------------------------------------------------------------------------------------------------------------



function TVirtualTreeColumn.GetLeft: Integer;



begin

  Result := FLeft;

  if [coVisible, coFixed] * FOptions <> [coVisible, coFixed] then

    Dec(Result, Owner.Header.Treeview.FEffectiveOffsetX);

end;



//----------------------------------------------------------------------------------------------------------------------



function TVirtualTreeColumn.IsBiDiModeStored: Boolean;



begin

  Result := not (coParentBiDiMode in FOptions);

end;



//----------------------------------------------------------------------------------------------------------------------



function TVirtualTreeColumn.IsCaptionAlignmentStored: Boolean;



begin

  Result := coUseCaptionAlignment in FOptions;

end;



//----------------------------------------------------------------------------------------------------------------------



function TVirtualTreeColumn.IsColorStored: Boolean;



begin

  Result := not (coParentColor in FOptions);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TVirtualTreeColumn.SetAlignment(const Value: TAlignment);



begin

  if FAlignment <> Value then

  begin

    FAlignment := Value;

    Changed(False);

    // Setting the alignment affects also the tree, hence invalidate it too.

    Owner.Header.TreeView.Invalidate;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TVirtualTreeColumn.SetBiDiMode(Value: TBiDiMode);



begin

  if Value <> FBiDiMode then

  begin

    FBiDiMode := Value;

    Exclude(FOptions, coParentBiDiMode);

    Changed(False);

    // Setting the alignment affects also the tree, hence invalidate it too.

    Owner.Header.TreeView.Invalidate;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TVirtualTreeColumn.SetCaptionAlignment(const Value: TAlignment);



begin

  if not (coUseCaptionAlignment in FOptions) or (FCaptionAlignment <> Value) then

  begin

    FCaptionAlignment := Value;

    Include(FOptions, coUseCaptionAlignment);

    // Setting the alignment affects also the tree, hence invalidate it too.

    Owner.Header.Invalidate(Self);

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TVirtualTreeColumn.SetColor(const Value: TColor);



begin

  if FColor <> Value then

  begin

    FColor := Value;

    Exclude(FOptions, coParentColor);

    Changed(False);

    Owner.Header.TreeView.Invalidate;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TVirtualTreeColumn.SetCheckBox(Value: Boolean);



begin

  if Value <> FCheckBox then

  begin

    FCheckBox := Value;

    if Value and (csDesigning in Owner.Header.Treeview.ComponentState) then

      Owner.Header.Options := Owner.Header.Options + [hoShowImages];

    Changed(False);

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TVirtualTreeColumn.SetCheckState(Value: TCheckState);



begin

  if Value <> FCheckState then

  begin

    FCheckState := Value;

    Changed(False);

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TVirtualTreeColumn.SetCheckType(Value: TCheckType);



begin

  if Value <> FCheckType then

  begin

    FCheckType := Value;

    Changed(False);

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TVirtualTreeColumn.SetImageIndex(Value: TImageIndex);



begin

  if Value <> FImageIndex then

  begin

    FImageIndex := Value;

    Changed(False);

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TVirtualTreeColumn.SetLayout(Value: TVTHeaderColumnLayout);



begin

  if FLayout <> Value then

  begin

    FLayout := Value;

    Changed(False);

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TVirtualTreeColumn.SetMargin(Value: Integer);



begin

  // Compatibility setting for -1.

  if Value < 0 then

    Value := 4;

  if FMargin <> Value then

  begin

    FMargin := Value;

    Changed(False);

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TVirtualTreeColumn.SetMaxWidth(Value: Integer);



begin

  if Value < FMinWidth then

    Value := FMinWidth;

  FMaxWidth := Value;

  SetWidth(FWidth);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TVirtualTreeColumn.SetMinWidth(Value: Integer);



begin

  if Value < 0 then

    Value := 0;

  if Value > FMaxWidth then

    Value := FMaxWidth;

  FMinWidth := Value;

  SetWidth(FWidth);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TVirtualTreeColumn.SetOptions(Value: TVTColumnOptions);



var

  ToBeSet,

  ToBeCleared: TVTColumnOptions;

  VisibleChanged,

  ColorChanged: Boolean;



begin

  if FOptions <> Value then

  begin

    ToBeCleared := FOptions - Value;

    ToBeSet := Value - FOptions;



    FOptions := Value;



    VisibleChanged := coVisible in (ToBeSet + ToBeCleared);

    ColorChanged := coParentColor in ToBeSet;



    if coParentBidiMode in ToBeSet then

      ParentBiDiModeChanged;

    if ColorChanged then

      ParentColorChanged;



    if coAutoSpring in ToBeSet then

      FSpringRest := 0;



    if ((coFixed in ToBeSet) or (coFixed in ToBeCleared)) and (coVisible in FOptions) then

      Owner.Header.RescaleHeader;



    Changed(False);

    // Need to repaint and adjust the owner tree too.

    with Owner, Header.Treeview do

      if not (csLoading in ComponentState) and (VisibleChanged or ColorChanged) and (UpdateCount = 0) and

        HandleAllocated then

      begin

        Invalidate;

        if VisibleChanged then

          UpdateHorizontalScrollBar(False);

      end;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TVirtualTreeColumn.SetPosition(Value: TColumnPosition);



var

  Temp: TColumnIndex;



begin

  if csLoading in Owner.Header.Treeview.ComponentState then

    // Only cache the position for final fixup when loading from DFM.

    FPosition := Value

  else

  begin

    if Value >= TColumnPosition(Collection.Count) then

      Value := Collection.Count - 1;

    if FPosition <> Value then

    begin

      with Owner do

      begin

        InitializePositionArray;

        Header.Treeview.CancelEditNode;

        AdjustPosition(Self, Value);

        Self.Changed(False);



        // Need to repaint.

        with Header do

        begin

          if (UpdateCount = 0) and Treeview.HandleAllocated then

          begin

            Invalidate(Self);

            Treeview.Invalidate;

          end;

        end;

      end;



      // If the moved column is now within the fixed columns then we make it fixed as well. If it's not

      // we clear the fixed state (in case that fixed column is moved outside fixed area).

      if (coFixed in FOptions) and (FPosition > 0) then

        Temp := Owner.ColumnFromPosition(FPosition - 1)

      else

        Temp := Owner.ColumnFromPosition(FPosition + 1);



      if Temp <> NoColumn then

      begin

        if coFixed in Owner[Temp].Options then

          Options := Options + [coFixed]

        else

          Options := Options - [coFixed];

      end;

    end;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TVirtualTreeColumn.SetSpacing(Value: Integer);



begin

  if FSpacing <> Value then

  begin

    FSpacing := Value;

    Changed(False);

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TVirtualTreeColumn.SetStyle(Value: TVirtualTreeColumnStyle);



begin

  if FStyle <> Value then

  begin

    FStyle := Value;

    Changed(False);

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TVirtualTreeColumn.SetText(const Value: UnicodeString);



begin

  if FText <> Value then

  begin

    FText := Value;

    FCaptionText := '';

    Changed(False);

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TVirtualTreeColumn.SetWidth(Value: Integer);



var

  EffectiveMaxWidth,

  EffectiveMinWidth,

  TotalFixedMaxWidth,

  TotalFixedMinWidth: Integer;

  I: TColumnIndex;



begin

  if not (hsScaling in Owner.FHeader.FStates) then

    if ([coVisible, coFixed] * FOptions = [coVisible, coFixed]) then

    begin

      with Owner, FHeader, FFixedAreaConstraints, TreeView do

      begin

        TotalFixedMinWidth := 0;

        TotalFixedMaxWidth := 0;

        for I := 0 to FColumns.Count - 1 do

          if ([coVisible, coFixed] * FColumns[I].FOptions = [coVisible, coFixed]) then

          begin

            Inc(TotalFixedMaxWidth, FColumns[I].FMaxWidth);

            Inc(TotalFixedMinWidth, FColumns[I].FMinWidth);

          end;



        // The percentage values have precedence over the pixel values.

        TotalFixedMinWidth := IfThen(FMaxWidthPercent > 0,

                                     Min((ClientWidth * FMaxWidthPercent) div 100, TotalFixedMinWidth),

                                     TotalFixedMinWidth);

        TotalFixedMaxWidth := IfThen(FMinWidthPercent > 0,

                                     Max((ClientWidth * FMinWidthPercent) div 100, TotalFixedMaxWidth),

                                     TotalFixedMaxWidth);



        EffectiveMaxWidth := Min(TotalFixedMaxWidth - (GetVisibleFixedWidth - Self.FWidth), FMaxWidth);

        EffectiveMinWidth := Max(TotalFixedMinWidth - (GetVisibleFixedWidth - Self.FWidth), FMinWidth);

        Value := Min(Max(Value, EffectiveMinWidth), EffectiveMaxWidth);



        if FMinWidthPercent > 0 then

          Value := Max((ClientWidth * FMinWidthPercent) div 100 - GetVisibleFixedWidth + Self.FWidth, Value);

        if FMaxWidthPercent > 0 then

          Value := Min((ClientWidth * FMaxWidthPercent) div 100 - GetVisibleFixedWidth + Self.FWidth, Value);

      end;

    end

    else

      Value := Min(Max(Value, FMinWidth), FMaxWidth);



  if FWidth <> Value then

  begin

    FLastWidth := FWidth;

    if not (hsResizing in Owner.Header.States) then

      FBonusPixel := False;

    with Owner, Header do

    begin

      if not (hoAutoResize in FOptions) or (Index <> FAutoSizeIndex) then

      begin

        FWidth := Value;

        UpdatePositions;

      end;

      if not (csLoading in Treeview.ComponentState) and (UpdateCount = 0) then

      begin

        if hoAutoResize in FOptions then

          AdjustAutoSize(Index);

        Treeview.DoColumnResize(Index);

      end;

    end;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TVirtualTreeColumn.ComputeHeaderLayout(DC: HDC; Client: TRect; UseHeaderGlyph, UseSortGlyph: Boolean;

  var HeaderGlyphPos, SortGlyphPos: TPoint; var SortGlyphSize: TSize; var TextBounds: TRect; DrawFormat: Cardinal;

  CalculateTextRect: Boolean = False);



// The layout of a column header is determined by a lot of factors. This method takes them all into account and

// determines all necessary positions and bounds:

// - for the header text

// - the header glyph

// - the sort glyph



var

  TextSize: TSize;

  TextPos,

  ClientSize,

  HeaderGlyphSize: TPoint;

  CurrentAlignment: TAlignment;

  MinLeft,

  MaxRight,

  TextSpacing: Integer;

  UseText: Boolean;

  R: TRect;

  Theme: HTHEME;



begin

  UseText := Length(FText) > 0;

  // If nothing is to show then don't waste time with useless preparation.

  if not (UseText or UseHeaderGlyph or UseSortGlyph) then

    Exit;



  CurrentAlignment := CaptionAlignment;

  if FBiDiMode <> bdLeftToRight then

    ChangeBiDiModeAlignment(CurrentAlignment);



  // Calculate sizes of the involved items.

  ClientSize := Point(Client.Right - Client.Left, Client.Bottom - Client.Top);

  with Owner, Header do

  begin

    if UseHeaderGlyph then

      if not FCheckBox then

        HeaderGlyphSize := Point(FImages.Width, FImages.Height)

      else

        with Self.Owner.Header.Treeview do

        begin

          if Assigned(FCheckImages) then

            HeaderGlyphSize := Point(FCheckImages.Width, FCheckImages.Height);

        end

    else

      HeaderGlyphSize := Point(0, 0);

    if UseSortGlyph then

    begin

      if tsUseExplorerTheme in FHeader.Treeview.FStates then

      begin

        R := Rect(0, 0, 100, 100);

        Theme := OpenThemeData(FHeader.Treeview.Handle, 'HEADER');

        GetThemePartSize(Theme, DC, HP_HEADERSORTARROW, HSAS_SORTEDUP, @R, TS_TRUE, SortGlyphSize);

        CloseThemeData(Theme);

      end

      else

      begin

        SortGlyphSize.cx := UtilityImages.Width;

        SortGlyphSize.cy := UtilityImages.Height;

      end;



      // In any case, the sort glyph is vertically centered.

      SortGlyphPos.Y := (ClientSize.Y - SortGlyphSize.cy) div 2;

    end

    else

    begin

      SortGlyphSize.cx := 0;

      SortGlyphSize.cy := 0;

    end;

  end;



  if UseText then

  begin

    if not (coWrapCaption in FOptions) then

    begin

      FCaptionText := FText;

      GetTextExtentPoint32W(DC, PWideChar(FText), Length(FText), TextSize);

      Inc(TextSize.cx, 2);

      TextBounds := Rect(0, 0, TextSize.cx, TextSize.cy);

    end

    else

    begin

      R := Client;

      if FCaptionText = '' then

        FCaptionText := WrapString(DC, FText, R, DT_RTLREADING and DrawFormat <> 0, DrawFormat);



      GetStringDrawRect(DC, FCaptionText, R, DrawFormat);

      TextSize.cx := Client.Right - Client.Left;

      TextSize.cy := R.Bottom - R.Top;

      TextBounds := Rect(0, 0, TextSize.cx, TextSize.cy);

    end;

    TextSpacing := FSpacing;

  end

  else

  begin

    TextSpacing := 0;

    TextSize.cx := 0;

    TextSize.cy := 0;

  end;



  // Check first for the special case where nothing is shown except the sort glyph.

  if UseSortGlyph and not (UseText or UseHeaderGlyph) then

  begin

    // Center the sort glyph in the available area if nothing else is there.

    SortGlyphPos := Point((ClientSize.X - SortGlyphSize.cx) div 2, (ClientSize.Y - SortGlyphSize.cy) div 2);

  end

  else

  begin

    // Determine extents of text and glyph and calculate positions which are clear from the layout.

    if (Layout in [blGlyphLeft, blGlyphRight]) or not UseHeaderGlyph then

    begin

      HeaderGlyphPos.Y := (ClientSize.Y - HeaderGlyphSize.Y) div 2;

      // If the text is taller than the given height, perform no vertical centration as this

      // would make the text even less readable.

      //Using Max() fixes badly positioned text if Extra Large fonts have been activated in the Windows display options

      TextPos.Y := Max(-5, (ClientSize.Y - TextSize.cy) div 2);

    end

    else

    begin

      if Layout = blGlyphTop then

      begin

        HeaderGlyphPos.Y := (ClientSize.Y - HeaderGlyphSize.Y - TextSize.cy - TextSpacing) div 2;

        TextPos.Y := HeaderGlyphPos.Y + HeaderGlyphSize.Y + TextSpacing;

      end

      else

      begin

        TextPos.Y := (ClientSize.Y - HeaderGlyphSize.Y - TextSize.cy - TextSpacing) div 2;

        HeaderGlyphPos.Y := TextPos.Y + TextSize.cy + TextSpacing;

      end;

    end;



    // Each alignment needs special consideration.

    case CurrentAlignment of

      taLeftJustify:

        begin

          MinLeft := FMargin;

          if UseSortGlyph and (FBiDiMode <> bdLeftToRight) then

          begin

            // In RTL context is the sort glyph placed on the left hand side.

            SortGlyphPos.X := MinLeft;

            Inc(MinLeft, SortGlyphSize.cx + FSpacing);

          end;

          if Layout in [blGlyphTop, blGlyphBottom] then

          begin

            // Header glyph is above or below text, so both must be considered when calculating

            // the left positition of the sort glyph (if it is on the right hand side).

            TextPos.X := MinLeft;

            if UseHeaderGlyph then

            begin

              HeaderGlyphPos.X := (ClientSize.X - HeaderGlyphSize.X) div 2;

              if HeaderGlyphPos.X < MinLeft then

                HeaderGlyphPos.X := MinLeft;

              MinLeft := Max(TextPos.X + TextSize.cx + TextSpacing, HeaderGlyphPos.X + HeaderGlyphSize.X + FSpacing);

            end

            else

              MinLeft := TextPos.X + TextSize.cx + TextSpacing;

          end

          else

          begin

            // Everything is lined up. TextSpacing might be 0 if there is no text.

            // This simplifies the calculation because no extra tests are necessary.

            if UseHeaderGlyph and (Layout = blGlyphLeft) then

            begin

              HeaderGlyphPos.X := MinLeft;

              Inc(MinLeft, HeaderGlyphSize.X + FSpacing);

            end;

            TextPos.X := MinLeft;

            Inc(MinLeft, TextSize.cx + TextSpacing);

            if UseHeaderGlyph and (Layout = blGlyphRight) then

            begin

              HeaderGlyphPos.X := MinLeft;

              Inc(MinLeft, HeaderGlyphSize.X + FSpacing);

            end;

          end;

          if UseSortGlyph and (FBiDiMode = bdLeftToRight) then

            SortGlyphPos.X := MinLeft;

        end;

      taCenter:

        begin

          if Layout in [blGlyphTop, blGlyphBottom] then

          begin

            HeaderGlyphPos.X := (ClientSize.X - HeaderGlyphSize.X) div 2;

            TextPos.X := (ClientSize.X - TextSize.cx) div 2;

            if UseSortGlyph then

              Dec(TextPos.X, SortGlyphSize.cx div 2);

          end

          else

          begin

            MinLeft := (ClientSize.X - HeaderGlyphSize.X - TextSpacing - TextSize.cx) div 2;

            if UseHeaderGlyph and (Layout = blGlyphLeft) then

            begin

              HeaderGlyphPos.X := MinLeft;

              Inc(MinLeft, HeaderGlyphSize.X + TextSpacing);

            end;

            TextPos.X := MinLeft;

            Inc(MinLeft, TextSize.cx + TextSpacing);

            if UseHeaderGlyph and (Layout = blGlyphRight) then

              HeaderGlyphPos.X := MinLeft;

          end;

          if UseHeaderGlyph then

          begin

            MinLeft := Min(HeaderGlyphPos.X, TextPos.X);

            MaxRight := Max(HeaderGlyphPos.X + HeaderGlyphSize.X, TextPos.X + TextSize.cx);

          end

          else

          begin

            MinLeft := TextPos.X;

            MaxRight := TextPos.X + TextSize.cx;

          end;

          // Place the sort glyph directly to the left or right of the larger item.

          if UseSortGlyph then

            if FBiDiMode = bdLeftToRight then

            begin

              // Sort glyph on the right hand side.

              SortGlyphPos.X := MaxRight + FSpacing;

            end

            else

            begin

              // Sort glyph on the left hand side.

              SortGlyphPos.X := MinLeft - FSpacing - SortGlyphSize.cx;

            end;

        end;

    else

      // taRightJustify

      MaxRight := ClientSize.X - FMargin;

      if UseSortGlyph and (FBiDiMode = bdLeftToRight) then

      begin

        // In LTR context is the sort glyph placed on the right hand side.

        Dec(MaxRight, SortGlyphSize.cx);

        SortGlyphPos.X := MaxRight;

        Dec(MaxRight, FSpacing);

      end;

      if Layout in [blGlyphTop, blGlyphBottom] then

      begin

        TextPos.X := MaxRight - TextSize.cx;

        if UseHeaderGlyph then

        begin

          HeaderGlyphPos.X := (ClientSize.X - HeaderGlyphSize.X) div 2;

          if HeaderGlyphPos.X + HeaderGlyphSize.X + FSpacing > MaxRight then

            HeaderGlyphPos.X := MaxRight - HeaderGlyphSize.X - FSpacing;

          MaxRight := Min(TextPos.X - TextSpacing, HeaderGlyphPos.X - FSpacing);

        end

        else

          MaxRight := TextPos.X - TextSpacing;

      end

      else

      begin

        // Everything is lined up. TextSpacing might be 0 if there is no text.

        // This simplifies the calculation because no extra tests are necessary.

        if UseHeaderGlyph and (Layout = blGlyphRight) then

        begin

          HeaderGlyphPos.X := MaxRight -  HeaderGlyphSize.X;

          MaxRight := HeaderGlyphPos.X - FSpacing;

        end;

        TextPos.X := MaxRight - TextSize.cx;

        MaxRight := TextPos.X - TextSpacing;

        if UseHeaderGlyph and (Layout = blGlyphLeft) then

        begin

          HeaderGlyphPos.X := MaxRight - HeaderGlyphSize.X;

          MaxRight := HeaderGlyphPos.X - FSpacing;

        end;

      end;

      if UseSortGlyph and (FBiDiMode <> bdLeftToRight) then

        SortGlyphPos.X := MaxRight - SortGlyphSize.cx;

    end;

  end;



  // Once the position of each element is determined there remains only one but important step.

  // The horizontal positions of every element must be adjusted so that it always fits into the

  // given header area. This is accomplished by shorten the text appropriately.



  // These are the maximum bounds. Nothing goes beyond them.

  MinLeft := FMargin;

  MaxRight := ClientSize.X - FMargin;

  if UseSortGlyph then

  begin

    if FBiDiMode = bdLeftToRight then

    begin

      // Sort glyph on the right hand side.

      if SortGlyphPos.X + SortGlyphSize.cx > MaxRight then

        SortGlyphPos.X := MaxRight - SortGlyphSize.cx;

      MaxRight := SortGlyphPos.X - FSpacing;

    end;



    // Consider also the left side of the sort glyph regardless of the bidi mode.

    if SortGlyphPos.X < MinLeft then

      SortGlyphPos.X := MinLeft;

    // Left border needs only adjustment if the sort glyph marks the left border.

    if FBiDiMode <> bdLeftToRight then

      MinLeft := SortGlyphPos.X + SortGlyphSize.cx + FSpacing;



    // Finally transform sort glyph to its actual position.

    Inc(SortGlyphPos.X, Client.Left);

    Inc(SortGlyphPos.Y, Client.Top);

  end;

  if UseHeaderGlyph then

  begin

    if HeaderGlyphPos.X + HeaderGlyphSize.X > MaxRight then

      HeaderGlyphPos.X := MaxRight - HeaderGlyphSize.X;

    if Layout = blGlyphRight then

      MaxRight := HeaderGlyphPos.X - FSpacing;

    if HeaderGlyphPos.X < MinLeft then

      HeaderGlyphPos.X := MinLeft;

    if Layout = blGlyphLeft then

      MinLeft := HeaderGlyphPos.X + HeaderGlyphSize.X + FSpacing;

    if FCheckBox and (Owner.Header.MainColumn = Self.Index) then

      Dec(HeaderGlyphPos.X, 2)

    else

      if Owner.Header.MainColumn <> Self.Index then

        Dec(HeaderGlyphPos.X, 2);



    // Finally transform header glyph to its actual position.

    Inc(HeaderGlyphPos.X, Client.Left);

    Inc(HeaderGlyphPos.Y, Client.Top);

  end;

  if UseText then

  begin

    if TextPos.X < MinLeft then

      TextPos.X := MinLeft;

    OffsetRect(TextBounds, TextPos.X, TextPos.Y);

    if TextBounds.Right > MaxRight then

      TextBounds.Right := MaxRight;

    OffsetRect(TextBounds, Client.Left, Client.Top);



    if coWrapCaption in FOptions then

    begin

      // Wrap the column caption if necessary.

      R := TextBounds;

      FCaptionText := WrapString(DC, FText, R, DT_RTLREADING and DrawFormat <> 0, DrawFormat);

      GetStringDrawRect(DC, FCaptionText, R, DrawFormat);

    end;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TVirtualTreeColumn.DefineProperties(Filer: TFiler);



begin

  inherited;



  // Must define a new name for the properties otherwise the VCL will try to load the wide string

  // without asking us and screws it completely up.

  Filer.DefineProperty('WideText', ReadText, WriteText, FText <> '');

  Filer.DefineProperty('WideHint', ReadHint, WriteHint, FHint <> '');

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TVirtualTreeColumn.GetAbsoluteBounds(var Left, Right: Integer);



// Returns the column's left and right bounds in header coordinates, that is, independant of the scrolling position.



begin

  Left := FLeft;

  Right := FLeft + FWidth;

end;



//----------------------------------------------------------------------------------------------------------------------



function TVirtualTreeColumn.GetDisplayName: string;



// Returns the column text if it only contains ANSI characters, otherwise the column id is returned because the IDE

// still cannot handle Unicode strings.



var

  I: Integer;



begin

  // Check if the text of the column contains characters > 255

  I := 1;

  while I <= Length(FText) do

  begin

    if Ord(FText[I]) > 255 then

      Break;

    Inc(I);

  end;



  if I > Length(FText) then

    Result := FText // implicit conversion

  else

    Result := Format('Column %d', [Index]);

end;



//----------------------------------------------------------------------------------------------------------------------



function TVirtualTreeColumn.GetOwner: TVirtualTreeColumns;



begin

  Result := Collection as TVirtualTreeColumns;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TVirtualTreeColumn.ReadText(Reader: TReader);



begin

  case Reader.NextValue of

    vaLString, vaString:

      SetText(Reader.ReadString);

  else

    SetText(Reader.{$if CompilerVersion >= 23}ReadString{$else}ReadWideString{$ifend});

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TVirtualTreeColumn.ReadHint(Reader: TReader);



begin

  case Reader.NextValue of

    vaLString, vaString:

      FHint := Reader.ReadString;

  else

    FHint := Reader.{$if CompilerVersion >= 23}ReadString{$else}ReadWideString{$ifend};

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TVirtualTreeColumn.WriteHint(Writer: TWriter);



begin

  Writer.{$IF CompilerVersion >= 20}WriteString{$else}WriteWideString{$ifend}(FHint);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TVirtualTreeColumn.WriteText(Writer: TWriter);



begin

  Writer.{$IF CompilerVersion >= 20}WriteString{$else}WriteWideString{$ifend}(FText);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TVirtualTreeColumn.Assign(Source: TPersistent);



var

  OldOptions: TVTColumnOptions;



begin

  if Source is TVirtualTreeColumn then

  begin

    OldOptions := FOptions;

    FOptions := [];



    BiDiMode := TVirtualTreeColumn(Source).BiDiMode;

    ImageIndex := TVirtualTreeColumn(Source).ImageIndex;

    Layout := TVirtualTreeColumn(Source).Layout;

    Margin := TVirtualTreeColumn(Source).Margin;

    MaxWidth := TVirtualTreeColumn(Source).MaxWidth;

    MinWidth := TVirtualTreeColumn(Source).MinWidth;

    Position := TVirtualTreeColumn(Source).Position;

    Spacing := TVirtualTreeColumn(Source).Spacing;

    Style := TVirtualTreeColumn(Source).Style;

    Text := TVirtualTreeColumn(Source).Text;

    Hint := TVirtualTreeColumn(Source).Hint;

    Width := TVirtualTreeColumn(Source).Width;

    Alignment := TVirtualTreeColumn(Source).Alignment;

    CaptionAlignment := TVirtualTreeColumn(Source).CaptionAlignment;

    Color := TVirtualTreeColumn(Source).Color;

    Tag := TVirtualTreeColumn(Source).Tag;



    // Order is important. Assign options last.

    FOptions := OldOptions;

    Options := TVirtualTreeColumn(Source).Options;



    Changed(False);

  end

  else

    inherited Assign(Source);

end;



//----------------------------------------------------------------------------------------------------------------------



function TVirtualTreeColumn.Equals(OtherColumnObj: TObject): Boolean;

var

 OtherColumn : TVirtualTreeColumn;

begin

  if OtherColumnObj is TVirtualTreeColumn then

  begin

    OtherColumn := TVirtualTreeColumn (OtherColumnObj);

    Result := (BiDiMode = OtherColumn.BiDiMode) and

      (ImageIndex = OtherColumn.ImageIndex) and

      (Layout = OtherColumn.Layout) and

      (Margin = OtherColumn.Margin) and

      (MaxWidth = OtherColumn.MaxWidth) and

      (MinWidth = OtherColumn.MinWidth) and

      (Position = OtherColumn.Position) and

      (Spacing = OtherColumn.Spacing) and

      (Style = OtherColumn.Style) and

      (Text = OtherColumn.Text) and

      (Hint = OtherColumn.Hint) and

      (Width = OtherColumn.Width) and

      (Alignment = OtherColumn.Alignment) and

      (CaptionAlignment = OtherColumn.CaptionAlignment) and

      (Color = OtherColumn.Color) and

      (Tag = OtherColumn.Tag) and

      (Options = OtherColumn.Options);

  end

  else

    Result := False;

end;



//----------------------------------------------------------------------------------------------------------------------



function TVirtualTreeColumn.GetRect: TRect;



// Returns the rectangle this column occupies in the header (relative to (0, 0) of the non-client area).



begin

  with TVirtualTreeColumns(GetOwner).FHeader do

    Result := Treeview.FHeaderRect;

  Inc(Result.Left, FLeft);

  Result.Right := Result.Left + FWidth;

end;



//----------------------------------------------------------------------------------------------------------------------



// [IPK]

function TVirtualTreeColumn.GetText: UnicodeString;



begin

  Result := FText;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TVirtualTreeColumn.LoadFromStream(const Stream: TStream; Version: Integer);



  //--------------- local function --------------------------------------------



  function ConvertOptions(Value: Cardinal): TVTColumnOptions;



  // Converts the given raw value which represents column options for possibly older

  // formats to the current format.



  begin

    if Version >= 3 then

      Result := TVTColumnOptions(Word(Value and $FFFF))

    else

      if Version = 2 then

        Result := TVTColumnOptions(Word(Value and $FF))

      else

      begin

        // In version 2 coParentColor has been added. This needs an option shift for older stream formats.

        // The first (lower) 4 options remain as they are.

        Result := TVTColumnOptions(Word(Value) and $F);

        Value := (Value and not $F) shl 1;

        Result := Result + TVTColumnOptions(Word(Value and $FF));

      end;

  end;



  //--------------- end local function ----------------------------------------



var

  Dummy: Integer;

  S: UnicodeString;



begin

  with Stream do

  begin

    ReadBuffer(Dummy, SizeOf(Dummy));

    SetLength(S, Dummy);

    ReadBuffer(PWideChar(S)^, 2 * Dummy);

    Text := S;

    ReadBuffer(Dummy, SizeOf(Dummy));

    SetLength(FHint, Dummy);

    ReadBuffer(PWideChar(FHint)^, 2 * Dummy);

    ReadBuffer(Dummy, SizeOf(Dummy));

    Width := Dummy;

    ReadBuffer(Dummy, SizeOf(Dummy));

    MinWidth := Dummy;

    ReadBuffer(Dummy, SizeOf(Dummy));

    MaxWidth := Dummy;

    ReadBuffer(Dummy, SizeOf(Dummy));

    Style := TVirtualTreeColumnStyle(Dummy);

    ReadBuffer(Dummy, SizeOf(Dummy));

    ImageIndex := Dummy;

    ReadBuffer(Dummy, SizeOf(Dummy));

    Layout := TVTHeaderColumnLayout(Dummy);

    ReadBuffer(Dummy, SizeOf(Dummy));

    Margin := Dummy;

    ReadBuffer(Dummy, SizeOf(Dummy));

    Spacing := Dummy;

    ReadBuffer(Dummy, SizeOf(Dummy));

    BiDiMode := TBiDiMode(Dummy);



    ReadBuffer(Dummy, SizeOf(Dummy));

    Options := ConvertOptions(Dummy);



    if Version > 0 then

    begin

      // Parts which have been introduced/changed with header stream version 1+.

      ReadBuffer(Dummy, SizeOf(Dummy));

      Tag := Dummy;

      ReadBuffer(Dummy, SizeOf(Dummy));

      Alignment := TAlignment(Dummy);



      if Version > 1 then

      begin

        ReadBuffer(Dummy, SizeOf(Dummy));

        Color := TColor(Dummy);

      end;



      if Version > 5 then

      begin

        if coUseCaptionAlignment in FOptions then

        begin

          ReadBuffer(Dummy, SizeOf(Dummy));

          CaptionAlignment := TAlignment(Dummy);

        end;

      end;

    end;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TVirtualTreeColumn.ParentBiDiModeChanged;



var

  Columns: TVirtualTreeColumns;



begin

  if coParentBiDiMode in FOptions then

  begin

    Columns := GetOwner as TVirtualTreeColumns;

    if Assigned(Columns) and (FBiDiMode <> Columns.FHeader.Treeview.BiDiMode) then

    begin

      FBiDiMode := Columns.FHeader.Treeview.BiDiMode;

      Changed(False);

    end;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TVirtualTreeColumn.ParentColorChanged;



var

  Columns: TVirtualTreeColumns;



begin

  if coParentColor in FOptions then

  begin

    Columns := GetOwner as TVirtualTreeColumns;

    if Assigned(Columns) and (FColor <> Columns.FHeader.Treeview.Color) then

    begin

      FColor := Columns.FHeader.Treeview.Color;

      Changed(False);

    end;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TVirtualTreeColumn.RestoreLastWidth;



begin

  TVirtualTreeColumns(GetOwner).AnimatedResize(Index, FLastWidth);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TVirtualTreeColumn.SaveToStream(const Stream: TStream);



var

  Dummy: Integer;



begin

  with Stream do

  begin

    Dummy := Length(FText);

    WriteBuffer(Dummy, SizeOf(Dummy));

    WriteBuffer(PWideChar(FText)^, 2 * Dummy);

    Dummy := Length(FHint);

    WriteBuffer(Dummy, SizeOf(Dummy));

    WriteBuffer(PWideChar(FHint)^, 2 * Dummy);

    WriteBuffer(FWidth, SizeOf(FWidth));

    WriteBuffer(FMinWidth, SizeOf(FMinWidth));

    WriteBuffer(FMaxWidth, SizeOf(FMaxWidth));

    Dummy := Ord(FStyle);

    WriteBuffer(Dummy, SizeOf(Dummy));

    Dummy := FImageIndex;

    WriteBuffer(Dummy, SizeOf(Dummy));

    Dummy := Ord(FLayout);

    WriteBuffer(Dummy, SizeOf(Dummy));

    WriteBuffer(FMargin, SizeOf(FMargin));

    WriteBuffer(FSpacing, SizeOf(FSpacing));

    Dummy := Ord(FBiDiMode);

    WriteBuffer(Dummy, SizeOf(Dummy));

    Dummy := Word(FOptions);

    WriteBuffer(Dummy, SizeOf(Dummy));



    // parts introduced with stream version 1

    WriteBuffer(FTag, SizeOf(Dummy));

    Dummy := Cardinal(FAlignment);

    WriteBuffer(Dummy, SizeOf(Dummy));



    // parts introduced with stream version 2

    Dummy := Integer(FColor);

    WriteBuffer(Dummy, SizeOf(Dummy));



    // parts introduced with stream version 6

    if coUseCaptionAlignment in FOptions then

    begin

      Dummy := Cardinal(FCaptionAlignment);

      WriteBuffer(Dummy, SizeOf(Dummy));

    end;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



function TVirtualTreeColumn.UseRightToLeftReading: Boolean;



begin

  Result := FBiDiMode <> bdLeftToRight;

end;



//----------------- TVirtualTreeColumns --------------------------------------------------------------------------------



constructor TVirtualTreeColumns.Create(AOwner: TVTHeader);



var

  ColumnClass: TVirtualTreeColumnClass;



begin

  FHeader := AOwner;



  // Determine column class to be used in the header.

  ColumnClass := AOwner.FOwner.GetColumnClass;

  // The owner tree always returns the default tree column class if not changed by application/descendants.

  inherited Create(ColumnClass);



  FHeaderBitmap := TBitmap.Create;

  FHeaderBitmap.PixelFormat := pf32Bit;



  FHoverIndex := NoColumn;

  FDownIndex := NoColumn;

  FClickIndex := NoColumn;

  FDropTarget := NoColumn;

  FTrackIndex := NoColumn;

  FDefaultWidth := 50;

end;



//----------------------------------------------------------------------------------------------------------------------



destructor TVirtualTreeColumns.Destroy;



begin

  FHeaderBitmap.Free;

  inherited;

end;



//----------------------------------------------------------------------------------------------------------------------



function TVirtualTreeColumns.GetCount: Integer;



begin

  Result := inherited Count;

end;



//----------------------------------------------------------------------------------------------------------------------



function TVirtualTreeColumns.GetItem(Index: TColumnIndex): TVirtualTreeColumn;



begin

  Result := TVirtualTreeColumn(inherited GetItem(Index));

end;



//----------------------------------------------------------------------------------------------------------------------



function TVirtualTreeColumns.GetNewIndex(P: TPoint; var OldIndex: TColumnIndex): Boolean;



var

  NewIndex: Integer;



begin

  Result := False;

  // convert to local coordinates

  Inc(P.Y, FHeader.FHeight);

  NewIndex := ColumnFromPosition(P);

  if NewIndex <> OldIndex then

  begin

    if OldIndex > NoColumn then

      FHeader.Invalidate(Items[OldIndex]);

    OldIndex := NewIndex;

    if OldIndex > NoColumn then

      FHeader.Invalidate(Items[OldIndex]);

    Result := True;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TVirtualTreeColumns.SetDefaultWidth(Value: Integer);



begin

  FDefaultWidth := Value;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TVirtualTreeColumns.SetItem(Index: TColumnIndex; Value: TVirtualTreeColumn);



begin

  inherited SetItem(Index, Value);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TVirtualTreeColumns.AdjustAutoSize(CurrentIndex: TColumnIndex; Force: Boolean = False);



// Called only if the header is in auto-size mode which means a column needs to be so large

// that it fills all the horizontal space not occupied by the other columns.

// CurrentIndex (if not InvalidColumn) describes which column has just been resized.



var

  NewValue,

  AutoIndex,

  Index,

  RestWidth: Integer;

  WasUpdating: Boolean;

begin

  if Count > 0 then

  begin

    // Determine index to be used for auto resizing. This is usually given by the owner's AutoSizeIndex, but

    // could be different if the column whose resize caused the invokation here is either the auto column itself

    // or visually to the right of the auto size column.

    AutoIndex := FHeader.FAutoSizeIndex;

    if (AutoIndex < 0) or (AutoIndex >= Count) then

      AutoIndex := Count - 1;



    if AutoIndex >= 0 then

    begin

      with FHeader.Treeview do

      begin

        if HandleAllocated then

          RestWidth := ClientWidth

        else

          RestWidth := Width;

      end;



      // Go through all columns and calculate the rest space remaining.

      for Index := 0 to Count - 1 do

        if (Index <> AutoIndex) and (coVisible in Items[Index].FOptions) then

          Dec(RestWidth, Items[Index].Width);



      with Items[AutoIndex] do

      begin

        NewValue := Max(MinWidth, Min(MaxWidth, RestWidth));

        if Force or (FWidth <> NewValue) then

        begin

          FWidth := NewValue;

          UpdatePositions;

          WasUpdating := csUpdating in FHeader.Treeview.ComponentState;

          if not WasUpdating then

            FHeader.Treeview.Updating();// Fixes #398

          try

            FHeader.Treeview.DoColumnResize(AutoIndex);

          finally

            if not WasUpdating then

              FHeader.Treeview.Updated();

          end;

        end;

      end;

    end;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



function TVirtualTreeColumns.AdjustDownColumn(P: TPoint): TColumnIndex;



// Determines the column from the given position and returns it. If this column is allowed to be clicked then

// it is also kept for later use.



begin

  // Convert to local coordinates.

  Inc(P.Y, FHeader.FHeight);

  Result := ColumnFromPosition(P);

  if (Result > NoColumn) and (Result <> FDownIndex) and (coAllowClick in Items[Result].FOptions) and

    (coEnabled in Items[Result].FOptions) then

  begin

    if FDownIndex > NoColumn then

      FHeader.Invalidate(Items[FDownIndex]);

    FDownIndex := Result;

    FCheckBoxHit := Items[Result].FHasImage and PtInRect(Items[Result].FImageRect, P) and Items[Result].CheckBox;

    FHeader.Invalidate(Items[FDownIndex]);

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



function TVirtualTreeColumns.AdjustHoverColumn(P: TPoint): Boolean;



// Determines the new hover column index and returns True if the index actually changed else False.



begin

  Result := GetNewIndex(P, FHoverIndex);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TVirtualTreeColumns.AdjustPosition(Column: TVirtualTreeColumn; Position: Cardinal);



// Reorders the column position array so that the given column gets the given position.



var

  OldPosition: Cardinal;



begin

  OldPosition := Column.Position;

  if OldPosition <> Position then

  begin

    if OldPosition < Position then

    begin

      // column will be moved up so move down other entries

      Move(FPositionToIndex[OldPosition + 1], FPositionToIndex[OldPosition], (Position - OldPosition) * SizeOf(Cardinal));

    end

    else

    begin

      // column will be moved down so move up other entries

      Move(FPositionToIndex[Position], FPositionToIndex[Position + 1], (OldPosition - Position) * SizeOf(Cardinal));

    end;

    FPositionToIndex[Position] := Column.Index;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



function TVirtualTreeColumns.CanSplitterResize(P: TPoint; Column: TColumnIndex): Boolean;



begin

  Result := (Column > NoColumn) and ([coResizable, coVisible] * Items[Column].FOptions = [coResizable, coVisible]);

  DoCanSplitterResize(P, Column, Result);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TVirtualTreeColumns.DoCanSplitterResize(P: TPoint; Column: TColumnIndex; var Allowed: Boolean);



begin

  if Assigned(FHeader.Treeview.FOnCanSplitterResizeColumn) then

    FHeader.Treeview.FOnCanSplitterResizeColumn(FHeader, P, Column, Allowed);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TVirtualTreeColumns.DrawButtonText(DC: HDC; Caption: UnicodeString; Bounds: TRect; Enabled, Hot: Boolean;

    DrawFormat: Cardinal; WrapCaption: Boolean);



var

  TextSpace: Integer;

  Size: TSize;



begin

  if not WrapCaption then

  begin

    // Do we need to shorten the caption due to limited space?

    GetTextExtentPoint32W(DC, PWideChar(Caption), Length(Caption), Size);

    TextSpace := Bounds.Right - Bounds.Left;

    if TextSpace < Size.cx then

      Caption := ShortenString(DC, Caption, TextSpace);

  end;



  SetBkMode(DC, TRANSPARENT);

  if not Enabled then

    if FHeader.Treeview.VclStyleEnabled then

    begin

      SetTextColor(DC, ColorToRGB(FHeader.Treeview.FColors.HeaderFontColor));

      Windows.DrawTextW(DC, PWideChar(Caption), Length(Caption), Bounds, DrawFormat);

    end

    else

  begin

    OffsetRect(Bounds, 1, 1);

    SetTextColor(DC, ColorToRGB(clBtnHighlight));

    Windows.DrawTextW(DC, PWideChar(Caption), Length(Caption), Bounds, DrawFormat);

    OffsetRect(Bounds, -1, -1);

    SetTextColor(DC, ColorToRGB(clBtnShadow));

    Windows.DrawTextW(DC, PWideChar(Caption), Length(Caption), Bounds, DrawFormat);

  end

  else

  begin

    if Hot then

      SetTextColor(DC, ColorToRGB(FHeader.Treeview.FColors.HeaderHotColor))

    else

      SetTextColor(DC, ColorToRGB(FHeader.Treeview.FColors.HeaderFontColor));

    Windows.DrawTextW(DC, PWideChar(Caption), Length(Caption), Bounds, DrawFormat);

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TVirtualTreeColumns.FixPositions;



// Fixes column positions after loading from DFM or Bidi mode change.



var

  I: Integer;



begin

  for I := 0 to Count - 1 do

    FPositionToIndex[Items[I].Position] := I;



  FNeedPositionsFix := False;

  UpdatePositions(True);

end;



//----------------------------------------------------------------------------------------------------------------------



function TVirtualTreeColumns.GetColumnAndBounds(P: TPoint; var ColumnLeft, ColumnRight: Integer;

  Relative: Boolean = True): Integer;



// Returns the column where the mouse is currently in as well as the left and right bound of

// this column (Left and Right are undetermined if no column is involved).



var

  I: Integer;



begin

  Result := InvalidColumn;

  if Relative and (P.X >= Header.Columns.GetVisibleFixedWidth) then

    ColumnLeft := -FHeader.Treeview.FEffectiveOffsetX

  else

    ColumnLeft := 0;



  if FHeader.Treeview.UseRightToLeftAlignment then

    Inc(ColumnLeft, FHeader.Treeview.ComputeRTLOffset(True));



  for I := 0 to Count - 1 do

    with Items[FPositionToIndex[I]] do

      if coVisible in FOptions then

      begin

        ColumnRight := ColumnLeft + FWidth;

        if P.X < ColumnRight then

        begin

          Result := FPositionToIndex[I];

          Exit;

        end;

        ColumnLeft := ColumnRight;

      end;

end;



//----------------------------------------------------------------------------------------------------------------------



function TVirtualTreeColumns.GetOwner: TPersistent;



begin

  Result := FHeader;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TVirtualTreeColumns.HandleClick(P: TPoint; Button: TMouseButton; Force, DblClick: Boolean);



// Generates a click event if the mouse button has been released over the same column it was pressed first.

// Alternatively, Force might be set to True to indicate that the down index does not matter (right, middle and

// double click).



var

  HitInfo: TVTHeaderHitInfo;

  NewClickIndex: Integer;



begin

  if (csDesigning in Header.Treeview.ComponentState) then

    exit;

  // Convert vertical position to local coordinates.

  Inc(P.Y, FHeader.FHeight);

  NewClickIndex := ColumnFromPosition(P);

  with HitInfo do

  begin

    X := P.X;

    Y := P.Y;

    Shift := FHeader.GetShiftState;

    if DblClick then

      Shift := Shift + [ssDouble];

  end;

  HitInfo.Button := Button;



  if (NewClickIndex > NoColumn) and (coAllowClick in Items[NewClickIndex].FOptions) and

    ((NewClickIndex = FDownIndex) or Force) then

  begin

    FClickIndex := NewClickIndex;

    HitInfo.Column := NewClickIndex;

    HitInfo.HitPosition := [hhiOnColumn];



    if Items[NewClickIndex].FHasImage and PtInRect(Items[NewClickIndex].FImageRect, P) then

    begin

      Include(HitInfo.HitPosition, hhiOnIcon);

      if Items[NewClickIndex].CheckBox then

      begin

        if Button = mbLeft then

          FHeader.Treeview.UpdateColumnCheckState(Items[NewClickIndex]);

        Include(HitInfo.HitPosition, hhiOnCheckbox);

      end;

    end;

  end

  else

  begin

    FClickIndex := NoColumn;

    HitInfo.Column := NoColumn;

    HitInfo.HitPosition := [hhiNoWhere];

  end;



  if (hoHeaderClickAutoSort in Header.Options) and (HitInfo.Button = mbLeft) and not DblClick and not (hhiOnCheckbox in HitInfo.HitPosition) and (HitInfo.Column >= 0) then

  begin

    // handle automatic setting of SortColumn and toggling of the sort order

    if HitInfo.Column <> Header.SortColumn then

    begin

      // set sort column

      Header.SortColumn := HitInfo.Column;

      Header.SortDirection := Self[Header.SortColumn].DefaultSortDirection;

    end//if

    else

    begin

      // toggle sort direction

      if Header.SortDirection = sdDescending then

        Header.SortDirection := sdAscending

      else

        Header.SortDirection := sdDescending;

    end;//else

  end;//if



  if DblClick then

    FHeader.Treeview.DoHeaderDblClick(HitInfo)

  else

    FHeader.Treeview.DoHeaderClick(HitInfo);



  if not (hhiNoWhere in HitInfo.HitPosition) then

    FHeader.Invalidate(Items[NewClickIndex]);

  if (FClickIndex > NoColumn) and (FClickIndex <> NewClickIndex) then

    FHeader.Invalidate(Items[FClickIndex]);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TVirtualTreeColumns.IndexChanged(OldIndex, NewIndex: Integer);



// Called by a column when its index in the collection changes. If NewIndex is -1 then the column is

// about to be removed, otherwise it is moved to a new index.

// The method will then update the position array to reflect the change.



var

  I: Integer;

  Increment: Integer;

  Lower,

  Upper: Integer;



begin

  if NewIndex = -1 then

  begin

    // Find position in the array with the old index.

    Upper := High(FPositionToIndex);

    for I := 0 to Upper do

    begin

      if FPositionToIndex[I] = OldIndex then

      begin

        // Index found. Move all higher entries one step down and remove the last entry.

        if I < Upper then

          Move(FPositionToIndex[I + 1], FPositionToIndex[I], (Upper - I) * SizeOf(TColumnIndex));

      end;

      // Decrease all indices, which are greater than the index to be deleted.

      if FPositionToIndex[I] > OldIndex then

        Dec(FPositionToIndex[I]);

    end;

    SetLength(FPositionToIndex, High(FPositionToIndex));

  end

  else

  begin

    if OldIndex < NewIndex then

      Increment := -1

    else

      Increment := 1;



    Lower := Min(OldIndex, NewIndex);

    Upper := Max(OldIndex, NewIndex);

    for I := 0 to High(FPositionToIndex) do

    begin

      if (FPositionToIndex[I] >= Lower) and (FPositionToIndex[I] < Upper) then

        Inc(FPositionToIndex[I], Increment)

      else

        if FPositionToIndex[I] = OldIndex then

          FPositionToIndex[I] := NewIndex;

    end;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TVirtualTreeColumns.InitializePositionArray;



// Ensures that the column position array contains as many entries as columns are defined.

// The array is resized and initialized with default values if needed.



var

  I, OldSize: Integer;

  Changed: Boolean;



begin

  if Count <> Length(FPositionToIndex) then

  begin

    OldSize := Length(FPositionToIndex);

    SetLength(FPositionToIndex, Count);

    if Count > OldSize then

    begin

      // New items have been added, just set their position to the same as their index.

      for I := OldSize to Count - 1 do

        FPositionToIndex[I] := I;

    end

    else

    begin

      // Items have been deleted, so reindex remaining entries by decrementing values larger than the highest

      // possible index until no entry is higher than this limit.

      repeat

        Changed := False;

        for I := 0 to Count - 1 do

          if FPositionToIndex[I] >= Count then

          begin

            Dec(FPositionToIndex[I]);

            Changed := True;

          end;

      until not Changed;

    end;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TVirtualTreeColumns.Notify(Item: TCollectionItem; Action: TCollectionNotification);



begin

  if Action in [cnExtracting, cnDeleting] then

    with Header.Treeview do

      if not (csLoading in ComponentState) and (FFocusedColumn = Item.Index) then

        FFocusedColumn := NoColumn;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TVirtualTreeColumns.ReorderColumns(RTL: Boolean);



var

  I: Integer;



begin

  if RTL then

  begin

    for I := 0 to Count - 1 do

      FPositionToIndex[I] := Count - I - 1;

  end

  else

  begin

    for I := 0 to Count - 1 do

      FPositionToIndex[I] := I;

  end;



  UpdatePositions(True);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TVirtualTreeColumns.Update(Item: TCollectionItem);



begin

  // This is the only place which gets notified when a new column has been added or removed

  // and we need this event to adjust the column position array.

  InitializePositionArray;

  if csLoading in Header.Treeview.ComponentState then

    FNeedPositionsFix := True

  else

    UpdatePositions;



  // The first column which is created is by definition also the main column.

  if (Count > 0) and (Header.FMainColumn < 0) then

    FHeader.FMainColumn := 0;



  if not (csLoading in Header.Treeview.ComponentState) and not (hsLoading in FHeader.FStates) then

  begin

    with FHeader do

    begin

      if hoAutoResize in FOptions then

        AdjustAutoSize(InvalidColumn);

      if Assigned(Item) then

        Invalidate(Item as TVirtualTreeColumn)

      else

        if Treeview.HandleAllocated then

        begin

          Treeview.UpdateHorizontalScrollBar(False);

          Invalidate(nil);

          Treeview.Invalidate;

        end;



      if not (tsUpdating in Treeview.FStates) then

        // This is mainly to let the designer know when a change occurs at design time which

        // doesn't involve the object inspector (like column resizing with the mouse).

        // This does NOT include design time code as the communication is done via an interface.

        Treeview.UpdateDesigner;

    end;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TVirtualTreeColumns.UpdatePositions(Force: Boolean = False);



// Recalculates the left border of every column and updates their position property according to the

// PostionToIndex array which primarily determines where each column is placed visually.



var

  I, RunningPos: Integer;



begin

  if not FNeedPositionsFix and (Force or (UpdateCount = 0)) then

  begin

    RunningPos := 0;

    for I := 0 to High(FPositionToIndex) do

      with Items[FPositionToIndex[I]] do

      begin

        FPosition := I;

        FLeft := RunningPos;

        if coVisible in FOptions then

          Inc(RunningPos, FWidth);

      end;

    FHeader.Treeview.UpdateHorizontalScrollBar(False);

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



function TVirtualTreeColumns.Add: TVirtualTreeColumn;



begin

  Result := TVirtualTreeColumn(inherited Add);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TVirtualTreeColumns.AnimatedResize(Column: TColumnIndex; NewWidth: Integer);



// Resizes the given column animated by scrolling the window DC.



var

  OldWidth: Integer;

  DC: HDC;

  I,

  Steps,

  DX: Integer;

  HeaderScrollRect,

  ScrollRect,

  R: TRect;



  NewBrush,

  LastBrush: HBRUSH;



begin

  if not IsValidColumn(Column) then

    Exit; // Just in case.



  // Make sure the width constrains are considered.

  if NewWidth < Items[Column].FMinWidth then

     NewWidth := Items[Column].FMinWidth;

  if NewWidth > Items[Column].FMaxWidth then

     NewWidth := Items[Column].FMaxWidth;



  OldWidth := Items[Column].Width;

  // Nothing to do if the width is the same.

  if OldWidth <> NewWidth then

  begin

    if not ( (hoDisableAnimatedResize in FHeader.Options) or

             (coDisableAnimatedResize in Items[Column].Options) ) then

    begin

      DC := GetWindowDC(FHeader.Treeview.Handle);

      with FHeader.Treeview do

      try

        Steps := 32;

        DX := (NewWidth - OldWidth) div Steps;



        // Determination of the scroll rectangle is a bit complicated since we neither want

        // to scroll the scrollbars nor the border of the treeview window.

        HeaderScrollRect := FHeaderRect;

        ScrollRect := HeaderScrollRect;

        // Exclude the header itself from scrolling.

        ScrollRect.Top := ScrollRect.Bottom;

        ScrollRect.Bottom := ScrollRect.Top + ClientHeight;

        ScrollRect.Right := ScrollRect.Left + ClientWidth;

        with Items[Column] do

          Inc(ScrollRect.Left, FLeft + FWidth);

        HeaderScrollRect.Left := ScrollRect.Left;

        HeaderScrollRect.Right := ScrollRect.Right;



        // When the new width is larger then avoid artefacts on the left hand side

        // by deleting a small stripe

        if NewWidth > OldWidth then

        begin

          R := ScrollRect;

          NewBrush := CreateSolidBrush(ColorToRGB(Color));

          LastBrush := SelectObject(DC, NewBrush);

          R.Right := R.Left + DX;

          FillRect(DC, R, NewBrush);

          SelectObject(DC, LastBrush);

          DeleteObject(NewBrush);

        end

        else

        begin

          Inc(HeaderScrollRect.Left, DX);

          Inc(ScrollRect.Left, DX);

        end;



        for I := 0 to Steps - 1 do

        begin

          ScrollDC(DC, DX, 0, HeaderScrollRect, HeaderScrollRect, 0, nil);

          Inc(HeaderScrollRect.Left, DX);

          ScrollDC(DC, DX, 0, ScrollRect, ScrollRect, 0, nil);

          Inc(ScrollRect.Left, DX);

          Sleep(1);

        end;

      finally

        ReleaseDC(Handle, DC);

      end;

    end;

    Items[Column].Width := NewWidth;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TVirtualTreeColumns.Assign(Source: TPersistent);



begin

  // Let the collection class assign the items.

  inherited;



  if Source is TVirtualTreeColumns then

  begin

    // Copying the position array is the only needed task here.

    FPositionToIndex := Copy(TVirtualTreeColumns(Source).FPositionToIndex, 0, MaxInt);



    // Make sure the left edges are correct after assignment.

    FNeedPositionsFix := False;

    UpdatePositions(True);

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TVirtualTreeColumns.Clear;



begin

  FClearing := True;

  try

    Header.Treeview.CancelEditNode;



    // Since we're freeing all columns, the following have to be true when we're done.

    FHoverIndex := NoColumn;

    FDownIndex := NoColumn;

    FTrackIndex := NoColumn;

    FClickIndex := NoColumn;

    FCheckBoxHit := False;



    with Header do

      if not (hsLoading in FStates) then

      begin

        FAutoSizeIndex := NoColumn;

        FMainColumn := NoColumn;

        FSortColumn := NoColumn;

      end;



    with Header.Treeview do

      if not (csLoading in ComponentState) then

        FFocusedColumn := NoColumn;



    inherited Clear;

  finally

    FClearing := False;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



function TVirtualTreeColumns.ColumnFromPosition(P: TPoint; Relative: Boolean = True): TColumnIndex;



// Determines the current column based on the position passed in P.



var

  I, Sum: Integer;



begin

  Result := InvalidColumn;



  // The position must be within the header area, but we extend the vertical bounds to the entire treeview area.

  if (P.X >= 0) and (P.Y >= 0) and (P.Y <= FHeader.TreeView.Height) then

    with FHeader, Treeview do

    begin

      if Relative and (P.X >= GetVisibleFixedWidth) then

        Sum := -FEffectiveOffsetX

      else

        Sum := 0;



      if UseRightToLeftAlignment then

        Inc(Sum, ComputeRTLOffset(True));



      for I := 0 to Count - 1 do

        if coVisible in Items[FPositionToIndex[I]].FOptions then

        begin

          Inc(Sum, Items[FPositionToIndex[I]].Width);

          if P.X < Sum then

          begin

            Result := FPositionToIndex[I];

            Break;

          end;

        end;

    end;

end;



//----------------------------------------------------------------------------------------------------------------------



function TVirtualTreeColumns.ColumnFromPosition(PositionIndex: TColumnPosition): TColumnIndex;



// Returns the index of the column at the given position.



begin

  if Integer(PositionIndex) < Length(FPositionToIndex) then

    Result := FPositionToIndex[PositionIndex]

  else

    Result := NoColumn;

end;



//----------------------------------------------------------------------------------------------------------------------



function TVirtualTreeColumns.Equals(OtherColumnsObj: TObject): Boolean;



// Compares itself with the given set of columns and returns True if all published properties are the same

// (including column order), otherwise False is returned.



var

  I: Integer;

  OtherColumns : TVirtualTreeColumns;



begin

  if not (OtherColumnsObj is TVirtualTreeColumns) then

  begin

    Result := False;

    Exit;

  end;



  OtherColumns := TVirtualTreeColumns (OtherColumnsObj);



  // Same number of columns?

  Result := OtherColumns.Count = Count;

  if Result then

  begin

    // Same order of columns?

    Result := CompareMem(Pointer(FPositionToIndex), Pointer(OtherColumns.FPositionToIndex),

      Length(FPositionToIndex) * SizeOf(TColumnIndex));

    if Result then

    begin

      for I := 0 to Count - 1 do

        if not Items[I].Equals(OtherColumns[I]) then

        begin

          Result := False;

          Break;

        end;

    end;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TVirtualTreeColumns.GetColumnBounds(Column: TColumnIndex; var Left, Right: Integer);



// Returns the left and right bound of the given column. If Column is NoColumn then the entire client width is returned.



begin

  if Column <= NoColumn then

  begin

    Left := 0;

    Right := FHeader.Treeview.ClientWidth;

  end

  else

  begin

    Left := Items[Column].Left;

    Right := Left + Items[Column].Width;

    if FHeader.Treeview.UseRightToLeftAlignment then

    begin

      Inc(Left, FHeader.Treeview.ComputeRTLOffset(True));

      Inc(Right, FHeader.Treeview.ComputeRTLOffset(True));

    end;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



function TVirtualTreeColumns.GetScrollWidth: Integer;



// Returns the average width of all visible, non-fixed columns. If there is no such column the indent is returned.



var

  I: Integer;

  ScrollColumnCount: Integer;



begin



  Result := 0;



  ScrollColumnCount := 0;

  for I := 0 to FHeader.Columns.Count - 1 do

  begin

    if ([coVisible, coFixed] * FHeader.Columns[I].Options = [coVisible]) then

    begin

      Inc(Result, FHeader.Columns[I].Width);

      Inc(ScrollColumnCount);

    end;

  end;



  if ScrollColumnCount > 0 then // use average width

    Result := Round(Result / ScrollColumnCount)

  else // use indent

    Result := Integer(FHeader.Treeview.FIndent);



end;



//----------------------------------------------------------------------------------------------------------------------



function TVirtualTreeColumns.GetFirstVisibleColumn(ConsiderAllowFocus: Boolean = False): TColumnIndex;



// Returns the index of the first visible column or "InvalidColumn" if either no columns are defined or

// all columns are hidden.

// If ConsiderAllowFocus is True then the column has not only to be visible but also focus has to be allowed.



var

  I: Integer;



begin

  Result := InvalidColumn;

  for I := 0 to Count - 1 do

    if (coVisible in Items[FPositionToIndex[I]].FOptions) and

       ( (not ConsiderAllowFocus) or

         (coAllowFocus in Items[FPositionToIndex[I]].FOptions)

       ) then

    begin

      Result := FPositionToIndex[I];

      Break;

    end;

end;



//----------------------------------------------------------------------------------------------------------------------



function TVirtualTreeColumns.GetLastVisibleColumn(ConsiderAllowFocus: Boolean = False): TColumnIndex;



// Returns the index of the last visible column or "InvalidColumn" if either no columns are defined or

// all columns are hidden.

// If ConsiderAllowFocus is True then the column has not only to be visible but also focus has to be allowed.



var

  I: Integer;



begin

  Result := InvalidColumn;

  for I := Count - 1 downto 0 do

    if (coVisible in Items[FPositionToIndex[I]].FOptions) and

       ( (not ConsiderAllowFocus) or

         (coAllowFocus in Items[FPositionToIndex[I]].FOptions)

       ) then

    begin

      Result := FPositionToIndex[I];

      Break;

    end;

end;



//----------------------------------------------------------------------------------------------------------------------



function TVirtualTreeColumns.GetFirstColumn: TColumnIndex;



// Returns the first column in display order.



begin

  if Count = 0 then

    Result := InvalidColumn

  else

    Result := FPositionToIndex[0];

end;



//----------------------------------------------------------------------------------------------------------------------



function TVirtualTreeColumns.GetNextColumn(Column: TColumnIndex): TColumnIndex;



// Returns the next column in display order. Column is the index of an item in the collection (a column).



var

  Position: Integer;



begin

  if Column < 0 then

    Result := InvalidColumn

  else

  begin

    Position := Items[Column].Position;

    if Position < Count - 1 then

      Result := FPositionToIndex[Position + 1]

    else

      Result := InvalidColumn;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



function TVirtualTreeColumns.GetNextVisibleColumn(Column: TColumnIndex; ConsiderAllowFocus: Boolean = False): TColumnIndex;



// Returns the next visible column in display order, Column is an index into the columns list.

// If ConsiderAllowFocus is True then the column has not only to be visible but also focus has to be allowed.



begin

  Result := Column;

  repeat

    Result := GetNextColumn(Result);

  until (Result = InvalidColumn) or

        ( (coVisible in Items[Result].FOptions) and

          ( (not ConsiderAllowFocus) or

            (coAllowFocus in Items[Result].FOptions)

          )

        );

end;



//----------------------------------------------------------------------------------------------------------------------



function TVirtualTreeColumns.GetPreviousColumn(Column: TColumnIndex): TColumnIndex;



// Returns the previous column in display order, Column is an index into the columns list.



var

  Position: Integer;



begin

  if Column < 0 then

    Result := InvalidColumn

  else

  begin

    Position := Items[Column].Position;

    if Position > 0 then

      Result := FPositionToIndex[Position - 1]

    else

      Result := InvalidColumn;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



function TVirtualTreeColumns.GetPreviousVisibleColumn(Column: TColumnIndex; ConsiderAllowFocus: Boolean = False): TColumnIndex;



// Returns the previous visible column in display order, Column is an index into the columns list.

// If ConsiderAllowFocus is True then the column has not only to be visible but also focus has to be allowed.



begin

  Result := Column;

  repeat

    Result := GetPreviousColumn(Result);

  until (Result = InvalidColumn) or

        ( (coVisible in Items[Result].FOptions) and

          ( (not ConsiderAllowFocus) or

            (coAllowFocus in Items[Result].FOptions)

          )

        );

end;



//----------------------------------------------------------------------------------------------------------------------



function TVirtualTreeColumns.GetVisibleColumns: TColumnsArray;



// Returns a list of all currently visible columns in actual order.



var

  I, Counter: Integer;



begin

  SetLength(Result, Count);

  Counter := 0;



  for I := 0 to Count - 1 do

    if coVisible in Items[FPositionToIndex[I]].FOptions then

    begin

      Result[Counter] := Items[FPositionToIndex[I]];

      Inc(Counter);

    end;

  // Set result length to actual visible count.

  SetLength(Result, Counter);

end;



//----------------------------------------------------------------------------------------------------------------------



function TVirtualTreeColumns.GetVisibleFixedWidth: Integer;



// Determines the horizontal space all visible and fixed columns occupy.



var

  I: Integer;



begin

  Result := 0;

  for I := 0 to Count - 1 do

  begin

    if Items[I].Options * [coVisible, coFixed] = [coVisible, coFixed] then

      Inc(Result, Items[I].Width);

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



function TVirtualTreeColumns.IsValidColumn(Column: TColumnIndex): Boolean;



// Determines whether the given column is valid or not, that is, whether it is one of the current columns.



begin

  Result := (Column > NoColumn) and (Column < Count);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TVirtualTreeColumns.LoadFromStream(const Stream: TStream; Version: Integer);



var

  I,

  ItemCount: Integer;



begin

  Clear;

  Stream.ReadBuffer(ItemCount, SizeOf(ItemCount));

  // number of columns

  if ItemCount > 0 then

  begin

    BeginUpdate;

    try

      for I := 0 to ItemCount - 1 do

        Add.LoadFromStream(Stream, Version);

      SetLength(FPositionToIndex, ItemCount);

      Stream.ReadBuffer(FPositionToIndex[0], ItemCount * SizeOf(TColumnIndex));

      UpdatePositions(True);

    finally

      EndUpdate;

    end;

  end;



  // Data introduced with header stream version 5

  if Version > 4 then

    Stream.ReadBuffer(FDefaultWidth, SizeOf(FDefaultWidth));

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TVirtualTreeColumns.PaintHeader(DC: HDC; R: TRect; HOffset: Integer);



// Backward compatible header paint method. This method takes care of visually moving floating columns



var

  VisibleFixedWidth: Integer;

  RTLOffset: Integer;



  procedure PaintFixedArea;

  

  begin

    if VisibleFixedWidth > 0 then

      PaintHeader(FHeaderBitmap.Canvas,

        Rect(0, 0, Min(R.Right, VisibleFixedWidth), R.Bottom - R.Top),

        Point(R.Left, R.Top), RTLOffset);

  end;



begin

  // Adjust size of the header bitmap

  with TWithSafeRect(FHeader.Treeview.FHeaderRect) do

  begin

    FHeaderBitmap.Width := Max(Right, R.Right - R.Left);

    FHeaderBitmap.Height := Bottom;

  end;



  VisibleFixedWidth := GetVisibleFixedWidth;



  // Consider right-to-left directionality.

  if FHeader.TreeView.UseRightToLeftAlignment then

    RTLOffset := FHeader.Treeview.ComputeRTLOffset

  else

    RTLOffset := 0;

    

  if RTLOffset = 0 then

    PaintFixedArea;



  // Paint the floating part of the header.

  PaintHeader(FHeaderBitmap.Canvas,

    Rect(VisibleFixedWidth - HOffset, 0, R.Right + VisibleFixedWidth - HOffset, R.Bottom - R.Top),

    Point(R.Left + VisibleFixedWidth, R.Top), RTLOffset);



  // In case of right-to-left directionality we paint the fixed part last.

  if RTLOffset <> 0 then

    PaintFixedArea;

  

  // Blit the result to target.

  with TWithSafeRect(R) do

    BitBlt(DC, Left, Top, Right - Left, Bottom - Top, FHeaderBitmap.Canvas.Handle, Left, Top, SRCCOPY);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TVirtualTreeColumns.PaintHeader(TargetCanvas: TCanvas; R: TRect; const Target: TPoint;

  RTLOffset: Integer = 0);



// Main paint method to draw the header.

// This procedure will paint the a slice (given in R) out of HeaderRect into TargetCanvas starting at position Target.

// This function does not offer the option to visually move floating columns due to scrolling. To accomplish this you

// need to call this method twice.



const

  SortGlyphs: array[TSortDirection, Boolean] of Integer = ( // ascending/descending, normal/XP style

    (3, 5) {ascending}, (2, 4) {descending}

  );



var

  Run: TColumnIndex;

  RightBorderFlag,

  NormalButtonStyle,

  NormalButtonFlags,

  PressedButtonStyle,

  PressedButtonFlags,

  RaisedButtonStyle,

  RaisedButtonFlags: Cardinal;

  Images: TCustomImageList;

  OwnerDraw,

  AdvancedOwnerDraw: Boolean;

  PaintInfo: THeaderPaintInfo;

  RequestedElements,

  ActualElements: THeaderPaintElements;



  //--------------- local functions -------------------------------------------



  procedure PrepareButtonStyles;



  // Prepare the button styles and flags for later usage.



  begin

    RaisedButtonStyle := 0;

    RaisedButtonFlags := 0;

    case FHeader.Style of

      hsThickButtons:

        begin

          NormalButtonStyle := BDR_RAISEDINNER or BDR_RAISEDOUTER;

          NormalButtonFlags := BF_LEFT or BF_TOP or BF_BOTTOM or BF_MIDDLE or BF_SOFT or BF_ADJUST;

          PressedButtonStyle := BDR_RAISEDINNER or BDR_RAISEDOUTER;

          PressedButtonFlags := NormalButtonFlags or BF_RIGHT or BF_FLAT or BF_ADJUST;

        end;

      hsFlatButtons:

        begin

          NormalButtonStyle := BDR_RAISEDINNER;

          NormalButtonFlags := BF_LEFT or BF_TOP or BF_BOTTOM or BF_MIDDLE or BF_ADJUST;

          PressedButtonStyle := BDR_SUNKENOUTER;

          PressedButtonFlags := BF_RECT or BF_MIDDLE or BF_ADJUST;

        end;

    else

      // hsPlates or hsXPStyle, values are not used in the latter case

      begin

        NormalButtonStyle := BDR_RAISEDINNER;

        NormalButtonFlags := BF_RECT or BF_MIDDLE or BF_SOFT or BF_ADJUST;

        PressedButtonStyle := BDR_SUNKENOUTER;

        PressedButtonFlags := BF_RECT or BF_MIDDLE or BF_ADJUST;

        RaisedButtonStyle := BDR_RAISEDINNER;

        RaisedButtonFlags := BF_LEFT or BF_TOP or BF_BOTTOM or BF_MIDDLE or BF_ADJUST;

      end;

    end;

  end;



  //---------------------------------------------------------------------------



  procedure DrawBackground;



  // Draw the header background.



  var

    BackgroundRect: TRect;

    Details: TThemedElementDetails;



  begin

    BackgroundRect := Rect(Target.X, Target.Y, Target.X + R.Right - R.Left, Target.Y + FHeader.Height);



    with TargetCanvas do

      begin

      if hpeBackground in RequestedElements then

      begin

        PaintInfo.PaintRectangle := BackgroundRect;

        FHeader.Treeview.DoAdvancedHeaderDraw(PaintInfo, [hpeBackground]);

      end  

      else

      begin

        if tsUseThemes in FHeader.Treeview.FStates then

        begin

          Details := StyleServices.GetElementDetails(thHeaderItemRightNormal);

          StyleServices.DrawElement(Handle, Details, BackgroundRect, @BackgroundRect);

        end

        else

        begin

          Brush.Color := FHeader.FBackground;

          FillRect(BackgroundRect);

        end;

      end;

    end;

  end;



  //---------------------------------------------------------------------------



  procedure PaintColumnHeader(AColumn: TColumnIndex; ATargetRect: TRect);



  // Draw a single column to TargetRect. The clipping rect needs to be set before

  // this procedure is called.



  var

    Y: Integer;

    SavedDC: Integer;

    ColCaptionText: UnicodeString;

    ColImageInfo: TVTImageInfo;

    SortIndex: Integer;

    SortGlyphSize: TSize;

    Glyph: TThemedHeader;

    Details: TThemedElementDetails;

    WrapCaption: Boolean;

    DrawFormat: Cardinal;

    Pos: TRect;

    DrawHot: Boolean;

    ImageWidth: Integer;

  begin

    ColImageInfo.Ghosted := False;

    PaintInfo.Column := Items[AColumn];

    with PaintInfo, Column do

    begin

      IsHoverIndex := (AColumn = FHoverIndex) and (hoHotTrack in FHeader.FOptions) and (coEnabled in FOptions);

      IsDownIndex := (AColumn = FDownIndex) and not FCheckBoxHit;



      if (coShowDropMark in FOptions) and (AColumn = FDropTarget) and (AColumn <> FDragIndex) then

      begin

        if FDropBefore then

          DropMark := dmmLeft

        else

          DropMark := dmmRight;

      end

      else

        DropMark := dmmNone;



      IsEnabled := (coEnabled in FOptions) and (FHeader.Treeview.Enabled);

      ShowHeaderGlyph := (hoShowImages in FHeader.FOptions) and ((Assigned(Images) and (FImageIndex > -1)) or FCheckBox);

      ShowSortGlyph := (AColumn = FHeader.FSortColumn) and (hoShowSortGlyphs in FHeader.FOptions);

      WrapCaption := coWrapCaption in FOptions;



      PaintRectangle := ATargetRect;



      // This path for text columns or advanced owner draw.

      if (Style = vsText) or not OwnerDraw or AdvancedOwnerDraw then

      begin

        // See if the application wants to draw part of the header itself.

        RequestedElements := [];

        if AdvancedOwnerDraw then

        begin

          PaintInfo.Column := Items[AColumn];

          FHeader.Treeview.DoHeaderDrawQueryElements(PaintInfo, RequestedElements);

        end;



        if ShowRightBorder or (AColumn < Count - 1) then

          RightBorderFlag := BF_RIGHT

        else

          RightBorderFlag := 0;



        if hpeBackground in RequestedElements then

          FHeader.Treeview.DoAdvancedHeaderDraw(PaintInfo, [hpeBackground])

        else

        begin

          if tsUseThemes in FHeader.Treeview.FStates then

          begin

            if IsDownIndex then

              Details := StyleServices.GetElementDetails(thHeaderItemPressed)

            else

              if IsHoverIndex then

                Details := StyleServices.GetElementDetails(thHeaderItemHot)

              else

                Details := StyleServices.GetElementDetails(thHeaderItemNormal);

            StyleServices.DrawElement(TargetCanvas.Handle, Details, PaintRectangle, @PaintRectangle);

          end

          else

          begin

            if IsDownIndex then

              DrawEdge(TargetCanvas.Handle, PaintRectangle, PressedButtonStyle, PressedButtonFlags)

            else

              // Plates have the special case of raising on mouse over.

              if (FHeader.Style = hsPlates) and IsHoverIndex and

                (coAllowClick in FOptions) and (coEnabled in FOptions) then

                DrawEdge(TargetCanvas.Handle, PaintRectangle, RaisedButtonStyle,

                         RaisedButtonFlags or RightBorderFlag)

              else

                DrawEdge(TargetCanvas.Handle, PaintRectangle, NormalButtonStyle,

                         NormalButtonFlags or RightBorderFlag);

          end;

        end;



        PaintRectangle := ATargetRect;



        // calculate text and glyph position

        InflateRect(PaintRectangle, -2, -2);

        DrawFormat := DT_TOP or DT_NOPREFIX;

        case CaptionAlignment of

          taLeftJustify  : DrawFormat := DrawFormat or DT_LEFT;

          taRightJustify : DrawFormat := DrawFormat or DT_RIGHT;

          taCenter       : DrawFormat := DrawFormat or DT_CENTER;

        end;

        if UseRightToLeftReading then

          DrawFormat := DrawFormat + DT_RTLREADING;

        ComputeHeaderLayout(TargetCanvas.Handle, PaintRectangle, ShowHeaderGlyph, ShowSortGlyph, GlyphPos,

          SortGlyphPos, SortGlyphSize, TextRectangle, DrawFormat);



        // Move glyph and text one pixel to the right and down to simulate a pressed button.

        if IsDownIndex then

        begin

          OffsetRect(TextRectangle, 1, 1);

          Inc(GlyphPos.X);

          Inc(GlyphPos.Y);

          Inc(SortGlyphPos.X);

          Inc(SortGlyphPos.Y);

        end;



        // Advanced owner draw allows to paint elements, which would normally not be painted (because of space

        // limitations, empty captions etc.).

        ActualElements := RequestedElements * [hpeHeaderGlyph, hpeSortGlyph, hpeDropMark, hpeText];



        // main glyph

        FHasImage := False;

        if Assigned(Images) then

          ImageWidth := Images.Width

        else

          ImageWidth := 0;



        if not (hpeHeaderGlyph in ActualElements) and ShowHeaderGlyph and

          (not ShowSortGlyph or (FBiDiMode <> bdLeftToRight) or (GlyphPos.X + ImageWidth <= SortGlyphPos.X) ) then

        begin

          if not FCheckBox then

          begin

            ColImageInfo.Images := Images;

            Images.Draw(TargetCanvas, GlyphPos.X, GlyphPos.Y, FImageIndex, IsEnabled);

          end

          else

          begin

            with Header.Treeview do

            begin

              ColImageInfo.Images := GetCheckImageListFor(CheckImageKind);

              ColImageInfo.Index := GetCheckImage(nil, FCheckType, FCheckState, IsEnabled);

              ColImageInfo.XPos := GlyphPos.X;

              ColImageInfo.YPos := GlyphPos.Y;

              PaintCheckImage(TargetCanvas, ColImageInfo, False);

            end;

          end;



          FHasImage := True;

          with TWithSafeRect(FImageRect) do

          begin

            Left := GlyphPos.X;

            Top := GlyphPos.Y;

            Right := Left + ColImageInfo.Images.Width;

            Bottom := Top + ColImageInfo.Images.Height;

          end;

        end;



        // caption

        if WrapCaption then

          ColCaptionText := FCaptionText

        else

          ColCaptionText := Text;

          if IsHoverIndex and FHeader.Treeview.VclStyleEnabled then

            DrawHot := True

          else

            DrawHot := (IsHoverIndex and (hoHotTrack in FHeader.FOptions) and not(tsUseThemes in FHeader.Treeview.FStates));

          if not(hpeText in ActualElements) and (Length(Text) > 0) then

            DrawButtonText(TargetCanvas.Handle, ColCaptionText, TextRectangle, IsEnabled, DrawHot, DrawFormat, WrapCaption);



        // sort glyph

        if not (hpeSortGlyph in ActualElements) and ShowSortGlyph then

        begin

          if tsUseExplorerTheme in FHeader.Treeview.FStates then

          begin

            Pos.TopLeft := SortGlyphPos;

            Pos.Right := Pos.Left + SortGlyphSize.cx;

            Pos.Bottom := Pos.Top + SortGlyphSize.cy;

            if FHeader.FSortDirection = sdAscending then

              Glyph := thHeaderSortArrowSortedUp

            else

              Glyph := thHeaderSortArrowSortedDown;

            Details := StyleServices.GetElementDetails(Glyph);

            StyleServices.DrawElement(TargetCanvas.Handle, Details, Pos, @Pos);

          end

          else

          begin

            SortIndex := SortGlyphs[FHeader.FSortDirection, tsUseThemes in FHeader.Treeview.FStates];

            UtilityImages.Draw(TargetCanvas, SortGlyphPos.X, SortGlyphPos.Y, SortIndex);

          end;

        end;



        // Show an indication if this column is the current drop target in a header drag operation.

        if not (hpeDropMark in ActualElements) and (DropMark <> dmmNone) then

        begin

          Y := (PaintRectangle.Top + PaintRectangle.Bottom - UtilityImages.Height) div 2;

          if DropMark = dmmLeft then

            UtilityImages.Draw(TargetCanvas, PaintRectangle.Left, Y, 0)

          else

            UtilityImages.Draw(TargetCanvas, PaintRectangle.Right - 16 , Y,  1);

        end;



        if ActualElements <> [] then

        begin

          SavedDC := SaveDC(TargetCanvas.Handle);

          FHeader.Treeview.DoAdvancedHeaderDraw(PaintInfo, ActualElements);

          RestoreDC(TargetCanvas.Handle, SavedDC);

        end;

      end

      else // Let application draw the header.

        FHeader.Treeview.DoHeaderDraw(TargetCanvas, Items[AColumn], PaintRectangle, IsHoverIndex, IsDownIndex,

          DropMark);

    end;

  end;



  //--------------- end local functions ---------------------------------------



var

  TargetRect: TRect;

  MaxX: Integer;



begin

  if IsRectEmpty(R) then

    Exit;



  // If both draw posibillities are specified then prefer the advanced way.

  AdvancedOwnerDraw := (hoOwnerDraw in FHeader.FOptions) and Assigned(FHeader.Treeview.FOnAdvancedHeaderDraw) and

    Assigned(FHeader.Treeview.FOnHeaderDrawQueryElements) and not (csDesigning in FHeader.Treeview.ComponentState);

  OwnerDraw := (hoOwnerDraw in FHeader.FOptions) and Assigned(FHeader.Treeview.FOnHeaderDraw) and

    not (csDesigning in FHeader.Treeview.ComponentState) and not AdvancedOwnerDraw;



  ZeroMemory(@PaintInfo, SizeOf(PaintInfo));

  PaintInfo.TargetCanvas := TargetCanvas;



  with PaintInfo, TargetCanvas do

  begin

    // Use shortcuts for the images and the font.

    Images := FHeader.FImages;

    Font := FHeader.FFont;



    PrepareButtonStyles;



    // At first, query the application which parts of the header it wants to draw on its own.

    RequestedElements := [];

    if AdvancedOwnerDraw then

    begin

      PaintRectangle := R;

      Column := nil;

      FHeader.Treeview.DoHeaderDrawQueryElements(PaintInfo, RequestedElements);

    end;



    // Draw the background.

    DrawBackground;



    // Now that we have drawn the background, we apply the header's dimensions to R.

    R := Rect(Max(R.Left, 0), Max(R.Top, 0), Min(R.Right, TotalWidth), Min(R.Bottom, Header.Height));



    // Determine where to stop.

    MaxX := Target.X + R.Right - R.Left;



    // Determine the start column.

    Run := ColumnFromPosition(Point(R.Left + RTLOffset, 0), False);

    if Run <= NoColumn then

      Exit;



    TargetRect.Top := Target.Y;

    TargetRect.Bottom := Target.Y + R.Bottom - R.Top;

    TargetRect.Left := Target.X - R.Left + Items[Run].FLeft + RTLOffset;

    // TargetRect.Right will be set in the loop



    ShowRightBorder := (FHeader.Style = hsThickButtons) or not (hoAutoResize in FHeader.FOptions) or

      (FHeader.Treeview.BevelKind = bkNone);



    // Now go for each button.

    while (Run > NoColumn) and (TargetRect.Left < MaxX) do

    begin

      TargetRect.Right := TargetRect.Left + Items[Run].FWidth;



      // create a clipping rect to limit painting to button area

      ClipCanvas(TargetCanvas, Rect(Max(TargetRect.Left, Target.X), Target.Y + R.Top,

                                    Min(TargetRect.Right, MaxX), TargetRect.Bottom));



      PaintColumnHeader(Run, TargetRect);



      SelectClipRgn(Handle, 0);

      

      TargetRect.Left := TargetRect.Right;

      Run := GetNextVisibleColumn(Run);

    end;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TVirtualTreeColumns.SaveToStream(const Stream: TStream);



var

  I: Integer;



begin

  I := Count;

  Stream.WriteBuffer(I, SizeOf(I));

  if I > 0 then

  begin

    for I := 0 to Count - 1 do

      TVirtualTreeColumn(Items[I]).SaveToStream(Stream);



    Stream.WriteBuffer(FPositionToIndex[0], Count * SizeOf(TColumnIndex));

  end;



  // Data introduced with header stream version 5.

  Stream.WriteBuffer(DefaultWidth, SizeOf(DefaultWidth));

end;



//----------------------------------------------------------------------------------------------------------------------



function TVirtualTreeColumns.TotalWidth: Integer;



var

  LastColumn: TColumnIndex;



begin

  Result := 0;

  if (Count > 0) and (Length(FPositionToIndex) > 0) then

  begin

    LastColumn := FPositionToIndex[Count - 1];

    if not (coVisible in Items[LastColumn].FOptions) then

      LastColumn := GetPreviousVisibleColumn(LastColumn);

    if LastColumn > NoColumn then

      with Items[LastColumn] do

        Result := FLeft + FWidth;

  end;

end;



//----------------- TVTFixedAreaConstraints ----------------------------------------------------------------------------



constructor TVTFixedAreaConstraints.Create(AOwner: TVTHeader);



begin

  inherited Create;



  FHeader := AOwner;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TVTFixedAreaConstraints.SetConstraints(Index: Integer; Value: TVTConstraintPercent);



begin

  case Index of

    0:

      if Value <> FMaxHeightPercent then

      begin

        FMaxHeightPercent := Value;

        if (Value > 0) and (Value < FMinHeightPercent) then

          FMinHeightPercent := Value;

        Change;

      end;

    1:

      if Value <> FMaxWidthPercent then

      begin

        FMaxWidthPercent := Value;

        if (Value > 0) and (Value < FMinWidthPercent) then

          FMinWidthPercent := Value;

        Change;

      end;

    2:

      if Value <> FMinHeightPercent then

      begin

        FMinHeightPercent := Value;

        if (FMaxHeightPercent > 0) and (Value > FMaxHeightPercent) then

          FMaxHeightPercent := Value;

        Change;

      end;

    3:

      if Value <> FMinWidthPercent then

      begin

        FMinWidthPercent := Value;

        if (FMaxWidthPercent > 0) and (Value > FMaxWidthPercent) then

          FMaxWidthPercent := Value;

        Change;

      end;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TVTFixedAreaConstraints.Change;



begin

  if Assigned(FOnChange) then

    FOnChange(Self);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TVTFixedAreaConstraints.Assign(Source: TPersistent);



begin

  if Source is TVTFixedAreaConstraints then

  begin

    FMaxHeightPercent := TVTFixedAreaConstraints(Source).FMaxHeightPercent;

    FMaxWidthPercent := TVTFixedAreaConstraints(Source).FMaxWidthPercent;

    FMinHeightPercent := TVTFixedAreaConstraints(Source).FMinHeightPercent;

    FMinWidthPercent := TVTFixedAreaConstraints(Source).FMinWidthPercent;

    Change;

  end

  else

    inherited;

end;



//----------------- TVTHeader -----------------------------------------------------------------------------------------



constructor TVTHeader.Create(AOwner: TBaseVirtualTree);



begin

  inherited Create;

  FOwner := AOwner;

  FColumns := GetColumnsClass.Create(Self);

  FHeight := 19;

  FDefaultHeight := FHeight;

  FMinHeight := 10;

  FMaxHeight := 10000;

  FFont := TFont.Create;

  FFont.OnChange := FontChanged;

  FParentFont := False;

  FBackground := clBtnFace;

  FOptions := [hoColumnResize, hoDrag, hoShowSortGlyphs];



  FImageChangeLink := TChangeLink.Create;

  FImageChangeLink.OnChange := ImageListChange;



  FSortColumn := NoColumn;

  FSortDirection := sdAscending;

  FMainColumn := NoColumn;



  FDragImage := TVTDragImage.Create(AOwner);

  with FDragImage do

  begin

    Fade := False;

    PostBlendBias := 0;

    PreBlendBias := -50;

    Transparency := 140;

  end;



  FFixedAreaConstraints := TVTFixedAreaConstraints.Create(Self);

  FFixedAreaConstraints.OnChange := FixedAreaConstraintsChanged;

end;



//----------------------------------------------------------------------------------------------------------------------



destructor TVTHeader.Destroy;



begin

  FDragImage.Free;

  FFixedAreaConstraints.Free;

  FImageChangeLink.Free;

  FFont.Free;

  FColumns.Clear; // TCollection's Clear method is not virtual, so we have to call our own Clear method manually.

  FColumns.Free;

  inherited;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TVTHeader.FontChanged(Sender: TObject);

var

  I: Integer;

  lMaxHeight: Integer;

begin

  if toAutoChangeScale in Treeview.TreeOptions.AutoOptions then

  begin

    // Find the largest Columns[].Spacing

    lMaxHeight := 0;

    for I := 0 to Self.Columns.Count - 1 do

      lMaxHeight := Max(lMaxHeight, Columns[I].Spacing);

    // Calculate the required size based on the font, this is important as the use migth just vave increased the size of the icon font

    with TBitmap.Create do

      try

        Canvas.Font.Assign(FFont);

        lMaxHeight := lMaxHeight {top spacing} + (lMaxHeight div 2) {minimum bottom spacing} + Canvas.TextHeight('Q');

      finally

        Free;

      end;

    // Get the maximum of the scaled original value an

    lMaxHeight := Max(lMaxHeight, FHeight);

    // Set the calculated size

    Self.SetHeight(lMaxHeight);

  end;

  Invalidate(nil);

end;



//----------------------------------------------------------------------------------------------------------------------



function TVTHeader.GetMainColumn: TColumnIndex;



begin

  if FColumns.Count > 0 then

    Result := FMainColumn

  else

    Result := NoColumn;

end;



//----------------------------------------------------------------------------------------------------------------------



function TVTHeader.GetUseColumns: Boolean;



begin

  Result := FColumns.Count > 0;

end;



//----------------------------------------------------------------------------------------------------------------------



function TVTHeader.IsFontStored: Boolean;



begin

  Result := not ParentFont;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TVTHeader.SetAutoSizeIndex(Value: TColumnIndex);



begin

  if FAutoSizeIndex <> Value then

  begin

    FAutoSizeIndex := Value;

    if hoAutoResize in FOptions then

      Columns.AdjustAutoSize(InvalidColumn);

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TVTHeader.SetBackground(Value: TColor);



begin

  if FBackground <> Value then

  begin

    FBackground := Value;

    Invalidate(nil);

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TVTHeader.SetColumns(Value: TVirtualTreeColumns);



begin

  FColumns.Assign(Value);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TVTHeader.SetDefaultHeight(Value: Integer);



begin

  if Value < FMinHeight then

    Value := FMinHeight;

  if Value > FMaxHeight then

    Value := FMaxHeight;



  if FHeight = FDefaultHeight then

    SetHeight(Value);

  FDefaultHeight := Value;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TVTHeader.SetFont(const Value: TFont);



begin

  FFont.Assign(Value);

  FParentFont := False;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TVTHeader.SetHeight(Value: Integer);



var

  RelativeMaxHeight,

  RelativeMinHeight,

  EffectiveMaxHeight,

  EffectiveMinHeight: Integer;



begin

  if not TreeView.HandleAllocated then

  begin

    FHeight := Value;

    Include(FStates, hsNeedScaling);

  end

  else

  begin

    with FFixedAreaConstraints do

    begin

      RelativeMaxHeight := ((Treeview.ClientHeight + FHeight) * FMaxHeightPercent) div 100;

      RelativeMinHeight := ((Treeview.ClientHeight + FHeight) * FMinHeightPercent) div 100;



      EffectiveMinHeight := IfThen(FMaxHeightPercent > 0, Min(RelativeMaxHeight, FMinHeight), FMinHeight);

      EffectiveMaxHeight := IfThen(FMinHeightPercent > 0, Max(RelativeMinHeight, FMaxHeight), FMaxHeight);



      Value := Min(Max(Value, EffectiveMinHeight), EffectiveMaxHeight);

      if FMinHeightPercent > 0 then

        Value := Max(RelativeMinHeight, Value);

      if FMaxHeightPercent > 0 then

        Value := Min(RelativeMaxHeight, Value);

    end;



    if FHeight <> Value then

    begin

      FHeight := Value;

      if not (csLoading in Treeview.ComponentState) and not (hsScaling in FStates) then

        RecalculateHeader;

      Treeview.Invalidate;

      UpdateWindow(Treeview.Handle);

    end;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TVTHeader.SetImages(const Value: TCustomImageList);



begin

  if FImages <> Value then

  begin

    if Assigned(FImages) then

    begin

      FImages.UnRegisterChanges(FImageChangeLink);

      FImages.RemoveFreeNotification(FOwner);

    end;

    FImages := Value;

    if Assigned(FImages) then

    begin

      FImages.RegisterChanges(FImageChangeLink);

      FImages.FreeNotification(FOwner);

    end;

    if not (csLoading in Treeview.ComponentState) then

      Invalidate(nil);

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TVTHeader.SetMainColumn(Value: TColumnIndex);



begin

  if csLoading in Treeview.ComponentState then

    FMainColumn := Value

  else

  begin

    if Value < 0 then

      Value := 0;

    if Value > FColumns.Count - 1 then

      Value := FColumns.Count - 1;

    if Value <> FMainColumn then

    begin

      FMainColumn := Value;

      if not (csLoading in Treeview.ComponentState) then

      begin

        Treeview.MainColumnChanged;

        if not (toExtendedFocus in Treeview.FOptions.FSelectionOptions) then

          Treeview.FocusedColumn := FMainColumn;

        Treeview.Invalidate;

      end;

    end;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TVTHeader.SetMaxHeight(Value: Integer);



begin

  if Value < FMinHeight then

    Value := FMinHeight;

  FMaxHeight := Value;

  SetHeight(FHeight);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TVTHeader.SetMinHeight(Value: Integer);



begin

  if Value < 0 then

    Value := 0;

  if Value > FMaxHeight then

    Value := FMaxHeight;

  FMinHeight := Value;

  SetHeight(FHeight);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TVTHeader.SetOptions(Value: TVTHeaderOptions);



var

  ToBeSet,

  ToBeCleared: TVTHeaderOptions;



begin

  ToBeSet := Value - FOptions;

  ToBeCleared := FOptions - Value;

  FOptions := Value;



  if (hoAutoResize in (ToBeSet + ToBeCleared)) and (FColumns.Count > 0) then

  begin

    FColumns.AdjustAutoSize(InvalidColumn);

    if Treeview.HandleAllocated then

    begin

      Treeview.UpdateHorizontalScrollBar(False);

      if hoAutoResize in ToBeSet then

        Treeview.Invalidate;

    end;

  end;



  if not (csLoading in Treeview.ComponentState) and Treeview.HandleAllocated then

  begin

    if hoVisible in (ToBeSet + ToBeCleared) then

      RecalculateHeader;

    Invalidate(nil);

    Treeview.Invalidate;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TVTHeader.SetParentFont(Value: Boolean);



begin

  if FParentFont <> Value then

  begin

    FParentFont := Value;

    if FParentFont then

      FFont.Assign(FOwner.Font);

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TVTHeader.SetSortColumn(Value: TColumnIndex);



begin

  if csLoading in Treeview.ComponentState then

    FSortColumn := Value

  else

    DoSetSortColumn(Value);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TVTHeader.SetSortDirection(const Value: TSortDirection);



begin

  if Value <> FSortDirection then

  begin

    FSortDirection := Value;

    Invalidate(nil);

    if ((toAutoSort in Treeview.FOptions.FAutoOptions) or (hoHeaderClickAutoSort in Options)) and (Treeview.FUpdateCount = 0) then

      Treeview.SortTree(FSortColumn, FSortDirection, True);

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



function TVTHeader.CanSplitterResize(P: TPoint): Boolean;



begin

  Result := hoHeightResize in FOptions;

  DoCanSplitterResize(P, Result);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TVTHeader.SetStyle(Value: TVTHeaderStyle);



begin

  if FStyle <> Value then

  begin

    FStyle := Value;

    if not (csLoading in Treeview.ComponentState) then

      Invalidate(nil);

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



function TVTHeader.CanWriteColumns: Boolean;



// descendants may override this to optionally prevent column writing (e.g. if they are build dynamically).



begin

  Result := True;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TVTHeader.ChangeScale(M, D: Integer);

var

  I: Integer;

begin

  // This method is only executed if toAutoChangeScale is set

  if not ParentFont then

    FFont.Size := MulDiv(FFont.Size, M, D);

  Self.Height := MulDiv(FHeight, M, D);

  // Scale the columns widths too

  for I := 0 to FColumns.Count - 1 do

  begin

    Self.FColumns[I].Width := MulDiv(Self.FColumns[I].Width, M, D);

  end;//for I

end;



//----------------------------------------------------------------------------------------------------------------------



function TVTHeader.DetermineSplitterIndex(P: TPoint): Boolean;



// Tries to find the index of that column whose right border corresponds to P.

// Result is True if column border was hit (with -3..+5 pixels tolerance).

// For continuous resizing the current track index and the column's left/right border are set.

// Note: The hit test is checking from right to left (or left to right in RTL mode) to make enlarging of zero-sized

//       columns possible.



var

  I,

  VisibleFixedWidth: Integer;

  SplitPoint: Integer;



  //--------------- local function --------------------------------------------



  function IsNearBy(IsFixedCol: Boolean; LeftTolerance, RightTolerance: Integer): Boolean;



  begin

    if IsFixedCol then

      Result := (P.X < SplitPoint + Treeview.FEffectiveOffsetX + RightTolerance) and (P.X > SplitPoint + Treeview.FEffectiveOffsetX - LeftTolerance)

    else

      Result := (P.X > VisibleFixedWidth) and (P.X < SplitPoint + RightTolerance) and (P.X > SplitPoint - LeftTolerance);

  end;



  //--------------- end local function ----------------------------------------



begin

  Result := False;

  FColumns.FTrackIndex := NoColumn;



  VisibleFixedWidth := FColumns.GetVisibleFixedWidth;



  if FColumns.Count > 0 then

  begin

    if Treeview.UseRightToLeftAlignment then

    begin

      SplitPoint := -Treeview.FEffectiveOffsetX;

      if Integer(Treeview.FRangeX) < Treeview.ClientWidth then

        Inc(SplitPoint, Treeview.ClientWidth - Integer(Treeview.FRangeX));



      for I := 0 to FColumns.Count - 1 do

        with FColumns, Items[FPositionToIndex[I]] do

          if coVisible in FOptions then

          begin

            if IsNearBy(coFixed in FOptions, 5, 3) then

            begin

              if CanSplitterResize(P, FPositionToIndex[I]) then

              begin

                Result := True;

                FTrackIndex := FPositionToIndex[I];



                // Keep the right border of this column. This and the current mouse position

                // directly determine the current column width.

                FTrackPoint.X := SplitPoint + IfThen(coFixed in FOptions, Treeview.FEffectiveOffsetX) + FWidth;

                FTrackPoint.Y := P.Y;

                Break;

              end;

            end;

            Inc(SplitPoint, FWidth);

          end;

    end

    else

    begin

      SplitPoint := -Treeview.FEffectiveOffsetX + Integer(Treeview.FRangeX);



      for I := FColumns.Count - 1 downto 0 do

        with FColumns, Items[FPositionToIndex[I]] do

          if coVisible in FOptions then

          begin

            if IsNearBy(coFixed in FOptions, 3, 5) then

            begin

              if CanSplitterResize(P, FPositionToIndex[I]) then

              begin

                Result := True;

                FTrackIndex := FPositionToIndex[I];



                // Keep the left border of this column. This and the current mouse position

                // directly determine the current column width.

                FTrackPoint.X := SplitPoint + IfThen(coFixed in FOptions, Treeview.FEffectiveOffsetX) - FWidth;

                FTrackPoint.Y := P.Y;

                Break;

              end;

            end;

            Dec(SplitPoint, FWidth);

          end;

    end;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TVTHeader.DoAfterAutoFitColumn(Column: TColumnIndex);



begin

  if Assigned(TreeView.FOnAfterAutoFitColumn) then

    TreeView.FOnAfterAutoFitColumn(Self, Column);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TVTHeader.DoAfterColumnWidthTracking(Column: TColumnIndex);



// Tell the application that a column width tracking operation has been finished.



begin

  if Assigned(TreeView.FOnAfterColumnWidthTracking) then

    TreeView.FOnAfterColumnWidthTracking(Self, Column);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TVTHeader.DoAfterHeightTracking;



// Tell the application that a height tracking operation has been finished.



begin

  if Assigned(TreeView.FOnAfterHeaderHeightTracking) then

    TreeView.FOnAfterHeaderHeightTracking(Self);

end;



//----------------------------------------------------------------------------------------------------------------------



function TVTHeader.DoBeforeAutoFitColumn(Column: TColumnIndex; SmartAutoFitType: TSmartAutoFitType): Boolean;



// Query the application if we may autofit a column.



begin

  Result := True;

  if Assigned(TreeView.FOnBeforeAutoFitColumn) then

    TreeView.FOnBeforeAutoFitColumn(Self, Column, SmartAutoFitType, Result);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TVTHeader.DoBeforeColumnWidthTracking(Column: TColumnIndex; Shift: TShiftState);



// Tell the a application that a column width tracking operation may begin.



begin

  if Assigned(TreeView.FOnBeforeColumnWidthTracking) then

    TreeView.FOnBeforeColumnWidthTracking(Self, Column, Shift);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TVTHeader.DoBeforeHeightTracking(Shift: TShiftState);



// Tell the application that a height tracking operation may begin.



begin

  if Assigned(TreeView.FOnBeforeHeaderHeightTracking) then

    TreeView.FOnBeforeHeaderHeightTracking(Self, Shift);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TVTHeader.DoCanSplitterResize(P: TPoint; var Allowed: Boolean);

begin

  if Assigned(TreeView.FOnCanSplitterResizeHeader) then

    TreeView.FOnCanSplitterResizeHeader(Self, P, Allowed);

end;



//----------------------------------------------------------------------------------------------------------------------



function TVTHeader.DoColumnWidthDblClickResize(Column: TColumnIndex; P: TPoint; Shift: TShiftState): Boolean;



// Queries the application whether a double click on the column splitter should resize the column.



begin

  Result := True;

  if Assigned(TreeView.FOnColumnWidthDblClickResize) then

    TreeView.FOnColumnWidthDblClickResize(Self, Column, Shift, P, Result);

end;



//----------------------------------------------------------------------------------------------------------------------



function TVTHeader.DoColumnWidthTracking(Column: TColumnIndex; Shift: TShiftState; var TrackPoint: TPoint; P: TPoint): Boolean;



begin

  Result := True;

  if Assigned(TreeView.FOnColumnWidthTracking) then

    TreeView.FOnColumnWidthTracking(Self, Column, Shift, TrackPoint, P, Result);

end;



//----------------------------------------------------------------------------------------------------------------------



function TVTHeader.DoGetPopupMenu(Column: TColumnIndex; Position: TPoint): TPopupMenu;



// Queries the application whether there is a column specific header popup menu.



var

  AskParent: Boolean;



begin

  Result := nil;

  if Assigned(TreeView.FOnGetPopupMenu) then

    TreeView.FOnGetPopupMenu(TreeView, nil, Column, Position, AskParent, Result);

end;



//----------------------------------------------------------------------------------------------------------------------



function TVTHeader.DoHeightTracking(var P: TPoint; Shift: TShiftState): Boolean;



begin

  Result := True;

  if Assigned(TreeView.FOnHeaderHeightTracking) then

    TreeView.FOnHeaderHeightTracking(Self, P, Shift, Result);

end;



//----------------------------------------------------------------------------------------------------------------------



function TVTHeader.DoHeightDblClickResize(var P: TPoint; Shift: TShiftState): Boolean;



begin

  Result := True;

  if Assigned(TreeView.FOnHeaderHeightDblClickResize) then

    TreeView.FOnHeaderHeightDblClickResize(Self, P, Shift, Result);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TVTHeader.DoSetSortColumn(Value: TColumnIndex);



begin

  if Value < NoColumn then

    Value := NoColumn;

  if Value > Columns.Count - 1 then

    Value := Columns.Count - 1;

  if FSortColumn <> Value then

  begin

    if FSortColumn > NoColumn then

      Invalidate(Columns[FSortColumn]);

    FSortColumn := Value;

    if FSortColumn > NoColumn then

      Invalidate(Columns[FSortColumn]);

    if ((toAutoSort in Treeview.FOptions.FAutoOptions) or (hoHeaderClickAutoSort in Options)) and (Treeview.FUpdateCount = 0) then

      Treeview.SortTree(FSortColumn, FSortDirection, True);

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TVTHeader.DragTo(P: TPoint);



// Moves the drag image to a new position, which is determined from the passed point P and the previous

// mouse position.



var

  I,

  NewTarget: Integer;

  // optimized drag image move support

  ClientP: TPoint;

  Left,

  Right: Integer;

  NeedRepaint: Boolean; // True if the screen needs an update (changed drop target or drop side)



begin

  // Determine new drop target and which side of it is prefered.

  ClientP := Treeview.ScreenToClient(P);

  // Make coordinates relative to (0, 0) of the non-client area.

  Inc(ClientP.Y, FHeight);

  NewTarget := FColumns.ColumnFromPosition(ClientP);

  NeedRepaint := (NewTarget <> InvalidColumn) and (NewTarget <> FColumns.FDropTarget);

  if NewTarget >= 0 then

  begin

    FColumns.GetColumnBounds(NewTarget, Left, Right);

    if (ClientP.X < ((Left + Right) div 2)) <> FColumns.FDropBefore then

    begin

      NeedRepaint := True;

      FColumns.FDropBefore := not FColumns.FDropBefore;

    end;

  end;



  if NeedRepaint then

  begin

    // Invalidate columns which need a repaint.

    if FColumns.FDropTarget > NoColumn then

    begin

      I := FColumns.FDropTarget;

      FColumns.FDropTarget := NoColumn;

      Invalidate(FColumns.Items[I]);

    end;

    if (NewTarget > NoColumn) and (NewTarget <> FColumns.FDropTarget) then

    begin

      Invalidate(FColumns.Items[NewTarget]);

      FColumns.FDropTarget := NewTarget;

    end;

  end;



  FDragImage.DragTo(P, NeedRepaint);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TVTHeader.FixedAreaConstraintsChanged(Sender: TObject);



// This method gets called when FFixedAreaConstraints is changed.



begin

  if Treeview.HandleAllocated then

    RescaleHeader

  else

    Include(FStates, hsNeedScaling);

end;



//----------------------------------------------------------------------------------------------------------------------



function TVTHeader.GetColumnsClass: TVirtualTreeColumnsClass;



// Returns the class to be used for the actual column implementation. descendants may optionally override this and

// return their own class.



begin

  Result := TVirtualTreeColumns;

end;



//----------------------------------------------------------------------------------------------------------------------



function TVTHeader.GetOwner: TPersistent;



begin

  Result := FOwner;

end;



//----------------------------------------------------------------------------------------------------------------------



function TVTHeader.GetShiftState: TShiftState;



begin

  Result := [];

  if GetKeyState(VK_SHIFT) < 0 then

    Include(Result, ssShift);

  if GetKeyState(VK_CONTROL) < 0 then

    Include(Result, ssCtrl);

  if GetKeyState(VK_MENU) < 0 then

    Include(Result, ssAlt);

end;



//----------------------------------------------------------------------------------------------------------------------



function TVTHeader.HandleHeaderMouseMove(var Message: TWMMouseMove): Boolean;



var

  P: TPoint;

  NextColumn,

  I: TColumnIndex;

  NewWidth: Integer;



begin

  Result := False;

  with Message do

  begin

    P := Point(XPos, YPos);

    if hsColumnWidthTrackPending in FStates then

    begin

      Treeview.StopTimer(HeaderTimer);

      FStates := FStates - [hsColumnWidthTrackPending] + [hsColumnWidthTracking];

      HandleHeaderMouseMove := True;

      Result := 0;

    end

    else

      if hsHeightTrackPending in FStates then

      begin

        Treeview.StopTimer(HeaderTimer);

        FStates := FStates - [hsHeightTrackPending] + [hsHeightTracking];

        HandleHeaderMouseMove := True;

        Result := 0;

      end

      else

        if hsColumnWidthTracking in FStates then

        begin

          if DoColumnWidthTracking(FColumns.FTrackIndex, GetShiftState, FTrackPoint, P) then

          begin

            if Treeview.UseRightToLeftAlignment then

            begin

              NewWidth := FTrackPoint.X - XPos;

              NextColumn := FColumns.GetPreviousVisibleColumn(FColumns.FTrackIndex);

          end

            else

            begin

              NewWidth := XPos - FTrackPoint.X;

              NextColumn := FColumns.GetNextVisibleColumn(FColumns.FTrackIndex);

            end;



            // The autosized column cannot be resized using the mouse normally. Instead we resize the next

            // visible column, so it look as we directly resize the autosized column.

            if (hoAutoResize in FOptions) and (FColumns.FTrackIndex = FAutoSizeIndex) and

               (NextColumn > NoColumn) and (coResizable in FColumns[NextColumn].FOptions) and

               (FColumns[FColumns.FTrackIndex].FMinWidth < NewWidth) and

               (FColumns[FColumns.FTrackIndex].FMaxWidth > NewWidth) then

              FColumns[NextColumn].Width := FColumns[NextColumn].Width - NewWidth

                                            + FColumns[FColumns.FTrackIndex].Width

            else

              FColumns[FColumns.FTrackIndex].Width := NewWidth; // 1 EListError seen here (List index out of bounds (-1)) since 10/2013

          end;

          HandleHeaderMouseMove := True;

          Result := 0;

        end

        else

          if hsHeightTracking in FStates then

          begin

            if DoHeightTracking(P, GetShiftState) then

              SetHeight(Integer(FHeight) + P.Y);

            HandleHeaderMouseMove := True;

            Result := 0;

          end

          else

          begin

            if hsDragPending in FStates then

            begin

              P := Treeview.ClientToScreen(P);

              // start actual dragging if allowed

              if (hoDrag in FOptions) and Treeview.DoHeaderDragging(FColumns.FDownIndex) then

              begin

                if ((Abs(FDragStart.X - P.X) > Mouse.DragThreshold) or

                   (Abs(FDragStart.Y - P.Y) > Mouse.DragThreshold)) then

                begin

                  Treeview.StopTimer(HeaderTimer);

                  I := FColumns.FDownIndex;

                  FColumns.FDownIndex := NoColumn;

                  FColumns.FHoverIndex := NoColumn;

                  if I > NoColumn then

                    Invalidate(FColumns[I]);

                  PrepareDrag(P, FDragStart);

                  FStates := FStates - [hsDragPending] + [hsDragging];

                  HandleHeaderMouseMove := True;

                  Result := 0;

                end;

              end;

            end

            else

              if hsDragging in FStates then

              begin

                DragTo(Treeview.ClientToScreen(Point(XPos, YPos)));

                HandleHeaderMouseMove := True;

                Result := 0;

              end;

          end;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



function TVTHeader.HandleMessage(var Message: TMessage): Boolean;



// The header gets here the opportunity to handle certain messages before they reach the tree. This is important

// because the tree needs to handle various non-client area messages for the header as well as some dragging/tracking

// events.

// By returning True the message will not be handled further, otherwise the message is then dispatched

// to the proper message handlers.



var

  P: TPoint;

  R: TRect;

  I: TColumnIndex;

  OldPosition: Integer;

  HitIndex: TColumnIndex;

  NewCursor: HCURSOR;

  Button: TMouseButton;

  Menu: TPopupMenu;

  IsInHeader,

  IsHSplitterHit,

  IsVSplitterHit: Boolean;



  //--------------- local function --------------------------------------------



  function HSplitterHit: Boolean;



  var

    NextCol: TColumnIndex;



  begin

    Result := (hoColumnResize in FOptions) and DetermineSplitterIndex(P);

    if Result and not InHeader(P) then

    begin

      NextCol := FColumns.GetNextVisibleColumn(FColumns.FTrackIndex);

      if not (coFixed in FColumns[FColumns.FTrackIndex].Options) or (NextCol <= NoColumn) or

         (coFixed in FColumns[NextCol].Options) or (P.Y > Integer(Treeview.FRangeY)) then

        Result := False;

    end;

  end;



  //--------------- end local function ----------------------------------------



begin

  Result := False;

  case Message.Msg of

    WM_SIZE:

      begin

        if not (tsWindowCreating in FOwner.FStates) then

          if (hoAutoResize in FOptions) and not (hsAutoSizing in FStates) then

          begin

            FColumns.AdjustAutoSize(InvalidColumn);

            Invalidate(nil);

          end

          else

            if not (hsScaling in FStates) then

            begin

              RescaleHeader;

              Invalidate(nil);

            end;

      end;

    CM_PARENTFONTCHANGED:

      if FParentFont then

        FFont.Assign(FOwner.Font);

    CM_BIDIMODECHANGED:

      for I := 0 to FColumns.Count - 1 do

        if coParentBiDiMode in FColumns[I].FOptions then

          FColumns[I].ParentBiDiModeChanged;

    WM_NCMBUTTONDOWN:

      begin

        with TWMNCMButtonDown(Message) do

          P := Treeview.ScreenToClient(Point(XCursor, YCursor));

        if InHeader(P) then

          FOwner.DoHeaderMouseDown(mbMiddle, GetShiftState, P.X, P.Y + Integer(FHeight));

      end;

    WM_NCMBUTTONUP:

      begin

        with TWMNCMButtonUp(Message) do

          P := FOwner.ScreenToClient(Point(XCursor, YCursor));

        if InHeader(P) then

        begin

          FColumns.HandleClick(P, mbMiddle, True, False);

          FOwner.DoHeaderMouseUp(mbMiddle, GetShiftState, P.X, P.Y + Integer(FHeight));

          FColumns.FDownIndex := NoColumn;

          FColumns.FCheckBoxHit := False;

        end;

      end;

    WM_LBUTTONDBLCLK,

    WM_NCLBUTTONDBLCLK,

    WM_NCMBUTTONDBLCLK,

    WM_NCRBUTTONDBLCLK:

      begin

        if Message.Msg <> WM_LBUTTONDBLCLK then

          with TWMNCLButtonDblClk(Message) do

            P := FOwner.ScreenToClient(Point(XCursor, YCursor))

        else

          with TWMLButtonDblClk(Message) do

            P := Point(XPos, YPos);



        if (hoHeightDblClickResize in FOptions) and InHeaderSplitterArea(P) and (FDefaultHeight > 0) then

        begin

          if DoHeightDblClickResize(P, GetShiftState) and (FDefaultHeight > 0) then

            SetHeight(FMinHeight);

          Result := True;

        end

        else

          if HSplitterHit and ((Message.Msg = WM_NCLBUTTONDBLCLK) or (Message.Msg = WM_LBUTTONDBLCLK)) and

             (hoDblClickResize in FOptions) and (FColumns.FTrackIndex > NoColumn) then

          begin

            // If the click was on a splitter then resize column to smallest width.

            if DoColumnWidthDblClickResize(FColumns.FTrackIndex, P, GetShiftState) then

              AutoFitColumns(True, smaUseColumnOption, FColumns[FColumns.FTrackIndex].FPosition,

                             FColumns[FColumns.FTrackIndex].FPosition);

            Message.Result := 0;

            Result := True;

          end

          else

            if InHeader(P) and (Message.Msg <> WM_LBUTTONDBLCLK) then

            begin

              case Message.Msg of

                WM_NCMBUTTONDBLCLK:

                  Button := mbMiddle;

                WM_NCRBUTTONDBLCLK:

                  Button := mbRight;

                else

                  // WM_NCLBUTTONDBLCLK

                  Button := mbLeft;

              end;

              if Button = mbLeft then

                Columns.AdjustDownColumn(P);

              FColumns.HandleClick(P, Button, True, True);

            end;

      end;

    // The "hot" area of the headers horizontal splitter is partly within the client area of the the tree, so we need

    // to handle WM_LBUTTONDOWN here, too.

    WM_LBUTTONDOWN,

    WM_NCLBUTTONDOWN:

      begin



        Application.CancelHint;



        if not (csDesigning in Treeview.ComponentState) then

        begin

          // make sure no auto scrolling is active...

          Treeview.StopTimer(ScrollTimer);

          Treeview.DoStateChange([], [tsScrollPending, tsScrolling]);

          // ... pending editing is cancelled (actual editing remains active)

          Treeview.StopTimer(EditTimer);

          Treeview.DoStateChange([], [tsEditPending]);

        end;



        if Message.Msg = WM_LBUTTONDOWN then

          // Coordinates are already client area based.

          with TWMLButtonDown(Message) do

            P := Point(XPos, YPos)

        else

          with TWMNCLButtonDown(Message) do

          begin

            // want the drag start point in screen coordinates

            FDragStart := Point(XCursor, YCursor);

            P := Treeview.ScreenToClient(FDragStart);

          end;



        IsInHeader := InHeader(P);

        // in design-time header columns are always resizable

        if (csDesigning in Treeview.ComponentState) then

          IsVSplitterHit := InHeaderSplitterArea(P)

        else

          IsVSplitterHit := InHeaderSplitterArea(P) and CanSplitterResize(P);

        IsHSplitterHit := HSplitterHit;



        if IsVSplitterHit or IsHSplitterHit then

        begin

          FTrackStart := P;

          FColumns.FHoverIndex := NoColumn;

          if IsVSplitterHit then

          begin

            if not (csDesigning in Treeview.ComponentState) then

              DoBeforeHeightTracking(GetShiftState);

            Include(FStates, hsHeightTrackPending);

          end

          else

          begin

            if not (csDesigning in Treeview.ComponentState) then

              DoBeforeColumnWidthTracking(FColumns.FTrackIndex, GetShiftState);

            Include(FStates, hsColumnWidthTrackPending);

          end;



          SetCapture(Treeview.Handle);

          Result := True;

          Message.Result := 0;

        end

        else

          if IsInHeader then

          begin

            HitIndex := Columns.AdjustDownColumn(P);

            // in design-time header columns are always draggable

            if ((csDesigning in Treeview.ComponentState) and (HitIndex > NoColumn)) or

               ((hoDrag in FOptions) and (HitIndex > NoColumn) and (coDraggable in FColumns[HitIndex].FOptions)) then

            begin

              // Show potential drag operation.

              // Disabled columns do not start a drag operation because they can't be clicked.

              Include(FStates, hsDragPending);

              SetCapture(Treeview.Handle);

              Result := True;

              Message.Result := 0;

            end;

          end;



        // This is a good opportunity to notify the application.

        if not (csDesigning in Treeview.ComponentState) and IsInHeader then

          FOwner.DoHeaderMouseDown(mbLeft, GetShiftState, P.X, P.Y + Integer(FHeight));

      end;

    WM_NCRBUTTONDOWN:

      begin

        with TWMNCRButtonDown(Message) do

          P := FOwner.ScreenToClient(Point(XCursor, YCursor));

        if InHeader(P) then

          FOwner.DoHeaderMouseDown(mbRight, GetShiftState, P.X, P.Y + Integer(FHeight));

      end;

    WM_NCRBUTTONUP:

      if not (csDesigning in FOwner.ComponentState) then

        with TWMNCRButtonUp(Message) do

        begin

          Application.CancelHint;



          P := FOwner.ScreenToClient(Point(XCursor, YCursor));

          if InHeader(P) then

          begin

            FColumns.HandleClick(P, mbRight, True, False);

            FOwner.DoHeaderMouseUp(mbRight, GetShiftState, P.X, P.Y + Integer(FHeight));

            FColumns.FDownIndex := NoColumn;

            FColumns.FTrackIndex := NoColumn;

            FColumns.FCheckBoxHit := False;



            Menu := FPopupMenu;

            if not Assigned(Menu) then

              Menu := DoGetPopupMenu(FColumns.ColumnFromPosition(Point(P.X, P.Y + Integer(FHeight))), P);



            // Trigger header popup if there's one.

            if Assigned(Menu) then

            begin

              Treeview.StopTimer(ScrollTimer);

              Treeview.StopTimer(HeaderTimer);

              FColumns.FHoverIndex := NoColumn;

              Treeview.DoStateChange([], [tsScrollPending, tsScrolling]);

              Menu.PopupComponent := Treeview;

              Menu.Popup(XCursor, YCursor);

              HandleMessage := True;

            end;

          end;

        end;

    // When the tree window has an active mouse capture then we only get "client-area" messages.

    WM_LBUTTONUP,

    WM_NCLBUTTONUP:

      begin

        Application.CancelHint;



        if FStates <> [] then

        begin

          ReleaseCapture;

          if hsDragging in FStates then

          begin

            // successfull dragging moves columns

            with TWMLButtonUp(Message) do

              P := Treeview.ClientToScreen(Point(XPos, YPos));

            GetWindowRect(Treeview.Handle, R);

            with FColumns do

            begin

              FDragImage.EndDrag;

              if (FDropTarget > -1) and (FDropTarget <> FDragIndex) and PtInRect(R, P) then

              begin

                OldPosition := FColumns[FDragIndex].Position;

                if FColumns.FDropBefore then

                begin

                  if FColumns[FDragIndex].Position < FColumns[FDropTarget].Position then

                    FColumns[FDragIndex].Position := Max(0, FColumns[FDropTarget].Position - 1)

                  else

                    FColumns[FDragIndex].Position := FColumns[FDropTarget].Position;

                end

                else

                begin

                  if FColumns[FDragIndex].Position < FColumns[FDropTarget].Position then

                    FColumns[FDragIndex].Position := FColumns[FDropTarget].Position

                  else

                    FColumns[FDragIndex].Position := FColumns[FDropTarget].Position + 1;

                end;

                Treeview.DoHeaderDragged(FDragIndex, OldPosition);

              end

              else

                Treeview.DoHeaderDraggedOut(FDragIndex, P);

              FDropTarget := NoColumn;

            end;

            Invalidate(nil);

          end;

          Result := True;

          Message.Result := 0;

        end;



        case Message.Msg of

          WM_LBUTTONUP:

            with TWMLButtonUp(Message) do

            begin

              if FColumns.FDownIndex > NoColumn then

                FColumns.HandleClick(Point(XPos, YPos), mbLeft, False, False);

              if FStates <> [] then

                FOwner.DoHeaderMouseUp(mbLeft, KeysToShiftState(Keys), XPos, YPos);

            end;

          WM_NCLBUTTONUP:

            with TWMNCLButtonUp(Message) do

            begin

              P := FOwner.ScreenToClient(Point(XCursor, YCursor));

              FColumns.HandleClick(P, mbLeft, False, False);

              FOwner.DoHeaderMouseUp(mbLeft, GetShiftState, P.X, P.Y + Integer(FHeight));

            end;

        end;



        if FColumns.FTrackIndex > NoColumn then

        begin

          if hsColumnWidthTracking in FStates then

            DoAfterColumnWidthTracking(FColumns.FTrackIndex);

          Invalidate(Columns[FColumns.FTrackIndex]);

          FColumns.FTrackIndex := NoColumn;

        end;

        if FColumns.FDownIndex > NoColumn then

        begin

          Invalidate(Columns[FColumns.FDownIndex]);

          FColumns.FDownIndex := NoColumn;

        end;

        if hsHeightTracking in FStates then

          DoAfterHeightTracking;



        FStates := FStates - [hsDragging, hsDragPending,

                              hsColumnWidthTracking, hsColumnWidthTrackPending,

                              hsHeightTracking, hsHeightTrackPending];

      end;

    // hovering, mouse leave detection

    WM_NCMOUSEMOVE:

      with TWMNCMouseMove(Message), FColumns do

      begin

        P := Treeview.ScreenToClient(Point(XCursor, YCursor));

        Treeview.DoHeaderMouseMove(GetShiftState, P.X, P.Y + Integer(FHeight));

        if InHeader(P) and ((AdjustHoverColumn(P)) or ((FDownIndex >= 0) and (FHoverIndex <> FDownIndex))) then

        begin

          // We need a mouse leave detection from here for the non client area.

          // TODO: The best solution available would be the TrackMouseEvent API.

          // With the drop of the support of Win95 totally and WinNT4 we should replace the timer.

          Treeview.StopTimer(HeaderTimer);

          SetTimer(Treeview.Handle, HeaderTimer, 50, nil);

          // use Delphi's internal hint handling for header hints too

          if hoShowHint in FOptions then

          begin

            // client coordinates!

            XCursor := P.X;

            YCursor := P.Y + Integer(FHeight);

            Application.HintMouseMessage(Treeview, Message);

          end;

        end;

      end;

    WM_TIMER:

      if TWMTimer(Message).TimerID = HeaderTimer then

      begin

        // determine current mouse position to check if it left the window

        GetCursorPos(P);

        P := Treeview.ScreenToClient(P);

        with FColumns do

        begin

          if not InHeader(P) or ((FDownIndex > NoColumn) and (FHoverIndex <> FDownIndex)) then

          begin

            Treeview.StopTimer(HeaderTimer);

            FHoverIndex := NoColumn;

            FClickIndex := NoColumn;

            FDownIndex := NoColumn;

            FCheckBoxHit := False;

            Result := True;

            Message.Result := 0;

            Invalidate(nil);

          end;

        end;

      end;

    WM_MOUSEMOVE: // mouse capture and general message redirection

      Result := HandleHeaderMouseMove(TWMMouseMove(Message));

    WM_SETCURSOR:

      // Feature: design-time header

      if (FStates = []) then

      begin

        // Retrieve last cursor position (GetMessagePos does not work here, I don't know why).

        GetCursorPos(P);



        // Is the mouse in the header rectangle and near the splitters?

        P := Treeview.ScreenToClient(P);

        IsHSplitterHit := HSplitterHit;

        // in design-time header columns are always resizable

        if (csDesigning in Treeview.ComponentState) then

          IsVSplitterHit := InHeaderSplitterArea(P)

        else

          IsVSplitterHit := InHeaderSplitterArea(P) and CanSplitterResize(P);



        if IsVSplitterHit or IsHSplitterHit then

        begin

          NewCursor := Screen.Cursors[Treeview.Cursor];

          if IsVSplitterHit and ((hoHeightResize in FOptions) or (csDesigning in Treeview.ComponentState)) then

            NewCursor := Screen.Cursors[crVertSplit]

          else

            if IsHSplitterHit then

              NewCursor := Screen.Cursors[crHeaderSplit];



          if not (csDesigning in Treeview.ComponentState) then

            Treeview.DoGetHeaderCursor(NewCursor);

          Result := NewCursor <> Screen.Cursors[crDefault];

          if Result then

          begin

            Windows.SetCursor(NewCursor);

            Message.Result := 1;

          end;

        end;

      end

      else

      begin

        Message.Result := 1;

        Result := True;

      end;

    WM_KEYDOWN,

    WM_KILLFOCUS:

      if (Message.Msg = WM_KILLFOCUS) or

         (TWMKeyDown(Message).CharCode = VK_ESCAPE) then

      begin

        if hsDragging in FStates then

        begin

          ReleaseCapture;

          FDragImage.EndDrag;

          Exclude(FStates, hsDragging);

          FColumns.FDropTarget := NoColumn;

          Invalidate(nil);

          Result := True;

          Message.Result := 0;

        end

        else

        begin

          if [hsColumnWidthTracking, hsHeightTracking] * FStates <> [] then

          begin

            ReleaseCapture;

            if hsColumnWidthTracking in FStates then

              DoAfterColumnWidthTracking(FColumns.FTrackIndex);

            if hsHeightTracking in FStates then

              DoAfterHeightTracking;

            Result := True;

            Message.Result := 0;

          end;



          FStates := FStates - [hsColumnWidthTracking, hsColumnWidthTrackPending,

                                hsHeightTracking, hsHeightTrackPending];

        end;

      end;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TVTHeader.ImageListChange(Sender: TObject);



begin

  if not (csDestroying in Treeview.ComponentState) then

    Invalidate(nil);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TVTHeader.PrepareDrag(P, Start: TPoint);



// Initializes dragging of the header, P is the current mouse postion and Start the initial mouse position.



var

  Image: TBitmap;

  ImagePos: TPoint;

  DragColumn: TVirtualTreeColumn;

  RTLOffset: Integer;



begin

  // Determine initial position of drag image (screen coordinates).

  FColumns.FDropTarget := NoColumn;

  Start := Treeview.ScreenToClient(Start);

  Inc(Start.Y, FHeight);

  FColumns.FDragIndex := FColumns.ColumnFromPosition(Start);

  DragColumn := FColumns[FColumns.FDragIndex];



  Image := TBitmap.Create;

  with Image do

  try

    PixelFormat := pf32Bit;

    Width := DragColumn.Width;

    Height := FHeight;



    // Erase the entire image with the color key value, for the case not everything

    // in the image is covered by the header image.

    Canvas.Brush.Color := clBtnFace;

    Canvas.FillRect(Rect(0, 0, Width, Height));



    if TreeView.UseRightToLeftAlignment then

      RTLOffset := Treeview.ComputeRTLOffset

    else

      RTLOffset := 0;

    with DragColumn do

      FColumns.PaintHeader(Canvas, Rect(FLeft, 0, FLeft + Width, Height), Point(-RTLOffset, 0), RTLOffset);



    if Treeview.UseRightToLeftAlignment then

      ImagePos := Treeview.ClientToScreen(Point(DragColumn.Left + Treeview.ComputeRTLOffset(True), 0))

    else

      ImagePos := Treeview.ClientToScreen(Point(DragColumn.Left, 0));

    // Column rectangles are given in local window coordinates not client coordinates.

    Dec(ImagePos.Y, FHeight);



    if hoRestrictDrag in FOptions then

      FDragImage.MoveRestriction := dmrHorizontalOnly

    else

      FDragImage.MoveRestriction := dmrNone;

    FDragImage.PrepareDrag(Image, ImagePos, P, nil);

    FDragImage.ShowDragImage;

  finally

    Image.Free;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TVTHeader.ReadColumns(Reader: TReader);



begin

  Include(FStates, hsLoading);

  Columns.Clear;

  Reader.ReadValue;

  Reader.ReadCollection(Columns);

  Exclude(FStates, hsLoading);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TVTHeader.RecalculateHeader;



// Initiate a recalculation of the non-client area of the owner tree.



begin

  if Treeview.HandleAllocated then

  begin

    Treeview.UpdateHeaderRect;

    SetWindowPos(Treeview.Handle, 0, 0, 0, 0, 0, SWP_FRAMECHANGED or SWP_NOMOVE or SWP_NOACTIVATE or SWP_NOOWNERZORDER or

      SWP_NOSENDCHANGING or SWP_NOSIZE or SWP_NOZORDER);

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TVTHeader.RescaleHeader;



// Rescale the fixed elements (fixed columns, header itself) to FixedAreaConstraints.



var

  FixedWidth,

  MaxFixedWidth,

  MinFixedWidth: Integer;



  //--------------- local function --------------------------------------------



  procedure ComputeConstraints;



  var

    I: TColumnIndex;



  begin

    with FColumns do

    begin

      I := GetFirstVisibleColumn;

      while I > NoColumn do

      begin

        if (coFixed in FColumns[I].Options) and (FColumns[I].Width < FColumns[I].MinWidth) then

          FColumns[I].FWidth := FColumns[I].FMinWidth;

        I := GetNextVisibleColumn(I);

      end;

      FixedWidth := GetVisibleFixedWidth;

    end;



    with FFixedAreaConstraints do

    begin

      MinFixedWidth := (TreeView.ClientWidth * FMinWidthPercent) div 100;

      MaxFixedWidth := (TreeView.ClientWidth * FMaxWidthPercent) div 100;

    end;

  end;



  //----------- end local function --------------------------------------------



begin

  if ([csLoading, csReading, csWriting, csDestroying] * Treeview.ComponentState = []) and not

     (hsLoading in FStates) and Treeview.HandleAllocated then

  begin

    Include(FStates, hsScaling);



    SetHeight(FHeight);

    RecalculateHeader;



    with FFixedAreaConstraints do

      if (FMinHeightPercent > 0) or (FMaxHeightPercent > 0) then

      begin

        ComputeConstraints;



        with FColumns do

          if (FMaxWidthPercent > 0) and (FixedWidth > MaxFixedWidth) then

            ResizeColumns(MaxFixedWidth - FixedWidth, 0, Count - 1, [coVisible, coFixed])

          else

            if (FMinWidthPercent > 0) and (FixedWidth < MinFixedWidth) then

              ResizeColumns(MinFixedWidth - FixedWidth, 0, Count - 1, [coVisible, coFixed]);



        FColumns.UpdatePositions;

      end;



    Exclude(FStates, hsScaling);

    Exclude(FStates, hsNeedScaling);

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TVTHeader.UpdateMainColumn;



// Called once the load process of the owner tree is done.



begin

  if FMainColumn < 0 then

    FMainColumn := 0;

  if FMainColumn > FColumns.Count - 1 then

    FMainColumn := FColumns.Count - 1;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TVTHeader.UpdateSpringColumns;



var

  I: TColumnIndex;

  SpringCount: Integer;

  Sign: Integer;

  ChangeBy: Single;

  Difference: Single;

  NewAccumulator: Single;



begin

  with TreeView do

    ChangeBy := FHeaderRect.Right - FHeaderRect.Left - FLastWidth;

  if (hoAutoSpring in FOptions) and (FLastWidth <> 0) and (ChangeBy <> 0) then

  begin

    // Stay positive if downsizing the control.

    if ChangeBy < 0 then

      Sign := -1

    else

      Sign := 1;

    ChangeBy := Abs(ChangeBy);

    // Count how many columns have spring enabled.

    SpringCount := 0;

    for I := 0 to FColumns.Count-1 do

      if [coVisible, coAutoSpring] * FColumns[I].FOptions = [coVisible, coAutoSpring] then

        Inc(SpringCount);

    if SpringCount > 0 then

    begin

      // Calculate the size to add/sub to each columns.

      Difference := ChangeBy / SpringCount;

      // Adjust the column's size accumulators and resize if the result is >= 1.

      for I := 0 to FColumns.Count - 1 do

        if [coVisible, coAutoSpring] * FColumns[I].FOptions = [coVisible, coAutoSpring] then

        begin

          // Sum up rest changes from previous runs and the amount from this one and store it in the

          // column. If there is at least one pixel difference then do a resize and reset the accumulator.

          NewAccumulator := FColumns[I].FSpringRest + Difference;

          // Set new width if at least one pixel size difference is reached.

          if NewAccumulator >= 1 then

            FColumns[I].SetWidth(FColumns[I].FWidth + (Trunc(NewAccumulator) * Sign));

          FColumns[I].FSpringRest := Frac(NewAccumulator);



          // Keep track of the size count.

          ChangeBy := ChangeBy - Difference;

          // Exit loop if resize count drops below freezing point.

          if ChangeBy < 0 then

            Break;

        end;

    end;

  end;

  with TreeView do

    FLastWidth := FHeaderRect.Right - FHeaderRect.Left;

end;



//----------------------------------------------------------------------------------------------------------------------



type

  // --- HACK WARNING!

  // This type cast is a partial rewrite of the private section of TWriter. The purpose is to have access to

  // the FPropPath member, which is otherwise not accessible. The reason why this access is needed is that

  // with nested components this member contains unneeded property path information. These information prevent

  // successful load of the stored properties later.

  // In Classes.pas you can see that FPropPath is reset several times to '' to prevent this case for certain properies.

  // Unfortunately, there is no clean way for us here to do the same.

  {$hints off}

  TWriterHack = class(TFiler)

  private

    FRootAncestor: TComponent;

    FPropPath: string;

  end;

  {$hints on}



procedure TVTHeader.WriteColumns(Writer: TWriter);



// Write out the columns but take care for the case VT is a nested component.



var

  LastPropPath: string;



begin

  // Save last property path for restoration.

  LastPropPath := TWriterHack(Writer).FPropPath;

  try

    // If VT is a nested component then this path contains the name of the parent component at this time

    // (otherwise it is already empty). This path is then combined with the property name under which the tree

    // is defined in the parent component. Unfortunately, the load code in Classes.pas does not consider this case

    // is then unable to load this property.

    TWriterHack(Writer).FPropPath := '';

    Writer.WriteCollection(Columns);

  finally

    TWriterHack(Writer).FPropPath := LastPropPath;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



function TVTHeader.AllowFocus(ColumnIndex: TColumnIndex): Boolean;

begin

  Result := False;

  if not FColumns.IsValidColumn(ColumnIndex) then

    Exit; // Just in case.



  Result := (coAllowFocus in FColumns[ColumnIndex].Options);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TVTHeader.Assign(Source: TPersistent);



begin

  if Source is TVTHeader then

  begin

    AutoSizeIndex := TVTHeader(Source).AutoSizeIndex;

    Background := TVTHeader(Source).Background;

    Columns := TVTHeader(Source).Columns;

    Font := TVTHeader(Source).Font;

    FixedAreaConstraints.Assign(TVTHeader(Source).FixedAreaConstraints);

    Height := TVTHeader(Source).Height;

    Images := TVTHeader(Source).Images;

    MainColumn := TVTHeader(Source).MainColumn;

    Options := TVTHeader(Source).Options;

    ParentFont := TVTHeader(Source).ParentFont;

    PopupMenu := TVTHeader(Source).PopupMenu;

    SortColumn := TVTHeader(Source).SortColumn;

    SortDirection := TVTHeader(Source).SortDirection;

    Style := TVTHeader(Source).Style;



    RescaleHeader;

  end

  else

    inherited;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TVTHeader.AutoFitColumns(Animated: Boolean = True; SmartAutoFitType: TSmartAutoFitType = smaUseColumnOption;

  RangeStartCol: Integer = NoColumn; RangeEndCol: Integer = NoColumn);



  //--------------- local functions -------------------------------------------



  function GetUseSmartColumnWidth(ColumnIndex: TColumnIndex): Boolean;



  begin

    Result := False;

    case SmartAutoFitType of

      smaAllColumns:

        Result := True;

      smaNoColumn:

        Result := False;

      smaUseColumnOption:

        Result := coSmartResize in FColumns.Items[ColumnIndex].FOptions;

    end;

  end;



  //----------------------------------------------------------------------------



  procedure DoAutoFitColumn(Column: TColumnIndex);



  begin

    with FColumns do

      if ([coResizable, coVisible] * Items[FPositionToIndex[Column]].FOptions = [coResizable, coVisible]) and

            DoBeforeAutoFitColumn(FPositionToIndex[Column], SmartAutoFitType) and not TreeView.OperationCanceled then

      begin

        if Animated then

          AnimatedResize(FPositionToIndex[Column], Treeview.GetMaxColumnWidth(FPositionToIndex[Column],

            GetUseSmartColumnWidth(FPositionToIndex[Column])))

        else

          FColumns[FPositionToIndex[Column]].Width := Treeview.GetMaxColumnWidth(FPositionToIndex[Column],

            GetUseSmartColumnWidth(FPositionToIndex[Column]));



        DoAfterAutoFitColumn(FPositionToIndex[Column]);

      end;

  end;



  //--------------- end local functions ----------------------------------------



var

  I: Integer;

  StartCol,

  EndCol: Integer;



begin

  StartCol := Max(NoColumn + 1, RangeStartCol);



  if RangeEndCol <= NoColumn then

    EndCol := FColumns.Count - 1

  else

    EndCol := Min(RangeEndCol, FColumns.Count - 1);



  if StartCol > EndCol then

    Exit; // nothing to do



  TreeView.StartOperation(okAutoFitColumns);

  try

    if Assigned(TreeView.FOnBeforeAutoFitColumns) then

      TreeView.FOnBeforeAutoFitColumns(Self, SmartAutoFitType);



    for I := StartCol to EndCol do

      DoAutoFitColumn(I);



    if Assigned(TreeView.FOnAfterAutoFitColumns) then

      TreeView.FOnAfterAutoFitColumns(Self);



  finally

    Treeview.EndOperation(okAutoFitColumns);

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



function TVTHeader.InHeader(P: TPoint): Boolean;



// Determines whether the given point (client coordinates!) is within the header rectangle (non-client coordinates).



var

  R, RW: TRect;



begin

  R := Treeview.FHeaderRect;



  // Current position of the owner in screen coordinates.

  GetWindowRect(Treeview.Handle, RW);



  // Convert to client coordinates.

  MapWindowPoints(0, Treeview.Handle, RW, 2);



  // Consider the header within this rectangle.

  OffsetRect(R, RW.Left, RW.Top);

  Result := PtInRect(R, P);

end;



//----------------------------------------------------------------------------------------------------------------------



function TVTHeader.InHeaderSplitterArea(P: TPoint): Boolean;



// Determines whether the given point (client coordinates!) hits the horizontal splitter area of the header.



var

  R, RW: TRect;



begin

  if (P.Y > 2) or (P.Y < -2) or not (hoVisible in FOptions) then

    Result := False

  else

  begin

    R := Treeview.FHeaderRect;

    Inc(R.Bottom, 2);



    // Current position of the owner in screen coordinates.

    GetWindowRect(Treeview.Handle, RW);



    // Convert to client coordinates.

    MapWindowPoints(0, Treeview.Handle, RW, 2);



    // Consider the header within this rectangle.

    OffsetRect(R, RW.Left, RW.Top);

    Result := PtInRect(R, P);

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TVTHeader.Invalidate(Column: TVirtualTreeColumn; ExpandToBorder: Boolean = False);



// Because the header is in the non-client area of the tree it needs some special handling in order to initiate its

// repainting.

// If ExpandToBorder is True then not only the given column but everything or (depending on hoFullRepaintOnResize) just

// everything to its right (or left, in RTL mode) will be invalidated (useful for resizing). This makes only sense when

// a column is given.



var

  R, RW: TRect;



begin

  if (hoVisible in FOptions) and Treeview.HandleAllocated then

    with Treeview do

    begin

      if Column = nil then

        R := FHeaderRect

      else

      begin

        R := Column.GetRect;

        if not (coFixed in Column.Options) then

          OffsetRect(R, -FEffectiveOffsetX, 0);

        if UseRightToLeftAlignment then

          OffsetRect(R, ComputeRTLOffset, 0);

        if ExpandToBorder then

        begin

          if (hoFullRepaintOnResize in FHeader.FOptions) then

          begin

            R.Left := FHeaderRect.Left;

            R.Right := FHeaderRect.Right;

          end

          else

          begin

            if UseRightToLeftAlignment then

              R.Left := FHeaderRect.Left

            else

              R.Right := FHeaderRect.Right;

          end;

        end;

      end;



      // Current position of the owner in screen coordinates.

      GetWindowRect(Handle, RW);



      // Consider the header within this rectangle.

      OffsetRect(R, RW.Left, RW.Top);



      // Expressed in client coordinates (because RedrawWindow wants them so, they will actually become negative).

      MapWindowPoints(0, Handle, R, 2);

      RedrawWindow(Handle, @R, 0, RDW_FRAME or RDW_INVALIDATE or RDW_VALIDATE or RDW_NOINTERNALPAINT or

        RDW_NOERASE or RDW_NOCHILDREN);

    end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TVTHeader.LoadFromStream(const Stream: TStream);



// restore the state of the header from the given stream



var

  Dummy,

  Version: Integer;

  S: AnsiString;

  OldOptions: TVTHeaderOptions;



begin

  Include(FStates, hsLoading);

  with Stream do

  try

    // Switch off all options which could influence loading the columns (they will be later set again).

    OldOptions := FOptions;

    FOptions := [];



    // Determine whether the stream contains data without a version number.

    ReadBuffer(Dummy, SizeOf(Dummy));

    if Dummy > -1 then

    begin

      // Seek back to undo the read operation if this is an old stream format.

      Seek(-SizeOf(Dummy), soFromCurrent);

      Version := -1;

    end

    else // Read version number if this is a "versionized" format.

      ReadBuffer(Version, SizeOf(Version));

    Columns.LoadFromStream(Stream, Version);



    ReadBuffer(Dummy, SizeOf(Dummy));

    AutoSizeIndex := Dummy;

    ReadBuffer(Dummy, SizeOf(Dummy));

    Background := Dummy;

    ReadBuffer(Dummy, SizeOf(Dummy));

    Height := Dummy;

    ReadBuffer(Dummy, SizeOf(Dummy));

    FOptions := OldOptions;

    Options := TVTHeaderOptions(Dummy);

    // PopupMenu is neither saved nor restored

    ReadBuffer(Dummy, SizeOf(Dummy));

    Style := TVTHeaderStyle(Dummy);

    // TFont has no own save routine so we do it manually

    with Font do

    begin

      ReadBuffer(Dummy, SizeOf(Dummy));

      Color := Dummy;

      ReadBuffer(Dummy, SizeOf(Dummy));

      Height := Dummy;

      ReadBuffer(Dummy, SizeOf(Dummy));

      SetLength(S, Dummy);

      ReadBuffer(PAnsiChar(S)^, Dummy);

      if VTHeaderStreamVersion >= 4 then

        {$if CompilerVersion >= 20}

        Name := UTF8ToString(S)

        {$else}

        Name := UTF8Decode(S)

        {$ifend}

      else

        Name := S;

      ReadBuffer(Dummy, SizeOf(Dummy));

      Pitch := TFontPitch(Dummy);

      ReadBuffer(Dummy, SizeOf(Dummy));

      Style := TFontStyles(Byte(Dummy));

    end;



    // Read data introduced by stream version 1+.

    if Version > 0 then

    begin

      ReadBuffer(Dummy, SizeOf(Dummy));

      MainColumn := Dummy;

      ReadBuffer(Dummy, SizeOf(Dummy));

      SortColumn := Dummy;

      ReadBuffer(Dummy, SizeOf(Dummy));

      SortDirection := TSortDirection(Byte(Dummy));

    end;



    // Read data introduced by stream version 5+.

    if Version > 4 then

    begin

      ReadBuffer(Dummy, SizeOf(Dummy));

      ParentFont := Boolean(Dummy);

      ReadBuffer(Dummy, SizeOf(Dummy));

      FMaxHeight := Integer(Dummy);

      ReadBuffer(Dummy, SizeOf(Dummy));

      FMinHeight := Integer(Dummy);

      ReadBuffer(Dummy, SizeOf(Dummy));

      FDefaultHeight := Integer(Dummy);

      with FFixedAreaConstraints do

      begin

        ReadBuffer(Dummy, SizeOf(Dummy));

        FMaxHeightPercent := TVTConstraintPercent(Dummy);

        ReadBuffer(Dummy, SizeOf(Dummy));

        FMaxWidthPercent := TVTConstraintPercent(Dummy);

        ReadBuffer(Dummy, SizeOf(Dummy));

        FMinHeightPercent := TVTConstraintPercent(Dummy);

        ReadBuffer(Dummy, SizeOf(Dummy));

        FMinWidthPercent := TVTConstraintPercent(Dummy);

      end;

    end;

  finally

    Exclude(FStates, hsLoading);

    Treeview.DoColumnResize(NoColumn);

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



function TVTHeader.ResizeColumns(ChangeBy: Integer; RangeStartCol: TColumnIndex; RangeEndCol: TColumnIndex;

  Options: TVTColumnOptions = [coVisible]): Integer;



// Distribute the given width change to a range of columns. A 'fair' way is used to distribute ChangeBy to the columns,

// while ensuring that everything that can be distributed will be distributed.



var

  Start,

  I: TColumnIndex;

  ColCount,

  ToGo,

  Sign,

  Rest,

  MaxDelta,

  Difference: Integer;

  Constraints,

  Widths: array of Integer;

  BonusPixel: Boolean;



  //--------------- local functions -------------------------------------------



  function IsResizable (Column: TColumnIndex): Boolean;



  begin

    if BonusPixel then

      Result := Widths[Column - RangeStartCol] < Constraints[Column - RangeStartCol]

    else

      Result := Widths[Column - RangeStartCol] > Constraints[Column - RangeStartCol];

  end;



  //---------------------------------------------------------------------------



  procedure IncDelta(Column: TColumnIndex);



  begin

    if BonusPixel then

      Inc(MaxDelta, FColumns[Column].MaxWidth - Widths[Column - RangeStartCol])

    else

      Inc(MaxDelta, Widths[Column - RangeStartCol] - Constraints[Column - RangeStartCol]);

  end;



  //---------------------------------------------------------------------------



  function ChangeWidth(Column: TColumnIndex; Delta: Integer): Integer;



  begin

    if Delta > 0 then

      Delta := Min(Delta, Constraints[Column - RangeStartCol] - Widths[Column - RangeStartCol])

    else

      Delta := Max(Delta, Constraints[Column - RangeStartCol] - Widths[Column - RangeStartCol]);



    Inc(Widths[Column - RangeStartCol], Delta);

    Dec(ToGo, Abs(Delta));

    Result := Abs(Delta);

  end;



  //---------------------------------------------------------------------------



  function ReduceConstraints: Boolean;



  var

    MaxWidth,

    MaxReserveCol,

    Column: TColumnIndex;



  begin

    Result := True;

    if not (hsScaling in FStates) or BonusPixel then

      Exit;



    MaxWidth := 0;

    MaxReserveCol := NoColumn;

    for Column := RangeStartCol to RangeEndCol do

      if (Options * FColumns[Column].FOptions = Options) and

         (FColumns[Column].FWidth > MaxWidth) then

      begin

        MaxWidth := Widths[Column - RangeStartCol];

        MaxReserveCol := Column;

      end;



    if (MaxReserveCol <= NoColumn) or (Constraints[MaxReserveCol - RangeStartCol] <= 10) then

      Result := False

    else

      Dec(Constraints[MaxReserveCol - RangeStartCol],

          Constraints[MaxReserveCol - RangeStartCol] div 10);

  end;



  //----------- end local functions -------------------------------------------



begin

  Result := 0;

  if ChangeBy <> 0 then

  begin

    // Do some initialization here

    BonusPixel := ChangeBy > 0;

    Sign := IfThen(BonusPixel, 1, -1);

    Start := IfThen(BonusPixel, RangeStartCol, RangeEndCol);

    ToGo := Abs(ChangeBy);

    SetLength(Widths, RangeEndCol - RangeStartCol + 1);

    SetLength(Constraints, RangeEndCol - RangeStartCol + 1);

    for I := RangeStartCol to RangeEndCol do

    begin

      Widths[I - RangeStartCol] := FColumns[I].FWidth;

      Constraints[I - RangeStartCol] := IfThen(BonusPixel, FColumns[I].MaxWidth, FColumns[I].MinWidth);

    end;



    repeat

      repeat

        MaxDelta := 0;

        ColCount := 0;

        for I := RangeStartCol to RangeEndCol do

          if (Options * FColumns[I].FOptions = Options) and IsResizable(I) then

          begin

            Inc(ColCount);

            IncDelta(I);

          end;

        if MaxDelta < Abs(ChangeBy) then

          if not ReduceConstraints then

            Break;

      until (MaxDelta >= Abs(ChangeBy)) or not (hsScaling in FStates);



      if ColCount = 0 then

        Break;



      ToGo := Min(ToGo, MaxDelta);

      Difference := ToGo div ColCount;

      Rest := ToGo mod ColCount;



      if Difference > 0 then

        for I := RangeStartCol to RangeEndCol do

          if (Options * FColumns[I].FOptions = Options) and IsResizable(I) then

            ChangeWidth(I, Difference * Sign);



      // Now distribute Rest.

      I := Start;

      while Rest > 0 do

      begin

        if (Options * FColumns[I].FOptions = Options) and IsResizable(I) then

          if FColumns[I].FBonusPixel <> BonusPixel then

          begin

            Dec(Rest, ChangeWidth(I, Sign));

            FColumns[I].FBonusPixel := BonusPixel;

          end;

        Inc(I, Sign);

        if (BonusPixel and (I > RangeEndCol)) or (not BonusPixel and (I < RangeStartCol)) then

        begin

          for I := RangeStartCol to RangeEndCol do

            if Options * FColumns[I].FOptions = Options then

              FColumns[I].FBonusPixel := not FColumns[I].FBonusPixel;

          I := Start;

        end;

      end;

    until ToGo <= 0;



    // Now set the computed widths. We also compute the result here.

    Include(FStates, hsResizing);

    for I := RangeStartCol to RangeEndCol do

      if (Options * FColumns[I].FOptions = Options) then

      begin

        Inc(Result, Widths[I - RangeStartCol] - FColumns[I].FWidth);

        FColumns[I].SetWidth(Widths[I - RangeStartCol]);

      end;

    Exclude(FStates, hsResizing);

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TVTHeader.RestoreColumns;



// Restores all columns to their width which they had before they have been auto fitted.



var

  I: TColumnIndex;



begin

  with FColumns do

    for I := Count - 1 downto 0 do

      if [coResizable, coVisible] * Items[FPositionToIndex[I]].FOptions = [coResizable, coVisible] then

        Items[I].RestoreLastWidth;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TVTHeader.SaveToStream(const Stream: TStream);



// Saves the complete state of the header into the provided stream.



var

  Dummy: Integer;

  Tmp: AnsiString;



begin

  with Stream do

  begin

    // In previous version of VT was no header stream version defined.

    // For feature enhancements it is necessary, however, to know which stream

    // format we are trying to load.

    // In order to distict from non-version streams an indicator is inserted.

    Dummy := -1;

    WriteBuffer(Dummy, SizeOf(Dummy));

    // Write current stream version number, nothing more is required at the time being.

    Dummy := VTHeaderStreamVersion;

    WriteBuffer(Dummy, SizeOf(Dummy));



    // Save columns in case they depend on certain options (like auto size).

    Columns.SaveToStream(Stream);



    Dummy := FAutoSizeIndex;

    WriteBuffer(Dummy, SizeOf(Dummy));

    Dummy := FBackground;

    WriteBuffer(Dummy, SizeOf(Dummy));

    Dummy := FHeight;

    WriteBuffer(Dummy, SizeOf(Dummy));

    Dummy := Integer(FOptions);

    WriteBuffer(Dummy, SizeOf(Dummy));

    // PopupMenu is neither saved nor restored

    Dummy := Ord(FStyle);

    WriteBuffer(Dummy, SizeOf(Dummy));

    // TFont has no own save routine so we do it manually

    with Font do

    begin

      Dummy := Color;

      WriteBuffer(Dummy, SizeOf(Dummy));



      // Need only to write one: size or height, I decided to write height.

      Dummy := Height;

      WriteBuffer(Dummy, SizeOf(Dummy));

      Tmp := UTF8Encode(Name);

      Dummy := Length(Tmp);

      WriteBuffer(Dummy, SizeOf(Dummy));

      WriteBuffer(PAnsiChar(Tmp)^, Dummy);

      Dummy := Ord(Pitch);

      WriteBuffer(Dummy, SizeOf(Dummy));

      Dummy := Byte(Style);

      WriteBuffer(Dummy, SizeOf(Dummy));

    end;



    // Data introduced by stream version 1.

    Dummy := FMainColumn;

    WriteBuffer(Dummy, SizeOf(Dummy));

    Dummy := FSortColumn;

    WriteBuffer(Dummy, SizeOf(Dummy));

    Dummy := Byte(FSortDirection);

    WriteBuffer(Dummy, SizeOf(Dummy));



    // Data introduced by stream version 5.

    Dummy := Integer(ParentFont);

    WriteBuffer(Dummy, SizeOf(Dummy));

    Dummy := Integer(FMaxHeight);

    WriteBuffer(Dummy, SizeOf(Dummy));

    Dummy := Integer(FMinHeight);

    WriteBuffer(Dummy, SizeOf(Dummy));

    Dummy := Integer(FDefaultHeight);

    WriteBuffer(Dummy, SizeOf(Dummy));

    with FFixedAreaConstraints do

    begin

      Dummy := Integer(FMaxHeightPercent);

      WriteBuffer(Dummy, SizeOf(Dummy));

      Dummy := Integer(FMaxWidthPercent);

      WriteBuffer(Dummy, SizeOf(Dummy));

      Dummy := Integer(FMinHeightPercent);

      WriteBuffer(Dummy, SizeOf(Dummy));

      Dummy := Integer(FMinWidthPercent);

      WriteBuffer(Dummy, SizeOf(Dummy));

    end;

  end;

end;



//----------------- TScrollBarOptions ----------------------------------------------------------------------------------



constructor TScrollBarOptions.Create(AOwner: TBaseVirtualTree);



begin

  inherited Create;



  FOwner := AOwner;

  FAlwaysVisible := False;

  FScrollBarStyle := sbmRegular;

  FScrollBars := ssBoth;

  FIncrementX := 20;

  FIncrementY := 20;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TScrollBarOptions.SetAlwaysVisible(Value: Boolean);



begin

  if FAlwaysVisible <> Value then

  begin

    FAlwaysVisible := Value;

    if not (csLoading in FOwner.ComponentState) and FOwner.HandleAllocated then

      FOwner.RecreateWnd;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TScrollBarOptions.SetScrollBars(Value: TScrollStyle);



begin

  if FScrollBars <> Value then

  begin

    FScrollBars := Value;

    if not (csLoading in FOwner.ComponentState) and FOwner.HandleAllocated then

      FOwner.RecreateWnd;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TScrollBarOptions.SetScrollBarStyle(Value: TScrollBarStyle);



begin

  if FScrollBarStyle <> Value then

  begin

    FScrollBarStyle := Value;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



function TScrollBarOptions.GetOwner: TPersistent;



begin

  Result := FOwner;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TScrollBarOptions.Assign(Source: TPersistent);



begin

  if Source is TScrollBarOptions then

  begin

    AlwaysVisible := TScrollBarOptions(Source).AlwaysVisible;

    HorizontalIncrement := TScrollBarOptions(Source).HorizontalIncrement;

    ScrollBars := TScrollBarOptions(Source).ScrollBars;

    ScrollBarStyle := TScrollBarOptions(Source).ScrollBarStyle;

    VerticalIncrement := TScrollBarOptions(Source).VerticalIncrement;

  end

  else

    inherited;

end;



//----------------- TVTColors ------------------------------------------------------------------------------------------



constructor TVTColors.Create(AOwner: TBaseVirtualTree);



begin

  FOwner := AOwner;

  FColors[0] := clBtnShadow;      // DisabledColor

  FColors[1] := clHighlight;      // DropMarkColor

  FColors[2] := clHighLight;      // DropTargetColor

  FColors[3] := clHighLight;      // FocusedSelectionColor

  FColors[4] := clBtnFace;        // GridLineColor

  FColors[5] := clBtnShadow;      // TreeLineColor

  FColors[6] := clBtnFace;        // UnfocusedSelectionColor

  FColors[7] := clBtnFace;        // BorderColor

  FColors[8] := clWindowText;     // HotColor

  FColors[9] := clHighLight;      // FocusedSelectionBorderColor

  FColors[10] := clBtnFace;       // UnfocusedSelectionBorderColor

  FColors[11] := clHighlight;     // DropTargetBorderColor

  FColors[12] := clHighlight;     // SelectionRectangleBlendColor

  FColors[13] := clHighlight;     // SelectionRectangleBorderColor

  FColors[14] := clBtnShadow;     // HeaderHotColor

  FColors[15] := clHighlightText; // SelectionTextColor

  FColors[16] := clBtnFace;       // UnfocusedColor  [IPK]

end;



//----------------------------------------------------------------------------------------------------------------------



function TVTColors.GetBackgroundColor: TColor;

begin

// XE2 VCL Style

{$IF CompilerVersion >= 23}

  if FOwner.VclStyleEnabled {$IF CompilerVersion >= 24}and (seClient in FOwner.StyleElements){$IFEND} then

    Result := StyleServices.GetStyleColor(scTreeView)

  else

{$IFEND}

    Result := FOwner.Color;

end;



//----------------------------------------------------------------------------------------------------------------------



function TVTColors.GetColor(const Index: Integer): TColor;



begin

{$IF CompilerVersion >= 23 }

  if FOwner.VclStyleEnabled then

  begin

    case Index of

      0:

        StyleServices.GetElementColor(StyleServices.GetElementDetails(ttItemDisabled), ecTextColor, Result); // DisabledColor

      1:

        Result := StyleServices.GetSystemColor(clHighlight); // DropMarkColor

      2:

        Result := StyleServices.GetSystemColor(clHighlight); // DropTargetColor

      3:

        Result := StyleServices.GetSystemColor(clHighlight); // FocusedSelectionColor

      4:

        Result := StyleServices.GetSystemColor(clBtnFace); // GridLineColor

      5:

        StyleServices.GetElementColor(StyleServices.GetElementDetails(ttBranch), ecBorderColor, Result); // TreeLineColor

      6:

        Result := StyleServices.GetSystemColor(clHighlight); // UnfocusedSelectionColor

      7:

        Result := StyleServices.GetSystemColor(clBtnFace); // BorderColor

      8:

        if not StyleServices.GetElementColor(StyleServices.GetElementDetails(ttItemHot), ecTextColor, Result) or

          (Result <> clWindowText) then

          Result := NodeFontColor; // HotColor

      9:

        StyleServices.GetElementColor(StyleServices.GetElementDetails(ttItemSelected), ecFillColor, Result);

      // FocusedSelectionBorderColor

      10:

        Result := StyleServices.GetSystemColor(clHighlight); // UnfocusedSelectionBorderColor

      11:

        Result := StyleServices.GetSystemColor(clBtnFace); // DropTargetBorderColor

      12:

        Result := StyleServices.GetSystemColor(clHighlight); // SelectionRectangleBlendColor

      13:

        Result := StyleServices.GetSystemColor(clHighlight); // SelectionRectangleBorderColor

      14:

        StyleServices.GetElementColor(StyleServices.GetElementDetails(thHeaderItemNormal), ecTextColor, Result); // HeaderHotColor

      15:

        if not StyleServices.GetElementColor(StyleServices.GetElementDetails(ttItemSelected), ecTextColor, Result) or

          (Result <> clWindowText) then

          Result := NodeFontColor; // SelectionTextColor

    end;

  end

  else

{$IFEND}

  Result := FColors[Index];

end;



//----------------------------------------------------------------------------------------------------------------------



function TVTColors.GetHeaderFontColor: TColor;

begin

// XE2+ VCL Style

{$IF CompilerVersion >= 23}

  if FOwner.VclStyleEnabled {$IF CompilerVersion >= 24}and (seFont in FOwner.StyleElements){$IFEND} then

    StyleServices.GetElementColor(StyleServices.GetElementDetails(thHeaderItemNormal), ecTextColor, Result)

  else

{$IFEND}

    Result := FOwner.FHeader.Font.Color;

end;



//----------------------------------------------------------------------------------------------------------------------



function TVTColors.GetNodeFontColor: TColor;

begin

{$IF CompilerVersion >= 23}

  if FOwner.VclStyleEnabled {$IF CompilerVersion >= 24}and (seFont in FOwner.StyleElements){$IFEND} then

    StyleServices.GetElementColor(StyleServices.GetElementDetails(ttItemNormal), ecTextColor, Result)

  else

{$IFEND}

    Result := FOwner.Font.Color;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TVTColors.SetColor(const Index: Integer; const Value: TColor);



begin

  if FColors[Index] <> Value then

  begin

    FColors[Index] := Value;

    if not (csLoading in FOwner.ComponentState) and FOwner.HandleAllocated then

    begin

      // Cause helper bitmap rebuild if the button color changed.

      case Index of

        5:

          begin

            FOwner.PrepareBitmaps(True, False);

            FOwner.Invalidate;

          end;

        7:

          RedrawWindow(FOwner.Handle, nil, 0, RDW_FRAME or RDW_INVALIDATE or RDW_NOERASE or RDW_NOCHILDREN)

      else

        FOwner.Invalidate;

      end;

    end;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TVTColors.Assign(Source: TPersistent);



begin

  if Source is TVTColors then

  begin

    FColors := TVTColors(Source).FColors;

    if FOwner.FUpdateCount = 0 then

      FOwner.Invalidate;

  end

  else

    inherited;

end;



//----------------- TClipboardFormats ----------------------------------------------------------------------------------



constructor TClipboardFormats.Create(AOwner: TBaseVirtualTree);



begin

  FOwner := AOwner;

  Sorted := True;

  Duplicates := dupIgnore;

end;



//----------------------------------------------------------------------------------------------------------------------



function TClipboardFormats.Add(const S: string): Integer;



// Restrict additions to the clipbard formats to only those which are registered with the owner tree or one of its

// ancestors.



var

  Format: Word;

  RegisteredClass: TVirtualTreeClass;



begin

  RegisteredClass := InternalClipboardFormats.FindFormat(S, Format);

  if Assigned(RegisteredClass) and FOwner.ClassType.InheritsFrom(RegisteredClass) then

    Result := inherited Add(S)

  else

    Result := -1;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TClipboardFormats.Insert(Index: Integer; const S: string);



// Restrict additions to the clipbard formats to only those which are registered with the owner tree or one of its

// ancestors.



var

  Format: Word;

  RegisteredClass: TVirtualTreeClass;



begin

  RegisteredClass := InternalClipboardFormats.FindFormat(S, Format);

  if Assigned(RegisteredClass) and FOwner.ClassType.InheritsFrom(RegisteredClass) then

    inherited Insert(Index, S);

end;



//----------------- TBaseVirtualTree -----------------------------------------------------------------------------------



constructor TBaseVirtualTree.Create(AOwner: TComponent);



begin

  if not Initialized then

    InitializeGlobalStructures;



  inherited;



  ControlStyle := ControlStyle - [csSetCaption] + [csCaptureMouse, csOpaque, csReplicatable, csDisplayDragImage,

    csReflector];

  FTotalInternalDataSize := 0;

  FNodeDataSize := -1;

  Width := 200;

  Height := 100;

  TabStop := True;

  ParentColor := False;

  FDefaultNodeHeight := 18;

  FDragOperations := [doCopy, doMove];

  FHotCursor := crDefault;

  FScrollBarOptions := TScrollBarOptions.Create(Self);

  FFocusedColumn := NoColumn;

  FDragImageKind := diComplete;

  FLastSelectionLevel := -1;

  FAnimationType := hatSystemDefault;

  FSelectionBlendFactor := 128;



  FIndent := 18;



  FPlusBM := TBitmap.Create;

  FHotPlusBM := TBitmap.Create;

  FMinusBM := TBitmap.Create;

  FHotMinusBM := TBitmap.Create;



  FBorderStyle := bsSingle;

  FButtonStyle := bsRectangle;

  FButtonFillMode := fmTreeColor;



  FHeader := GetHeaderClass.Create(Self);



  // we have an own double buffer handling

  inherited DoubleBuffered := False;



  FCheckImageKind := ckSystemDefault;

  FCheckImages := SystemCheckImages;



  FImageChangeLink := TChangeLink.Create;

  FImageChangeLink.OnChange := ImageListChange;

  FStateChangeLink := TChangeLink.Create;

  FStateChangeLink.OnChange := ImageListChange;

  FCustomCheckChangeLink := TChangeLink.Create;

  FCustomCheckChangeLink.OnChange := ImageListChange;



  FAutoExpandDelay := 1000;

  FAutoScrollDelay := 1000;

  FAutoScrollInterval := 1;



  FBackground := TPicture.Create;



  FDefaultPasteMode := amAddChildLast;

  FMargin := 4;

  FTextMargin := 4;

  FLastDragEffect := DROPEFFECT_NONE;

  FDragType := dtOLE;

  FDragHeight := 350;

  FDragWidth := 200;



  FColors := TVTColors.Create(Self);

  FEditDelay := 1000;



  FDragImage := TVTDragImage.Create(Self);

  with FDragImage do

  begin

    Fade := True;

    PostBlendBias := 0;

    PreBlendBias := 0;

    Transparency := 200;

  end;



  SetLength(FSingletonNodeArray, 1);

  FAnimationDuration := 200;

  FSearchTimeout := 1000;

  FSearchStart := ssFocusedNode;

  FNodeAlignment := naProportional;

  FLineStyle := lsDotted;

  FIncrementalSearch := isNone;

  FClipboardFormats := TClipboardFormats.Create(Self);

  FOptions := GetOptionsClass.Create(Self);



  AddThreadReference;



  FVclStyleEnabled := False;

  // XE2+ VCL Style

  {$if CompilerVersion >= 23 }

  FSetOrRestoreBevelKindAndBevelWidth := False;

  FSavedBevelKind := bkNone;

  FSavedBorderWidth := 0;

  {$ifend}

end;



//----------------------------------------------------------------------------------------------------------------------



destructor TBaseVirtualTree.Destroy;



begin

  InterruptValidation();

  Exclude(FOptions.FMiscOptions, toReadOnly);

  ReleaseThreadReference(Self);

  StopWheelPanning;

  CancelEditNode;



  // Just in case it didn't happen already release the edit link.

  FEditLink := nil;

  FClipboardFormats.Free;

  // Clear will also free the drag manager if it is still alive.

  Clear;

  FDragImage.Free;

  FColors.Free;

  FBackground.Free;

  FImageChangeLink.Free;

  FStateChangeLink.Free;

  FCustomCheckChangeLink.Free;

  FScrollBarOptions.Free;



  // The window handle must be destroyed before the header is freed because it is needed in WM_NCDESTROY.

  if HandleAllocated then

    DestroyWindowHandle;



  // Release FDottedBrush in case WM_NCDESTROY hasn't been triggered.

  if FDottedBrush <> 0 then

    DeleteObject(FDottedBrush);

  FDottedBrush := 0;



  FHeader.Free;

  FHeader := nil; // Do not use FreeAndNil() before checking issue #497

  FreeAndNil(FOptions); // WM_NCDESTROY accesses FOptions



  FreeMem(FRoot);



  FPlusBM.Free;

  FHotPlusBM.Free;

  FMinusBM.Free;

  FHotMinusBM.Free;



  inherited;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.AdjustCoordinatesByIndent(var PaintInfo: TVTPaintInfo; Indent: Integer);



// During painting of the main column some coordinates must be adjusted due to the tree lines.

// The offset resulting from the tree lines and indentation level is given in Indent.



var

  Offset: Integer;



begin

  with PaintInfo do

  begin

    Offset := Indent * Integer(FIndent);

    if BidiMode = bdLeftToRight then

    begin

      Inc(ContentRect.Left, Offset);

      Inc(ImageInfo[iiNormal].XPos, Offset);

      Inc(ImageInfo[iiState].XPos, Offset);

      Inc(ImageInfo[iiCheck].XPos, Offset);

    end

    else

    begin

      Dec(ContentRect.Right, Offset);

      Dec(ImageInfo[iiNormal].XPos, Offset);

      Dec(ImageInfo[iiState].XPos, Offset);

      Dec(ImageInfo[iiCheck].XPos, Offset);

    end;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.AdjustTotalCount(Node: PVirtualNode; Value: Integer; Relative: Boolean = False);



// Sets a node's total count to the given value and recursively adjusts the parent's total count

// (actually, the adjustment is done iteratively to avoid function call overheads).



var

  Difference: Integer;

  Run: PVirtualNode;



begin

  if Relative then

    Difference := Value

  else

    Difference := Value - Integer(Node.TotalCount);

  if Difference <> 0 then

  begin

    Run := Node;

    // Root node has as parent the tree view.

    while Assigned(Run) and (Run <> Pointer(Self)) do

    begin

      Inc(Integer(Run.TotalCount), Difference);

      Run := Run.Parent;

    end;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.AdjustTotalHeight(Node: PVirtualNode; Value: Integer; Relative: Boolean = False);



// Sets a node's total height to the given value and recursively adjusts the parent's total height.



var

  Difference: Integer;

  Run: PVirtualNode;



begin

  if Relative then

    Difference := Value

  else

    Difference := Value - Integer(Node.TotalHeight);

  if Difference <> 0 then

  begin

    Run := Node;

    repeat

      Inc(Integer(Run.TotalHeight), Difference);

      // If the node is not visible or the parent node is not expanded or we are already at the top

      // then nothing more remains to do.

      if not (vsVisible in Run.States) or (Run = FRoot) or

        (Run.Parent = nil) or not (vsExpanded in Run.Parent.States) then

        Break;



      Run := Run.Parent;

    until False;

  end;



  UpdateVerticalRange;

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.CalculateCacheEntryCount: Integer;



// Calculates the size of the position cache.



begin

  if FVisibleCount > 1 then

    Result := Ceil(FVisibleCount / CacheThreshold)

  else

    Result := 0;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.CalculateVerticalAlignments(ShowImages, ShowStateImages: Boolean; Node: PVirtualNode;

  var VAlign, VButtonAlign: Integer);



// Calculates the vertical alignment of the given node and its associated expand/collapse button during

// a node paint cycle depending on the required node alignment style.



begin

  // For absolute alignment the calculation is trivial.

  case FNodeAlignment of

    naFromTop:

      VAlign := Node.Align;

    naFromBottom:

      VAlign := Integer(NodeHeight[Node]) - Node.Align;

  else // naProportional

    // Consider button and line alignment, but make sure neither the image nor the button (whichever is taller)

    // go out of the entire node height (100% means bottom alignment to the node's bounds).

    if ShowImages or ShowStateImages then

    begin

      if ShowImages then

        VAlign := GetNodeImageSize(Node).cy

      else

        VAlign := FStateImages.Height;

      VAlign := MulDiv((Integer(NodeHeight[Node]) - VAlign), Node.Align, 100) + VAlign div 2;

    end

    else

      if toShowButtons in FOptions.FPaintOptions then

        VAlign := MulDiv((Integer(NodeHeight[Node]) - FPlusBM.Height), Node.Align, 100) + FPlusBM.Height div 2

      else

        VAlign := MulDiv(Integer(Node.NodeHeight), Node.Align, 100);

  end;



  VButtonAlign := VAlign - FPlusBM.Height div 2 - (FPlusBM.Height and 1);

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.ChangeCheckState(Node: PVirtualNode; Value: TCheckState): Boolean;



// Sets the check state of the node according to the given value and the node's check type.

// If the check state must be propagated to the parent nodes and one of them refuses to change then

// nothing happens and False is returned, otherwise True.



var

  Run: PVirtualNode;

  UncheckedCount,

  MixedCheckCount,

  CheckedCount: Cardinal;



begin

  Result := not (vsChecking in Node.States);

  with Node^ do

  if Result then

  begin

    Include(States, vsChecking);

    try

      if not (vsInitialized in States) then

        InitNode(Node)

      else if CheckState = Value then

      begin

        // Value didn't change and node was initialized, so nothing to do

        Result := False;

        Exit;

      end;//if



      // Indicate that we are going to propagate check states up and down the hierarchy.

      if FCheckPropagationCount = 0 then // WL, 05.02.2004: Do not enter tsCheckPropagation more than once

        DoStateChange([tsCheckPropagation]);

      Inc(FCheckPropagationCount); // WL, 05.02.2004

      // Do actions which are associated with the given check state.

      case CheckType of

        // Check state change with additional consequences for check states of the children.

        ctTriStateCheckBox:

          begin

            // Propagate state down to the children.

            if toAutoTristateTracking in FOptions.FAutoOptions then

              case Value of

                csUncheckedNormal:

                  if Node.ChildCount > 0 then

                  begin

                    Run := FirstChild;

                    CheckedCount := 0;

                    MixedCheckCount := 0;

                    UncheckedCount := 0;

                    while Assigned(Run) do

                    begin

                      if Run.CheckType in [ctCheckBox, ctTriStateCheckBox] then

                      begin

                        SetCheckState(Run, csUncheckedNormal);

                        // Check if the new child state was set successfully, otherwise we have to adjust the

                        // node's new check state accordingly.

                        case Run.CheckState of

                          csCheckedNormal:

                            Inc(CheckedCount);

                          csMixedNormal:

                            Inc(MixedCheckCount);

                          csUncheckedNormal:

                            Inc(UncheckedCount);

                        end;

                      end;

                      Run := Run.NextSibling;

                    end;



                    // If there is still a mixed state child node checkbox then this node must be mixed checked too.

                    if MixedCheckCount > 0 then

                      Value := csMixedNormal

                    else

                      // If nodes are normally checked child nodes then the unchecked count determines what

                      // to set for the node itself.

                      if CheckedCount > 0 then

                        if UncheckedCount > 0 then

                          Value := csMixedNormal

                        else

                          Value := csCheckedNormal;

                  end;

                csCheckedNormal:

                  if Node.ChildCount > 0 then

                  begin

                    Run := FirstChild;

                    CheckedCount := 0;

                    MixedCheckCount := 0;

                    UncheckedCount := 0;

                    while Assigned(Run) do

                    begin

                      if Run.CheckType in [ctCheckBox, ctTriStateCheckBox] then

                      begin

                        SetCheckState(Run, csCheckedNormal);

                        // Check if the new child state was set successfully, otherwise we have to adjust the

                        // node's new check state accordingly.

                        case Run.CheckState of

                          csCheckedNormal:

                            Inc(CheckedCount);

                          csMixedNormal:

                            Inc(MixedCheckCount);

                          csUncheckedNormal:

                            Inc(UncheckedCount);

                        end;

                      end;

                      Run := Run.NextSibling;

                    end;



                    // If there is still a mixed state child node checkbox then this node must be mixed checked too.

                    if MixedCheckCount > 0 then

                      Value := csMixedNormal

                    else

                      // If nodes are normally checked child nodes then the unchecked count determines what

                      // to set for the node itself.

                      if CheckedCount > 0 then

                        if UncheckedCount > 0 then

                          Value := csMixedNormal

                        else

                          Value := csCheckedNormal;

                  end;

              end;

          end;

        // radio button check state change

        ctRadioButton:

          if Value = csCheckedNormal then

          begin

            Value := csCheckedNormal;

            // Make sure only this node is checked.

            Run := Parent.FirstChild;

            while Assigned(Run) do

            begin

              if Run.CheckType = ctRadioButton then

                Run.CheckState := csUncheckedNormal;

              Run := Run.NextSibling;

            end;

            Invalidate;

          end;

      end;



      if Result then

        CheckState := Value // Set new check state

      else

        CheckState := UnpressedState[CheckState]; // Reset dynamic check state.



      // Propagate state up to the parent.

      if not (vsInitialized in Parent.States) then

        InitNode(Parent);

      if (toAutoTristateTracking in FOptions.FAutoOptions) and ([vsChecking, vsDisabled] * Parent.States = []) and

        (CheckType in [ctCheckBox, ctTriStateCheckBox]) and (Parent <> FRoot) and

        (Parent.CheckType = ctTriStateCheckBox) then

        Result := CheckParentCheckState(Node, Value)

      else

        Result := True;



      InvalidateNode(Node);



      Dec(FCheckPropagationCount); // WL, 05.02.2004

      if FCheckPropagationCount = 0 then // WL, 05.02.2004: Allow state change event after all check operations finished

        DoStateChange([], [tsCheckPropagation]);

    finally

      Exclude(States, vsChecking);

    end;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.CollectSelectedNodesLTR(MainColumn, NodeLeft, NodeRight: Integer; Alignment: TAlignment;

  OldRect, NewRect: TRect): Boolean;



// Helper routine used when a draw selection takes place. This version handles left-to-right directionality.

// In the process of adding or removing nodes the current selection is modified which requires to pack it after

// the function returns. Another side effect of this method is that a temporary list of nodes will be created

// (see also InternalCacheNode) which must be inserted into the current selection by the caller.



var

  Run,

  NextNode: PVirtualNode;

  TextRight,

  TextLeft,

  CheckOffset,

  CurrentTop,

  CurrentRight,

  NextTop,

  NextColumn,

  NodeWidth,

  Dummy: Integer;

  MinY, MaxY: Integer;

  StateImageOffset: Integer;

  IsInOldRect,

  IsInNewRect: Boolean;



  // quick check variables for various parameters

  WithCheck,

  WithImages,

  WithStateImages,

  DoSwitch,

  AutoSpan: Boolean;

  SimpleSelection: Boolean;



begin

  // A priori nothing changes.

  Result := False;



  // Determine minimum and maximum vertical coordinates to limit iteration to.

  MinY := Min(OldRect.Top, NewRect.Top);

  MaxY := Max(OldRect.Bottom, NewRect.Bottom);



  // Initialize short hand variables to speed up tests below.

  DoSwitch := ssCtrl in FDrawSelShiftState;

  WithCheck := (toCheckSupport in FOptions.FMiscOptions) and Assigned(FCheckImages);

  // Don't check the events here as descendant trees might have overriden the DoGetImageIndex method.

  WithImages := Assigned(FImages);

  WithStateImages := Assigned(FStateImages);

  if WithStateImages then

    StateImageOffset := FStateImages.Width + 2

  else

    StateImageOffset := 0;

  if WithCheck then

    CheckOffset := FCheckImages.Width + 2

  else

    CheckOffset := 0;

  AutoSpan := FHeader.UseColumns and (toAutoSpanColumns in FOptions.FAutoOptions);

  SimpleSelection := toSimpleDrawSelection in FOptions.FSelectionOptions;

  // This is the node to start with.

  Run := GetNodeAt(0, MinY, False, CurrentTop);



  if Assigned(Run) then

  begin

    // The initial minimal left border is determined by the identation level of the node and is dynamically adjusted.

    if toShowRoot in FOptions.FPaintOptions then

      Inc(NodeLeft, Integer((GetNodeLevel(Run) + 1) * FIndent) + FMargin)

    else

      Inc(NodeLeft, Integer(GetNodeLevel(Run) * FIndent) + FMargin);



    // ----- main loop

    // Change selection depending on the node's rectangle being in the selection rectangle or not, but

    // touch only those nodes which overlap either the old selection rectangle or the new one but not both.

    repeat

      // Collect offsets for check, normal and state images.

      TextLeft := NodeLeft;

      if WithCheck and (Run.CheckType <> ctNone) then

        Inc(TextLeft, CheckOffset);

      if WithImages and HasImage(Run, ikNormal, MainColumn) then

        Inc(TextLeft, GetNodeImageSize(Run).cx + 2);

      if WithStateImages and HasImage(Run, ikState, MainColumn) then

        Inc(TextLeft, StateImageOffset);

      NextTop := CurrentTop + Integer(NodeHeight[Run]);



      // Simple selection allows to draw the selection rectangle anywhere. No intersection with node captions is

      // required. Only top and bottom bounds of the rectangle matter.

      if SimpleSelection or (toFullRowSelect in FOptions.FSelectionOptions) then

      begin

        IsInOldRect := (NextTop > OldRect.Top) and (CurrentTop < OldRect.Bottom) and

          ((FHeader.Columns.Count = 0) or (FHeader.Columns.TotalWidth > OldRect.Left)) and (NodeLeft < OldRect.Right);

        IsInNewRect := (NextTop > NewRect.Top) and (CurrentTop < NewRect.Bottom) and

          ((FHeader.Columns.Count = 0) or (FHeader.Columns.TotalWidth > NewRect.Left)) and (NodeLeft < NewRect.Right);

      end

      else

      begin

        // The right column border might be extended if column spanning is enabled.

        if AutoSpan then

        begin

          with FHeader.FColumns do

          begin

            NextColumn := MainColumn;

            repeat

              Dummy := GetNextVisibleColumn(NextColumn);

              if (Dummy = InvalidColumn) or not ColumnIsEmpty(Run, Dummy) or

                 (Items[Dummy].BidiMode <> bdLeftToRight) then

                Break;

              NextColumn := Dummy;

            until False;

            if NextColumn = MainColumn then

              CurrentRight := NodeRight

            else

              GetColumnBounds(NextColumn, Dummy, CurrentRight);

          end;

        end

        else

          CurrentRight := NodeRight;

          // Check if we need the node's width. This is the case when the node is not left aligned or the

          // left border of the selection rectangle is to the right of the left node border.

          if (TextLeft < OldRect.Left) or (TextLeft < NewRect.Left) or (Alignment <> taLeftJustify) then

          begin

            NodeWidth := DoGetNodeWidth(Run, MainColumn);

            if NodeWidth >= (CurrentRight - TextLeft) then

              TextRight := CurrentRight

            else

              case Alignment of

                taLeftJustify:

                  TextRight := TextLeft + NodeWidth;

                taCenter:

                  begin

                    TextLeft := (TextLeft + CurrentRight - NodeWidth) div 2;

                    TextRight := TextLeft + NodeWidth;

                  end;

              else

                // taRightJustify

                TextRight := CurrentRight;

                TextLeft := TextRight - NodeWidth;

              end;

          end

          else

            TextRight := CurrentRight;



        // Now determine whether we need to change the state.

        IsInOldRect := (OldRect.Left <= TextRight) and (OldRect.Right >= TextLeft) and

          (NextTop > OldRect.Top) and (CurrentTop < OldRect.Bottom);

        IsInNewRect := (NewRect.Left <= TextRight) and (NewRect.Right >= TextLeft) and

          (NextTop > NewRect.Top) and (CurrentTop < NewRect.Bottom);

      end;



      if IsInOldRect xor IsInNewRect then

      begin

        Result := True;

        if DoSwitch then

        begin

          if vsSelected in Run.States then

            InternalRemoveFromSelection(Run)

          else

            InternalCacheNode(Run);

        end

        else

        begin

          if IsInNewRect then

            InternalCacheNode(Run)

          else

            InternalRemoveFromSelection(Run);

          end;

      end;

      CurrentTop := NextTop;

      // Get next visible node and update left node position.

      NextNode := GetNextVisibleNoInit(Run, True);

      if NextNode = nil then

        Break;

      Inc(NodeLeft, CountLevelDifference(Run, NextNode) * Integer(FIndent));

      Run := NextNode;

    until CurrentTop > MaxY;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.CollectSelectedNodesRTL(MainColumn, NodeLeft, NodeRight: Integer; Alignment: TAlignment;

  OldRect, NewRect: TRect): Boolean;



// Helper routine used when a draw selection takes place. This version handles right-to-left directionality.

// See also comments in CollectSelectedNodesLTR.



var

  Run,

  NextNode: PVirtualNode;

  TextRight,

  TextLeft,

  CheckOffset,

  CurrentTop,

  CurrentLeft,

  NextTop,

  NextColumn,

  NodeWidth,

  Dummy: Integer;

  MinY, MaxY: Integer;

  StateImageOffset: Integer;

  IsInOldRect,

  IsInNewRect: Boolean;



  // quick check variables for various parameters

  WithCheck,

  WithImages,

  WithStateImages,

  DoSwitch,

  AutoSpan: Boolean;

  SimpleSelection: Boolean;



begin

  // A priori nothing changes.

  Result := False;

  // Switch the alignment to the opposite value in RTL context.

  ChangeBiDiModeAlignment(Alignment);



  // Determine minimum and maximum vertical coordinates to limit iteration to.

  MinY := Min(OldRect.Top, NewRect.Top);

  MaxY := Max(OldRect.Bottom, NewRect.Bottom);



  // Initialize short hand variables to speed up tests below.

  DoSwitch := ssCtrl in FDrawSelShiftState;

  WithCheck := (toCheckSupport in FOptions.FMiscOptions) and Assigned(FCheckImages);

  // Don't check the events here as descendant trees might have overriden the DoGetImageIndex method.

  WithImages := Assigned(FImages);

  WithStateImages := Assigned(FStateImages);

  if WithStateImages then

    StateImageOffset := FStateImages.Width + 2

  else

    StateImageOffset := 0;

  if WithCheck then

    CheckOffset := FCheckImages.Width + 2

  else

    CheckOffset := 0;

  AutoSpan := FHeader.UseColumns and (toAutoSpanColumns in FOptions.FAutoOptions);

  SimpleSelection := toSimpleDrawSelection in FOptions.FSelectionOptions;

  // This is the node to start with.

  Run := GetNodeAt(0, MinY, False, CurrentTop);



  if Assigned(Run) then

  begin

    // The initial minimal left border is determined by the identation level of the node and is dynamically adjusted.

    if toShowRoot in FOptions.FPaintOptions then

      Dec(NodeRight, Integer((GetNodeLevel(Run) + 1) * FIndent) + FMargin)

    else

      Dec(NodeRight, Integer(GetNodeLevel(Run) * FIndent) + FMargin);



    // ----- main loop

    // Change selection depending on the node's rectangle being in the selection rectangle or not, but

    // touch only those nodes which overlap either the old selection rectangle or the new one but not both.

    repeat

      // Collect offsets for check, normal and state images.

      TextRight := NodeRight;

      if WithCheck and (Run.CheckType <> ctNone) then

        Dec(TextRight, CheckOffset);

      if WithImages and HasImage(Run, ikNormal, MainColumn) then

        Dec(TextRight, GetNodeImageSize(Run).cx + 2);

      if WithStateImages and HasImage(Run, ikState, MainColumn) then

        Dec(TextRight, StateImageOffset);

      NextTop := CurrentTop + Integer(NodeHeight[Run]);



      // Simple selection allows to draw the selection rectangle anywhere. No intersection with node captions is

      // required. Only top and bottom bounds of the rectangle matter.

      if SimpleSelection then

      begin

        IsInOldRect := (NextTop > OldRect.Top) and (CurrentTop < OldRect.Bottom);

        IsInNewRect := (NextTop > NewRect.Top) and (CurrentTop < NewRect.Bottom);

      end

      else

      begin        // The left column border might be extended if column spanning is enabled.

        if AutoSpan then

        begin

          NextColumn := MainColumn;

          repeat

            Dummy := FHeader.FColumns.GetPreviousVisibleColumn(NextColumn);

            if (Dummy = InvalidColumn) or not ColumnIsEmpty(Run, Dummy) or

               (FHeader.FColumns[Dummy].BiDiMode = bdLeftToRight) then

              Break;

            NextColumn := Dummy;

          until False;

          if NextColumn = MainColumn then

            CurrentLeft := NodeLeft

          else

            FHeader.FColumns.GetColumnBounds(NextColumn, CurrentLeft, Dummy);

        end

        else

          CurrentLeft := NodeLeft;

          // Check if we need the node's width. This is the case when the node is not left aligned (in RTL context this        // means actually right aligned) or the right border of the selection rectangle is to the left

          // of the right node border.

          if (TextRight > OldRect.Right) or (TextRight > NewRect.Right) or (Alignment <> taRightJustify) then

          begin

          NodeWidth := DoGetNodeWidth(Run, MainColumn);

          if NodeWidth >= (TextRight - CurrentLeft) then

            TextLeft := CurrentLeft

          else

            case Alignment of

              taLeftJustify:

                begin

                  TextLeft := CurrentLeft;

                  TextRight := TextLeft + NodeWidth;

                end;

              taCenter:

                begin

                  TextLeft := (TextRight + CurrentLeft - NodeWidth) div 2;

                  TextRight := TextLeft + NodeWidth;

                end;

              else

                // taRightJustify

                TextLeft := TextRight - NodeWidth;

            end;

        end

        else

          TextLeft := CurrentLeft;



        // Now determine whether we need to change the state.

        IsInOldRect := (OldRect.Right >= TextLeft) and (OldRect.Left <= TextRight) and

          (NextTop > OldRect.Top) and (CurrentTop < OldRect.Bottom);

        IsInNewRect := (NewRect.Right >= TextLeft) and (NewRect.Left <= TextRight) and

          (NextTop > NewRect.Top) and (CurrentTop < NewRect.Bottom);

      end;



      if IsInOldRect xor IsInNewRect then

      begin

        Result := True;

        if DoSwitch then

        begin

          if vsSelected in Run.States then

            InternalRemoveFromSelection(Run)

          else

            InternalCacheNode(Run);

        end

        else

        begin

          if IsInNewRect then

            InternalCacheNode(Run)

          else

            InternalRemoveFromSelection(Run);

        end;

      end;

      CurrentTop := NextTop;

      // Get next visible node and update left node position.

      NextNode := GetNextVisibleNoInit(Run, True);

      if NextNode = nil then

        Break;

      Dec(NodeRight, CountLevelDifference(Run, NextNode) * Integer(FIndent));

      Run := NextNode;

    until CurrentTop > MaxY;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.ClearNodeBackground(const PaintInfo: TVTPaintInfo; UseBackground, Floating: Boolean;

  R: TRect);



// Erases a node's background depending on what the application decides to do.

// UseBackground determines whether or not to use the background picture, while Floating indicates

// that R is given in coordinates of the small node bitmap or the superordinated target bitmap used in PaintTree.



var

  BackColor: TColor;

  EraseAction: TItemEraseAction;

  Offset: TPoint;



begin

  BackColor := FColors.BackGroundColor;

  with PaintInfo do

  begin

    EraseAction := eaDefault;



    if Floating then

    begin

      Offset := Point(-FEffectiveOffsetX, R.Top);

      OffsetRect(R, 0, -Offset.Y);

    end

    else

      Offset := Point(0, 0);



    DoBeforeItemErase(Canvas, Node, R, BackColor, EraseAction);



    with Canvas do

    begin

      case EraseAction of

        eaNone:

          ;

        eaColor:

          begin

            // User has given a new background color.

            Brush.Color := BackColor;

            FillRect(R);

          end;

      else // eaDefault

        if UseBackground then

        begin

          if toStaticBackground in TreeOptions.PaintOptions then

            StaticBackground(FBackground.Bitmap, Canvas, Offset, R)

          else

            TileBackground(FBackground.Bitmap, Canvas, Offset, R);

        end

        else

        begin

          if (poDrawSelection in PaintOptions) and (toFullRowSelect in FOptions.FSelectionOptions) and

             (vsSelected in Node.States) and not (toUseBlendedSelection in FOptions.PaintOptions) and not

             (tsUseExplorerTheme in FStates) then

          begin

            if toShowHorzGridLines in FOptions.PaintOptions then

            begin

              Brush.Color := BackColor;

              FillRect(Rect(R.Left, R.Bottom - 1, R.Right, R.Bottom));

              Dec(R.Bottom);

            end;

            if Focused or (toPopupMode in FOptions.FPaintOptions) then

            begin

              Brush.Color := FColors.FocusedSelectionColor;

              Pen.Color := FColors.FocusedSelectionBorderColor;

            end

            else

            begin

              Brush.Color := FColors.UnfocusedSelectionColor;

              Pen.Color := FColors.UnfocusedSelectionBorderColor;

            end;



            with TWithSafeRect(R) do

              RoundRect(Left, Top, Right, Bottom, FSelectionCurveRadius, FSelectionCurveRadius);

          end

          else

          begin

            Brush.Color := BackColor;

            FillRect(R);

          end;

        end;

      end;

      DoAfterItemErase(Canvas, Node, R);

    end;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.CompareNodePositions(Node1, Node2: PVirtualNode; ConsiderChildrenAbove: Boolean = False): Integer;



// Tries hard and smart to quickly determine whether Node1's structural position is before Node2's position.

// If ConsiderChildrenAbove is True, the nodes will be compared with their visual order in mind.

// Returns 0 if Node1 = Node2, < 0 if Node1 is located before Node2 else > 0.



var

  Run1,

  Run2: PVirtualNode;

  Level1,

  Level2: Cardinal;



begin

  Assert(Assigned(Node1) and Assigned(Node2), 'Nodes must never be nil.');



  if Node1 = Node2 then

    Result := 0

  else

  begin

    if HasAsParent(Node1, Node2) then

      Result := IfThen(ConsiderChildrenAbove and (toChildrenAbove in FOptions.FPaintOptions), -1, 1)

    else

      if HasAsParent(Node2, Node1) then

        Result := IfThen(ConsiderChildrenAbove and (toChildrenAbove in FOptions.FPaintOptions), 1, -1)

      else

      begin

        // the given nodes are neither equal nor are they parents of each other, so go up to FRoot

        // for each node and compare the child indices of the top level parents

        // Note: neither Node1 nor Node2 can be FRoot at this point as this (a bit strange) circumstance would

        //       be caught by the previous code.



        // start lookup at the same level

        Level1 := GetNodeLevel(Node1);

        Level2 := GetNodeLevel(Node2);

        Run1 := Node1;

        while Level1 > Level2 do

        begin

          Run1 := Run1.Parent;

          Dec(Level1);

        end;

        Run2 := Node2;

        while Level2 > Level1 do

        begin

          Run2 := Run2.Parent;

          Dec(Level2);

        end;



        // now go up until we find a common parent node (loop will safely stop at FRoot if the nodes

        // don't share a common parent)

        while Run1.Parent <> Run2.Parent do

        begin

          Run1 := Run1.Parent;

          Run2 := Run2.Parent;

        end;

        Result := Integer(Run1.Index) - Integer(Run2.Index);

      end;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.DrawLineImage(const PaintInfo: TVTPaintInfo; X, Y, H, VAlign: Integer; Style: TVTLineType;

  Reverse: Boolean);



// Draws (depending on Style) one of the 5 line types of the tree.

// If Reverse is True then a right-to-left column is being drawn, hence horizontal lines must be mirrored.

// X and Y describe the left upper corner of the line image rectangle, while H denotes its height (and width).



var

  HalfWidth,

  TargetX: Integer;



begin

  HalfWidth := Round(FIndent / 2);

  if Reverse then

    TargetX := 0

  else

    TargetX := FIndent;



  with PaintInfo.Canvas do

  begin

    case Style of

      ltBottomRight:

        begin

          DrawDottedVLine(PaintInfo, Y + VAlign, Y + H, X + HalfWidth);

          DrawDottedHLine(PaintInfo, X + HalfWidth, X + TargetX, Y + VAlign);

        end;

      ltTopDown:

        DrawDottedVLine(PaintInfo, Y, Y + H, X + HalfWidth);

      ltTopDownRight:

        begin

          DrawDottedVLine(PaintInfo, Y, Y + H, X + HalfWidth);

          DrawDottedHLine(PaintInfo, X + HalfWidth, X + TargetX, Y + VAlign);

        end;

      ltRight:

        DrawDottedHLine(PaintInfo, X + HalfWidth, X + TargetX, Y + VAlign);

      ltTopRight:

        begin

          DrawDottedVLine(PaintInfo, Y, Y + VAlign, X + HalfWidth);

          DrawDottedHLine(PaintInfo, X + HalfWidth, X + TargetX, Y + VAlign);

        end;

      ltLeft: // left can also mean right for RTL context

        if Reverse then

          DrawDottedVLine(PaintInfo, Y, Y + H, X + Integer(FIndent))

        else

          DrawDottedVLine(PaintInfo, Y, Y + H, X);

      ltLeftBottom:

        if Reverse then

        begin

          DrawDottedVLine(PaintInfo, Y, Y + H, X + Integer(FIndent));

          DrawDottedHLine(PaintInfo, X, X + Integer(FIndent), Y + H);

        end

        else

        begin

          DrawDottedVLine(PaintInfo, Y, Y + H, X);

          DrawDottedHLine(PaintInfo, X, X + Integer(FIndent), Y + H);

        end;

    end;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.FindInPositionCache(Node: PVirtualNode; var CurrentPos: Cardinal): PVirtualNode;



// Looks through the position cache and returns the node whose top position is the largest one which is smaller or equal

// to the position of the given node.



var

  L, H, I: Integer;



begin

  L := 0;

  H := High(FPositionCache);

  while L <= H do

  begin

    I := (L + H) shr 1;

    if CompareNodePositions(FPositionCache[I].Node, Node) <= 0 then

      L := I + 1

    else

      H := I - 1;

  end;

  if L = 0 then // High(FPositionCache) = -1

  begin

    Result := nil;

    CurrentPos := 0;

  end

  else

  begin

    Result := FPositionCache[L - 1].Node;

    CurrentPos := FPositionCache[L - 1].AbsoluteTop;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.FindInPositionCache(Position: Cardinal; var CurrentPos: Cardinal): PVirtualNode;



// Looks through the position cache and returns the node whose top position is the largest one which is smaller or equal

// to the given vertical position.

// The returned node does not necessarily occupy the given position but is the nearest one to start

// iterating from to approach the real node for a given position. CurrentPos receives the actual position of the found

// node which is needed for further iteration.



var

  L, H, I: Integer;



begin

  L := 0;

  H := High(FPositionCache);

  while L <= H do

  begin

    I := (L + H) shr 1;

    if FPositionCache[I].AbsoluteTop <= Position then

      L := I + 1

    else

      H := I - 1;

  end;

  if L = 0 then // High(FPositionCache) = -1

  begin

    Result := nil;

    CurrentPos := 0;

  end

  else

  begin

    Result := FPositionCache[L - 1].Node;

    CurrentPos := FPositionCache[L - 1].AbsoluteTop;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.FixupTotalCount(Node: PVirtualNode);



// Called after loading a subtree from stream. The child count in each node is already set but not

// their total count.



var

  Child: PVirtualNode;



begin

  // Initial total count is set to one on node creation.

  Child := Node.FirstChild;

  while Assigned(Child) do

  begin

    FixupTotalCount(Child);

    Inc(Node.TotalCount, Child.TotalCount);

    Child := Child.NextSibling;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.FixupTotalHeight(Node: PVirtualNode);



// Called after loading a subtree from stream. The individual height of each node is set already,

// but their total height needs an adjustment depending on their visibility state.



var

  Child: PVirtualNode;



begin

  // Initial total height is set to the node height on load.

  Child := Node.FirstChild;



  if vsExpanded in Node.States then

  begin

    while Assigned(Child) do

    begin

      FixupTotalHeight(Child);

      if vsVisible in Child.States then

        Inc(Node.TotalHeight, Child.TotalHeight);

      Child := Child.NextSibling;

    end;

  end

  else

  begin

    // The node is collapsed, so just update the total height of its child nodes.

    while Assigned(Child) do

    begin

      FixupTotalHeight(Child);

      Child := Child.NextSibling;

    end;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.GetBottomNode: PVirtualNode;



begin

  Result := GetNodeAt(0, ClientHeight - 1);

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.GetCheckedCount: Integer;



var

  Node: PVirtualNode;



begin

  Result := 0;

  Node := GetFirstChecked;

  while Assigned(Node) do

  begin

     Inc(Result);

     Node := GetNextChecked(Node);

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.GetCheckState(Node: PVirtualNode): TCheckState;



begin

  Result := Node.CheckState;

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.GetCheckType(Node: PVirtualNode): TCheckType;



begin

  Result := Node.CheckType;

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.GetChildCount(Node: PVirtualNode): Cardinal;



begin

  if (Node = nil) or (Node = FRoot) then

    Result := FRoot.ChildCount

  else

    Result := Node.ChildCount;

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.GetChildrenInitialized(Node: PVirtualNode): Boolean;



begin

  Result := not (vsHasChildren in Node.States) or (Node.ChildCount > 0);

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.GetCutCopyCount: Integer;



var

  Node: PVirtualNode;



begin

  Result := 0;

  Node := GetFirstCutCopy;

  while Assigned(Node) do

  begin

     Inc(Result);

     Node := GetNextCutCopy(Node);

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.GetDisabled(Node: PVirtualNode): Boolean;



begin

  Result := Assigned(Node) and (vsDisabled in Node.States);

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.GetDragManager: IVTDragManager;



// Returns the internal drag manager interface. If this does not yet exist then it is created here.



begin

  if FDragManager = nil then

  begin

    FDragManager := DoCreateDragManager;

    if FDragManager = nil then

      FDragManager := TVTDragManager.Create(Self);

  end;



  Result := FDragManager;

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.GetExpanded(Node: PVirtualNode): Boolean;



begin

  if Assigned(Node) then

    Result := vsExpanded in Node.States

  else

    Result := False;

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.GetFiltered(Node: PVirtualNode): Boolean;



begin

  Result := vsFiltered in Node.States;

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.GetFullyVisible(Node: PVirtualNode): Boolean;



// Determines whether the given node has the visibility flag set as well as all its parents are expanded.



begin

  Assert(Assigned(Node), 'Invalid parameter.');

  Result := vsVisible in Node.States;

  if Result and (Node <> FRoot) then

    Result := VisiblePath[Node];

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.GetHasChildren(Node: PVirtualNode): Boolean;



begin

  if Assigned(Node) then

    Result := vsHasChildren in Node.States

  else

    Result := vsHasChildren in FRoot.States;

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.GetMultiline(Node: PVirtualNode): Boolean;



begin

  Result := Assigned(Node) and (Node <> FRoot) and (vsMultiline in Node.States);

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.GetNodeHeight(Node: PVirtualNode): Cardinal;



begin

  if Assigned(Node) and (Node <> FRoot) then

  begin

    if (toVariableNodeHeight in FOptions.FMiscOptions) and not (vsDeleting in Node.States) then

    begin

      if not (vsInitialized in Node.States) then

        InitNode(Node);



      // Ensure the node's height is determined.

      MeasureItemHeight(Self.Canvas, Node);

    end;

    Result := Node.NodeHeight;

  end

  else

    Result := 0;

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.GetNodeParent(Node: PVirtualNode): PVirtualNode;



begin

  if Assigned(Node) and (Node.Parent <> FRoot) then

    Result := Node.Parent

  else

    Result := nil;

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.GetOffsetXY: TPoint;



begin

  Result := Point(FOffsetX, FOffsetY);

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.GetRangeX: Cardinal;

begin

  Result := Max(0, FRangeX);

end;



function TBaseVirtualTree.GetRootNodeCount: Cardinal;



begin

  Result := FRoot.ChildCount;

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.GetSelected(Node: PVirtualNode): Boolean;



begin

  Result := Assigned(Node) and (vsSelected in Node.States);

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.GetTopNode: PVirtualNode;



var

  Dummy: Integer;



begin

  Result := GetNodeAt(0, 0, True, Dummy);

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.GetTotalCount: Cardinal;



begin

  Inc(FUpdateCount);

  try

    ValidateNode(FRoot, True);

  finally

    Dec(FUpdateCount);

  end;

  // The root node itself doesn't count as node.

  Result := FRoot.TotalCount - 1;

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.GetVerticalAlignment(Node: PVirtualNode): Byte;



begin

  Result := Node.Align;

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.GetVisible(Node: PVirtualNode): Boolean;



// Determines if the given node is marked as being visible.



begin

  if Node = nil then

    Node := FRoot;



  if not (vsInitialized in Node.States) then

    InitNode(Node);



  Result := vsVisible in Node.States;

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.GetVisiblePath(Node: PVirtualNode): Boolean;



// Determines if all parents of the given node are expanded and have the visibility flag set.



begin

  Assert(Assigned(Node) and (Node <> FRoot), 'Invalid parameters.');



  // FRoot is always expanded

  repeat

    Node := Node.Parent;

  until (Node = FRoot) or not (vsExpanded in Node.States) or not (vsVisible in Node.States);



  Result := Node = FRoot;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.HandleClickSelection(LastFocused, NewNode: PVirtualNode; Shift: TShiftState;

  DragPending: Boolean);



// Handles multi-selection with mouse click.



begin

  // Ctrl key down

  if ssCtrl in Shift then

  begin

    if ssShift in Shift then

    begin

      SelectNodes(FRangeAnchor, NewNode, True);

    end

    else

    begin

      if not (toSiblingSelectConstraint in FOptions.SelectionOptions) then

        FRangeAnchor := NewNode;

      // Delay selection change if a drag operation is pending.

      // Otherwise switch selection state here.

      if DragPending then

        DoStateChange([tsToggleFocusedSelection])

      else

        if vsSelected in NewNode.States then

          RemoveFromSelection(NewNode)

        else

          AddToSelection(NewNode);

    end;

    Invalidate();

  end

  else

    // Shift key down

    if ssShift in Shift then

    begin

      if FRangeAnchor = nil then

        FRangeAnchor := FRoot.FirstChild;



      // select node range

      if Assigned(FRangeAnchor) then

      begin

        SelectNodes(FRangeAnchor, NewNode, False);

        Invalidate;

      end;

    end

    else

    begin

      // any other case

      if not (vsSelected in NewNode.States) then

      begin

        AddToSelection(NewNode);

        InvalidateNode(NewNode);

      end;

      // assign new reference item

      FRangeAnchor := NewNode;

    end;

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.HandleDrawSelection(X, Y: Integer): Boolean;



// Handles multi-selection with a focus rectangle.

// Result is True if something changed in selection.



var

  OldRect,

  NewRect: TRect;

  MainColumn: TColumnIndex;

  MaxValue: Integer;



  // limits of a node and its text

  NodeLeft,

  NodeRight: Integer;



  // alignment and directionality

  CurrentBidiMode: TBidiMode;

  CurrentAlignment: TAlignment;



begin

  Result := False;



  // Selection changes are only done if the user drew a selection rectangle large

  // enough to exceed the threshold.

  if (FRoot.TotalCount > 1) and (tsDrawSelecting in FStates) then

  begin

    // Effective handling of node selection is done by using two rectangles stored in FSelectRec.

    OldRect := OrderRect(FLastSelRect);

    NewRect := OrderRect(FNewSelRect);

    ClearTempCache;



    MainColumn := FHeader.MainColumn;



    // Alignment and bidi mode determine where the node text is located within a node.

    if MainColumn <= NoColumn then

    begin

      CurrentBidiMode := BidiMode;

      CurrentAlignment := Alignment;

    end

    else

    begin

      CurrentBidiMode := FHeader.FColumns[MainColumn].BidiMode;

      CurrentAlignment := FHeader.FColumns[MainColumn].Alignment;

    end;



    // Determine initial left border of first node (take column reordering into account).

    if FHeader.UseColumns then

    begin

      // The mouse coordinates don't include any horizontal scrolling hence take this also

      // out from the returned column position.

      NodeLeft := FHeader.FColumns[MainColumn].Left - FEffectiveOffsetX;

      NodeRight := NodeLeft + FHeader.FColumns[MainColumn].Width;

    end

    else

    begin

      NodeLeft := 0;

      NodeRight := ClientWidth;

    end;

    if CurrentBidiMode = bdLeftToRight then

      Result := CollectSelectedNodesLTR(MainColumn, NodeLeft, NodeRight, CurrentAlignment, OldRect, NewRect)

    else

      Result := CollectSelectedNodesRTL(MainColumn, NodeLeft, NodeRight, CurrentAlignment, OldRect, NewRect);

  end;



  if Result then

  begin

    // Do some housekeeping if there was a change.

    MaxValue := PackArray(FSelection, FSelectionCount);

    if MaxValue > -1 then

    begin

      FSelectionCount := MaxValue;

      SetLength(FSelection, FSelectionCount);

    end;

    if FTempNodeCount > 0 then

    begin

      AddToSelection(FTempNodeCache, FTempNodeCount);

      ClearTempCache;

    end;



    Change(nil);

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.HasVisibleNextSibling(Node: PVirtualNode): Boolean;



// Helper method to determine if the given node has a visible next sibling. This is needed to

// draw correct tree lines.



begin

  // Check if there is a sibling at all.

  Result := Assigned(Node.NextSibling);



  if Result then

  begin

    repeat

      Node := Node.NextSibling;

      Result := IsEffectivelyVisible[Node];

    until Result or (Node.NextSibling = nil);

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.HasVisiblePreviousSibling(Node: PVirtualNode): Boolean;



// Helper method to determine if the given node has a visible previous sibling. This is needed to

// draw correct tree lines.



begin

  // Check if there is a sibling at all.

  Result := Assigned(Node.PrevSibling);



  if Result then

  begin

    repeat

      Node := Node.PrevSibling;

      Result := IsEffectivelyVisible[Node];

    until Result or (Node.PrevSibling = nil);

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.ImageListChange(Sender: TObject);



begin

  if not (csDestroying in ComponentState) then

    Invalidate;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.InitializeFirstColumnValues(var PaintInfo: TVTPaintInfo);



// Determines initial index, position and cell size of the first visible column.



begin

  PaintInfo.Column := FHeader.FColumns.GetFirstVisibleColumn;

  with FHeader.FColumns, PaintInfo do

  begin

    if Column > NoColumn then

    begin

      CellRect.Right := CellRect.Left + Items[Column].Width;

      Position := Items[Column].Position;

    end

    else

      Position := 0;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.InitRootNode(OldSize: Cardinal = 0);



// Reinitializes the root node.



var

  NewSize: Cardinal;



begin

  NewSize := TreeNodeSize + FTotalInternalDataSize;

  if FRoot = nil then

    FRoot := AllocMem(NewSize)

  else

  begin

    ReallocMem(FRoot, NewSize);

    ZeroMemory(PByte(FRoot) + OldSize, NewSize - OldSize);

  end;



  with FRoot^ do

  begin

    // Indication that this node is the root node.

    PrevSibling := FRoot;

    NextSibling := FRoot;

    Parent := Pointer(Self);

    States := [vsInitialized, vsExpanded, vsHasChildren, vsVisible];

    TotalHeight := FDefaultNodeHeight;

    TotalCount := 1;

    NodeHeight := FDefaultNodeHeight;

    Align := 50;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.InterruptValidation;



var

  WasValidating: Boolean;



begin

  DoStateChange([tsStopValidation], [tsUseCache]);



  // Check the worker thread existance. It might already be gone (usually on destruction of the last tree).

  if Assigned(WorkerThread) then

  begin

    WasValidating := (tsValidating in FStates);

    WorkerThread.RemoveTree(Self);

    if WasValidating then

      InvalidateCache();

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.IsFirstVisibleChild(Parent, Node: PVirtualNode): Boolean;



// Helper method to check if Node is the same as the first visible child of Parent.



var

  Run: PVirtualNode;



begin

  // Find first visible child.

  Run := Parent.FirstChild;

  while Assigned(Run) and not IsEffectivelyVisible[Run] do

    Run := Run.NextSibling;



  Result := Assigned(Run) and (Run = Node);

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.IsLastVisibleChild(Parent, Node: PVirtualNode): Boolean;



// Helper method to check if Node is the same as the last visible child of Parent.



var

  Run: PVirtualNode;



begin

  // Find last visible child.

  Run := Parent.LastChild;

  while Assigned(Run) and not IsEffectivelyVisible[Run] do

    Run := Run.PrevSibling;



  Result := Assigned(Run) and (Run = Node);

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.MakeNewNode: PVirtualNode;



var

  Size: Cardinal;



begin

  Size := TreeNodeSize;

  if not (csDesigning in ComponentState) then

  begin

    // Make sure FNodeDataSize is valid.

    if FNodeDataSize = -1 then

      ValidateNodeDataSize(FNodeDataSize);



    // Take record alignment into account.

    Inc(Size, FNodeDataSize);

  end;



  Result := AllocMem(Size + FTotalInternalDataSize);



  // Fill in some default values.

  with Result^ do

  begin

    TotalCount := 1;

    TotalHeight := FDefaultNodeHeight;

    NodeHeight := FDefaultNodeHeight;

    States := [vsVisible];

    Align := 50;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.PackArray({*}const TheArray: TNodeArray; Count: Integer): Integer; assembler;

// *This is an optimization to get as near as possible with the PUREPASCAL code without the

//  compiler generating a _DynArrayAddRef call. We still modify the array's content via pointers.



// Removes all entries from the selection array which are no longer in use. The selection array must be sorted for this

// algo to work. Values which must be removed are marked with bit 0 (LSB) set. This little trick works because memory

// is always allocated DWORD aligned. Since the selection array must be sorted while determining the entries to be

// removed it is much more efficient to increment the entry in question instead of setting it to nil (which would break

// the ordered appearance of the list).

//

// On enter EAX contains self reference, EDX the address to TheArray and ECX Count

// The returned value is the number of remaining entries in the array, so the caller can reallocate (shorten)

// the selection array if needed or -1 if nothing needs to be changed.



{$ifdef CPUX64}

var

  Source, Dest: ^PVirtualNode;

  ConstOne: NativeInt;

begin

  Source := Pointer(TheArray);

  ConstOne := 1;

  Result := 0;

  // Do the fastest scan possible to find the first entry

  while (Count <> 0) and {not Odd(NativeInt(Source^))} (NativeInt(Source^) and ConstOne = 0) do

  begin

    Inc(Result);

    Inc(Source);

    Dec(Count);

  end;



  if Count <> 0 then

  begin

    Dest := Source;

    repeat

      // Skip odd entries

      if {not Odd(NativeInt(Source^))} NativeInt(Source^) and ConstOne = 0 then

      begin

        Dest^ := Source^;

        Inc(Result);

        Inc(Dest);

      end;

      Inc(Source); // Point to the next entry

      Dec(Count);

    until Count = 0;

  end;

end;

{$else}

asm

        PUSH    EBX

        PUSH    EDI

        PUSH    ESI

        MOV     ESI, EDX

        MOV     EDX, -1

        JCXZ    @@Finish               // Empty list?

        INC     EDX                    // init remaining entries counter

        MOV     EDI, ESI               // source and destination point to the list memory

        MOV     EBX, 1                 // use a register instead of immediate operant to check against

@@PreScan:

        TEST    [ESI], EBX             // do the fastest scan possible to find the first entry

                                       // which must be removed

        JNZ     @@DoMainLoop

        INC     EDX

        ADD     ESI, 4

        DEC     ECX

        JNZ     @@PreScan

        JMP     @@Finish



@@DoMainLoop:

        MOV     EDI, ESI

@@MainLoop:

        TEST    [ESI], EBX             // odd entry?

        JNE     @@Skip                 // yes, so skip this one

        MOVSD                          // else move the entry to new location

        INC     EDX                    // count the moved entries

        DEC     ECX

        JNZ     @@MainLoop             // do it until all entries are processed

        JMP     @@Finish



@@Skip:

        ADD     ESI, 4                 // point to the next entry

        DEC     ECX

        JNZ     @@MainLoop             // do it until all entries are processed

@@Finish:

        MOV     EAX, EDX               // prepare return value

        POP     ESI

        POP     EDI

        POP     EBX

end;

{$endif CPUX64}



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.PrepareBitmaps(NeedButtons, NeedLines: Boolean);



// initializes the contents of the internal bitmaps



const

  LineBitsDotted: array [0..8] of Word = ($55, $AA, $55, $AA, $55, $AA, $55, $AA, $55);

  LineBitsSolid: array [0..7] of Word = (0, 0, 0, 0, 0, 0, 0, 0);



var

  PatternBitmap: HBITMAP;

  Bits: Pointer;

  Size: TSize;

  Theme: HTHEME;

  R: TRect;



  //--------------- local function --------------------------------------------



  procedure FillBitmap (ABitmap: TBitmap);

  begin

    with ABitmap, Canvas do

    begin

      Width := Size.cx;

      Height := Size.cy;



      if IsWinVistaOrAbove and (tsUseThemes in FStates) and (toUseExplorerTheme in FOptions.FPaintOptions) or VclStyleEnabled then

      begin

        if (FHeader.MainColumn > NoColumn) and not (coParentColor in FHeader.FColumns[FHeader.MainColumn].Options) then

          Brush.Color := FHeader.FColumns[FHeader.MainColumn].Color

        else

          Brush.Color := FColors.BackGroundColor;

      end

      else

        Brush.Color := clFuchsia;



      Transparent := True;

      TransparentColor := Brush.Color;



      FillRect(Rect(0, 0, Width, Height));

    end;

  end;



  //--------------- end local function ----------------------------------------



begin

  Size.cx := 9;

  Size.cy := 9;



  if tsUseThemes in FStates then

  begin

    R := Rect(0, 0, 100, 100);

    Theme := OpenThemeData(Handle, 'TREEVIEW');

    GetThemePartSize(Theme, FPlusBM.Canvas.Handle, TVP_GLYPH, GLPS_OPENED, @R, TS_TRUE, Size);

  end

  else

    Theme := 0;



  if NeedButtons then

  begin

     with FMinusBM, Canvas do

     begin

      // box is always of odd size

      FillBitmap(FMinusBM);

      FillBitmap(FHotMinusBM);

      // Weil die selbstgezeichneten Bitmaps sehen im Vcl Style scheiße aus

      if (not VclStyleEnabled) or (Theme = 0) then

      begin

        if not(tsUseExplorerTheme in FStates) then

        begin

          if FButtonStyle = bsTriangle then

          begin

            Brush.Color := clBlack;

            Pen.Color := clBlack;

            Polygon([Point(0, 2), Point(8, 2), Point(4, 6)]);

          end

          else

          begin

            // Button style is rectangular. Now ButtonFillMode determines how to fill the interior.

            if FButtonFillMode in [fmTreeColor, fmWindowColor, fmTransparent] then

            begin

              case FButtonFillMode of

                fmTreeColor:

                  Brush.Color := FColors.BackGroundColor;

                fmWindowColor:

                  Brush.Color := clWindow;

              end;

              Pen.Color := FColors.TreeLineColor;

              Rectangle(0, 0, Width, Height);

              Pen.Color := FColors.NodeFontColor;

              MoveTo(2, Width div 2);

              LineTo(Width - 2, Width div 2);

            end

            else

              FMinusBM.Handle := LoadBitmap(HInstance, 'VT_XPBUTTONMINUS');

            FHotMinusBM.Canvas.Draw(0, 0, FMinusBM);

          end;

        end;

      end;

    end;



    with FPlusBM, Canvas do

    begin

      FillBitmap(FPlusBM);

      FillBitmap(FHotPlusBM);

      if (not VclStyleEnabled) or (Theme = 0) then

      begin

        if not(tsUseExplorerTheme in FStates) then

        begin

          if FButtonStyle = bsTriangle then

          begin

            Brush.Color := clBlack;

            Pen.Color := clBlack;

            Polygon([Point(2, 0), Point(6, 4), Point(2, 8)]);

          end

          else

          begin

            // Button style is rectangular. Now ButtonFillMode determines how to fill the interior.

            if FButtonFillMode in [fmTreeColor, fmWindowColor, fmTransparent] then

            begin

              case FButtonFillMode of

                fmTreeColor:

                  Brush.Color := FColors.BackGroundColor;

                fmWindowColor:

                  Brush.Color := clWindow;

              end;



              Pen.Color := FColors.TreeLineColor;

              Rectangle(0, 0, Width, Height);

              Pen.Color := FColors.NodeFontColor;

              MoveTo(2, Width div 2);

              LineTo(Width - 2, Width div 2);

              MoveTo(Width div 2, 2);

              LineTo(Width div 2, Width - 2);

            end

            else

              FPlusBM.Handle := LoadBitmap(HInstance, 'VT_XPBUTTONPLUS');

            FHotPlusBM.Canvas.Draw(0, 0, FPlusBM);

          end;

        end;

      end;

    end;



    // Overwrite glyph images if theme is active.

    if (tsUseThemes in FStates) and (Theme <> 0) then

    begin

      R := Rect(0, 0, Size.cx, Size.cy);

      DrawThemeBackground(Theme, FPlusBM.Canvas.Handle, TVP_GLYPH, GLPS_CLOSED, R, nil);

      DrawThemeBackground(Theme, FMinusBM.Canvas.Handle, TVP_GLYPH, GLPS_OPENED, R, nil);

      if tsUseExplorerTheme in FStates then

      begin

        DrawThemeBackground(Theme, FHotPlusBM.Canvas.Handle, TVP_HOTGLYPH, GLPS_CLOSED, R, nil);

        DrawThemeBackground(Theme, FHotMinusBM.Canvas.Handle, TVP_HOTGLYPH, GLPS_OPENED, R, nil);

      end

      else

      begin

        FHotPlusBM.Canvas.Draw(0, 0, FPlusBM);

        FHotMinusBM.Canvas.Draw(0, 0, FMinusBM);

      end;

    end;

  end;



  if NeedLines then

  begin

    if FDottedBrush <> 0 then

      DeleteObject(FDottedBrush);



    case FLineStyle of

      lsDotted:

        Bits := @LineBitsDotted;

      lsSolid:

        Bits := @LineBitsSolid;

    else // lsCustomStyle

      Bits := @LineBitsDotted;

      DoGetLineStyle(Bits);

    end;

    PatternBitmap := CreateBitmap(8, 8, 1, 1, Bits);

    FDottedBrush := CreatePatternBrush(PatternBitmap);

    DeleteObject(PatternBitmap);

  end;



  if tsUseThemes in FStates then

    CloseThemeData(Theme);

end;



//----------------------------------------------------------------------------------------------------------------------



type

  TOldVTOption = (voAcceptOLEDrop, voAnimatedToggle, voAutoDropExpand, voAutoExpand, voAutoScroll,

    voAutoSort, voAutoSpanColumns, voAutoTristateTracking, voCheckSupport, voDisableDrawSelection, voEditable,

    voExtendedFocus, voFullRowSelect, voGridExtensions, voHideFocusRect, voHideSelection, voHotTrack, voInitOnSave,

    voLevelSelectConstraint, voMiddleClickSelect, voMultiSelect, voRightClickSelect, voPopupMode, voShowBackground,

    voShowButtons, voShowDropmark, voShowHorzGridLines, voShowRoot, voShowTreeLines, voShowVertGridLines,

    voSiblingSelectConstraint, voToggleOnDblClick);



const

  OptionMap: array[TOldVTOption] of Integer = (

    Ord(toAcceptOLEDrop), Ord(toAnimatedToggle), Ord(toAutoDropExpand), Ord(toAutoExpand), Ord(toAutoScroll),

    Ord(toAutoSort), Ord(toAutoSpanColumns), Ord(toAutoTristateTracking), Ord(toCheckSupport), Ord(toDisableDrawSelection),

    Ord(toEditable), Ord(toExtendedFocus), Ord(toFullRowSelect), Ord(toGridExtensions), Ord(toHideFocusRect),

    Ord(toHideSelection), Ord(toHotTrack), Ord(toInitOnSave), Ord(toLevelSelectConstraint), Ord(toMiddleClickSelect),

    Ord(toMultiSelect), Ord(toRightClickSelect), Ord(toPopupMode), Ord(toShowBackground),

    Ord(toShowButtons), Ord(toShowDropmark), Ord(toShowHorzGridLines), Ord(toShowRoot), Ord(toShowTreeLines),

    Ord(toShowVertGridLines), Ord(toSiblingSelectConstraint), Ord(toToggleOnDblClick)

  );



procedure TBaseVirtualTree.ReadOldOptions(Reader: TReader);



// Migration helper routine to silently convert forms containing the old tree options member into the new

// sub-options structure.



var

  OldOption: TOldVTOption;

  EnumName: string;



begin

  // If we are at design time currently then let the designer know we changed something.

  UpdateDesigner;



  // It should never happen at this place that there is something different than the old set.

  if Reader.ReadValue = vaSet then

  begin

    // Remove all default values set by the constructor.

    FOptions.AnimationOptions := [];

    FOptions.AutoOptions := [];

    FOptions.MiscOptions := [];

    FOptions.PaintOptions := [];

    FOptions.SelectionOptions := [];



    while True do

    begin

      // Sets are stored with their members as simple strings. Read them one by one and map them to the new option

      // in the correct sub-option set.

      EnumName := Reader.ReadStr;

      if EnumName = '' then

        Break;

      OldOption := TOldVTOption(GetEnumValue(TypeInfo(TOldVTOption), EnumName));

      case OldOption of

        voAcceptOLEDrop, voCheckSupport, voEditable, voGridExtensions, voInitOnSave, voToggleOnDblClick:

          FOptions.MiscOptions := FOptions.FMiscOptions + [TVTMiscOption(OptionMap[OldOption])];

        voAnimatedToggle:

          FOptions.AnimationOptions := FOptions.FAnimationOptions + [TVTAnimationOption(OptionMap[OldOption])];

        voAutoDropExpand, voAutoExpand, voAutoScroll, voAutoSort, voAutoSpanColumns, voAutoTristateTracking:

          FOptions.AutoOptions := FOptions.FAutoOptions + [TVTAutoOption(OptionMap[OldOption])];

        voDisableDrawSelection, voExtendedFocus, voFullRowSelect, voLevelSelectConstraint,

        voMiddleClickSelect, voMultiSelect, voRightClickSelect, voSiblingSelectConstraint:

          FOptions.SelectionOptions := FOptions.FSelectionOptions + [TVTSelectionOption(OptionMap[OldOption])];

        voHideFocusRect, voHideSelection, voHotTrack, voPopupMode, voShowBackground, voShowButtons,

        voShowDropmark, voShowHorzGridLines, voShowRoot, voShowTreeLines, voShowVertGridLines:

          FOptions.PaintOptions := FOptions.FPaintOptions + [TVTPaintOption(OptionMap[OldOption])];

      end;

    end;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.SetAlignment(const Value: TAlignment);



begin

  if FAlignment <> Value then

  begin

    FAlignment := Value;

    if not (csLoading in ComponentState) then

      Invalidate;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.SetAnimationDuration(const Value: Cardinal);



begin

  FAnimationDuration := Value;

  if FAnimationDuration = 0 then

    Exclude(FOptions.FAnimationOptions, toAnimatedToggle)

  else

    Include(FOptions.FAnimationOptions, toAnimatedToggle);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.SetBackground(const Value: TPicture);



begin

  FBackground.Assign(Value);

  Invalidate;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.SetBackgroundOffset(const Index, Value: Integer);



begin

  case Index of

    0:

      if FBackgroundOffsetX <> Value then

      begin

        FBackgroundOffsetX := Value;

        Invalidate;

      end;

    1:

      if FBackgroundOffsetY <> Value then

      begin

        FBackgroundOffsetY := Value;

        Invalidate;

      end;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.SetBorderStyle(Value: TBorderStyle);



begin

  if FBorderStyle <> Value then

  begin

    FBorderStyle := Value;

    RecreateWnd;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.SetBottomNode(Node: PVirtualNode);



var

  Run: PVirtualNode;

  R: TRect;



begin

  if Assigned(Node) then

  begin

    // make sure all parents of the node are expanded

    Run := Node.Parent;

    while Run <> FRoot do

    begin

      if not (vsExpanded in Run.States) then

        ToggleNode(Run);

      Run := Run.Parent;

    end;

    R := GetDisplayRect(Node, FHeader.MainColumn, True);

    DoSetOffsetXY(Point(FOffsetX, FOffsetY + ClientHeight - R.Top - Integer(NodeHeight[Node])),

      [suoRepaintScrollBars, suoUpdateNCArea]);

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.SetBottomSpace(const Value: Cardinal);



begin

  if FBottomSpace <> Value then

  begin

    FBottomSpace := Value;

    UpdateVerticalScrollBar(True);

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.SetButtonFillMode(const Value: TVTButtonFillMode);



begin

  if FButtonFillMode <> Value then

  begin

    FButtonFillMode := Value;

    if not (csLoading in ComponentState) then

    begin

      PrepareBitmaps(True, False);

      if HandleAllocated then

        Invalidate;

    end;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.SetButtonStyle(const Value: TVTButtonStyle);



begin

  if FButtonStyle <> Value then

  begin

    FButtonStyle := Value;

    if not (csLoading in ComponentState) then

    begin

      PrepareBitmaps(True, False);

      if HandleAllocated then

        Invalidate;

    end;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.SetCheckImageKind(Value: TCheckImageKind);



begin

  if FCheckImageKind <> Value then

  begin

    FCheckImageKind := Value;

    FCheckImages := GetCheckImageListFor(Value);

    if not Assigned(FCheckImages) then

      FCheckImages := FCustomCheckImages;

    if HandleAllocated and (FUpdateCount = 0) and not (csLoading in ComponentState) then

      InvalidateRect(Handle, nil, False);

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.SetCheckState(Node: PVirtualNode; Value: TCheckState);



begin

  if (Node.CheckState <> Value) and not (vsDisabled in Node.States) and DoChecking(Node, Value) then

    DoCheckClick(Node, Value);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.SetCheckType(Node: PVirtualNode; Value: TCheckType);



begin

  if (Node.CheckType <> Value) and not (toReadOnly in FOptions.FMiscOptions) then

  begin

    Node.CheckType := Value;

    if (Value <> ctTriStateCheckBox) and (Node.CheckState in [csMixedNormal, csMixedPressed]) then

      Node.CheckState := csUncheckedNormal;// reset check state if it doesn't fit the new check type

    // For check boxes with tri-state check box parents we have to initialize differently.

    if (toAutoTriStateTracking in FOptions.FAutoOptions) and (Value in [ctCheckBox, ctTriStateCheckBox]) and

      (Node.Parent <> FRoot) then

    begin

      if not (vsInitialized in Node.Parent.States) then

        InitNode(Node.Parent);

      if (Node.Parent.CheckType = ctTriStateCheckBox) and

        (Node.Parent.CheckState in [csUncheckedNormal, csCheckedNormal]) then

        CheckState[Node] := Node.Parent.CheckState;

    end;

    InvalidateNode(Node);

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.SetChildCount(Node: PVirtualNode; NewChildCount: Cardinal);



// Changes a node's child structure to accomodate the new child count. This is used to add or delete

// child nodes to/from the end of the node's child list. To insert or delete a specific node a separate

// routine is used.



var

  Remaining: Cardinal;

  Index: Cardinal;

  Child: PVirtualNode;

  Count: Integer;

  NewHeight: Integer;

  lNodeHeight: Integer;

begin

  if not (toReadOnly in FOptions.FMiscOptions) then

  begin

    if Node = nil then

      Node := FRoot;



    if NewChildCount = 0 then

      DeleteChildren(Node)

    else

    begin

      // If nothing changed then do nothing.

      if NewChildCount <> Node.ChildCount then

      begin

        InterruptValidation;

        NewHeight := 0;



        if NewChildCount > Node.ChildCount then

        begin

          Remaining := NewChildCount - Node.ChildCount;

          Count := Remaining;



          // New nodes to add.

          if Assigned(Node.LastChild) then

            Index := Node.LastChild.Index + 1

          else

          begin

            Index := 0;

            Include(Node.States, vsHasChildren);

          end;

          Node.States := Node.States - [vsAllChildrenHidden, vsHeightMeasured];



          // New nodes are by default always visible, so we don't need to check the visibility.

          while Remaining > 0 do

          begin

            Child := MakeNewNode;

            Child.Index := Index;

            Child.PrevSibling := Node.LastChild;

            if Assigned(Node.LastChild) then

              Node.LastChild.NextSibling := Child;

            Child.Parent := Node;

            Node.LastChild := Child;

            if Node.FirstChild = nil then

              Node.FirstChild := Child;

            Dec(Remaining);

            Inc(Index);



            if (toVariableNodeHeight in FOptions.FMiscOptions) then

            begin

              lNodeHeight := Child.NodeHeight;

              DoMeasureItem(Canvas, Child, lNodeHeight);

              Child.NodeHeight := lNodeHeight;

              Child.TotalHeight := lNodeHeight;

            end;

            Inc(NewHeight, Child.NodeHeight);

          end;



          if vsExpanded in Node.States then

          begin

            AdjustTotalHeight(Node, NewHeight, True);

            if FullyVisible[Node] then

              Inc(Integer(FVisibleCount), Count);

          end;



          AdjustTotalCount(Node, Count, True);

          Node.ChildCount := NewChildCount;

          if (FUpdateCount = 0) and (toAutoSort in FOptions.FAutoOptions) and (FHeader.FSortColumn > InvalidColumn) then

            Sort(Node, FHeader.FSortColumn, FHeader.FSortDirection, True);



          InvalidateCache;

        end

        else

        begin

          // Nodes have to be deleted.

          Remaining := Node.ChildCount - NewChildCount;

          while Remaining > 0 do

          begin

            DeleteNode(Node.LastChild);

            Dec(Remaining);

          end;

        end;



        if FUpdateCount = 0 then

        begin

          ValidateCache;

          UpdateScrollBars(True);

          Invalidate;

        end;



        if Node = FRoot then

          StructureChange(nil, crChildAdded)

        else

          StructureChange(Node, crChildAdded);

      end;

    end;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.SetClipboardFormats(const Value: TClipboardFormats);



var

  I: Integer;



begin

  // Add string by string instead doing an Assign or AddStrings because the list may return -1 for

  // invalid entries which cause trouble for the standard implementation.

  FClipboardFormats.Clear;

  for I := 0 to Value.Count - 1 do

    FClipboardFormats.Add(Value[I]);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.SetColors(const Value: TVTColors);



begin

  FColors.Assign(Value);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.SetCustomCheckImages(const Value: TCustomImageList);



begin

  if FCustomCheckImages <> Value then

  begin

    if Assigned(FCustomCheckImages) then

    begin

      FCustomCheckImages.UnRegisterChanges(FCustomCheckChangeLink);

      FCustomCheckImages.RemoveFreeNotification(Self);

      // Reset the internal check image list reference too, if necessary.

      if FCheckImages = FCustomCheckImages then

        FCheckImages := nil;

    end;

    FCustomCheckImages := Value;

    if Assigned(FCustomCheckImages) then

    begin

      FCustomCheckImages.RegisterChanges(FCustomCheckChangeLink);

      FCustomCheckImages.FreeNotification(Self);

    end;

    // Check if currently custom check images are active.

    if FCheckImageKind = ckCustom then

      FCheckImages := Value;

    if not (csLoading in ComponentState) then

      Invalidate;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.SetDefaultNodeHeight(Value: Cardinal);



begin

  if Value = 0 then

    Value := 18;

  if FDefaultNodeHeight <> Value then

  begin

    Inc(Integer(FRoot.TotalHeight), Integer(Value) - Integer(FDefaultNodeHeight));

    Inc(SmallInt(FRoot.NodeHeight), Integer(Value) - Integer(FDefaultNodeHeight));

    FDefaultNodeHeight := Value;

    InvalidateCache;

    if (FUpdateCount = 0) and HandleAllocated and not (csLoading in ComponentState) then

    begin

      ValidateCache;

      UpdateScrollBars(True);

      ScrollIntoView(FFocusedNode, toCenterScrollIntoView in FOptions.SelectionOptions, True);

      Invalidate;

    end;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.SetDisabled(Node: PVirtualNode; Value: Boolean);



begin

  if Assigned(Node) and (Value xor (vsDisabled in Node.States)) then

  begin

    if Value then

      Include(Node.States, vsDisabled)

    else

      Exclude(Node.States, vsDisabled);



    if FUpdateCount = 0 then

      InvalidateNode(Node);

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.SetDoubleBuffered(const Value: Boolean);

begin

  // empty by intention, we do our own buffering

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.GetDoubleBuffered: Boolean;

begin

  Result := True; // we do our own buffering

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.SetEmptyListMessage(const Value: UnicodeString);



begin

  if Value <> EmptyListMessage then

  begin

    FEmptyListMessage := Value;

    Invalidate;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.SetExpanded(Node: PVirtualNode; Value: Boolean);



begin

  if Assigned(Node) and (Node <> FRoot) and (Value xor (vsExpanded in Node.States)) then

    ToggleNode(Node);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.SetFocusedColumn(Value: TColumnIndex);



begin

  if (FFocusedColumn <> Value) and

     DoFocusChanging(FFocusedNode, FFocusedNode, FFocusedColumn, Value) then

  begin

    CancelEditNode;

    InvalidateColumn(FFocusedColumn);

    InvalidateColumn(Value);

    FFocusedColumn := Value;

    if Assigned(FFocusedNode) and not (toDisableAutoscrollOnFocus in FOptions.FAutoOptions) then

    begin

      if ScrollIntoView(FFocusedNode, toCenterScrollIntoView in FOptions.SelectionOptions, True) then

        InvalidateNode(FFocusedNode);

    end;



    if Assigned(FDropTargetNode) then

      InvalidateNode(FDropTargetNode);



    DoFocusChange(FFocusedNode, FFocusedColumn);

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.SetFocusedNode(Value: PVirtualNode);



var

  WasDifferent: Boolean;



begin

  WasDifferent := Value <> FFocusedNode;

  DoFocusNode(Value, True);

  // Do change event only if there was actually a change.

  if WasDifferent and (FFocusedNode = Value) then

    DoFocusChange(FFocusedNode, FFocusedColumn);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.SetFullyVisible(Node: PVirtualNode; Value: Boolean);



// This method ensures that a node is visible and all its parent nodes are expanded and also visible

// if Value is True. Otherwise the visibility flag of the node is reset but the expand state

// of the parent nodes stays untouched.



begin

  Assert(Assigned(Node) and (Node <> FRoot), 'Invalid parameter');



  IsVisible[Node] := Value;

  if Value then

  begin

    repeat

      Node := Node.Parent;

      if Node = FRoot then

        Break;

      if not (vsExpanded in Node.States) then

        ToggleNode(Node);

      if not (vsVisible in Node.States) then

        IsVisible[Node] := True;

    until False;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.SetHasChildren(Node: PVirtualNode; Value: Boolean);



begin

  if Assigned(Node) and not (toReadOnly in FOptions.FMiscOptions) then

  begin

    if Value then

      Include(Node.States, vsHasChildren)

    else

    begin

      Exclude(Node.States, vsHasChildren);

      DeleteChildren(Node);

    end;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.SetHeader(const Value: TVTHeader);



begin

  FHeader.Assign(Value);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.SetFiltered(Node: PVirtualNode; Value: Boolean);



// Sets the 'filtered' flag of the given node according to Value and updates all dependent states.



var

  NeedUpdate: Boolean;



begin

  Assert(Assigned(Node) and (Node <> FRoot), 'Invalid parameter.');



  // Initialize the node if necessary as this might change the filtered state.

  if not (vsInitialized in Node.States) then

    InitNode(Node);



  if Value <> (vsFiltered in Node.States) then

  begin

    InterruptValidation;

    NeedUpdate := False;

    if Value then

    begin

      Include(Node.States, vsFiltered);

      if not (toShowFilteredNodes in FOptions.FPaintOptions) then

      begin

        AdjustTotalHeight(Node, -Integer(NodeHeight[Node]), True);

        if FullyVisible[Node] then

        begin

          Dec(FVisibleCount);

          NeedUpdate := True;

        end;

      end;



      if FUpdateCount = 0 then

        DetermineHiddenChildrenFlag(Node.Parent)

      else

        Include(FStates, tsUpdateHiddenChildrenNeeded);

    end

    else

    begin

      Exclude(Node.States, vsFiltered);

      if not (toShowFilteredNodes in FOptions.FPaintOptions) then

      begin

        AdjustTotalHeight(Node, Integer(NodeHeight[Node]), True);

        if FullyVisible[Node] then

        begin

          Inc(FVisibleCount);

          NeedUpdate := True;

        end;

      end;



      if vsVisible in Node.States then

        // Update the hidden children flag of the parent.

        // Since this node is now visible we simply have to remove the flag.

        Exclude(Node.Parent.States, vsAllChildrenHidden);

    end;



    InvalidateCache;

    if NeedUpdate and (FUpdateCount = 0) then

    begin

      ValidateCache;

      UpdateScrollBars(True);

      Invalidate;

    end;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------

procedure TBaseVirtualTree.SetImages(const Value: TCustomImageList);



begin

  if FImages <> Value then

  begin

    if Assigned(FImages) then

    begin

      FImages.UnRegisterChanges(FImageChangeLink);

      FImages.RemoveFreeNotification(Self);

    end;

    FImages := Value;

    if Assigned(FImages) then

    begin

      FImages.RegisterChanges(FImageChangeLink);

      FImages.FreeNotification(Self);

    end;

    if not (csLoading in ComponentState) then

      Invalidate;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.SetIndent(Value: Cardinal);



begin

  if FIndent <> Value then

  begin

    FIndent := Value;

    if not (csLoading in ComponentState) and (FUpdateCount = 0) and HandleAllocated then

    begin

      UpdateScrollBars(True);

      Invalidate;

    end;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.SetLineMode(const Value: TVTLineMode);



begin

  if FLineMode <> Value then

  begin

    FLineMode := Value;

    if HandleAllocated and not (csLoading in ComponentState) then

      Invalidate;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.SetLineStyle(const Value: TVTLineStyle);



begin

  if FLineStyle <> Value then

  begin

    FLineStyle := Value;

    if not (csLoading in ComponentState) then

    begin

      PrepareBitmaps(False, True);

      if HandleAllocated then

        Invalidate;

    end;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.SetMargin(Value: Integer);



begin

  if FMargin <> Value then

  begin

    FMargin := Value;

    if HandleAllocated and not (csLoading in ComponentState) then

      Invalidate;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.SetMultiline(Node: PVirtualNode; const Value: Boolean);



begin

  if Assigned(Node) and (Node <> FRoot) then

    if Value <> (vsMultiline in Node.States) then

    begin

      if Value then

        Include(Node.States, vsMultiline)

      else

        Exclude(Node.States, vsMultiline);



      if FUpdateCount = 0 then

        InvalidateNode(Node);

    end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.SetNodeAlignment(const Value: TVTNodeAlignment);



begin

  if FNodeAlignment <> Value then

  begin

    FNodeAlignment := Value;

    if HandleAllocated and not (csReading in ComponentState) then

      Invalidate;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.SetNodeDataSize(Value: Integer);



var

  LastRootCount: Cardinal;



begin

  if Value < -1 then

    Value := -1;

  if FNodeDataSize <> Value then

  begin

    FNodeDataSize := Value;

    if not (csLoading in ComponentState) and not (csDesigning in ComponentState) then

    begin

      LastRootCount := FRoot.ChildCount;

      Clear;

      SetRootNodeCount(LastRootCount);

    end;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.SetNodeHeight(Node: PVirtualNode; Value: Cardinal);



var

  Difference: Integer;



begin

  if Assigned(Node) and (Node <> FRoot) and (Node.NodeHeight <> Value) and not (toReadOnly in FOptions.FMiscOptions) then

  begin

    Difference := Integer(Value) - Integer(Node.NodeHeight);

    Node.NodeHeight := Value;



    // If the node is effectively filtered out, nothing else has to be done, as it is not visible anyway.

    if not IsEffectivelyFiltered[Node] then

    begin

      AdjustTotalHeight(Node, Difference, True);



      // If an edit operation is currently active then update the editors boundaries as well.

      UpdateEditBounds;



      InvalidateCache;

      // Stay away from touching the node cache while it is being validated.

      if not (tsValidating in FStates) and FullyVisible[Node] and not IsEffectivelyFiltered[Node] then

      begin

        if (FUpdateCount = 0) and ([tsPainting, tsSizing] * FStates = []) then

        begin

          ValidateCache;

          InvalidateToBottom(Node);

          UpdateScrollBars(True);

        end;

      end;

    end;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.SetNodeParent(Node: PVirtualNode; const Value: PVirtualNode);



begin

  if Assigned(Node) and Assigned(Value) and (Node.Parent <> Value) then

    MoveTo(Node, Value, amAddChildLast, False);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.SetOffsetX(const Value: Integer);



begin

  DoSetOffsetXY(Point(Value, FOffsetY), DefaultScrollUpdateFlags);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.SetOffsetXY(const Value: TPoint);



begin

  DoSetOffsetXY(Value, DefaultScrollUpdateFlags);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.SetOffsetY(const Value: Integer);



begin

  DoSetOffsetXY(Point(FOffsetX, Value), DefaultScrollUpdateFlags);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.SetOptions(const Value: TCustomVirtualTreeOptions);



begin

  FOptions.Assign(Value);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.SetRootNodeCount(Value: Cardinal);



begin

  // Don't set the root node count until all other properties (in particular the OnInitNode event) have been set.

  if csLoading in ComponentState then

  begin

    FRoot.ChildCount := Value;

    DoStateChange([tsNeedRootCountUpdate]);

  end

  else

    if FRoot.ChildCount <> Value then

    begin

      BeginUpdate;

      InterruptValidation;

      SetChildCount(FRoot, Value);

      EndUpdate;

    end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.SetScrollBarOptions(Value: TScrollBarOptions);



begin

  FScrollBarOptions.Assign(Value);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.SetSearchOption(const Value: TVTIncrementalSearch);



begin

  if FIncrementalSearch <> Value then

  begin

    FIncrementalSearch := Value;

    if FIncrementalSearch = isNone then

    begin

      StopTimer(SearchTimer);

      FSearchBuffer := '';

      FLastSearchNode := nil;

    end;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.SetSelected(Node: PVirtualNode; Value: Boolean);



begin

  if not FSelectionLocked and Assigned(Node) and (Node <> FRoot) and (Value xor (vsSelected in Node.States)) then

  begin

    if Value then

    begin

      if FSelectionCount = 0 then

        FRangeAnchor := Node

      else

        if not (toMultiSelect in FOptions.FSelectionOptions) then

          ClearSelection;



      AddToSelection(Node);



      // Make sure there is a valid column selected (if there are columns at all).

      if ((FFocusedColumn < 0) or not (coVisible in FHeader.Columns[FFocusedColumn].Options)) and

        (FHeader.MainColumn > NoColumn) then

        if ([coVisible, coAllowFocus] *  FHeader.Columns[FHeader.MainColumn].Options = [coVisible, coAllowFocus]) then

          FFocusedColumn := FHeader.MainColumn

        else

          FFocusedColumn := FHeader.Columns.GetFirstVisibleColumn(True);

      if FRangeAnchor = nil then

        FRangeAnchor := Node;

    end

    else

    begin

      RemoveFromSelection(Node);

      if FSelectionCount = 0 then

        ResetRangeAnchor;

    end;

    if FullyVisible[Node] and not IsEffectivelyFiltered[Node] then

      InvalidateNode(Node);

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.SetSelectionCurveRadius(const Value: Cardinal);



begin

  if FSelectionCurveRadius <> Value then

  begin

    FSelectionCurveRadius := Value;

    if HandleAllocated and not (csLoading in ComponentState) then

      Invalidate;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.SetStateImages(const Value: TCustomImageList);



begin

  if FStateImages <> Value then

  begin

    if Assigned(FStateImages) then

    begin

      FStateImages.UnRegisterChanges(FStateChangeLink);

      FStateImages.RemoveFreeNotification(Self);

    end;

    FStateImages := Value;

    if Assigned(FStateImages) then

    begin

      FStateImages.RegisterChanges(FStateChangeLink);

      FStateImages.FreeNotification(Self);

    end;

    if HandleAllocated and not (csLoading in ComponentState) then

      Invalidate;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.SetTextMargin(Value: Integer);



begin

  if FTextMargin <> Value then

  begin

    FTextMargin := Value;

    if not (csLoading in ComponentState) then

      Invalidate;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.SetTopNode(Node: PVirtualNode);



var

  R: TRect;

  Run: PVirtualNode;



begin

  if Assigned(Node) then

  begin

    // make sure all parents of the node are expanded

    Run := Node.Parent;

    while Run <> FRoot do

    begin

      if not (vsExpanded in Run.States) then

        ToggleNode(Run);

      Run := Run.Parent;

    end;

    R := GetDisplayRect(Node, FHeader.MainColumn, True);

    SetOffsetY(FOffsetY - R.Top);

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.SetUpdateState(Updating: Boolean);



begin

  // The check for visibility is necessary otherwise the tree is automatically shown when

  // updating is allowed. As this happens internally the VCL does not get notified and

  // still assumes the control is hidden. This results in weird "cannot focus invisible control" errors.

  if Visible and HandleAllocated and (FUpdateCount = 0) then

    SendMessage(Handle, WM_SETREDRAW, Ord(not Updating), 0);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.SetVerticalAlignment(Node: PVirtualNode; Value: Byte);



begin

  if Value > 100 then

    Value := 100;

  if Node.Align <> Value then

  begin

    Node.Align := Value;

    if FullyVisible[Node] and not IsEffectivelyFiltered[Node] then

      InvalidateNode(Node);

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.SetVisible(Node: PVirtualNode; Value: Boolean);



// Sets the visibility style of the given node according to Value.



var

  NeedUpdate: Boolean;



begin

  Assert(Assigned(Node) and (Node <> FRoot), 'Invalid parameter.');



  if Value <> (vsVisible in Node.States) then

  begin

    InterruptValidation;

    NeedUpdate := False;

    if Value then

    begin

      Include(Node.States, vsVisible);

      if vsExpanded in Node.Parent.States then

        AdjustTotalHeight(Node.Parent, Node.TotalHeight, True);

      if VisiblePath[Node] then

      begin

        Inc(FVisibleCount, CountVisibleChildren(Node) + Cardinal(IfThen(IsEffectivelyVisible[Node], 1)));

        NeedUpdate := True;

      end;



      // Update the hidden children flag of the parent.

      // Since this node is now visible we simply have to remove the flag.

      if not IsEffectivelyFiltered[Node] then

        Exclude(Node.Parent.States, vsAllChildrenHidden);

    end

    else

    begin

      if vsExpanded in Node.Parent.States then

        AdjustTotalHeight(Node.Parent, -Integer(Node.TotalHeight), True);

      if VisiblePath[Node] then

      begin

        Dec(FVisibleCount, CountVisibleChildren(Node) + Cardinal(IfThen(IsEffectivelyVisible[Node], 1)));

        NeedUpdate := True;

      end;

      Exclude(Node.States, vsVisible);



      if FUpdateCount = 0 then

        DetermineHiddenChildrenFlag(Node.Parent)

      else

        Include(FStates, tsUpdateHiddenChildrenNeeded);

    end;



    InvalidateCache;

    if NeedUpdate and (FUpdateCount = 0) then

    begin

      ValidateCache;

      UpdateScrollBars(True);

      Invalidate;

    end;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.SetVisiblePath(Node: PVirtualNode; Value: Boolean);



// If Value is True then all parent nodes of Node are expanded.



begin

  Assert(Assigned(Node) and (Node <> FRoot), 'Invalid parameter.');



  if Value then

  begin

    repeat

      Node := Node.Parent;

      if Node = FRoot then

        Break;

      if not (vsExpanded in Node.States) then

        ToggleNode(Node);

    until False;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.StaticBackground(Source: TBitmap; Target: TCanvas; OffsetPosition: TPoint; R: TRect);



// Draws the given source graphic so that it stays static in the given rectangle which is relative to the target bitmap.

// The graphic is aligned so that it always starts at the upper left corner of the target canvas.

// Offset gives the position of the target window as a possible superordinated surface.



const

  DST = $00AA0029; // Ternary Raster Operation - Destination unchanged



var

  PicRect: TRect;

  AreaRect: TRect;

  DrawRect: TRect;



begin

  // clear background

  Target.Brush.Color := Color;

  Target.FillRect(R);



  // Picture rect in relation to client viewscreen.

  PicRect := Rect(FBackgroundOffsetX, FBackgroundOffsetY, FBackgroundOffsetX + Source.Width, FBackgroundOffsetY + Source.Height);



  // Area to be draw in relation to client viewscreen.

  AreaRect := Rect(OffsetPosition.X + R.Left, OffsetPosition.Y + R.Top, OffsetPosition.X + R.Right, OffsetPosition.Y + R.Bottom);



  // If picture falls in AreaRect, return intersection (DrawRect).

  if IntersectRect(DrawRect, PicRect, AreaRect) then

  begin

    // Draw portion of image which falls in canvas area.

    if Source.Transparent then

    begin

      // Leave transparent area as destination unchanged (DST), copy non-transparent areas to canvas (SRCCOPY).

      MaskBlt(Target.Handle, DrawRect.Left - OffsetPosition.X, DrawRect.Top - OffsetPosition.Y, (DrawRect.Right - OffsetPosition.X) - (DrawRect.Left - OffsetPosition.X),

        (DrawRect.Bottom - OffsetPosition.Y) - (DrawRect.Top - OffsetPosition.Y), Source.Canvas.Handle, DrawRect.Left - PicRect.Left, DrawRect.Top - PicRect.Top,

        Source.MaskHandle, DrawRect.Left - PicRect.Left, DrawRect.Top - PicRect.Top, MakeROP4(DST, SRCCOPY));

    end

    else

    begin

      // copy image to destination

      BitBlt(Target.Handle, DrawRect.Left - OffsetPosition.X, DrawRect.Top - OffsetPosition.Y, (DrawRect.Right - OffsetPosition.X) - (DrawRect.Left - OffsetPosition.X),

        (DrawRect.Bottom - OffsetPosition.Y) - (DrawRect.Top - OffsetPosition.Y) + R.Top, Source.Canvas.Handle, DrawRect.Left - PicRect.Left, DrawRect.Top - PicRect.Top,

        SRCCOPY);

    end;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.StopTimer(ID: Integer);



begin

  if HandleAllocated then

    KillTimer(Handle, ID);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.SetWindowTheme(Theme: UnicodeString);



begin

  FChangingTheme := True;

  UxTheme.SetWindowTheme(Handle, PWideChar(Theme), nil);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.TileBackground(Source: TBitmap; Target: TCanvas; Offset: TPoint; R: TRect);



// Draws the given source graphic so that it tiles into the given rectangle which is relative to the target bitmap.

// The graphic is aligned so that it always starts at the upper left corner of the target canvas.

// Offset gives the position of the target window in an possible superordinated surface.



var

  SourceX,

  SourceY,

  TargetX,

  DeltaY: Integer;



begin

  with Target do

  begin

    SourceY := (R.Top + Offset.Y + FBackgroundOffsetY) mod Source.Height;

    // Always wrap the source coordinates into positive range.

    if SourceY < 0 then

      SourceY := Source.Height + SourceY;



    // Tile image vertically until target rect is filled.

    while R.Top < R.Bottom do

    begin

      SourceX := (R.Left + Offset.X + FBackgroundOffsetX) mod Source.Width;

      // always wrap the source coordinates into positive range

      if SourceX < 0 then

        SourceX := Source.Width + SourceX;



      TargetX := R.Left;

      // height of strip to draw

      DeltaY := Min(R.Bottom - R.Top, Source.Height - SourceY);



      // tile the image horizontally

      while TargetX < R.Right do

      begin

        BitBlt(Handle, TargetX, R.Top, Min(R.Right - TargetX, Source.Width - SourceX), DeltaY,

          Source.Canvas.Handle, SourceX, SourceY, SRCCOPY);

        Inc(TargetX, Source.Width - SourceX);

        SourceX := 0;

      end;

      Inc(R.Top, Source.Height - SourceY);

      SourceY := 0;

    end;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.ToggleCallback(Step, StepSize: Integer; Data: Pointer): Boolean;



var

  Column: TColumnIndex;

  Run: TRect;

  SecondaryStepSize: Integer;



  //--------------- local functions -------------------------------------------



  procedure EraseLine;



  var

    LocalBrush: HBRUSH;



  begin

    with TToggleAnimationData(Data^), FHeader.FColumns do

    begin

      // Iterate through all columns and erase background in their local color.

      // LocalBrush is a brush in the color of the particular column.

      Column := GetFirstVisibleColumn;

      while (Column > InvalidColumn) and (Run.Left < ClientWidth) do

      begin

        GetColumnBounds(Column, Run.Left, Run.Right);

        if coParentColor in Items[Column].FOptions then

          FillRect(DC, Run, Brush)

        else

        begin

          if VclStyleEnabled then

            LocalBrush := CreateSolidBrush(ColorToRGB(FColors.BackGroundColor))

          else

            LocalBrush := CreateSolidBrush(ColorToRGB(Items[Column].Color));

          FillRect(DC, Run, LocalBrush);

          DeleteObject(LocalBrush);

        end;

        Column := GetNextVisibleColumn(Column);

      end;

    end;

  end;



  //---------------------------------------------------------------------------



  procedure DoScrollUp(DC: HDC; Brush: HBRUSH; Area: TRect; Steps: Integer);



  begin

    ScrollDC(DC, 0, -Steps, Area, Area, 0, nil);



    if Step = 0 then

      if not FHeader.UseColumns then

        FillRect(DC, Rect(Area.Left, Area.Bottom - Steps - 1, Area.Right, Area.Bottom), Brush)

      else

      begin

        Run := Rect(Area.Left, Area.Bottom - Steps - 1, Area.Right, Area.Bottom);

        EraseLine;

      end;

  end;



  //---------------------------------------------------------------------------



  procedure DoScrollDown(DC: HDC; Brush: HBRUSH; Area: TRect; Steps: Integer);



  begin

    ScrollDC(DC, 0, Steps, Area, Area, 0, nil);



    if Step = 0 then

      if not FHeader.UseColumns then

        FillRect(DC, Rect(Area.Left, Area.Top, Area.Right, Area.Top + Steps + 1), Brush)

      else

      begin

        Run := Rect(Area.Left, Area.Top, Area.Right, Area.Top + Steps + 1);

        EraseLine;

      end;

  end;



  //--------------- end local functions ---------------------------------------



begin

  Result := True;

  if StepSize > 0 then

  begin

    SecondaryStepSize := 0;

    with TToggleAnimationData(Data^) do

    begin

      if Mode1 <> tamNoScroll then

      begin

        if Mode1 = tamScrollUp then

          DoScrollUp(DC, Brush, R1, StepSize)

        else

          DoScrollDown(DC, Brush, R1, StepSize);



        if (Mode2 <> tamNoScroll) and (ScaleFactor > 0) then

        begin

          // As this routine is able to scroll two independent areas at once, the missing StepSize is

          // computed in that case. To ensure the maximal accuracy the rounding error is accumulated.

          SecondaryStepSize := Round((StepSize + MissedSteps) * ScaleFactor);

          MissedSteps := MissedSteps + StepSize * ScaleFactor - SecondaryStepSize;

        end;

      end

      else

        SecondaryStepSize := StepSize;



      if Mode2 <> tamNoScroll then

        if Mode2 = tamScrollUp then

          DoScrollUp(DC, Brush, R2, SecondaryStepSize)

        else

          DoScrollDown(DC, Brush, R2, SecondaryStepSize);

    end;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.CMColorChange(var Message: TMessage);



begin

  if not (csLoading in ComponentState) then

  begin

    PrepareBitmaps(True, False);

    if HandleAllocated then

      Invalidate;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.CMCtl3DChanged(var Message: TMessage);



begin

  inherited;

  if FBorderStyle = bsSingle then

    RecreateWnd;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.CMBiDiModeChanged(var Message: TMessage);



begin

  inherited;



  if UseRightToLeftAlignment then

    FEffectiveOffsetX := Integer(FRangeX) - ClientWidth + FOffsetX

  else

    FEffectiveOffsetX := -FOffsetX;

  if FEffectiveOffsetX < 0 then

    FEffectiveOffsetX := 0;



  if toAutoBidiColumnOrdering in FOptions.FAutoOptions then

    FHeader.FColumns.ReorderColumns(UseRightToLeftAlignment);

  FHeader.Invalidate(nil);

end;



 {$if CompilerVersion >= 23 }

procedure TBaseVirtualTree.CMBorderChanged(var Message: TMessage);

begin

  inherited;

  // For XE2+ themes

  if not FSetOrRestoreBevelKindAndBevelWidth then

  begin

    FSavedBevelKind := BevelKind;

    FSavedBorderWidth := BorderWidth;

  end;

end;



procedure TBaseVirtualTree.CMStyleChanged(var Message: TMessage);

begin

  VclStyleChanged;

  RecreateWnd;

end;



procedure TBaseVirtualTree.CMParentDoubleBufferedChange(var Message: TMessage);

begin

  // empty by intention, we do our own buffering

end;



{$ifend}



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.CMDenySubclassing(var Message: TMessage);



// If a Windows XP Theme Manager component is used in the application it will try to subclass all controls which do not

// explicitly deny this. Virtual Treeview knows how to handle XP themes so it does not need subclassing.



begin

  Message.Result := 1;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.CMDrag(var Message: TCMDrag);



var

  S: TObject;

  ShiftState: Integer;

  P: TPoint;

  Formats: TFormatArray;

  Effect: Integer;



begin

  with Message, DragRec^ do

  begin

    S := Source;

    Formats := nil;



    // Let the ancestor handle dock operations.

    if S is TDragDockObject then

      inherited

    else

    begin

      // We need an extra check for the control drag object as there might be other objects not derived from

      // this class (e.g. TActionDragObject).

      if not (tsUserDragObject in FStates) and (S is TBaseDragControlObject) then

        S := (S as TBaseDragControlObject).Control;

      case DragMessage of

        dmDragEnter, dmDragLeave, dmDragMove:

          begin

            if DragMessage = dmDragEnter then

              DoStateChange([tsVCLDragging]);

            if DragMessage = dmDragLeave then

              DoStateChange([tsVCLDragFinished], [tsVCLDragging]);



            if DragMessage = dmDragMove then

              with ScreenToClient(Pos) do

                DoAutoScroll(X, Y);



            ShiftState := 0;

            // Alt key will be queried by the KeysToShiftState function in DragOver.

            if GetKeyState(VK_SHIFT) < 0 then

              ShiftState := ShiftState or MK_SHIFT;

            if GetKeyState(VK_CONTROL) < 0 then

              ShiftState := ShiftState or MK_CONTROL;



            // Allowed drop effects are simulated for VCL dd.

            Effect := DROPEFFECT_MOVE or DROPEFFECT_COPY;

            DragOver(S, ShiftState, TDragState(DragMessage), Pos, Effect);

            FLastVCLDragTarget := FDropTargetNode;

            FVCLDragEffect := Effect;

            if (DragMessage = dmDragLeave) and Assigned(FDropTargetNode) then

            begin

              InvalidateNode(FDropTargetNode);

              FDropTargetNode := nil;

            end;

            Result := LRESULT(Effect);

          end;

        dmDragDrop:

          begin

            ShiftState := 0;

            // Alt key will be queried by the KeysToShiftState function in DragOver

            if GetKeyState(VK_SHIFT) < 0 then

              ShiftState := ShiftState or MK_SHIFT;

            if GetKeyState(VK_CONTROL) < 0 then

              ShiftState := ShiftState or MK_CONTROL;



            // allowed drop effects are simulated for VCL dd,

            // replace target node with cached node from other VCL dd messages

            if Assigned(FDropTargetNode) then

              InvalidateNode(FDropTargetNode);

            FDropTargetNode := FLastVCLDragTarget;

            P := Point(Pos.X, Pos.Y);

            P := ScreenToClient(P);

            try

              DoDragDrop(S, nil, Formats, KeysToShiftState(ShiftState), P, FVCLDragEffect, FLastDropMode);

            finally

              if Assigned(FDropTargetNode) then

              begin

                InvalidateNode(FDropTargetNode);

                FDropTargetNode := nil;

              end;

            end;

          end;

        dmFindTarget:

          begin

            Result := LRESULT(ControlAtPos(ScreenToClient(Pos), False));

            if Result = 0 then

              Result := LRESULT(Self);



            // This is a reliable place to check whether VCL drag has

            // really begun.

            if tsVCLDragPending in FStates then

              DoStateChange([tsVCLDragging], [tsVCLDragPending, tsEditPending, tsClearPending]);

          end;

      end;

    end;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.CMEnabledChanged(var Message: TMessage);



begin

  inherited;



  // Need to invalidate the non-client area as well, since the header must be redrawn too.

  if csDesigning in ComponentState then

    RedrawWindow(Handle, nil, 0, RDW_FRAME or RDW_INVALIDATE or RDW_NOERASE or RDW_NOCHILDREN);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.CMFontChanged(var Message: TMessage);



var

  HeaderMessage: TMessage;



begin

  inherited;



  if not (csLoading in ComponentState) then

  begin

    AutoScale();

    PrepareBitmaps(True, False);

    if HandleAllocated then

      Invalidate;

  end;



  HeaderMessage.Msg := CM_PARENTFONTCHANGED;

  HeaderMessage.WParam := 0;

  HeaderMessage.LParam := 0;

  HeaderMessage.Result := 0;

  FHeader.HandleMessage(HeaderMessage);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.CMHintShow(var Message: TCMHintShow);



// Determines hint message (tooltip) and out-of-hint rect.

// Note: A special handling is needed here because we cannot pass wide strings back to the caller.

//       I had to introduce the hint data record anyway so we can use this to pass the hint string.

//       We still need to set a dummy hint string in the message to make the VCL showing the hint window.



var

  NodeRect: TRect;

  SpanColumn,

  Dummy,

  ColLeft,

  ColRight: Integer;

  HitInfo: THitInfo;

  ShowOwnHint: Boolean;

  IsFocusedOrEditing: Boolean;

  ParentForm: TCustomForm;

  BottomRightCellContentMargin: TPoint;

  DummyLineBreakStyle: TVTTooltipLineBreakStyle;

  HintKind: TVTHintKind;

begin

  with Message do

  begin

    Result := 1;



    if PtInRect(FLastHintRect, HintInfo.CursorPos) then

      Exit;



    // Determine node for which to show hint/tooltip.

    with HintInfo^ do

      GetHitTestInfoAt(CursorPos.X, CursorPos.Y, True, HitInfo);



    // Make sure a hint is only shown if the tree or at least its parent form is active.

    // Active editing is ok too as long as we don't want the hint for the current edit node.

    if IsEditing then

      IsFocusedOrEditing := HitInfo.HitNode <> FFocusedNode

    else

    begin

      IsFocusedOrEditing := Focused;

      ParentForm := GetParentForm(Self);

      if Assigned(ParentForm) then

        IsFocusedOrEditing := ParentForm.Focused or Application.Active;

    end;



    if (GetCapture = 0) and ShowHint and not (Dragging or IsMouseSelecting) and ([tsScrolling] * FStates = []) and

      (FHeader.States = []) and IsFocusedOrEditing then

    begin

      with HintInfo^ do

      begin

        Result := 0;

        ShowOwnHint := False;

        // Assign a dummy string otherwise the VCL will not show the hint window.

        if GetHintWindowClass.InheritsFrom(TVirtualTreeHintWindow) then

          HintStr := ' '

        else

        begin

          //workaround for issue #291

          //it duplicates parts of the following code and code in TVirtualTreeHintWindow

          HintStr := '';

          if FHeader.UseColumns and (hoShowHint in FHeader.FOptions) and FHeader.InHeader(CursorPos) then

          begin

            CursorRect := FHeaderRect;

            // Convert the cursor rectangle into real client coordinates.

            OffsetRect(CursorRect, 0, -Integer(FHeader.FHeight));

            HitInfo.HitColumn := FHeader.FColumns.GetColumnAndBounds(CursorPos, CursorRect.Left, CursorRect.Right);

            if (HitInfo.HitColumn > -1) and not (csLButtonDown in ControlState) and

              (FHeader.FColumns[HitInfo.HitColumn].FHint <> '') then

              HintStr := FHeader.FColumns[HitInfo.HitColumn].FHint;

          end

          else

          if HintMode = hmDefault then

            HintStr := GetShortHint(Hint)

          else

          if Assigned(HitInfo.HitNode) and (HitInfo.HitColumn > InvalidColumn) then

          begin

            if HintMode = hmToolTip then

              HintStr := DoGetNodeToolTip(HitInfo.HitNode, HitInfo.HitColumn, DummyLineBreakStyle)

            else

              HintStr := DoGetNodeHint(HitInfo.HitNode, HitInfo.HitColumn, DummyLineBreakStyle);

          end;

        end;



        // First check whether there is a header hint to show.

        if FHeader.UseColumns and (hoShowHint in FHeader.FOptions) and FHeader.InHeader(CursorPos) then

        begin

          CursorRect := FHeaderRect;

          // Convert the cursor rectangle into real client coordinates.

          OffsetRect(CursorRect, 0, -Integer(FHeader.FHeight));

          HitInfo.HitColumn := FHeader.FColumns.GetColumnAndBounds(CursorPos, CursorRect.Left, CursorRect.Right);

          // align the vertical hint position on the bottom bound of the header, but

          // avoid overlapping of mouse cursor and hint

          HintPos.Y := Max(HintPos.Y, ClientToScreen(Point(0, CursorRect.Bottom)).Y);

          // Note: the test for the left mouse button in ControlState might cause problems whenever the VCL does not

          //       realize when the button is released. This, for instance, happens when doing OLE drag'n drop and

          //       cancel this with ESC.

          if (HitInfo.HitColumn > -1) and not (csLButtonDown in ControlState) then

          begin

            FHintData.DefaultHint := FHeader.FColumns[HitInfo.HitColumn].FHint;

            if FHintData.DefaultHint <> '' then

              ShowOwnHint := True

            else

              Result := 1;

          end

          else

            Result := 1;

        end

        else

        begin

          // Default mode is handled as would the tree be a usual VCL control (no own hint window necessary).

          if FHintMode = hmDefault then

            HintStr := GetShortHint(Hint)

          else

          begin

            if Assigned(HitInfo.HitNode) and (HitInfo.HitColumn > InvalidColumn) then

            begin

              // An owner-draw tree should only display a hint when at least

              // its OnGetHintSize event handler is assigned.

              DoGetHintKind(HitInfo.HitNode, HitInfo.HitColumn, HintKind);

              FHintData.HintRect := Rect(0, 0, 0, 0);

              if (HintKind = vhkOwnerDraw) then

              begin

                DoGetHintSize(HitInfo.HitNode, HitInfo.HitColumn, FHintData.HintRect);

                ShowOwnHint := not IsRectEmpty(FHintData.HintRect);

              end

              else

                // For trees displaying text hints, a decision about showing the hint or not is based

                // on the hint string (if it is empty then no hint is shown).

                ShowOwnHint := True;



              if ShowOwnHint then

              begin

                if HitInfo.HitColumn > NoColumn then

                begin

                  FHeader.FColumns.GetColumnBounds(HitInfo.HitColumn, ColLeft, ColRight);

                  // The right column border might be extended if column spanning is enabled.

                  if toAutoSpanColumns in FOptions.FAutoOptions then

                  begin

                    SpanColumn := HitInfo.HitColumn;

                    repeat

                      Dummy := FHeader.FColumns.GetNextVisibleColumn(SpanColumn);

                      if (Dummy = InvalidColumn) or not ColumnIsEmpty(HitInfo.HitNode, Dummy) then

                        Break;

                      SpanColumn := Dummy;

                    until False;

                    if SpanColumn <> HitInfo.HitColumn then

                      FHeader.FColumns.GetColumnBounds(SpanColumn, Dummy, ColRight);

                  end;

                end

                else

                begin

                  ColLeft := 0;

                  ColRight := ClientWidth;

                end;



                FHintData.DefaultHint := '';

                if FHintMode <> hmTooltip then

                begin

                  // Node specific hint text.

                  CursorRect := GetDisplayRect(HitInfo.HitNode, HitInfo.HitColumn, False);

                  CursorRect.Left := ColLeft;

                  CursorRect.Right := ColRight;

                  // Align the vertical hint position on the bottom bound of the node, but

                  // avoid overlapping of mouse cursor and hint.

                  HintPos.Y := Max(HintPos.Y, ClientToScreen(CursorRect.BottomRight).Y) + 2;

                end

                else

                begin

                  // Tool tip to show. This means the full caption of the node must be displayed.

                  if vsMultiline in HitInfo.HitNode.States then

                  begin

                    if hiOnItemLabel in HitInfo.HitPositions then

                    begin

                      ShowOwnHint := True;

                      NodeRect := GetDisplayRect(HitInfo.HitNode, HitInfo.HitColumn, True, False);

                    end;

                  end

                  else

                  begin

                    NodeRect := GetDisplayRect(HitInfo.HitNode, HitInfo.HitColumn, True, True, True);

                    BottomRightCellContentMargin := DoGetCellContentMargin(HitInfo.HitNode, HitInfo.HitColumn, ccmtBottomRightOnly);



                    ShowOwnHint := (HitInfo.HitColumn > InvalidColumn) and PtInRect(NodeRect, CursorPos) and

                      (CursorPos.X <= ColRight) and (CursorPos.X >= ColLeft) and

                      (

                        // Show hint also if the node text is partially out of the client area.

                        // "ColRight - 1", since the right column border is not part of this cell.

                        ( (NodeRect.Right + BottomRightCellContentMargin.X) > Min(ColRight - 1, ClientWidth) ) or

                        (NodeRect.Left < Max(ColLeft, 0)) or

                        ( (NodeRect.Bottom + BottomRightCellContentMargin.Y) > ClientHeight ) or

                        (NodeRect.Top < 0)

                      );

                  end;



                  if ShowOwnHint then

                  begin

                    // Node specific hint text given will be retrieved when needed.

                    FHintData.DefaultHint := '';

                    HintPos := ClientToScreen(Point(NodeRect.Left, NodeRect.Top));

                    CursorRect := NodeRect;

                  end

                  else

                    // nothing to show

                    Result := 1;

                end;

              end

              else

                Result := 1; // Avoid hint if this is a draw tree returning an empty hint rectangle.

            end

            else

            begin

              // No node so fall back to control's hint (if indicated) or show nothing.

              if FHintMode = hmHintAndDefault then

              begin

                FHintData.DefaultHint := GetShortHint(Hint);

                if Length(FHintData.DefaultHint) = 0 then

                  Result := 1

                else

                  ShowOwnHint := True;

              end

              else

                Result := 1;

            end;

          end;

        end;



        // Set our own hint window class and prepare structure to be passed to the hint window.

        if ShowOwnHint and (Result = 0) then

        begin

          HintWindowClass := GetHintWindowClass;



          FHintData.Tree := Self;

          FHintData.Column := HitInfo.HitColumn;

          FHintData.Node := HitInfo.HitNode;

          FLastHintRect := CursorRect;

          HintData := @FHintData;

        end

        else

          FLastHintRect := Rect(0, 0, 0, 0);

      end;



      // Remind that a hint is about to show.

      if Result = 0 then

        DoStateChange([tsHint])

      else

        DoStateChange([], [tsHint]);

    end;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.CMHintShowPause(var Message: TCMHintShowPause);



// Tells the application that the tree (and only the tree) does not want a delayed tool tip.

// Normal hints / header hints use the default delay (except for the first time).



var

  P: TPoint;



begin

  // A little workaround is needed here to make the application class using the correct hint window class.

  // Once the application gets ShowHint set to true (which is the case when we want to show hints in the tree) then

  // an internal hint window will be created which is not our own class (because we don't set an application wide

  // hint window class but only one for the tree). Unfortunately, this default hint window class will prevent

  // hints for the non-client area to show up (e.g. for the header) by calling CancelHint whenever certain messages

  // arrive. By setting the hint show pause to 0 if our hint class was not used recently we make sure

  // that the hint timer (in Forms.pas) is not used and our class is created immediately.

  if FHintWindowDestroyed then

  begin

    GetCursorPos(P);

    // Check if the mouse is in the header or tool tips are enabled, which must be shown without delay anyway.

    if FHeader.UseColumns and (hoShowHint in FHeader.FOptions) and FHeader.InHeader(ScreenToClient(P)) or

      (FHintMode = hmToolTip) then

      Message.Pause^ := 0;

  end

  else

    if FHintMode = hmToolTip then

      Message.Pause^ := 0;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.CMMouseEnter(var Message: TMessage);

begin

  DoMouseEnter();

  inherited;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.CMMouseLeave(var Message: TMessage);



var

  LeaveStates: TVirtualTreeStates;



begin

  // Reset the last used hint rectangle in case the mouse enters the window within the bounds

  if Assigned(FHintData.Tree) then

    FHintData.Tree.FLastHintRect := Rect(0, 0, 0, 0);



  LeaveStates := [tsHint];

  if [tsWheelPanning, tsWheelScrolling] * FStates = [] then

  begin

    StopTimer(ScrollTimer);

    LeaveStates := LeaveStates + [tsScrollPending, tsScrolling];

  end;

  DoStateChange([], LeaveStates);

  if Assigned(FCurrentHotNode) then

  begin

    DoHotChange(FCurrentHotNode, nil);

    if (toHotTrack in FOptions.PaintOptions) or (toCheckSupport in FOptions.FMiscOptions) then

      InvalidateNode(FCurrentHotNode);

    FCurrentHotNode := nil;

  end;



  if Assigned(Header) then

  begin

    Header.FColumns.FDownIndex := NoColumn;

    Header.FColumns.FHoverIndex := NoColumn;

    Header.FColumns.FCheckBoxHit := False;

  end;

  DoMouseLeave();

  inherited;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.CMMouseWheel(var Message: TCMMouseWheel);



var

  ScrollAmount: Integer;

  ScrollLines: DWORD;

  RTLFactor: Integer;

  WheelFactor: Double;



begin

  StopWheelPanning;



  inherited;



  if Message.Result = 0  then

  begin

    with Message do

    begin

      Result := 1;

      WheelFactor := WheelDelta / WHEEL_DELTA;

      if (FRangeY > Cardinal(ClientHeight)) and (not (ssShift in ShiftState)) then

      begin

        // Scroll vertically if there's something to scroll...

        if ssCtrl in ShiftState then

          ScrollAmount := Trunc(WheelFactor * ClientHeight)

        else

        begin

          SystemParametersInfo(SPI_GETWHEELSCROLLLINES, 0, @ScrollLines, 0);

          if ScrollLines = WHEEL_PAGESCROLL then

            ScrollAmount := Trunc(WheelFactor * ClientHeight)

          else

            ScrollAmount := Integer(Trunc(WheelFactor * ScrollLines * FDefaultNodeHeight));

        end;

        SetOffsetY(FOffsetY + ScrollAmount);

      end

      else

      begin

        // ...else scroll horizontally if there's something to scroll.

        if UseRightToLeftAlignment then

          RTLFactor := -1

        else

          RTLFactor := 1;



        if ssCtrl in ShiftState then

          ScrollAmount := Trunc(WheelFactor * (ClientWidth - FHeader.Columns.GetVisibleFixedWidth))

        else

        begin

          SystemParametersInfo(SPI_GETWHEELSCROLLLINES, 0, @ScrollLines, 0);

          ScrollAmount := Trunc(WheelFactor * ScrollLines * FHeader.Columns.GetScrollWidth);

        end;

        SetOffsetX(FOffsetX + RTLFactor * ScrollAmount);

      end;

    end;



  end;



end;



//----------------------------------------------------------------------------------------------------------------------

procedure TBaseVirtualTree.CMSysColorChange(var Message: TMessage);



begin

  inherited;



  ConvertImageList(LightCheckImages, 'VT_CHECK_LIGHT');

  ConvertImageList(DarkCheckImages, 'VT_CHECK_DARK');

  ConvertImageList(LightTickImages, 'VT_TICK_LIGHT');

  ConvertImageList(DarkTickImages, 'VT_TICK_DARK');

  ConvertImageList(FlatImages, 'VT_FLAT');

  ConvertImageList(UtilityImages, 'VT_UTILITIES');

  // XP images do not need to be converted.

  // System check images do not need to be converted.

  Message.Msg := WM_SYSCOLORCHANGE;

  DefaultHandler(Message);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.TVMGetItem(var Message: TMessage);



// Screen reader support function. The method returns information about a particular node.



const

  StateMask = TVIS_STATEIMAGEMASK or TVIS_OVERLAYMASK or TVIS_EXPANDED or TVIS_DROPHILITED or TVIS_CUT or

    TVIS_SELECTED or TVIS_FOCUSED;



var

  Item: PTVItemEx;

  Node: PVirtualNode;

  Ghosted: Boolean;

  ImageIndex: Integer;

  R: TRect;

  Text: UnicodeString;

  {$ifndef UNICODE}

    ANSIText: ANSIString;

  {$endif}



begin

  // We can only return valid data if a nodes reference is given.

  Item := Pointer(Message.LParam);

  Message.Result := Ord(((Item.mask and TVIF_HANDLE) <> 0) and Assigned(Item.hItem));

  if Message.Result = 1 then

  begin

    Node := Pointer(Item.hItem);

    // Child count requested?

    if (Item.mask and TVIF_CHILDREN) <> 0 then

      Item.cChildren := Node.ChildCount;

    // Index for normal image requested?

    if (Item.mask and TVIF_IMAGE) <> 0 then

    begin

      Item.iImage := -1;

      DoGetImageIndex(Node, ikNormal, -1, Ghosted, Item.iImage);

    end;

    // Index for selected image requested?

    if (Item.mask and TVIF_SELECTEDIMAGE) <> 0 then

    begin

      Item.iSelectedImage := -1;

      DoGetImageIndex(Node, ikSelected, -1, Ghosted, Item.iSelectedImage);

    end;

    // State info requested?

    if (Item.mask and TVIF_STATE) <> 0 then

    begin

      // Everything, which is possible is returned.

      Item.stateMask := StateMask;

      Item.state := 0;

      if Node = FFocusedNode then

        Item.state := Item.state or TVIS_FOCUSED;

      if vsSelected in Node.States then

        Item.state := Item.state or TVIS_SELECTED;

      if vsCutOrCopy in Node.States then

        Item.state := Item.state or TVIS_CUT;

      if Node = FDropTargetNode then

        Item.state := Item.state or TVIS_DROPHILITED;

      if vsExpanded in Node.States then

        Item.state := Item.state or TVIS_EXPANDED;



      // Construct state image and overlay image indices. They are one based, btw.

      // and zero means there is no image.

      ImageIndex := -1;

      DoGetImageIndex(Node, ikState, -1, Ghosted, ImageIndex);

      Item.state := Item.state or Byte(IndexToStateImageMask(ImageIndex + 1));

      ImageIndex := -1;

      DoGetImageIndex(Node, ikOverlay, -1, Ghosted, ImageIndex);

      Item.state := Item.state or Byte(IndexToOverlayMask(ImageIndex + 1));

    end;

    // Node caption requested?

    if (Item.mask and TVIF_TEXT) <> 0 then

    begin

      GetTextInfo(Node, -1, Font, R, Text);



      {$ifdef UNICODE}

        StrLCopy(Item.pszText, PWideChar(Text), Item.cchTextMax - 1);

        Item.pszText[Length(Text)] := #0;

      {$else}

        // Convert the Unicode implicitely to ANSI using the current locale.

        ANSIText := Text;

        StrLCopy(Item.pszText, PChar(ANSIText), Item.cchTextMax - 1);

        Item.pszText[Length(ANSIText)] := #0;

      {$endif}

    end;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.TVMGetItemRect(var Message: TMessage);



// Screen read support function. This method returns a node's display rectangle.



var

  TextOnly: Boolean;

  Node: PVirtualNode;



begin

  // The lparam member is used two-way. On enter it contains a pointer to the item (node).

  // On exit it is to be considered as pointer to a rectangle structure.

  Node := Pointer(Pointer(Message.LParam)^);

  Message.Result := Ord(IsVisible[Node]);

  if Message.Result <> 0 then

  begin

    TextOnly := Message.WParam <> 0;

    PRect(Message.LParam)^ := GetDisplayRect(Node, -1, TextOnly);

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.TVMGetNextItem(var Message: TMessage);



// Screen read support function. This method returns a node depending on the requested case.



var

  Node: PVirtualNode;



begin

  // Start with a nil result.

  Message.Result := 0;

  Node := Pointer(Message.LParam);

  case Message.WParam of

    TVGN_CARET:

      Message.Result := LRESULT(FFocusedNode);

    TVGN_CHILD:

      if Assigned(Node) then

        Message.Result := LRESULT(GetFirstChild(Node));

    TVGN_DROPHILITE:

      Message.Result := LRESULT(FDropTargetNode);

    TVGN_FIRSTVISIBLE:

      Message.Result := LRESULT(GetFirstVisible(nil, True));

    TVGN_LASTVISIBLE:

      Message.Result := LRESULT(GetLastVisible(nil, True));

    TVGN_NEXT:

      if Assigned(Node) then

        Message.Result := LRESULT(GetNextSibling(Node));

    TVGN_NEXTVISIBLE:

      if Assigned(Node) then

        Message.Result := LRESULT(GetNextVisible(Node, True));

    TVGN_PARENT:

      if Assigned(Node) and (Node <> FRoot) and (Node.Parent <> FRoot) then

        Message.Result := LRESULT(Node.Parent);

    TVGN_PREVIOUS:

      if Assigned(Node) then

        Message.Result := LRESULT(GetPreviousSibling(Node));

    TVGN_PREVIOUSVISIBLE:

      if Assigned(Node) then

        Message.Result := LRESULT(GetPreviousVisible(Node, True));

    TVGN_ROOT:

      Message.Result := LRESULT(GetFirst);

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.WMCancelMode(var Message: TWMCancelMode);



begin

  // Clear any transient state.

  StopTimer(ExpandTimer);

  StopTimer(EditTimer);

  StopTimer(HeaderTimer);

  StopTimer(ScrollTimer);

  StopTimer(SearchTimer);

  StopTimer(ThemeChangedTimer);

  FSearchBuffer := '';

  FLastSearchNode := nil;



  DoStateChange([], [tsClearPending, tsEditPending, tsOLEDragPending, tsVCLDragPending, tsDrawSelecting,

    tsDrawSelPending, tsIncrementalSearching]);



  inherited;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.WMChangeState(var Message: TMessage);



var

  EnterStates,

  LeaveStates: TVirtualTreeStates;



begin

  EnterStates := [];

  if csStopValidation in TChangeStates(Byte(Message.WParam)) then

    Include(EnterStates, tsStopValidation);

  if csUseCache in TChangeStates(Byte(Message.WParam)) then

    Include(EnterStates, tsUseCache);

  if csValidating in TChangeStates(Byte(Message.WParam)) then

    Include(EnterStates, tsValidating);

  if csValidationNeeded in TChangeStates(Byte(Message.WParam)) then

    Include(EnterStates, tsValidationNeeded);



  LeaveStates := [];

  if csStopValidation in TChangeStates(Byte(Message.LParam)) then

    Include(LeaveStates, tsStopValidation);

  if csUseCache in TChangeStates(Byte(Message.LParam)) then

    Include(LeaveStates, tsUseCache);

  if csValidating in TChangeStates(Byte(Message.LParam)) then

    Include(LeaveStates, tsValidating);

  if csValidationNeeded in TChangeStates(Byte(Message.LParam)) then

    Include(LeaveStates, tsValidationNeeded);



  DoStateChange(EnterStates, LeaveStates);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.WMChar(var Message: TWMChar);



begin

  if tsIncrementalSearchPending in FStates then

  begin

    HandleIncrementalSearch(Message.CharCode);

    DoStateChange([], [tsIncrementalSearchPending]);

  end;



  inherited;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.WMContextMenu(var Message: TWMContextMenu);



// This method is called when a popup menu is about to be displayed.

// We have to cancel some pending states here to avoid interferences.



begin

  DoStateChange([], [tsClearPending, tsEditPending, tsOLEDragPending, tsVCLDragPending]);



  if not (tsPopupMenuShown in FStates) then

    inherited;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.WMCopy(var Message: TWMCopy);



begin

  CopyToClipboard;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.WMCut(var Message: TWMCut);



begin

  CutToClipboard;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.WMEnable(var Message: TWMEnable);



begin

  inherited;

  RedrawWindow(Handle, nil, 0, RDW_FRAME or RDW_INVALIDATE or RDW_NOERASE or RDW_NOCHILDREN);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.WMEraseBkgnd(var Message: TWMEraseBkgnd);



begin

  Message.Result := 1;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.WMGetDlgCode(var Message: TWMGetDlgCode);



begin

  Message.Result := DLGC_WANTCHARS or DLGC_WANTARROWS;

  if FWantTabs then

    Message.Result := Message.Result or DLGC_WANTTAB;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.WMGetObject(var Message: TMessage);



begin

  if GetAccessibilityFactory <> nil then

  begin

    // Create the IAccessibles for the tree view and tree view items, if necessary.

    if FAccessible = nil then

      FAccessible := GetAccessibilityFactory.CreateIAccessible(Self);

    if FAccessibleItem = nil then

      FAccessibleItem := GetAccessibilityFactory.CreateIAccessible(Self);

    if Cardinal(Message.LParam) = OBJID_CLIENT then

      {$if CompilerVersion >= 18}

      if Assigned(Accessible) then

        Message.Result := LresultFromObject(IID_IAccessible, Message.WParam, FAccessible)

      else

      {$ifend}

        Message.Result := 0;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.WMHScroll(var Message: TWMHScroll);



  //--------------- local functions -------------------------------------------



  function GetRealScrollPosition: Integer;



  var

    SI: TScrollInfo;

    Code: Integer;



  begin

    SI.cbSize := SizeOf(TScrollInfo);

    SI.fMask := SIF_TRACKPOS;

    Code := SB_HORZ;

    GetScrollInfo(Handle, Code, SI);

    Result := SI.nTrackPos;

  end;



  //--------------- end local functions ---------------------------------------



var

  RTLFactor: Integer;



begin

  if UseRightToLeftAlignment then

    RTLFactor := -1

  else

    RTLFactor := 1;



  case Message.ScrollCode of

    SB_BOTTOM:

      SetOffsetX(-Integer(FRangeX));

    SB_ENDSCROLL:

      begin

        DoStateChange([], [tsThumbTracking]);

        // avoiding to adjust the vertical scroll position while tracking makes it much smoother

        // but we need to adjust the final position here then

        UpdateHorizontalScrollBar(False);

      end;

    SB_LINELEFT:

      SetOffsetX(FOffsetX + RTLFactor * FScrollBarOptions.FIncrementX);

    SB_LINERIGHT:

      SetOffsetX(FOffsetX - RTLFactor * FScrollBarOptions.FIncrementX);

    SB_PAGELEFT:

      SetOffsetX(FOffsetX + RTLFactor * (ClientWidth - FHeader.Columns.GetVisibleFixedWidth));

    SB_PAGERIGHT:

      SetOffsetX(FOffsetX - RTLFactor * (ClientWidth - FHeader.Columns.GetVisibleFixedWidth));

    SB_THUMBPOSITION,

    SB_THUMBTRACK:

      begin

        DoStateChange([tsThumbTracking]);

        if UseRightToLeftAlignment then

          SetOffsetX(-Integer(FRangeX) + ClientWidth + GetRealScrollPosition)

        else

          SetOffsetX(-GetRealScrollPosition);

      end;

    SB_TOP:

      SetOffsetX(0);

  end;



  Message.Result := 0;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.WMKeyDown(var Message: TWMKeyDown);



// Keyboard event handling for node focus, selection, node specific popup menus and help invokation.

// For a detailed description of every action done here read the help.



var

  Shift: TShiftState;

  Node, Temp,

  LastFocused: PVirtualNode;

  Offset: Integer;

  ClearPending,

  NeedInvalidate,

  DoRangeSelect,

  HandleMultiSelect: Boolean;

  Context: Integer;

  ParentControl: TWinControl;

  R: TRect;

  NewCheckState: TCheckState;

  TempColumn,

  NewColumn: TColumnIndex;

  ActAsGrid: Boolean;

  ForceSelection: Boolean;

  NewWidth,

  NewHeight: Integer;

  RTLFactor: Integer;



  // for tabulator handling

  GetStartColumn: function(ConsiderAllowFocus: Boolean = False): TColumnIndex of object;

  GetNextColumn: function(Column: TColumnIndex; ConsiderAllowFocus: Boolean = False): TColumnIndex of object;

  GetNextNode: TGetNextNodeProc;



  KeyState: TKeyboardState;

  Buffer: array[0..1] of AnsiChar;



begin

  // Make form key preview work and let application modify the key if it wants this.

  inherited;



  with Message do

  begin

    Shift := KeyDataToShiftState(KeyData);

    // Ask the application if the default key handling is desired.

    if DoKeyAction(CharCode, Shift) then

    begin

      if (tsKeyCheckPending in FStates) and (CharCode <> VK_SPACE) then

      begin

        DoStateChange([], [tskeyCheckPending]);

        FCheckNode.CheckState := UnpressedState[FCheckNode.CheckState];

        RepaintNode(FCheckNode);

        FCheckNode := nil;

      end;



      if (CharCode in [VK_HOME, VK_END, VK_PRIOR, VK_NEXT, VK_UP, VK_DOWN, VK_LEFT, VK_RIGHT, VK_BACK, VK_TAB]) and (RootNode.FirstChild <> nil) then

      begin

        HandleMultiSelect := (ssShift in Shift) and (toMultiSelect in FOptions.FSelectionOptions) and not IsEditing;



        // Flag to avoid range selection in case of single node advance.

        DoRangeSelect := (CharCode in [VK_HOME, VK_END, VK_PRIOR, VK_NEXT]) and HandleMultiSelect and not IsEditing;



        NeedInvalidate := DoRangeSelect or (FSelectionCount > 1);

        ActAsGrid := toGridExtensions in FOptions.FMiscOptions;

        ClearPending := (Shift = []) or (ActAsGrid and not (ssShift in Shift)) or

          not (toMultiSelect in FOptions.FSelectionOptions) or (CharCode in [VK_TAB, VK_BACK]);



        // Keep old focused node for range selection. Use a default node if none was focused until now.

        LastFocused := FFocusedNode;

        if (LastFocused = nil) and (Shift <> []) then

          LastFocused := GetFirstVisible(nil, True);



        // Set an initial range anchor if there is not yet one.

        if FRangeAnchor = nil then

          FRangeAnchor := GetFirstSelected;

        if FRangeAnchor = nil then

          FRangeAnchor := GetFirst;



        if UseRightToLeftAlignment then

          RTLFactor := -1

        else

          RTLFactor := 1;



        // Determine new focused node.

        case CharCode of

          VK_HOME, VK_END:

            begin

              if (CharCode = VK_END) xor UseRightToLeftAlignment then

              begin

                GetStartColumn := FHeader.FColumns.GetLastVisibleColumn;

                GetNextColumn := FHeader.FColumns.GetPreviousVisibleColumn;

                GetNextNode := GetPreviousVisible;

                Node := GetLastVisible(nil, True);

              end

              else

              begin

                GetStartColumn := FHeader.FColumns.GetFirstVisibleColumn;

                GetNextColumn := FHeader.FColumns.GetNextVisibleColumn;

                GetNextNode := GetNextVisible;

                Node := GetFirstVisible(nil, True);

              end;



              // Advance to next/previous visible column.

              if FHeader.UseColumns then

                NewColumn := GetStartColumn

              else

                NewColumn := NoColumn;

              // Find a column for the new/current node which can be focused.

              // Make the 'DoFocusChanging' for finding a valid column

              // identifiable from the 'DoFocusChanging' raised later on by

              // "FocusedNode := Node;"

              while (NewColumn > NoColumn) and not DoFocusChanging(FFocusedNode, FFocusedNode, FFocusedColumn, NewColumn) do

                NewColumn := GetNextColumn(NewColumn);

              if NewColumn > InvalidColumn then

              begin

                if (Shift = [ssCtrl]) and not ActAsGrid then

                begin

                  ScrollIntoView(Node, toCenterScrollIntoView in FOptions.SelectionOptions,

                    not (toDisableAutoscrollOnFocus in FOptions.FAutoOptions));

                  if (CharCode = VK_HOME) and not UseRightToLeftAlignment then

                    SetOffsetX(0)

                  else

                    SetOffsetX(-MaxInt);

                end

                else

                begin

                  if not ActAsGrid or (ssCtrl in Shift) then

                    FocusedNode := Node;

                  if ActAsGrid and not (toFullRowSelect in FOptions.FSelectionOptions) then

                    FocusedColumn := NewColumn;

                end;

              end;

            end;

          VK_PRIOR:

            if Shift = [ssCtrl, ssShift] then

              SetOffsetX(FOffsetX + ClientWidth)

            else

              if [ssShift, ssAlt] = Shift then

              begin

                if FFocusedColumn <= NoColumn then

                  NewColumn := FHeader.FColumns.GetFirstVisibleColumn

                else

                begin

                  Offset := FHeader.FColumns.GetVisibleFixedWidth;

                  NewColumn := FFocusedColumn;

                  while True do

                  begin

                    TempColumn := FHeader.FColumns.GetPreviousVisibleColumn(NewColumn);

                    NewWidth := FHeader.FColumns[NewColumn].Width;

                    if (TempColumn <= NoColumn) or

                       (Offset + NewWidth >= ClientWidth) or

                       (coFixed in FHeader.FColumns[TempColumn].FOptions) then

                      Break;

                    NewColumn := TempColumn;

                    Inc(Offset, NewWidth);

                  end;

                end;

                SetFocusedColumn(NewColumn);

              end

              else

                if ssCtrl in Shift then

                  SetOffsetY(FOffsetY + ClientHeight)

                else

                begin

                  Offset := 0;

                  // If there's no focused node then just take the very first visible one.

                  if FFocusedNode = nil then

                    Node := GetFirstVisible(nil, True)

                  else

                  begin

                    // Go up as many nodes as comprise together a size of ClientHeight.

                    Node := FFocusedNode;

                    while True do

                    begin

                      Temp := GetPreviousVisible(Node, True);

                      NewHeight := NodeHeight[Node];

                      if (Temp = nil) or (Offset + NewHeight >= ClientHeight) then

                        Break;

                      Node := Temp;

                      Inc(Offset, NodeHeight[Node]);

                    end;

                  end;

                  FocusedNode := Node;

                end;

          VK_NEXT:

            if Shift = [ssCtrl, ssShift] then

              SetOffsetX(FOffsetX - ClientWidth)

            else

              if [ssShift, ssAlt] = Shift then

              begin

                if FFocusedColumn <= NoColumn then

                  NewColumn := FHeader.FColumns.GetFirstVisibleColumn

                else

                begin

                  Offset := FHeader.FColumns.GetVisibleFixedWidth;

                  NewColumn := FFocusedColumn;

                  while True do

                  begin

                    TempColumn := FHeader.FColumns.GetNextVisibleColumn(NewColumn);

                    NewWidth := FHeader.FColumns[NewColumn].Width;

                    if (TempColumn <= NoColumn) or

                       (Offset + NewWidth >= ClientWidth) or

                       (coFixed in FHeader.FColumns[TempColumn].FOptions) then

                      Break;

                    NewColumn := TempColumn;

                    Inc(Offset, NewWidth);

                  end;

                end;

                SetFocusedColumn(NewColumn);

              end

              else

                if ssCtrl in Shift then

                  SetOffsetY(FOffsetY - ClientHeight)

                else

                begin

                  Offset := 0;

                  // If there's no focused node then just take the very last one.

                  if FFocusedNode = nil then

                    Node := GetLastVisible(nil, True)

                  else

                  begin

                    // Go up as many nodes as comprise together a size of ClientHeight.

                    Node := FFocusedNode;

                    while True do

                    begin

                      Temp := GetNextVisible(Node, True);

                      NewHeight := NodeHeight[Node];

                      if (Temp = nil) or (Offset + NewHeight >= ClientHeight) then

                        Break;

                      Node := Temp;

                      Inc(Offset, NewHeight);

                    end;

                  end;

                  FocusedNode := Node;

                end;

          VK_UP:

            begin

              // scrolling without selection change

              if ssCtrl in Shift then

                SetOffsetY(FOffsetY + Integer(FDefaultNodeHeight))

              else

              begin

                if FFocusedNode = nil then

                  Node := GetLastVisible(nil, True)

                else

                  Node := GetPreviousVisible(FFocusedNode, True);



                if Assigned(Node) then

                begin

                  EndEditNode;

                  if HandleMultiSelect and (CompareNodePositions(LastFocused, FRangeAnchor) > 0) and

                    Assigned(FFocusedNode) then

                    RemoveFromSelection(FFocusedNode);

                  if FFocusedColumn <= NoColumn then

                    FFocusedColumn := FHeader.MainColumn;

                  FocusedNode := Node;

                end

                else

                  if Assigned(FFocusedNode) then

                    InvalidateNode(FFocusedNode);

              end;

            end;

          VK_DOWN:

            begin

              // scrolling without selection change

              if ssCtrl in Shift then

                SetOffsetY(FOffsetY - Integer(FDefaultNodeHeight))

              else

              begin

                if FFocusedNode = nil then

                  Node := GetFirstVisible(nil, True)

                else

                  Node := GetNextVisible(FFocusedNode, True);



                if Assigned(Node) then

                begin

                  EndEditNode;

                  if HandleMultiSelect and (CompareNodePositions(LastFocused, FRangeAnchor) < 0) and

                    Assigned(FFocusedNode) then

                    RemoveFromSelection(FFocusedNode);

                  if FFocusedColumn <= NoColumn then

                    FFocusedColumn := FHeader.MainColumn;

                  FocusedNode := Node;

                end

                else

                  if Assigned(FFocusedNode) then

                    InvalidateNode(FFocusedNode);

              end;

            end;

          VK_LEFT:

            begin

              // special handling

              if ssCtrl in Shift then

                SetOffsetX(FOffsetX + RTLFactor * FHeader.Columns.GetScrollWidth)

              else

              begin

                // other special cases

                Context := NoColumn;

                if (toExtendedFocus in FOptions.FSelectionOptions) and (toGridExtensions in FOptions.FMiscOptions) then

                begin

                  Context := FHeader.Columns.GetPreviousVisibleColumn(FFocusedColumn, True);

                  if Context > -1 then

                    FocusedColumn := Context;

                end

                else

                  if Assigned(FFocusedNode) and (vsExpanded in FFocusedNode.States) and

                     (Shift = []) and (vsHasChildren in FFocusedNode.States) then

                    ToggleNode(FFocusedNode)

                  else

                  begin

                    if FFocusedNode = nil then

                      FocusedNode := GetFirstVisible(nil, True)

                    else

                    begin

                      if FFocusedNode.Parent <> FRoot then

                        Node := FFocusedNode.Parent

                      else

                        Node := nil;

                      if Assigned(Node) then

                      begin

                        if HandleMultiSelect then

                        begin

                          // and a third special case

                          if FFocusedNode.Index > 0 then

                            DoRangeSelect := True

                          else

                           if CompareNodePositions(Node, FRangeAnchor) > 0 then

                             RemoveFromSelection(FFocusedNode);

                        end;

                        FocusedNode := Node;

                      end;

                    end;

                  end;

              end;

            end;

          VK_RIGHT:

            begin

              // special handling

              if ssCtrl in Shift then

                SetOffsetX(FOffsetX - RTLFactor * FHeader.Columns.GetScrollWidth)

              else

              begin

                // other special cases

                Context := NoColumn;

                if (toExtendedFocus in FOptions.FSelectionOptions) and (toGridExtensions in FOptions.FMiscOptions) then

                begin

                  Context := FHeader.Columns.GetNextVisibleColumn(FFocusedColumn, True);

                  if Context > -1 then

                    FocusedColumn := Context;

                end

                else

                  if Assigned(FFocusedNode) and not (vsExpanded in FFocusedNode.States) and

                     (Shift = []) and (vsHasChildren in FFocusedNode.States) then

                    ToggleNode(FFocusedNode)

                  else

                  begin

                    if FFocusedNode = nil then

                      FocusedNode := GetFirstVisible(nil, True)

                    else

                    begin

                      Node := GetFirstVisibleChild(FFocusedNode);

                      if Assigned(Node) then

                      begin

                        if HandleMultiSelect and (CompareNodePositions(Node, FRangeAnchor) < 0) then

                          RemoveFromSelection(FFocusedNode);

                        FocusedNode := Node;

                      end;

                    end;

                  end;

              end;

            end;

          VK_BACK:

            if tsIncrementalSearching in FStates then

              DoStateChange([tsIncrementalSearchPending])

            else

              if Assigned(FFocusedNode) and (FFocusedNode.Parent <> FRoot) then

                FocusedNode := FocusedNode.Parent;

          VK_TAB:

            if (toExtendedFocus in FOptions.FSelectionOptions) and FHeader.UseColumns then

            begin

              // In order to avoid duplicating source code just to change the direction

              // we use function variables.

              if ssShift in Shift then

              begin

                GetStartColumn := FHeader.FColumns.GetLastVisibleColumn;

                GetNextColumn := FHeader.FColumns.GetPreviousVisibleColumn;

                GetNextNode := GetPreviousVisible;

              end

              else

              begin

                GetStartColumn := FHeader.FColumns.GetFirstVisibleColumn;

                GetNextColumn := FHeader.FColumns.GetNextVisibleColumn;

                GetNextNode := GetNextVisible;

              end;



              // Advance to next/previous visible column/node.

              Node := FFocusedNode;

              NewColumn := GetNextColumn(FFocusedColumn, True);

              repeat

                // Find a column for the current node which can be focused.

                while (NewColumn > NoColumn) and not DoFocusChanging(FFocusedNode, Node, FFocusedColumn, NewColumn) do

                  NewColumn := GetNextColumn(NewColumn, True);



                if NewColumn > NoColumn then

                begin

                  // Set new node and column in one go.

                  SetFocusedNodeAndColumn(Node, NewColumn);

                  Break;

                end;



                // No next column was accepted for the current node. So advance to next node and try again.

                Node := GetNextNode(Node);

                NewColumn := GetStartColumn;

              until Node = nil;

            end;

        end;



        // Clear old selection if required but take care to select the new focused node if it was not selected before.

        ForceSelection := False;

        if ClearPending and ((LastFocused <> FFocusedNode) or (FSelectionCount <> 1)) then

        begin

          ClearSelection;

          ForceSelection := True;

        end;



        // Determine new selection anchor.

        if Shift = [] then

        begin

          FRangeAnchor := FFocusedNode;

          FLastSelectionLevel := GetNodeLevel(FFocusedNode);

        end;



        if Assigned(FFocusedNode) then

        begin

          // Finally change the selection for a specific range of nodes.

          if DoRangeSelect then

            ToggleSelection(LastFocused, FFocusedNode);



          // Make sure the new focused node is also selected.

          if (LastFocused <> FFocusedNode) or ForceSelection then

            AddToSelection(FFocusedNode);

        end;



        // If a repaint is needed then paint the entire tree because of the ClearSelection call,

        if NeedInvalidate then

          Invalidate;

      end

      else

      begin

        // Second chance for keys not directly concerned with selection changes.



        // For +, -, /, * keys on the main keyboard (not numpad) there is no virtual key code defined.

        // We have to do special processing to get them working too.

        GetKeyboardState(KeyState);

        // Avoid conversion to control characters. We have captured the control key state already in Shift.

        KeyState[VK_CONTROL] := 0;

        if ToASCII(Message.CharCode, (Message.KeyData shr 16) and 7, KeyState, PChar(@Buffer), 0) > 0 then

        begin

          case Buffer[0] of

            '*':

              CharCode := VK_MULTIPLY;

            '+':

              CharCode := VK_ADD;

            '/':

              CharCode := VK_DIVIDE;

            '-':

              CharCode := VK_SUBTRACT;

          end;

        end;



        // According to https://web.archive.org/web/20041129085958/http://www.it-faq.pl/mskb/99/337.HTM

        // there is a problem with ToASCII when used in conjunction with dead chars.

        // The article recommends to call ToASCII twice to restore a deleted flag in the key message

        // structure under certain circumstances. It turned out it is best to always call ToASCII twice.

        ToASCII(Message.CharCode, (Message.KeyData shr 16) and 7, KeyState, PChar(@Buffer), 0);



        case CharCode of

          VK_F2:

            if (Shift = []) and Assigned(FFocusedNode) and CanEdit(FFocusedNode, FFocusedColumn) then

            begin

              FEditColumn := FFocusedColumn;

              DoEdit;

            end;

          VK_ADD:

            if not (tsIncrementalSearching in FStates) then

            begin

              if ssCtrl in Shift then

                if not (toReverseFullExpandHotKey in TreeOptions.MiscOptions) and (ssShift in Shift) then

                  FullExpand

                else

                  FHeader.AutoFitColumns

              else

                if Assigned(FFocusedNode) and not (vsExpanded in FFocusedNode.States) then

                  ToggleNode(FFocusedNode);

            end

            else

              DoStateChange([tsIncrementalSearchPending]);

          VK_SUBTRACT:

            if not (tsIncrementalSearching in FStates) then

            begin

              if ssCtrl in Shift then

                if not (toReverseFullExpandHotKey in TreeOptions.MiscOptions) and (ssShift in Shift) then

                  FullCollapse

                else

                  FHeader.RestoreColumns

              else

                if Assigned(FFocusedNode) and (vsExpanded in FFocusedNode.States) then

                  ToggleNode(FFocusedNode);

            end

            else

              DoStateChange([tsIncrementalSearchPending]);

          VK_MULTIPLY:

            if not (tsIncrementalSearching in FStates) then

            begin

              if Assigned(FFocusedNode) then

                FullExpand(FFocusedNode);

            end

            else

              DoStateChange([tsIncrementalSearchPending]);

          VK_DIVIDE:

            if not (tsIncrementalSearching in FStates) then

            begin

              if Assigned(FFocusedNode) then

                FullCollapse(FFocusedNode);

            end

            else

              DoStateChange([tsIncrementalSearchPending]);

          VK_ESCAPE: // cancel actions currently in progress

            begin

              if IsMouseSelecting then

              begin

                DoStateChange([], [tsDrawSelecting, tsDrawSelPending]);

                Invalidate;

              end

              else

                if IsEditing then

                  CancelEditNode;

            end;

          VK_SPACE:

            if (toCheckSupport in FOptions.FMiscOptions) and Assigned(FFocusedNode) and

              (FFocusedNode.CheckType <> ctNone) then

            begin

              if (FStates * [tsKeyCheckPending, tsMouseCheckPending] = []) and

                not (vsDisabled in FFocusedNode.States) then

              begin

                with FFocusedNode^ do

                  NewCheckState := DetermineNextCheckState(CheckType, CheckState);

                if DoChecking(FFocusedNode, NewCheckState) then

                begin

                  DoStateChange([tsKeyCheckPending]);

                  FCheckNode := FFocusedNode;

                  FPendingCheckState := NewCheckState;

                  FCheckNode.CheckState := PressedState[FCheckNode.CheckState];

                  RepaintNode(FCheckNode);

                end;

              end;

            end

            else

              DoStateChange([tsIncrementalSearchPending]);

          VK_F1:

            if Assigned(FOnGetHelpContext) then

            begin

              Context := 0;

              if Assigned(FFocusedNode) then

              begin

                Node := FFocusedNode;

                // Traverse the tree structure up to the root.

                repeat

                  FOnGetHelpContext(Self, Node, IfThen(FFocusedColumn > NoColumn, FFocusedColumn, 0), Context);

                  Node := Node.Parent;

                until (Node = FRoot) or (Context <> 0);

              end;



              // If no help context could be found try the tree's one or its parent's contexts.

              ParentControl := Self;

              while Assigned(ParentControl) and (Context = 0) do

              begin

                Context := ParentControl.HelpContext;

                ParentControl := ParentControl.Parent;

              end;

              if Context <> 0 then

                Application.HelpContext(Context);

            end;

          VK_APPS:

            if Assigned(FFocusedNode) then

            begin

              R := GetDisplayRect(FFocusedNode, FFocusedColumn, True);

              Offset := DoGetNodeWidth(FFocusedNode, FFocusedColumn);

              if FFocusedColumn >= 0 then

              begin

                if Offset > FHeader.Columns[FFocusedColumn].Width then

                  Offset := FHeader.Columns[FFocusedColumn].Width;

              end

              else

              begin

                if Offset > ClientWidth then

                  Offset := ClientWidth;

              end;

              DoPopupMenu(FFocusedNode, FFocusedColumn, Point(R.Left + Offset div 2, (R.Top + R.Bottom) div 2));

            end

            else

              DoPopupMenu(nil, FFocusedColumn, Point(-1, -1));

          Ord('a'), Ord('A'):

            if ssCtrl in Shift then

              SelectAll(True)

            else

              DoStateChange([tsIncrementalSearchPending]);

        else

        begin

          // Use the key for incremental search.

          // Since we are dealing with Unicode all the time there should be a more sophisticated way

          // of checking for valid characters for incremental search.

          // This is available but would require to include a significant amount of Unicode character

          // properties, so we stick with the simple space check.

          if ((Shift * [ssCtrl, ssAlt] = []) or ((Shift * [ssCtrl, ssAlt] = [ssCtrl, ssAlt]))) and (CharCode >= 32) then

            DoStateChange([tsIncrementalSearchPending]);

          end;

        end;

      end;

    end;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.WMKeyUp(var Message: TWMKeyUp);



begin

  inherited;



  case Message.CharCode of

    VK_SPACE:

      if tsKeyCheckPending in FStates then

      begin

        DoStateChange([], [tskeyCheckPending]);

        if FCheckNode = FFocusedNode then

          DoCheckClick(FCheckNode, FPendingCheckState);

        InvalidateNode(FCheckNode);

        FCheckNode := nil;

      end;

     VK_TAB:

       EnsureNodeFocused(); // Always select a node if the control gets the focus via TAB key, #237

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.WMKillFocus(var Msg: TWMKillFocus);



var

  Form: TCustomForm;

  Control: TWinControl;

  Pos: TSmallPoint;

  Unknown: IUnknown;



begin

  inherited;



  // Remove hint if shown currently.

  if tsHint in Self.FStates then

    Application.CancelHint;



  // Stop wheel panning if active.

  StopWheelPanning;



  // Don't let any timer continue if the tree is no longer the active control (except change timers).

  StopTimer(ExpandTimer);

  StopTimer(EditTimer);

  StopTimer(HeaderTimer);

  StopTimer(ScrollTimer);

  StopTimer(SearchTimer);

  FSearchBuffer := '';

  FLastSearchNode := nil;



  DoStateChange([], [tsScrollPending, tsScrolling, tsEditPending, tsLeftButtonDown, tsRightButtonDown,

    tsMiddleButtonDown, tsOLEDragPending, tsVCLDragPending, tsIncrementalSearching, tsNodeHeightTrackPending,

    tsNodeHeightTracking]);



  if (FSelectionCount > 0) or not (toGhostedIfUnfocused in FOptions.FPaintOptions) then

    Invalidate

  else

    if Assigned(FFocusedNode) then

      InvalidateNode(FFocusedNode);



  // Workaround for wrapped non-VCL controls (like TWebBrowser), which do not use VCL mechanisms and

  // leave the ActiveControl property in the wrong state, which causes trouble when the control is refocused.

  Form := GetParentForm(Self);

  if Assigned(Form) and (Form.ActiveControl = Self) then

  begin

    Cardinal(Pos) := GetMessagePos;

    Control := FindVCLWindow(SmallPointToPoint(Pos));

    // Every control derived from TOleControl has potentially the focus problem. In order to avoid including

    // the OleCtrls unit (which will, among others, include Variants), which would allow to test for the TOleControl

    // class, the IOleClientSite interface is used for the test, which is supported by TOleControl and a good indicator.

    if Assigned(Control) and Control.GetInterface(IOleClientSite, Unknown) then

      Form.ActiveControl := nil;



    // For other classes the active control should not be modified. Otherwise you need two clicks to select it.

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.WMLButtonDblClk(var Message: TWMLButtonDblClk);



var

  HitInfo: THitInfo;



begin

  DoStateChange([tsLeftDblClick]);

  inherited;



  // get information about the hit

  GetHitTestInfoAt(Message.XPos, Message.YPos, True, HitInfo);

  HandleMouseDblClick(Message, HitInfo);

  DoStateChange([], [tsLeftDblClick]);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.WMLButtonDown(var Message: TWMLButtonDown);



var

  HitInfo: THitInfo;



begin

  DoStateChange([tsLeftButtonDown]);

  inherited;



  // get information about the hit

  GetHitTestInfoAt(Message.XPos, Message.YPos, True, HitInfo);

  HandleMouseDown(Message, HitInfo);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.WMLButtonUp(var Message: TWMLButtonUp);



var

  HitInfo: THitInfo;



begin

  DoStateChange([], [tsLeftButtonDown, tsNodeHeightTracking, tsNodeHeightTrackPending]);



  // get information about the hit

  GetHitTestInfoAt(Message.XPos, Message.YPos, True, HitInfo);

  HandleMouseUp(Message, HitInfo);



  inherited;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.WMMButtonDblClk(var Message: TWMMButtonDblClk);



var

  HitInfo: THitInfo;



begin

  DoStateChange([tsMiddleDblClick]);

  inherited;



  // get information about the hit

  if toMiddleClickSelect in FOptions.FSelectionOptions then

  begin

    GetHitTestInfoAt(Message.XPos, Message.YPos, True, HitInfo);

    HandleMouseDblClick(Message, HitInfo);

  end;

  DoStateChange([], [tsMiddleDblClick]);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.WMMButtonDown(var Message: TWMMButtonDown);



var

  HitInfo: THitInfo;



begin

  DoStateChange([tsMiddleButtonDown]);



  if FHeader.FStates = [] then

  begin

    inherited;



    // Start wheel panning or scrolling if not already active, allowed and scrolling is useful at all.

    if (toWheelPanning in FOptions.FMiscOptions) and ([tsWheelScrolling, tsWheelPanning] * FStates = []) and

      ((Integer(FRangeX) > ClientWidth) or (Integer(FRangeY) > ClientHeight)) then

    begin

      FLastClickPos := SmallPointToPoint(Message.Pos);

      StartWheelPanning(FLastClickPos);

    end

    else

    begin

      StopWheelPanning;



      // Get information about the hit.

      if toMiddleClickSelect in FOptions.FSelectionOptions then

      begin

        GetHitTestInfoAt(Message.XPos, Message.YPos, True, HitInfo);

        HandleMouseDown(Message, HitInfo);

      end;

    end;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.WMMButtonUp(var Message: TWMMButtonUp);



var

  HitInfo: THitInfo;



begin

  DoStateChange([], [tsMiddleButtonDown]);



  // If wheel panning/scrolling is active and the mouse has not yet been moved then the user starts wheel auto scrolling.

  // Indicate this by removing the panning flag. Otherwise (the mouse has moved meanwhile) stop panning.

  if [tsWheelPanning, tsWheelScrolling] * FStates <> [] then

  begin

    if tsWheelScrolling in FStates then

      DoStateChange([], [tsWheelPanning])

    else

      StopWheelPanning;

  end

  else

    if FHeader.FStates = [] then

    begin

      inherited;



      // get information about the hit

      if toMiddleClickSelect in FOptions.FSelectionOptions then

      begin

        GetHitTestInfoAt(Message.XPos, Message.YPos, True, HitInfo);

        HandleMouseUp(Message, HitInfo);

      end;

    end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.WMNCCalcSize(var Message: TWMNCCalcSize);



begin

  inherited;



  with FHeader do

    if hoVisible in FHeader.FOptions then

      with Message.CalcSize_Params^ do

        Inc(rgrc[0].Top, FHeight);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.WMNCDestroy(var Message: TWMNCDestroy);



// Used to release a reference of the drag manager. This is the only reliable way we get notified about

// window destruction, because of the automatic release of a window if its parent window is freed.



begin

  InterruptValidation;



  StopTimer(ChangeTimer);

  StopTimer(StructureChangeTimer);



  if not (csDesigning in ComponentState) and (toAcceptOLEDrop in FOptions.FMiscOptions) then

    RevokeDragDrop(Handle);



  // Clean up other stuff.

  DeleteObject(FDottedBrush);

  FDottedBrush := 0;

  if tsInAnimation in FStates then

    FHintWindowDestroyed := True; // Stop any pending animation.



  inherited;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.WMNCHitTest(var Message: TWMNCHitTest);



begin

  inherited;

  if (hoVisible in FHeader.FOptions) and

    FHeader.InHeader(ScreenToClient(SmallPointToPoint(Message.Pos))) then

    Message.Result := HTBORDER;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.WMNCPaint(var Message: TRealWMNCPaint);



var

  DC: HDC;

  R: TRect;

  Flags: DWORD;

  ExStyle: Integer;

  TempRgn: HRGN;

  BorderWidth,

  BorderHeight: Integer;



begin

  if tsUseThemes in FStates then

  begin

    // If theming is enabled and the client edge border is set for the window then prevent the default window proc

    // from painting the old border to avoid flickering.

    ExStyle := GetWindowLong(Handle, GWL_EXSTYLE);

    if (ExStyle and WS_EX_CLIENTEDGE) <> 0 then

    begin

      GetWindowRect(Handle, R);

      // Determine width of the client edge.

      BorderWidth := GetSystemMetrics(SM_CXEDGE);

      BorderHeight := GetSystemMetrics(SM_CYEDGE);

      InflateRect(R, -BorderWidth, -BorderHeight);

      TempRgn := CreateRectRgnIndirect(R);

      // Exclude the border from the message region if there is one. Otherwise just use the inflated

      // window area region.

      if Message.Rgn <> 1 then

        CombineRgn(TempRgn, Message.Rgn, TempRgn, RGN_AND);

      DefWindowProc(Handle, Message.Msg, WPARAM(TempRgn), 0);

      DeleteObject(TempRgn);

    end

    else

      DefaultHandler(Message);

  end

  else

    DefaultHandler(Message);



  Flags := DCX_CACHE or DCX_CLIPSIBLINGS or DCX_WINDOW or DCX_VALIDATE;



  if (Message.Rgn = 1) then

    DC := GetDCEx(Handle, 0, Flags)

  else

    DC := GetDCEx(Handle, Message.Rgn, Flags or DCX_INTERSECTRGN);



  if DC <> 0 then

  begin

    if hoVisible in FHeader.FOptions then

    begin

      R := FHeaderRect;

      FHeader.FColumns.PaintHeader(DC, R, -FEffectiveOffsetX);

    end;

    OriginalWMNCPaint(DC);

    ReleaseDC(Handle, DC);

  end;

    if ((tsUseThemes in FStates) or VclStyleEnabled){$IF CompilerVersion >= 24} and (seBorder in StyleElements) {$IFEND} then

      StyleServices.PaintBorder(Self, False);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.WMPaint(var Message: TWMPaint);



begin

  if tsVCLDragging in FStates then

    ImageList_DragShowNolock(False);

  if csPaintCopy in ControlState then

    FUpdateRect := ClientRect

  else

    GetUpdateRect(Handle, FUpdateRect, True);



  inherited;



  if tsVCLDragging in FStates then

    ImageList_DragShowNolock(True);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.WMPaste(var Message: TWMPaste);



begin

  PasteFromClipboard;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.WMPrint(var Message: TWMPrint);



// This message is sent to request that the tree draws itself to a given device context. This includes not only

// the client area but also the non-client area (header!).



begin

  // Draw only if the window is visible or visibility is not required.

  if ((Message.Flags and PRF_CHECKVISIBLE) = 0) or IsWindowVisible(Handle) then

    Header.Columns.PaintHeader(Message.DC, FHeaderRect, -FEffectiveOffsetX);



  inherited;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.WMPrintClient(var Message: TWMPrintClient);



var

  Window: TRect;

  Target: TPoint;

  Canvas: TCanvas;



begin

  // Draw only if the window is visible or visibility is not required.

  if ((Message.Flags and PRF_CHECKVISIBLE) = 0) or IsWindowVisible(Handle) then

  begin

    // Determine area of the entire tree to be displayed in the control.

    Window := ClientRect;

    Target := Window.TopLeft;



    // The Window rectangle is given in client coordinates. We have to convert it into

    // a sliding window of the tree image.

    OffsetRect(Window, FEffectiveOffsetX, -FOffsetY);



    Canvas := TCanvas.Create;

    try

      Canvas.Handle := Message.DC;

      PaintTree(Canvas, Window, Target, [poBackground, poDrawFocusRect, poDrawDropMark, poDrawSelection, poGridLines]);

    finally

      Canvas.Handle := 0;

      Canvas.Free;

    end;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.WMRButtonDblClk(var Message: TWMRButtonDblClk);



var

  HitInfo: THitInfo;



begin

  DoStateChange([tsRightDblClick]);

  inherited;



  // get information about the hit

  if toMiddleClickSelect in FOptions.FSelectionOptions then

  begin

    GetHitTestInfoAt(Message.XPos, Message.YPos, True, HitInfo);

    HandleMouseDblClick(Message, HitInfo);

  end;

  DoStateChange([], [tsRightDblClick]);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.WMRButtonDown(var Message: TWMRButtonDown);



var

  HitInfo: THitInfo;



begin

  DoStateChange([tsRightButtonDown]);



  if FHeader.FStates = [] then

  begin

    inherited;



    // get information about the hit

    if toRightClickSelect in FOptions.FSelectionOptions then

    begin

      GetHitTestInfoAt(Message.XPos, Message.YPos, True, HitInfo);

      HandleMouseDown(Message, HitInfo);

    end;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.WMRButtonUp(var Message: TWMRButtonUp);



// handle right click selection and node specific popup menu



var

  HitInfo: THitInfo;



begin

  DoStateChange([], [tsPopupMenuShown, tsRightButtonDown]);



  if FHeader.FStates = [] then

  begin

    Application.CancelHint;



    if IsMouseSelecting and Assigned(PopupMenu) then

    begin

      // Reset selection state already here, before the inherited handler opens the default menu.

      DoStateChange([], [tsDrawSelecting, tsDrawSelPending]);

      Invalidate;

    end;



    inherited;



    // get information about the hit

    GetHitTestInfoAt(Message.XPos, Message.YPos, True, HitInfo);



    if toRightClickSelect in FOptions.FSelectionOptions then

      HandleMouseUp(Message, HitInfo);



    if not Assigned(PopupMenu) then

      DoPopupMenu(HitInfo.HitNode, HitInfo.HitColumn, Point(Message.XPos, Message.YPos));

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.WMSetCursor(var Message: TWMSetCursor);



// Sets the hot node mouse cursor for the tree. Cursor changes for the header are handled in Header.HandleMessage.



var

  NewCursor: TCursor;

  HitInfo: THitInfo;

  P: TPoint;

  Node: PVirtualNode;



begin

  with Message do

  begin

    // Feature: design-time header #415

    // Allow header to handle cursor and return control's default if it did nothing

    if (CursorWnd = Handle) and

      ([tsWheelPanning, tsWheelScrolling] * FStates = []) then

    begin

      if not FHeader.HandleMessage(TMessage(Message)) then

      begin

        // Apply own cursors only if there is no global cursor set.

        if Screen.Cursor = crDefault then

        begin

          // node resizing and hot tracking - for run-time only

          if not (csDesigning in ComponentState) then

          begin

            NewCursor := crDefault;

            if (toNodeHeightResize in FOptions.FMiscOptions) then

            begin

              GetCursorPos(P);

              P := ScreenToClient(P);

              GetHitTestInfoAt(P.X, P.Y, True, HitInfo);

              if (hiOnItem in HitInfo.HitPositions) and

                 ([hiUpperSplitter, hiLowerSplitter] * HitInfo.HitPositions <> []) then

              begin

                if hiUpperSplitter in HitInfo.HitPositions then

                  Node := GetPreviousVisible(HitInfo.HitNode, True)

                else

                  Node := HitInfo.HitNode;



                if CanSplitterResizeNode(P, Node, HitInfo.HitColumn) then

                  NewCursor := crVertSplit;

              end;

            end;



            if (NewCursor = crDefault) then

              if (toHotTrack in FOptions.PaintOptions) and Assigned(FCurrentHotNode) and (FHotCursor <> crDefault) then

                NewCursor := FHotCursor

              else

                NewCursor := Cursor;



            DoGetCursor(NewCursor);

          end

          else

            NewCursor := Cursor;

          Windows.SetCursor(Screen.Cursors[NewCursor]);

          Message.Result := 1;

        end

        else

          inherited;

      end;

    end

    else

      inherited;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.WMSetFocus(var Msg: TWMSetFocus);



begin

  inherited;

  if (FSelectionCount > 0) or not (toGhostedIfUnfocused in FOptions.FPaintOptions) then

    Invalidate;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.WMSize(var Message: TWMSize);



begin

  inherited;



  // Need to update scroll bars here. This will cause a recursion because of the change of the client area

  // when changing a scrollbar. Usually this is no problem since with the second level recursion no change of the

  // window size happens (the same values for the scrollbars are set, which shouldn't cause a window size change).

  // Appearently, this applies not to all systems, however.

  if HandleAllocated and ([tsSizing, tsWindowCreating] * FStates = []) and (ClientHeight > 0) then

  try

    DoStateChange([tsSizing]);

    // This call will invalidate the entire non-client area which needs recalculation on resize.

    FHeader.RescaleHeader;

    FHeader.UpdateSpringColumns;

    UpdateScrollBars(True);



    if (tsEditing in FStates) and not FHeader.UseColumns then

      UpdateEditBounds;

  finally

    DoStateChange([], [tsSizing]);

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.WMThemeChanged(var Message: TMessage);



begin

  inherited;



  if StyleServices.Enabled and (toThemeAware in TreeOptions.PaintOptions) then

    DoStateChange([tsUseThemes])

  else

    DoStateChange([], [tsUseThemes]);



  // Updating the visuals here will not work correctly. Therefore we postpone

  // the update by using a timer.

  if not FChangingTheme then

    SetTimer(Handle, ThemeChangedTimer, ThemeChangedTimerDelay, nil);

  FChangingTheme := False;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.WMTimer(var Message: TWMTimer);



// centralized timer handling happens here



begin

  with Message do

  begin

    case TimerID of

      ExpandTimer:

        DoDragExpand;

      EditTimer:

        DoEdit;

      ScrollTimer:

        begin

          if tsScrollPending in FStates then

          begin

            Application.CancelHint;

            // Scroll delay has elapsed, set to normal scroll interval now.

            SetTimer(Handle, ScrollTimer, FAutoScrollInterval, nil);

            DoStateChange([tsScrolling], [tsScrollPending]);

          end;

          DoTimerScroll;

        end;

      ChangeTimer:

        DoChange(FLastChangedNode);

      StructureChangeTimer:

        DoStructureChange(FLastStructureChangeNode, FLastStructureChangeReason);

      SearchTimer:

        begin

          // When this event triggers then the user did not pressed any key for the specified timeout period.

          // Hence incremental searching is stopped.

          DoStateChange([], [tsIncrementalSearching]);

          StopTimer(SearchTimer);

          FSearchBuffer := '';

          FLastSearchNode := nil;

        end;

      ThemeChangedTimer:

        begin

          StopTimer(ThemeChangedTimer);

          RecreateWnd;

        end;

    end;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.WMVScroll(var Message: TWMVScroll);



  //--------------- local functions -------------------------------------------



  function GetRealScrollPosition: Integer;



  var

    SI: TScrollInfo;

    Code: Integer;



  begin

    SI.cbSize := SizeOf(TScrollInfo);

    SI.fMask := SIF_TRACKPOS;

    Code := SB_VERT;

    GetScrollInfo(Handle, Code, SI);

    Result := SI.nTrackPos;

  end;



  //--------------- end local functions ---------------------------------------



begin

  case Message.ScrollCode of

    SB_BOTTOM:

      SetOffsetY(-Integer(FRoot.TotalHeight));

    SB_ENDSCROLL:

      begin

        DoStateChange([], [tsThumbTracking]);

        // Avoiding to adjust the horizontal scroll position while tracking makes scrolling much smoother

        // but we need to adjust the final position here then.

        UpdateScrollBars(True);

        // Really weird invalidation needed here (and I do it only because it happens so rarely), because

        // when showing the horizontal scrollbar while scrolling down using the down arrow button,

        // the button will be repainted on mouse up (at the wrong place in the far right lower corner)...

        RedrawWindow(Handle, nil, 0, RDW_FRAME or RDW_INVALIDATE or RDW_NOERASE or RDW_NOCHILDREN);

      end;

    SB_LINEUP:

      SetOffsetY(FOffsetY + FScrollBarOptions.FIncrementY);

    SB_LINEDOWN:

      SetOffsetY(FOffsetY - FScrollBarOptions.FIncrementY);

    SB_PAGEUP:

      SetOffsetY(FOffsetY + ClientHeight);

    SB_PAGEDOWN:

      SetOffsetY(FOffsetY - ClientHeight);



    SB_THUMBPOSITION,

    SB_THUMBTRACK:

      begin

        DoStateChange([tsThumbTracking]);

        SetOffsetY(-GetRealScrollPosition);

      end;

    SB_TOP:

      SetOffsetY(0);

  end;

  Message.Result := 0;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.AddToSelection(Node: PVirtualNode);



var

  Changed: Boolean;



begin

  if not FSelectionLocked then

  begin

    Assert(Assigned(Node), 'Node must not be nil!');

    FSingletonNodeArray[0] := Node;

    Changed := InternalAddToSelection(FSingletonNodeArray, 1, False);

    if Changed then

    begin

      InvalidateNode(Node);

      Change(Node);

    end;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.AddToSelection(const NewItems: TNodeArray; NewLength: Integer; ForceInsert: Boolean = False);



// Adds the given items all at once into the current selection array. NewLength is the amount of

// nodes to add (necessary to allow NewItems to be larger than the actual used entries).

// ForceInsert is True if nodes must be inserted without consideration of level select constraint or

// already set selected flags (e.g. when loading from stream).

// Note: In the case ForceInsert is True the caller is responsible for making sure the new nodes aren't already in the

//       selection array!



var

  Changed: Boolean;



begin

  Changed := InternalAddToSelection(NewItems, NewLength, ForceInsert);

  if Changed then

  begin

    if NewLength = 1 then

    begin

      InvalidateNode(NewItems[0]);

      Change(NewItems[0]);

    end

    else

    begin

      Invalidate;

      Change(nil);

    end;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.AdjustImageBorder(Images: TCustomImageList; BidiMode: TBidiMode; VAlign: Integer; var R: TRect;

  var ImageInfo: TVTImageInfo);



// Depending on the width of the image list as well as the given bidi mode R must be adjusted.



begin

  if BidiMode = bdLeftToRight then

  begin

    ImageInfo.XPos := R.Left;

    Inc(R.Left, Images.Width + 2);

  end

  else

  begin

    ImageInfo.XPos := R.Right - Images.Width;

    Dec(R.Right, Images.Width + 2);

  end;

  ImageInfo.YPos := R.Top + VAlign - Images.Height div 2;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.AdjustPaintCellRect(var PaintInfo: TVTPaintInfo; var NextNonEmpty: TColumnIndex);



// Used in descendants to modify the paint rectangle of the current column while painting a certain node.



begin

  // Since cells are always drawn from left to right the next column index is independent of the

  // bidi mode, but not the column borders, which might change depending on the cell's content.

  NextNonEmpty := FHeader.FColumns.GetNextVisibleColumn(PaintInfo.Column);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.AdjustPanningCursor(X, Y: Integer);



// Triggered by a mouse move when wheel panning/scrolling is active.

// Loads the proper cursor which indicates into which direction scrolling is done.



var

  Name: string;

  NewCursor: HCURSOR;

  ScrollHorizontal,

  ScrollVertical: Boolean;



begin

  ScrollHorizontal := Integer(FRangeX) > ClientWidth;

  ScrollVertical := Integer(FRangeY) > ClientHeight;



  if (Abs(X - FLastClickPos.X) < 8) and (Abs(Y - FLastClickPos.Y) < 8) then

  begin

    // Mouse is in the neutral zone.

    if ScrollHorizontal then

    begin

      if ScrollVertical then

        Name := 'VT_MOVEALL'

      else

        Name := 'VT_MOVEEW';

    end

    else

      Name := 'VT_MOVENS';

  end

  else

  begin

    // One of 8 directions applies: north, north-east, east, south-east, south, south-west, west and north-west.

    // Check also if scrolling in the particular direction is possible.

    if ScrollVertical and ScrollHorizontal then

    begin

      // All directions allowed.

      if X - FLastClickPos.X < -8 then

      begin

        // Left hand side.

        if Y - FLastClickPos.Y < -8 then

          Name := 'VT_MOVENW'

        else

          if Y - FLastClickPos.Y > 8 then

            Name := 'VT_MOVESW'

          else

            Name := 'VT_MOVEW';

      end

      else

        if X - FLastClickPos.X > 8 then

        begin

          // Right hand side.

          if Y - FLastClickPos.Y < -8 then

            Name := 'VT_MOVENE'

          else

            if Y - FLastClickPos.Y > 8 then

              Name := 'VT_MOVESE'

            else

              Name := 'VT_MOVEE';

        end

        else

        begin

          // Up or down.

          if Y < FLastClickPos.Y then

            Name := 'VT_MOVEN'

          else

            Name := 'VT_MOVES';

        end;

    end

    else

      if ScrollHorizontal then

      begin

        // Only horizontal movement allowed.

        if X < FLastClickPos.X then

          Name := 'VT_MOVEW'

        else

          Name := 'VT_MOVEE';

      end

      else

      begin

        // Only vertical movement allowed.

        if Y < FLastClickPos.Y then

          Name := 'VT_MOVEN'

        else

          Name := 'VT_MOVES';

      end;

  end;



  // Now load the cursor and apply it.

  NewCursor := LoadCursor(HInstance, PChar(Name));

  if FPanningCursor <> NewCursor then

  begin

    DeleteObject(FPanningCursor);

    FPanningCursor := NewCursor;

    Windows.SetCursor(FPanningCursor);

  end

  else

    DeleteObject(NewCursor);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.AdviseChangeEvent(StructureChange: Boolean; Node: PVirtualNode; Reason: TChangeReason);



// Used to register a delayed change event. If StructureChange is False then we have a selection change event (without

// a specific reason) otherwise it is a structure change.



begin

  if StructureChange then

  begin

    if tsStructureChangePending in FStates then

      StopTimer(StructureChangeTimer)

    else

      DoStateChange([tsStructureChangePending]);



    FLastStructureChangeNode := Node;

    if FLastStructureChangeReason = crIgnore then

      FLastStructureChangeReason := Reason

    else

      if Reason <> crIgnore then

        FLastStructureChangeReason := crAccumulated;

  end

  else

  begin

    if tsChangePending in FStates then

      StopTimer(ChangeTimer)

    else

      DoStateChange([tsChangePending]);



    FLastChangedNode := Node;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.AllocateInternalDataArea(Size: Cardinal): Cardinal;



// Simple registration method to be called by each descendant to claim their internal data area.

// Result is the offset from the begin of the node to the internal data area of the calling tree class.



begin

  Assert((FRoot = nil) or (FRoot.ChildCount = 0), 'Internal data allocation must be done before any node is created.');



  Result := TreeNodeSize + FTotalInternalDataSize;

  Inc(FTotalInternalDataSize, (Size + (SizeOf(Pointer) - 1)) and not (SizeOf(Pointer) - 1));

  InitRootNode(Result);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.Animate(Steps, Duration: Cardinal; Callback: TVTAnimationCallback; Data: Pointer);



// This method does the calculation part of an animation as used for node toggling and hint animations.

// Steps is the maximum amount of animation steps to do and Duration determines the milliseconds the animation

// has to run. Callback is a task specific method which is called in the loop for every step and Data is simply

// something to pass on to the callback.

// The callback is called with the current step, the current step size and the Data parameter. Since the step amount

// as well as the step size are possibly adjusted during the animation, it is impossible to determine if the current

// step is the last step, even if the original step amount is known. To solve this problem the callback will be

// called after the loop has finished with a step size of 0 indicating so to execute any post processing.



var

  StepSize,

  RemainingTime,

  RemainingSteps,

  NextTimeStep,

  CurrentStep,

  StartTime,

  CurrentTime: Cardinal;



begin

  if not (tsInAnimation in FStates) and (Duration > 0) then

  begin

    DoStateChange([tsInAnimation]);

    try

      RemainingTime := Duration;

      RemainingSteps := Steps;



      // Determine the initial step size which is either 1 if the needed steps are less than the number of

      // steps possible given by the duration or > 1 otherwise.

      StepSize := Round(Max(1, RemainingSteps / Duration));

      RemainingSteps := RemainingSteps div StepSize;

      CurrentStep := 0;



      while (RemainingSteps > 0) and (RemainingTime > 0) and not Application.Terminated do

      begin

        StartTime := timeGetTime;

        NextTimeStep := StartTime + RemainingTime div RemainingSteps;

        if not Callback(CurrentStep, StepSize, Data) then

          Break;



        // Keep duration for this step for rest calculation.

        CurrentTime := timeGetTime;

        // Wait until the calculated time has been reached.

        while CurrentTime < NextTimeStep do

          CurrentTime := timeGetTime;



        // Subtract the time this step really needed.

        if RemainingTime >= CurrentTime - StartTime then

        begin

          Dec(RemainingTime, CurrentTime - StartTime);

          Dec(RemainingSteps);

        end

        else

        begin

          RemainingTime := 0;

          RemainingSteps := 0;

        end;

        // If the remaining time per step is less than one time step then we have to decrease the

        // step count and increase the step size.

        if (RemainingSteps > 0) and ((RemainingTime div RemainingSteps) < 1) then

        begin

          repeat

            Inc(StepSize);

            RemainingSteps := RemainingTime div StepSize;

          until (RemainingSteps <= 0) or ((RemainingTime div RemainingSteps) >= 1);

        end;

        CurrentStep := Cardinal(Steps) - RemainingSteps;

      end;



      if not Application.Terminated then

        Callback(0, 0, Data);

    finally

      DoStateChange([], [tsCancelHintAnimation, tsInAnimation]);

    end;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.StartOperation(OperationKind: TVTOperationKind);



// Called to indicate that a long-running operation has been started.



begin

  Inc(FOperationCount);

  DoStartOperation(OperationKind);

  if FOperationCount = 1 then

    FOperationCanceled := False;

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.CalculateSelectionRect(X, Y: Integer): Boolean;



// Recalculates old and new selection rectangle given that X, Y are new mouse coordinates.

// Returns True if there was a change since the last call.



var

  MaxValue: Integer;



begin

  if tsDrawSelecting in FStates then

    FLastSelRect := FNewSelRect;

  FNewSelRect.BottomRight := Point(X + FEffectiveOffsetX, Y - FOffsetY);

  if FNewSelRect.Right < 0 then

    FNewSelRect.Right := 0;

  if FNewSelRect.Bottom < 0 then

    FNewSelRect.Bottom := 0;

  MaxValue := ClientWidth;

  if FRangeX > Cardinal(MaxValue) then

    MaxValue := FRangeX;

  if FNewSelRect.Right > MaxValue then

    FNewSelRect.Right := MaxValue;

  MaxValue := ClientHeight;

  if FRangeY > Cardinal(MaxValue) then

    MaxValue := FRangeY;

  if FNewSelRect.Bottom > MaxValue then

    FNewSelRect.Bottom := MaxValue;



  Result := not CompareMem(@FLastSelRect, @FNewSelRect, SizeOf(FNewSelRect));

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.CanAutoScroll: Boolean;



// Determines if auto scrolling is currently allowed.



var

  IsDropTarget: Boolean;

  IsDrawSelecting: Boolean;

  IsWheelPanning: Boolean;



begin

  // Don't scroll the client area if the header is currently doing tracking or dragging.

  // Do auto scroll only if there is a draw selection in progress or the tree is the current drop target or

  // wheel panning/scrolling is active.

  IsDropTarget := Assigned(FDragManager) and DragManager.IsDropTarget;

  IsDrawSelecting := [tsDrawSelPending, tsDrawSelecting] * FStates <> [];

  IsWheelPanning := [tsWheelPanning, tsWheelScrolling] * FStates <> [];

  Result := ((toAutoScroll in FOptions.FAutoOptions) or IsWheelPanning) and

    (FHeader.FStates = []) and (IsDrawSelecting or IsDropTarget or (tsVCLDragging in FStates) or IsWheelPanning);

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.CanShowDragImage: Boolean;



// Determines whether a drag image should be shown.



begin

  Result := FDragImageKind <> diNoImage;

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.CanSplitterResizeNode(P: TPoint; Node: PVirtualNode; Column: TColumnIndex): Boolean;



begin

  Result := (toNodeHeightResize in FOptions.FMiscOptions) and Assigned(Node) and (Node <> FRoot) and

            (Column > NoColumn) and (coFixed in FHeader.FColumns[Column].FOptions);

  DoCanSplitterResizeNode(P, Node, Column, Result);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.Change(Node: PVirtualNode);



begin

  AdviseChangeEvent(False, Node, crIgnore);



  if FUpdateCount = 0 then

  begin

    if (FChangeDelay > 0) and not (tsSynchMode in FStates) then

      SetTimer(Handle, ChangeTimer, FChangeDelay, nil)

    else

      DoChange(Node);

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.ChangeScale(M, D: Integer);



begin

  inherited;



  if (M <> D) and (toAutoChangeScale in FOptions.FAutoOptions) then

  begin

    SetDefaultNodeHeight(MulDiv(FDefaultNodeHeight, M, D));

    FHeader.ChangeScale(M, D);

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.ChangeTreeStatesAsync(EnterStates, LeaveStates: TChangeStates);



begin

  if (Self.HandleAllocated) then

    SendMessage(Self.Handle, WM_CHANGESTATE, Byte(EnterStates), Byte(LeaveStates));

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.CheckParentCheckState(Node: PVirtualNode; NewCheckState: TCheckState): Boolean;



// Checks all siblings of node to determine which check state Node's parent must get.



var

  CheckCount,

  BoxCount: Cardinal;

  PartialCheck: Boolean;

  Run: PVirtualNode;



begin

  CheckCount := 0;

  BoxCount := 0;

  PartialCheck := False;

  Run := Node.Parent.FirstChild;

  while Assigned(Run) do

  begin

    if Run = Node then

    begin

      // The given node cannot be checked because it does not yet have its new check state (as this depends

      // on the outcome of this method). Instead NewCheckState is used as this contains the new state the node

      // will get if this method returns True.

      if Run.CheckType in [ctCheckBox, ctTriStateCheckBox] then

      begin

        Inc(BoxCount);

        if NewCheckState in [csCheckedNormal, csCheckedPressed] then

          Inc(CheckCount);

        PartialCheck := PartialCheck or (NewCheckState = csMixedNormal);

      end;

    end

    else

      if Run.CheckType in [ctCheckBox, ctTriStateCheckBox] then

      begin

        Inc(BoxCount);

        if Run.CheckState in [csCheckedNormal, csCheckedPressed] then

          Inc(CheckCount);

        PartialCheck := PartialCheck or (Run.CheckState = csMixedNormal);

      end;

    Run := Run.NextSibling;

  end;



  if (CheckCount = 0) and not PartialCheck then

    NewCheckState := csUncheckedNormal

  else

    if CheckCount < BoxCount then

      NewCheckState := csMixedNormal

    else

      NewCheckState := csCheckedNormal;



  Node := Node.Parent;

  Result := DoChecking(Node, NewCheckState);

  if Result then

  begin

    DoCheckClick(Node, NewCheckState);

    // Recursively adjust parent of parent.

    // This is already done in the function DoCheckClick() called in the above line

    // We revent unnecessary upward recursion by commenting this code.

    //    with Node^ do

    //    begin

    //      if not (vsInitialized in Parent.States) then

    //        InitNode(Parent);

    //      if ([vsChecking, vsDisabled] * Parent.States = []) and (Parent <> FRoot) and

    //        (Parent.CheckType = ctTriStateCheckBox) then

    //        Result := CheckParentCheckState(Node, NewCheckState);

    //    end;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.ClearTempCache;



// make sure the temporary node cache is in a reliable state



begin

  FTempNodeCache := nil;

  FTempNodeCount := 0;

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.ColumnIsEmpty(Node: PVirtualNode; Column: TColumnIndex): Boolean;



// Returns True if the given column is to be considered as being empty. This will usually be determined by

// descendants as the base tree implementation has not enough information to decide.



begin

  Result := True;

  if Assigned(FOnGetCellIsEmpty) then

    FOnGetCellIsEmpty(Self, Node, Column, Result);

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.ComputeRTLOffset(ExcludeScrollBar: Boolean): Integer;



// Computes the horizontal offset needed when all columns are automatically right aligned (in RTL bidi mode).

// ExcludeScrollBar determines if the left-hand vertical scrollbar is to be included (if visible) or not.



var

  HeaderWidth: Integer;

  ScrollBarVisible: Boolean;

begin

  ScrollBarVisible := (Integer(FRangeY) > ClientHeight) and (ScrollBarOptions.ScrollBars in [ssVertical, ssBoth]);

  if ScrollBarVisible then

    Result := GetSystemMetrics(SM_CXVSCROLL)

  else

    Result := 0;



  // Make everything right aligned.

  HeaderWidth := FHeaderRect.Right - FHeaderRect.Left;

  if Integer(FRangeX) + Result <= HeaderWidth then

    Result := HeaderWidth - Integer(FRangeX);

  // Otherwise take only left-hand vertical scrollbar into account.



  if ScrollBarVisible and ExcludeScrollBar then

    Dec(Result, GetSystemMetrics(SM_CXVSCROLL));

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.CountLevelDifference(Node1, Node2: PVirtualNode): Integer;



// This method counts how many indentation levels the given nodes are apart. If both nodes have the same parent then the

// difference is 0 otherwise the result is basically GetNodeLevel(Node2) - GetNodeLevel(Node1), but with sign.

// If the result is negative then Node2 is less intended than Node1.



var

  Level1, Level2: Integer;



begin

  Assert(Assigned(Node1) and Assigned(Node2), 'Both nodes must be Assigned.');



  Level1 := 0;

  while Node1.Parent <> FRoot do

  begin

    Inc(Level1);

    Node1 := Node1.Parent;

  end;



  Level2 := 0;

  while Node2.Parent <> FRoot do

  begin

    Inc(Level2);

    Node2 := Node2.Parent;

  end;



  Result := Level2 - Level1;

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.CountVisibleChildren(Node: PVirtualNode): Cardinal;



// Returns the number of visible child nodes of the given node.



begin

  Result := 0;



  // The node's direct children...

  if vsExpanded in Node.States then

  begin

    // ...and their children.

    Node := Node.FirstChild;

    while Assigned(Node) do

    begin

      if vsVisible in Node.States then

        Inc(Result, CountVisibleChildren(Node) + Cardinal(IfThen(IsEffectivelyVisible[Node], 1)));

      Node := Node.NextSibling;

    end;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.CreateParams(var Params: TCreateParams);



const

  ScrollBar: array[TScrollStyle] of Cardinal = (0, WS_HSCROLL, WS_VSCROLL, WS_HSCROLL or WS_VSCROLL);



begin

  inherited CreateParams(Params);



  with Params do

  begin

    Style := Style or WS_CLIPCHILDREN or WS_CLIPSIBLINGS or ScrollBar[ScrollBarOptions.FScrollBars];

    if toFullRepaintOnResize in FOptions.FMiscOptions then

      WindowClass.style := WindowClass.style or CS_HREDRAW or CS_VREDRAW

    else

      WindowClass.style := WindowClass.style and not (CS_HREDRAW or CS_VREDRAW);

    if FBorderStyle = bsSingle then

    begin

      if Ctl3D then

      begin

        ExStyle := ExStyle or WS_EX_CLIENTEDGE;

        Style := Style and not WS_BORDER;

      end

      else

        Style := Style or WS_BORDER;

    end

    else

      Style := Style and not WS_BORDER;



    AddBiDiModeExStyle(ExStyle);

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.CreateWnd;



// Initializes data which depends on a valid window handle.



begin

  DoStateChange([tsWindowCreating]);

  inherited;

  DoStateChange([], [tsWindowCreating]);



  if (StyleServices.Enabled and (toThemeAware in TreeOptions.PaintOptions)) or VclStyleEnabled then

  begin

    DoStateChange([tsUseThemes]);

    if not VclStyleEnabled then

      if (toUseExplorerTheme in FOptions.FPaintOptions) and IsWinVistaOrAbove then

      begin

        DoStateChange([tsUseExplorerTheme]);

         SetWindowTheme('explorer');

      end

      else

        DoStateChange([], [tsUseExplorerTheme]);

  end

  else

    DoStateChange([], [tsUseThemes, tsUseExplorerTheme]);



  AutoScale();

  // Because of the special recursion and update stopper when creating the window (or resizing it)

  // we have to manually trigger the auto size calculation here.

  if hsNeedScaling in FHeader.FStates then

    FHeader.RescaleHeader;

  if hoAutoResize in FHeader.FOptions then

    FHeader.FColumns.AdjustAutoSize(InvalidColumn);



  PrepareBitmaps(True, True);



  // Register tree as OLE drop target.

  if not (csDesigning in ComponentState) and (toAcceptOLEDrop in FOptions.FMiscOptions) then

    if not (csLoading in ComponentState) then // will be done in Loaded after all inherited settings are loaded from the DFMs

      RegisterDragDrop(Handle, DragManager as IDropTarget);



  UpdateScrollBars(True);

  UpdateHeaderRect;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.DefineProperties(Filer: TFiler);



// There were heavy changes in some properties during development of VT. This method helps to make migration easier

// by reading old properties manually and put them into the new properties as appropriate.

// Note: these old properties are never written again and silently disappear.

// June 2002: Meanwhile another task is done here too: working around the problem that TCollection is not streamed

//            correctly when using Visual Form Inheritance (VFI).



var

  StoreIt: Boolean;



begin

  inherited;



  // The header can prevent writing columns altogether.

  if FHeader.CanWriteColumns then

  begin

    // Check if we inherit from an ancestor form (Visual Form Inheritance).

    StoreIt := Filer.Ancestor = nil;

    // If there is an ancestor then save columns only if they are different to the base set.

    if not StoreIt then

      StoreIt := not FHeader.Columns.Equals(TBaseVirtualTree(Filer.Ancestor).FHeader.Columns);

  end

  else

    StoreIt := False;



  Filer.DefineProperty('Columns', FHeader.ReadColumns, FHeader.WriteColumns, StoreIt);

  Filer.DefineProperty('Options', ReadOldOptions, nil, False);

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.DetermineDropMode(const P: TPoint; var HitInfo: THitInfo; var NodeRect: TRect): TDropMode;



// Determine the DropMode.



var

  ImageHit: Boolean;

  LabelHit: Boolean;

  ItemHit: Boolean;



begin

  ImageHit := HitInfo.HitPositions * [hiOnNormalIcon, hiOnStateIcon] <> [];

  LabelHit := hiOnItemLabel in HitInfo.HitPositions;

  ItemHit := ((hiOnItem in HitInfo.HitPositions) and

             ((toFullRowDrag in FOptions.FMiscOptions) or (toFullRowSelect in FOptions.FSelectionOptions)));



  // In report mode only direct hits of the node captions/images in the main column are accepted as hits.

  if (toReportMode in FOptions.FMiscOptions) and not (ItemHit or ((LabelHit or ImageHit) and

    (HitInfo.HitColumn = FHeader.MainColumn))) then

    HitInfo.HitNode := nil;



  if Assigned(HitInfo.HitNode) then

  begin

    if LabelHit or ImageHit or not (toShowDropmark in FOptions.FPaintOptions) then

      Result := dmOnNode

    else

      if ((NodeRect.Top + NodeRect.Bottom) div 2) > P.Y then

        Result := dmAbove

      else

        Result := dmBelow;

  end

  else

    Result := dmNowhere;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.DetermineHiddenChildrenFlag(Node: PVirtualNode);



// Update the hidden children flag of the given node.



var

  Run: PVirtualNode;



begin

  if Node.ChildCount = 0 then

  begin

    if vsHasChildren in Node.States then

      Exclude(Node.States, vsAllChildrenHidden)

    else

      Include(Node.States, vsAllChildrenHidden);

  end

  else

  begin

    // Iterate through all siblings and stop when one visible is found.

    Run := Node.FirstChild;

    while Assigned(Run) and not IsEffectivelyVisible[Run] do

      Run := Run.NextSibling;

    if Assigned(Run) then

      Exclude(Node.States, vsAllChildrenHidden)

    else

      Include(Node.States, vsAllChildrenHidden);

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.DetermineHiddenChildrenFlagAllNodes;



var

  Run: PVirtualNode;



begin

  Run := GetFirstNoInit(False);

  while Assigned(Run) do

  begin

    DetermineHiddenChildrenFlag(Run);

    Run := GetNextNoInit(Run);

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.DetermineHitPositionLTR(var HitInfo: THitInfo; Offset, Right: Integer;

  Alignment: TAlignment);



// This method determines the hit position within a node with left-to-right orientation.



var

  MainColumnHit: Boolean;

  Run: PVirtualNode;

  Indent,

  TextWidth,

  ImageOffset: Integer;



begin

  MainColumnHit := HitInfo.HitColumn = FHeader.MainColumn;

  Indent := 0;



  // If columns are not used or the main column is hit then the tree indentation must be considered too.

  if MainColumnHit then

  begin

    if toFixedIndent in FOptions.FPaintOptions then

      Indent := FIndent

    else

    begin

      Run := HitInfo.HitNode;

      while (Run.Parent <> FRoot) do

      begin

        Inc(Indent, FIndent);

      Run := Run.Parent;

      end;

      if toShowRoot in FOptions.FPaintOptions then

        Inc(Indent, FIndent);

    end;

  end;



  if (MainColumnHit and (Offset < (Indent + Margin{See issue #259}))) then

  begin

    // Position is to the left of calculated indentation which can only happen for the main column.

    // Check whether it corresponds to a button/checkbox.

    if (toShowButtons in FOptions.FPaintOptions) and (vsHasChildren in HitInfo.HitNode.States) then

    begin

      // Position of button is interpreted very generously to avoid forcing the user

      // to click exactly into the 9x9 pixels area. The entire node height and one full

      // indentation level is accepted as button hit.

      if Offset >= Indent - Integer(FIndent) then

        Include(HitInfo.HitPositions, hiOnItemButton);

      if Offset >= Indent - FPlusBM.Width then

        Include(HitInfo.HitPositions, hiOnItemButtonExact);

    end;

    // no button hit so position is on indent

    if HitInfo.HitPositions = [] then

      Include(HitInfo.HitPositions, hiOnItemIndent);

  end

  else

  begin

    // The next hit positions can be:

    //   - on the check box

    //   - on the state image

    //   - on the normal image

    //   - to the left of the text area

    //   - on the label or

    //   - to the right of the text area

    // (in this order).



    // In report mode no hit other than in the main column is possible.

    if MainColumnHit or not (toReportMode in FOptions.FMiscOptions) then

    begin

      ImageOffset := Indent +  FMargin;



      // Check support is only available for the main column.

      if MainColumnHit and (toCheckSupport in FOptions.FMiscOptions) and Assigned(FCheckImages) and

        (HitInfo.HitNode.CheckType <> ctNone) then

        Inc(ImageOffset, FCheckImages.Width + 2);



      if MainColumnHit and (Offset < ImageOffset) then

      begin

        HitInfo.HitPositions := [hiOnItem];

        if (HitInfo.HitNode.CheckType <> ctNone) then

          Include(HitInfo.HitPositions, hiOnItemCheckBox);

      end

      else

      begin

        if Assigned(FStateImages) and HasImage(HitInfo.HitNode, ikState, HitInfo.HitColumn) then

          Inc(ImageOffset, FStateImages.Width + 2);

        if Offset < ImageOffset then

          Include(HitInfo.HitPositions, hiOnStateIcon)

        else

        begin

          if Assigned(FImages) and HasImage(HitInfo.HitNode, ikNormal, HitInfo.HitColumn) then

            Inc(ImageOffset, GetNodeImageSize(HitInfo.HitNode).cx + 2);

          if Offset < ImageOffset then

            Include(HitInfo.HitPositions, hiOnNormalIcon)

          else

          begin

            // ImageOffset contains now the left border of the node label area. This is used to calculate the

            // correct alignment in the column.

            TextWidth := DoGetNodeWidth(HitInfo.HitNode, HitInfo.HitColumn);



            // Check if the text can be aligned at all. This is only possible if there is enough room

            // in the remaining text rectangle.

            if TextWidth > Right - ImageOffset then

              Include(HitInfo.HitPositions, hiOnItemLabel)

            else

            begin

              case Alignment of

                taCenter:

                  begin

                    Indent := (ImageOffset + Right - TextWidth) div 2;

                    if Offset < Indent then

                      Include(HitInfo.HitPositions, hiOnItemLeft)

                    else

                      if Offset < Indent + TextWidth then

                        Include(HitInfo.HitPositions, hiOnItemLabel)

                      else

                        Include(HitInfo.HitPositions, hiOnItemRight);

                  end;

                taRightJustify:

                  begin

                    Indent := Right - TextWidth;

                    if Offset < Indent then

                      Include(HitInfo.HitPositions, hiOnItemLeft)

                    else

                      Include(HitInfo.HitPositions, hiOnItemLabel);

                  end;

              else // taLeftJustify

                if Offset < ImageOffset + TextWidth then

                  Include(HitInfo.HitPositions, hiOnItemLabel)

                else

                  Include(HitInfo.HitPositions, hiOnItemRight);

              end;

            end;

          end;

        end;

      end;

    end;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.DetermineHitPositionRTL(var HitInfo: THitInfo; Offset, Right: Integer; Alignment: TAlignment);



// This method determines the hit position within a node with right-to-left orientation.



var

  MainColumnHit: Boolean;

  Run: PVirtualNode;

  Indent,

  TextWidth,

  ImageOffset: Integer;



begin

  MainColumnHit := HitInfo.HitColumn = FHeader.MainColumn;



  // If columns are not used or the main column is hit then the tree indentation must be considered too.

  if MainColumnHit then

  begin

    if toFixedIndent in FOptions.FPaintOptions then

      Dec(Right, FIndent)

    else

    begin

      Run := HitInfo.HitNode;

      while (Run.Parent <> FRoot) do

      begin

        Dec(Right, FIndent);

        Run := Run.Parent;

      end;

      if toShowRoot in FOptions.FPaintOptions then

        Dec(Right, FIndent);

    end;

  end;



  if Offset >= Right then

  begin

    // Position is to the right of calculated indentation which can only happen for the main column.

    // Check whether it corresponds to a button/checkbox.

    if (toShowButtons in FOptions.FPaintOptions) and (vsHasChildren in HitInfo.HitNode.States) then

    begin

      // Position of button is interpreted very generously to avoid forcing the user

      // to click exactly into the 9x9 pixels area. The entire node height and one full

      // indentation level is accepted as button hit.

      if Offset <= Right + Integer(FIndent) then

        Include(HitInfo.HitPositions, hiOnItemButton);

      if Offset <= Right + FPlusBM.Width then

        Include(HitInfo.HitPositions, hiOnItemButtonExact);

    end;

    // no button hit so position is on indent

    if HitInfo.HitPositions = [] then

      Include(HitInfo.HitPositions, hiOnItemIndent);

  end

  else

  begin

    // The next hit positions can be:

    //   - on the check box

    //   - on the state image

    //   - on the normal image

    //   - to the left of the text area

    //   - on the label or

    //   - to the right of the text area

    // (in this order).



    // In report mode no hit other than in the main column is possible.

    if MainColumnHit or not (toReportMode in FOptions.FMiscOptions) then

    begin

      ImageOffset := Right - FMargin;



      // Check support is only available for the main column.

      if MainColumnHit and (toCheckSupport in FOptions.FMiscOptions) and Assigned(FCheckImages) and

        (HitInfo.HitNode.CheckType <> ctNone) then

        Dec(ImageOffset, FCheckImages.Width + 2);



      if MainColumnHit and (Offset > ImageOffset) then

      begin

        HitInfo.HitPositions := [hiOnItem];

        if (HitInfo.HitNode.CheckType <> ctNone) then

          Include(HitInfo.HitPositions, hiOnItemCheckBox);

      end

      else

      begin

        if Assigned(FStateImages) and HasImage(HitInfo.HitNode, ikState, HitInfo.HitColumn) then

          Dec(ImageOffset, FStateImages.Width + 2);

        if Offset > ImageOffset then

          Include(HitInfo.HitPositions, hiOnStateIcon)

        else

        begin

          if Assigned(FImages) and HasImage(HitInfo.HitNode, ikNormal, HitInfo.HitColumn) then

            Dec(ImageOffset, GetNodeImageSize(HitInfo.HitNode).cx + 2);

          if Offset > ImageOffset then

            Include(HitInfo.HitPositions, hiOnNormalIcon)

          else

          begin

            // ImageOffset contains now the right border of the node label area. This is used to calculate the

            // correct alignment in the column.

            TextWidth := DoGetNodeWidth(HitInfo.HitNode, HitInfo.HitColumn);



            // Check if the text can be aligned at all. This is only possible if there is enough room

            // in the remaining text rectangle.

            if TextWidth > ImageOffset then

              Include(HitInfo.HitPositions, hiOnItemLabel)

            else

            begin

              // Consider bidi mode here. In RTL context does left alignment actually mean right alignment

              // and vice versa.

              ChangeBiDiModeAlignment(Alignment);



              case Alignment of

                taCenter:

                  begin

                    Indent := (ImageOffset - TextWidth) div 2;

                    if Offset < Indent then

                      Include(HitInfo.HitPositions, hiOnItemLeft)

                    else

                      if Offset < Indent + TextWidth then

                        Include(HitInfo.HitPositions, hiOnItemLabel)

                      else

                        Include(HitInfo.HitPositions, hiOnItemRight);

                  end;

                taRightJustify:

                  begin

                    Indent := ImageOffset - TextWidth;

                    if Offset < Indent then

                      Include(HitInfo.HitPositions, hiOnItemLeft)

                    else

                      Include(HitInfo.HitPositions, hiOnItemLabel);

                  end;

              else // taLeftJustify

                if Offset > TextWidth then

                  Include(HitInfo.HitPositions, hiOnItemRight)

                else

                  Include(HitInfo.HitPositions, hiOnItemLabel);

              end;

            end;

          end;

        end;

      end;

    end;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.DetermineLineImageAndSelectLevel(Node: PVirtualNode; var LineImage: TLineImage): Integer;



// This method is used during paint cycles and initializes an array of line type IDs. These IDs are used to paint

// the tree lines in front of the given node.

// Additionally an initial count of selected parents is determined and returned which is used for specific painting.



var

  X: Integer;

  Indent: Integer;

  Run: PVirtualNode;



begin

  Result := 0;

  if toShowRoot in FOptions.FPaintOptions then

    X := 1

  else

    X := 0;

  Run := Node;

  // Determine indentation level of top node.

  while Run.Parent <> FRoot do

  begin

    Inc(X);

    Run := Run.Parent;

    // Count selected nodes (FRoot is never selected).

    if vsSelected in Run.States then

      Inc(Result);

  end;



  // Set initial size of line index array, this will automatically initialized all entries to ltNone.

  SetLength(LineImage, X);

  Indent := X - 1;



  // Only use lines if requested.

  if (toShowTreeLines in FOptions.FPaintOptions) and

     (not (toHideTreeLinesIfThemed in FOptions.FPaintOptions) or not (tsUseThemes in FStates)) then

  begin

    if toChildrenAbove in FOptions.FPaintOptions then

    begin

      Dec(X);

      if not HasVisiblePreviousSibling(Node) then

      begin

        if (Node.Parent <> FRoot) or HasVisibleNextSibling(Node) then

          LineImage[X] := ltBottomRight

        else

          LineImage[X] := ltRight;

      end

      else

        if (Node.Parent = FRoot) and (not HasVisibleNextSibling(Node)) then

          LineImage[X] := ltTopRight

        else

          LineImage[X] := ltTopDownRight;



      // Now go up to the root to determine the rest.

      Run := Node.Parent;

      while Run <> FRoot do

      begin

        Dec(X);

        if HasVisiblePreviousSibling(Run) then

          LineImage[X] := ltTopDown

        else

          LineImage[X] := ltNone;



        Run := Run.Parent;

      end;

    end

    else

    begin

      // Start over parent traversal if necessary.

      Run := Node;



      if Run.Parent <> FRoot then

      begin

        // The very last image (the one immediately before the item label) is different.

        if HasVisibleNextSibling(Run) then

          LineImage[X - 1] := ltTopDownRight

        else

          LineImage[X - 1] := ltTopRight;

        Run := Run.Parent;



        // Now go up all parents.

        repeat

          if Run.Parent = FRoot then

            Break;

          Dec(X);

          if HasVisibleNextSibling(Run) then

            LineImage[X - 1] := ltTopDown

          else

            LineImage[X - 1] := ltNone;

          Run := Run.Parent;

        until False;

      end;



      // Prepare root level. Run points at this stage to a top level node.

      if (toShowRoot in FOptions.FPaintOptions) and ((toShowTreeLines in FOptions.FPaintOptions) and

         (not (toHideTreeLinesIfThemed in FOptions.FPaintOptions) or not (tsUseThemes in FStates))) then

      begin

        // Is the top node a root node?

        if Run = Node then

        begin

          // First child gets the bottom-right bitmap if it isn't also the only child.

          if IsFirstVisibleChild(FRoot, Run) then

            // Is it the only child?

            if IsLastVisibleChild(FRoot, Run) then

              LineImage[0] := ltRight

            else

              LineImage[0] := ltBottomRight

          else

            // real last child

            if IsLastVisibleChild(FRoot, Run) then

              LineImage[0] := ltTopRight

            else

              LineImage[0] := ltTopDownRight;

        end

        else

        begin

          // No, top node is not a top level node. So we need different painting.

          if HasVisibleNextSibling(Run) then

            LineImage[0] := ltTopDown

          else

            LineImage[0] := ltNone;

        end;

      end;

    end;

  end;



  if (tsUseExplorerTheme in FStates) and HasChildren[Node] and (Indent >= 0) then

    LineImage[Indent] := ltNone;

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.DetermineNextCheckState(CheckType: TCheckType; CheckState: TCheckState): TCheckState;



// Determines the next check state in case the user click the check image or pressed the space key.



begin

  case CheckType of

    ctTriStateCheckBox,

    ctCheckBox:

      if CheckState = csCheckedNormal then

        Result := csUncheckedNormal

      else

        Result := csCheckedNormal;

    ctRadioButton:

      Result := csCheckedNormal;

    ctButton:

      Result := csUncheckedNormal;

  else

    Result := csMixedNormal;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.DetermineScrollDirections(X, Y: Integer): TScrollDirections;



// Determines which direction the client area must be scrolled depending on the given position.



begin

  Result:= [];



  if CanAutoScroll then

  begin

    // Calculation for wheel panning/scrolling is a bit different to normal auto scroll.

    if [tsWheelPanning, tsWheelScrolling] * FStates <> [] then

    begin

      if (X - FLastClickPos.X) < -8 then

        Include(Result, sdLeft);

      if (X - FLastClickPos.X) > 8 then

        Include(Result, sdRight);



      if (Y - FLastClickPos.Y) < -8 then

        Include(Result, sdUp);

      if (Y - FLastClickPos.Y) > 8 then

        Include(Result, sdDown);

    end

    else

    begin

      if (X < Integer(FDefaultNodeHeight)) and (FEffectiveOffsetX <> 0) then

        Include(Result, sdLeft);

      if (ClientWidth + FEffectiveOffsetX < Integer(FRangeX)) and (X > ClientWidth - Integer(FDefaultNodeHeight)) then

        Include(Result, sdRight);



      if (Y < Integer(FDefaultNodeHeight)) and (FOffsetY <> 0) then

        Include(Result, sdUp);

      if (ClientHeight - FOffsetY < Integer(FRangeY)) and (Y > ClientHeight - Integer(FDefaultNodeHeight)) then

        Include(Result, sdDown);



      // Since scrolling during dragging is not handled via the timer we do a check here whether the auto

      // scroll timeout already has elapsed or not.

      if (Result <> []) and

        ((Assigned(FDragManager) and DragManager.IsDropTarget) or

        (FindDragTarget(Point(X, Y), False) = Self)) then

      begin

        if FDragScrollStart = 0 then

          FDragScrollStart := timeGetTime;

        // Reset any scroll direction to avoid scroll in the case the user is dragging and the auto scroll time has not

        // yet elapsed.

        if ((timeGetTime - FDragScrollStart) < FAutoScrollDelay) then

          Result := [];

      end;

    end;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.DoAdvancedHeaderDraw(var PaintInfo: THeaderPaintInfo; const Elements: THeaderPaintElements);



begin

  if Assigned(FOnAdvancedHeaderDraw) then

    FOnAdvancedHeaderDraw(FHeader, PaintInfo, Elements);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.DoAfterCellPaint(Canvas: TCanvas; Node: PVirtualNode; Column: TColumnIndex; CellRect: TRect);



begin

  if Assigned(FOnAfterCellPaint) then

    FOnAfterCellPaint(Self, Canvas, Node, Column, CellRect);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.DoAfterItemErase(Canvas: TCanvas; Node: PVirtualNode; ItemRect: TRect);



begin

  if Assigned(FOnAfterItemErase) then

    FOnAfterItemErase(Self, Canvas, Node, ItemRect);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.DoAfterItemPaint(Canvas: TCanvas; Node: PVirtualNode; ItemRect: TRect);



begin

  if Assigned(FOnAfterItemPaint) then

    FOnAfterItemPaint(Self, Canvas, Node, ItemRect);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.DoAfterPaint(Canvas: TCanvas);



begin

  if Assigned(FOnAfterPaint) then

    FOnAfterPaint(Self, Canvas);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.DoAutoScroll(X, Y: Integer);



begin

  FScrollDirections := DetermineScrollDirections(X, Y);



  if FStates * [tsWheelPanning, tsWheelScrolling] = [] then

  begin

    if FScrollDirections = [] then

    begin

      if ((FStates * [tsScrollPending, tsScrolling]) <> []) then

      begin

        StopTimer(ScrollTimer);

        DoStateChange([], [tsScrollPending, tsScrolling]);

      end;

    end

    else

    begin

      // start auto scroll if not yet done

      if (FStates * [tsScrollPending, tsScrolling]) = [] then

      begin

        DoStateChange([tsScrollPending]);

        SetTimer(Handle, ScrollTimer, FAutoScrollDelay, nil);

      end;

    end;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.DoBeforeDrag(Node: PVirtualNode; Column: TColumnIndex): Boolean;



begin

  Result := False;

  if Assigned(FOnDragAllowed) then

    FOnDragAllowed(Self, Node, Column, Result);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.DoBeforeCellPaint(Canvas: TCanvas; Node: PVirtualNode; Column: TColumnIndex;

  CellPaintMode: TVTCellPaintMode; CellRect: TRect; var ContentRect: TRect);



var

  UpdateRect: TRect;



begin

  if Assigned(FOnBeforeCellPaint) then

  begin

    if CellPaintMode = cpmGetContentMargin then

    begin

      // Prevent drawing if we are only about to get the margin. As this also clears the update rect we need to save it.

      GetUpdateRect(Handle, UpdateRect, False);

      SetUpdateState(True);

    end;



    Canvas.Font := Self.Font; // Fixes issue #298

    FOnBeforeCellPaint(Self, Canvas, Node, Column, CellPaintMode, CellRect, ContentRect);



    if CellPaintMode = cpmGetContentMargin then

    begin

      SetUpdateState(False);

      InvalidateRect(Handle, @UpdateRect, False);

    end;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.DoBeforeItemErase(Canvas: TCanvas; Node: PVirtualNode; ItemRect: TRect; var Color: TColor;

  var EraseAction: TItemEraseAction);



begin

  if Assigned(FOnBeforeItemErase) then

    FOnBeforeItemErase(Self, Canvas, Node, ItemRect, Color, EraseAction);

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.DoBeforeItemPaint(Canvas: TCanvas; Node: PVirtualNode; ItemRect: TRect): Boolean;



begin

  // By default custom draw will not be used, so the tree handles drawing the node.

  Result := False;

  if Assigned(FOnBeforeItemPaint) then

    FOnBeforeItemPaint(Self, Canvas, Node, ItemRect, Result);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.DoBeforePaint(Canvas: TCanvas);



begin

  if Assigned(FOnBeforePaint) then

    FOnBeforePaint(Self, Canvas);

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.DoCancelEdit: Boolean;



// Called when the current edit action or a pending edit must be cancelled.



begin

  StopTimer(EditTimer);

  DoStateChange([], [tsEditPending]);

  Result := (tsEditing in FStates) and FEditLink.CancelEdit;

  if Result then

  begin

    DoStateChange([], [tsEditing]);

    if Assigned(FOnEditCancelled) then

      FOnEditCancelled(Self, FEditColumn);

    if not (csDestroying in ComponentState) then

      FEditLink := nil;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.DoCanEdit(Node: PVirtualNode; Column: TColumnIndex; var Allowed: Boolean);



begin

  if Assigned(FOnEditing) then

    FOnEditing(Self, Node, Column, Allowed);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.DoCanSplitterResizeNode(P: TPoint; Node: PVirtualNode; Column: TColumnIndex;

  var Allowed: Boolean);



begin

  if Assigned(FOnCanSplitterResizeNode) then

    FOnCanSplitterResizeNode(Self, P, Node, Column, Allowed);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.DoChange(Node: PVirtualNode);



begin

  StopTimer(ChangeTimer);

  if Assigned(FOnChange) then

    FOnChange(Self, Node);



  // This is a good place to reset the cached node. This is the same as the node passed in here.

  // This is necessary to allow descendants to override this method and get the node then.

  DoStateChange([], [tsChangePending]);

  FLastChangedNode := nil;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.DoCheckClick(Node: PVirtualNode; NewCheckState: TCheckState);



begin

  if ChangeCheckState(Node, NewCheckState) then

    DoChecked(Node);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.DoChecked(Node: PVirtualNode);



begin

  if Assigned(FOnChecked) then

    FOnChecked(Self, Node);

  if Assigned(FAccessibleItem) then

    NotifyWinEvent(EVENT_OBJECT_STATECHANGE, Handle, OBJID_CLIENT, CHILDID_SELF);

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.DoChecking(Node: PVirtualNode; var NewCheckState: TCheckState): Boolean;



// Determines if a node is allowed to change its check state to NewCheckState.



begin

  if toReadOnly in FOptions.FMiscOptions then

    Result := False

  else

  begin

    Result := True;

    if Assigned(FOnChecking) then

      FOnChecking(Self, Node, NewCheckState, Result);

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.DoCollapsed(Node: PVirtualNode);

var

  lFirstSelected: PVirtualNode;

  lParent: PVirtualNode;

begin

  if Assigned(FOnCollapsed) then

    FOnCollapsed(Self, Node);



  if Assigned(FAccessibleItem) then

    NotifyWinEvent(EVENT_OBJECT_STATECHANGE, Handle, OBJID_CLIENT, CHILDID_SELF);



  if (toAlwaysSelectNode in TreeOptions.SelectionOptions) then

  begin

    // Select the next visible parent if the currently selected node gets invisible due to a collapse

    // This makes the VT behave more like the Win32 custom TreeView control

    // This makes only sense no no multi selection is allowed and if there is a selected node at all

    lFirstSelected := GetFirstSelected();

    if Assigned(lFirstSelected) and not FullyVisible[lFirstSelected] then

    begin

      lParent := GetVisibleParent(lFirstSelected);

      Selected[lParent] := True;

      Selected[lFirstSelected] := False;

    end;//if

    //if there is (still) no selected node, then use FNextNodeToSelect to select one

    if SelectedCount = 0 then

      EnsureNodeSelected();

  end;//if

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.DoCollapsing(Node: PVirtualNode): Boolean;



begin

  Result := True;

  if Assigned(FOnCollapsing) then

    FOnCollapsing(Self, Node, Result);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.DoColumnClick(Column: TColumnIndex; Shift: TShiftState);



begin

  if Assigned(FOnColumnClick) then

    FOnColumnClick(Self, Column, Shift);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.DoColumnDblClick(Column: TColumnIndex; Shift: TShiftState);



begin

  if Assigned(FOnColumnDblClick) then

    FOnColumnDblClick(Self, Column, Shift);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.DoColumnResize(Column: TColumnIndex);



var

  R: TRect;

  Run: PVirtualNode;



begin

  if not (csLoading in ComponentState) and HandleAllocated then

  begin

    // Reset all vsHeightMeasured flags if we are in multiline mode.

    Run := GetFirstInitialized;

    while Assigned(Run) do

    begin

      if vsMultiline in Run.States then

        Exclude(Run.States, vsHeightMeasured);

      Run := GetNextInitialized(Run);

    end;



    UpdateHorizontalScrollBar(True);

    if Column > NoColumn then

    begin

      // Invalidate client area from the current column all to the right (or left in RTL mode).

      R := ClientRect;

      if not (toAutoSpanColumns in FOptions.FAutoOptions) then

        if UseRightToLeftAlignment then

          R.Right := FHeader.Columns[Column].Left + FHeader.Columns[Column].Width + ComputeRTLOffset

        else

          R.Left := FHeader.Columns[Column].Left;

      InvalidateRect(Handle, @R, False);

      FHeader.Invalidate(FHeader.Columns[Column], True);

    end;

    if [hsColumnWidthTracking, hsResizing] * FHeader.States = [hsColumnWidthTracking] then

      UpdateWindow(Handle);



    if not (tsUpdating in FStates) then

      UpdateDesigner; // design time only



    if Assigned(FOnColumnResize) and not (hsResizing in FHeader.States) then

      FOnColumnResize(FHeader, Column);



    // If the tree is currently in edit state then notify edit link.

    if tsEditing in FStates then

      UpdateEditBounds;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.DoCompare(Node1, Node2: PVirtualNode; Column: TColumnIndex): Integer;



begin

  Result := 0;

  if Assigned(FOnCompareNodes) then

    FOnCompareNodes(Self, Node1, Node2, Column, Result);

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.DoCreateDataObject: IDataObject;



begin

  Result := nil;

  if Assigned(FOnCreateDataObject) then

    FOnCreateDataObject(Self, Result);

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.DoCreateDragManager: IVTDragManager;



begin

  Result := nil;

  if Assigned(FOnCreateDragManager) then

    FOnCreateDragManager(Self, Result);

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.DoCreateEditor(Node: PVirtualNode; Column: TColumnIndex): IVTEditLink;



begin

  Result := nil;

  if Assigned(FOnCreateEditor) then

    FOnCreateEditor(Self, Node, Column, Result);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.DoDragging(P: TPoint);



// Initiates finally the drag'n drop operation and returns after DD is finished.



  //--------------- local function --------------------------------------------



  function GetDragOperations: Integer;



  begin

    if FDragOperations = [] then

      Result := DROPEFFECT_COPY or DROPEFFECT_MOVE or DROPEFFECT_LINK

    else

    begin

      Result := 0;

      if doCopy in FDragOperations then

        Result := Result or DROPEFFECT_COPY;

      if doLink in FDragOperations then

        Result := Result or DROPEFFECT_LINK;

      if doMove in FDragOperations then

        Result := Result or DROPEFFECT_MOVE;

    end;

  end;



  //--------------- end local function ----------------------------------------



var

  AllowedEffects: LongInt;

  DragObject: TDragObject;



  DataObject: IDataObject;



begin

  DataObject := nil;

  // Dragging is dragging, nothing else.

  DoCancelEdit;



  if Assigned(FCurrentHotNode) then

  begin

    InvalidateNode(FCurrentHotNode);

    FCurrentHotNode := nil;

  end;

  // Select the focused node if not already done.

  if Assigned(FFocusedNode) and not (vsSelected in FFocusedNode.States) then

  begin

    InternalAddToSelection(FFocusedNode, False);

    InvalidateNode(FFocusedNode);

  end;



  UpdateWindow(Handle);



  // Keep a list of all currently selected nodes as this list might change,

  // but we have probably to delete currently selected nodes.

  FDragSelection := GetSortedSelection(True);

  try

    DoStateChange([tsOLEDragging], [tsOLEDragPending, tsClearPending]);



    // An application might create a drag object like used during VCL dd. This is not required for OLE dd but

    // required as parameter.

    DragObject := nil;

    DoStartDrag(DragObject);

    DragObject.Free;



    DataObject := DragManager.DataObject;

    PrepareDragImage(P, DataObject);



    FLastDropMode := dmOnNode;

    // Don't forget to initialize the result. It might never be touched.

    FLastDragEffect := DROPEFFECT_NONE;

    AllowedEffects := GetDragOperations;

    try

      DragAndDrop(AllowedEffects, DataObject, FLastDragEffect);

      DragManager.ForceDragLeave;

    finally

      GetCursorPos(P);

      P := ScreenToClient(P);

      DoEndDrag(Self, P.X, P.Y);



      FDragImage.EndDrag;



      // Finish the operation.

      if (FLastDragEffect = DROPEFFECT_MOVE) and (toAutoDeleteMovedNodes in TreeOptions.AutoOptions) then

      begin

        // The operation was a move so delete the previously selected nodes.

        DeleteSelectedNodes;

      end;



      DoStateChange([], [tsOLEDragging]);

    end;

  finally

    FDragSelection := nil;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.DoDragExpand;



var

  SourceTree: TBaseVirtualTree;



begin

  StopTimer(ExpandTimer);

  if Assigned(FDropTargetNode) and (vsHasChildren in FDropTargetNode.States) and

    not (vsExpanded in FDropTargetNode.States) then

  begin

    if Assigned(FDragManager) then

      SourceTree := DragManager.DragSource

    else

      SourceTree := nil;



    if not DragManager.DropTargetHelperSupported and Assigned(SourceTree) then

      SourceTree.FDragImage.HideDragImage;

    ToggleNode(FDropTargetNode);

    UpdateWindow(Handle);

    if not DragManager.DropTargetHelperSupported and Assigned(SourceTree) then

      SourceTree.FDragImage.ShowDragImage;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.DoDragOver(Source: TObject; Shift: TShiftState; State: TDragState; Pt: TPoint; Mode: TDropMode;

  var Effect: Integer): Boolean;



begin

  Result := False;

  if Assigned(FOnDragOver) then

    FOnDragOver(Self, Source, Shift, State, Pt, Mode, Effect, Result);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.DoDragDrop(Source: TObject; DataObject: IDataObject; Formats: TFormatArray;

  Shift: TShiftState; Pt: TPoint; var Effect: Integer; Mode: TDropMode);



begin

  if Assigned(FOnDragDrop) then

    FOnDragDrop(Self, Source, DataObject, Formats, Shift, Pt, Effect, Mode);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.DoBeforeDrawLineImage(Node: PVirtualNode; Level: Integer; var XPos: Integer);



begin

  if Assigned(FOnBeforeDrawLineImage) then

    FOnBeforeDrawLineImage(Self, Node, Level, XPos);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.DoEdit;



begin

  Application.CancelHint;

  StopTimer(ScrollTimer);

  StopTimer(EditTimer);

  DoStateChange([], [tsEditPending]);

  if Assigned(FFocusedNode) and not (vsDisabled in FFocusedNode.States) and

    not (toReadOnly in FOptions.FMiscOptions) and (FEditLink = nil) then

  begin

    FEditLink := DoCreateEditor(FFocusedNode, FEditColumn);

    if Assigned(FEditLink) then

    begin

      DoStateChange([tsEditing], [tsDrawSelecting, tsDrawSelPending, tsToggleFocusedSelection, tsOLEDragPending,

        tsOLEDragging, tsClearPending, tsDrawSelPending, tsScrollPending, tsScrolling, tsMouseCheckPending]);

      ScrollIntoView(FFocusedNode, toCenterScrollIntoView in FOptions.SelectionOptions,

        not (toDisableAutoscrollOnEdit in FOptions.AutoOptions));

      if FEditLink.PrepareEdit(Self, FFocusedNode, FEditColumn) then

      begin

        UpdateEditBounds;

        // Node needs repaint because the selection rectangle and static text must disappear.

        InvalidateNode(FFocusedNode);

        if not FEditLink.BeginEdit then

          DoStateChange([], [tsEditing]);

      end

      else

        DoStateChange([], [tsEditing]);

      if not (tsEditing in FStates) then

        FEditLink := nil;

    end;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.DoEndDrag(Target: TObject; X, Y: Integer);



// Does some housekeeping for VCL drag'n drop;



begin

  inherited;



  DragFinished;

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.DoEndEdit: Boolean;



begin

  StopTimer(EditTimer);

  Result := (tsEditing in FStates) and FEditLink.EndEdit;

  if Result then

  begin

    DoStateChange([], [tsEditing]);

    FEditLink := nil;

    if Assigned(FOnEdited) then

      FOnEdited(Self, FFocusedNode, FEditColumn);

  end;

  DoStateChange([], [tsEditPending]);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.DoEndOperation(OperationKind: TVTOperationKind);



begin

  if Assigned(FOnEndOperation) then

    FOnEndOperation(Self, OperationKind);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.DoEnter();

begin

  inherited;

  EnsureNodeSelected();

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.DoExpanded(Node: PVirtualNode);



begin

  if Assigned(FOnExpanded) then

    FOnExpanded(Self, Node);



  if Assigned(FAccessibleItem) then

    NotifyWinEvent(EVENT_OBJECT_STATECHANGE, Handle, OBJID_CLIENT, CHILDID_SELF);

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.DoExpanding(Node: PVirtualNode): Boolean;



begin

  Result := True;

  if Assigned(FOnExpanding) then

    FOnExpanding(Self, Node, Result);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.DoFocusChange(Node: PVirtualNode; Column: TColumnIndex);



begin

  if Assigned(FOnFocusChanged) then

    FOnFocusChanged(Self, Node, Column);



  if Assigned(FAccessibleItem) then

  begin

    NotifyWinEvent(EVENT_OBJECT_LOCATIONCHANGE, Handle, OBJID_CLIENT, CHILDID_SELF);

    NotifyWinEvent(EVENT_OBJECT_NAMECHANGE, Handle, OBJID_CLIENT, CHILDID_SELF);

    NotifyWinEvent(EVENT_OBJECT_VALUECHANGE, Handle, OBJID_CLIENT, CHILDID_SELF);

    NotifyWinEvent(EVENT_OBJECT_STATECHANGE, Handle, OBJID_CLIENT, CHILDID_SELF);

    NotifyWinEvent(EVENT_OBJECT_SELECTION, Handle, OBJID_CLIENT, CHILDID_SELF);

    NotifyWinEvent(EVENT_OBJECT_FOCUS, Handle, OBJID_CLIENT, CHILDID_SELF);

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.DoFocusChanging(OldNode, NewNode: PVirtualNode; OldColumn, NewColumn: TColumnIndex): Boolean;



begin

  Result := (OldColumn = NewColumn) or FHeader.AllowFocus(NewColumn);

  if Assigned(FOnFocusChanging) then

    FOnFocusChanging(Self, OldNode, NewNode, OldColumn, NewColumn, Result);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.DoFocusNode(Node: PVirtualNode; Ask: Boolean);



begin

  if not (tsEditing in FStates) or EndEditNode then

  begin

    if Node = FRoot then

      Node := nil;

    if (FFocusedNode <> Node) and (not Ask or DoFocusChanging(FFocusedNode, Node, FFocusedColumn, FFocusedColumn)) then

    begin

      if Assigned(FFocusedNode) then

      begin

        // Do automatic collapsing of last focused node if enabled. This is however only done if

        // old and new focused node have a common parent node.

        if (toAutoExpand in FOptions.FAutoOptions) and Assigned(Node) and (Node.Parent = FFocusedNode.Parent) and

          (vsExpanded in FFocusedNode.States) then

          ToggleNode(FFocusedNode)

        else

          InvalidateNode(FFocusedNode);

      end;

      FFocusedNode := Node;

    end;



    // Have to scroll the node into view, even it is the same node as before.

    if Assigned(FFocusedNode) then

    begin

      // Make sure a valid column is set if columns are used and no column has currently the focus.

      if FHeader.UseColumns and (not FHeader.FColumns.IsValidColumn(FFocusedColumn)) then

        FFocusedColumn := FHeader.MainColumn;

      // Do automatic expansion of the newly focused node if enabled.

      if (toAutoExpand in FOptions.FAutoOptions) and not (vsExpanded in FFocusedNode.States) then

        ToggleNode(FFocusedNode);

      InvalidateNode(FFocusedNode);

      if (FUpdateCount = 0) and not (toDisableAutoscrollOnFocus in FOptions.FAutoOptions) then

        ScrollIntoView(FFocusedNode, (toCenterScrollIntoView in FOptions.SelectionOptions) and

          (MouseButtonDown * FStates = []), not (toFullRowSelect in FOptions.SelectionOptions) );

    end;



    // Reset range anchor if necessary.

    if FSelectionCount = 0 then

      ResetRangeAnchor;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.DoFreeNode(Node: PVirtualNode);



begin

  // Prevent invalid references

  if Node = FLastChangedNode then

    FLastChangedNode := nil;

  if Node = FCurrentHotNode then

    FCurrentHotNode := nil;

  if Node = FDropTargetNode then

    FDropTargetNode := nil;

  if Node = FLastStructureChangeNode then

    FLastStructureChangeNode := nil;



  if Node = FNextNodeToSelect then

    FNextNodeToSelect := nil;

  if Self.UpdateCount = 0 then

  begin

    // Omit this stuff if the control is in a BeginUpdate/EndUpdate bracket to increase performance

    // We now try

    // Make sure that CurrentNode does not point to an invalid node

    if (toAlwaysSelectNode in TreeOptions.SelectionOptions) and (Node = GetFirstSelected()) then

    begin

      if Assigned(FNextNodeToSelect) then

        // Select a new node if the currently selected node gets freed

        Selected[FNextNodeToSelect] := True

      else

      begin

        FNextNodeToSelect := Self.NodeParent[GetFirstSelected()];

        if Assigned(FNextNodeToSelect) then

          Selected[FNextNodeToSelect] := True;

      end;//else

    end;//if

  end;



  // fire event

  if Assigned(FOnFreeNode) and ([vsInitialized, vsOnFreeNodeCallRequired] * Node.States <> []) then

    FOnFreeNode(Self, Node);

  FreeMem(Node);

  if Self.UpdateCount = 0 then

    EnsureNodeSelected();

end;



//----------------------------------------------------------------------------------------------------------------------



// These constants are defined in the platform SDK for W2K/XP, but not yet in Delphi.

const

  SPI_GETTOOLTIPANIMATION = $1016;

  SPI_GETTOOLTIPFADE = $1018;



function TBaseVirtualTree.DoGetAnimationType: THintAnimationType;



// Determines (depending on the properties settings and the system) which hint

// animation type is to be used.



var

  Animation: BOOL;



begin

  Result := FAnimationType;

  if Result = hatSystemDefault then

  begin

    SystemParametersInfo(SPI_GETTOOLTIPANIMATION, 0, @Animation, 0);

    if not Animation then

      Result := hatNone

    else

    begin

      SystemParametersInfo(SPI_GETTOOLTIPFADE, 0, @Animation, 0);

      if Animation then

        Result := hatFade

      else

        Result := hatSlide;

    end;

  end;



  // Check availability of MMX if fading is requested.

  if not MMXAvailable and (Result = hatFade) then

    Result := hatSlide;

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.DoGetCellContentMargin(Node: PVirtualNode; Column: TColumnIndex;

  CellContentMarginType: TVTCellContentMarginType = ccmtAllSides; Canvas: TCanvas = nil): TPoint;



// Determines the margins of the content rectangle caused by DoBeforeCellPaint.

// Note that shrinking the content rectangle results in positive margins whereas enlarging the content rectangle results

// in negative margins.



var

  CellRect,

  ContentRect: TRect;



begin

  Result := Point(0, 0);



  if Assigned(FOnBeforeCellPaint) then // Otherwise DoBeforeCellPaint has no effect.

  begin

    if Canvas = nil then

      Canvas := Self.Canvas;



    // Determine then node's cell rectangle and content rectangle before calling DoBeforeCellPaint.

    CellRect := GetDisplayRect(Node, Column, True);

    ContentRect := CellRect;

    DoBeforeCellPaint(Canvas, Node, Column, cpmGetContentMargin, CellRect, ContentRect);



    // Calculate the changes caused by DoBeforeCellPaint.

    case CellContentMarginType of

      ccmtAllSides:

        // Calculate the width difference and high difference.

        Result := Point((CellRect.Right - CellRect.Left) - (ContentRect.Right - ContentRect.Left),

                        (CellRect.Bottom - CellRect.Top) - (ContentRect.Bottom - ContentRect.Top));

      ccmtTopLeftOnly:

        // Calculate the left margin and top margin only.

        Result := Point(ContentRect.Left - CellRect.Left, ContentRect.Top - CellRect.Top);

      ccmtBottomRightOnly:

        // Calculate the right margin and bottom margin only.

        Result := Point(CellRect.Right - ContentRect.Right, CellRect.Bottom - ContentRect.Bottom);

    end;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.DoGetCursor(var Cursor: TCursor);



begin

  if Assigned(FOnGetCursor) then

    FOnGetCursor(Self, Cursor);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.DoGetHeaderCursor(var Cursor: HCURSOR);



begin

  if Assigned(FOnGetHeaderCursor) then

    FOnGetHeaderCursor(FHeader, Cursor);

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.DoGetImageIndex(Node: PVirtualNode; Kind: TVTImageKind; Column: TColumnIndex;

  var Ghosted: Boolean; var Index: Integer): TCustomImageList;



// Queries the application/descendant about certain image properties for a node.

// Returns a custom image list if given by the callee, otherwise nil.



begin

  Result := nil;



  // First try the enhanced event to allow for custom image lists.

  if Assigned(FOnGetImageEx) then

    FOnGetImageEx(Self, Node, Kind, Column, Ghosted, Index, Result)

  else

    if Assigned(FOnGetImage) then

      FOnGetImage(Self, Node, Kind, Column, Ghosted, Index);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.DoGetImageText(Node: PVirtualNode; Kind: TVTImageKind;

  Column: TColumnIndex; var ImageText: UnicodeString);



// Queries the application/descendant about alternative image text for a node.



begin

  if Assigned(FOnGetImageText) then

     FOnGetImageText(Self, Node, Kind, Column, ImageText);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.DoGetLineStyle(var Bits: Pointer);



begin

  if Assigned(FOnGetLineStyle) then

    FOnGetLineStyle(Self, Bits);

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.DoGetNodeHint(Node: PVirtualNode; Column: TColumnIndex;

  var LineBreakStyle: TVTTooltipLineBreakStyle): UnicodeString;



begin

  Result := Hint;

  LineBreakStyle := hlbDefault;

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.DoGetNodeTooltip(Node: PVirtualNode; Column: TColumnIndex;

  var LineBreakStyle: TVTTooltipLineBreakStyle): UnicodeString;



begin

  Result := Hint;

  LineBreakStyle := hlbDefault;

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.DoGetNodeExtraWidth(Node: PVirtualNode; Column: TColumnIndex; Canvas: TCanvas = nil): Integer;



// Returns the pixel width of extra space occupied by node contents (for example, static text).



begin

  Result := 0;

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.DoGetNodeWidth(Node: PVirtualNode; Column: TColumnIndex; Canvas: TCanvas = nil): Integer;



// Returns the pixel width of a node.



begin

  Result := 0;

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.DoGetPopupMenu(Node: PVirtualNode; Column: TColumnIndex; Position: TPoint): TPopupMenu;



// Queries the application whether there is a node specific popup menu.



var

  Run: PVirtualNode;

  AskParent: Boolean;



begin

  Result := nil;

  if Assigned(FOnGetPopupMenu) then

  begin

    Run := Node;



    if Assigned(Run) then

    begin

      AskParent := True;

      repeat

        FOnGetPopupMenu(Self, Run, Column, Position, AskParent, Result);

        Run := Run.Parent;

      until (Run = FRoot) or Assigned(Result) or not AskParent;

    end

    else

      FOnGetPopupMenu(Self, nil, -1, Position, AskParent, Result);

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.DoGetUserClipboardFormats(var Formats: TFormatEtcArray);



begin

  if Assigned(FOnGetUserClipboardFormats) then

    FOnGetUserClipboardFormats(Self, Formats);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.DoHeaderClick(HitInfo: TVTHeaderHitInfo);



begin

  if Assigned(FOnHeaderClick) then

    FOnHeaderClick(FHeader, HitInfo);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.DoHeaderDblClick(HitInfo: TVTHeaderHitInfo);



begin

  if Assigned(FOnHeaderDblClick) then

    FOnHeaderDblClick(FHeader, HitInfo);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.DoHeaderDragged(Column: TColumnIndex; OldPosition: TColumnPosition);



begin

  if Assigned(FOnHeaderDragged) then

    FOnHeaderDragged(FHeader, Column, OldPosition);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.DoHeaderDraggedOut(Column: TColumnIndex; DropPosition: TPoint);



begin

  if Assigned(FOnHeaderDraggedOut) then

    FOnHeaderDraggedOut(FHeader, Column, DropPosition);

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.DoHeaderDragging(Column: TColumnIndex): Boolean;



begin

  Result := True;

  if Assigned(FOnHeaderDragging) then

    FOnHeaderDragging(FHeader, Column, Result);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.DoHeaderDraw(Canvas: TCanvas; Column: TVirtualTreeColumn; R: TRect; Hover, Pressed: Boolean;

  DropMark: TVTDropMarkMode);



begin

  if Assigned(FOnHeaderDraw) then

    FOnHeaderDraw(FHeader, Canvas, Column, R, Hover, Pressed, DropMark);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.DoHeaderDrawQueryElements(var PaintInfo: THeaderPaintInfo; var Elements: THeaderPaintElements);



begin

  if Assigned(FOnHeaderDrawQueryElements) then

    FOnHeaderDrawQueryElements(FHeader, PaintInfo, Elements);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.DoHeaderMouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);



begin

  if Assigned(FOnHeaderMouseDown) then

    FOnHeaderMouseDown(FHeader, Button, Shift, X, Y);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.DoHeaderMouseMove(Shift: TShiftState; X, Y: Integer);



begin

  if Assigned(FOnHeaderMouseMove) then

    FOnHeaderMouseMove(FHeader, Shift, X, Y);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.DoHeaderMouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);



begin

  if Assigned(FOnHeaderMouseUp) then

    FOnHeaderMouseUp(FHeader, Button, Shift, X, Y);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.DoHotChange(Old, New: PVirtualNode);



begin

  if Assigned(FOnHotChange) then

    FOnHotChange(Self, Old, New);

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.DoIncrementalSearch(Node: PVirtualNode; const Text: UnicodeString): Integer;



begin

  Result := 0;

  if Assigned(FOnIncrementalSearch) then

    FOnIncrementalSearch(Self, Node, Text, Result);

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.DoInitChildren(Node: PVirtualNode; var ChildCount: Cardinal): Boolean;

/// The function calls the OnInitChildren and returns True if the event was called; it returns False if the caller can expect that no changes have been made to ChildCount

begin

  if Assigned(FOnInitChildren) then

  begin

    FOnInitChildren(Self, Node, ChildCount);

    Result := True;

  end

  else

    Result := False;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.DoInitNode(Parent, Node: PVirtualNode; var InitStates: TVirtualNodeInitStates);



begin

  if Assigned(FOnInitNode) then

    FOnInitNode(Self, Parent, Node, InitStates);

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.DoKeyAction(var CharCode: Word; var Shift: TShiftState): Boolean;



begin

  Result := True;

  if Assigned(FOnKeyAction) then

    FOnKeyAction(Self, CharCode, Shift, Result);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.DoLoadUserData(Node: PVirtualNode; Stream: TStream);



begin

  if Assigned(FOnLoadNode) then

    if Node = FRoot then

      FOnLoadNode(Self, nil, Stream)

    else

      FOnLoadNode(Self, Node, Stream);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.DoMeasureItem(TargetCanvas: TCanvas; Node: PVirtualNode; var NodeHeight: Integer);



begin

  if Assigned(FOnMeasureItem) then

    FOnMeasureItem(Self, TargetCanvas, Node, NodeHeight);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.DoMouseEnter();



begin

  if Assigned(FOnMouseEnter) then

    FOnMouseEnter(Self);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.DoMouseLeave;



begin

  if Assigned(FOnMouseLeave) then

    FOnMouseLeave(Self);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.DoNodeCopied(Node: PVirtualNode);



begin

  if Assigned(FOnNodeCopied) then

    FOnNodeCopied(Self, Node);

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.DoNodeCopying(Node, NewParent: PVirtualNode): Boolean;



begin

  Result := True;

  if Assigned(FOnNodeCopying) then

    FOnNodeCopying(Self, Node, NewParent, Result);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.DoNodeClick(const HitInfo: THitInfo);



begin

  if Assigned(FOnNodeClick) then

    FOnNodeClick(Self, HitInfo);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.DoNodeDblClick(const HitInfo: THitInfo);



begin

  if Assigned(FOnNodeDblClick) then

    FOnNodeDblClick(Self, HitInfo);

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.DoNodeHeightDblClickResize(Node: PVirtualNode; Column: TColumnIndex; Shift: TShiftState;

  P: TPoint): Boolean;



begin

  Result := True;

  if Assigned(FOnNodeHeightDblClickResize) then

    FOnNodeHeightDblClickResize(Self, Node, Column, Shift, P, Result);

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.DoNodeHeightTracking(Node: PVirtualNode; Column: TColumnIndex; Shift: TShiftState;

  var TrackPoint: TPoint; P: TPoint): Boolean;



begin

  Result := True;

  if Assigned(FOnNodeHeightTracking) then

    FOnNodeHeightTracking(Self, Node, Column, Shift, TrackPoint, P, Result);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.DoNodeMoved(Node: PVirtualNode);



begin

  if Assigned(FOnNodeMoved) then

    FOnNodeMoved(Self, Node);

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.DoNodeMoving(Node, NewParent: PVirtualNode): Boolean;



begin

  Result := True;

  if Assigned(FOnNodeMoving) then

    FOnNodeMoving(Self, Node, NewParent, Result);

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.DoPaintBackground(Canvas: TCanvas; R: TRect): Boolean;



begin

  Result := False;

  if Assigned(FOnPaintBackground) then

    FOnPaintBackground(Self, Canvas, R, Result);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.DoPaintDropMark(Canvas: TCanvas; Node: PVirtualNode; R: TRect);



// draws the drop mark into the given rectangle

// Note: Changed properties of the given canvas should be reset to their previous values.



var

  SaveBrushColor: TColor;

  SavePenStyle: TPenStyle;



begin

  if FLastDropMode in [dmAbove, dmBelow] then

    with Canvas do

    begin

      SavePenStyle := Pen.Style;

      Pen.Style := psClear;

      SaveBrushColor := Brush.Color;

      Brush.Color := FColors.DropMarkColor;



      if FLastDropMode = dmAbove then

      begin

        Polygon([Point(R.Left + 2, R.Top),

                 Point(R.Right - 2, R.Top),

                 Point(R.Right - 2, R.Top + 6),

                 Point(R.Right - 6, R.Top + 2),

                 Point(R.Left + 6 , R.Top + 2),

                 Point(R.Left + 2, R.Top + 6)

        ]);

      end

      else

        Polygon([Point(R.Left + 2, R.Bottom - 1),

                 Point(R.Right - 2, R.Bottom - 1),

                 Point(R.Right - 2, R.Bottom - 8),

                 Point(R.Right - 7, R.Bottom - 3),

                 Point(R.Left + 7 , R.Bottom - 3),

                 Point(R.Left + 2, R.Bottom - 8)

        ]);

      Brush.Color := SaveBrushColor;

      Pen.Style := SavePenStyle;

    end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.DoPaintNode(var PaintInfo: TVTPaintInfo);



begin

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.DoPopupMenu(Node: PVirtualNode; Column: TColumnIndex; Position: TPoint);



// Support for node dependent popup menus.



var

  Menu: TPopupMenu;



begin

  Menu := DoGetPopupMenu(Node, Column, Position);



  if Assigned(Menu) then

  begin

    DoStateChange([tsPopupMenuShown]);

    StopTimer(EditTimer);

    Menu.PopupComponent := Self;

    with ClientToScreen(Position) do

      Menu.Popup(X, Y);

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.DoRemoveFromSelection(Node: PVirtualNode);



begin

  if Assigned(FOnRemoveFromSelection) then

    FOnRemoveFromSelection(Self, Node);

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.DoRenderOLEData(const FormatEtcIn: TFormatEtc; out Medium: TStgMedium;

  ForClipboard: Boolean): HRESULT;



begin

  Result := E_FAIL;

  if Assigned(FOnRenderOLEData) then

    FOnRenderOLEData(Self, FormatEtcIn, Medium, ForClipboard, Result);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.DoReset(Node: PVirtualNode);



begin

  if Assigned(FOnResetNode) then

    FOnResetNode(Self, Node);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.DoSaveUserData(Node: PVirtualNode; Stream: TStream);



begin

  if Assigned(FOnSaveNode) then

    if Node = FRoot then

      FOnSaveNode(Self, nil, Stream)

    else

      FOnSaveNode(Self, Node, Stream);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.DoScroll(DeltaX, DeltaY: Integer);



begin

  if Assigned(FOnScroll) then

    FOnScroll(Self, DeltaX, DeltaY);

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.DoSetOffsetXY(Value: TPoint; Options: TScrollUpdateOptions; ClipRect: PRect = nil): Boolean;



// Actual offset setter used to scroll the client area, update scroll bars and invalidating the header (all optional).

// Returns True if the offset really changed otherwise False is returned.



var

  DeltaX: Integer;

  DeltaY: Integer;

  DWPStructure: HDWP;

  I: Integer;

  P: TPoint;

  R: TRect;



begin

  // Range check, order is important here.

  if Value.X < (ClientWidth - Integer(FRangeX)) then

    Value.X := ClientWidth - Integer(FRangeX);

  if Value.X > 0 then

    Value.X := 0;

  DeltaX := Value.X - FOffsetX;

  if UseRightToLeftAlignment then

    DeltaX := -DeltaX;

  if Value.Y < (ClientHeight - Integer(FRangeY)) then

    Value.Y := ClientHeight - Integer(FRangeY);

  if Value.Y > 0 then

    Value.Y := 0;

  DeltaY := Value.Y - FOffsetY;



  Result := (DeltaX <> 0) or (DeltaY <> 0);

  if Result then

  begin

    FOffsetX := Value.X;

    FOffsetY := Value.Y;

    Result := True;



    if tsHint in Self.FStates then

      Application.CancelHint;

    if FUpdateCount = 0 then

    begin

      // The drag image from VCL controls need special consideration.

      if tsVCLDragging in FStates then

        ImageList_DragShowNolock(False);



      if (suoScrollClientArea in Options) and not (tsToggling in FStates) then

      begin

        // Have to invalidate the entire window if there's a background.

        if (toShowBackground in FOptions.FPaintOptions) and (FBackground.Graphic is TBitmap) then

        begin

          // Since we don't use ScrollWindow here we have to move all client windows ourselves.

          DWPStructure := BeginDeferWindowPos(ControlCount);

          for I := 0 to ControlCount - 1 do

            if Controls[I] is TWinControl then

            begin

              with Controls[I] as TWinControl do

                DWPStructure := DeferWindowPos(DWPStructure, Handle, 0, Left + DeltaX, Top + DeltaY, 0, 0,

                  SWP_NOZORDER or SWP_NOACTIVATE or SWP_NOSIZE);

              if DWPStructure = 0 then

                Break;

            end;

          if DWPStructure <> 0 then

            EndDeferWindowPos(DWPStructure);

          InvalidateRect(Handle, nil, False);

        end

        else

        begin

          if (DeltaX <> 0) and (Header.Columns.GetVisibleFixedWidth > 0) then

          begin

            // When fixed columns exists we have to scroll separately horizontally and vertically.

            // Horizontally is scroll only the client area not occupied by fixed columns and

            // vertically entire client area (or clipping area if one exists).

            R := ClientRect;

            R.Left := Header.Columns.GetVisibleFixedWidth;



            ScrollWindow(Handle, DeltaX, 0, @R, @R);

            if DeltaY <> 0 then

              ScrollWindow(Handle, 0, DeltaY, ClipRect, ClipRect);

          end

          else

            ScrollWindow(Handle, DeltaX, DeltaY, ClipRect, ClipRect);

        end;

      end;



      if suoUpdateNCArea in Options then

      begin

        if DeltaX <> 0 then

        begin

          if (suoRepaintHeader in Options) and (hoVisible in FHeader.FOptions) then

            FHeader.Invalidate(nil);

          if not (tsSizing in FStates) and (FScrollBarOptions.ScrollBars in [{$if CompilerVersion >= 24}System.UITypes.TScrollStyle.{$ifend}ssHorizontal, {$if CompilerVersion >= 24}System.UITypes.TScrollStyle.{$ifend}ssBoth]) then

            UpdateHorizontalScrollBar(suoRepaintScrollBars in Options);

        end;



        if (DeltaY <> 0) and ([tsThumbTracking, tsSizing] * FStates = []) then

        begin

          UpdateVerticalScrollBar(suoRepaintScrollBars in Options);

          if not (FHeader.UseColumns or IsMouseSelecting) and

            (FScrollBarOptions.ScrollBars in [{$if CompilerVersion >= 24}System.UITypes.TScrollStyle.{$ifend}ssHorizontal, {$if CompilerVersion >= 24}System.UITypes.TScrollStyle.{$ifend}ssBoth]) then

            UpdateHorizontalScrollBar(suoRepaintScrollBars in Options);

        end;

      end;



      if tsVCLDragging in FStates then

        ImageList_DragShowNolock(True);

    end;



    // Finally update "hot" node if hot tracking is activated

    GetCursorPos(P);

    P := ScreenToClient(P);

    if PtInRect(ClientRect, P) then

      HandleHotTrack(P.X, P.Y);



    DoScroll(DeltaX, DeltaY);

    Perform(CM_UPDATE_VCLSTYLE_SCROLLBARS,0,0);

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.DoShowScrollBar(Bar: Integer; Show: Boolean);



begin

  ShowScrollBar(Handle, Bar, Show);

  if Assigned(FOnShowScrollBar) then

    FOnShowScrollBar(Self, Bar, Show);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.DoStartDrag(var DragObject: TDragObject);



begin

  inherited;



  // Check if the application created an own drag object. This is needed to pass the correct source in

  // OnDragOver and OnDragDrop.

  if Assigned(DragObject) then

    DoStateChange([tsUserDragObject]);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.DoStartOperation(OperationKind: TVTOperationKind);



begin

  if Assigned(FOnStartOperation) then

    FOnStartOperation(Self, OperationKind);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.DoStateChange(Enter: TVirtualTreeStates; Leave: TVirtualTreeStates = []);



var

  ActualEnter,

  ActualLeave: TVirtualTreeStates;



begin

  if Assigned(FOnStateChange) then

  begin

    ActualEnter := Enter - FStates;

    ActualLeave := FStates * Leave;

    if (ActualEnter + ActualLeave) <> [] then

      FOnStateChange(Self, Enter, Leave);

  end;

  FStates := FStates + Enter - Leave;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.DoStructureChange(Node: PVirtualNode; Reason: TChangeReason);



begin

  StopTimer(StructureChangeTimer);

  if Assigned(FOnStructureChange) then

    FOnStructureChange(Self, Node, Reason);



  // This is a good place to reset the cached node and reason. These are the same as the values passed in here.

  // This is necessary to allow descendants to override this method and get them.

  DoStateChange([], [tsStructureChangePending]);

  FLastStructureChangeNode := nil;

  FLastStructureChangeReason := crIgnore;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.DoTimerScroll;



var

  P,

  ClientP: TPoint;

  InRect,

  Panning: Boolean;

  R,

  ClipRect: TRect;

  DeltaX,

  DeltaY: Integer;



begin

  GetCursorPos(P);

  R := ClientRect;

  ClipRect := R;

  MapWindowPoints(Handle, 0, R, 2);

  InRect := PtInRect(R, P);

  ClientP := ScreenToClient(P);

  Panning := [tsWheelPanning, tsWheelScrolling] * FStates <> [];



  if IsMouseSelecting or InRect or Panning then

  begin

    DeltaX := 0;

    DeltaY := 0;

    if sdUp in FScrollDirections then

    begin

      if Panning then

        DeltaY := FLastClickPos.Y - ClientP.Y - 8

      else

        if InRect then

          DeltaY := Min(FScrollBarOptions.FIncrementY, ClientHeight)

        else

          DeltaY := Min(FScrollBarOptions.FIncrementY, ClientHeight) * Abs(R.Top - P.Y);

      if FOffsetY = 0 then

        Exclude(FScrollDirections, sdUp);

    end;



    if sdDown in FScrollDirections then

    begin

      if Panning then

        DeltaY := FLastClickPos.Y - ClientP.Y + 8

      else

        if InRect then

          DeltaY := -Min(FScrollBarOptions.FIncrementY, ClientHeight)

        else

          DeltaY := -Min(FScrollBarOptions.FIncrementY, ClientHeight) * Abs(P.Y - R.Bottom);

      if (ClientHeight - FOffsetY) = Integer(FRangeY) then

        Exclude(FScrollDirections, sdDown);

    end;



    if sdLeft in FScrollDirections then

    begin

      if Panning then

        DeltaX := FLastClickPos.X - ClientP.X - 8

      else

        if InRect then

          DeltaX := FScrollBarOptions.FIncrementX

        else

          DeltaX := FScrollBarOptions.FIncrementX * Abs(R.Left - P.X);

      if FEffectiveOffsetX = 0 then

        Exclude(FScrollDirections, sdleft);

    end;



    if sdRight in FScrollDirections then

    begin

      if Panning then

        DeltaX := FLastClickPos.X - ClientP.X + 8

      else

        if InRect then

          DeltaX := -FScrollBarOptions.FIncrementX

        else

          DeltaX := -FScrollBarOptions.FIncrementX * Abs(P.X - R.Right);



      if (ClientWidth + FEffectiveOffsetX) = Integer(FRangeX) then

        Exclude(FScrollDirections, sdRight);

    end;



    if UseRightToLeftAlignment then

      DeltaX := - DeltaX;



    if IsMouseSelecting then

    begin

      // In order to avoid scrolling the area which needs a repaint due to the changed selection rectangle

      // we limit the scroll area explicitely.

      OffsetRect(ClipRect, DeltaX, DeltaY);

      DoSetOffsetXY(Point(FOffsetX + DeltaX, FOffsetY + DeltaY), DefaultScrollUpdateFlags, @ClipRect);

      // When selecting with the mouse then either update only the parts of the window which have been uncovered

      // by the scroll operation if no change in the selection happend or invalidate and redraw the entire

      // client area otherwise (to avoid the time consuming task of determining the display rectangles of every

      // changed node).

      if CalculateSelectionRect(ClientP.X, ClientP.Y) and HandleDrawSelection(ClientP.X, ClientP.Y) then

        InvalidateRect(Handle, nil, False)

      else

      begin

        // The selection did not change so invalidate only the part of the window which really needs an update.

        // 1) Invalidate the parts uncovered by the scroll operation. Add another offset range, we have to

        //    scroll only one stripe but have to update two.

        OffsetRect(ClipRect, DeltaX, DeltaY);

        SubtractRect(ClipRect, ClientRect, ClipRect);

        InvalidateRect(Handle, @ClipRect, False);



        // 2) Invalidate the selection rectangles.

        UnionRect(ClipRect, OrderRect(FNewSelRect), OrderRect(FLastSelRect));

        OffsetRect(ClipRect, FOffsetX, FOffsetY);

        InvalidateRect(Handle, @ClipRect, False);

      end;

    end

    else

    begin

      // Scroll only if there is no drag'n drop in progress. Drag'n drop scrolling is handled in DragOver.

      if ((FDragManager = nil) or not DragManager.IsDropTarget) and ((DeltaX <> 0) or (DeltaY <> 0)) then

        DoSetOffsetXY(Point(FOffsetX + DeltaX, FOffsetY + DeltaY), DefaultScrollUpdateFlags, nil);

    end;

    UpdateWindow(Handle);



    if (FScrollDirections = []) and ([tsWheelPanning, tsWheelScrolling] * FStates = []) then

    begin

      StopTimer(ScrollTimer);

      DoStateChange([], [tsScrollPending, tsScrolling]);

    end;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.DoUpdating(State: TVTUpdateState);



begin

  if Assigned(FOnUpdating) then

    FOnUpdating(Self, State);

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.DoValidateCache: Boolean;



// This method fills the cache, which is used to speed up searching for nodes.

// The strategy is simple: Take the current number of visible nodes and distribute evenly a number of marks

// (which are stored in FPositionCache) so that iterating through the tree doesn't cost too much time.

// If there are less than 'CacheThreshold' nodes in the tree then the cache remains empty.

// Result is True if the cache was filled without interruption, otherwise False.

// Note: You can adjust the maximum number of nodes between two cache entries by changing CacheThreshold.



var

  EntryCount,

  CurrentTop,

  Index: Cardinal;

  CurrentNode,

  Temp: PVirtualNode;



begin

  EntryCount := 0;

  if not (tsStopValidation in FStates) then

  begin

    if FStartIndex = 0 then

      FPositionCache := nil;



    EntryCount := CalculateCacheEntryCount;

    SetLength(FPositionCache, EntryCount);

    if FStartIndex > EntryCount then

      FStartIndex := EntryCount;



    // Optimize validation by starting with FStartIndex if set.

    if (FStartIndex > 0) and Assigned(FPositionCache[FStartIndex - 1].Node) then

    begin

      // Index is the current entry in FPositionCache.

      Index := FStartIndex - 1;

      // Running term for absolute top value.

      CurrentTop := FPositionCache[Index].AbsoluteTop;

      // Running node pointer.

      CurrentNode := FPositionCache[Index].Node;

    end

    else

    begin

      // Index is the current entry in FPositionCache.

      Index := 0;

      // Running term for absolute top value.

      CurrentTop := 0;

      // Running node pointer.

      CurrentNode := GetFirstVisibleNoInit(nil, True);

    end;



    // EntryCount serves as counter for processed nodes here. This value can always start at 0 as

    // the validation either starts also at index 0 or an index which is always a multiple of CacheThreshold

    // and EntryCount is only used with modulo CacheThreshold.

    EntryCount := 0;

    if Assigned(CurrentNode) then

    begin

      while not (tsStopValidation in FStates) do

      begin

        // If the cache is full then stop the loop.

        if (Integer(Index) > Length(FPositionCache)) then    // ADDED: 17.09.2013 - Veit Zimmermann

          Break;                                             // ADDED: 17.09.2013 - Veit Zimmermann

        if (EntryCount mod CacheThreshold) = 0 then

        begin

          // New cache entry to set up.

          with FPositionCache[Index] do

          begin

            Node := CurrentNode;

            AbsoluteTop := CurrentTop;

          end;

          Inc(Index);

        end;



        Inc(CurrentTop, NodeHeight[CurrentNode]);

        // Advance to next visible node.

        Temp := GetNextVisibleNoInit(CurrentNode, True);

        // If there is no further node then stop the loop.

        if (Temp = nil) then       // CHANGED: 17.09.2013 - Veit Zimmermann

          Break;                   // CHANGED: 17.09.2013 - Veit Zimmermann



        CurrentNode := Temp;

        Inc(EntryCount);

      end;

    end;

    // Finalize the position cache so no nil entry remains there.

    if not (tsStopValidation in FStates) and (Integer(Index) <= High(FPositionCache)) then

    begin

      SetLength(FPositionCache, Index + 1);

      with FPositionCache[Index] do

      begin

        Node := CurrentNode;

        AbsoluteTop := CurrentTop;

      end;

    end;

  end;



  Result := (EntryCount > 0) and not (tsStopValidation in FStates);



  // In variable node height mode it might have happend that some or all of the nodes have been adjusted in their

  // height. During validation updates of the scrollbars is disabled so let's do this here.

  if Result and (toVariableNodeHeight in FOptions.FMiscOptions) then

  begin

    UpdateScrollBars(True);

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.DragAndDrop(AllowedEffects: Dword; DataObject: IDataObject; var DragEffect: LongInt);

{$IF CompilerVersion >= 22}

var

  lDragEffect: DWord; // required for type compatibility with SHDoDragDrop

{$ifend}

begin

  {$IF CompilerVersion >= 22}

  if IsWinVistaOrAbove then

  begin

    lDragEffect := DWord(DragEffect);

    SHDoDragDrop(Self.Handle, DataObject, nil, AllowedEffects, lDragEffect); // supports drag hints on Windows Vista and later

    DragEffect := LongInt(lDragEffect);

  end

  else

  {$ifend}

  ActiveX.DoDragDrop(DataObject, DragManager as IDropSource, AllowedEffects, DragEffect);

 end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.DragCanceled;



// Does some housekeeping for VCL drag'n drop;



begin

  inherited;



  DragFinished;

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.DragDrop(const DataObject: IDataObject; KeyState: Integer; Pt: TPoint;

  var Effect: Integer): HResult;



var

  Shift: TShiftState;

  EnumFormat: IEnumFormatEtc;

  Fetched: Integer;

  OLEFormat: TFormatEtc;

  Formats: TFormatArray;



begin

  StopTimer(ExpandTimer);

  StopTimer(ScrollTimer);

  DoStateChange([], [tsScrollPending, tsScrolling]);

  Formats := nil;



  // Ask explicitly again whether the action is allowed. Otherwise we may accept a drop which is intentionally not

  // allowed but cannot be prevented by the application because when the tree was scrolling while dropping

  // no DragOver event is created by the OLE subsystem.

  Result := DragOver(DragManager.DragSource, KeyState, dsDragMove, Pt, Effect);

  try

    if (Result <> NOERROR) or ((Effect and not DROPEFFECT_SCROLL) = DROPEFFECT_NONE) then

      Result := E_FAIL

    else

    begin

      try

        Shift := KeysToShiftState(KeyState);

        if tsLeftButtonDown in FStates then

          Include(Shift, ssLeft);

        if tsMiddleButtonDown in FStates then

          Include(Shift, ssMiddle);

        if tsRightButtonDown in FStates then

          Include(Shift, ssRight);

        Pt := ScreenToClient(Pt);

        // Determine which formats we can get and pass them along with the data object to the drop handler.

        Result := DataObject.EnumFormatEtc(DATADIR_GET, EnumFormat);

        if Failed(Result) then

          Abort;

        Result := EnumFormat.Reset;

        if Failed(Result) then

          Abort;

        // create a list of available formats

        while EnumFormat.Next(1, OLEFormat, @Fetched) = S_OK do

        begin

          SetLength(Formats, Length(Formats) + 1);

          Formats[High(Formats)] := OLEFormat.cfFormat;

        end;

        DoDragDrop(DragManager.DragSource, DataObject, Formats, Shift, Pt, Effect, FLastDropMode);

      except

        // An unhandled exception here leaks memory.

        Application.HandleException(Self);

        Result := E_UNEXPECTED;

      end;

    end;

  finally

    if Assigned(FDropTargetNode) then

    begin

      InvalidateNode(FDropTargetNode);

      FDropTargetNode := nil;

    end;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.DragEnter(KeyState: Integer; Pt: TPoint; var Effect: Integer): HResult;



// callback routine for the drop target interface



var

  Shift: TShiftState;

  Accept: Boolean;

  R: TRect;

  HitInfo: THitInfo;



begin

  try

    // Determine acceptance of drag operation and reset scroll start time.

    FDragScrollStart := 0;



    Shift := KeysToShiftState(KeyState);

    if tsLeftButtonDown in FStates then

      Include(Shift, ssLeft);

    if tsMiddleButtonDown in FStates then

      Include(Shift, ssMiddle);

    if tsRightButtonDown in FStates then

      Include(Shift, ssRight);

    Pt := ScreenToClient(Pt);

    Effect := SuggestDropEffect(DragManager.DragSource, Shift, Pt, Effect);

    Accept := DoDragOver(DragManager.DragSource, Shift, dsDragEnter, Pt, FLastDropMode, Effect);

    if not Accept then

      Effect := DROPEFFECT_NONE

    else

    begin

      // Set initial drop target node and drop mode.

      GetHitTestInfoAt(Pt.X, Pt.Y, True, HitInfo);

      if Assigned(HitInfo.HitNode) then

      begin

        FDropTargetNode := HitInfo.HitNode;

        R := GetDisplayRect(HitInfo.HitNode, FHeader.MainColumn, False);

        if (hiOnItemLabel in HitInfo.HitPositions) or ((hiOnItem in HitInfo.HitPositions) and

          ((toFullRowDrag in FOptions.FMiscOptions) or (toFullRowSelect in FOptions.FSelectionOptions)))then

          FLastDropMode := dmOnNode

        else

          if ((R.Top + R.Bottom) div 2) > Pt.Y then

            FLastDropMode := dmAbove

          else

            FLastDropMode := dmBelow;

      end

      else

        FLastDropMode := dmNowhere;

    end;



    // If the drag source is a virtual tree then we know how to control the drag image

    // and can show it even if the source is not the target tree.

    // This is only necessary if we cannot use the drag image helper interfaces.

    if not DragManager.DropTargetHelperSupported and Assigned(DragManager.DragSource) then

      DragManager.DragSource.FDragImage.ShowDragImage;

    Result := NOERROR;

  except

    Result := E_UNEXPECTED;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.DragFinished;



// Called by DragCancelled or EndDrag to make up for the still missing mouse button up messages.

// These are important for such important things like popup menus.



var

  P: TPoint;



begin

  if [tsOLEDragging, tsVCLDragPending, tsVCLDragging, tsVCLDragFinished] * FStates = [] then

    Exit;



  DoStateChange([], [tsVCLDragPending, tsVCLDragging, tsUserDragObject, tsVCLDragFinished]);



  GetCursorPos(P);

  P := ScreenToClient(P);

  if tsRightButtonDown in FStates then

    Perform(WM_RBUTTONUP, 0, LPARAM(Longint(PointToSmallPoint(P))))

  else

    if tsMiddleButtonDown in FStates then

      Perform(WM_MBUTTONUP, 0, LPARAM(Longint(PointToSmallPoint(P))))

    else

      Perform(WM_LBUTTONUP, 0, LPARAM(Longint(PointToSmallPoint(P))));

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.DragLeave;



var

  Effect: Integer;



begin

  StopTimer(ExpandTimer);



  if not DragManager.DropTargetHelperSupported and Assigned(DragManager.DragSource) then

    DragManager.DragSource.FDragImage.HideDragImage;



  if Assigned(FDropTargetNode) then

  begin

    InvalidateNode(FDropTargetNode);

    FDropTargetNode := nil;

  end;

  UpdateWindow(Handle);



  Effect := 0;

  DoDragOver(nil, [], dsDragLeave, Point(0, 0), FLastDropMode, Effect);

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.DragOver(Source: TObject; KeyState: Integer; DragState: TDragState; Pt: TPoint;

  var Effect: LongInt): HResult;



// callback routine for the drop target interface



var

  Shift: TShiftState;

  Accept,

  DragImageWillMove,

  WindowScrolled: Boolean;

  OldR, R: TRect;

  NewDropMode: TDropMode;

  HitInfo: THitInfo;

  DragPos: TPoint;

  Tree: TBaseVirtualTree;

  LastNode: PVirtualNode;

  DeltaX,

  DeltaY: Integer;

  ScrollOptions: TScrollUpdateOptions;



begin

  if not DragManager.DropTargetHelperSupported and (Source is TBaseVirtualTree) then

  begin

    Tree := Source as TBaseVirtualTree;

    ScrollOptions := [suoUpdateNCArea];

  end

  else

  begin

    Tree := nil;

    ScrollOptions := DefaultScrollUpdateFlags;

  end;



  try

    DragPos := Pt;

    Pt := ScreenToClient(Pt);



    // Check if we have to scroll the client area.

    FScrollDirections := DetermineScrollDirections(Pt.X, Pt.Y);

    DeltaX := 0;

    DeltaY := 0;

    if FScrollDirections <> [] then

    begin

      // Determine amount to scroll.

      if sdUp in FScrollDirections then

      begin

        DeltaY := Min(FScrollBarOptions.FIncrementY, ClientHeight);

        if FOffsetY = 0 then

          Exclude(FScrollDirections, sdUp);

      end;

      if sdDown in FScrollDirections then

      begin

        DeltaY := -Min(FScrollBarOptions.FIncrementY, ClientHeight);

        if (ClientHeight - FOffsetY) = Integer(FRangeY) then

          Exclude(FScrollDirections, sdDown);

      end;

      if sdLeft in FScrollDirections then

      begin

        DeltaX := FScrollBarOptions.FIncrementX;

        if FEffectiveOffsetX = 0 then

          Exclude(FScrollDirections, sdleft);

      end;

      if sdRight in FScrollDirections then

      begin

        DeltaX := -FScrollBarOptions.FIncrementX;

        if (ClientWidth + FEffectiveOffsetX) = Integer(FRangeX) then

          Exclude(FScrollDirections, sdRight);

      end;

      WindowScrolled := DoSetOffsetXY(Point(FOffsetX + DeltaX, FOffsetY + DeltaY), ScrollOptions, nil);

    end

    else

      WindowScrolled := False;



    // Determine acceptance of drag operation as well as drag target.

    Shift := KeysToShiftState(KeyState);

    if tsLeftButtonDown in FStates then

      Include(Shift, ssLeft);

    if tsMiddleButtonDown in FStates then

      Include(Shift, ssMiddle);

    if tsRightButtonDown in FStates then

      Include(Shift, ssRight);

    GetHitTestInfoAt(Pt.X, Pt.Y, True, HitInfo);



    if Assigned(HitInfo.HitNode) then

      R := GetDisplayRect(HitInfo.HitNode, NoColumn, False)

    else

      R := Rect(0, 0, 0, 0);

    NewDropMode := DetermineDropMode(Pt, HitInfo, R);



    if Assigned(Tree) then

      DragImageWillMove := Tree.FDragImage.WillMove(DragPos)

    else

      DragImageWillMove := False;



    if (HitInfo.HitNode <> FDropTargetNode) or (FLastDropMode <> NewDropMode) then

    begin

      // Something in the tree will change. This requires to update the screen and/or the drag image.

      FLastDropMode := NewDropMode;

      if HitInfo.HitNode <> FDropTargetNode then

      begin

        StopTimer(ExpandTimer);

        // The last target node is needed for the rectangle determination but must already be set for

        // the recapture call, hence it must be stored somewhere.

        LastNode := FDropTargetNode;

        FDropTargetNode := HitInfo.HitNode;

        // In order to show a selection rectangle a column must be focused.

        if FFocusedColumn <= NoColumn then

          FFocusedColumn := FHeader.MainColumn;



        if Assigned(LastNode) and Assigned(FDropTargetNode) then

        begin

          // Optimize the case that the selection moved between two nodes.

          OldR := GetDisplayRect(LastNode, NoColumn, False);

          UnionRect(R, R, OldR);

          if Assigned(Tree) then

          begin

            if WindowScrolled then

              UpdateWindowAndDragImage(Tree, ClientRect, True, not DragImageWillMove)

            else

              UpdateWindowAndDragImage(Tree, R, False, not DragImageWillMove);

          end

          else

            InvalidateRect(Handle, @R, False);

        end

        else

        begin

          if Assigned(LastNode) then

          begin

            // Repaint last target node.

            OldR := GetDisplayRect(LastNode, NoColumn, False);

            if Assigned(Tree) then

            begin

              if WindowScrolled then

                UpdateWindowAndDragImage(Tree, ClientRect, WindowScrolled, not DragImageWillMove)

              else

                UpdateWindowAndDragImage(Tree, OldR, False, not DragImageWillMove);

            end

            else

              InvalidateRect(Handle, @OldR, False);

          end

          else

          begin

            if Assigned(Tree) then

            begin

              if WindowScrolled then

                UpdateWindowAndDragImage(Tree, ClientRect, WindowScrolled, not DragImageWillMove)

              else

                UpdateWindowAndDragImage(Tree, R, False, not DragImageWillMove);

            end

            else

              InvalidateRect(Handle, @R, False);

          end;

        end;



        // Start auto expand timer if necessary.

        if (toAutoDropExpand in FOptions.FAutoOptions) and Assigned(FDropTargetNode) and

          (vsHasChildren in FDropTargetNode.States) then

          SetTimer(Handle, ExpandTimer, FAutoExpandDelay, nil);

      end

      else

      begin

        // Only the drop mark position changed so invalidate the current drop target node.

        if Assigned(Tree) then

        begin

          if WindowScrolled then

            UpdateWindowAndDragImage(Tree, ClientRect, WindowScrolled, not DragImageWillMove)

          else

            UpdateWindowAndDragImage(Tree, R, False, not DragImageWillMove);

        end

        else

          InvalidateRect(Handle, @R, False);

      end;

    end

    else

    begin

      // No change in the current drop target or drop mode. This might still mean horizontal or vertical scrolling.

      if Assigned(Tree) and ((DeltaX <> 0) or (DeltaY <> 0)) then

        UpdateWindowAndDragImage(Tree, ClientRect, WindowScrolled, not DragImageWillMove);

    end;



    Update;



    if Assigned(Tree) and DragImageWillMove then

      Tree.FDragImage.DragTo(DragPos, False);



    Effect := SuggestDropEffect(Source, Shift, Pt, Effect);

    Accept := DoDragOver(Source, Shift, DragState, Pt, FLastDropMode, Effect);

    if not Accept then

      Effect := DROPEFFECT_NONE;

    if WindowScrolled then

      Effect := Effect or Integer(DROPEFFECT_SCROLL);

    Result := NOERROR;

  except

    Result := E_UNEXPECTED;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.DrawDottedHLine(const PaintInfo: TVTPaintInfo; Left, Right, Top: Integer);



// Draws a horizontal line with alternating pixels (this style is not supported for pens under Win9x).



var

  R: TRect;



begin

  with PaintInfo, Canvas do

  begin

    Brush.Color := FColors.BackGroundColor;

    R := Rect(Min(Left, Right), Top, Max(Left, Right) + 1, Top + 1);

    Windows.FillRect(Handle, R, FDottedBrush);

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.DrawDottedVLine(const PaintInfo: TVTPaintInfo; Top, Bottom, Left: Integer; UseSelectedBkColor: Boolean = False);



// Draws a horizontal line with alternating pixels (this style is not supported for pens under Win9x).



var

  R: TRect;



begin

  with PaintInfo, Canvas do

  begin

    if UseSelectedBkColor then

    begin

      if Focused or (toPopupMode in FOptions.FPaintOptions) then

        Brush.Color := FColors.FocusedSelectionColor

      else

        Brush.Color := FColors.UnfocusedSelectionColor;

    end

    else

    Brush.Color := FColors.BackGroundColor;

    R := Rect(Left, Min(Top, Bottom), Left + 1, Max(Top, Bottom) + 1);

    Windows.FillRect(Handle, R, FDottedBrush);

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.EndOperation(OperationKind: TVTOperationKind);



// Called to indicate that a long-running operation has finished.



begin

  Assert(FOperationCount > 0, 'EndOperation must not be called when no operation in progress.');

  Dec(FOperationCount);

  DoEndOperation(OperationKind);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.EnsureNodeFocused();

begin

  if FocusedNode = nil then

    FocusedNode := Self.GetFirstVisible();

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.EnsureNodeSelected;

begin

  if (toAlwaysSelectNode in TreeOptions.SelectionOptions) and (GetFirstSelected() = nil) and not SelectionLocked then

  begin

    if Assigned(FNextNodeToSelect) then

      Selected[FNextNodeToSelect] := True

    else if Self.Focused then

      Selected[GetFirstVisible] := True;

  end;//if

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.FindNodeInSelection(P: PVirtualNode; var Index: Integer; LowBound,

  HighBound: Integer): Boolean;



// Search routine to find a specific node in the selection array.

// LowBound and HighBound determine the range in which to search the node.

// Either value can be -1 to denote the maximum range otherwise LowBound must be less or equal HighBound.



var

  L, H,

  I: Integer;



begin

  Result := False;

  L := 0;

  if LowBound >= 0 then

    L := LowBound;

  H := FSelectionCount - 1;

  if HighBound >= 0 then

    H := HighBound;

  while L <= H do

  begin

    I := (L + H) shr 1;

    if PAnsiChar(FSelection[I]) < PAnsiChar(P) then

      L := I + 1

    else

    begin

      H := I - 1;

      if FSelection[I] = P then

      begin

        Result := True;

        L := I;

      end;

    end;

  end;

  Index := L;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.FinishChunkHeader(Stream: TStream; StartPos, EndPos: Integer);



// used while streaming out a node to finally write out the size of the chunk



var

  Size: Integer;



begin

  // seek back to the second entry in the chunk header

  Stream.Position := StartPos + SizeOf(Size);

  // determine size of chunk without the chunk header

  Size := EndPos - StartPos - SizeOf(TChunkHeader);

  // write the size...

  Stream.Write(Size, SizeOf(Size));

  // ... and seek to the last endposition

  Stream.Position := EndPos;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.FontChanged(AFont: TObject);



// Little helper function for font changes (as they are not tracked in TBitmap/TCanvas.OnChange).



begin

  FFontChanged := True;

  if Assigned(FOldFontChange) then

    FOldFontChange(AFont);

  //if not (tsPainting in TreeStates) then AutoScale();

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.GetBorderDimensions: TSize;



// Returns the overall width of the current window border, depending on border styles.

// Note: these numbers represent the system's standards not special properties, which can be set for TWinControl

// (e.g. bevels, border width).



var

  Styles: Integer;



begin

  Result.cx := 0;

  Result.cy := 0;



  Styles := GetWindowLong(Handle, GWL_STYLE);

  if (Styles and WS_BORDER) <> 0 then

  begin

    Dec(Result.cx);

    Dec(Result.cy);

  end;

  if (Styles and WS_THICKFRAME) <> 0 then

  begin

    Dec(Result.cx, GetSystemMetrics(SM_CXFIXEDFRAME));

    Dec(Result.cy, GetSystemMetrics(SM_CYFIXEDFRAME));

  end;

  Styles := GetWindowLong(Handle, GWL_EXSTYLE);

  if (Styles and WS_EX_CLIENTEDGE) <> 0 then

  begin

    Dec(Result.cx, GetSystemMetrics(SM_CXEDGE));

    Dec(Result.cy, GetSystemMetrics(SM_CYEDGE));

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.GetCheckImage(Node: PVirtualNode; ImgCheckType: TCheckType = ctNone; ImgCheckState:

  TCheckState = csUncheckedNormal; ImgEnabled: Boolean = True): Integer;



// Determines the index into the check image list for the given node depending on the check type

// and enabled state.



const

  // Four dimensional array consisting of image indices for the check type, the check state, the enabled state and the

  // hot state.

  CheckStateToCheckImage: array[ctCheckBox..ctButton, csUncheckedNormal..csMixedPressed, Boolean, Boolean] of Integer = (

    // ctCheckBox, ctTriStateCheckBox

    (

      // csUncheckedNormal (disabled [not hot, hot], enabled [not hot, hot])

      ((ckCheckUncheckedDisabled, ckCheckUncheckedDisabled), (ckCheckUncheckedNormal, ckCheckUncheckedHot)),

      // csUncheckedPressed (disabled [not hot, hot], enabled [not hot, hot])

      ((ckCheckUncheckedDisabled, ckCheckUncheckedDisabled), (ckCheckUncheckedPressed, ckCheckUncheckedPressed)),

      // csCheckedNormal

      ((ckCheckCheckedDisabled, ckCheckCheckedDisabled), (ckCheckCheckedNormal, ckCheckCheckedHot)),

      // csCheckedPressed

      ((ckCheckCheckedDisabled, ckCheckCheckedDisabled), (ckCheckCheckedPressed, ckCheckCheckedPressed)),

      // csMixedNormal

      ((ckCheckMixedDisabled, ckCheckMixedDisabled), (ckCheckMixedNormal, ckCheckMixedHot)),

      // csMixedPressed

      ((ckCheckMixedDisabled, ckCheckMixedDisabled), (ckCheckMixedPressed, ckCheckMixedPressed))

    ),

    // ctRadioButton

    (

      // csUncheckedNormal (disabled [not hot, hot], enabled [not hot, hot])

      ((ckRadioUncheckedDisabled, ckRadioUncheckedDisabled), (ckRadioUncheckedNormal, ckRadioUncheckedHot)),

      // csUncheckedPressed (disabled [not hot, hot], enabled [not hot, hot])

      ((ckRadioUncheckedDisabled, ckRadioUncheckedDisabled), (ckRadioUncheckedPressed, ckRadioUncheckedPressed)),

      // csCheckedNormal

      ((ckRadioCheckedDisabled, ckRadioCheckedDisabled), (ckRadioCheckedNormal, ckRadioCheckedHot)),

      // csCheckedPressed

      ((ckRadioCheckedDisabled, ckRadioCheckedDisabled), (ckRadioCheckedPressed, ckRadioCheckedPressed)),

      // csMixedNormal (should never appear with ctRadioButton)

      ((ckCheckMixedDisabled, ckCheckMixedDisabled), (ckCheckMixedNormal, ckCheckMixedHot)),

      // csMixedPressed (should never appear with ctRadioButton)

      ((ckCheckMixedDisabled, ckCheckMixedDisabled), (ckCheckMixedPressed, ckCheckMixedPressed))

    ),

    // ctButton

    (

      // csUncheckedNormal (disabled [not hot, hot], enabled [not hot, hot])

      ((ckButtonDisabled, ckButtonDisabled), (ckButtonNormal, ckButtonHot)),

      // csUncheckedPressed (disabled [not hot, hot], enabled [not hot, hot])

      ((ckButtonDisabled, ckButtonDisabled), (ckButtonPressed, ckButtonPressed)),

      // csCheckedNormal

      ((ckButtonDisabled, ckButtonDisabled), (ckButtonNormal, ckButtonHot)),

      // csCheckedPressed

      ((ckButtonDisabled, ckButtonDisabled), (ckButtonPressed, ckButtonPressed)),

      // csMixedNormal (should never appear with ctButton)

      ((ckCheckMixedDisabled, ckCheckMixedDisabled), (ckCheckMixedNormal, ckCheckMixedHot)),

      // csMixedPressed (should never appear with ctButton)

      ((ckCheckMixedDisabled, ckCheckMixedDisabled), (ckCheckMixedPressed, ckCheckMixedPressed))

    )

  );



var

  IsHot: Boolean;



begin

  if Assigned(Node) then

  begin

    ImgCheckType := Node.CheckType;

    ImgCheckState := Node.CheckState;

    ImgEnabled := not (vsDisabled in Node.States) and Enabled;

    IsHot := Node = FCurrentHotNode;

  end

  else

    IsHot := False;



  if ImgCheckType = ctTriStateCheckBox then

    ImgCheckType := ctCheckBox;



  if ImgCheckType = ctNone then

    Result := -1

  else

    Result := CheckStateToCheckImage[ImgCheckType, ImgCheckState, ImgEnabled, IsHot];

end;



//----------------------------------------------------------------------------------------------------------------------



class function TBaseVirtualTree.GetCheckImageListFor(Kind: TCheckImageKind): TCustomImageList;



begin

  case Kind of

    ckDarkCheck:

      Result := DarkCheckImages;

    ckLightTick:

      Result := LightTickImages;

    ckDarkTick:

      Result := DarkTickImages;

    ckLightCheck:

      Result := LightCheckImages;

    ckFlat:

      Result := FlatImages;

    ckXP:

      Result := XPImages;

    ckSystemDefault:

      Result := SystemCheckImages;

    ckSystemFlat:

      Result := SystemFlatCheckImages;

    else

      Result := nil;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.GetColumnClass: TVirtualTreeColumnClass;



begin

  Result := TVirtualTreeColumn;

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.GetHeaderClass: TVTHeaderClass;



begin

  Result := TVTHeader;

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.GetHintWindowClass: THintWindowClass;



// Returns the default hint window class used for the tree. Descendants can override it to use their own classes.



begin

  Result := TVirtualTreeHintWindow;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.GetImageIndex(var Info: TVTPaintInfo; Kind: TVTImageKind; InfoIndex: TVTImageInfoIndex;

  DefaultImages: TCustomImageList);



// Retrieves the image index and an eventual customized image list for drawing.



var

  CustomImages: TCustomImageList;



begin

  with Info do

  begin

    ImageInfo[InfoIndex].Index := -1;

    ImageInfo[InfoIndex].Ghosted := False;



    CustomImages := DoGetImageIndex(Node, Kind, Column, ImageInfo[InfoIndex].Ghosted, ImageInfo[InfoIndex].Index);

    if Assigned(CustomImages) then

      ImageInfo[InfoIndex].Images := CustomImages

    else

      ImageInfo[InfoIndex].Images := DefaultImages;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.IsEmpty: Boolean;

begin

  Result := (Self.ChildCount[nil] = 0);

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.GetNodeImageSize(Node: PVirtualNode): TSize;



  // Returns the size of an image

  // Override if you need different sized images for certain nodes.

begin

  if Assigned(FImages) then

  begin

    Result.cx := FImages.Width;

    Result.cy := FImages.Height;

  end

  else

  begin

    Result.cx := 0;

    Result.cy := 0;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.GetMaxRightExtend: Cardinal;



// Determines the maximum with of the currently visible part of the tree, depending on the length

// of the node texts. This method is used for determining the horizontal scroll range if no columns are used.



var

  Node,

  NextNode: PVirtualNode;

  TopPosition: Integer;

  NodeLeft,

  CurrentWidth: Integer;

  WithCheck: Boolean;

  CheckOffset: Integer;



begin

  Node := GetNodeAt(0, 0, True, TopPosition);

  Result := 0;

  if toShowRoot in FOptions.FPaintOptions then

    NodeLeft := (GetNodeLevel(Node) + 1) * FIndent

  else

    NodeLeft := GetNodeLevel(Node) * FIndent;



  if Assigned(FStateImages) then

    Inc(NodeLeft, FStateImages.Width + 2);

  if Assigned(FImages) then

    Inc(NodeLeft, FImages.Width + 2);

  WithCheck := (toCheckSupport in FOptions.FMiscOptions) and Assigned(FCheckImages);

  if WithCheck then

    CheckOffset := FCheckImages.Width + 2

  else

    CheckOffset := 0;



  while Assigned(Node) do

  begin

    if not (vsInitialized in Node.States) then

      InitNode(Node);



    if WithCheck and (Node.CheckType <> ctNone) then

      Inc(NodeLeft, CheckOffset);

    CurrentWidth := DoGetNodeWidth(Node, NoColumn);

    Inc(CurrentWidth, DoGetNodeExtraWidth(Node, NoColumn));

    if Integer(Result) < (NodeLeft + CurrentWidth) then

      Result := NodeLeft + CurrentWidth;

    Inc(TopPosition, NodeHeight[Node]);

    if TopPosition > Height then

      Break;



    if WithCheck and (Node.CheckType <> ctNone) then

      Dec(NodeLeft, CheckOffset);



    // Get next visible node and update left node position.

    NextNode := GetNextVisible(Node, True);

    if NextNode = nil then

      Break;

    Inc(NodeLeft, CountLevelDifference(Node, NextNode) * Integer(FIndent));

    Node := NextNode;

  end;



  Inc(Result, FMargin);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.GetNativeClipboardFormats(var Formats: TFormatEtcArray);



// Returns the supported clipboard formats of the tree.



begin

  InternalClipboardFormats.EnumerateFormats(TVirtualTreeClass(ClassType), Formats, FClipboardFormats);

  // Ask application/descendants for self defined formats.

  DoGetUserClipboardFormats(Formats);

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.GetOperationCanceled;



begin

  Result := FOperationCanceled and (FOperationCount > 0);

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.GetOptionsClass: TTreeOptionsClass;



begin

  Result := TCustomVirtualTreeOptions;

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.GetTreeFromDataObject(const DataObject: IDataObject): TBaseVirtualTree;



// Returns the owner/sender of the given data object by means of a special clipboard format

// or nil if the sender is in another process or no virtual tree at all.



var

  Medium: TStgMedium;

  Data: PVTReference;



begin

  Result := nil;

  if Assigned(DataObject) then

  begin

    StandardOLEFormat.cfFormat := CF_VTREFERENCE;

    if DataObject.GetData(StandardOLEFormat, Medium) = S_OK then

    begin

      Data := GlobalLock(Medium.hGlobal);

      if Assigned(Data) then

      begin

        if Data.Process = GetCurrentProcessID then

          Result := Data.Tree;

        GlobalUnlock(Medium.hGlobal);

      end;

      ReleaseStgMedium(Medium);

    end;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.HandleHotTrack(X, Y: Integer);



// Updates the current "hot" node.



var

  HitInfo: THitInfo;

  CheckPositions: THitPositions;

  ButtonIsHit,

  DoInvalidate: Boolean;



begin

  DoInvalidate := False;

  // Get information about the hit.

  GetHitTestInfoAt(X, Y, True, HitInfo);



  // Only make the new node being "hot" if its label is hit or full row selection is enabled.

  CheckPositions := [hiOnItemLabel, hiOnItemCheckbox];



  // If running under Windows Vista using the explorer theme hitting the buttons makes the node hot, too.

  if tsUseExplorerTheme in FStates then

    Include(CheckPositions, hiOnItemButtonExact);



  if (CheckPositions * HitInfo.HitPositions = []) and

    (not (toFullRowSelect in FOptions.FSelectionOptions) or (hiNowhere in HitInfo.HitPositions)) then

    HitInfo.HitNode := nil;

  if (HitInfo.HitNode <> FCurrentHotNode) or (HitInfo.HitColumn <> FCurrentHotColumn) then

  begin

    DoInvalidate := (toHotTrack in FOptions.PaintOptions) or (toCheckSupport in FOptions.FMiscOptions);

    DoHotChange(FCurrentHotNode, HitInfo.HitNode);

    if Assigned(FCurrentHotNode) and DoInvalidate then

      InvalidateNode(FCurrentHotNode);

    FCurrentHotNode := HitInfo.HitNode;

    FCurrentHotColumn := HitInfo.HitColumn;

  end;



  ButtonIsHit := (hiOnItemButtonExact in HitInfo.HitPositions) and (toHotTrack in FOptions.FPaintOptions);

  if Assigned(FCurrentHotNode) and ((FHotNodeButtonHit <> ButtonIsHit) or DoInvalidate) then

  begin

    FHotNodeButtonHit := ButtonIsHit and (toHotTrack in FOptions.FPaintOptions);

    InvalidateNode(FCurrentHotNode);

  end

  else

    if not Assigned(FCurrentHotNode) then

      FHotNodeButtonHit := False;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.HandleIncrementalSearch(CharCode: Word);



var

  Run, Stop: PVirtualNode;

  GetNextNode: TGetNextNodeProc;

  NewSearchText: UnicodeString;

  SingleLetter,

  PreviousSearch: Boolean; // True if VK_BACK was sent.

  SearchDirection: TVTSearchDirection;



  //--------------- local functions -------------------------------------------



  procedure SetupNavigation;



  // If the search buffer is empty then we start searching with the next node after the last one, otherwise

  // we continue with the last one. Node navigation function is set up too here, to avoid frequent checks.



  var

    FindNextNode: Boolean;



  begin

    FindNextNode := (Length(FSearchBuffer) = 0) or (Run = nil) or SingleLetter or PreviousSearch;

    case FIncrementalSearch of

      isVisibleOnly:

        if SearchDirection = sdForward then

        begin

          GetNextNode := GetNextVisible;

          if FindNextNode then

          begin

            if Run = nil then

              Run := GetFirstVisible(nil, True)

            else

            begin

              Run := GetNextVisible(Run, True);

              // Do wrap around.

              if Run = nil then

                Run := GetFirstVisible(nil, True);

            end;

          end;

        end

        else

        begin

          GetNextNode := GetPreviousVisible;

          if FindNextNode then

          begin

            if Run = nil then

              Run := GetLastVisible(nil, True)

            else

            begin

              Run := GetPreviousVisible(Run, True);

              // Do wrap around.

              if Run = nil then

                Run := GetLastVisible(nil, True);

            end;

          end;

        end;

      isInitializedOnly:

        if SearchDirection = sdForward then

        begin

          GetNextNode := GetNextNoInit;

          if FindNextNode then

          begin

            if Run = nil then

              Run := GetFirstNoInit

            else

            begin

              Run := GetNextNoInit(Run);

              // Do wrap around.

              if Run = nil then

                Run := GetFirstNoInit;

            end;

          end;

        end

        else

        begin

          GetNextNode := GetPreviousNoInit;

          if FindNextNode then

          begin

            if Run = nil then

              Run := GetLastNoInit

            else

            begin

              Run := GetPreviousNoInit(Run);

              // Do wrap around.

              if Run = nil then

                Run := GetLastNoInit;

            end;

          end;

        end;

    else

      // isAll

      if SearchDirection = sdForward then

      begin

        GetNextNode := GetNext;

        if FindNextNode then

        begin

          if Run = nil then

            Run := GetFirst

          else

          begin

            Run := GetNext(Run);

            // Do wrap around.

            if Run = nil then

              Run := GetFirst;

          end;

        end;

      end

      else

      begin

        GetNextNode := GetPrevious;

        if FindNextNode then

        begin

          if Run = nil then

            Run := GetLast

          else

          begin

            Run := GetPrevious(Run);

            // Do wrap around.

            if Run = nil then

              Run := GetLast;

          end;

        end;

      end;

    end;

  end;



  //---------------------------------------------------------------------------



  function CodePageFromLocale(Language: LCID): Integer;



  // Determines the code page for a given locale.

  // Unfortunately there is no easier way than this, currently.



  var

    Buf: array[0..6] of Char;



  begin

    GetLocaleInfo(Language, LOCALE_IDEFAULTANSICODEPAGE, Buf, 6);

    Result := StrToIntDef(Buf, GetACP);

  end;



  //---------------------------------------------------------------------------



  function KeyUnicode(C: Char): WideChar;

  // Converts the given character into its corresponding Unicode character

  // depending on the active keyboard layout.

  begin

    {$ifdef UNICODE}

    Result := C;      //!!!!!!

    {$ELSE}

    MultiByteToWideChar(CodePageFromLocale(GetKeyboardLayout(0) and $FFFF),

      MB_USEGLYPHCHARS, @C, 1, @Result, 1);

    {$endif}

  end;



  //--------------- end local functions ---------------------------------------



var

  FoundMatch: Boolean;

  NewChar: WideChar;



begin

  StopTimer(SearchTimer);



  if FIncrementalSearch <> isNone then

  begin

    if CharCode <> 0 then

    begin

      DoStateChange([tsIncrementalSearching]);



      // Convert the given virtual key code into a Unicode character based on the current locale.

      NewChar := KeyUnicode(Char(CharCode));

      PreviousSearch := NewChar = WideChar(VK_BACK);

      // We cannot do a search with an empty search buffer.

      if not PreviousSearch or (FSearchBuffer <> '') then

      begin

        // Determine which method to use to advance nodes and the start node to search from.

        case FSearchStart of

          ssAlwaysStartOver:

            Run := nil;

          ssFocusedNode:

            Run := FFocusedNode;

        else // ssLastHit

          Run := FLastSearchNode;

        end;



        // Make sure the start node corresponds to the search criterion.

        if Assigned(Run) then

        begin

          case FIncrementalSearch of

            isInitializedOnly:

              if not (vsInitialized in Run.States) then

                Run := nil;

            isVisibleOnly:

              if not FullyVisible[Run] or IsEffectivelyFiltered[Run] then

                Run := nil;

          end;

        end;

        Stop := Run;



        // VK_BACK temporarily changes search direction to opposite mode.

        if PreviousSearch then

        begin

          if SearchDirection = sdBackward then

            SearchDirection := sdForward

          else

            SearchDirection := sdBackward;

        end

        else

          SearchDirection := FSearchDirection;

        // The "single letter mode" is used to advance quickly from node to node when pressing the same key several times.

        SingleLetter := (Length(FSearchBuffer) = 1) and not PreviousSearch and (FSearchBuffer[1] = NewChar);

        // However if the current hit (if there is one) would fit also with a repeated character then

        // don't use single letter mode.

        if SingleLetter and (DoIncrementalSearch(Run, FSearchBuffer + NewChar) = 0) then

          SingleLetter := False;

        SetupNavigation;

        FoundMatch := False;



        if Assigned(Run) then

        begin

          if SingleLetter then

            NewSearchText := FSearchBuffer

          else

            if PreviousSearch then

            begin

              SetLength(FSearchBuffer, Length(FSearchBuffer) - 1);

              NewSearchText := FSearchBuffer;

            end

            else

              NewSearchText := FSearchBuffer + NewChar;



          repeat

            if DoIncrementalSearch(Run, NewSearchText) = 0 then

            begin

              FoundMatch := True;

              Break;

            end;



            // Advance to next node if we have not found a match.

            Run := GetNextNode(Run);

            // Do wrap around start or end of tree.

            if (Run <> Stop) and (Run = nil) then

              SetupNavigation;

          until Run = Stop;

        end;



        if FoundMatch then

        begin

          ClearSelection;

          FSearchBuffer := NewSearchText;

          FLastSearchNode := Run;

          FocusedNode := Run;

          Selected[Run] := True;

          FLastSearchNode := Run;

        end

        else

          // Play an acoustic signal if nothing could be found but don't beep if only the currently

          // focused node matches.

          if Assigned(Run) and (DoIncrementalSearch(Run, NewSearchText) <> 0) then

            Beep;

      end;

    end;



    // Restart search timeout interval.

    SetTimer(Handle, SearchTimer, FSearchTimeout, nil);

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.HandleMouseDblClick(var Message: TWMMouse; const HitInfo: THitInfo);



var

  NewCheckState: TCheckState;

  Node: PVirtualNode;

  MayEdit: Boolean;



begin

  MayEdit := not (tsEditing in FStates) and (toEditOnDblClick in FOptions.FMiscOptions);

  if tsEditPending in FStates then

  begin

    StopTimer(EditTimer);

    DoStateChange([], [tsEditPending]);

  end;



  if not (tsEditing in FStates) or DoEndEdit then

  begin

    if HitInfo.HitColumn = FHeader.FColumns.FClickIndex then

      DoColumnDblClick(HitInfo.HitColumn, KeysToShiftState(Message.Keys));



      if HitInfo.HitNode <> nil then

      DoNodeDblClick(HitInfo);



    Node := nil;

    if (hiOnItem in HitInfo.HitPositions) and (HitInfo.HitColumn > NoColumn) and

       (coFixed in FHeader.FColumns[HitInfo.HitColumn].FOptions) then

    begin

      if hiUpperSplitter in HitInfo.HitPositions then

        Node := GetPreviousVisible(HitInfo.HitNode, True)

      else

        if  hiLowerSplitter in HitInfo.HitPositions then

          Node := HitInfo.HitNode;

    end;



    if Assigned(Node) and (Node <> FRoot) and (toNodeHeightDblClickResize in FOptions.FMiscOptions) then

    begin

      if DoNodeHeightDblClickResize(Node, HitInfo.HitColumn, KeysToShiftState(Message.Keys), Point(Message.XPos, Message.YPos)) then

      begin

        SetNodeHeight(Node, FDefaultNodeHeight);

        UpdateWindow(Handle);

        MayEdit := False;

      end;

    end

    else

      if hiOnItemCheckBox in HitInfo.HitPositions then

      begin

        if (FStates * [tsMouseCheckPending, tsKeyCheckPending] = []) and not (vsDisabled in HitInfo.HitNode.States) then

        begin

          with HitInfo.HitNode^ do

            NewCheckState := DetermineNextCheckState(CheckType, CheckState);

          if (ssLeft in KeysToShiftState(Message.Keys)) and DoChecking(HitInfo.HitNode, NewCheckState) then

          begin

            DoStateChange([tsMouseCheckPending]);

            FCheckNode := HitInfo.HitNode;

            FPendingCheckState := NewCheckState;

            FCheckNode.CheckState := PressedState[FCheckNode.CheckState];

            InvalidateNode(HitInfo.HitNode);

            MayEdit := False;

          end;

        end;

      end

      else

      begin

        if hiOnItemButton in HitInfo.HitPositions then

        begin

          ToggleNode(HitInfo.HitNode);

          MayEdit := False;

        end

        else

        begin

          if toToggleOnDblClick in FOptions.FMiscOptions then

          begin

            if ((([hiOnItemButton, hiOnItemLabel, hiOnNormalIcon, hiOnStateIcon] * HitInfo.HitPositions) <> []) or

              ((toFullRowSelect in FOptions.FSelectionOptions) and Assigned(HitInfo.HitNode))) then

            begin

              ToggleNode(HitInfo.HitNode);

              MayEdit := False;

            end;

          end;

        end;

      end;

  end;



  if MayEdit and Assigned(FFocusedNode) and (FFocusedNode = HitInfo.HitNode) and

    (FFocusedColumn = HitInfo.HitColumn) and CanEdit(FFocusedNode, HitInfo.HitColumn) then

  begin

    DoStateChange([tsEditPending]);

    FEditColumn := FFocusedColumn;

    SetTimer(Handle, EditTimer, FEditDelay, nil);

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.HandleMouseDown(var Message: TWMMouse; var HitInfo: THitInfo);



// centralized mouse button down handling



var

  LastFocused: PVirtualNode;

  Column: TColumnIndex;

  ShiftState: TShiftState;



  // helper variables to shorten boolean equations/expressions

  AutoDrag,              // automatic (or allowed) drag start

  IsLabelHit,            // the node's caption or images are hit

  IsCellHit,             // for grid extension or full row select (but not check box, button)

  IsAnyHit,              // either IsHit or IsCellHit

  IsHeightTracking,      // height tracking

  MultiSelect,           // multiselection is enabled

  ShiftEmpty,            // ShiftState = []

  NodeSelected: Boolean; // the new node (if any) is selected

  NewColumn: Boolean;    // column changed

  NewNode: Boolean;      // Node changed.

  NeedChange: Boolean;   // change event is required for selection change

  CanClear: Boolean;

  NewCheckState: TCheckState;

  AltPressed: Boolean;   // Pressing the Alt key enables special processing for selection.

  FullRowDrag: Boolean;  // Start dragging anywhere within a node's bound.

  NodeRect: TRect;



begin

  if [tsWheelPanning, tsWheelScrolling] * FStates <> [] then

  begin

    StopWheelPanning;

    Exit;

  end;



  if tsEditPending in FStates then

  begin

    StopTimer(EditTimer);

    DoStateChange([], [tsEditPending]);

  end;



  if (tsEditing in FStates) then

    DoEndEdit;



  // Focus change. Don't use the SetFocus method as this does not work for MDI windows.

  if not Focused and CanFocus then

  begin

    Windows.SetFocus(Handle);

    // Repeat the hit test as an OnExit event might got triggered that could modify the tree.

    GetHitTestInfoAt(Message.XPos, Message.YPos, True, HitInfo);

  end;



  // Keep clicked column in case the application needs it.

  FHeader.FColumns.FClickIndex := HitInfo.HitColumn;



  // Change column only if we have hit the node label.

  if (hiOnItemLabel in HitInfo.HitPositions) or

    (toFullRowSelect in FOptions.FSelectionOptions) or

    (toGridExtensions in FOptions.FMiscOptions) then

  begin

    NewColumn := FFocusedColumn <> HitInfo.HitColumn;

    if toExtendedFocus in FOptions.FSelectionOptions then

      Column := HitInfo.HitColumn

    else

      Column := FHeader.MainColumn;

  end

  else

  begin

    NewColumn := False;

    Column := FFocusedColumn;

  end;



  if NewColumn and not FHeader.AllowFocus(Column) then

  begin

    NewColumn := False;

    Column := FFocusedColumn;

  end;



  NewNode := FFocusedNode <> HitInfo.HitNode;



  // Translate keys and filter out shift and control key.

  ShiftState := KeysToShiftState(Message.Keys) * [ssShift, ssCtrl, ssAlt];

  if ssAlt in ShiftState then

  begin

    AltPressed := True;

    // Remove the Alt key from the shift state. It is not meaningful there.

    Exclude(ShiftState, ssAlt);

  end

  else

    AltPressed := False;



  // Various combinations determine what states the tree enters now.

  // We initialize shorthand variables to avoid the following expressions getting too large

  // and to avoid repeative expensive checks.

  IsLabelHit := not AltPressed and not (toSimpleDrawSelection in FOptions.FSelectionOptions) and

    ((hiOnItemLabel in HitInfo.HitPositions) or (hiOnNormalIcon in HitInfo.HitPositions));



  IsCellHit := not AltPressed and not IsLabelHit and Assigned(HitInfo.HitNode) and

    ([hiOnItemButton, hiOnItemCheckBox] * HitInfo.HitPositions = []) and

    ((toFullRowSelect in FOptions.FSelectionOptions) or

    ((toGridExtensions in FOptions.FMiscOptions) and (HitInfo.HitColumn > NoColumn)));



  IsAnyHit := IsLabelHit or IsCellHit;

  MultiSelect := toMultiSelect in FOptions.FSelectionOptions;

  ShiftEmpty := ShiftState = [];

  NodeSelected := IsAnyHit and (vsSelected in HitInfo.HitNode.States);



  // Determine the Drag behavior.

  if MultiSelect and not (toDisableDrawSelection in FOptions.FSelectionOptions) then

  begin

    // We have MultiSelect and want to draw a selection rectangle.

    // We will start a full row drag only in case a label was hit,

    // otherwise a multi selection will start.

    FullRowDrag := (toFullRowDrag in FOptions.FMiscOptions) and IsCellHit and

        not (hiNowhere in HitInfo.HitPositions) and

        (NodeSelected or (hiOnItemLabel in HitInfo.HitPositions) or (hiOnNormalIcon in HitInfo.HitPositions));

  end

  else // No MultiSelect, hence we can start a drag anywhere in the row.

    FullRowDrag := toFullRowDrag in FOptions.FMiscOptions;



  IsHeightTracking := (Message.Msg = WM_LBUTTONDOWN) and

                      (hiOnItem in HitInfo.HitPositions) and

                      ([hiUpperSplitter, hiLowerSplitter] * HitInfo.HitPositions <> []);



  // Dragging might be started in the inherited handler manually (which is discouraged for stability reasons)

  // the test for manual mode is done below (after the focused node is set).

  AutoDrag := ((DragMode = dmAutomatic) or Dragging) and (not IsCellHit or FullRowDrag);



  // Query the application to learn if dragging may start now (if set to dmManual).

  if Assigned(HitInfo.HitNode) and not AutoDrag and (DragMode = dmManual) then

    AutoDrag := DoBeforeDrag(HitInfo.HitNode, Column) and (FullRowDrag or IsLabelHit);



  // handle node height tracking

  if IsHeightTracking then

  begin

    if hiUpperSplitter in HitInfo.HitPositions then

      FHeightTrackNode := GetPreviousVisible(HitInfo.HitNode, True)

    else

      FHeightTrackNode := HitInfo.HitNode;



    if CanSplitterResizeNode(Point(Message.XPos, Message.YPos), FHeightTrackNode, HitInfo.HitColumn) then

    begin

      FHeightTrackColumn := HitInfo.HitColumn;

      NodeRect := GetDisplayRect(FHeightTrackNode, FHeightTrackColumn, False);

      FHeightTrackPoint := Point(NodeRect.Left, NodeRect.Top);

      DoStateChange([tsNodeHeightTrackPending]);

      Exit;

    end;

  end;



  // handle button clicks

  if (hiOnItemButton in HitInfo.HitPositions) and (vsHasChildren in HitInfo.HitNode.States) then

  begin

    ToggleNode(HitInfo.HitNode);

    Exit;

  end;



  // check event

  if hiOnItemCheckBox in HitInfo.HitPositions then

  begin

    if (FStates * [tsMouseCheckPending, tsKeyCheckPending] = []) and not (vsDisabled in HitInfo.HitNode.States) then

    begin

      with HitInfo.HitNode^ do

        NewCheckState := DetermineNextCheckState(CheckType, CheckState);

      if (ssLeft in KeysToShiftState(Message.Keys)) and DoChecking(HitInfo.HitNode, NewCheckState) then

      begin

        DoStateChange([tsMouseCheckPending]);

        FCheckNode := HitInfo.HitNode;

        FPendingCheckState := NewCheckState;

        FCheckNode.CheckState := PressedState[FCheckNode.CheckState];

        InvalidateNode(HitInfo.HitNode);

      end;

    end;

    Exit;

  end;



  // Keep this node's level in case we need it for constraint selection.

  if (FRoot.ChildCount > 0) and ShiftEmpty or (FSelectionCount = 0) then

    if Assigned(HitInfo.HitNode) then

      FLastSelectionLevel := GetNodeLevel(HitInfo.HitNode)

    else

      FLastSelectionLevel := GetNodeLevel(GetLastVisibleNoInit(nil, True));



  // pending clearance

  if MultiSelect and ShiftEmpty and not (hiOnItemCheckbox in HitInfo.HitPositions) and IsAnyHit and AutoDrag and

    NodeSelected and not FSelectionLocked then

    DoStateChange([tsClearPending]);



  // immediate clearance

  // Determine for the right mouse button if there is a popup menu. In this case and if drag'n drop is pending

  // the current selection has to stay as it is.

  with HitInfo, Message do

    CanClear := not AutoDrag and

      (not (tsRightButtonDown in FStates) or not HasPopupMenu(HitNode, HitColumn, Point(XPos, YPos)));



  // User starts a selection with a selection rectangle.

  if not (toDisableDrawSelection in FOptions.FSelectionOptions) and not (IsLabelHit or FullRowDrag) and MultiSelect then

  begin

    SetCapture(Handle);

    DoStateChange([tsDrawSelPending]);

    FDrawSelShiftState := ShiftState;

    FNewSelRect := Rect(Message.XPos + FEffectiveOffsetX, Message.YPos - FOffsetY, Message.XPos + FEffectiveOffsetX,

      Message.YPos - FOffsetY);

    FLastSelRect := Rect(0, 0, 0, 0);

  end;



  if not FSelectionLocked and ((not (IsAnyHit or FullRowDrag) and MultiSelect and ShiftEmpty) or

    (IsAnyHit and (not NodeSelected or (NodeSelected and CanClear)) and (ShiftEmpty or not MultiSelect))) then

  begin

    Assert(not (tsClearPending in FStates), 'Pending and direct clearance are mutual exclusive!');



    // If the currently hit node was already selected then we have to reselect it again after clearing the current

    // selection, but without a change event if it is the only selected node.

    // The same applies if the Alt key is pressed, which allows to start drawing the selection rectangle also

    // on node captions and images. Here the previous selection state does not matter, though.

    if NodeSelected or (AltPressed and Assigned(HitInfo.HitNode) and (HitInfo.HitColumn = FHeader.MainColumn)) and not (hiNowhere in HitInfo.HitPositions) then

    begin

      NeedChange := FSelectionCount > 1;

      InternalClearSelection;

      InternalAddToSelection(HitInfo.HitNode, True);

      if NeedChange then

      begin

        Invalidate;

        Change(nil);

      end;

    end

    else if not ((hiNowhere in HitInfo.HitPositions) and (toAlwaysSelectNode in Self.TreeOptions.SelectionOptions)) then // When clicking in the free space we don't want the selection to be cleared in case toAlwaysSelectNode is set

      ClearSelection;

  end;



  // pending node edit

  if Focused and

    ((hiOnItemLabel in HitInfo.HitPositions) or ((toGridExtensions in FOptions.FMiscOptions) and

    (hiOnItem in HitInfo.HitPositions))) and NodeSelected and not NewColumn and ShiftEmpty then

  begin

    DoStateChange([tsEditPending]);

  end;



  if not (toDisableDrawSelection in FOptions.FSelectionOptions)

    and not (IsLabelHit or FullRowDrag) and MultiSelect then

  begin

    // The original code here was moved up to fix issue #187.

    // In order not to break the semantics of this procedure, we are leaving these if statements here

    if not IsCellHit or (hiNowhere in HitInfo.HitPositions) then

      Exit;

  end;



  // Keep current mouse position.

  FLastClickPos := Point(Message.XPos, Message.YPos);



  // Handle selection and node focus change.

  if (IsLabelHit or IsCellHit) and

     DoFocusChanging(FFocusedNode, HitInfo.HitNode, FFocusedColumn, Column) then

  begin

    if NewColumn then

    begin

      InvalidateColumn(FFocusedColumn);

      InvalidateColumn(Column);

      FFocusedColumn := Column;

    end;

    if DragKind = dkDock then

    begin

      StopTimer(ScrollTimer);

      DoStateChange([], [tsScrollPending, tsScrolling]);

    end;

    // Get the currently focused node to make multiple multi-selection blocks possible.

    LastFocused := FFocusedNode;

    if NewNode then

      DoFocusNode(HitInfo.HitNode, False);



    if MultiSelect and not ShiftEmpty then

      HandleClickSelection(LastFocused, HitInfo.HitNode, ShiftState, AutoDrag)

    else

    begin

      if ShiftEmpty then

        FRangeAnchor := HitInfo.HitNode;



      // If the hit node is not yet selected then do it now.

      if not NodeSelected then

        AddToSelection(HitInfo.HitNode);

    end;



    if NewNode or NewColumn then

    begin

      ScrollIntoView(FFocusedNode, toCenterScrollIntoView in FOptions.SelectionOptions,

        not (toDisableAutoscrollOnFocus in FOptions.FAutoOptions)

        and not (toFullRowSelect in FOptions.SelectionOptions));



      DoFocusChange(FFocusedNode, FFocusedColumn);

    end;

  end;



  // Drag'n drop initiation

  // If we lost focus in the interim the button states would be cleared in WM_KILLFOCUS.

  if AutoDrag and IsAnyHit and (FStates * [tsLeftButtonDown, tsRightButtonDown, tsMiddleButtonDown] <> []) then

    BeginDrag(False);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.HandleMouseUp(var Message: TWMMouse; const HitInfo: THitInfo);



// Counterpart to the mouse down handler.



var

  ReselectFocusedNode: Boolean;



begin

  ReleaseCapture;



  if not (tsVCLDragPending in FStates) then

  begin

    // reset pending or persistent states

    if IsMouseSelecting then

    begin

      DoStateChange([], [tsDrawSelecting, tsDrawSelPending, tsToggleFocusedSelection]);

      Invalidate;

    end;



    if tsClearPending in FStates then

    begin

      ReselectFocusedNode := Assigned(FFocusedNode) and (vsSelected in FFocusedNode.States);

      ClearSelection;

      if ReselectFocusedNode then

        AddToSelection(FFocusedNode);

    end;



    if (tsToggleFocusedSelection in FStates) and (HitInfo.HitNode = FFocusedNode) and Assigned(HitInfo.HitNode) then //Prevent AV when dereferencing HitInfo.HitNode below, see bug #100

    begin

      if vsSelected in HitInfo.HitNode.States then

      begin

        if not (toAlwaysSelectNode in TreeOptions.SelectionOptions) or (Self.SelectedCount > 1) then

          RemoveFromSelection(HitInfo.HitNode);

      end

      else

        AddToSelection(HitInfo.HitNode);

      InvalidateNode(HitInfo.HitNode);

    end;



    DoStateChange([], [tsOLEDragPending, tsOLEDragging, tsClearPending, tsDrawSelPending, tsToggleFocusedSelection,

      tsScrollPending, tsScrolling]);

    StopTimer(ScrollTimer);



    if tsMouseCheckPending in FStates then

    begin

      DoStateChange([], [tsMouseCheckPending]);

     //  Need check for nil, issue #285

     //  because when mouse down on checkbox but not yet released

     //  and in this time list starts to rebuild by timer

     //  after this when mouse release  FCheckNode equal nil

     if Assigned (FCheckNode) then

     begin

       // Is the mouse still over the same node?

       if (HitInfo.HitNode = FCheckNode) and (hiOnItem in HitInfo.HitPositions) then

          DoCheckClick(FCheckNode, FPendingCheckState)

        else

          FCheckNode.CheckState := UnpressedState[FCheckNode.CheckState];

        InvalidateNode(FCheckNode);

      end;

      FCheckNode := nil;

    end;



    if (FHeader.FColumns.FClickIndex > NoColumn) and (FHeader.FColumns.FClickIndex = HitInfo.HitColumn) then

      DoColumnClick(HitInfo.HitColumn, KeysToShiftState(Message.Keys));



    if HitInfo.HitNode <> nil then

     DoNodeClick(HitInfo);



    // handle a pending edit event

    if tsEditPending in FStates then

    begin

      // Is the mouse still over the same node?

      if (HitInfo.HitNode = FFocusedNode) and (hiOnItem in HitInfo.HitPositions) and

         (toEditOnClick in FOptions.FMiscOptions) and (FFocusedColumn = HitInfo.HitColumn) and

         CanEdit(FFocusedNode, HitInfo.HitColumn) then

      begin

        FEditColumn := FFocusedColumn;

        SetTimer(Handle, EditTimer, FEditDelay, nil);

      end

      else

        DoStateChange([], [tsEditPending]);

    end;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.HasImage(Node: PVirtualNode; Kind: TVTImageKind; Column: TColumnIndex): Boolean;



// Determines whether the given node has got an image of the given kind in the given column.

// Returns True if so, otherwise False.

// The given node will be implicitly initialized if needed.



var

  Ghosted: Boolean;

  Index: Integer;



begin

  if not (vsInitialized in Node.States) then

    InitNode(Node);



  Index := -1;

  Ghosted := False;

  DoGetImageIndex(Node, Kind, Column, Ghosted, Index);

  Result := Index > -1;

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.HasPopupMenu(Node: PVirtualNode; Column: TColumnIndex; Pos: TPoint): Boolean;



// Determines whether the tree got a popup menu, either in its PopupMenu property, via the OnGetPopupMenu event or

// through inheritance. The latter case must be checked by the descendant which must override this method.



begin

  Result := Assigned(PopupMenu) or Assigned(DoGetPopupMenu(Node, Column, Pos));

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.InitChildren(Node: PVirtualNode);



// Initiates the initialization of the child number of the given node.



var

  Count: Cardinal;



begin

  if Assigned(Node) and (Node <> FRoot) and (vsHasChildren in Node.States) then

  begin

    Count := Node.ChildCount;

    if DoInitChildren(Node, Count) then

    begin

      SetChildCount(Node, Count);

      if Count = 0 then

        Exclude(Node.States, vsHasChildren);

    end;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.InitNode(Node: PVirtualNode);



// Initiates the initialization of the given node to allow the application to load needed data for it.



var

  InitStates: TVirtualNodeInitStates;



begin

  with Node^ do

  begin

    InitStates := [];

    if vsInitialized in States then

      Include(InitStates, ivsReInit);

    Include(States, vsInitialized);

    if Parent = FRoot then

      DoInitNode(nil, Node, InitStates)

    else

      DoInitNode(Parent, Node, InitStates);

    if ivsDisabled in InitStates then

      Include(States, vsDisabled);

    if ivsHasChildren in InitStates then

      Include(States, vsHasChildren);

    if ivsSelected in InitStates then

    begin

      FSingletonNodeArray[0] := Node;

      InternalAddToSelection(FSingletonNodeArray, 1, False);

    end;

    if ivsMultiline in InitStates then

      Include(States, vsMultiline);

    if ivsFiltered in InitStates then

    begin

      Include(States, vsFiltered);

      if not (toShowFilteredNodes in FOptions.FPaintOptions) then

      begin

        AdjustTotalHeight(Node, -NodeHeight, True);

        if FullyVisible[Node] then

          Dec(FVisibleCount);

        UpdateScrollBars(True);

      end;

    end;



    // Expanded may already be set (when called from ReinitNode) or be set in DoInitNode, allow both.

    if (vsExpanded in Node.States) xor (ivsExpanded in InitStates) then

    begin

      // Expand node if not yet done (this will automatically initialize child nodes).

      if ivsExpanded in InitStates then

        ToggleNode(Node)

      else

        // If the node already was expanded then explicitly trigger child initialization.

        if vsHasChildren in Node.States then

          InitChildren(Node);

    end;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.InternalAddFromStream(Stream: TStream; Version: Integer; Node: PVirtualNode);



// Loads all details for Node (including its children) from the given stream.

// Because the new nodes might be selected this method also fixes the selection array.



var

  Stop: PVirtualNode;

  Index: Integer;

  LastTotalHeight: Cardinal;

  WasFullyVisible: Boolean;



begin

  Assert(Node <> FRoot, 'The root node cannot be loaded from stream.');



  // Keep the current total height value of Node as it has already been applied

  // but might change in the load and fixup code. We have to adjust that afterwards.

  LastTotalHeight := Node.TotalHeight;

  WasFullyVisible := FullyVisible[Node] and not IsEffectivelyFiltered[Node];



  // Read in the new nodes.

  ReadNode(Stream, Version, Node);



  // One time update of node-internal states and the global visibility counter.

  // This is located here to ease and speed up the loading process.

  FixupTotalCount(Node);

  AdjustTotalCount(Node.Parent, Node.TotalCount - 1, True); // -1 because Node itself was already set.

  FixupTotalHeight(Node);

  AdjustTotalHeight(Node.Parent, Node.TotalHeight - LastTotalHeight, True);



  // New nodes are always visible, so the visible node count has been increased already.

  // If Node is now invisible we have to take back this increment and don't need to add any visible child node.

  if not FullyVisible[Node] or IsEffectivelyFiltered[Node] then

  begin

    if WasFullyVisible then

      Dec(FVisibleCount);

  end

  else

    // It can never happen that the node is now fully visible but was not before as this would require

    // that the visibility state of one of its parents has changed, which cannot happen during loading.

    Inc(FVisibleCount, CountVisibleChildren(Node));



  // Fix selection array.

  ClearTempCache;

  if Node = FRoot then

    Stop := nil

  else

    Stop := Node.NextSibling;



  if toMultiSelect in FOptions.FSelectionOptions then

  begin

    // Add all nodes which were selected before to the current selection (unless they are already there).

    while Node <> Stop do

    begin

      if (vsSelected in Node.States) and not FindNodeInSelection(Node, Index, 0, High(FSelection)) then

        InternalCacheNode(Node);

      Node := GetNextNoInit(Node);

    end;

    if FTempNodeCount > 0 then

      AddToSelection(FTempNodeCache, FTempNodeCount, True);

    ClearTempCache;

  end

  else // No further selected nodes allowed so delete the corresponding flag in all new nodes.

    while Node <> Stop do

    begin

      Exclude(Node.States, vsSelected);

      Node := GetNextNoInit(Node);

    end;

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.InternalAddToSelection(Node: PVirtualNode; ForceInsert: Boolean): Boolean;



begin

  Assert(Assigned(Node), 'Node must not be nil!');

  FSingletonNodeArray[0] := Node;

  Result := InternalAddToSelection(FSingletonNodeArray, 1, ForceInsert);

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.InternalAddToSelection(const NewItems: TNodeArray; NewLength: Integer;

  ForceInsert: Boolean): Boolean;



// Internal version of method AddToSelection which does not trigger OnChange events



var

  I, J: Integer;

  CurrentEnd: Integer;

  Constrained,

  SiblingConstrained: Boolean;



begin

  // The idea behind this code is to use a kind of reverse merge sort. QuickSort is quite fast

  // and would do the job here too but has a serious problem with already sorted lists like FSelection.



  // 1) Remove already selected items, mark all other as being selected.

  if ForceInsert then

  begin

    for I := 0 to NewLength - 1 do

    begin

      Include(NewItems[I].States, vsSelected);

      if Assigned(FOnAddToSelection) then

        FOnAddToSelection(Self, NewItems[I]);

    end;

  end

  else

  begin

    Constrained := toLevelSelectConstraint in FOptions.FSelectionOptions;

    if Constrained and (FLastSelectionLevel = -1) then

      FLastSelectionLevel := GetNodeLevel(NewItems[0]);

    SiblingConstrained := toSiblingSelectConstraint in FOptions.FSelectionOptions;

    if SiblingConstrained and (FRangeAnchor = nil) then

      FRangeAnchor := NewItems[0];



    for I := 0 to NewLength - 1 do

      if ([vsSelected, vsDisabled] * NewItems[I].States <> []) or

         (Constrained and (Cardinal(FLastSelectionLevel) <> GetNodeLevel(NewItems[I]))) or

         (SiblingConstrained and (FRangeAnchor.Parent <> NewItems[I].Parent)) then

        Inc(PAnsiChar(NewItems[I]))

      else

      begin

        Include(NewItems[I].States, vsSelected);

        if Assigned(FOnAddToSelection) then

          FOnAddToSelection(Self, NewItems[I]);

      end;

  end;



  I := PackArray(NewItems, NewLength);

  if I > -1 then

    NewLength := I;



  Result := NewLength > 0;

  if Result then

  begin

    // 2) Sort the new item list so we can easily traverse it.

    if NewLength > 1 then

      QuickSort(NewItems, 0, NewLength - 1);

    // 3) Make room in FSelection for the new items.

    if FSelectionCount + NewLength >= Length(FSelection) then

      SetLength(FSelection, FSelectionCount + NewLength);



    // 4) Merge in new items

    J := NewLength - 1;

    CurrentEnd := FSelectionCount - 1;



    while J >= 0 do

    begin

      // First insert all new entries which are greater than the greatest entry in the old list.

      // If the current end marker is < 0 then there's nothing more to move in the selection

      // array and only the remaining new items must be inserted.

      if CurrentEnd >= 0 then

      begin

        while (J >= 0) and (PAnsiChar(NewItems[J]) > PAnsiChar(FSelection[CurrentEnd])) do

        begin

          FSelection[CurrentEnd + J + 1] := NewItems[J];

          Dec(J);

        end;

        // early out if nothing more needs to be copied

        if J < 0 then

          Break;

      end

      else

      begin

        // insert remaining new entries at position 0

        Move(NewItems[0], FSelection[0], (J + 1) * SizeOf(Pointer));

        // nothing more to do so exit main loop

        Break;

      end;



      // find the last entry in the remaining selection list which is smaller then the largest

      // entry in the remaining new items list

      FindNodeInSelection(NewItems[J], I, 0, CurrentEnd);

      Dec(I);

      // move all entries which are greater than the greatest entry in the new items list up

      // so the remaining gap travels down to where new items must be inserted

      Move(FSelection[I + 1], FSelection[I + J + 2], (CurrentEnd - I) * SizeOf(Pointer));

      CurrentEnd := I;

    end;



    Inc(FSelectionCount, NewLength);

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.InternalCacheNode(Node: PVirtualNode);



// Adds the given node to the temporary node cache (used when collecting possibly large amounts of nodes).



var

  Len: Cardinal;



begin

  Len := Length(FTempNodeCache);

  if FTempNodeCount = Len then

  begin

    if Len < 100 then

      Len := 100

    else

      Len := Len + Len div 10;

    SetLength(FTempNodeCache, Len);

  end;

  FTempNodeCache[FTempNodeCount] := Node;

  Inc(FTempNodeCount);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.InternalClearSelection;



var

  Count: Integer;



begin

  // It is possible that there are invalid node references in the selection array

  // if the tree update is locked and changes in the structure were made.

  // Handle this potentially dangerous situation by packing the selection array explicitely.

  if FUpdateCount > 0 then

  begin

    Count := PackArray(FSelection, FSelectionCount);

    if Count > -1 then

    begin

      FSelectionCount := Count;

      SetLength(FSelection, FSelectionCount);

    end;

  end;



  while FSelectionCount > 0 do

  begin

    Dec(FSelectionCount);

    Exclude(FSelection[FSelectionCount].States, vsSelected);

    DoRemoveFromSelection(FSelection[FSelectionCount]);

  end;

  ResetRangeAnchor;

  FSelection := nil;

  DoStateChange([], [tsClearPending]);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.InternalConnectNode(Node, Destination: PVirtualNode; Target: TBaseVirtualTree;

  Mode: TVTNodeAttachMode);



// Connects Node with Destination depending on Mode.

// No error checking takes place. Node as well as Destination must be valid. Node must never be a root node and

// Destination must not be a root node if Mode is amInsertBefore or amInsertAfter.



var

  Run: PVirtualNode;



begin

  // Keep in mind that the destination node might belong to another tree.

  with Target do

  begin

    case Mode of

      amInsertBefore:

        begin

          Node.PrevSibling := Destination.PrevSibling;

          Destination.PrevSibling := Node;

          Node.NextSibling := Destination;

          Node.Parent := Destination.Parent;

          Node.Index := Destination.Index;

          if Node.PrevSibling = nil then

            Node.Parent.FirstChild := Node

          else

            Node.PrevSibling.NextSibling := Node;



          // reindex all following nodes

          Run := Destination;

          while Assigned(Run) do

          begin

            Inc(Run.Index);

            Run := Run.NextSibling;

          end;



          Inc(Destination.Parent.ChildCount);

          Include(Destination.Parent.States, vsHasChildren);

          AdjustTotalCount(Destination.Parent, Node.TotalCount, True);



          // Add the new node's height only if its parent is expanded.

          if FullyVisible[Node] then

          begin

            AdjustTotalHeight(Destination.Parent, Node.TotalHeight, True);

            Inc(FVisibleCount, CountVisibleChildren(Node) + Cardinal(IfThen(IsEffectivelyVisible[Node], 1)));

          end;

        end;

      amInsertAfter:

        begin

          Node.NextSibling := Destination.NextSibling;

          Destination.NextSibling := Node;

          Node.PrevSibling := Destination;

          Node.Parent := Destination.Parent;

          if Node.NextSibling = nil then

            Node.Parent.LastChild := Node

          else

            Node.NextSibling.PrevSibling := Node;

          Node.Index := Destination.Index;



          // reindex all following nodes

          Run := Node;

          while Assigned(Run) do

          begin

            Inc(Run.Index);

            Run := Run.NextSibling;

          end;



          Inc(Destination.Parent.ChildCount);

          Include(Destination.Parent.States, vsHasChildren);

          AdjustTotalCount(Destination.Parent, Node.TotalCount, True);



          // Add the new node's height only if its parent is expanded.

          if FullyVisible[Node] then

          begin

            AdjustTotalHeight(Destination.Parent, Node.TotalHeight, True);

            Inc(FVisibleCount, CountVisibleChildren(Node) + Cardinal(IfThen(IsEffectivelyVisible[Node], 1)));

          end;

        end;

      amAddChildFirst:

        begin

          if Assigned(Destination.FirstChild) then

          begin

            // If there's a first child then there must also be a last child.

            Destination.FirstChild.PrevSibling := Node;

            Node.NextSibling := Destination.FirstChild;

            Destination.FirstChild := Node;

          end

          else

          begin

            // First child node at this location.

            Destination.FirstChild := Node;

            Destination.LastChild := Node;

            Node.NextSibling := nil;

          end;

          Node.PrevSibling := nil;

          Node.Parent := Destination;

          Node.Index := 0;

          // reindex all following nodes

          Run := Node.NextSibling;

          while Assigned(Run) do

          begin

            Inc(Run.Index);

            Run := Run.NextSibling;

          end;



          Inc(Destination.ChildCount);

          Include(Destination.States, vsHasChildren);

          AdjustTotalCount(Destination, Node.TotalCount, True);

          // Add the new node's height only if its parent is expanded.

          if FullyVisible[Node] then

          begin

            AdjustTotalHeight(Destination, Node.TotalHeight, True);

            Inc(FVisibleCount, CountVisibleChildren(Node) + Cardinal(IfThen(IsEffectivelyVisible[Node], 1)));

          end;

        end;

      amAddChildLast:

        begin

          if Assigned(Destination.LastChild) then

          begin

            // If there's a last child then there must also be a first child.

            Destination.LastChild.NextSibling := Node;

            Node.PrevSibling := Destination.LastChild;

            Destination.LastChild := Node;

          end

          else

          begin

            // first child node at this location

            Destination.FirstChild := Node;

            Destination.LastChild := Node;

            Node.PrevSibling := nil;

          end;

          Node.NextSibling := nil;

          Node.Parent := Destination;

          if Assigned(Node.PrevSibling) then

            Node.Index := Node.PrevSibling.Index + 1

          else

            Node.Index := 0;

          Inc(Destination.ChildCount);

          Include(Destination.States, vsHasChildren);

          AdjustTotalCount(Destination, Node.TotalCount, True);

          // Add the new node's height only if its parent is expanded.

          if FullyVisible[Node] then

          begin

            AdjustTotalHeight(Destination, Node.TotalHeight, True);

            Inc(FVisibleCount, CountVisibleChildren(Node) + Cardinal(IfThen(IsEffectivelyVisible[Node], 1)));

          end;

        end;

    else

      // amNoWhere: do nothing

    end;



    // Remove temporary states.

    Node.States := Node.States - [vsChecking, vsCutOrCopy, vsDeleting, vsClearing];



    // Update the hidden children flag of the parent.

    if (Mode <> amNoWhere) and (Node.Parent <> FRoot) then

    begin

      // If we have added a visible node then simply remove the all-children-hidden flag.

      if IsEffectivelyVisible[Node] then

        Exclude(Node.Parent.States, vsAllChildrenHidden)

      else

        // If we have added an invisible node and this is the only child node then

        // make sure the all-children-hidden flag is in a determined state.

        // If there were child nodes before then no action is needed.

        if Node.Parent.ChildCount = 1 then

          Include(Node.Parent.States, vsAllChildrenHidden);

    end;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.InternalData(Node: PVirtualNode): Pointer;



begin

  Result := nil;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.InternalDisconnectNode(Node: PVirtualNode; KeepFocus: Boolean; Reindex: Boolean = True);



// Disconnects the given node from its parent and siblings. The node's pointer are not reset so they can still be used

// after return from this method (probably a very short time only!).

// If KeepFocus is True then the focused node is not reset. This is useful if the given node is reconnected to the tree

// immediately after return of this method and should stay being the focused node if it was it before.

// Note: Node must not be nil or the root node.



var

  Parent,

  Run: PVirtualNode;

  Index: Integer;

  AdjustHeight: Boolean;



begin

  Assert(Assigned(Node) and (Node <> FRoot), 'Node must neither be nil nor the root node.');



  if (Node = FFocusedNode) and not KeepFocus then

  begin

    DoFocusNode(nil, False);

    DoFocusChange(FFocusedNode, FFocusedColumn);

  end;



  if Node = FRangeAnchor then

    ResetRangeAnchor;



  // Update the hidden children flag of the parent.

  if (Node.Parent <> FRoot) and not (vsClearing in Node.Parent.States) then

    if FUpdateCount = 0 then

      DetermineHiddenChildrenFlag(Node.Parent)

    else

      Include(FStates, tsUpdateHiddenChildrenNeeded);



  if not (vsDeleting in Node.States) then

  begin

    // Some states are only temporary so take them out.

    Node.States := Node.States - [vsChecking];

    Parent := Node.Parent;

    Dec(Parent.ChildCount);

    AdjustHeight := (vsExpanded in Parent.States) and (vsVisible in Node.States);

    if Parent.ChildCount = 0 then

    begin

      Parent.States := Parent.States - [vsAllChildrenHidden, vsHasChildren];

      if (Parent <> FRoot) and (vsExpanded in Parent.States) then

        Exclude(Parent.States, vsExpanded);

    end;

    AdjustTotalCount(Parent, -Integer(Node.TotalCount), True);

    if AdjustHeight then

      AdjustTotalHeight(Parent, -Integer(Node.TotalHeight), True);

    if FullyVisible[Node] then

      Dec(FVisibleCount, CountVisibleChildren(Node) + Cardinal(IfThen(IsEffectivelyVisible[Node], 1)));



    if Assigned(Node.PrevSibling) then

      Node.PrevSibling.NextSibling := Node.NextSibling

    else

      Parent.FirstChild := Node.NextSibling;



    if Assigned(Node.NextSibling) then

    begin

      Node.NextSibling.PrevSibling := Node.PrevSibling;

      // Reindex all following nodes.

      if Reindex then

      begin

        Run := Node.NextSibling;

        Index := Node.Index;

        while Assigned(Run) do

        begin

          Run.Index := Index;

          Inc(Index);

          Run := Run.NextSibling;

        end;

      end;

    end

    else

      Parent.LastChild := Node.PrevSibling;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.InternalRemoveFromSelection(Node: PVirtualNode);



// Special version to mark a node to be no longer in the current selection. PackArray must

// be used to remove finally those entries.



var

  Index: Integer;



begin

  // Because pointers are always DWORD aligned we can simply increment all those

  // which we want to have removed (see also PackArray) and still have the

  // order in the list preserved.

  if FindNodeInSelection(Node, Index, -1, -1) then

  begin

    Exclude(Node.States, vsSelected);

    Inc(PAnsiChar(FSelection[Index]));

    DoRemoveFromSelection(Node);

    AdviseChangeEvent(False, Node, crIgnore);

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.InvalidateCache;



// Marks the cache as invalid.



begin

  DoStateChange([tsValidationNeeded], [tsUseCache]);

  //ChangeTreeStatesAsync([csValidationNeeded], [csUseCache]);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.MarkCutCopyNodes;



// Sets the vsCutOrCopy style in every currently selected but not disabled node to indicate it is

// now part of a clipboard operation.



var

  Nodes: TNodeArray;

  I: Integer;



begin

  Nodes := nil;

  if FSelectionCount > 0 then

  begin

    // need the current selection sorted to exclude selected nodes which are children, grandchildren etc. of

    // already selected nodes

    Nodes := GetSortedSelection(False);

    for I := 0 to High(Nodes) do

      with Nodes[I]^ do

        if not (vsDisabled in States) then

          Include(States, vsCutOrCopy);

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.Loaded;



var

  LastRootCount: Cardinal;

  IsReadOnly: Boolean;



begin

  inherited;



  // Call RegisterDragDrop after all visual inheritance changes to MiscOptions have been applied.

  if not (csDesigning in ComponentState) and (toAcceptOLEDrop in FOptions.FMiscOptions) then

    if HandleAllocated then

      RegisterDragDrop(Handle, DragManager as IDropTarget);



  {$IF CompilerVersion >= 23}

    FSavedBorderWidth := BorderWidth;

    FSavedBevelKind := BevelKind;

  {$IFEND}

  VclStyleChanged;

  // If a root node count has been set during load of the tree then update its child structure now

  // as this hasn't been done yet in this case.

  if (tsNeedRootCountUpdate in FStates) and (FRoot.ChildCount > 0) then

  begin

    DoStateChange([], [tsNeedRootCountUpdate]);

    IsReadOnly := toReadOnly in FOptions.FMiscOptions;

    Exclude(FOptions.FMiscOptions, toReadOnly);

    LastRootCount := FRoot.ChildCount;

    FRoot.ChildCount := 0;

    BeginUpdate;

    SetChildCount(FRoot, LastRootCount);

    EndUpdate;

    if IsReadOnly then

      Include(FOptions.FMiscOptions, toReadOnly);

  end;



  // Prevent the object inspector at design time from marking the header as being modified

  // when auto resize is enabled.

  Updating;

  try

    FHeader.UpdateMainColumn;

    FHeader.FColumns.FixPositions;

    if toAutoBidiColumnOrdering in FOptions.FAutoOptions then

      FHeader.FColumns.ReorderColumns(UseRightToLeftAlignment);

    // Because of the special recursion and update stopper when creating the window (or resizing it)

    // we have to manually trigger the auto size calculation here.

    if hsNeedScaling in FHeader.FStates then

      FHeader.RescaleHeader

    else

      FHeader.RecalculateHeader;

    if hoAutoResize in FHeader.FOptions then

      FHeader.FColumns.AdjustAutoSize(InvalidColumn, True);

  finally

    Updated;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.MainColumnChanged;



begin

  DoCancelEdit;



  if Assigned(FAccessibleItem) then

    NotifyWinEvent(EVENT_OBJECT_NAMECHANGE, Handle, OBJID_CLIENT, CHILDID_SELF);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.MouseMove(Shift: TShiftState; X, Y: Integer);



var

  R: TRect;



begin

  if tsNodeHeightTrackPending in FStates then

  begin

    // Remove hint if shown currently.

    Application.CancelHint;



    // Stop wheel panning if active.

    StopWheelPanning;



    // Stop timers

    StopTimer(ExpandTimer);

    StopTimer(EditTimer);

    StopTimer(HeaderTimer);

    StopTimer(ScrollTimer);

    StopTimer(SearchTimer);

    FSearchBuffer := '';

    FLastSearchNode := nil;



    DoStateChange([tsNodeHeightTracking], [tsScrollPending, tsScrolling, tsEditPending, tsOLEDragPending, tsVCLDragPending,

      tsIncrementalSearching, tsNodeHeightTrackPending]);

  end;



  if tsDrawSelPending in FStates then

  begin

    // Remove current selection in case the user clicked somewhere in the window (but not a node)

    // and moved the mouse.

    if CalculateSelectionRect(X, Y) then

    begin

      InvalidateRect(Handle, @FNewSelRect, False);

      UpdateWindow(Handle);

      if (Abs(FNewSelRect.Right - FNewSelRect.Left) > Mouse.DragThreshold) or

         (Abs(FNewSelRect.Bottom - FNewSelRect.Top) > Mouse.DragThreshold) then

      begin

        if tsClearPending in FStates then

        begin

          DoStateChange([], [tsClearPending]);

          ClearSelection;

        end;

        DoStateChange([tsDrawSelecting], [tsDrawSelPending]);



        // Reset to main column for multiselection.

        FocusedColumn := FHeader.MainColumn;



        // The current rectangle may already include some node captions. Handle this.

        if HandleDrawSelection(X, Y) then

          InvalidateRect(Handle, nil, False);

      end;

    end;

  end

  else

  begin

    if tsNodeHeightTracking in FStates then

    begin

      // Handle height tracking.

      if DoNodeHeightTracking(FHeightTrackNode, FHeightTrackColumn, FHeader.GetShiftState,

        FHeightTrackPoint, Point(X, Y)) then

      begin

        // Avoid negative (or zero) node heights.

        if FHeightTrackPoint.Y >= Y then

          Y := FHeightTrackPoint.Y + 1;

        SetNodeHeight(FHeightTrackNode, Y - FHeightTrackPoint.Y);

        UpdateWindow(Handle);

        Exit;

      end;

    end;



    // If both wheel panning and auto scrolling are pending then the user moved the mouse while holding down the

    // middle mouse button. This means panning is being used, hence remove the wheel scroll flag.

    if [tsWheelPanning, tsWheelScrolling] * FStates = [tsWheelPanning, tsWheelScrolling] then

    begin

      if ((Abs(FLastClickPos.X - X) >= Mouse.DragThreshold) or (Abs(FLastClickPos.Y - Y) >= Mouse.DragThreshold)) then

        DoStateChange([], [tsWheelScrolling]);

    end;



    // Really start dragging if the mouse has been moved more than the threshold.

    if (tsOLEDragPending in FStates) and ((Abs(FLastClickPos.X - X) >= FDragThreshold) or

       (Abs(FLastClickPos.Y - Y) >= FDragThreshold)) then

      DoDragging(FLastClickPos)

    else

    begin

      if CanAutoScroll then

        DoAutoScroll(X, Y);

      if [tsWheelPanning, tsWheelScrolling] * FStates <> [] then

        AdjustPanningCursor(X, Y);

      if not IsMouseSelecting then

      begin

        HandleHotTrack(X, Y);

        inherited MouseMove(Shift, X, Y);

      end

      else

      begin

        // Handle draw selection if required, but don't do the work twice if the

        // auto scrolling code already cares about the selection.

        if not (tsScrolling in FStates) and CalculateSelectionRect(X, Y) then

        begin

          // If something in the selection changed then invalidate the entire

          // tree instead trying to figure out the display rects of all changed nodes.

          if HandleDrawSelection(X, Y) then

            InvalidateRect(Handle, nil, False)

          else

          begin

            UnionRect(R, OrderRect(FNewSelRect), OrderRect(FLastSelRect));

            OffsetRect(R, -FEffectiveOffsetX, FOffsetY);

            InvalidateRect(Handle, @R, False);

          end;

          UpdateWindow(Handle);

        end;

      end;

    end;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.Notification(AComponent: TComponent; Operation: TOperation);



begin

  if (AComponent <> Self) and (Operation = opRemove) then

  begin

    // Check for components linked to the tree.

    if AComponent = FImages then

    begin

      Images := nil;

      if not (csDestroying in ComponentState) then

        Invalidate;

    end

    else

      if AComponent = FStateImages then

      begin

        StateImages := nil;

        if not (csDestroying in ComponentState) then

          Invalidate;

      end

      else

        if AComponent = FCustomCheckImages then

        begin

          CustomCheckImages := nil;

          FCheckImageKind := ckSystemDefault;

          if not (csDestroying in ComponentState) then

            Invalidate;

        end

        else

          if AComponent = PopupMenu then

            PopupMenu := nil

          else

            // Check for components linked to the header.

            if Assigned(FHeader) then

            begin

              if AComponent = FHeader.FImages then

                FHeader.Images := nil

              else

                if AComponent = FHeader.PopupMenu then

                  FHeader.PopupMenu := nil;

            end;

  end;

  inherited;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.OriginalWMNCPaint(DC: HDC);



// Unfortunately, the painting for the non-client area in TControl is not always correct and does also not consider

// existing clipping regions, so it has been modified here to take this into account.



const

  InnerStyles: array[TBevelCut] of Integer = (0, BDR_SUNKENINNER, BDR_RAISEDINNER, 0);

  OuterStyles: array[TBevelCut] of Integer = (0, BDR_SUNKENOUTER, BDR_RAISEDOUTER, 0);

  EdgeStyles: array[TBevelKind] of Integer = (0, 0, BF_SOFT, BF_FLAT);

  Ctl3DStyles: array[Boolean] of Integer = (BF_MONO, 0);



var

  RC, RW: TRect;

  EdgeSize: Integer;

  Size: TSize;



begin

  if (BevelKind <> bkNone) or (BorderWidth > 0) then

  begin

    RC := Rect(0, 0, Width, Height);

    Size := GetBorderDimensions;

    InflateRect(RC, Size.cx, Size.cy);



    RW := RC;



    if BevelKind <> bkNone then

    begin

      DrawEdge(DC, RC, InnerStyles[BevelInner] or OuterStyles[BevelOuter], Byte(BevelEdges) or EdgeStyles[BevelKind] or

        Ctl3DStyles[Ctl3D]);



      EdgeSize := 0;

      if BevelInner <> bvNone then

        Inc(EdgeSize, BevelWidth);

      if BevelOuter <> bvNone then

        Inc(EdgeSize, BevelWidth);

      with TWithSafeRect(RC) do

      begin

        if beLeft in BevelEdges then

          Inc(Left, EdgeSize);

        if beTop in BevelEdges then

          Inc(Top, EdgeSize);

        if beRight in BevelEdges then

          Dec(Right, EdgeSize);

        if beBottom in BevelEdges then

          Dec(Bottom, EdgeSize);

      end;

    end;



    // Repaint only the part in the original clipping region and not yet drawn parts.

    IntersectClipRect(DC, RC.Left, RC.Top, RC.Right, RC.Bottom);



    // Determine inner rectangle to exclude (RC corresponds then to the client area).

    InflateRect(RC, -Integer(BorderWidth), -Integer(BorderWidth));



    // Remove the inner rectangle.

    ExcludeClipRect(DC, RC.Left, RC.Top, RC.Right, RC.Bottom);



    // Erase parts not drawn.

    Brush.Color := FColors.BorderColor;

    Windows.FillRect(DC, RW, Brush.Handle);

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.Paint;



// Window paint routine. Used when the tree window needs to be updated.



var

  Window: TRect;

  Target: TPoint;

  Temp: Integer;

  Options: TVTInternalPaintOptions;

  RTLOffset: Integer;



begin

  Options := [poBackground, poColumnColor, poDrawFocusRect, poDrawDropMark, poDrawSelection, poGridLines];

  if UseRightToLeftAlignment and FHeader.UseColumns then

    RTLOffset := ComputeRTLOffset(True)

  else

    RTLOffset := 0;



  // The update rect has already been filled in WMPaint, as it is the window's update rect, which gets

  // reset when BeginPaint is called (in the ancestor).

  // The difference to the DC's clipbox is that it is also valid with internal paint operations used

  // e.g. by the Explorer while dragging, but show window content while dragging is disabled.

  if not IsRectEmpty(FUpdateRect) then

  begin

    Temp := Header.Columns.GetVisibleFixedWidth;

    if Temp = 0 then

    begin

      Window := FUpdateRect;

      Target := Window.TopLeft;



      // The clipping rectangle is given in client coordinates of the window. We have to convert it into

      // a sliding window of the tree image.

      OffsetRect(Window, FEffectiveOffsetX - RTLOffset, -FOffsetY);

      PaintTree(Canvas, Window, Target, Options);

    end

    else

    begin

      // First part, fixed columns

      Window := ClientRect;

      Window.Right := Temp;

      Target := Window.TopLeft;



      OffsetRect(Window,  -RTLOffset, -FOffsetY);

      PaintTree(Canvas, Window, Target, Options);



      // Second part, other columns

      Window := GetClientRect;



      if Temp > Window.Right then

        Exit;



      Window.Left := Temp;

      Target := Window.TopLeft;



      OffsetRect(Window, FEffectiveOffsetX - RTLOffset, -FOffsetY);

      PaintTree(Canvas, Window, Target, Options);

    end;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.PaintCheckImage(Canvas: TCanvas; const ImageInfo: TVTImageInfo; Selected: Boolean);



var

  ForegroundColor: COLORREF;

  R: TRect;

  Details: TThemedElementDetails;



begin

  with ImageInfo do

  begin

    if (tsUseThemes in FStates) and (FCheckImageKind = ckSystemDefault) then

    begin

      R := Rect(XPos - 1, YPos + 1, XPos + 16, YPos + 16);

      Details.Element := teButton;

      case Index of

        // ctRadioButton

        1 : Details := StyleServices.GetElementDetails(tbRadioButtonUncheckedNormal);

        2 : Details := StyleServices.GetElementDetails(tbRadioButtonUncheckedHot);

        3 : Details := StyleServices.GetElementDetails(tbRadioButtonUncheckedPressed);

        4 : Details := StyleServices.GetElementDetails(tbRadioButtonUncheckedDisabled);

        5 : Details := StyleServices.GetElementDetails(tbRadioButtonCheckedNormal);

        6 : Details := StyleServices.GetElementDetails(tbRadioButtonCheckedHot);

        7 : Details := StyleServices.GetElementDetails(tbRadioButtonCheckedPressed);

        8 : Details := StyleServices.GetElementDetails(tbRadioButtonCheckedDisabled);

       // ct(TriState)CheckBox

        9 : Details := StyleServices.GetElementDetails(tbCheckBoxUncheckedNormal);

       10 : Details := StyleServices.GetElementDetails(tbCheckBoxUncheckedHot);

       11 : Details := StyleServices.GetElementDetails(tbCheckBoxUncheckedPressed);

       12 : Details := StyleServices.GetElementDetails(tbCheckBoxUncheckedDisabled);

       13 : Details := StyleServices.GetElementDetails(tbCheckBoxCheckedNormal);

       14 : Details := StyleServices.GetElementDetails(tbCheckBoxCheckedHot);

       15 : Details := StyleServices.GetElementDetails(tbCheckBoxCheckedPressed);

       16 : Details := StyleServices.GetElementDetails(tbCheckBoxCheckedDisabled);

       17 : Details := StyleServices.GetElementDetails(tbCheckBoxMixedNormal);

       18 : Details := StyleServices.GetElementDetails(tbCheckBoxMixedHot);

       19 : Details := StyleServices.GetElementDetails(tbCheckBoxMixedPressed);

       20 : Details := StyleServices.GetElementDetails(tbCheckBoxMixedDisabled);

       // ctButton

       21 : Details := StyleServices.GetElementDetails(tbPushButtonNormal);

       22 : Details := StyleServices.GetElementDetails(tbPushButtonHot);

       23 : Details := StyleServices.GetElementDetails(tbPushButtonPressed);

       24 : Details := StyleServices.GetElementDetails(tbPushButtonDisabled);

      else

        Details := StyleServices.GetElementDetails(tbButtonRoot);

      end;

      StyleServices.DrawElement(Canvas.Handle, Details, R);

      if Index in [21..24] then

        UtilityImages.Draw(Canvas, XPos - 1, YPos, 4);

    end

    else

      with FCheckImages do

      begin

        if Selected and not Ghosted then

        begin

          if Focused or (toPopupMode in FOptions.FPaintOptions) then

            ForegroundColor := ColorToRGB(FColors.FocusedSelectionColor)

          else

            ForegroundColor := ColorToRGB(FColors.UnfocusedSelectionColor);

        end

        else

          ForegroundColor := GetRGBColor(BlendColor);



          ImageList_DrawEx(Handle, Index, Canvas.Handle, XPos, YPos, 0, 0, GetRGBColor(BkColor), ForegroundColor,

            ILD_TRANSPARENT);

      end;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



type

  TCustomImageListCast = class(TCustomImageList);



procedure DrawImage(ImageList: TCustomImageList; Index: Integer; Canvas: TCanvas; X, Y: Integer; Style: Cardinal; Enabled: Boolean);



  procedure DrawDisabledImage(ImageList: TCustomImageList; Canvas: TCanvas; X, Y, Index: Integer);

  {$if CompilerVersion >= 21}

  var

    Params: TImageListDrawParams;

  begin

    FillChar(Params, SizeOf(Params), 0);

    Params.cbSize := SizeOf(Params);

    Params.himl := ImageList.Handle;

    Params.i := Index;

    Params.hdcDst := Canvas.Handle;

    Params.x := X;

    Params.y := Y;

    Params.fState := ILS_SATURATE;

    ImageList_DrawIndirect(@Params);

  {$else}

  begin

    TCustomImageListCast(ImageList).DoDraw(Index, Canvas, X, Y, Style, False);

  {$ifend}

  end;



begin

  if Enabled then

    TCustomImageListCast(ImageList).DoDraw(Index, Canvas, X, Y, Style, Enabled)

  else

    DrawDisabledImage(ImageList, Canvas, X, Y, Index);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.PaintImage(var PaintInfo: TVTPaintInfo; ImageInfoIndex: TVTImageInfoIndex; DoOverlay: Boolean);

const

  Style: array[TImageType] of Cardinal = (0, ILD_MASK);

var

  ExtraStyle: Cardinal;

  CutNode: Boolean;

  PaintFocused: Boolean;

  DrawEnabled: Boolean;



begin

  with PaintInfo do

  begin

    CutNode := (vsCutOrCopy in Node.States) and (tsCutPending in FStates);

    PaintFocused := Focused or (toGhostedIfUnfocused in FOptions.FPaintOptions);



    // Since the overlay image must be specified together with the image to draw

    // it is meaningfull to retrieve it in advance.

    if DoOverlay then

      GetImageIndex(PaintInfo, ikOverlay, iiOverlay, Images)

    else

      PaintInfo.ImageInfo[iiOverlay].Index := -1;



    DrawEnabled := not (vsDisabled in Node.States) and Enabled;

    with ImageInfo[ImageInfoIndex] do

    begin

       if (vsSelected in Node.States) and not(Ghosted or CutNode) then

      begin

        if PaintFocused or (toPopupMode in FOptions.FPaintOptions) then

          Images.BlendColor := FColors.FocusedSelectionColor

        else

          Images.BlendColor := FColors.UnfocusedSelectionColor;

      end

      else

        Images.BlendColor := Color;



      // If the user returned an index >= 15 then we cannot use the built-in overlay image drawing.

      // Instead we do it manually.

      if (ImageInfo[iiOverlay].Index > -1) and (ImageInfo[iiOverlay].Index < 15) then

        ExtraStyle := ILD_TRANSPARENT or ILD_OVERLAYMASK and IndexToOverlayMask(ImageInfo[iiOverlay].Index + 1)

      else

        ExtraStyle := ILD_TRANSPARENT;



      // Blend image if enabled and the tree has the focus (or ghosted images must be drawn also if unfocused) ...

      if (toUseBlendedImages in FOptions.FPaintOptions) and PaintFocused

        // ... and the image is ghosted...

        and (Ghosted or

        // ... or it is not the check image and the node is selected (but selection is not for the entire row)...

        ((vsSelected in Node.States) and

        not (toFullRowSelect in FOptions.FSelectionOptions) and

        not (toGridExtensions in FOptions.FMiscOptions)) or

        // ... or the node must be shown in cut mode.

        CutNode) then

        ExtraStyle := ExtraStyle or ILD_BLEND50;



      if (vsSelected in Node.States) and not Ghosted then

        Images.BlendColor := clDefault;



      DrawImage(Images, Index, Canvas, XPos, YPos, Style[Images.ImageType] or ExtraStyle, DrawEnabled);



      // Now, draw the overlay. This circumnavigates limitations in the overlay mask index (it has to be 4 bits in size,

      // anything larger will be truncated by the ILD_OVERLAYMASK).

      // However this will only be done if the overlay image index is > 15, to avoid breaking code that relies

      // on overlay image indices (e.g. when using system image lists).

      if PaintInfo.ImageInfo[iiOverlay].Index >= 15 then

        // Note: XPos and YPos are those of the normal images.

        DrawImage(ImageInfo[iiOverlay].Images, ImageInfo[iiOverlay].Index, Canvas, XPos, YPos,

          Style[ImageInfo[iiOverlay].Images.ImageType] or ExtraStyle, DrawEnabled);

    end;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.PaintNodeButton(Canvas: TCanvas; Node: PVirtualNode; Column: TColumnIndex; const R: TRect;

  ButtonX, ButtonY: Integer; BidiMode: TBiDiMode);



var

  Bitmap: TBitmap;

  XPos: Integer;

  IsHot: Boolean;

  Theme: HTHEME;

  Glyph: Integer;

  State: Integer;

  Pos: TRect;



begin

  IsHot := (toHotTrack in FOptions.FPaintOptions) and (FCurrentHotNode = Node) and FHotNodeButtonHit;



  // Draw the node's plus/minus button according to the directionality.

  if BidiMode = bdLeftToRight then

    XPos := R.Left + ButtonX

  else

    XPos := R.Right - ButtonX - FPlusBM.Width;



  if tsUseExplorerTheme in FStates then

  begin

    Glyph := IfThen(IsHot, TVP_HOTGLYPH, TVP_GLYPH);

    State := IfThen(vsExpanded in Node.States, GLPS_OPENED, GLPS_CLOSED);

    Pos := Rect(XPos, R.Top + ButtonY, XPos + FPlusBM.Width, R.Top + ButtonY + FPlusBM.Height);

    Theme := OpenThemeData(Handle, 'TREEVIEW');

    DrawThemeBackground(Theme, Canvas.Handle, Glyph, State, Pos, nil);

    CloseThemeData(Theme);

  end

  else

  begin

    if vsExpanded in Node.States then

    begin

      if IsHot then

        Bitmap := FHotMinusBM

      else

        Bitmap := FMinusBM;

    end

    else

    begin

      if IsHot then

        Bitmap := FHotPlusBM

      else

        Bitmap := FPlusBM;

    end;

    // Need to draw this masked.

    Canvas.Draw(XPos, R.Top + ButtonY, Bitmap);

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.PaintTreeLines(const PaintInfo: TVTPaintInfo; VAlignment, IndentSize: Integer;

  LineImage: TLineImage);



var

  I: Integer;

  XPos,

  Offset: Integer;

  NewStyles: TLineImage;



begin

  NewStyles := nil;



  with PaintInfo do

  begin

    if BidiMode = bdLeftToRight then

    begin

      XPos := CellRect.Left;

      Offset := FIndent;

    end

    else

    begin

      Offset := -Integer(FIndent);

      XPos := CellRect.Right + Offset;

    end;



    case FLineMode of

      lmBands:

        if poGridLines in PaintInfo.PaintOptions then

        begin

          // Convert the line images in correct bands.

          SetLength(NewStyles, Length(LineImage));

          for I := IndentSize - 1 downto 0 do

          begin

            if (vsExpanded in Node.States) and not (vsAllChildrenHidden in Node.States) then

              NewStyles[I] := ltLeft

            else

              case LineImage[I] of

                ltRight,

                ltBottomRight,

                ltTopDownRight,

                ltTopRight:

                  NewStyles[I] := ltLeftBottom;

                ltNone:

                  // Have to take over the image to the right of this one. A no line entry can never appear as

                  // last entry so I don't need an end check here.

                  if LineImage[I + 1] in [ltNone, ltTopRight] then

                    NewStyles[I] := NewStyles[I + 1]

                  else

                    NewStyles[I] := ltLeft;

                ltTopDown:

                  // Have to check the image to the right of this one. A top down line can never appear as

                  // last entry so I don't need an end check here.

                  if LineImage[I + 1] in [ltNone, ltTopRight] then

                    NewStyles[I] := NewStyles[I + 1]

                  else

                    NewStyles[I] := ltLeft;

              end;

          end;



          PaintInfo.Canvas.Font.Color := FColors.GridLineColor;

          for I := 0 to IndentSize - 1 do

          begin

            DoBeforeDrawLineImage(PaintInfo.Node, I + Ord(not (toShowRoot in TreeOptions.PaintOptions)), XPos);

            DrawLineImage(PaintInfo, XPos, CellRect.Top, NodeHeight[Node] - 1, VAlignment - 1, NewStyles[I],

              BidiMode <> bdLeftToRight);

            Inc(XPos, Offset);

          end;

        end;

    else // lmNormal

      PaintInfo.Canvas.Font.Color := FColors.TreeLineColor;

      for I := 0 to IndentSize - 1 do

      begin

        DoBeforeDrawLineImage(PaintInfo.Node, I + Ord(not (toShowRoot in TreeOptions.PaintOptions)), XPos);

        DrawLineImage(PaintInfo, XPos, CellRect.Top, NodeHeight[Node], VAlignment - 1, LineImage[I],

          BidiMode <> bdLeftToRight);

        Inc(XPos, Offset);

      end;

    end;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.PaintSelectionRectangle(Target: TCanvas; WindowOrgX: Integer; const SelectionRect: TRect;

  TargetRect: TRect);



// Helper routine to draw a selection rectangle in the mode determined by DrawSelectionMode.



var

  BlendRect: TRect;

  TextColorBackup,

  BackColorBackup: COLORREF;   // used to restore forground and background colors when drawing a selection rectangle



begin

  if ((FDrawSelectionMode = smDottedRectangle) and not (tsUseThemes in FStates)) or

    not MMXAvailable then

  begin

    // Classical selection rectangle using dotted borderlines.

    TextColorBackup := GetTextColor(Target.Handle);

    SetTextColor(Target.Handle, $FFFFFF);

    BackColorBackup := GetBkColor(Target.Handle);

    SetBkColor(Target.Handle, 0);

    Target.DrawFocusRect(SelectionRect);

    SetTextColor(Target.Handle, TextColorBackup);

    SetBkColor(Target.Handle, BackColorBackup);

  end

  else

  begin

    // Modern alpha blended style.

    OffsetRect(TargetRect, WindowOrgX, 0);

    if IntersectRect(BlendRect, OrderRect(SelectionRect), TargetRect) then

    begin

      OffsetRect(BlendRect, -WindowOrgX, 0);

      AlphaBlend(0, Target.Handle, BlendRect, Point(0, 0), bmConstantAlphaAndColor, FSelectionBlendFactor,

        ColorToRGB(FColors.SelectionRectangleBlendColor));



      Target.Brush.Color := FColors.SelectionRectangleBorderColor;

      Target.FrameRect(SelectionRect);

    end;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.PanningWindowProc(var Message: TMessage);



var

  PS: TPaintStruct;

  Canvas: TCanvas;



begin

  if Message.Msg = WM_PAINT then

  begin

    BeginPaint(FPanningWindow, PS);

    Canvas := TCanvas.Create;

    Canvas.Handle := PS.hdc;

    try

      Canvas.Draw(0, 0, FPanningImage);

    finally

      Canvas.Handle := 0;

      Canvas.Free;

      EndPaint(FPanningWindow, PS);

    end;

    Message.Result := 0;

  end

  else

    with Message do

      Result := DefWindowProc(FPanningWindow, Msg, wParam, lParam);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.PrepareCell(var PaintInfo: TVTPaintInfo; WindowOrgX, MaxWidth: Integer);



// This method is called immediately before a cell's content is drawn und is responsible to paint selection colors etc.



var

  TextColorBackup,

  BackColorBackup: COLORREF;

  FocusRect,

  InnerRect: TRect;

  RowRect: TRect;

  Theme: HTHEME;

{$if CompilerVersion < 19}

const

  TREIS_HOTSELECTED = 6;

{$ifend}



  //--------------- local functions -------------------------------------------



  procedure AlphaBlendSelection(Color: TColor);



  var

    R: TRect;



  begin

    // Take into account any window offset and size limitations in the target bitmap, as this is only as large

    // as necessary and might not cover the whole node. For normal painting this does not matter (because of

    // clipping) but for the MMX code there is no such check and it will crash badly when bitmap boundaries are

    // crossed.

    R := InnerRect;

    OffsetRect(R, -WindowOrgX, 0);

    if R.Left < 0 then

      R.Left := 0;

    if R.Right > MaxWidth then

      R.Right := MaxWidth;

    AlphaBlend(0, PaintInfo.Canvas.Handle, R, Point(0, 0), bmConstantAlphaAndColor,

      FSelectionBlendFactor, ColorToRGB(Color));

  end;



  //---------------------------------------------------------------------------



  procedure DrawBackground(State: Integer);

  begin

    // if the full row selection is disabled or toGridExtensions is in the MiscOptions, draw the selection

    // into the InnerRect, otherwise into the RowRect

    if not (toFullRowSelect in FOptions.FSelectionOptions) or (toGridExtensions in FOptions.FMiscOptions) then

      DrawThemeBackground(Theme, PaintInfo.Canvas.Handle, TVP_TREEITEM, State, InnerRect, nil)

    else

      DrawThemeBackground(Theme, PaintInfo.Canvas.Handle, TVP_TREEITEM, State, RowRect, nil);

  end;



  procedure DrawThemedFocusRect(State: Integer);

  var

    Theme: HTHEME;

  begin

    Theme := OpenThemeData(Application.{$if CompilerVersion >= 20}ActiveFormHandle{$else}Handle{$ifend}, 'Explorer::ItemsView');

    if not (toFullRowSelect in FOptions.FSelectionOptions) or (toGridExtensions in FOptions.FMiscOptions) then

      DrawThemeBackground(Theme, PaintInfo.Canvas.Handle, LVP_LISTDETAIL, State, InnerRect, nil)

    else

      DrawThemeBackground(Theme, PaintInfo.Canvas.Handle, LVP_LISTDETAIL, State, RowRect, nil);

    CloseThemeData(Theme);

  end;



  //--------------- end local functions ---------------------------------------



begin

  if tsUseExplorerTheme in FStates then

  begin

    Theme := OpenThemeData(Application.{$if CompilerVersion >= 20}ActiveFormHandle{$else}Handle{$ifend}, 'Explorer::TreeView');

    RowRect := Rect(0, PaintInfo.CellRect.Top, FRangeX, PaintInfo.CellRect.Bottom);

    if (Header.Columns.Count = 0) and (toFullRowSelect in TreeOptions.SelectionOptions) then

      RowRect.Right := Max(ClientWidth, RowRect.Right);

    if toShowVertGridLines in FOptions.PaintOptions then

      Dec(RowRect.Right);

  end;



  with PaintInfo, Canvas do

  begin

    // Fill cell background if its color differs from tree background.

    with FHeader.FColumns do

    if poColumnColor in PaintOptions then

    begin

      if (VclStyleEnabled and not (coParentColor in FHeader.FColumns[Column].FOptions)) then

        Brush.Color := FColors.BackGroundColor

      else

        Brush.Color := Items[Column].Color;

      FillRect(CellRect);

     end;



    // Let the application customize the cell background and the content rectangle.

    DoBeforeCellPaint(Canvas, Node, Column, cpmPaint, CellRect, ContentRect);



    InnerRect := ContentRect;



    // The selection rectangle depends on alignment.

    if not (toGridExtensions in FOptions.FMiscOptions) then

    begin

      case Alignment of

        taLeftJustify:

          with TWithSafeRect(InnerRect) do

            if Left + NodeWidth < Right then

              Right := Left + NodeWidth;

        taCenter:

          with TWithSafeRect(InnerRect) do

            if (Right - Left) > NodeWidth then

            begin

              Left := (Left + Right - NodeWidth) div 2;

              Right := Left + NodeWidth;

            end;

        taRightJustify:

          with TWithSafeRect(InnerRect) do

            if (Right - Left) > NodeWidth then

              Left := Right - NodeWidth;

      end;

    end;



    if (Column = FFocusedColumn) or (toFullRowSelect in FOptions.FSelectionOptions) then

    begin

      // Fill the selection rectangle.

      if poDrawSelection in PaintOptions then

      begin

        if Node = FDropTargetNode then

        begin

          if (FLastDropMode = dmOnNode) or (vsSelected in Node.States) then

          begin

            Brush.Color := FColors.DropTargetColor;

            Pen.Color := FColors.DropTargetBorderColor;



            if (toGridExtensions in FOptions.FMiscOptions) or

              (toFullRowSelect in FOptions.FSelectionOptions) then

              InnerRect := CellRect;

            if not IsRectEmpty(InnerRect) then

              if tsUseExplorerTheme in FStates then

                DrawBackground(TREIS_SELECTED)

              else

                if MMXAvailable and (toUseBlendedSelection in FOptions.PaintOptions) then

                  AlphaBlendSelection(Brush.Color)

                else

                  with TWithSafeRect(InnerRect) do

                    RoundRect(Left, Top, Right, Bottom, FSelectionCurveRadius, FSelectionCurveRadius);

          end

          else

          begin

            Brush.Style := bsClear;

          end;

        end

        else

          if vsSelected in Node.States then

          begin

             if Focused or (toPopupMode in FOptions.FPaintOptions) then

             begin

              Brush.Color := FColors.FocusedSelectionColor;

              Pen.Color := FColors.FocusedSelectionBorderColor;

            end

            else

            begin

              Brush.Color := FColors.UnfocusedSelectionColor;

              Pen.Color := FColors.UnfocusedSelectionBorderColor;

          end;



            if (toGridExtensions in FOptions.FMiscOptions) or (toFullRowSelect in FOptions.FSelectionOptions) then

              InnerRect := CellRect;

            if not IsRectEmpty(InnerRect) then

              if tsUseExplorerTheme in FStates then

              begin

                // If the node is also hot, its background will be drawn later.

                if not (toHotTrack in FOptions.FPaintOptions) or (Node <> FCurrentHotNode) or

                   ((Column <> FCurrentHotColumn) and not (toFullRowSelect in FOptions.FSelectionOptions)) then

                  DrawBackground(IfThen(Self.Focused, TREIS_SELECTED, TREIS_SELECTEDNOTFOCUS));

              end

              else

                if MMXAvailable and (toUseBlendedSelection in FOptions.PaintOptions) then

                  AlphaBlendSelection(Brush.Color)

                else

                  with TWithSafeRect(InnerRect) do

                    RoundRect(Left, Top, Right, Bottom, FSelectionCurveRadius, FSelectionCurveRadius);

          end;

      end;

    end;



    if (tsUseExplorerTheme in FStates) and (toHotTrack in FOptions.FPaintOptions) and (Node = FCurrentHotNode) and

       ((Column = FCurrentHotColumn) or (toFullRowSelect in FOptions.FSelectionOptions)) then

      DrawBackground(IfThen((vsSelected in Node.States) and not (toAlwaysHideSelection in FOptions.FPaintOptions),

                            TREIS_HOTSELECTED, TREIS_HOT));



    if (Column = FFocusedColumn) or (toFullRowSelect in FOptions.FSelectionOptions) then

    begin

      // draw focus rect

      if (poDrawFocusRect in PaintOptions) and

         (Focused or (toPopupMode in FOptions.FPaintOptions)) and (FFocusedNode = Node) and

         ( (Column = FFocusedColumn) or

             ((not (toExtendedFocus in FOptions.FSelectionOptions) or IsWinVistaOrAbove) and

             (toFullRowSelect in FOptions.FSelectionOptions) and

             (tsUseExplorerTheme in FStates) ) ) then

      begin

        TextColorBackup := GetTextColor(Handle);

        SetTextColor(Handle, $FFFFFF);

        BackColorBackup := GetBkColor(Handle);

        SetBkColor(Handle, 0);



        if not (toExtendedFocus in FOptions.FSelectionOptions) and (toFullRowSelect in FOptions.FSelectionOptions) and

          (tsUseExplorerTheme in FStates) then

          FocusRect := RowRect

        else

          if toGridExtensions in FOptions.FMiscOptions then

            FocusRect := CellRect

          else

            FocusRect := InnerRect;



        if tsUseExplorerTheme in FStates then

          InflateRect(FocusRect, -1, -1);



        if (tsUseExplorerTheme in FStates) and IsWinVistaOrAbove then

        begin

          //Draw focused unselected style like Windows 7 Explorer

          if not (vsSelected in Node.States) then

            DrawThemedFocusRect(LIS_NORMAL)

          else

            DrawBackground(TREIS_HOTSELECTED);

        end

        else

          Windows.DrawFocusRect(Handle, FocusRect);

        SetTextColor(Handle, TextColorBackup);

        SetBkColor(Handle, BackColorBackup);

      end;

    end;

  end;



  if tsUseExplorerTheme in FStates then

    CloseThemeData(Theme);

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.ReadChunk(Stream: TStream; Version: Integer; Node: PVirtualNode; ChunkType,

  ChunkSize: Integer): Boolean;



// Called while loading a tree structure, Node is already valid (allocated) at this point.

// The function handles the base and user chunks, any other chunk is marked as being unknown (result becomes False)

// and skipped. descendants may handle them by overriding this method.

// Returns True if the chunk could be handled, otherwise False.



var

  ChunkBody: TBaseChunkBody;

  Run: PVirtualNode;

  LastPosition: Integer;



begin

  case ChunkType of

    BaseChunk:

      begin

        // Load base chunk's body (chunk header has already been consumed).

        if Version > 1 then

          Stream.Read(ChunkBody, SizeOf(ChunkBody))

        else

        begin

          with ChunkBody do

          begin

            // In version prior to 2 there was a smaller chunk body. Hence we have to read it entry by entry now.

            Stream.Read(ChildCount, SizeOf(ChildCount));

            Stream.Read(NodeHeight, SizeOf(NodeHeight));

            // TVirtualNodeStates was a byte sized type in version 1.

            States := [];

            Stream.Read(States, SizeOf(Byte));

            // vsVisible is now in the place where vsSelected was before, but every node was visible in the old version

            // so we need to fix this too.

            if vsVisible in States then

              Include(States, vsSelected)

            else

              Include(States, vsVisible);

            Stream.Read(Align, SizeOf(Align));

            Stream.Read(CheckState, SizeOf(CheckState));

            Stream.Read(CheckType, SizeOf(CheckType));

          end;

        end;



        with Node^ do

        begin

          // Set states first, in case the node is invisible.

          States := ChunkBody.States;

          NodeHeight := ChunkBody.NodeHeight;

          TotalHeight := NodeHeight;

          Align := ChunkBody.Align;

          CheckState := ChunkBody.CheckState;

          CheckType := ChunkBody.CheckType;

          ChildCount := ChunkBody.ChildCount;



          // Create and read child nodes.

          while ChunkBody.ChildCount > 0 do

          begin

            Run := MakeNewNode;



            Run.PrevSibling := Node.LastChild;

            if Assigned(Run.PrevSibling) then

              Run.Index := Run.PrevSibling.Index + 1;

            if Assigned(Node.LastChild) then

              Node.LastChild.NextSibling := Run

            else

              Node.FirstChild := Run;

            Node.LastChild := Run;

            Run.Parent := Node;



            ReadNode(Stream, Version, Run);

            Dec(ChunkBody.ChildCount);

          end;

        end;

        Result := True;

      end;

    UserChunk:

      if ChunkSize > 0 then

      begin

        // need to know whether the data was read

        LastPosition := Stream.Position;

        DoLoadUserData(Node, Stream);

        // compare stream position to learn whether the data was read

        Result := Stream.Position > LastPosition;

        // Improve stability by advancing the stream to the chunk's real end if

        // the application did not read what has been written.

        if not Result or (Stream.Position <> (LastPosition + ChunkSize)) then

          Stream.Position := LastPosition + ChunkSize;

      end

      else

        Result := True;

  else

    // unknown chunk, skip it

    Stream.Position := Stream.Position + ChunkSize;

    Result := False;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.ReadNode(Stream: TStream; Version: Integer; Node: PVirtualNode);



// Reads the anchor chunk of each node and initiates reading the sub chunks for this node



var

  Header: TChunkHeader;

  EndPosition: Integer;



begin

  with Stream do

  begin

    // Read anchor chunk of the node.

    Stream.Read(Header, SizeOf(Header));

    if Header.ChunkType = NodeChunk then

    begin

      EndPosition := Stream.Position + Header.ChunkSize;

      // Read all subchunks until the indicated chunk end position is reached in the stream.

      while Position < EndPosition do

      begin

        // Read new chunk header.

        Stream.Read(Header, SizeOf(Header));

        ReadChunk(Stream, Version, Node, Header.ChunkType, Header.ChunkSize);

      end;

      // If the last chunk does not end at the given end position then there is something wrong.

      if Position <> EndPosition then

        ShowError(SCorruptStream2, hcTFCorruptStream2);

    end

    else

      ShowError(SCorruptStream1, hcTFCorruptStream1);

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.RedirectFontChangeEvent(Canvas: TCanvas);



begin

  if @Canvas.Font.OnChange <> @FOldFontChange then

  begin

    FOldFontChange := Canvas.Font.OnChange;

    Canvas.Font.OnChange := FontChanged;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.RemoveFromSelection(Node: PVirtualNode);



var

  Index: Integer;



begin

  if not FSelectionLocked then

  begin

    Assert(Assigned(Node), 'Node must not be nil!');

    if vsSelected in Node.States then

    begin

      Exclude(Node.States, vsSelected);

      if FindNodeInSelection(Node, Index, -1, -1) and (Index < FSelectionCount - 1) then

        Move(FSelection[Index + 1], FSelection[Index], (FSelectionCount - Index - 1) * SizeOf(Pointer));

      if FSelectionCount > 0 then

        Dec(FSelectionCount);

      SetLength(FSelection, FSelectionCount);



      if FSelectionCount = 0 then

        ResetRangeAnchor;



      if FSelectionCount <= 1 then

        UpdateNextNodeToSelect(Node);



      DoRemoveFromSelection(Node);

      Change(Node);

    end;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.UpdateNextNodeToSelect(Node: PVirtualNode);



// save a potential node to select after the currently selected node will be deleted.

// This will make the VT to behave more like the Win32 TreeView, which always selecta a new node if the currently

// selected one gets deleted.



begin

  if not (toAlwaysSelectNode in TreeOptions.SelectionOptions) then

    Exit;

  if GetNextSibling(Node) <> nil then

    FNextNodeToSelect := GetNextSibling(Node)

  else if GetPreviousSibling(Node) <> nil then

    FNextNodeToSelect := GetPreviousSibling(Node)

  else if GetNodeLevel(Node) > 0 then

    FNextNodeToSelect := Node.Parent

  else

    FNextNodeToSelect := GetFirstChild(Node);

end;//if Assigned(Node);



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.RenderOLEData(const FormatEtcIn: TFormatEtc; out Medium: TStgMedium;

  ForClipboard: Boolean): HResult;



// Returns a memory expression of all currently selected nodes in the Medium structure.

// Note: The memory requirement of this method might be very high. This depends however on the requested storage format.

//       For HGlobal (a global memory block) we need to render first all nodes to local memory and copy this then to

//       the global memory in Medium. This is necessary because we have first to determine how much

//       memory is needed before we can allocate it. Hence for a short moment we need twice the space as used by the

//       nodes alone (plus the amount the nodes need in the tree anyway)!

//       With IStream this does not happen. We directly stream out the nodes and pass the constructed stream along.



  //--------------- local function --------------------------------------------



  procedure WriteNodes(Stream: TStream);



  var

    Selection: TNodeArray;

    I: Integer;



  begin

    if ForClipboard then

      Selection := GetSortedCutCopySet(True)

    else

      Selection := GetSortedSelection(True);

    for I := 0 to High(Selection) do

      WriteNode(Stream, Selection[I]);

  end;



  //--------------- end local function ----------------------------------------



var

  Data: PCardinal;

  ResPointer: Pointer;

  ResSize: Integer;

  OLEStream: IStream;

  VCLStream: TStream;



begin

  ZeroMemory (@Medium, SizeOf(Medium));



  // We can render the native clipboard format in two different storage media.

  if (FormatEtcIn.cfFormat = CF_VIRTUALTREE) and (FormatEtcIn.tymed and (TYMED_HGLOBAL or TYMED_ISTREAM) <> 0) then

  begin

    VCLStream := nil;

    try

      Medium.unkForRelease := nil;

      // Return data in one of the supported storage formats, prefer IStream.

      if FormatEtcIn.tymed and TYMED_ISTREAM <> 0 then

      begin

        // Create an IStream on a memory handle (here it is 0 which indicates to implicitely allocated a handle).

        // Do not use TStreamAdapter as it is not compatible with OLE (when flushing the clipboard OLE wants the HGlobal

        // back which is not supported by TStreamAdapater).

        CreateStreamOnHGlobal(0, True, OLEStream);

        VCLStream := TOLEStream.Create(OLEStream);

        WriteNodes(VCLStream);

        // Rewind stream.

        VCLStream.Position := 0;

        Medium.tymed := TYMED_ISTREAM;

        IUnknown(Medium.stm) := OLEStream;

        Result := S_OK;

      end

      else

      begin

        VCLStream := TMemoryStream.Create;

        WriteNodes(VCLStream);

        ResPointer := TMemoryStream(VCLStream).Memory;

        ResSize := VCLStream.Position;



        // Allocate memory to hold the string.

        if ResSize > 0 then

        begin

          Medium.hGlobal := GlobalAlloc(GHND or GMEM_SHARE, ResSize + SizeOf(Cardinal));

          Data := GlobalLock(Medium.hGlobal);

          // Store the size of the data too, for easy retrival.

          Data^ := ResSize;

          Inc(Data);

          Move(ResPointer^, Data^, ResSize);

          GlobalUnlock(Medium.hGlobal);

          Medium.tymed := TYMED_HGLOBAL;



          Result := S_OK;

        end

        else

          Result := E_FAIL;

      end;

    finally

      // We can free the VCL stream here since it was either a pure memory stream or only a wrapper around

      // the OLEStream which exists independently.

      VCLStream.Free;

    end;

  end

  else // Ask application descendants to render self defined formats.

    Result := DoRenderOLEData(FormatEtcIn, Medium, ForClipboard);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.ResetRangeAnchor;



// Called when there is no selected node anymore and the selection range anchor needs a new value.



begin

  FRangeAnchor := FFocusedNode;

  FLastSelectionLevel := -1;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.RestoreFontChangeEvent(Canvas: TCanvas);



begin

  Canvas.Font.OnChange := FOldFontChange;

  FOldFontChange := nil;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.SelectNodes(StartNode, EndNode: PVirtualNode; AddOnly: Boolean);



// Selects a range of nodes and unselects all other eventually selected nodes which are not in this range if

// AddOnly is False.

// EndNode must be visible while StartNode does not necessarily as in the case where the last focused node is the start

// node but it is a child of a node which has been collapsed previously. In this case the first visible parent node

// is used as start node. StartNode can be nil in which case the very first node in the tree is used.



var

  NodeFrom,

  NodeTo,

  LastAnchor: PVirtualNode;

  Index: Integer;



begin

  Assert(Assigned(EndNode), 'EndNode must not be nil!');

  if not FSelectionLocked then

  begin

    ClearTempCache;

    if StartNode = nil then

      StartNode := GetFirstVisibleNoInit(nil, True)

    else

      if not FullyVisible[StartNode] then

      begin

        StartNode := GetPreviousVisible(StartNode, True);

        if StartNode = nil then

          StartNode := GetFirstVisibleNoInit(nil, True);

      end;



    if CompareNodePositions(StartNode, EndNode, True) < 0 then

    begin

      NodeFrom := StartNode;

      NodeTo := EndNode;

    end

    else

    begin

      NodeFrom := EndNode;

      NodeTo := StartNode;

    end;



    // The range anchor will be reset by the following call.

    LastAnchor := FRangeAnchor;

    if not AddOnly then

      InternalClearSelection;



    while NodeFrom <> NodeTo do

    begin

      InternalCacheNode(NodeFrom);

      NodeFrom := GetNextVisible(NodeFrom, True);

    end;

    // select last node too

    InternalCacheNode(NodeFrom);

    // now add them all in "one" step

    AddToSelection(FTempNodeCache, FTempNodeCount);

    ClearTempCache;

    if Assigned(LastAnchor) and FindNodeInSelection(LastAnchor, Index, -1, -1) then

     FRangeAnchor := LastAnchor;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.SetFocusedNodeAndColumn(Node: PVirtualNode; Column: TColumnIndex);



var

  OldColumn: TColumnIndex;

  WasDifferent: Boolean;



begin

  if not FHeader.AllowFocus(Column) then

    Column := FFocusedColumn;



  WasDifferent := (Node <> FFocusedNode) or (Column <> FFocusedColumn);



  OldColumn := FFocusedColumn;

  FFocusedColumn := Column;



  DoFocusNode(Node, True);



  // Check if the change was accepted.

  if FFocusedNode = Node then

  begin

    CancelEditNode;

    if WasDifferent then

      DoFocusChange(FFocusedNode, FFocusedColumn);

  end

  else

    // If the user did not accept the new cell to focus then set also the focused column back

    // to its original state.

    FFocusedColumn := OldColumn;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.SkipNode(Stream: TStream);



// Skips the data for the next node in the given stream (including the child nodes).



var

  Header: TChunkHeader;



begin

  with Stream do

  begin

    // read achor chunk of the node

    Stream.Read(Header, SizeOf(Header));

    if Header.ChunkType = NodeChunk then

      Stream.Position := Stream.Position + Header.ChunkSize

    else

      ShowError(SCorruptStream1, hcTFCorruptStream1);

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



var

  PanningWindowClass: TWndClass = (

    style: 0;

    lpfnWndProc: @DefWindowProc;

    cbClsExtra: 0;

    cbWndExtra: 0;

    hInstance: 0;

    hIcon: 0;

    hCursor: 0;

    hbrBackground: 0;

    lpszMenuName: nil;

    lpszClassName: 'VTPanningWindow'

  );



procedure TBaseVirtualTree.StartWheelPanning(Position: TPoint);



// Called when wheel panning should start. A little helper window is created to indicate the reference position,

// which determines in which direction and how far wheel panning/scrolling will happen.



  //--------------- local function --------------------------------------------



  function CreateClipRegion: HRGN;



  // In order to avoid doing all the transparent drawing ourselves we use a

  // window region for the wheel window.

  // Since we only work on a very small image (32x32 pixels) this is acceptable.



  var

    Start, X, Y: Integer;

    Temp: HRGN;



  begin

    Assert(not FPanningImage.Empty, 'Invalid wheel panning image.');



    // Create an initial region on which we operate.

    Result := CreateRectRgn(0, 0, 0, 0);

    with FPanningImage, Canvas do

    begin

      for Y := 0 to Height - 1 do

      begin

        Start := -1;

        for X := 0 to Width - 1 do

        begin

          // Start a new span if we found a non-transparent pixel and no span is currently started.

          if (Start = -1) and (Pixels[X, Y] <> clFuchsia) then

            Start := X

          else

            if (Start > -1) and (Pixels[X, Y] = clFuchsia) then

            begin

              // A non-transparent span is finished. Add it to the result region.

              Temp := CreateRectRgn(Start, Y, X, Y + 1);

              CombineRgn(Result, Result, Temp, RGN_OR);

              DeleteObject(Temp);

              Start := -1;

            end;

        end;

        // If there is an open span then add this also to the result region.

        if Start > -1 then

        begin

          Temp := CreateRectRgn(Start, Y, Width, Y + 1);

          CombineRgn(Result, Result, Temp, RGN_OR);

          DeleteObject(Temp);

        end;

      end;

    end;

    // The resulting region is used as window region so we must not delete it.

    // Windows will own it after the assignment below.

  end;



  //--------------- end local function ----------------------------------------



var

  TempClass: TWndClass;

  ClassRegistered: Boolean;

  ImageName: string;

  Pt: TPoint;



begin

  // Set both panning and scrolling flag. One will be removed shortly depending on whether the middle mouse button is

  // released before the mouse is moved or vice versa. The first case is referred to as wheel scrolling while the

  // latter is called wheel panning.

  StopTimer(ScrollTimer);

  DoStateChange([tsWheelPanning, tsWheelScrolling]);



  // Register the helper window class.

  PanningWindowClass.hInstance := HInstance;

  ClassRegistered := GetClassInfo(HInstance, PanningWindowClass.lpszClassName, TempClass);

  if not ClassRegistered or (TempClass.lpfnWndProc <> @DefWindowProc) then

  begin

    if ClassRegistered then

      Windows.UnregisterClass(PanningWindowClass.lpszClassName, HInstance);

    Windows.RegisterClass(PanningWindowClass);

  end;

  // Create the helper window and show it at the given position without activating it.

  Pt := ClientToScreen(Position);

  FPanningWindow := CreateWindowEx(WS_EX_TOOLWINDOW, PanningWindowClass.lpszClassName, nil, WS_POPUP, Pt.X - 16, Pt.Y - 16,

    32, 32, Handle, 0, HInstance, nil);



  FPanningImage := TBitmap.Create;

  if Integer(FRangeX) > ClientWidth then

  begin

    if Integer(FRangeY) > ClientHeight then

      ImageName := 'VT_MOVEALL'

    else

      ImageName := 'VT_MOVEEW';

  end

  else

    ImageName := 'VT_MOVENS';

  FPanningImage.LoadFromResourceName(HInstance, ImageName);

  SetWindowRgn(FPanningWindow, CreateClipRegion, False);



  {$ifdef CPUX64}

  SetWindowLongPtr(FPanningWindow, GWLP_WNDPROC, LONG_PTR(Classes.MakeObjectInstance(PanningWindowProc)));

  {$else}

  SetWindowLong(FPanningWindow, GWL_WNDPROC, Longint(Classes.MakeObjectInstance(PanningWindowProc)));

  {$endif CPUX64}

  ShowWindow(FPanningWindow, SW_SHOWNOACTIVATE);



  // Setup the panscroll timer and capture all mouse input.

  SetFocus;

  SetCapture(Handle);

  SetTimer(Handle, ScrollTimer, 20, nil);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.StopWheelPanning;



// Stops panning if currently active and destroys the helper window.



var

  Instance: Pointer;



begin

  if [tsWheelPanning, tsWheelScrolling] * FStates <> [] then

  begin

    // Release the mouse capture and stop the panscroll timer.

    StopTimer(ScrollTimer);

    ReleaseCapture;

    DoStateChange([], [tsWheelPanning, tsWheelScrolling]);



    // Destroy the helper window.

    {$ifdef CPUX64}

    Instance := Pointer(GetWindowLongPtr(FPanningWindow, GWLP_WNDPROC));

    {$else}

    Instance := Pointer(GetWindowLong(FPanningWindow, GWL_WNDPROC));

    {$endif CPUX64}

    DestroyWindow(FPanningWindow);

    if Instance <> @DefWindowProc then

      Classes.FreeObjectInstance(Instance);

    FPanningWindow := 0;

    FPanningImage.Free;

    FPanningImage := nil;

    DeleteObject(FPanningCursor);

    FPanningCursor := 0;

    Windows.SetCursor(Screen.Cursors[Cursor]);

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.StructureChange(Node: PVirtualNode; Reason: TChangeReason);



begin

  AdviseChangeEvent(True, Node, Reason);



  if FUpdateCount = 0 then

  begin

    if (FChangeDelay > 0) and not (tsSynchMode in FStates) then

      SetTimer(Handle, StructureChangeTimer, FChangeDelay, nil)

    else

      DoStructureChange(Node, Reason);

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.SuggestDropEffect(Source: TObject; Shift: TShiftState; Pt: TPoint;

  AllowedEffects: Integer): Integer;



// determines the drop action to take if the drag'n drop operation ends on this tree

// Note: Source can be any Delphi object not just a virtual tree



begin

  Result := AllowedEffects;



  // prefer MOVE if source and target are the same control, otherwise whatever is allowed as initial value

  if Assigned(Source) and (Source = Self) then

    if (AllowedEffects and DROPEFFECT_MOVE) <> 0 then

      Result := DROPEFFECT_MOVE

    else // no change

  else

    // drag between different applicatons

    if (AllowedEffects and DROPEFFECT_COPY) <> 0 then

      Result := DROPEFFECT_COPY;



  // consider modifier keys and what is allowed at the moment, if none of the following conditions apply then

  // the initial value just set is used

  if ssCtrl in Shift then

  begin

    // copy or link

    if ssShift in Shift then

    begin

      // link

      if (AllowedEffects and DROPEFFECT_LINK) <> 0 then

        Result := DROPEFFECT_LINK;

    end

    else

    begin

      // copy

      if (AllowedEffects and DROPEFFECT_COPY) <> 0 then

        Result := DROPEFFECT_COPY;

    end;

  end

  else

  begin

    // move, link or default

    if ssShift in Shift then

    begin

      // move

      if (AllowedEffects and DROPEFFECT_MOVE) <> 0 then

        Result := DROPEFFECT_MOVE;

    end

    else

    begin

      // link or default

      if ssAlt in Shift then

      begin

        // link

        if (AllowedEffects and DROPEFFECT_LINK) <> 0 then

          Result := DROPEFFECT_LINK;

      end;

      // else default

    end;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.ToggleSelection(StartNode, EndNode: PVirtualNode);



// Switchs the selection state of a range of nodes.

// Note: This method is specifically designed to help selecting ranges with the keyboard and considers therefore

//       the range anchor.



var

  NodeFrom,

  NodeTo: PVirtualNode;

  NewSize: Integer;

  Position: Integer;



begin

  if not FSelectionLocked then

  begin

    Assert(Assigned(EndNode), 'EndNode must not be nil!');

    if StartNode = nil then

      StartNode := FRoot.FirstChild

    else

      if not FullyVisible[StartNode] then

        StartNode := GetPreviousVisible(StartNode, True);



    Position := CompareNodePositions(StartNode, EndNode);

    // nothing to do if start and end node are the same

    if Position <> 0 then

    begin

      if Position < 0 then

      begin

        NodeFrom := StartNode;

        NodeTo := EndNode;

      end

      else

      begin

        NodeFrom := EndNode;

        NodeTo := StartNode;

      end;



      ClearTempCache;



      // 1) toggle the start node if it is before the range anchor

      if CompareNodePositions(NodeFrom, FRangeAnchor) < 0 then

        if not (vsSelected in NodeFrom.States) then

          InternalCacheNode(NodeFrom)

        else

          InternalRemoveFromSelection(NodeFrom);



      // 2) toggle all nodes within the range

      NodeFrom := GetNextVisible(NodeFrom, True);

      while NodeFrom <> NodeTo do

      begin

        if not (vsSelected in NodeFrom.States) then

          InternalCacheNode(NodeFrom)

        else

          InternalRemoveFromSelection(NodeFrom);

        NodeFrom := GetNextVisible(NodeFrom, True);

      end;



      // 3) toggle end node if it is after the range anchor

      if CompareNodePositions(NodeFrom, FRangeAnchor) > 0 then

        if not (vsSelected in NodeFrom.States) then

          InternalCacheNode(NodeFrom)

        else

          InternalRemoveFromSelection(NodeFrom);



      // Do some housekeeping if there was a change.

      NewSize := PackArray(FSelection, FSelectionCount);

      if NewSize > -1 then

      begin

        FSelectionCount := NewSize;

        SetLength(FSelection, FSelectionCount);

      end;

      // If the range went over the anchor then we need to reselect it.

      if not (vsSelected in FRangeAnchor.States) then

        InternalCacheNode(FRangeAnchor);

      if FTempNodeCount > 0 then

        AddToSelection(FTempNodeCache, FTempNodeCount);

      ClearTempCache;

    end;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.UnselectNodes(StartNode, EndNode: PVirtualNode);



// Deselects a range of nodes.

// EndNode must be visible while StartNode must not as in the case where the last focused node is the start node

// but it is a child of a node which has been collapsed previously. In this case the first visible parent node

// is used as start node. StartNode can be nil in which case the very first node in the tree is used.



var

  NodeFrom,

  NodeTo: PVirtualNode;

  NewSize: Integer;



begin

  if not FSelectionLocked then

  begin

    Assert(Assigned(EndNode), 'EndNode must not be nil!');



    if StartNode = nil then

      StartNode := FRoot.FirstChild

    else

      if not FullyVisible[StartNode] then

      begin

        StartNode := GetPreviousVisible(StartNode, True);

        if StartNode = nil then

          StartNode := FRoot.FirstChild;

      end;



    if CompareNodePositions(StartNode, EndNode) < 0 then

    begin

      NodeFrom := StartNode;

      NodeTo := EndNode;

    end

    else

    begin

      NodeFrom := EndNode;

      NodeTo := StartNode;

    end;



    while NodeFrom <> NodeTo do

    begin

      InternalRemoveFromSelection(NodeFrom);

      NodeFrom := GetNextVisible(NodeFrom, True);

    end;

    // Deselect last node too.

    InternalRemoveFromSelection(NodeFrom);



    // Do some housekeeping.

    NewSize := PackArray(FSelection, FSelectionCount);

    if NewSize > -1 then

    begin

      FSelectionCount := NewSize;

      SetLength(FSelection, FSelectionCount);

    end;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.UpdateColumnCheckState(Col: TVirtualTreeColumn);



begin

  Col.CheckState := DetermineNextCheckState(Col.CheckType, Col.CheckState);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.UpdateDesigner;



var

  ParentForm: TCustomForm;



begin

  if (csDesigning in ComponentState) and not (csUpdating in ComponentState) then

  begin

    ParentForm := GetParentForm(Self);

    if Assigned(ParentForm) and Assigned(ParentForm.Designer) then

      ParentForm.Designer.Modified;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.UpdateHeaderRect;



// Calculates the rectangle the header occupies in non-client area.

// These coordinates are in window rectangle.



var

  OffsetX,

  OffsetY: Integer;

  EdgeSize: Integer;

  Size: TSize;



begin

  FHeaderRect := Rect(0, 0, Width, Height);



  // Consider borders...

  Size := GetBorderDimensions;

  InflateRect(FHeaderRect, Size.cx, Size.cy);



  // ... and bevels.

  OffsetX := BorderWidth;

  OffsetY := BorderWidth;

  if BevelKind <> bkNone then

  begin

    EdgeSize := 0;

    if BevelInner <> bvNone then

      Inc(EdgeSize, BevelWidth);

    if BevelOuter <> bvNone then

      Inc(EdgeSize, BevelWidth);

    if beLeft in BevelEdges then

      Inc(OffsetX, EdgeSize);

    if beTop in BevelEdges then

      Inc(OffsetY, EdgeSize);

  end;



  InflateRect(FHeaderRect, -OffsetX, -OffsetY);



  if hoVisible in FHeader.FOptions then

  begin

    if FHeaderRect.Left <= FHeaderRect.Right then

      FHeaderRect.Bottom := FHeaderRect.Top + Integer(FHeader.FHeight)

    else

      FHeaderRect := Rect(0, 0, 0, 0);

  end

  else

    FHeaderRect.Bottom := FHeaderRect.Top;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.UpdateEditBounds;



// Used to update the bounds of the current node editor if editing is currently active.



var

  R: TRect;

  Dummy: Integer;

  CurrentAlignment: TAlignment;

  CurrentBidiMode: TBidiMode;



begin

  if (tsEditing in FStates) and Assigned(FFocusedNode) and

     (FEditColumn < FHeader.Columns.Count) then // prevent EArgumentOutOfRangeException

  begin

    if (GetCurrentThreadId <> MainThreadID) then

    begin

      // UpdateEditBounds() will be called at the end of the thread

      Exit;

    end;

    if vsMultiline in FFocusedNode.States then

      R := GetDisplayRect(FFocusedNode, FEditColumn, True, False)

    else

      R := GetDisplayRect(FFocusedNode, FEditColumn, True, True);

    if (toGridExtensions in FOptions.FMiscOptions) then

    begin

      // Adjust edit bounds depending on alignment and bidi mode.

      if FEditColumn <= NoColumn then

      begin

        CurrentAlignment := Alignment;

        CurrentBidiMode := BiDiMode;

      end

      else

      begin

        CurrentAlignment := FHeader.Columns[FEditColumn].FAlignment;

        CurrentBidiMode := FHeader.Columns[FEditColumn].FBiDiMode;

      end;

      // Consider bidi mode here. In RTL context does left alignment actually mean right alignment and vice versa.

      if CurrentBidiMode <> bdLeftToRight then

        ChangeBiDiModeAlignment(CurrentAlignment);

      if CurrentAlignment = taLeftJustify then

        FHeader.Columns.GetColumnBounds(FEditColumn, Dummy, R.Right)

      else

        FHeader.Columns.GetColumnBounds(FEditColumn, R.Left, Dummy);

    end;

    if toShowHorzGridLines in TreeOptions.PaintOptions then

      Dec(R.Bottom);

    R.Bottom := R.Top + Max(R.Bottom - R.Top, FEditLink.GetBounds.Bottom - FEditLink.GetBounds.Top); // Ensure to never decrease the size of the currently active edit control. Helps to prevent issue #159

    FEditLink.SetBounds(R);

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



const

  ScrollMasks: array[Boolean] of Cardinal = (0, SIF_DISABLENOSCROLL);



const // Region identifiers for GetRandomRgn

  CLIPRGN = 1;

  METARGN = 2;

  APIRGN = 3;

  SYSRGN = 4;



function GetRandomRgn(DC: HDC; Rgn: HRGN; iNum: Integer): Integer; stdcall; external 'GDI32.DLL';



procedure TBaseVirtualTree.UpdateWindowAndDragImage(const Tree: TBaseVirtualTree; TreeRect: TRect; UpdateNCArea,

  ReshowDragImage: Boolean);



// Method to repaint part of the window area which is not covered by the drag image and to initiate a recapture

// of the drag image.

// Note: This method must only be called during a drag operation and the tree passed in is the one managing the current

// drag image (so it is the actual drag source).



var

  DragRegion,          // the region representing the drag image

  UpdateRegion,        // the unclipped region within the tree to be updated

  NCRegion: HRGN;      // the region representing the non-client area of the tree

  DragRect,

  NCRect: TRect;

  RedrawFlags: Cardinal;



  VisibleTreeRegion: HRGN;



  DC: HDC;



begin

  if IntersectRect(TreeRect, TreeRect, ClientRect) then

  begin

    // Retrieve the visible region of the window. This is important to avoid overpainting parts of other windows

    // which overlap this one.

    VisibleTreeRegion := CreateRectRgn(0, 0, 1, 1);

    DC := GetDCEx(Handle, 0, DCX_CACHE or DCX_WINDOW or DCX_CLIPSIBLINGS or DCX_CLIPCHILDREN);

    GetRandomRgn(DC, VisibleTreeRegion, SYSRGN);

    ReleaseDC(Handle, DC);



    // The drag image will figure out itself what part of the rectangle can be recaptured.

    // Recapturing is not done by taking a snapshot of the screen, but by letting the tree draw itself

    // into the back bitmap of the drag image. So the order here is unimportant.

    Tree.FDragImage.RecaptureBackground(Self, TreeRect, VisibleTreeRegion, UpdateNCArea, ReshowDragImage);



    // Calculate the screen area not covered by the drag image and which needs an update.

    DragRect := Tree.FDragImage.GetDragImageRect;

    MapWindowPoints(0, Handle, DragRect, 2);

    DragRegion := CreateRectRgnIndirect(DragRect);



    // Start with non-client area if requested.

    if UpdateNCArea then

    begin

      // Compute the part of the non-client area which must be updated.



      // Determine the outer rectangle of the entire tree window.

      GetWindowRect(Handle, NCRect);

      // Express the tree window rectangle in client coordinates (because RedrawWindow wants them so).

      MapWindowPoints(0, Handle, NCRect, 2);

      NCRegion := CreateRectRgnIndirect(NCRect);

      // Determine client rect in screen coordinates and create another region for it.

      UpdateRegion := CreateRectRgnIndirect(ClientRect);

      // Create a region which only contains the NC part by subtracting out the client area.

      CombineRgn(NCRegion, NCRegion, UpdateRegion, RGN_DIFF);

      // Subtract also out what is hidden by the drag image.

      CombineRgn(NCRegion, NCRegion, DragRegion, RGN_DIFF);

      RedrawWindow(Handle, nil, NCRegion, RDW_FRAME or RDW_NOERASE or RDW_NOCHILDREN or RDW_INVALIDATE or RDW_VALIDATE or

        RDW_UPDATENOW);

      DeleteObject(NCRegion);

      DeleteObject(UpdateRegion);

    end;



    UpdateRegion := CreateRectRgnIndirect(TreeRect);

    RedrawFlags := RDW_INVALIDATE or RDW_VALIDATE or RDW_UPDATENOW or RDW_NOERASE or RDW_NOCHILDREN;

    // Remove the part of the update region which is covered by the drag image.

    CombineRgn(UpdateRegion, UpdateRegion, DragRegion, RGN_DIFF);

    RedrawWindow(Handle, nil, UpdateRegion, RedrawFlags);

    DeleteObject(UpdateRegion);

    DeleteObject(DragRegion);

    DeleteObject(VisibleTreeRegion);

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.ValidateCache;



// Starts cache validation if not already done by adding this instance to the worker thread's waiter list

// (if not already there) and signalling the thread it can start validating.



begin

  // Wait for thread to stop validation if it is currently validating this tree's cache.

  InterruptValidation;



  FStartIndex := 0;

  if (tsValidationNeeded in FStates) and (FVisibleCount > CacheThreshold) then

  begin

    // Tell the thread this tree needs actually something to do.

    WorkerThread.AddTree(Self);

    SetEvent(WorkEvent);

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.ValidateNodeDataSize(var Size: Integer);



begin

  Size := SizeOf(Pointer);

  if Assigned(FOnGetNodeDataSize) then

    FOnGetNodeDataSize(Self, Size);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.VclStyleChanged;

begin

  {$if CompilerVersion >= 23 }

  FSetOrRestoreBevelKindAndBevelWidth := True;

  FVclStyleEnabled := StyleServices.Enabled and not StyleServices.IsSystemStyle;

  if not VclStyleEnabled then

  begin

    if FSavedBevelKind <> BevelKind then

      BevelKind := FSavedBevelKind;

    if FSavedBorderWidth <> BorderWidth then

      BorderWidth := FSavedBorderWidth;

  end

  else

  begin

    if BevelKind <> bkNone then

      BevelKind := bkNone;

    if BorderWidth <> 0 then

      BorderWidth := 0;

  end;

  FSetOrRestoreBevelKindAndBevelWidth := False;

  {$else}

  FVclStyleEnabled := False;

  {$ifend}

end;



//----------------------------------------------------------------------------------------------------------------------



//PROFILE-NO

procedure TBaseVirtualTree.WndProc(var Message: TMessage);



var

  Handled: Boolean;



begin

  Handled := False;



  // Try the header whether it needs to take this message.

  if Assigned(FHeader) and (FHeader.FStates <> []) then

    Handled := FHeader.HandleMessage(Message);

  if not Handled then

  begin

    // For auto drag mode, let tree handle itself, instead of TControl.

    if not (csDesigning in ComponentState) and

       ((Message.Msg = WM_LBUTTONDOWN) or (Message.Msg = WM_LBUTTONDBLCLK)) then

    begin

      if (DragMode = dmAutomatic) and (DragKind = dkDrag) then

      begin

        if IsControlMouseMsg(TWMMouse(Message)) then

          Handled := True;

        if not Handled then

        begin

          ControlState := ControlState + [csLButtonDown];

          Dispatch(Message);  // overrides TControl's BeginDrag

          Handled := True;

        end;

      end;

    end;



    if not Handled and Assigned(FHeader) then

      Handled := FHeader.HandleMessage(Message);



    if not Handled then

    begin

      if (Message.Msg in [WM_NCLBUTTONDOWN, WM_NCRBUTTONDOWN, WM_NCMBUTTONDOWN]) and not Focused and CanFocus then

        SetFocus;

      inherited;

    end;

  end;

end;

//PROFILE-YES



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.WriteChunks(Stream: TStream; Node: PVirtualNode);



// Writes the core chunks for Node into the stream.

// Note: descendants can optionally override this method to add other node specific chunks.

//       Keep in mind that this method is also called for the root node. Using this fact in descendants you can

//       create a kind of "global" chunks not directly bound to a specific node.



var

  Header: TChunkHeader;

  LastPosition,

  ChunkSize: Integer;

  Chunk: TBaseChunk;

  Run: PVirtualNode;



begin

  with Stream do

  begin

    // 1. The base chunk...

    LastPosition := Position;

    Chunk.Header.ChunkType := BaseChunk;

    with Node^, Chunk do

    begin

      Body.ChildCount := ChildCount;

      Body.NodeHeight := NodeHeight;

      // Some states are only temporary so take them out as they make no sense at the new location.

      Body.States := States - [vsChecking, vsCutOrCopy, vsDeleting, vsOnFreeNodeCallRequired, vsHeightMeasured];

      Body.Align := Align;

      Body.CheckState := CheckState;

      Body.CheckType := CheckType;

      Body.Reserved := 0;

    end;

    // write the base chunk

    Write(Chunk, SizeOf(Chunk));



    // 2. ... directly followed by the child node chunks (actually they are child chunks of

    //   the base chunk)

    if vsInitialized in Node.States then

    begin

      Run := Node.FirstChild;

      while Assigned(Run) do

      begin

        WriteNode(Stream, Run);

        Run := Run.NextSibling;

      end;

    end;



    FinishChunkHeader(Stream, LastPosition, Position);



    // 3. write user data

    LastPosition := Position;

    Header.ChunkType := UserChunk;

    Write(Header, SizeOf(Header));

    DoSaveUserData(Node, Stream);

    // check if the application actually wrote data

    ChunkSize := Position - LastPosition - SizeOf(TChunkHeader);

    // seek back to start of chunk if nothing has been written

    if ChunkSize = 0 then

    begin

      Position := LastPosition;

      Size := Size - SizeOf(Header);

    end

    else

      FinishChunkHeader(Stream, LastPosition, Position);

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.WriteNode(Stream: TStream; Node: PVirtualNode);



// Writes the "cover" chunk for Node to Stream and initiates writing child nodes and chunks.



var

  LastPosition: Integer;

  Header: TChunkHeader;



begin

  // Initialize the node first if necessary and wanted.

  if toInitOnSave in FOptions.FMiscOptions then

  begin

    if not (vsInitialized in Node.States) then

      InitNode(Node);

    if (vsHasChildren in Node.States) and (Node.ChildCount = 0) then

      InitChildren(Node);

  end;



  with Stream do

  begin

    LastPosition := Position;

    // Emit the anchor chunk.

    Header.ChunkType := NodeChunk;

    Write(Header, SizeOf(Header));

    // Write other chunks to stream taking their size into this chunk's size.

    WriteChunks(Stream, Node);



    // Update chunk size.

    FinishChunkHeader(Stream, LastPosition, Position);

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.AbsoluteIndex(Node: PVirtualNode): Cardinal;



begin

  Result := 0;

  while Assigned(Node) and (Node <> FRoot) do

  begin

    if not (vsInitialized in Node.States) then

      InitNode(Node);

    if Assigned(Node.PrevSibling) then

    begin

      // if there's a previous sibling then add its total count to the result

      Node := Node.PrevSibling;

      Inc(Result, Node.TotalCount);

    end

    else

    begin

      Node := Node.Parent;

      if Node <> FRoot then

        Inc(Result);

    end;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.AddChild(Parent: PVirtualNode; UserData: Pointer = nil): PVirtualNode;



// Adds a new node to the given parent node. This is simply done by increasing the child count of the

// parent node. If Parent is nil then the new node is added as (last) top level node.

// UserData can be used to set the first SizeOf(Pointer) bytes of the user data area to an initial value which can be used

// in OnInitNode and will also cause to trigger the OnFreeNode event (if <> nil) even if the node is not yet

// "officially" initialized.

// AddChild is a compatibility method and will implicitly validate the parent node. This is however

// against the virtual paradigm and hence I dissuade from its usage.



var

  NodeData: ^Pointer;



begin

  if not (toReadOnly in FOptions.FMiscOptions) then

  begin

    CancelEditNode;



    if Parent = nil then

      Parent := FRoot;

    if not (vsInitialized in Parent.States) then

      InitNode(Parent);



    // Locally stop updates of the tree in order to avoid usage of the new node before it is correctly set up.

    // If the update count was 0 on enter then there will be a correct update at the end of this method.

    Inc(FUpdateCount);

    try

      SetChildCount(Parent, Parent.ChildCount + 1);

      // Update the hidden children flag of the parent. Nodes are added as being visible by default.

      Exclude(Parent.States, vsAllChildrenHidden);

    finally

      Dec(FUpdateCount);

    end;

    Result := Parent.LastChild;



    // Check if there is initial user data and there is also enough user data space allocated.

    if Assigned(UserData) then

      if FNodeDataSize >= SizeOf(Pointer) then

      begin

        NodeData := Pointer(PByte(@Result.Data) + FTotalInternalDataSize);

        NodeData^ := UserData;

        Include(Result.States, vsOnFreeNodeCallRequired);

      end

      else

        ShowError(SCannotSetUserData, hcTFCannotSetUserData);



    InvalidateCache;

    if FUpdateCount = 0 then

    begin

      ValidateCache;

      if tsStructureChangePending in FStates then

      begin

        if Parent = FRoot then

          StructureChange(nil, crChildAdded)

        else

          StructureChange(Parent, crChildAdded);

      end;



      if (toAutoSort in FOptions.FAutoOptions) and (FHeader.FSortColumn > InvalidColumn) then

        Sort(Parent, FHeader.FSortColumn, FHeader.FSortDirection, True);



      InvalidateToBottom(Parent);

      UpdateScrollBars(True);

   end;

  end

  else

    Result := nil;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.AddFromStream(Stream: TStream; TargetNode: PVirtualNode);



// loads nodes from the given stream and adds them to TargetNode

// the current content is not cleared before the load process starts (see also LoadFromStream)



var

  ThisID: TMagicID;

  Version,

  Count: Cardinal;

  Node: PVirtualNode;



begin

  if not (toReadOnly in FOptions.FMiscOptions) then

  begin

    // check first whether this is a stream we can read

    Stream.ReadBuffer(ThisID, SizeOf(TMagicID));

    if (ThisID[0] = MagicID[0]) and

       (ThisID[1] = MagicID[1]) and

       (ThisID[2] = MagicID[2]) and

       (ThisID[5] = MagicID[5]) then

    begin

      Version := Word(ThisID[3]);

      if Version <= VTTreeStreamVersion  then

      begin

        BeginUpdate;

        try

          if Version < 2 then

            Count := MaxInt

          else

            Stream.ReadBuffer(Count, SizeOf(Count));



          while (Stream.Position < Stream.Size) and (Count > 0) do

          begin

            Dec(Count);

            Node := MakeNewNode;

            InternalConnectNode(Node, TargetNode, Self, amAddChildLast);

            InternalAddFromStream(Stream, Version, Node);

          end;

          if TargetNode = FRoot then

            DoNodeCopied(nil)

          else

            DoNodeCopied(TargetNode);

        finally

          EndUpdate;

        end;

      end

      else

        ShowError(SWrongStreamVersion, hcTFWrongStreamVersion);

    end

    else

      ShowError(SWrongStreamVersion, hcTFWrongStreamVersion);

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.AfterConstruction;



begin

  inherited;



  if FRoot = nil then

    InitRootNode;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.Assign(Source: TPersistent);



begin

  if (Source is TBaseVirtualTree) and not (toReadOnly in FOptions.FMiscOptions) then

    with Source as TBaseVirtualTree do

    begin

      Self.Align := Align;

      Self.Anchors := Anchors;

      Self.AutoScrollDelay := AutoScrollDelay;

      Self.AutoScrollInterval := AutoScrollInterval;

      Self.AutoSize := AutoSize;

      Self.Background := Background;

      Self.BevelEdges := BevelEdges;

      Self.BevelInner := BevelInner;

      Self.BevelKind := BevelKind;

      Self.BevelOuter := BevelOuter;

      Self.BevelWidth := BevelWidth;

      Self.BiDiMode := BiDiMode;

      Self.BorderStyle := BorderStyle;

      Self.BorderWidth := BorderWidth;

      Self.ChangeDelay := ChangeDelay;

      Self.CheckImageKind := CheckImageKind;

      Self.Color := Color;

      Self.Colors.Assign(Colors);

      Self.Constraints.Assign(Constraints);

      Self.Ctl3D := Ctl3D;

      Self.DefaultNodeHeight := DefaultNodeHeight;

      Self.DefaultPasteMode := DefaultPasteMode;

      Self.DragCursor := DragCursor;

      Self.DragImageKind := DragImageKind;

      Self.DragKind := DragKind;

      Self.DragMode := DragMode;

      Self.Enabled := Enabled;

      Self.Font := Font;

      Self.Header := Header;

      Self.HintAnimation := HintAnimation;

      Self.HintMode := HintMode;

      Self.HotCursor := HotCursor;

      Self.Images := Images;

      Self.ImeMode := ImeMode;

      Self.ImeName := ImeName;

      Self.Indent := Indent;

      Self.Margin := Margin;

      Self.NodeAlignment := NodeAlignment;

      Self.NodeDataSize := NodeDataSize;

      Self.TreeOptions := TreeOptions;

      Self.ParentBiDiMode := ParentBiDiMode;

      Self.ParentColor := ParentColor;

      Self.ParentCtl3D := ParentCtl3D;

      Self.ParentFont := ParentFont;

      Self.ParentShowHint := ParentShowHint;

      Self.PopupMenu := PopupMenu;

      Self.RootNodeCount := RootNodeCount;

      Self.ScrollBarOptions := ScrollBarOptions;

      Self.ShowHint := ShowHint;

      Self.StateImages := StateImages;

      {$if CompilerVersion >= 24}

      Self.StyleElements := StyleElements;

      {$ifend}

      Self.TabOrder := TabOrder;

      Self.TabStop := TabStop;

      Self.Visible := Visible;

      Self.SelectionCurveRadius := SelectionCurveRadius;

      Self.SelectionBlendFactor := SelectionBlendFactor;

      Self.EmptyListMessage := EmptyListMessage;

    end

    else

      inherited;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.AutoScale();



// If toAutoChangeScale is set, this method ensures that the defaulz node height is set corectly.



var

  lTextHeight: Cardinal;

begin

  if (toAutoChangeScale in TreeOptions.AutoOptions) then

  begin

    Canvas.Font.Assign(Self.Font);

    lTextHeight := Canvas.TextHeight('Tg');

    if (lTextHeight > Self.DefaultNodeHeight) then

      Self.DefaultNodeHeight := lTextHeight;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.BeginDrag(Immediate: Boolean; Threshold: Integer);



// Reintroduced method to allow to start OLE drag'n drop as well as VCL drag'n drop.



begin

  if FDragType = dtVCL then

  begin

    DoStateChange([tsVCLDragPending]);

    inherited;

  end

  else

    if (FStates * [tsOLEDragPending, tsOLEDragging]) = [] then

    begin

      // Drag start position has already been recorded in WMMouseDown.

      if Threshold < 0 then

        FDragThreshold := Mouse.DragThreshold

      else

        FDragThreshold := Threshold;

      if Immediate then

        DoDragging(FLastClickPos)

      else

        DoStateChange([tsOLEDragPending]);

    end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.BeginSynch;



// Starts the synchronous update mode (if not already active).



begin

  if not (csDestroying in ComponentState) then

  begin

    if FSynchUpdateCount = 0 then

    begin

      DoUpdating(usBeginSynch);



      // Stop all timers...

      StopTimer(ChangeTimer);

      StopTimer(StructureChangeTimer);

      StopTimer(ExpandTimer);

      StopTimer(EditTimer);

      StopTimer(HeaderTimer);

      StopTimer(ScrollTimer);

      StopTimer(SearchTimer);

      FSearchBuffer := '';

      FLastSearchNode := nil;

      DoStateChange([], [tsEditPending, tsScrollPending, tsScrolling, tsIncrementalSearching]);



      // ...and trigger pending update states.

      if tsStructureChangePending in FStates then

        DoStructureChange(FLastStructureChangeNode, FLastStructureChangeReason);

      if tsChangePending in FStates then

        DoChange(FLastChangedNode);

    end

    else

      DoUpdating(usSynch);

  end;

  Inc(FSynchUpdateCount);

  DoStateChange([tsSynchMode]);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.BeginUpdate;



begin

  if not (csDestroying in ComponentState) then

  begin

    if FUpdateCount = 0 then

    begin

      DoUpdating(usBegin);

      SetUpdateState(True);

    end

    else

      DoUpdating(usUpdate);

  end;

  Inc(FUpdateCount);

  DoStateChange([tsUpdating]);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.CancelCutOrCopy;



// Resets nodes which are marked as being cut.



var

  Run: PVirtualNode;



begin

  if ([tsCutPending, tsCopyPending] * FStates) <> [] then

  begin

    Run := FRoot.FirstChild;

    while Assigned(Run) do

    begin

      if vsCutOrCopy in Run.States then

        Exclude(Run.States, vsCutOrCopy);

      Run := GetNextNoInit(Run);

    end;

  end;

  DoStateChange([], [tsCutPending, tsCopyPending]);

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.CancelEditNode: Boolean;



// Called by the application or the current edit link to cancel the edit action.



begin

  if HandleAllocated and ([tsEditing, tsEditPending] * FStates <> []) then

    Result := DoCancelEdit

  else

    Result := True;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.CancelOperation;



// Called by the application to cancel a long-running operation.



begin

  if FOperationCount > 0 then

    FOperationCanceled := True;

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.CanEdit(Node: PVirtualNode; Column: TColumnIndex): Boolean;



// Returns True if the given node can be edited.



begin

  Result := (toEditable in FOptions.FMiscOptions) and Enabled and not (toReadOnly in FOptions.FMiscOptions)

    and ((Column < 0) or (coEditable in FHeader.Columns[Column].Options));

  DoCanEdit(Node, Column, Result);

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.CanFocus: Boolean;



var

  Form: TCustomForm;



begin

  Result := inherited CanFocus;



  if Result and not (csDesigning in ComponentState) then

  begin

    Form := GetParentForm(Self);

    Result := (Form = nil) or (Form.Enabled and Form.Visible);

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.Clear;



begin

  if not (toReadOnly in FOptions.FMiscOptions) or (csDestroying in ComponentState) then

  begin

    BeginUpdate;

    try

      InterruptValidation;

      if IsEditing then

        CancelEditNode;



      if ClipboardStates * FStates <> [] then

      begin

        OleSetClipboard(nil);

        DoStateChange([], ClipboardStates);

      end;

      ClearSelection;

      FFocusedNode := nil;

      FLastSelected := nil;

      FCurrentHotNode := nil;

      FDropTargetNode := nil;

      FLastChangedNode := nil;

      FRangeAnchor := nil;

      FCheckNode := nil;

      FLastVCLDragTarget := nil;

      FLastSearchNode := nil;

      DeleteChildren(FRoot, True);

      FOffsetX := 0;

      FOffsetY := 0;



    finally

      EndUpdate;

    end;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.ClearChecked;



var

  Node: PVirtualNode;



begin

  Node := RootNode.FirstChild;

  while Assigned(Node) do

  begin

    if Node.CheckState <> csUncheckedNormal then

      CheckState[Node] := csUncheckedNormal;

    Node := GetNextNoInit(Node);

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.ClearSelection;



var

  Node: PVirtualNode;

  Dummy: Integer;

  R: TRect;

  Counter: Integer;



begin

  if not FSelectionLocked and (FSelectionCount > 0) and not (csDestroying in ComponentState) then

  begin

    if (FUpdateCount = 0) and HandleAllocated and (FVisibleCount > 0) then

    begin

      // Iterate through nodes currently visible in the client area and invalidate them.

      Node := GetNodeAt(0, 0, True, Dummy);

      if Assigned(Node) then

        R := GetDisplayRect(Node, NoColumn, False);

      Counter := FSelectionCount;



      while Assigned(Node) do

      begin

        R.Bottom := R.Top + Integer(NodeHeight[Node]);

        if vsSelected in Node.States then

        begin

          InvalidateRect(Handle, @R, False);

          Dec(Counter);

          // Only try as many nodes as are selected.

          if Counter = 0 then

            Break;

        end;

        R.Top := R.Bottom;

        if R.Top > ClientHeight then

          Break;

        Node := GetNextVisibleNoInit(Node, True);

      end;

    end;



    InternalClearSelection;

    Change(nil);

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.CopyTo(Source: PVirtualNode; Tree: TBaseVirtualTree; Mode: TVTNodeAttachMode;

  ChildrenOnly: Boolean): PVirtualNode;



// A simplified CopyTo method to allow to copy nodes to the root of another tree.



begin

  Result := CopyTo(Source, Tree.FRoot, Mode, ChildrenOnly);

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.CopyTo(Source, Target: PVirtualNode; Mode: TVTNodeAttachMode;

  ChildrenOnly: Boolean): PVirtualNode;



// Copies Source and all its child nodes to Target.

// Mode is used to specify further where to add the new node actually (as sibling of Target or as child of Target).

// Result is the newly created node to which source has been copied if ChildrenOnly is False or just contains Target

// in the other case.

// ChildrenOnly determines whether to copy also the source node or only its child nodes.



var

  TargetTree: TBaseVirtualTree;

  Stream: TMemoryStream;



begin

  Assert(TreeFromNode(Source) = Self, 'The source tree must contain the source node.');



  Result := nil;

  if (Mode <> amNoWhere) and Assigned(Source) and (Source <> FRoot) then

  begin

    // Assume that an empty destination means the root in this (the source) tree.

    if Target = nil then

    begin

      TargetTree := Self;

      Target := FRoot;

      Mode := amAddChildFirst;

    end

    else

      TargetTree := TreeFromNode(Target);



    if not (toReadOnly in TargetTree.FOptions.FMiscOptions) then

    begin

      if Target = TargetTree.FRoot then

      begin

        case Mode of

          amInsertBefore:

            Mode := amAddChildFirst;

          amInsertAfter:

            Mode := amAddChildLast;

        end;

      end;



      Stream := TMemoryStream.Create;

      try

        // Write all nodes into a temprary stream depending on the ChildrenOnly flag.

        if not ChildrenOnly then

          WriteNode(Stream, Source)

        else

        begin

          Source := Source.FirstChild;

          while Assigned(Source) do

          begin

            WriteNode(Stream, Source);

            Source := Source.NextSibling;

          end;

        end;

        // Now load the serialized nodes into the target node (tree).

        TargetTree.BeginUpdate;

        try

          Stream.Position := 0;

          while Stream.Position < Stream.Size do

          begin

            Result := TargetTree.MakeNewNode;

            InternalConnectNode(Result, Target, TargetTree, Mode);

            TargetTree.InternalAddFromStream(Stream, VTTreeStreamVersion, Result);

            if not DoNodeCopying(Result, Target) then

            begin

              TargetTree.DeleteNode(Result);

              Result := nil;

            end

            else

              DoNodeCopied(Result);

          end;

          if ChildrenOnly then

            Result := Target;

        finally

          TargetTree.EndUpdate;

        end;

      finally

        Stream.Free;

      end;



      with TargetTree do

      begin

        InvalidateCache;

        if FUpdateCount = 0 then

        begin

          ValidateCache;

          UpdateScrollBars(True);

          Invalidate;

        end;

        StructureChange(Source, crNodeCopied);

      end;

    end;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.CopyToClipboard;



var

  DataObject: IDataObject;



begin

  if FSelectionCount > 0 then

  begin

    DataObject := TVTDataObject.Create(Self, True) as IDataObject;

    if OleSetClipboard(DataObject) = S_OK then

    begin

      MarkCutCopyNodes;

      DoStateChange([tsCopyPending]);

      Invalidate;

    end;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.CutToClipboard;

begin

  if (FSelectionCount > 0) and not (toReadOnly in FOptions.FMiscOptions) then

  begin

    if OleSetClipboard(TVTDataObject.Create(Self, True)) = S_OK then

    begin

      MarkCutCopyNodes;

      DoStateChange([tsCutPending], [tsCopyPending]);

      Invalidate;

    end;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.DeleteChildren(Node: PVirtualNode; ResetHasChildren: Boolean = False);



// Removes all children and their children from memory without changing the vsHasChildren style by default.



var

  Run,

  Mark: PVirtualNode;

  LastTop,

  LastLeft,

  NewSize: Integer;

  ParentVisible: Boolean;



begin

  if Assigned(Node) and (Node.ChildCount > 0) and not (toReadOnly in FOptions.FMiscOptions) then

  begin

    Assert(not (tsIterating in FStates), 'Deleting nodes during tree iteration leads to invalid pointers.');



    // The code below uses some flags for speed improvements which may cause invalid pointers if updates of

    // the tree happen. Hence switch updates off until we have finished the operation.

    Inc(FUpdateCount);

    try

      InterruptValidation;

      LastLeft := -FEffectiveOffsetX;

      LastTop := FOffsetY;



      // Make a local copy of the visibility state of this node to speed up

      // adjusting the visible nodes count.

      ParentVisible := Node = FRoot;

      if not ParentVisible then

        ParentVisible := FullyVisible[Node] and (vsExpanded in Node.States);



      // Show that we are clearing the child list, to avoid registering structure change events.

      Include(Node.States, vsClearing);

      Run := Node.LastChild;

      while Assigned(Run) do

      begin

        if ParentVisible and IsEffectivelyVisible[Run] then

          Dec(FVisibleCount);



        Include(Run.States, vsDeleting);

        Mark := Run;

        Run := Run.PrevSibling;

        // Important, to avoid exchange of invalid pointers while disconnecting the node.

        if Assigned(Run) then

          Run.NextSibling := nil;

        DeleteNode(Mark);

      end;

      Exclude(Node.States, vsClearing);

      if ResetHasChildren then

        Exclude(Node.States, vsHasChildren);

      if Node <> FRoot then

        Exclude(Node.States, vsExpanded);

      Node.ChildCount := 0;

      if (Node = FRoot) or (vsDeleting in Node.States) then

      begin

        Node.TotalHeight := FDefaultNodeHeight + NodeHeight[Node];

        Node.TotalCount := 1;

      end

      else

      begin

        AdjustTotalHeight(Node, NodeHeight[Node]);

        AdjustTotalCount(Node, 1);

      end;

      Node.FirstChild := nil;

      Node.LastChild := nil;

    finally

      Dec(FUpdateCount);

    end;



    InvalidateCache;

    if FUpdateCount = 0 then

    begin

      NewSize := PackArray(FSelection, FSelectionCount);

      if NewSize > -1 then

      begin

        FSelectionCount := NewSize;

        SetLength(FSelection, FSelectionCount);

      end;



      ValidateCache;

      UpdateScrollBars(True);

      // Invalidate entire tree if it scrolled e.g. to make the last node also the

      // bottom node in the treeview.

      if (LastLeft <> FOffsetX) or (LastTop <> FOffsetY) then

        Invalidate

      else

        InvalidateToBottom(Node);

    end;

    StructureChange(Node, crChildDeleted);

  end

  else if ResetHasChildren then

    Exclude(Node.States, vsHasChildren);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.DeleteNode(Node: PVirtualNode; Reindex: Boolean = True);



var

  LastTop,

  LastLeft: Integer;

  LastParent: PVirtualNode;

  WasInSynchMode: Boolean;

  ParentClearing: Boolean;



begin

  if Assigned(Node) and (Node <> FRoot) and not (toReadOnly in FOptions.FMiscOptions) then

  begin

    Assert(not (tsIterating in FStates), 'Deleting nodes during tree iteration leads to invalid pointers.');



    // Determine parent node for structure change notification.

    ParentClearing := vsClearing in Node.Parent.States;

    LastParent := Node.Parent;



    if not ParentClearing then

    begin

      if LastParent = FRoot then

        StructureChange(nil, crChildDeleted)

      else

        StructureChange(LastParent, crChildDeleted);

    end;



    LastLeft := -FEffectiveOffsetX;

    LastTop := FOffsetY;



    if vsSelected in Node.States then

    begin

      if FUpdateCount = 0 then

      begin

        // Go temporarily into sync mode to avoid a delayed change event for the node

        // when unselecting.

        WasInSynchMode := tsSynchMode in FStates;

        Include(FStates, tsSynchMode);

        RemoveFromSelection(Node);

        if not WasInSynchMode then

          Exclude(FStates, tsSynchMode);

        InvalidateToBottom(LastParent);

      end

      else

        InternalRemoveFromSelection(Node);

    end

    else

      InvalidateToBottom(LastParent);



    if tsHint in FStates then

    begin

      Application.CancelHint;

      DoStateChange([], [tsHint]);

    end;



    if not ParentClearing then

      InterruptValidation;



    DeleteChildren(Node);

    InternalDisconnectNode(Node, False, Reindex);

    DoFreeNode(Node);



    if not ParentClearing then

    begin

      DetermineHiddenChildrenFlag(LastParent);

      InvalidateCache;

      if FUpdateCount = 0 then

      begin

        ValidateCache;

        UpdateScrollBars(True);

        // Invalidate entire tree if it scrolled e.g. to make the last node also the

        // bottom node in the treeview.

        if (LastLeft <> FOffsetX) or (LastTop <> FOffsetY) then

          Invalidate;

      end;

    end;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.DeleteSelectedNodes;



// Deletes all currently selected nodes (including their child nodes).



var

  Nodes: TNodeArray;

  I: Integer;

  LevelChange: Boolean;



begin

  Nodes := nil;

  if (FSelectionCount > 0) and not (toReadOnly in FOptions.FMiscOptions) then

  begin

    BeginUpdate;

    try

      Nodes := GetSortedSelection(True);

      for I := High(Nodes) downto 1 do

      begin

        LevelChange := Nodes[I].Parent <> Nodes[I - 1].Parent;

        DeleteNode(Nodes[I], LevelChange);

      end;

      DeleteNode(Nodes[0]);

    finally

      EndUpdate;

    end;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.Dragging: Boolean;



begin

  // Check for both OLE drag'n drop as well as VCL drag'n drop.

  Result := ([tsOLEDragPending, tsOLEDragging] * FStates <> []) or inherited Dragging;

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.EditNode(Node: PVirtualNode; Column: TColumnIndex): Boolean;



// Application triggered edit event for the given node.

// Returns True if the tree started editing otherwise False.



begin

  Assert(Assigned(Node), 'Node must not be nil.');

  Assert((Column > InvalidColumn) and (Column < FHeader.Columns.Count),

    'Column must be a valid column index (-1 if no header is shown).');



  Result := tsEditing in FStates;

  // If the tree is already editing then we don't disrupt this.

  if not Result and not (toReadOnly in FOptions.FMiscOptions) then

  begin

    FocusedNode := Node;

    if Assigned(FFocusedNode) and (Node = FFocusedNode) and CanEdit(FFocusedNode, Column) then

    begin

      FEditColumn := Column;

      if not (vsInitialized in Node.States) then

        InitNode(Node);

      DoEdit;

      Result := tsEditing in FStates;

    end

    else

      Result := False;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.EndEditNode: Boolean;



// Called to finish a current edit action or stop the edit timer if an edit operation is pending.



begin

  if [tsEditing, tsEditPending] * FStates <> [] then

    Result := DoEndEdit

  else

    Result := True;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.EndSynch;



begin

  if FSynchUpdateCount > 0 then

    Dec(FSynchUpdateCount);



  if not (csDestroying in ComponentState) then

  begin

    if FSynchUpdateCount = 0 then

    begin

      DoStateChange([], [tsSynchMode]);

      DoUpdating(usEndSynch);

    end

    else

      DoUpdating(usSynch);

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.EndUpdate;



var

  NewSize: Integer;



begin

  if FUpdateCount > 0 then

    Dec(FUpdateCount);



  if not (csDestroying in ComponentState) then

  begin

    if (FUpdateCount = 0) and (tsUpdating in FStates) then

    begin

      if tsUpdateHiddenChildrenNeeded in FStates then

      begin

        DetermineHiddenChildrenFlagAllNodes;

        Exclude(FStates, tsUpdateHiddenChildrenNeeded);

      end;



      DoStateChange([], [tsUpdating]);



      NewSize := PackArray(FSelection, FSelectionCount);

      if NewSize > -1 then

      begin

        FSelectionCount := NewSize;

        SetLength(FSelection, FSelectionCount);

      end;



      InvalidateCache;

      ValidateCache;

      if HandleAllocated then

        UpdateScrollBars(False);



      if tsStructureChangePending in FStates then

        DoStructureChange(FLastStructureChangeNode, FLastStructureChangeReason);

      try

        if tsChangePending in FStates then

          DoChange(FLastChangedNode);

      finally

        if toAutoSort in FOptions.FAutoOptions then

          SortTree(FHeader.FSortColumn, FHeader.FSortDirection, True);



        SetUpdateState(False);

        if HandleAllocated then

          Invalidate;

        UpdateDesigner;

      end;

    end;



    if FUpdateCount = 0 then begin

      DoUpdating(usEnd);

      EnsureNodeSelected();

    end

    else

      DoUpdating(usUpdate);

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.ExecuteAction(Action: TBasicAction): Boolean;



// Some support for standard actions.



begin

  Result := inherited ExecuteAction(Action);



  if not Result then

  begin

    Result := Action is TEditSelectAll;

    if Result then

      SelectAll(False)

    else

    begin

      Result := Action is TEditCopy;

      if Result then

        CopyToClipboard

      else

        if not (toReadOnly in FOptions.FMiscOptions) then

        begin

          Result := Action is TEditCut;

          if Result then

            CutToClipboard

          else

          begin

            Result := Action is TEditPaste;

            if Result then

              PasteFromClipboard

              else

              begin

                Result := Action is TEditDelete;

                if Result then

                  DeleteSelectedNodes;

              end;

          end;

      end;

    end;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.FinishCutOrCopy;



// Deletes nodes which are marked as being cutted.



var

  Run: PVirtualNode;



begin

  if tsCutPending in FStates then

  begin

    Run := FRoot.FirstChild;

    while Assigned(Run) do

    begin

      if vsCutOrCopy in Run.States then

        DeleteNode(Run);

      Run := GetNextNoInit(Run);

    end;

    DoStateChange([], [tsCutPending]);

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.FlushClipboard;



// Used to render the data which is currently on the clipboard (finishes delayed rendering).



begin

  if ClipboardStates * FStates <> [] then

  begin

    DoStateChange([tsClipboardFlushing]);

    OleFlushClipboard;

    CancelCutOrCopy;

    DoStateChange([], [tsClipboardFlushing]);

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.FullCollapse(Node: PVirtualNode = nil);



// This routine collapses all expanded nodes in the subtree given by Node or the whole tree if Node is FRoot or nil.

// Only nodes which are expanded will be collapsed. This excludes uninitialized nodes but nodes marked as visible

// will still be collapsed if they are expanded.



var

  Stop: PVirtualNode;



begin

  if FRoot.TotalCount > 1 then

  begin

    if Node = FRoot then

      Node := nil;



    DoStateChange([tsCollapsing]);

    BeginUpdate;

    try

      Stop := Node;

      Node := GetLastVisibleNoInit(Node, True);



      if Assigned(Node) then

      begin

        repeat

          if [vsHasChildren, vsExpanded] * Node.States = [vsHasChildren, vsExpanded] then

            ToggleNode(Node);

          Node := GetPreviousNoInit(Node, True);

        until (Node = Stop) or not Assigned(Node);



        // Collapse the start node too.

        if Assigned(Stop) and ([vsHasChildren, vsExpanded] * Stop.States = [vsHasChildren, vsExpanded]) then

          ToggleNode(Stop);

      end;

    finally

      EndUpdate;

      DoStateChange([], [tsCollapsing]);

    end;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.FullExpand(Node: PVirtualNode = nil);



// This routine expands all collapsed nodes in the subtree given by Node or the whole tree if Node is FRoot or nil.

// All nodes on the way down are initialized so this procedure might take a long time.

// Since all nodes are validated, the tree cannot make use of optimatizations. Hence it is counter productive and you

// should consider avoiding its use.



var

  Stop: PVirtualNode;



begin

  if FRoot.TotalCount > 1 then

  begin

    DoStateChange([tsExpanding]);

    BeginUpdate;

    try

      if Node = nil then

      begin

        Node := FRoot.FirstChild;

        Stop := nil;

      end

      else

      begin

        Stop := Node.NextSibling;

        if Stop = nil then

        begin

          Stop := Node;

          repeat

            Stop := Stop.Parent;

          until (Stop = FRoot) or Assigned(Stop.NextSibling);

          if Stop = FRoot then

            Stop := nil

          else

            Stop := Stop.NextSibling;

        end;

      end;



      // Initialize the start node. Others will be initialized in GetNext.

      if not (vsInitialized in Node.States) then

        InitNode(Node);



      repeat

        if not (vsExpanded in Node.States) then

          ToggleNode(Node);

        Node := GetNext(Node);

      until Node = Stop;

    finally

      EndUpdate;

      DoStateChange([], [tsExpanding]);

    end;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.GetControlsAlignment: TAlignment;



begin

  Result := FAlignment;

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.GetDisplayRect(Node: PVirtualNode; Column: TColumnIndex; TextOnly: Boolean;

  Unclipped: Boolean = False; ApplyCellContentMargin: Boolean = False): TRect;



// Determines the client coordinates the given node covers, depending on scrolling, expand state etc.

// If the given node cannot be found (because one of its parents is collapsed or it is invisible) then an empty

// rectangle is returned.

// If TextOnly is True then only the text bounds are returned, that is, the resulting rectangle's left and right border

// are updated according to bidi mode, alignment and text width of the node.

// If Unclipped is True (which only makes sense if also TextOnly is True) then the calculated text rectangle is

// not clipped if the text does not entirely fit into the text space. This is special handling needed for hints.

// If ApplyCellContentMargin is True (which only makes sense if also TextOnly is True) then the calculated text

// rectangle respects the cell content margin.

// If Column is -1 then the entire client width is used before determining the node's width otherwise the bounds of the

// particular column are used.

// Note: Column must be a valid column and is used independent of whether the header is visible or not.



var

  Temp: PVirtualNode;

  Offset: Cardinal;

  CacheIsAvailable: Boolean;

  Indent,

  TextWidth: Integer;

  MainColumnHit: Boolean;

  CurrentBidiMode: TBidiMode;

  CurrentAlignment: TAlignment;

  MaxUnclippedHeight: Integer;

  TM: TTextMetric;

  ExtraVerticalMargin: Integer;



begin

  Assert(Assigned(Node), 'Node must not be nil.');

  Assert(Node <> FRoot, 'Node must not be the hidden root node.');



  MainColumnHit := (Column + 1) in [0, FHeader.MainColumn + 1];

  if not (vsInitialized in Node.States) then

    InitNode(Node);



  Result := Rect(0, 0, 0, 0);



  // Check whether the node is visible (determine indentation level btw.).

  if not IsEffectivelyVisible[Node] then

    Exit;

  Temp := Node;

  Indent := 0;

  if not (toFixedIndent in FOptions.FPaintOptions) then

  begin

    while Temp <> FRoot do

    begin

      if not (vsVisible in Temp.States) or not (vsExpanded in Temp.Parent.States) then

        Exit;

      Temp := Temp.Parent;

      if MainColumnHit and (Temp <> FRoot) then

        Inc(Indent, FIndent);

    end;

  end;//if not toFixedIndent



  // Here we know the node is visible.

  Offset := 0;

  CacheIsAvailable := False;

  if tsUseCache in FStates then

  begin

    // If we can use the position cache then do a binary search to find a cached node which is as close as possible

    // to the current node. Iterate then through all following and visible nodes and sum up their heights.

    Temp := FindInPositionCache(Node, Offset);

    CacheIsAvailable := Assigned(Temp);

    while Assigned(Temp) and (Temp <> Node) do

    begin

      Inc(Offset, NodeHeight[Temp]);

      Temp := GetNextVisibleNoInit(Temp, True);

    end;

  end;

  if not CacheIsAvailable then

  begin

    // If the cache is not available then go straight through all nodes up to the root and sum up their heights.

    Temp := Node;

    repeat

      Temp := GetPreviousVisibleNoInit(Temp, True);

      if Temp = nil then

        Break;

      Inc(Offset, NodeHeight[Temp]);

    until False;

  end;



  Result := Rect(0, Offset, Max(FRangeX, ClientWidth), Offset + NodeHeight[Node]);



  // Limit left and right bounds to the given column (if any) and move bounds according to current scroll state.

  if Column > NoColumn then

  begin

    FHeader.FColumns.GetColumnBounds(Column, Result.Left, Result.Right);

    // The right column border is not part of this cell.

    Dec(Result.Right);

    OffsetRect(Result, 0, FOffsetY);

  end

  else

    OffsetRect(Result, -FEffectiveOffsetX, FOffsetY);



  // Limit left and right bounds further if only the text area is required.

  if TextOnly then

  begin

    // Start with the offset of the text in the column and consider the indentation level too.

    Offset := FMargin + Indent;

    // If the text of a node is involved then we have to consider directionality and alignment too.

    if Column <= NoColumn then

    begin

      CurrentBidiMode := BidiMode;

      CurrentAlignment := Alignment;

    end

    else

    begin

      CurrentBidiMode := FHeader.FColumns[Column].BidiMode;

      CurrentAlignment := FHeader.FColumns[Column].Alignment;

    end;



    if MainColumnHit then

    begin

      if toShowRoot in FOptions.FPaintOptions then

        Inc(Offset, FIndent);

      if (toCheckSupport in FOptions.FMiscOptions) and Assigned(FCheckImages) and (Node.CheckType <> ctNone) then

        Inc(Offset, FCheckImages.Width + 2);

    end;

    // Consider associated images.

    if Assigned(FStateImages) and HasImage(Node, ikState, Column) then

      Inc(Offset, FStateImages.Width + 2);

    if Assigned(FImages) and HasImage(Node, ikNormal, Column) then

      Inc(Offset, GetNodeImageSize(Node).cx + 2);



    // Offset contains now the distance from the left or right border of the rectangle (depending on bidi mode).

    // Now consider the alignment too and calculate the final result.

    if CurrentBidiMode = bdLeftToRight then

    begin

      Inc(Result.Left, Offset);

      // Left-to-right reading does not need any special adjustment of the alignment.

    end

    else

    begin

      Dec(Result.Right, Offset);



      // Consider bidi mode here. In RTL context does left alignment actually mean right alignment and vice versa.

      ChangeBiDiModeAlignment(CurrentAlignment);

    end;



    TextWidth := DoGetNodeWidth(Node, Column);



    // Keep cell height before applying cell content margin in order to increase cell height if text does not fit

    // and Unclipped it true (see below).

    MaxUnclippedHeight := Result.Bottom - Result.Top;



    if ApplyCellContentMargin then

      DoBeforeCellPaint(Self.Canvas, Node, Column, cpmGetContentMargin, Result, Result);



    if Unclipped then

    begin

      // The caller requested the text coordinates unclipped. This means they must be calculated so as would

      // there be enough space, regardless of column bounds etc.

      // The layout still depends on the available space too, because this determines the position

      // of the unclipped text rectangle.

      if Result.Right - Result.Left < TextWidth - 1 then

        if CurrentBidiMode = bdLeftToRight then

          CurrentAlignment := taLeftJustify

        else

          CurrentAlignment := taRightJustify;



      // Increase cell height (up to MaxUnclippedHeight determined above) if text does not fit.

      GetTextMetrics(Self.Canvas.Handle, TM);

      ExtraVerticalMargin := Math.Min(TM.tmHeight, MaxUnclippedHeight) - (Result.Bottom - Result.Top);

      if ExtraVerticalMargin > 0 then

        InflateRect(Result, 0, (ExtraVerticalMargin + 1) div 2);



      case CurrentAlignment of

        taCenter:

          begin

            Result.Left := (Result.Left + Result.Right - TextWidth) div 2;

            Result.Right := Result.Left + TextWidth;

          end;

        taRightJustify:

          Result.Left := Result.Right - TextWidth;

      else // taLeftJustify

        Result.Right := Result.Left + TextWidth - 1;

      end;

    end

    else

      // Modify rectangle only if the text fits entirely into the given room.

      if Result.Right - Result.Left > TextWidth then

        case CurrentAlignment of

          taCenter:

            begin

              Result.Left := (Result.Left + Result.Right - TextWidth) div 2;

              Result.Right := Result.Left + TextWidth;

            end;

          taRightJustify:

            Result.Left := Result.Right - TextWidth;

        else // taLeftJustify

          Result.Right := Result.Left + TextWidth;

        end;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.GetEffectivelyFiltered(Node: PVirtualNode): Boolean;



// Checks if a node is effectively filtered out. This depends on the nodes state and the paint options.



begin

  if Assigned(Node) then

    Result := (vsFiltered in Node.States) and not (toShowFilteredNodes in FOptions.FPaintOptions)

  else

    Result := False;

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.GetEffectivelyVisible(Node: PVirtualNode): Boolean;



begin

  Result := (vsVisible in Node.States) and not IsEffectivelyFiltered[Node];

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.GetFirst(ConsiderChildrenAbove: Boolean = False): PVirtualNode;



// Returns the first node in the tree while optionally considering toChildrenAbove.



begin

  if ConsiderChildrenAbove and (toChildrenAbove in FOptions.FPaintOptions) then

  begin

    if vsHasChildren in FRoot.States then

    begin

      Result := FRoot;



      // Child nodes are the first choice if possible.

      if Assigned(Result.FirstChild) then

      begin

        while Assigned(Result.FirstChild) do

        begin

          Result := Result.FirstChild;

          if not (vsInitialized in Result.States) then

            InitNode(Result);



          if (vsHasChildren in Result.States) and (Result.ChildCount = 0) then

            InitChildren(Result);

        end;

      end

      else

        Result := nil;

    end

    else

      Result := nil;

  end

  else

    Result := FRoot.FirstChild;



  if Assigned(Result) and not (vsInitialized in Result.States) then

    InitNode(Result);

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.GetFirstChecked(State: TCheckState = csCheckedNormal;

  ConsiderChildrenAbove: Boolean = False): PVirtualNode;



// Returns the first node in the tree with the given check state.



begin

  Result := GetNextChecked(nil, State, ConsiderChildrenAbove);

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.GetFirstChild(Node: PVirtualNode): PVirtualNode;



// Returns the first child of the given node. The result node is initialized before exit.



begin

  if (Node = nil) or (Node = FRoot) then

    Result := FRoot.FirstChild

  else

  begin

    if not (vsInitialized in Node.States) then

      InitNode(Node);

    if vsHasChildren in Node.States then

    begin

      if Node.ChildCount = 0 then

        InitChildren(Node);

      Result := Node.FirstChild;

    end

    else

      Result := nil;

  end;



  if Assigned(Result) and not (vsInitialized in Result.States) then

    InitNode(Result);

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.GetFirstChildNoInit(Node: PVirtualNode): PVirtualNode;

// Determines the first child of the given node but does not initialize it.



begin

  if (Node = nil) or (Node = FRoot) then

    Result := FRoot.FirstChild

  else

  begin

    if vsHasChildren in Node.States then

      Result := Node.FirstChild

    else

      Result := nil;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.GetFirstCutCopy(ConsiderChildrenAbove: Boolean = False): PVirtualNode;



// Returns the first node in the tree which is currently marked for a clipboard operation.

// See also GetNextCutCopy for comments on initialization.



begin

  Result := GetNextCutCopy(nil, ConsiderChildrenAbove);

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.GetFirstInitialized(ConsiderChildrenAbove: Boolean = False): PVirtualNode;



// Returns the first node which is already initialized.



begin

  Result := GetFirstNoInit(ConsiderChildrenAbove);

  if Assigned(Result) and not (vsInitialized in Result.States) then

    Result := GetNextInitialized(Result, ConsiderChildrenAbove);

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.GetFirstLeaf: PVirtualNode;



// Returns the first node in the tree which has currently no children.

// The result is initialized if necessary.



begin

  Result := GetNextLeaf(nil);

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.GetFirstLevel(NodeLevel: Cardinal): PVirtualNode;



// Returns the first node in the tree on a specific level.

// The result is initialized if necessary.



begin

  Result := GetFirstNoInit(True);

  while Assigned(Result) and (GetNodeLevel(Result) <> NodeLevel) do

    Result := GetNextNoInit(Result, True);



  if Assigned(Result) and (GetNodeLevel(Result) <> NodeLevel) then // i.e. there is no node with the desired level in the tree

    Result := nil;



  if Assigned(Result) and not (vsInitialized in Result.States) then

    InitNode(Result);

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.GetFirstNoInit(ConsiderChildrenAbove: Boolean = False): PVirtualNode;



// Returns the first node in the tree while optionally considering toChildrenAbove.

// No initialization is performed.



begin

  if ConsiderChildrenAbove and (toChildrenAbove in FOptions.FPaintOptions) then

  begin

    if vsHasChildren in FRoot.States then

    begin

      Result := FRoot;



      // Child nodes are the first choice if possible.

      if Assigned(Result.FirstChild) then

      begin

        while Assigned(Result.FirstChild) do

          Result := Result.FirstChild;

      end

      else

        Result := nil;

    end

    else

      Result := nil;

  end

  else

    Result := FRoot.FirstChild;

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.GetFirstSelected(ConsiderChildrenAbove: Boolean = False): PVirtualNode;



// Returns the first node in the current selection while optionally considering toChildrenAbove.



begin

  Result := GetNextSelected(nil, ConsiderChildrenAbove);

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.GetFirstVisible(Node: PVirtualNode = nil; ConsiderChildrenAbove: Boolean = True;

  IncludeFiltered: Boolean = False): PVirtualNode;



// Returns the first visible node in the tree while optionally considering toChildrenAbove.

// If necessary nodes are initialized on demand.



begin

  Result := Node;

  if not Assigned(Result) then

    Result := FRoot;



  if vsHasChildren in Result.States then

  begin

    if Result.ChildCount = 0 then

      InitChildren(Result);



    // Child nodes are the first choice if possible.

    if Assigned(Result.FirstChild) then

    begin

      Result := GetFirstChild(Result);



      if ConsiderChildrenAbove and (toChildrenAbove in FOptions.FPaintOptions) then

      begin

        repeat

          // Search the first visible sibling.

          while Assigned(Result.NextSibling) and not (vsVisible in Result.States) do

          begin

            Result := Result.NextSibling;

            // Init node on demand as this might change the visibility.

            if not (vsInitialized in Result.States) then

              InitNode(Result);

          end;



          // If there are no visible siblings take the parent.

          if not (vsVisible in Result.States) then

          begin

            Result := Result.Parent;

            if Result = FRoot then

              Result := nil;

            Break;

          end

          else

          begin

            if (vsHasChildren in Result.States) and (Result.ChildCount = 0) then

              InitChildren(Result);

            if (not Assigned(Result.FirstChild)) or (not (vsExpanded in Result.States)) then

              Break;

          end;



          Result := Result.FirstChild;

          if not (vsInitialized in Result.States) then

            InitNode(Result);

        until False;

      end

      else

      begin

        // If there are no children or the first child is not visible then search the sibling nodes or traverse parents.

        if not (vsVisible in Result.States) then

        begin

          repeat

            // Is there a next sibling?

            if Assigned(Result.NextSibling) then

            begin

              Result := Result.NextSibling;

              // The visible state can be removed during initialization so init the node first.

              if not (vsInitialized in Result.States) then

                InitNode(Result);

              if vsVisible in Result.States then

                Break;

            end

            else

            begin

              // No sibling anymore, so use the parent's next sibling.

              if Result.Parent <> FRoot then

                Result := Result.Parent

              else

              begin

                // There are no further nodes to examine, hence there is no further visible node.

                Result := nil;

                Break;

              end;

            end;

          until False;

        end;

      end;

    end

    else

      Result := nil;

  end

  else

    Result := nil;



  if Assigned(Result) and not IncludeFiltered and IsEffectivelyFiltered[Result] then

    Result := GetNextVisible(Result);

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.GetFirstVisibleChild(Node: PVirtualNode; IncludeFiltered: Boolean = False): PVirtualNode;



// Returns the first visible child node of Node. If necessary nodes are initialized on demand.



begin

  if Node = nil then

    Node := FRoot;

  Result := GetFirstChild(Node);



  if Assigned(Result) and (not (vsVisible in Result.States) or

     (not IncludeFiltered and IsEffectivelyFiltered[Node])) then

    Result := GetNextVisibleSibling(Result, IncludeFiltered);

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.GetFirstVisibleChildNoInit(Node: PVirtualNode; IncludeFiltered: Boolean = False): PVirtualNode;



// Returns the first visible child node of Node.



begin

  if Node = nil then

    Node := FRoot;

  Result := Node.FirstChild;

  if Assigned(Result) and (not (vsVisible in Result.States) or

     (not IncludeFiltered and IsEffectivelyFiltered[Node])) then

    Result := GetNextVisibleSiblingNoInit(Result, IncludeFiltered);

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.GetFirstVisibleNoInit(Node: PVirtualNode = nil;

  ConsiderChildrenAbove: Boolean = True; IncludeFiltered: Boolean = False): PVirtualNode;



// Returns the first visible node in the tree or given subtree while optionally considering toChildrenAbove.

// No initialization is performed.



begin

  Result := Node;

  if not Assigned(Result) then

    Result := FRoot;



  if vsHasChildren in Result.States then

  begin

    // Child nodes are the first choice if possible.

    if Assigned(Result.FirstChild) then

    begin

      Result := Result.FirstChild;



      if ConsiderChildrenAbove and (toChildrenAbove in FOptions.FPaintOptions) then

      begin

        repeat

          // Search the first visible sibling.

          while Assigned(Result.NextSibling) and not (vsVisible in Result.States) do

            Result := Result.NextSibling;



          // If there a no visible siblings take the parent.

          if not (vsVisible in Result.States) then

          begin

            Result := Result.Parent;

            if Result = FRoot then

              Result := nil;

            Break;

          end

          else

            if (not Assigned(Result.FirstChild)) or (not (vsExpanded in Result.States))then

              Break;



          Result := Result.FirstChild;

        until False;

      end

      else

      begin

        // If there are no children or the first child is not visible then search the sibling nodes or traverse parents.

        if not (vsVisible in Result.States) then

        begin

          repeat

            // Is there a next sibling?

            if Assigned(Result.NextSibling) then

            begin

              Result := Result.NextSibling;

              if vsVisible in Result.States then

                Break;

            end

            else

            begin

              // No sibling anymore, so use the parent's next sibling.

              if Result.Parent <> FRoot then

                Result := Result.Parent

              else

              begin

                // There are no further nodes to examine, hence there is no further visible node.

                Result := nil;

                Break;

              end;

            end;

          until False;

        end;

      end;

    end

    else

      Result := nil;

  end

  else

    Result := nil;



  if Assigned(Result) and not IncludeFiltered and IsEffectivelyFiltered[Result] then

    Result := GetNextVisibleNoInit(Result);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.GetHitTestInfoAt(X, Y: Integer; Relative: Boolean; var HitInfo: THitInfo);



// Determines the node that occupies the specified point or nil if there's none. The parameter Relative determines

// whether to consider X and Y as being client coordinates (if True) or as being absolute tree coordinates.

// HitInfo is filled with flags describing the hit further.



var

  ColLeft,

  ColRight: Integer;

  NodeTop: Integer;

  InitialColumn,

  NextColumn: TColumnIndex;

  CurrentBidiMode: TBidiMode;

  CurrentAlignment: TAlignment;

  NodeRect: TRect;



begin

  HitInfo.HitNode := nil;

  HitInfo.HitPositions := [];

  HitInfo.HitColumn := NoColumn;



  // Determine if point lies in the tree's client area.

  if X < 0 then

    Include(HitInfo.HitPositions, hiToLeft)

  else

    if X > Max(FRangeX, ClientWidth) then

      Include(HitInfo.HitPositions, hiToRight);



  if Y < 0 then

    Include(HitInfo.HitPositions, hiAbove)

  else

    if Y > Max(FRangeY, ClientHeight) then

      Include(HitInfo.HitPositions, hiBelow);



  // Convert position into absolute coordinate if necessary.

  if Relative then

  begin

    if X >= Header.Columns.GetVisibleFixedWidth then

      Inc(X, FEffectiveOffsetX);

    Inc(Y, -FOffsetY);

  end;

  HitInfo.HitPoint.X := X;

  HitInfo.HitPoint.Y := Y;



  // If the point is in the tree area then check the nodes.

  if HitInfo.HitPositions = [] then

  begin

    HitInfo.HitNode := GetNodeAt(X, Y, False, NodeTop);

    if HitInfo.HitNode = nil then

      Include(HitInfo.HitPositions, hiNowhere)

    else

    begin

      // At this point we need some info about the node, so it must be initialized.

      if not (vsInitialized in HitInfo.HitNode.States) then

        InitNode(HitInfo.HitNode);



      if FHeader.UseColumns then

      begin

        HitInfo.HitColumn := FHeader.Columns.GetColumnAndBounds(Point(X, Y), ColLeft, ColRight, False);

        // If auto column spanning is enabled then look for the last non empty column.

        if toAutoSpanColumns in FOptions.FAutoOptions then

        begin

          InitialColumn := HitInfo.HitColumn;

          // Search to the left of the hit column for empty columns.

          while (HitInfo.HitColumn > NoColumn) and ColumnIsEmpty(HitInfo.HitNode, HitInfo.HitColumn) do

          begin

            NextColumn := FHeader.FColumns.GetPreviousVisibleColumn(HitInfo.HitColumn);

            if NextColumn = InvalidColumn then

              Break;

            HitInfo.HitColumn := NextColumn;

            Dec(ColLeft, FHeader.FColumns[NextColumn].Width);

          end;

          // Search to the right of the hit column for empty columns.

          repeat

            InitialColumn := FHeader.FColumns.GetNextVisibleColumn(InitialColumn);

            if (InitialColumn = InvalidColumn) or not ColumnIsEmpty(HitInfo.HitNode, InitialColumn) then

              Break;

            Inc(ColRight, FHeader.FColumns[InitialColumn].Width);

          until False;

        end;

        // Make the X position and the right border relative to the start of the column.

        Dec(X, ColLeft);

        Dec(ColRight, ColLeft);

      end

      else

      begin

        HitInfo.HitColumn := NoColumn;

        ColRight := Max(FRangeX, ClientWidth);

      end;

      ColLeft := 0;



      if HitInfo.HitColumn = InvalidColumn then

        Include(HitInfo.HitPositions, hiNowhere)

      else

      begin

        // From now on X is in "column" coordinates (relative to the left column border).

        HitInfo.HitPositions := [hiOnItem];



        // Avoid getting the display rect if this is not necessary.

        if toNodeHeightResize in FOptions.FMiscOptions then

        begin

          NodeRect := GetDisplayRect(HitInfo.HitNode, HitInfo.HitColumn, False);

          if Y <= (NodeRect.Top - FOffsetY + 1) then

            Include(HitInfo.HitPositions, hiUpperSplitter)

          else

          if Y >= (NodeRect.Bottom - FOffsetY - 3) then

            Include(HitInfo.HitPositions, hiLowerSplitter);

        end;



        if HitInfo.HitColumn <= NoColumn then

        begin

          CurrentBidiMode := BidiMode;

          CurrentAlignment := Alignment;

        end

        else

        begin

          CurrentBidiMode := FHeader.FColumns[HitInfo.HitColumn].BidiMode;

          CurrentAlignment := FHeader.FColumns[HitInfo.HitColumn].Alignment;

        end;



        if CurrentBidiMode = bdLeftToRight then

          DetermineHitPositionLTR(HitInfo, X, ColRight, CurrentAlignment)

        else

          DetermineHitPositionRTL(HitInfo, X, ColRight, CurrentAlignment);

      end;

    end;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.GetLast(Node: PVirtualNode = nil; ConsiderChildrenAbove: Boolean = False): PVirtualNode;



// Returns the very last node in the tree branch given by Node and initializes the nodes all the way down including the

// result. toChildrenAbove is optionally considered. By using Node = nil the very last node in the tree is returned.



var

  Next: PVirtualNode;



begin

  Result := GetLastChild(Node);

  if not ConsiderChildrenAbove or not (toChildrenAbove in FOptions.FPaintOptions) then

    while Assigned(Result) do

    begin

      // Test if there is a next last child. If not keep the node from the last run.

      // Otherwise use the next last child.

      Next := GetLastChild(Result);

      if Next = nil then

        Break;

      Result := Next;

    end;

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.GetLastInitialized(Node: PVirtualNode = nil;

  ConsiderChildrenAbove: Boolean = False): PVirtualNode;



// Returns the very last initialized child node in the tree branch given by Node.



begin

  Result := GetLastNoInit(Node, ConsiderChildrenAbove);

  if Assigned(Result) and not (vsInitialized in Result.States) then

    Result := GetPreviousInitialized(Result, ConsiderChildrenAbove);

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.GetLastNoInit(Node: PVirtualNode = nil; ConsiderChildrenAbove: Boolean = False): PVirtualNode;



// Returns the very last node in the tree branch given by Node without initialization.



var

  Next: PVirtualNode;



begin

  Result := GetLastChildNoInit(Node);

  if not ConsiderChildrenAbove or not (toChildrenAbove in FOptions.FPaintOptions) then

    while Assigned(Result) do

    begin

      // Test if there is a next last child. If not keep the node from the last run.

      // Otherwise use the next last child.

      Next := GetLastChildNoInit(Result);

      if Next = nil then

        Break;

      Result := Next;

    end;

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.GetLastChild(Node: PVirtualNode): PVirtualNode;



// Determines the last child of the given node and initializes it if there is one.



begin

  if (Node = nil) or (Node = FRoot) then

    Result := FRoot.LastChild

  else

  begin

    if not (vsInitialized in Node.States) then

      InitNode(Node);

    if vsHasChildren in Node.States then

    begin

      if Node.ChildCount = 0 then

        InitChildren(Node);

      Result := Node.LastChild;

    end

    else

      Result := nil;

  end;



  if Assigned(Result) and not (vsInitialized in Result.States) then

    InitNode(Result);

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.GetLastChildNoInit(Node: PVirtualNode): PVirtualNode;



// Determines the last child of the given node but does not initialize it.



begin

  if (Node = nil) or (Node = FRoot) then

    Result := FRoot.LastChild

  else

  begin

    if vsHasChildren in Node.States then

      Result := Node.LastChild

    else

      Result := nil;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.GetLastVisible(Node: PVirtualNode = nil; ConsiderChildrenAbove: Boolean = True;

  IncludeFiltered: Boolean = False): PVirtualNode;



// Returns the very last visible node in the tree while optionally considering toChildrenAbove.

// The nodes are intialized all the way up including the result node.



var

  Run: PVirtualNode;



begin

  Result := GetLastVisibleNoInit(Node, ConsiderChildrenAbove);



  Run := Result;

  while Assigned(Run) and (Run <> Node)  and (Run <> RootNode) do

  begin

    if not (vsInitialized in Run.States) then

      InitNode(Run);

    Run := Run.Parent;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.GetLastVisibleChild(Node: PVirtualNode; IncludeFiltered: Boolean = False): PVirtualNode;



// Determines the last visible child of the given node and initializes it if necessary.



begin

  if (Node = nil) or (Node = FRoot) then

    Result := GetLastChild(FRoot)

  else

    if FullyVisible[Node] and (vsExpanded in Node.States) then

      Result := GetLastChild(Node)

    else

      Result := nil;



  if Assigned(Result) and (not (vsVisible in Result.States) or

     (not IncludeFiltered and IsEffectivelyFiltered[Node])) then

    Result := GetPreviousVisibleSibling(Result, IncludeFiltered);



  if Assigned(Result) and not (vsInitialized in Result.States) then

    InitNode(Result);

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.GetLastVisibleChildNoInit(Node: PVirtualNode; IncludeFiltered: Boolean = False): PVirtualNode;



// Determines the last visible child of the given node without initialization.



begin

  if (Node = nil) or (Node = FRoot) then

    Result := GetLastChildNoInit(FRoot)

  else

    if FullyVisible[Node] and (vsExpanded in Node.States) then

      Result := GetLastChildNoInit(Node)

    else

      Result := nil;



  if Assigned(Result) and (not (vsVisible in Result.States) or

     (not IncludeFiltered and IsEffectivelyFiltered[Node])) then

    Result := GetPreviousVisibleSiblingNoInit(Result, IncludeFiltered);

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.GetLastVisibleNoInit(Node: PVirtualNode = nil;

  ConsiderChildrenAbove: Boolean = True; IncludeFiltered: Boolean = False): PVirtualNode;



// Returns the very last visible node in the tree while optionally considering toChildrenAbove.

// No initialization is performed.



begin

  Result := GetLastNoInit(Node, ConsiderChildrenAbove);

  while Assigned(Result) and (Result <> Node) do

  begin

    if FullyVisible[Result] and

       (IncludeFiltered or not IsEffectivelyFiltered[Result]) then

      Break;

    Result := GetPreviousNoInit(Result, ConsiderChildrenAbove);

  end;



  if (Result = Node) then // i.e. there is no visible node

    Result := nil;

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.GetMaxColumnWidth(Column: TColumnIndex; UseSmartColumnWidth: Boolean = False): Integer;



// This method determines the width of the largest node in the given column.

// If UseSmartColumnWidth is True then only the visible nodes which are in view will be considered

// Note: If UseSmartColumnWidth is False then every visible node in the tree will be initialized contradicting so

//       the virtual paradigm.



var

  Run,

  LastNode,

  NextNode: PVirtualNode;

  NodeLeft,

  TextLeft,

  CurrentWidth: Integer;

  AssumeImage: Boolean;

  WithCheck,

  WithStateImages: Boolean;

  CheckOffset,

  StateImageOffset: Integer;



begin

  if OperationCanceled then

  begin

    // Behave non-destructive.

    Result := FHeader.FColumns[Column].Width;

    Exit;

  end

  else

    Result := 0;



  StartOperation(okGetMaxColumnWidth);

  try

    if Assigned(FOnBeforeGetMaxColumnWidth) then

      FOnBeforeGetMaxColumnWidth(FHeader, Column, UseSmartColumnWidth);



    WithStateImages := Assigned(FStateImages);

    if WithStateImages then

      StateImageOffset := FStateImages.Width + 2

    else

      StateImageOffset := 0;

    if Assigned(FCheckImages) then

      CheckOffset := FCheckImages.Width + 2

    else

      CheckOffset := 0;



    if UseSmartColumnWidth then // Get first visible node which is in view.

      Run := GetTopNode

    else

      Run := GetFirstVisible(nil, True);



    if Column = FHeader.MainColumn then

    begin

      if toFixedIndent in FOptions.FPaintOptions then

        NodeLeft := FIndent

      else

      begin

        if toShowRoot in FOptions.FPaintOptions then

          NodeLeft := Integer((GetNodeLevel(Run) + 1) * FIndent)

        else

          NodeLeft := Integer(GetNodeLevel(Run) * FIndent);

      end;



      WithCheck := (toCheckSupport in FOptions.FMiscOptions) and Assigned(FCheckImages);

    end

    else

    begin

      NodeLeft := 0;

      WithCheck := False;

    end;



    // Consider node margin at the left of the nodes.

    Inc(NodeLeft, FMargin);



    // Decide where to stop.

    if UseSmartColumnWidth then

      LastNode := GetNextVisible(BottomNode)

    else

      LastNode := nil;



    AssumeImage := False;

    while Assigned(Run) and not OperationCanceled do

    begin

      TextLeft := NodeLeft;

      if WithCheck and (Run.CheckType <> ctNone) then

        Inc(TextLeft, CheckOffset);

      if Assigned(FImages) and (AssumeImage or HasImage(Run, ikNormal, Column)) then

      begin

        TextLeft := TextLeft + GetNodeImageSize(Run).cx + 2;

        AssumeImage := True;// From now on, assume that the nodes do ave an image

      end;

      if WithStateImages and HasImage(Run, ikState, Column) then

        Inc(TextLeft, StateImageOffset);



      CurrentWidth := DoGetNodeWidth(Run, Column);

      Inc(CurrentWidth, DoGetNodeExtraWidth(Run, Column));

      Inc(CurrentWidth, DoGetCellContentMargin(Run, Column).X);



      if Result < (TextLeft + CurrentWidth) then

        Result := TextLeft + CurrentWidth;



      // Get next visible node and update left node position if needed.

      NextNode := GetNextVisible(Run, True);

      if NextNode = LastNode then

        Break;

      if (Column = Header.MainColumn) and not (toFixedIndent in FOptions.FPaintOptions) then

        Inc(NodeLeft, CountLevelDifference(Run, NextNode) * Integer(FIndent));

      Run := NextNode;

    end;

    if toShowVertGridLines in FOptions.FPaintOptions then

      Inc(Result);



    if Assigned(FOnAfterGetMaxColumnWidth) then

      FOnAfterGetMaxColumnWidth(FHeader, Column, Result);



  finally

    EndOperation(okGetMaxColumnWidth);

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.GetNext(Node: PVirtualNode; ConsiderChildrenAbove: Boolean = False): PVirtualNode;



// Returns next node in tree while optionally considering toChildrenAbove. The Result will be initialized if needed.



begin

  Result := Node;

  if Assigned(Result) then

  begin

    Assert(Result <> FRoot, 'Node must not be the hidden root node.');



    if ConsiderChildrenAbove and (toChildrenAbove in FOptions.FPaintOptions) then

    begin

      // If this node has no siblings use the parent.

      if not Assigned(Result.NextSibling) then

      begin

        Result := Result.Parent;

        if Result = FRoot then

        begin

          Result := nil;

        end;

      end

      else

      begin

        // There is at least one sibling so take it.

        Result := Result.NextSibling;



        // Has this node got children? Initialize them if necessary.

        if (vsHasChildren in Result.States) and (Result.ChildCount = 0) then

          InitChildren(Result);



        // Now take a look at the children.

        while Assigned(Result.FirstChild) do

        begin

          Result := Result.FirstChild;

          if (vsHasChildren in Result.States) and (Result.ChildCount = 0) then

            InitChildren(Result);

        end;

      end;

    end

    else

    begin

      // Has this node got children?

      if vsHasChildren in Result.States then

      begin

        // Yes, there are child nodes. Initialize them if necessary.

        if Result.ChildCount = 0 then

          InitChildren(Result);

      end;



      // if there is no child node try siblings

      if Assigned(Result.FirstChild) then

        Result := Result.FirstChild

      else

      begin

        repeat

          // Is there a next sibling?

          if Assigned(Result.NextSibling) then

          begin

            Result := Result.NextSibling;

            Break;

          end

          else

          begin

            // No sibling anymore, so use the parent's next sibling.

            if Result.Parent <> FRoot then

              Result := Result.Parent

            else

            begin

              // There are no further nodes to examine, hence there is no further visible node.

              Result := nil;

              Break;

            end;

          end;

        until False;

      end;

    end;

  end;



  if Assigned(Result) and not (vsInitialized in Result.States) then

    InitNode(Result);

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.GetNextChecked(Node: PVirtualNode; State: TCheckState = csCheckedNormal;

  ConsiderChildrenAbove: Boolean = False): PVirtualNode;



begin

  if (Node = nil) or (Node = FRoot) then

    Result := GetFirstNoInit(ConsiderChildrenAbove)

  else

    Result := GetNextNoInit(Node, ConsiderChildrenAbove);



  while Assigned(Result) and (Result.CheckState <> State) do

    Result := GetNextNoInit(Result, ConsiderChildrenAbove);



  if Assigned(Result) and not (vsInitialized in Result.States) then

    InitNode(Result);

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.GetNextChecked(Node: PVirtualNode; ConsiderChildrenAbove: Boolean): PVirtualNode;

begin

  Result := Self.GetNextChecked(Node, csCheckedNormal, ConsiderChildrenAbove);

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.GetNextCutCopy(Node: PVirtualNode; ConsiderChildrenAbove: Boolean = False): PVirtualNode;



// Returns the next node in the tree which is currently marked for a clipboard operation. Since only visible nodes can

// be marked (or they are hidden after they have been marked) it is not necessary to initialize nodes to check for

// child nodes. The result, however, is initialized if necessary.



begin

  if ClipboardStates * FStates <> [] then

  begin

    if (Node = nil) or (Node = FRoot) then

      Result := GetFirstNoInit(ConsiderChildrenAbove)

    else

      Result := GetNextNoInit(Node, ConsiderChildrenAbove);

    while Assigned(Result) and not (vsCutOrCopy in Result.States) do

      Result := GetNextNoInit(Result, ConsiderChildrenAbove);

    if Assigned(Result) and not (vsInitialized in Result.States) then

      InitNode(Result);

  end

  else

    Result := nil;

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.GetNextInitialized(Node: PVirtualNode; ConsiderChildrenAbove: Boolean = False): PVirtualNode;



// Returns the next node in tree which is initialized.



begin

  Result := Node;

  repeat

    Result := GetNextNoInit(Result, ConsiderChildrenAbove);

  until (Result = nil) or (vsInitialized in Result.States);

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.GetNextLeaf(Node: PVirtualNode): PVirtualNode;



// Returns the next node in the tree which has currently no children.

// The result is initialized if necessary.



begin

  if (Node = nil) or (Node = FRoot) then

    Result := FRoot.FirstChild

  else

    Result := GetNext(Node);

  while Assigned(Result) and (vsHasChildren in Result.States) do

    Result := GetNext(Result);

  if Assigned(Result) and not (vsInitialized in Result.States) then

    InitNode(Result);

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.GetNextLevel(Node: PVirtualNode; NodeLevel: Cardinal): PVirtualNode;



// Returns the next node in the tree on a specific level.

// The result is initialized if necessary.



var

  StartNodeLevel: Cardinal;



begin

  Result := nil;



  if Assigned(Node) and (Node <> FRoot) then

  begin

    StartNodeLevel := GetNodeLevel(Node);



    if StartNodeLevel < NodeLevel then

    begin

      Result := GetNext(Node);

      if Assigned(Result) and (GetNodeLevel(Result) <> NodeLevel) then

        Result := GetNextLevel(Result, NodeLevel);

    end

    else

      if StartNodeLevel = NodeLevel then

      begin

        Result := Node.NextSibling;

        if not Assigned(Result) then // i.e. start node was a last sibling

        begin

          Result := Node.Parent;

          if Assigned(Result) then

          begin

            // go to next anchestor of the start node which has a next sibling (if exists)

            while Assigned(Result) and not Assigned(Result.NextSibling) do

              Result := Result.Parent;

            if Assigned(Result) then

              Result := GetNextLevel(Result.NextSibling, NodeLevel);

          end;

        end;

      end

      else

        // i.e. StartNodeLevel > NodeLevel

        Result := GetNextLevel(Node.Parent, NodeLevel);

  end;



  if Assigned(Result) and not (vsInitialized in Result.States) then

    InitNode(Result);

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.GetNextNoInit(Node: PVirtualNode; ConsiderChildrenAbove: Boolean): PVirtualNode;



// Optimized version of GetNext performing no initialization, but optionally considering toChildrenAbove.



begin

  Result := Node;

  if Assigned(Result) then

  begin

    Assert(Result <> FRoot, 'Node must not be the hidden root node.');



    if ConsiderChildrenAbove and (toChildrenAbove in FOptions.FPaintOptions) then

    begin

      // If this node has no siblings use the parent.

      if not Assigned(Result.NextSibling) then

      begin

        Result := Result.Parent;

        if Result = FRoot then

        begin

          Result := nil;

        end;

      end

      else

      begin

        // There is at least one sibling so take it.

        Result := Result.NextSibling;



        // Now take a look at the children.

        while Assigned(Result.FirstChild) do

        begin

          Result := Result.FirstChild;

        end;

      end;

    end

    else

    begin

      // If there is no child node try siblings.

      if Assigned(Result.FirstChild) then

        Result := Result.FirstChild

      else

      begin

        repeat

          // Is there a next sibling?

          if Assigned(Result.NextSibling) then

          begin

            Result := Result.NextSibling;

            Break;

          end

          else

          begin

            // No sibling anymore, so use the parent's next sibling.

            if Result.Parent <> FRoot then

              Result := Result.Parent

            else

            begin

              // There are no further nodes to examine, hence there is no further visible node.

              Result := nil;

              Break;

            end;

          end;

        until False;

      end;

    end;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.GetNextSelected(Node: PVirtualNode; ConsiderChildrenAbove: Boolean = False): PVirtualNode;



// Returns the next node in the tree which is currently selected. Since children of unitialized nodes cannot be

// in the current selection (because they simply do not exist yet) it is not necessary to initialize nodes here.

// The result however is initialized if necessary.



begin

  if FSelectionCount > 0 then

  begin

    if (Node = nil) or (Node = FRoot) then

      Result := GetFirstNoInit(ConsiderChildrenAbove)

    else

      Result := GetNextNoInit(Node, ConsiderChildrenAbove);

    while Assigned(Result) and not (vsSelected in Result.States) do

      Result := GetNextNoInit(Result, ConsiderChildrenAbove);

    if Assigned(Result) and not (vsInitialized in Result.States) then

      InitNode(Result);

  end

  else

    Result := nil;

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.GetNextSibling(Node: PVirtualNode): PVirtualNode;



// Returns the next sibling of Node and initializes it if necessary.



begin

  Result := Node;

  if Assigned(Result) then

  begin

    Assert(Result <> FRoot, 'Node must not be the hidden root node.');



    Result := Result.NextSibling;

    if Assigned(Result) and not (vsInitialized in Result.States) then

      InitNode(Result);

  end;

end;



function TBaseVirtualTree.GetNextSiblingNoInit(Node: PVirtualNode): PVirtualNode;



// Returns the next sibling of Node.



begin

  Result := Node;

  if Assigned(Result) then

  begin

    Assert(Result <> FRoot, 'Node must not be the hidden root node.');



    Result := Result.NextSibling;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.GetNextVisible(Node: PVirtualNode; ConsiderChildrenAbove: Boolean = True): PVirtualNode;



// Returns next node in tree, with regard to Node, which is visible.

// Nodes which need an initialization (including the result) are initialized.

// toChildrenAbove is optionally considered which is the default here.



var

  ForceSearch: Boolean;



begin

  Result := Node;

  if Assigned(Result) then

  begin

    Assert(Result <> FRoot, 'Node must not be the hidden root node.');



    repeat

      // If the given node is not visible then look for a parent node which is visible, otherwise we will

      // likely go unnecessarily through a whole bunch of invisible nodes.

      if not FullyVisible[Result] then

        Result := GetVisibleParent(Result, True);



      if ConsiderChildrenAbove and (toChildrenAbove in FOptions.FPaintOptions) then

      begin

        repeat

          // If there a no siblings anymore, go up one level.

          if not Assigned(Result.NextSibling) then

          begin

            Result := Result.Parent;

            if Result = FRoot then

            begin

              Result := nil;

              Break;

            end;



            if not (vsInitialized in Result.States) then

              InitNode(Result);

            if vsVisible in Result.States then

              Break;

          end

          else

          begin

            // There is at least one sibling so take it.

            Result := Result.NextSibling;

            if not (vsInitialized in Result.States) then

              InitNode(Result);

            if not (vsVisible in Result.States) then

              Continue;



            // Now take a look at the children.

            // As the children are initialized while toggling, we don't need to do this here.

            while (vsExpanded in Result.States) and Assigned(Result.FirstChild) do

            begin

              Result := Result.FirstChild;

              if not (vsInitialized in Result.States) then

                InitNode(Result);

              if not (vsVisible in Result.States) then

                Break;

            end;



            // If we found a visible node we don't need to search any longer.

            if vsVisible in Result.States then

              Break;

          end;

        until False;

      end

      else

      begin

        // Has this node got children?

        if [vsHasChildren, vsExpanded] * Result.States = [vsHasChildren, vsExpanded] then

        begin

          // Yes, there are child nodes. Initialize them if necessary.

          if Result.ChildCount = 0 then

            InitChildren(Result);

        end;



        // Child nodes are the first choice if possible.

        if (vsExpanded in Result.States) and Assigned(Result.FirstChild) then

        begin

          Result := GetFirstChild(Result);

          ForceSearch := False;

        end

        else

          ForceSearch := True;



        // If there are no children or the first child is not visible then search the sibling nodes or traverse parents.

        if Assigned(Result) and (ForceSearch or not (vsVisible in Result.States)) then

        begin

          repeat

            // Is there a next sibling?

            if Assigned(Result.NextSibling) then

            begin

              Result := Result.NextSibling;

              if not (vsInitialized in Result.States) then

                InitNode(Result);

              if vsVisible in Result.States then

                Break;

            end

            else

            begin

              // No sibling anymore, so use the parent's next sibling.

              if Result.Parent <> FRoot then

                Result := Result.Parent

              else

              begin

                // There are no further nodes to examine, hence there is no further visible node.

                Result := nil;

                Break;

              end;

            end;

          until False;

        end;

      end;

    until not Assigned(Result) or IsEffectivelyVisible[Result];

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.GetNextVisibleNoInit(Node: PVirtualNode; ConsiderChildrenAbove: Boolean = True): PVirtualNode;



// Returns the next node in tree, with regard to Node, which is visible.

// toChildrenAbove is optionally considered (which is the default). No initialization is done.



var

  ForceSearch: Boolean;



begin

  Result := Node;

  if Assigned(Result) then

  begin

    Assert(Result <> FRoot, 'Node must not be the hidden root node.');



    repeat

      if ConsiderChildrenAbove and (toChildrenAbove in FOptions.FPaintOptions) then

      begin

        repeat

          // If there a no siblings anymore, go up one level.

          if not Assigned(Result.NextSibling) then

          begin

            Result := Result.Parent;

            if Result = FRoot then

            begin

              Result := nil;

              Break;

            end;

            if vsVisible in Result.States then

              Break;

          end

          else

          begin

            // There is at least one sibling so take it.

            Result := Result.NextSibling;

            if not (vsVisible in Result.States) then

              Continue;



            // Now take a look at the children.

            while (vsExpanded in Result.States) and Assigned(Result.FirstChild) do

            begin

              Result := Result.FirstChild;

              if not (vsVisible in Result.States) then

                Break;

            end;



            // If we found a visible node we don't need to search any longer.

            if vsVisible in Result.States then

              Break;

          end;

        until False;

      end

      else

      begin

        // If the given node is not visible then look for a parent node which is visible, otherwise we will

        // likely go unnecessarily through a whole bunch of invisible nodes.

        if not FullyVisible[Result] then

          Result := GetVisibleParent(Result, True);



        // Child nodes are the first choice if possible.

        if (vsExpanded in Result.States) and Assigned(Result.FirstChild) then

        begin

          Result := Result.FirstChild;

          ForceSearch := False;

        end

        else

          ForceSearch := True;



        // If there are no children or the first child is not visible then search the sibling nodes or traverse parents.

        if ForceSearch or not (vsVisible in Result.States) then

        begin

          repeat

            // Is there a next sibling?

            if Assigned(Result.NextSibling) then

            begin

              Result := Result.NextSibling;

              if vsVisible in Result.States then

                Break;

            end

            else

            begin

              // No sibling anymore, so use the parent's next sibling.

              if Result.Parent <> FRoot then

                Result := Result.Parent

              else

              begin

                // There are no further nodes to examine, hence there is no further visible node.

                Result := nil;

                Break;

              end;

            end;

          until False;

        end;

      end;

    until not Assigned(Result) or IsEffectivelyVisible[Result];

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.GetNextVisibleSibling(Node: PVirtualNode; IncludeFiltered: Boolean = False): PVirtualNode;



// Returns the next visible sibling after Node. Initialization is done implicitly.



begin

  Assert(Assigned(Node) and (Node <> FRoot), 'Invalid parameter.');



  Result := Node;

  repeat

    Result := GetNextSibling(Result);

  until not Assigned(Result) or ((vsVisible in Result.States) and

        (IncludeFiltered or not IsEffectivelyFiltered[Result]));

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.GetNextVisibleSiblingNoInit(Node: PVirtualNode; IncludeFiltered: Boolean = False): PVirtualNode;



// Returns the next visible sibling after Node.



begin

  Assert(Assigned(Node) and (Node <> FRoot), 'Invalid parameter.');



  Result := Node;

  repeat

    Result := Result.NextSibling;

  until not Assigned(Result) or ((vsVisible in Result.States) and

       (IncludeFiltered or not IsEffectivelyFiltered[Result]));

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.GetNodeAt(X, Y: Integer): PVirtualNode;



// Overloaded variant of GetNodeAt to easy life of application developers which do not need to have the exact

// top position returned and always use client coordinates.



var

  Dummy: Integer;



begin

  Result := GetNodeAt(X, Y, True, Dummy);

end;



function TBaseVirtualTree.GetNodeAt(const P: TPoint): PVirtualNode;

begin

  Result := GetNodeAt(P.X, P.Y);

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.GetNodeAt(X, Y: Integer; Relative: Boolean; var NodeTop: Integer): PVirtualNode;



// This method returns the node that occupies the specified point, or nil if there's none.

// If Releative is True then X and Y are given in client coordinates otherwise they are considered as being

// absolute values into the virtual tree image (regardless of the current offsets in the tree window).

// NodeTop gets the absolute or relative top position of the node returned or is untouched if no node

// could be found.



var

  AbsolutePos,

  CurrentPos: Cardinal;



begin

  if Y < 0 then

    Y := 0;



  AbsolutePos := Y;

  if Relative then

    Inc(AbsolutePos, -FOffsetY);



  // CurrentPos tracks a running term of the current position to test for.

  // It corresponds always to the top position of the currently considered node.

  CurrentPos := 0;



  // If the cache is available then use it.

  if tsUseCache in FStates then

    Result := FindInPositionCache(AbsolutePos, CurrentPos)

  else

    Result := GetFirstVisibleNoInit(nil, True);



  // Determine node, of which position and height corresponds to the scroll position most closely.

  while Assigned(Result) and (Result <> FRoot) do

  begin

    if AbsolutePos < (CurrentPos + NodeHeight[Result]) then

      Break;

    Inc(CurrentPos, NodeHeight[Result]);

    Result := GetNextVisibleNoInit(Result, True);

  end;



  if Result = FRoot then

    Result := nil;



  // Since the given vertical position is likely not the same as the top position

  // of the found node this top position is returned.

  if Assigned(Result) then

  begin

    NodeTop := CurrentPos;

    if Relative then

      Inc(NodeTop, FOffsetY);

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.GetNodeData(Node: PVirtualNode): Pointer;



// Returns the address of the user defined data area in the node.



begin

  Assert(FNodeDataSize > 0, 'NodeDataSize not initialized.');

  if (FNodeDataSize <= 0) or (Node = nil) or (Node = FRoot) then

    Result := nil

  else

  begin

    Result := PByte(@Node.Data) + FTotalInternalDataSize;

    Include(Node.States, vsOnFreeNodeCallRequired); // We now need to call OnFreeNode, see bug #323

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.GetNodeLevel(Node: PVirtualNode): Cardinal;



// returns the level of the given node



var

  Run: PVirtualNode;



begin

  Result := 0;

  if Assigned(Node) and (Node <> FRoot) then

  begin

    Run := Node.Parent;

    while Run <> FRoot do

    begin

      Run := Run.Parent;

      Inc(Result);

    end;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.GetPrevious(Node: PVirtualNode; ConsiderChildrenAbove: Boolean = False): PVirtualNode;



// Returns previous node in tree. If ConsiderChildrenAbove is True the function considers

// whether toChildrenAbove is currently set, otherwise the result will always be the previous

// node in top-down order regardless of the current PaintOptions.

// The Result will be initialized if needed.



var

  Run: PVirtualNode;



begin

  Result := Node;

  if Assigned(Result) then

  begin

    Assert(Result <> FRoot, 'Node must not be the hidden root node.');



    if ConsiderChildrenAbove and (toChildrenAbove in FOptions.FPaintOptions) then

    begin

      // Has this node got children? Initialize them if necessary.

      if (vsHasChildren in Result.States) and (Result.ChildCount = 0) then

        InitChildren(Result);



      // If there is a last child, take it; if not try the previous sibling.

      if Assigned(Result.LastChild) then

        Result := Result.LastChild

      else

        if Assigned(Result.PrevSibling) then

           Result := Result.PrevSibling

      else

      begin

        // If neither a last child nor a previous sibling exist, go the tree upwards and

        // look, wether one of the parent nodes have a previous sibling. If not the result

        // will ne nil.

        repeat

          Result := Result.Parent;

          Run := nil;

          if Result <> FRoot then

            Run := Result.PrevSibling

          else

            Result := nil;

        until Assigned(Run) or (Result = nil);



        if Assigned(Run) then

          Result := Run;

      end;

    end

    else

    begin

      // Is there a previous sibling?

      if Assigned(Node.PrevSibling) then

      begin

        // Go down and find the last child node.

        Result := GetLast(Node.PrevSibling);

        if Result = nil then

          Result := Node.PrevSibling;

      end

      else

        // no previous sibling so the parent of the node is the previous visible node

        if Node.Parent <> FRoot then

          Result := Node.Parent

        else

          Result := nil;

    end;

  end;



  if Assigned(Result) and not (vsInitialized in Result.States) then

    InitNode(Result);

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.GetPreviousChecked(Node: PVirtualNode; State: TCheckState = csCheckedNormal;

  ConsiderChildrenAbove: Boolean = False): PVirtualNode;



begin

  if (Node = nil) or (Node = FRoot) then

    Result := GetLastNoInit(nil, ConsiderChildrenAbove)

  else

    Result := GetPreviousNoInit(Node, ConsiderChildrenAbove);



  while Assigned(Result) and (Result.CheckState <> State) do

    Result := GetPreviousNoInit(Result, ConsiderChildrenAbove);



  if Assigned(Result) and not (vsInitialized in Result.States) then

    InitNode(Result);

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.GetPreviousCutCopy(Node: PVirtualNode; ConsiderChildrenAbove: Boolean = False): PVirtualNode;



// Returns the previous node in the tree which is currently marked for a clipboard operation. Since only visible nodes can

// be marked (or they are hidden after they have been marked) it is not necessary to initialize nodes to check for

// child nodes. The result, however, is initialized if necessary.



begin

  if ClipboardStates * FStates <> [] then

  begin

    if (Node = nil) or (Node = FRoot) then

      Result := GetLastNoInit(nil, ConsiderChildrenAbove)

    else

      Result := GetPreviousNoInit(Node, ConsiderChildrenAbove);

    while Assigned(Result) and not (vsCutOrCopy in Result.States) do

      Result := GetPreviousNoInit(Result, ConsiderChildrenAbove);

    if Assigned(Result) and not (vsInitialized in Result.States) then

      InitNode(Result);

  end

  else

    Result := nil;

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.GetPreviousInitialized(Node: PVirtualNode; ConsiderChildrenAbove: Boolean = False): PVirtualNode;



// Returns the previous node in tree which is initialized.



begin

  Result := Node;

  repeat

    Result := GetPreviousNoInit(Result, ConsiderChildrenAbove);

  until (Result = nil) or (vsInitialized in Result.States);

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.GetPreviousLeaf(Node: PVirtualNode): PVirtualNode;



// Returns the previous node in the tree which has currently no children.

// The result is initialized if necessary.



begin

  if (Node = nil) or (Node = FRoot) then

    Result := FRoot.LastChild

  else

    Result := GetPrevious(Node);

  while Assigned(Result) and (vsHasChildren in Result.States) do

    Result := GetPrevious(Result);

  if Assigned(Result) and not (vsInitialized in Result.States) then

    InitNode(Result);

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.GetPreviousLevel(Node: PVirtualNode; NodeLevel: Cardinal): PVirtualNode;



// Returns the previous node in the tree on a specific level.

// The result is initialized if necessary.



var

  StartNodeLevel: Cardinal;

  Run: PVirtualNode;



begin

  Result := nil;



  if Assigned(Node) and (Node <> FRoot) then

  begin

    StartNodeLevel := GetNodeLevel(Node);



    if StartNodeLevel < NodeLevel then

    begin

      Result := Node.PrevSibling;

      if Assigned(Result) then

      begin

        // go to last descendant of previous sibling with desired node level (if exists)

        Run := Result;

        while Assigned(Run) and (GetNodeLevel(Run) < NodeLevel) do

        begin

          Result := Run;

          Run := GetLastChild(Run);

        end;

        if Assigned(Run) and (GetNodeLevel(Run) = NodeLevel) then

          Result := Run

        else

        begin

          if Assigned(Result.PrevSibling) then

            Result := GetPreviousLevel(Result, NodeLevel)

          else

            if Assigned(Result) and (Result.Parent <> FRoot) then

              Result := GetPreviousLevel(Result.Parent, NodeLevel)

          else

            Result := nil;

        end;

      end

      else

        Result := GetPreviousLevel(Node.Parent, NodeLevel);

    end

    else

      if StartNodeLevel = NodeLevel then

      begin

        Result := Node.PrevSibling;

        if not Assigned(Result) then // i.e. start node was a first sibling

        begin

          Result := Node.Parent;

          if Assigned(Result) then

            Result := GetPreviousLevel(Result, NodeLevel);

        end;

      end

      else // i.e. StartNodeLevel > NodeLevel

        Result := GetPreviousLevel(Node.Parent, NodeLevel);

  end;



  if Assigned(Result) and not (vsInitialized in Result.States) then

    InitNode(Result);

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.GetPreviousNoInit(Node: PVirtualNode; ConsiderChildrenAbove: Boolean = False): PVirtualNode;



// Returns previous node in tree, optionally considering toChildrenAbove. No initialization is performed.



var

  Run: PVirtualNode;



begin

  Result := Node;

  if Assigned(Result) then

  begin

    Assert(Result <> FRoot, 'Node must not be the hidden root node.');



    if ConsiderChildrenAbove and (toChildrenAbove in FOptions.FPaintOptions) then

    begin

      // If there is a last child, take it; if not try the previous sibling.

      if Assigned(Result.LastChild) then

        Result := Result.LastChild

      else

        if Assigned(Result.PrevSibling) then

          Result := Result.PrevSibling

        else

        begin

          // If neither a last child nor a previous sibling exist, go the tree upwards and

          // look, wether one of the parent nodes have a previous sibling. If not the result

          // will ne nil.

          repeat

            Result := Result.Parent;

            Run := nil;

            if Result <> FRoot then

              Run := Result.PrevSibling

            else

              Result := nil;

          until Assigned(Run) or (Result = nil);



          if Assigned(Run) then

            Result := Run;

        end;

    end

    else

    begin

      // Is there a previous sibling?

      if Assigned(Node.PrevSibling) then

      begin

        // Go down and find the last child node.

        Result := GetLastNoInit(Node.PrevSibling);

        if Result = nil then

          Result := Node.PrevSibling;

      end

      else

        // No previous sibling so the parent of the node is the previous node.

        if Node.Parent <> FRoot then

          Result := Node.Parent

        else

          Result := nil;

    end;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.GetPreviousSelected(Node: PVirtualNode; ConsiderChildrenAbove: Boolean = False): PVirtualNode;



// Returns the previous node in the tree which is currently selected. Since children of unitialized nodes cannot be

// in the current selection (because they simply do not exist yet) it is not necessary to initialize nodes here.

// The result however is initialized if necessary.



begin

  if FSelectionCount > 0 then

  begin

    if (Node = nil) or (Node = FRoot) then

      Result := FRoot.LastChild

    else

      Result := GetPreviousNoInit(Node, ConsiderChildrenAbove);

    while Assigned(Result) and not (vsSelected in Result.States) do

      Result := GetPreviousNoInit(Result, ConsiderChildrenAbove);

    if Assigned(Result) and not (vsInitialized in Result.States) then

      InitNode(Result);

  end

  else

    Result := nil;

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.GetPreviousSibling(Node: PVirtualNode): PVirtualNode;



// Returns the previous sibling of Node and initializes it if necessary.



begin

  Result := Node;

  if Assigned(Result) then

  begin

    Assert(Result <> FRoot, 'Node must not be the hidden root node.');



    Result := Result.PrevSibling;

    if Assigned(Result) and not (vsInitialized in Result.States) then

      InitNode(Result);

  end;

end;



function TBaseVirtualTree.GetPreviousSiblingNoInit(Node: PVirtualNode): PVirtualNode;



// Returns the previous sibling of Node



begin

  Result := Node;

  if Assigned(Result) then

  begin

    Assert(Result <> FRoot, 'Node must not be the hidden root node.');



    Result := Result.PrevSibling;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.GetPreviousVisible(Node: PVirtualNode; ConsiderChildrenAbove: Boolean = True): PVirtualNode;



// Returns the previous node in tree, with regard to Node, which is visible.

// Nodes which need an initialization (including the result) are initialized.

// toChildrenAbove is optionally considered which is the default here.



var

  Marker: PVirtualNode;



begin

  Result := Node;

  if Assigned(Result) then

  begin

    Assert(Result <> FRoot, 'Node must not be the hidden root node.');



    repeat

      // If the given node is not visible then look for a parent node which is visible and use its last visible

      // child or the parent node (if there is no visible child) as result.

      if not FullyVisible[Result] then

      begin

        Result := GetVisibleParent(Result, True);

        if Result = FRoot then

          Result := nil;

        Marker := GetLastVisible(Result, True);

        if Assigned(Marker) then

          Result := Marker;

      end

      else

      begin

        if ConsiderChildrenAbove and (toChildrenAbove in FOptions.FPaintOptions) then

        begin

          repeat

            if Assigned(Result.LastChild) and (vsExpanded in Result.States) then

            begin

              Result := Result.LastChild;

              if not (vsInitialized in Result.States) then

                InitNode(Result);



              if vsVisible in Result.States then

                Break;

            end

            else

              if Assigned(Result.PrevSibling) then

              begin

                if not (vsInitialized in Result.PrevSibling.States) then

                  InitNode(Result.PrevSibling);



                if vsVisible in Result.PrevSibling.States then

                begin

                  Result := Result.PrevSibling;

                  Break;

                end;

              end

              else

              begin

                Marker := nil;

                repeat

                  Result := Result.Parent;

                  if Result <> FRoot then

                    Marker := GetPreviousVisibleSibling(Result, True)

                  else

                    Result := nil;

                until Assigned(Marker) or (Result = nil);

                if Assigned(Marker) then

                  Result := Marker;



                Break;

              end;

          until False;

        end

        else

        begin

          repeat

            // Is there a previous sibling node?

            if Assigned(Result.PrevSibling) then

            begin

              Result := Result.PrevSibling;

              // Initialize the new node and check its visibility.

              if not (vsInitialized in Result.States) then

                InitNode(Result);

              if vsVisible in Result.States then

              begin

                // If there are visible child nodes then use the last one.

                Marker := GetLastVisible(Result, True, True);

                if Assigned(Marker) then

                  Result := Marker;

                Break;

              end;

            end

            else

            begin

              // No previous sibling there so the parent node is the nearest previous node.

              Result := Result.Parent;

              if Result = FRoot then

                Result := nil;

              Break;

            end;

          until False;

        end;



        if Assigned(Result) and not (vsInitialized in Result.States) then

          InitNode(Result);

      end;

    until not Assigned(Result) or IsEffectivelyVisible[Result];

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.GetPreviousVisibleNoInit(Node: PVirtualNode;

  ConsiderChildrenAbove: Boolean = True): PVirtualNode;



// Returns the previous node in tree, with regard to Node, which is visible.

// toChildrenAbove is optionally considered which is the default here.



var

  Marker: PVirtualNode;



begin

  Result := Node;

  if Assigned(Result) then

  begin

    Assert(Result <> FRoot, 'Node must not be the hidden root node.');



    repeat

      // If the given node is not visible then look for a parent node which is visible and use its last visible

      // child or the parent node (if there is no visible child) as result.

      if not FullyVisible[Result] then

      begin

        Result := GetVisibleParent(Result, True);

        if Result = FRoot then

          Result := nil;

        Marker := GetLastVisibleNoInit(Result, True);

        if Assigned(Marker) then

          Result := Marker;

      end

      else

      begin

        if ConsiderChildrenAbove and (toChildrenAbove in FOptions.FPaintOptions) then

        begin

          repeat

            // Is the current node expanded and has children?

            if (vsExpanded in Result.States) and Assigned(Result.LastChild) then

            begin

              Result := Result.LastChild;

              if vsVisible in Result.States then

                Break;

            end

            else

              if Assigned(Result.PrevSibling) then

              begin

                // No children anymore, so take the previous sibling.

                if vsVisible in Result.PrevSibling.States then

                begin

                  Result := Result.PrevSibling;

                  Break;

                end;

              end

              else

              begin

                // No children and no previous siblings, so walk up the tree and look wether

                // a parent has a previous visible sibling. If that is the case take it,

                // otherwise there is no previous visible node.

                Marker := nil;

                repeat

                  Result := Result.Parent;

                  if Result <> FRoot then

                    Marker := GetPreviousVisibleSiblingNoInit(Result, True)

                  else

                    Result := nil;

                until Assigned(Marker) or (Result = nil);

                if Assigned(Marker) then

                  Result := Marker;

                Break;

              end;

          until False;

        end

        else

        begin

          repeat

            // Is there a previous sibling node?

            if Assigned(Result.PrevSibling) then

            begin

              Result := Result.PrevSibling;

              if vsVisible in Result.States then

              begin

                // If there are visible child nodes then use the last one.

                Marker := GetLastVisibleNoInit(Result, True, True);

                if Assigned(Marker) then

                  Result := Marker;

                Break;

              end;

            end

            else

            begin

              // No previous sibling there so the parent node is the nearest previous node.

              Result := Result.Parent;

              if Result = FRoot then

                Result := nil;

              Break;

            end;

          until False;

        end;

      end;

    until not Assigned(Result) or IsEffectivelyVisible[Result];

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.GetPreviousVisibleSibling(Node: PVirtualNode; IncludeFiltered: Boolean = False): PVirtualNode;



// Returns the previous visible sibling before Node. Initialization is done implicitly.



begin

  Assert(Assigned(Node) and (Node <> FRoot), 'Invalid parameter.');



  Result := Node;

  repeat

    Result := GetPreviousSibling(Result);

  until not Assigned(Result) or ((vsVisible in Result.States) and

        (IncludeFiltered or not IsEffectivelyFiltered[Result]));

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.GetPreviousVisibleSiblingNoInit(Node: PVirtualNode;

  IncludeFiltered: Boolean = False): PVirtualNode;



// Returns the previous visible sibling before Node.



begin

  Assert(Assigned(Node) and (Node <> FRoot), 'Invalid parameter.');



  Result := Node;

  repeat

    Result := Result.PrevSibling;

  until not Assigned(Result) or ((vsVisible in Result.States) and

        (IncludeFiltered or not IsEffectivelyFiltered[Result]));

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.Nodes(ConsiderChildrenAbove: Boolean): TVTVirtualNodeEnumeration;



// Enumeration for all nodes



begin

  Result.FMode := vneAll;

  Result.FTree := Self;

  Result.FConsiderChildrenAbove := ConsiderChildrenAbove;

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.CheckedNodes(State: TCheckState; ConsiderChildrenAbove: Boolean): TVTVirtualNodeEnumeration;



// Enumeration for all checked nodes



begin

  Result.FMode := vneChecked;

  Result.FTree := Self;

  Result.FState := State;

  Result.FConsiderChildrenAbove := ConsiderChildrenAbove;

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.ChildNodes(Node: PVirtualNode): TVTVirtualNodeEnumeration;



// Enumeration for child nodes



begin

  Result.FMode := vneChild;

  Result.FTree := Self;

  Result.FNode := Node;

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.CutCopyNodes(ConsiderChildrenAbove: Boolean): TVTVirtualNodeEnumeration;



// Enumeration for cut copy node



begin

  Result.FMode := vneCutCopy;

  Result.FTree := Self;

  Result.FConsiderChildrenAbove := ConsiderChildrenAbove;

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.InitializedNodes(ConsiderChildrenAbove: Boolean): TVTVirtualNodeEnumeration;



// Enumeration for initialized nodes



begin

  Result.FMode := vneInitialized;

  Result.FTree := Self;

  Result.FConsiderChildrenAbove := ConsiderChildrenAbove;

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.LeafNodes: TVTVirtualNodeEnumeration;



// Enumeration for leaf nodes



begin

  Result.FMode := vneLeaf;

  Result.FTree := Self;

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.LevelNodes(NodeLevel: Cardinal): TVTVirtualNodeEnumeration;



// Enumeration for level nodes



begin

  Result.FMode := vneLevel;

  Result.FTree := Self;

  Result.FNodeLevel := NodeLevel;

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.NoInitNodes(ConsiderChildrenAbove: Boolean): TVTVirtualNodeEnumeration;



// Enumeration for no init nodes

begin

  Result.FMode := vneNoInit;

  Result.FTree := Self;

  Result.FConsiderChildrenAbove := ConsiderChildrenAbove;

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.SelectedNodes(ConsiderChildrenAbove: Boolean): TVTVirtualNodeEnumeration;



// Enumeration for selected nodes



begin

  Result.FMode := vneSelected;

  Result.FTree := Self;

  Result.FConsiderChildrenAbove := ConsiderChildrenAbove;

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.VisibleNodes(Node: PVirtualNode; ConsiderChildrenAbove: Boolean;

  IncludeFiltered: Boolean): TVTVirtualNodeEnumeration;



// Enumeration for visible nodes



begin

  Result.FMode := vneVisible;

  Result.FTree := Self;

  Result.FNode := Node;

  Result.FConsiderChildrenAbove := ConsiderChildrenAbove;

  Result.FIncludeFiltered := IncludeFiltered;

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.VisibleChildNodes(Node: PVirtualNode; IncludeFiltered: Boolean): TVTVirtualNodeEnumeration;



// Enumeration for visible child nodes



begin

  Result.FMode := vneVisibleChild;

  Result.FTree := Self;

  Result.FNode := Node;

  Result.FIncludeFiltered := IncludeFiltered;

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.VisibleChildNoInitNodes(Node: PVirtualNode; IncludeFiltered: Boolean): TVTVirtualNodeEnumeration;



// Enumeration for visible child no init nodes



begin

  Result.FMode := vneVisibleNoInitChild;

  Result.FTree := Self;

  Result.FNode := Node;

  Result.FIncludeFiltered := IncludeFiltered;

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.VisibleNoInitNodes(Node: PVirtualNode; ConsiderChildrenAbove: Boolean;

  IncludeFiltered: Boolean): TVTVirtualNodeEnumeration;



// Enumeration for visible no init nodes



begin

  Result.FMode := vneVisibleNoInit;

  Result.FTree := Self;

  Result.FNode := Node;

  Result.FConsiderChildrenAbove := ConsiderChildrenAbove;

  Result.FIncludeFiltered := IncludeFiltered;

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.GetSortedCutCopySet(Resolve: Boolean): TNodeArray;



// Same as GetSortedSelection but with nodes marked as being part in the current cut/copy set (e.g. for clipboard).



var

  Run: PVirtualNode;

  Counter: Cardinal;



  //--------------- local function --------------------------------------------



  procedure IncludeThisNode(Node: PVirtualNode);



  // adds the given node to the result



  var

    Len: Cardinal;



  begin

    Len := Length(Result);

    if Counter = Len then

    begin

      if Len < 100 then

        Len := 100

      else

        Len := Len + Len div 10;

      SetLength(Result, Len);

    end;

    Result[Counter] := Node;

    Inc(Counter);

  end;



  //--------------- end local function ----------------------------------------



begin

  Run := FRoot.FirstChild;

  Counter := 0;

  if Resolve then

  begin

    // Resolving is actually easy: just find the first cutted node in logical order

    // and then never go deeper in level than this node as long as there's a sibling node.

    // Restart the search for a cutted node (at any level) if there are no further siblings.

    while Assigned(Run) do

    begin

      if vsCutOrCopy in Run.States then

      begin

        IncludeThisNode(Run);

        if Assigned(Run.NextSibling) then

          Run := Run.NextSibling

        else

        begin

          // If there are no further siblings then go up one or more levels until a node is

          // found or all nodes have been processed. Although we consider here only initialized

          // nodes we don't need to make any special checks as only initialized nodes can also be selected.

          repeat

            Run := Run.Parent;

          until (Run = FRoot) or Assigned(Run.NextSibling);

          if Run = FRoot then

            Break

          else

            Run := Run.NextSibling;

        end;

      end

      else

        Run := GetNextNoInit(Run);

    end;

  end

  else

    while Assigned(Run) do

    begin

      if vsCutOrCopy in Run.States then

        IncludeThisNode(Run);

      Run := GetNextNoInit(Run);

    end;



  // set the resulting array to its real length

  SetLength(Result, Counter);

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.GetSortedSelection(Resolve: Boolean): TNodeArray;



// Returns a list of selected nodes sorted in logical order, that is, as they appear in the tree.

// If Resolve is True then nodes which are children of other selected nodes are not put into the new array.

// This feature is in particuar important when doing drag'n drop as in this case all selected node plus their children

// need to be considered. A selected node which is child (grand child etc.) of another selected node is then

// automatically included and doesn't need to be explicitely mentioned in the returned selection array.

//

// Note: The caller is responsible for freeing the array. Allocation is done here. Usually, though, freeing the array

//       doesn't need additional attention as it is automatically freed by Delphi when it gets out of scope.



var

  Run: PVirtualNode;

  Counter: Cardinal;



begin

  SetLength(Result, FSelectionCount);

  if FSelectionCount > 0 then

  begin

    Run := FRoot.FirstChild;

    Counter := 0;

    if Resolve then

    begin

      // Resolving is actually easy: just find the first selected node in logical order

      // and then never go deeper in level than this node as long as there's a sibling node.

      // Restart the search for a selected node (at any level) if there are no further siblings.

      while Assigned(Run) do

      begin

        if vsSelected in Run.States then

        begin

          Result[Counter] := Run;

          Inc(Counter);

          if Assigned(Run.NextSibling) then

            Run := Run.NextSibling

          else

          begin

            // If there are no further siblings then go up one or more levels until a node is

            // found or all nodes have been processed. Although we consider here only initialized

            // nodes we don't need to make any special checks as only initialized nodes can also be selected.

            repeat

              Run := Run.Parent;

            until (Run = FRoot) or Assigned(Run.NextSibling);

            if Run = FRoot then

              Break

            else

              Run := Run.NextSibling;

          end;

        end

        else

          Run := GetNextNoInit(Run);

      end;

    end

    else

      while Assigned(Run) do

      begin

        if vsSelected in Run.States then

        begin

          Result[Counter] := Run;

          Inc(Counter);

        end;

        Run := GetNextNoInit(Run);

      end;



    // Since we may have skipped some nodes the result array is likely to be smaller than the

    // selection array, hence shorten the result to true length.

    if Integer(Counter) < Length(Result) then

      SetLength(Result, Counter);

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.GetTextInfo(Node: PVirtualNode; Column: TColumnIndex; const AFont: TFont; var R: TRect;

  var Text: UnicodeString);



// Generic base method for editors, hint windows etc. to get some info about a node.



begin

  R := Rect(0, 0, 0, 0);

  Text := '';

  AFont.Assign(Font);

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.GetTreeRect: TRect;



// Returns the true size of the tree in pixels. This size is at least ClientHeight x ClientWidth and depends on

// the expand state, header size etc.

// Note: if no columns are used then the width of the tree is determined by the largest node which is currently in the

//       client area. This might however not be the largest node in the entire tree.



begin

  Result := Rect(0, 0, Max(FRangeX, ClientWidth), Max(FRangeY, ClientHeight));

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.GetVisibleParent(Node: PVirtualNode; IncludeFiltered: Boolean = False): PVirtualNode;



// Returns the first (nearest) parent node of Node which is visible.

// This method is one of the seldom cases where the hidden root node could be returned.



begin

  Assert(Assigned(Node), 'Node must not be nil.');

  Assert(Node <> FRoot, 'Node must not be the hidden root node.');



  Result := Node.Parent;

  while (Result <> FRoot) and (not FullyVisible[Result] or (not IncludeFiltered and IsEffectivelyFiltered[Result])) do

    Result := Result.Parent;

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.HasAsParent(Node, PotentialParent: PVirtualNode): Boolean;



// Determines whether Node has got PotentialParent as one of its parents.



var

  Run: PVirtualNode;



begin

  Result := Assigned(Node) and Assigned(PotentialParent) and (Node <> PotentialParent);

  if Result then

  begin

    Run := Node;

    while (Run <> FRoot) and (Run <> PotentialParent) do

      Run := Run.Parent;

    Result := Run = PotentialParent;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.InsertNode(Node: PVirtualNode; Mode: TVTNodeAttachMode; UserData: Pointer = nil): PVirtualNode;



// Adds a new node relative to Node. The final position is determined by Mode.

// UserData can be used to set the first SizeOf(Pointer) bytes of the user data area to an initial value which can be used

// in OnInitNode and will also cause to trigger the OnFreeNode event (if <> nil) even if the node is not yet

// "officially" initialized.

// InsertNode is a compatibility method and will implicitly validate the given node if the new node

// is to be added as child node. This is however against the virtual paradigm and hence I dissuade from its usage.



var

  NodeData: ^Pointer;



begin

  if Mode <> amNoWhere then

  begin

    CancelEditNode;



    if Node = nil then

      Node := FRoot;

    // we need a new node...

    Result := MakeNewNode;

    // avoid erronous attach modes

    if Node = FRoot then

    begin

      case Mode of

        amInsertBefore:

          Mode := amAddChildFirst;

        amInsertAfter:

          Mode := amAddChildLast;

      end;

    end;



    // Validate given node in case the new node becomes its child.

    if (Mode in [amAddChildFirst, amAddChildLast]) and not (vsInitialized in Node.States) then

      InitNode(Node);

    InternalConnectNode(Result, Node, Self, Mode);



    // Check if there is initial user data and there is also enough user data space allocated.

    if Assigned(UserData) then

      if FNodeDataSize >= SizeOf(Pointer) then

      begin

        NodeData := Pointer(PByte(@Result.Data) + FTotalInternalDataSize);

        NodeData^ := UserData;

        Include(Result.States, vsOnFreeNodeCallRequired);

      end

      else

        ShowError(SCannotSetUserData, hcTFCannotSetUserData);



    if FUpdateCount = 0 then

    begin

      // If auto sort is enabled then sort the node or its parent (depending on the insert mode).

      if (toAutoSort in FOptions.FAutoOptions) and (FHeader.FSortColumn > InvalidColumn) then

        case Mode of

          amInsertBefore,

          amInsertAfter:

            // Here no initialization is necessary because *if* a node has already got children then it

            // must also be initialized.

            // Note: Node can never be FRoot at this point.

            Sort(Node.Parent, FHeader.FSortColumn, FHeader.FSortDirection, True);

          amAddChildFirst,

          amAddChildLast:

            Sort(Node, FHeader.FSortColumn, FHeader.FSortDirection, True);

        end;



      UpdateScrollBars(True);

      if Mode = amInsertBefore then

        InvalidateToBottom(Result)

      else

        InvalidateToBottom(Node);

    end;

    StructureChange(Result, crNodeAdded);

  end

  else

    Result := nil;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.InvalidateChildren(Node: PVirtualNode; Recursive: Boolean);



// Invalidates Node and its immediate children.

// If Recursive is True then all grandchildren are invalidated as well.

// The node itself is initialized if necessary and its child nodes are created (and initialized too if

// Recursive is True).



var

  Run: PVirtualNode;



begin

  if Assigned(Node) then

  begin

    if not (vsInitialized in Node.States) then

      InitNode(Node);

    InvalidateNode(Node);

    if (vsHasChildren in Node.States) and (Node.ChildCount = 0) then

      InitChildren(Node);

    Run := Node.FirstChild;

  end

  else

    Run := FRoot.FirstChild;



  while Assigned(Run) do

  begin

    InvalidateNode(Run);

    if Recursive then

      InvalidateChildren(Run, True);

    Run := Run.NextSibling;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.InvalidateColumn(Column: TColumnIndex);



// Invalidates the client area part of a column.



var

  R: TRect;



begin

  if (FUpdateCount = 0) and HandleAllocated and FHeader.FColumns.IsValidColumn(Column) then

  begin

    R := ClientRect;

    FHeader.Columns.GetColumnBounds(Column, R.Left, R.Right);

    InvalidateRect(Handle, @R, False);

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.InvalidateNode(Node: PVirtualNode): TRect;



// Initiates repaint of the given node and returns the just invalidated rectangle.



begin

  if (FUpdateCount = 0) and HandleAllocated then

  begin

    Result := GetDisplayRect(Node, NoColumn, False);

    InvalidateRect(Handle, @Result, False);

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.InvalidateToBottom(Node: PVirtualNode);



// Initiates repaint of client area starting at given node. If this node is not visible or not yet initialized

// then nothing happens.



var

  R: TRect;



begin

  if (FUpdateCount = 0) and HandleAllocated then

  begin

    if (Node = nil) or (Node = FRoot) then

      Invalidate

    else

      if (vsInitialized in Node.States) and IsEffectivelyVisible[Node] then

      begin

        R := GetDisplayRect(Node, -1, False);

        if R.Top < ClientHeight then

        begin

          if (toChildrenAbove in FOptions.FPaintOptions) and (vsExpanded in Node.States) then

            Dec(R.Top, Node.TotalHeight + NodeHeight[Node]);

          R.Bottom := ClientHeight;

          InvalidateRect(Handle, @R, False);

        end;

      end;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.InvertSelection(VisibleOnly: Boolean);



// Inverts the current selection (so nodes which are selected become unselected and vice versa).

// If VisibleOnly is True then only visible nodes are considered.



var

  Run: PVirtualNode;

  NewSize: Integer;

  NextFunction: TGetNextNodeProc;

  TriggerChange: Boolean;



begin

  if not FSelectionLocked and (toMultiSelect in FOptions.FSelectionOptions) then

  begin

    Run := FRoot.FirstChild;

    ClearTempCache;

    if VisibleOnly then

      NextFunction := GetNextVisibleNoInit

    else

      NextFunction := GetNextNoInit;

    while Assigned(Run) do

    begin

      if vsSelected in Run.States then

        InternalRemoveFromSelection(Run)

      else

        InternalCacheNode(Run);

      Run := NextFunction(Run);

    end;



    // do some housekeeping

    // Need to trigger the OnChange event from here if nodes were only deleted but not added.

    TriggerChange := False;

    NewSize := PackArray(FSelection, FSelectionCount);

    if NewSize > -1 then

    begin

      FSelectionCount := NewSize;

      SetLength(FSelection, FSelectionCount);

      TriggerChange := True;

    end;

    if FTempNodeCount > 0 then

    begin

      AddToSelection(FTempNodeCache, FTempNodeCount);

      ClearTempCache;

      TriggerChange := False;

    end;

    Invalidate;

    if TriggerChange then

      Change(nil);

    if Self.SelectedCount = 0 then

      FNextNodeToSelect := nil;//Ensure that no other node is selected now

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.IsEditing: Boolean;



begin

  Result := tsEditing in FStates;

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.IsMouseSelecting: Boolean;



begin

  Result := (tsDrawSelPending in FStates) or (tsDrawSelecting in FStates);

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.IterateSubtree(Node: PVirtualNode; Callback: TVTGetNodeProc; Data: Pointer;

  Filter: TVirtualNodeStates = []; DoInit: Boolean = False; ChildNodesOnly: Boolean = False): PVirtualNode;



// Iterates through the all children and grandchildren etc. of Node (or the entire tree if Node = nil)

// and calls for each node the provided callback method (which must not be empty).

// Filter determines which nodes to consider (an empty set denotes all nodes).

// If DoInit is True then nodes which aren't initialized yet will be initialized.

// Note: During execution of the callback the application can set Abort to True. In this case the iteration is stopped

//       and the last accessed node (the one on which the callback set Abort to True) is returned to the caller.

//       Otherwise (no abort) nil is returned.



var

  Stop: PVirtualNode;

  Abort: Boolean;

  GetNextNode: TGetNextNodeProc;

  WasIterating: Boolean;



begin

  Assert(Node <> FRoot, 'Node must not be the hidden root node.');



  WasIterating := tsIterating in FStates;

  DoStateChange([tsIterating]);

  try

    // prepare function to be used when advancing

    if DoInit then

      GetNextNode := GetNext

    else

      GetNextNode := GetNextNoInit;



    Abort := False;

    if Node = nil then

      Stop := nil

    else

    begin

      if not (vsInitialized in Node.States) and DoInit then

        InitNode(Node);



      // The stopper does not need to be initialized since it is not taken into the enumeration.

      Stop := Node.NextSibling;

      if Stop = nil then

      begin

        Stop := Node;

        repeat

          Stop := Stop.Parent;

        until (Stop = FRoot) or Assigned(Stop.NextSibling);

        if Stop = FRoot then

          Stop := nil

        else

          Stop := Stop.NextSibling;

      end;

    end;



    // Use first node if we start with the root.

    if Node = nil then

      Node := GetFirstNoInit;



    if Assigned(Node) then

    begin

      if not (vsInitialized in Node.States) and DoInit then

        InitNode(Node);



      // Skip given node if only the child nodes are requested.

      if ChildNodesOnly then

      begin

        if Node.ChildCount = 0 then

          Node := nil

        else

          Node := GetNextNode(Node);

      end;



      if Filter = [] then

      begin

        // unfiltered loop

        while Assigned(Node) and (Node <> Stop) do

        begin

          Callback(Self, Node, Data, Abort);

          if Abort then

            Break;

          Node := GetNextNode(Node);

        end;

      end

      else

      begin

        // filtered loop

        while Assigned(Node) and (Node <> Stop) do

        begin

          if Node.States * Filter = Filter then

            Callback(Self, Node, Data, Abort);

          if Abort then

            Break;

          Node := GetNextNode(Node);

        end;

      end;

    end;



    if Abort then

      Result := Node

    else

      Result := nil;

  finally

    if not WasIterating then

      DoStateChange([], [tsIterating]);

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.LoadFromFile(const FileName: TFileName);



var

  FileStream: TFileStream;



begin

  FileStream := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);

  try

    LoadFromStream(FileStream);

  finally

    FileStream.Free;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.LoadFromStream(Stream: TStream);



// Clears the current content of the tree and loads a new structure from the given stream.



var

  ThisID: TMagicID;

  Version,

  Count: Cardinal;

  Node: PVirtualNode;



begin

  if not (toReadOnly in FOptions.FMiscOptions) then

  begin

    Clear;

    // Check first whether this is a stream we can read.

    if Stream.Read(ThisID, SizeOf(TMagicID)) < SizeOf(TMagicID) then

      ShowError(SStreamTooSmall, hcTFStreamTooSmall);



    if (ThisID[0] = MagicID[0]) and

       (ThisID[1] = MagicID[1]) and

       (ThisID[2] = MagicID[2]) and

       (ThisID[5] = MagicID[5]) then

    begin

      Version := Word(ThisID[3]);

      if Version <= VTTreeStreamVersion then

      begin

        BeginUpdate;

        try

          if Version < 2 then

            Count := MaxInt

          else

            Stream.ReadBuffer(Count, SizeOf(Count));



          while (Stream.Position < Stream.Size) and (Count > 0) do

          begin

            Dec(Count);

            Node := MakeNewNode;

            InternalConnectNode(Node, FRoot, Self, amAddChildLast);

            InternalAddFromStream(Stream, Version, Node);

          end;

          DoNodeCopied(nil);

          if Assigned(FOnLoadTree) then

            FOnLoadTree(Self, Stream);

        finally

          EndUpdate;

        end;

      end

      else

        ShowError(SWrongStreamVersion, hcTFWrongStreamVersion);

    end

    else

      ShowError(SWrongStreamFormat, hcTFWrongStreamFormat);

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.MeasureItemHeight(const Canvas: TCanvas; Node: PVirtualNode);



// If the height of the given node has not yet been measured then do it now.



var

  NewNodeHeight: Integer;



begin

  if not (vsHeightMeasured in Node.States) {$if CompilerVersion < 20}and (MainThreadId = GetCurrentThreadId){$ifend} then

  begin

    Include(Node.States, vsHeightMeasured);

    if (toVariableNodeHeight in FOptions.FMiscOptions) then

    begin

      NewNodeHeight := Node.NodeHeight;

      {$if CompilerVersion >= 20} // Anonymous methods help to make this thread safe easily. In Delphi 2007 and lower developers must take care themselves about thread synchronization when consuming the OnMeasureItemHeight event

      if (MainThreadId <> GetCurrentThreadId) then

        TThread.Synchronize(nil,

          procedure

          begin

            DoMeasureItem(Canvas, Node, NewNodeHeight);

            SetNodeHeight(Node, NewNodeHeight);

          end

        )

      else

      {$ifend}

      begin

        DoMeasureItem(Canvas, Node, NewNodeHeight);

        SetNodeHeight(Node, NewNodeHeight);

      end;

    end;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.MoveTo(Node: PVirtualNode; Tree: TBaseVirtualTree; Mode: TVTNodeAttachMode;

  ChildrenOnly: Boolean);



// A simplified method to allow to move nodes to the root of another tree.



begin

  MoveTo(Node, Tree.FRoot, Mode, ChildrenOnly);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.MoveTo(Source, Target: PVirtualNode; Mode: TVTNodeAttachMode; ChildrenOnly: Boolean);



// Moves the given node (and all its children) to Target. Source must belong to the tree instance which calls this

// MoveTo method. Mode determines how to connect Source to Target.

// This method might involve a change of the tree if Target belongs to a different tree than Source.



var

  TargetTree: TBaseVirtualTree;

  Allowed: Boolean;

  NewNode: PVirtualNode;

  Stream: TMemoryStream;



begin

  Assert(TreeFromNode(Source) = Self, 'The source tree must contain the source node.');



  // When moving nodes then source and target must not be the same node unless only the source's children are

  // moved and they are inserted before or after the node itself.

  Allowed := (Source <> Target) or ((Mode in [amInsertBefore, amInsertAfter]) and ChildrenOnly);



  if Allowed and (Mode <> amNoWhere) and Assigned(Source) and (Source <> FRoot) and

    not (toReadOnly in FOptions.FMiscOptions) then

  begin

    // Assume that an empty destination means the root in this (the source) tree.

    if Target = nil then

    begin

      TargetTree := Self;

      Target := FRoot;

      Mode := amAddChildFirst;

    end

    else

      TargetTree := TreeFromNode(Target);



    if Target = TargetTree.FRoot then

    begin

      case Mode of

        amInsertBefore:

          Mode := amAddChildFirst;

        amInsertAfter:

          Mode := amAddChildLast;

      end;

    end;



    // Make sure the target node is initialized.

    if not (vsInitialized in Target.States) then

      TargetTree.InitNode(Target)

    else

      if (vsHasChildren in Target.States) and (Target.ChildCount = 0) then

        TargetTree.InitChildren(Target);



    if TargetTree = Self then

    begin

      // Simple case: move node(s) within the same tree.

      if Target = FRoot then

        Allowed := DoNodeMoving(Source, nil)

      else

        Allowed := DoNodeMoving(Source, Target);

      if Allowed then

      begin

        // Check first that Source is not added as new child to a target node which

        // is already a child of Source.

        // Consider the case Source and Target are the same node, but only child nodes are moved.

        if (Source <> Target) and HasAsParent(Target, Source) then

            ShowError(SWrongMoveError, hcTFWrongMoveError);



        if not ChildrenOnly then

        begin

          // Disconnect from old location.

          InternalDisconnectNode(Source, True);

          // Connect to new location.

          InternalConnectNode(Source, Target, Self, Mode);

          DoNodeMoved(Source);

        end

        else

        begin

          // Only child nodes should be moved. Insertion order depends on move mode.

          if Mode = amAddChildFirst then

          begin

            Source := Source.LastChild;

            while Assigned(Source) do

            begin

              NewNode := Source.PrevSibling;

              // Disconnect from old location.

              InternalDisconnectNode(Source, True, False);

              // Connect to new location.

              InternalConnectNode(Source, Target, Self, Mode);

              DoNodeMoved(Source);

              Source := NewNode;

            end;

          end

          else

          begin

            Source := Source.FirstChild;

            while Assigned(Source) do

            begin

              NewNode := Source.NextSibling;

              // Disconnect from old location.

              InternalDisconnectNode(Source, True, False);

              // Connect to new location.

              InternalConnectNode(Source, Target, Self, Mode);

              DoNodeMoved(Source);

              Source := NewNode;

            end;

          end;

        end;

      end;

    end

    else

    begin

      // Difficult case: move node(s) to another tree.

      // In opposition to node copying we ask only once if moving is allowed because

      // we cannot take back a move once done.

      if Target = TargetTree.FRoot then

        Allowed := DoNodeMoving(Source, nil)

      else

        Allowed := DoNodeMoving(Source, Target);



      if Allowed then

      begin

        Stream := TMemoryStream.Create;

        try

          // Write all nodes into a temporary stream depending on the ChildrenOnly flag.

          if not ChildrenOnly then

            WriteNode(Stream, Source)

          else

          begin

            Source := Source.FirstChild;

            while Assigned(Source) do

            begin

              WriteNode(Stream, Source);

              Source := Source.NextSibling;

            end;

          end;

          // Now load the serialized nodes into the target node (tree).

          TargetTree.BeginUpdate;

          try

            Stream.Position := 0;

            while Stream.Position < Stream.Size do

            begin

              NewNode := TargetTree.MakeNewNode;

              InternalConnectNode(NewNode, Target, TargetTree, Mode);

              TargetTree.InternalAddFromStream(Stream, VTTreeStreamVersion, NewNode);

              DoNodeMoved(NewNode);

            end;

          finally

            TargetTree.EndUpdate;

          end;

        finally

          Stream.Free;

        end;

        // finally delete original nodes

        BeginUpdate;

        try

          if ChildrenOnly then

            DeleteChildren(Source)

          else

            DeleteNode(Source);

        finally

          EndUpdate;

        end;

      end;

    end;



    InvalidateCache;

    if (FUpdateCount = 0) and Allowed then

    begin

      ValidateCache;

      UpdateScrollBars(True);

      Invalidate;

      if TargetTree <> Self then

        TargetTree.Invalidate;

    end;

    StructureChange(Source, crNodeMoved);

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.PaintTree(TargetCanvas: TCanvas; Window: TRect; Target: TPoint;

  PaintOptions: TVTInternalPaintOptions; PixelFormat: TPixelFormat);



// This is the core paint routine of the tree. It is responsible for maintaining the paint cycles per node as well

// as coordinating drawing of the various parts of the tree image.

// TargetCanvas is the canvas to which to draw the tree image. This is usually the tree window itself but could well

// be a bitmap or printer canvas.

// Window determines which part of the entire tree image to draw. The full size of the virtual image is determined

// by GetTreeRect.

// Target is the position in TargetCanvas where to draw the tree part specified by Window.

// PaintOptions determines what of the tree to draw. For different tasks usually different parts need to be drawn, with

// a full image in the window, selected only nodes for a drag image etc.



const

  ImageKind: array[Boolean] of TVTImageKind = (ikNormal, ikSelected);



var

  DrawSelectionRect,

  UseBackground,

  ShowImages,

  ShowStateImages,

  ShowCheckImages,

  UseColumns,

  IsMainColumn: Boolean;



  VAlign,

  IndentSize,

  ButtonX,

  ButtonY: Integer;

  LineImage: TLineImage;

  PaintInfo: TVTPaintInfo;     // all necessary information about a node to pass to the paint routines



  R,                           // the area of an entire node in its local coordinate

  TargetRect,                  // the area of a node (part) in the target canvas

  SelectionRect,               // ordered rectangle used for drawing the selection focus rect

  ClipRect: TRect;             // area to which the canvas will be clipped when painting a node's content

  NextColumn: TColumnIndex;

  BaseOffset: Integer;         // top position of the top node to draw given in absolute tree coordinates

  NodeBitmap: TBitmap;         // small buffer to draw flicker free

  MaximumRight,                // maximum horizontal target position

  MaximumBottom: Integer;      // maximum vertical target position

  SelectLevel: Integer;        // > 0 if current node is selected or child/grandchild etc. of a selected node

  FirstColumn: TColumnIndex;   // index of first column which is at least partially visible in the given window



  MaxRight,

  ColLeft,

  ColRight: Integer;



  SavedTargetDC: Integer;

  PaintWidth: Integer;

  CurrentNodeHeight: Integer;

  lUseSelectedBkColor: Boolean; // determines if the dotted grid lines need to be painted in selection color of background color



  CellIsTouchingClientRight: Boolean;

  CellIsInLastColumn: Boolean;

  ColumnIsFixed: Boolean;



begin

  if not (tsPainting in FStates) then

  begin

    DoStateChange([tsPainting]);

    try

      DoBeforePaint(TargetCanvas);



      if poUnbuffered in PaintOptions then

        SavedTargetDC := SaveDC(TargetCanvas.Handle)

      else

        SavedTargetDC := 0;



      // Prepare paint info structure.

      ZeroMemory(@PaintInfo, SizeOf(PaintInfo));



      PaintWidth := Window.Right - Window.Left;



      if not (poUnbuffered in PaintOptions) then

      begin

        // Create small bitmaps and initialize default values.

        // The bitmaps are used to paint one node at a time and to draw the result to the target (e.g. screen) in one step,

        // to prevent flickering.

        NodeBitmap := TBitmap.Create;

        // For alpha blending we need the 32 bit pixel format. For other targets there might be a need for a certain

        // pixel format (e.g. printing).

        if MMXAvailable and ((FDrawSelectionMode = smBlendedRectangle) or (tsUseThemes in FStates) or

          (toUseBlendedSelection in FOptions.PaintOptions)) then

          NodeBitmap.PixelFormat := pf32Bit

        else

          NodeBitmap.PixelFormat := PixelFormat;



        NodeBitmap.Width := PaintWidth;



        // Make sure the buffer bitmap and target bitmap use the same transformation mode.

        SetMapMode(NodeBitmap.Canvas.Handle, GetMapMode(TargetCanvas.Handle));

        PaintInfo.Canvas := NodeBitmap.Canvas;

      end

      else

      begin

        PaintInfo.Canvas := TargetCanvas;

        NodeBitmap := nil;

      end;



      // Lock the canvas to avoid that it gets freed on the way.

      PaintInfo.Canvas.Lock;

      try

        // Prepare the current selection rectangle once. The corner points are absolute tree coordinates.

        SelectionRect := OrderRect(FNewSelRect);

        DrawSelectionRect := IsMouseSelecting and not IsRectEmpty(SelectionRect) and (GetKeyState(VK_LBUTTON) < 0);



        // R represents an entire node (all columns), but is a bit unprecise when it comes to

        // trees without any column defined, because FRangeX only represents the maximum width of all

        // nodes in the client area (not all defined nodes). There might be, however, wider nodes somewhere. Without full

        // validation I cannot better determine the width, though. By using at least the control's width it is ensured

        // that the tree is fully displayed on screen.

        R := Rect(0, 0, Max(FRangeX, ClientWidth), 0);



        // For quick checks some intermediate variables are used.

        UseBackground := (toShowBackground in FOptions.FPaintOptions) and (FBackground.Graphic is TBitmap) and

          (poBackground in PaintOptions);

        ShowImages := Assigned(FImages);

        ShowStateImages := Assigned(FStateImages);

        ShowCheckImages := Assigned(FCheckImages) and (toCheckSupport in FOptions.FMiscOptions);

        UseColumns := FHeader.UseColumns;



        // Adjust paint options to tree settings. Hide selection if told so or the tree is unfocused.

        if (toAlwaysHideSelection in FOptions.FPaintOptions) or

          (not Focused and (toHideSelection in FOptions.FPaintOptions)) then

          Exclude(PaintOptions, poDrawSelection);

        if toHideFocusRect in FOptions.FPaintOptions then

          Exclude(PaintOptions, poDrawFocusRect);



        // Determine node to start drawing with.

        BaseOffset := 0;

        PaintInfo.Node := GetNodeAt(0, Window.Top, False, BaseOffset);

        if PaintInfo.Node = nil then

          BaseOffset := Window.Top;



        // Transform selection rectangle into node bitmap coordinates.

        if DrawSelectionRect then

          OffsetRect(SelectionRect, 0, -BaseOffset);



        // The target rectangle holds the coordinates of the exact area to blit in target canvas coordinates.

        // It is usually smaller than an entire node and wanders while the paint loop advances.

        MaximumRight := Target.X + (Window.Right - Window.Left);

        MaximumBottom := Target.Y + (Window.Bottom - Window.Top);



        TargetRect := Rect(Target.X, Target.Y - (Window.Top - BaseOffset), MaximumRight, 0);

        TargetRect.Bottom := TargetRect.Top;

        TargetCanvas.Font := Self.Font;



        // This marker gets the index of the first column which is visible in the given window.

        // This is needed for column based background colors.

        FirstColumn := InvalidColumn;



        if Assigned(PaintInfo.Node) then

        begin

          ButtonX := Round((Integer(FIndent) - FPlusBM.Width) / 2) + 1;



          // ----- main node paint loop

          while Assigned(PaintInfo.Node) do

          begin

            // Determine LineImage, SelectionLevel and IndentSize

            SelectLevel := DetermineLineImageAndSelectLevel(PaintInfo.Node, LineImage);

            IndentSize := Length(LineImage);

            if not (toFixedIndent in FOptions.FPaintOptions) then

              ButtonX := (IndentSize - 1) * Integer(FIndent) + Round((Integer(FIndent) - FPlusBM.Width) / 2) + 1;



            // Initialize node if not already done.

            if not (vsInitialized in PaintInfo.Node.States) then

              InitNode(PaintInfo.Node);

            if (vsSelected in PaintInfo.Node.States) and not (toChildrenAbove in FOptions.FPaintOptions) then

              Inc(SelectLevel);



            // Ensure the node's height is determined.

            MeasureItemHeight(PaintInfo.Canvas, PaintInfo.Node);



            // Adjust the brush origin for dotted lines depending on the current source position.

            // It is applied some lines later, as the canvas might get reallocated, when changing the node bitmap.

            PaintInfo.BrushOrigin := Point(Window.Left and 1, BaseOffset and 1);

            Inc(BaseOffset, PaintInfo.Node.NodeHeight);



            TargetRect.Bottom := TargetRect.Top + PaintInfo.Node.NodeHeight;



            // If poSelectedOnly is active then do the following stuff only for selected nodes or nodes

            // which are children of selected nodes.

            if (SelectLevel > 0) or not (poSelectedOnly in PaintOptions) then

            begin

              if not (poUnbuffered in PaintOptions) then

              begin

                // Adjust height of temporary node bitmap.

                with NodeBitmap do

                begin

                  if Height <> PaintInfo.Node.NodeHeight then

                  begin

                    // Avoid that the VCL copies the bitmap while changing its height.

                    Height := 0;

                    Height := PaintInfo.Node.NodeHeight;

                    SetCanvasOrigin(Canvas, Window.Left, 0);

                  end;

                end;

              end

              else

              begin

                SetCanvasOrigin(PaintInfo.Canvas, -TargetRect.Left + Window.Left, -TargetRect.Top);

                ClipCanvas(PaintInfo.Canvas, Rect(TargetRect.Left, TargetRect.Top, TargetRect.Right,

                                                  Min(TargetRect.Bottom, MaximumBottom)));

              end;



              // Set the origin of the canvas' brush. This depends on the node heights.

              with PaintInfo do

                SetBrushOrigin(Canvas, BrushOrigin.X, BrushOrigin.Y);



              CurrentNodeHeight := PaintInfo.Node.NodeHeight;

              R.Bottom := CurrentNodeHeight;

              

              CalculateVerticalAlignments(ShowImages, ShowStateImages, PaintInfo.Node, VAlign, ButtonY);



              // Let application decide whether the node should normally be drawn or by the application itself.

              if not DoBeforeItemPaint(PaintInfo.Canvas, PaintInfo.Node, R) then

              begin

                // Init paint options for the background painting.

                PaintInfo.PaintOptions := PaintOptions;



                // The node background can contain a single color, a bitmap or can be drawn by the application.

                ClearNodeBackground(PaintInfo, UseBackground, True, Rect(Window.Left, TargetRect.Top, Window.Right,

                  TargetRect.Bottom));



                // Prepare column, position and node clipping rectangle.

                PaintInfo.CellRect := R;

                if UseColumns then

                  InitializeFirstColumnValues(PaintInfo);



                // Now go through all visible columns (there's still one run if columns aren't used).

                with FHeader.FColumns do

                begin

                  while ((PaintInfo.Column > InvalidColumn) or not UseColumns)

                    and (PaintInfo.CellRect.Left < Window.Right) do

                  begin

                    if UseColumns then

                    begin

                      PaintInfo.Column := FPositionToIndex[PaintInfo.Position];

                      if FirstColumn = InvalidColumn then

                        FirstColumn := PaintInfo.Column;

                      PaintInfo.BidiMode := Items[PaintInfo.Column].FBiDiMode;

                      PaintInfo.Alignment := Items[PaintInfo.Column].FAlignment;

                    end

                    else

                    begin

                      PaintInfo.Column := NoColumn;

                      PaintInfo.BidiMode := BidiMode;

                      PaintInfo.Alignment := FAlignment;

                    end;



                    PaintInfo.PaintOptions := PaintOptions;

                    with PaintInfo do

                    begin

                      if (tsEditing in FStates) and (Node = FFocusedNode) and

                        ((Column = FEditColumn) or not UseColumns) then

                        Exclude(PaintOptions, poDrawSelection);

                      if not UseColumns or

                        ((vsSelected in Node.States) and (toFullRowSelect in FOptions.FSelectionOptions) and

                         (poDrawSelection in PaintOptions)) or

                        (coParentColor in Items[PaintInfo.Column].Options) then

                        Exclude(PaintOptions, poColumnColor);

                    end;

                    IsMainColumn := PaintInfo.Column = FHeader.MainColumn;



                    // Consider bidi mode here. In RTL context means left alignment actually right alignment and vice versa.

                    if PaintInfo.BidiMode <> bdLeftToRight then

                      ChangeBiDiModeAlignment(PaintInfo.Alignment);



                    // Paint the current cell if it is marked as being visible or columns aren't used and

                    // if this cell belongs to the main column if only the main column should be drawn.

                    if (not UseColumns or (coVisible in Items[PaintInfo.Column].FOptions)) and

                      (not (poMainOnly in PaintOptions) or IsMainColumn) then

                    begin

                      AdjustPaintCellRect(PaintInfo, NextColumn);



                      // Paint the cell only if it is in the current window.

                      if PaintInfo.CellRect.Right > Window.Left then

                      begin

                        with PaintInfo do

                        begin

                          // Fill in remaining values in the paint info structure.

                          NodeWidth := DoGetNodeWidth(Node, Column, Canvas);

                          // Not the entire cell is covered by text. Hence we need a running rectangle to follow up.

                          ContentRect := CellRect;

                          // Set up the distance from column border (margin).

                          if BidiMode <> bdLeftToRight then

                            Dec(ContentRect.Right, FMargin)

                          else

                            Inc(ContentRect.Left, FMargin);



                          if ShowCheckImages and IsMainColumn then

                          begin

                            ImageInfo[iiCheck].Index := GetCheckImage(Node);

                            if ImageInfo[iiCheck].Index > -1 then

                            begin

                              AdjustImageBorder(FCheckImages, BidiMode, VAlign, ContentRect, ImageInfo[iiCheck]);

                              ImageInfo[iiCheck].Ghosted := False;

                            end;

                          end

                          else

                            ImageInfo[iiCheck].Index := -1;

                          if ShowStateImages then

                          begin

                            GetImageIndex(PaintInfo, ikState, iiState, FStateImages);

                            if ImageInfo[iiState].Index > -1 then

                              AdjustImageBorder(FStateImages, BidiMode, VAlign, ContentRect, ImageInfo[iiState]);

                          end

                          else

                            ImageInfo[iiState].Index := -1;

                          if ShowImages then

                          begin

                            GetImageIndex(PaintInfo, ImageKind[vsSelected in Node.States], iiNormal, FImages);

                            if ImageInfo[iiNormal].Index > -1 then

                              AdjustImageBorder(ImageInfo[iiNormal].Images, BidiMode, VAlign, ContentRect, ImageInfo[iiNormal]);

                          end

                          else

                            ImageInfo[iiNormal].Index := -1;



                          // Take the space for the tree lines into account.

                          if IsMainColumn then

                            AdjustCoordinatesByIndent(PaintInfo, IfThen(toFixedIndent in FOptions.FPaintOptions, 1, IndentSize));



                          if UseColumns then

                          begin

                            ClipRect := CellRect;

                            if poUnbuffered in PaintOptions then

                            begin

                              ClipRect.Left := Max(ClipRect.Left, Window.Left);

                              ClipRect.Right := Min(ClipRect.Right, Window.Right);

                              ClipRect.Top := Max(ClipRect.Top, Window.Top - (BaseOffset - CurrentNodeHeight));

                              ClipRect.Bottom := ClipRect.Bottom - Max(TargetRect.Bottom - MaximumBottom, 0);

                            end;

                            ClipCanvas(Canvas, ClipRect);

                          end;



                          // Paint the horizontal grid line.

                          if (poGridLines in PaintOptions) and (toShowHorzGridLines in FOptions.FPaintOptions) then

                          begin

                            Canvas.Font.Color := FColors.GridLineColor;

                            if IsMainColumn and (FLineMode = lmBands) then

                            begin

                              if BidiMode = bdLeftToRight then

                              begin

                                DrawDottedHLine(PaintInfo, CellRect.Left + IfThen(toFixedIndent in FOptions.FPaintOptions, 1, IndentSize) * Integer(FIndent), CellRect.Right - 1,

                                  CellRect.Bottom - 1);

                              end

                              else

                              begin

                                DrawDottedHLine(PaintInfo, CellRect.Left, CellRect.Right - IfThen(toFixedIndent in FOptions.FPaintOptions, 1, IndentSize) * Integer(FIndent) - 1,

                                  CellRect.Bottom - 1);

                              end;

                            end

                            else

                              DrawDottedHLine(PaintInfo, CellRect.Left, CellRect.Right, CellRect.Bottom - 1);



                            Dec(CellRect.Bottom);

                            Dec(ContentRect.Bottom);

                          end;



                          if UseColumns then

                          begin

                            // Paint vertical grid line.

                            if (poGridLines in PaintOptions) and (toShowVertGridLines in FOptions.FPaintOptions) then

                            begin

                              // These variables and the nested if conditions shall make the logic

                              // easier to understand.

                              CellIsTouchingClientRight := PaintInfo.CellRect.Right = Window.Right;

                              CellIsInLastColumn := Position = TColumnPosition(Count - 1);

                              ColumnIsFixed := coFixed in FHeader.FColumns[Column].Options;



                              // Don't draw if this is the last column and the header is in autosize mode.

                              if not ((hoAutoResize in FHeader.FOptions) and CellIsInLastColumn) then

                              begin

                                // We have to take spanned cells into account which we determine

                                // by checking if CellRect.Right equals the Window.Right.

                                // But since the PaintTree procedure is called twice in

                                // TBaseVirtualTree.Paint (i.e. for fixed columns and other columns.

                                // CellIsTouchingClientRight does not work for fixed columns.)

                                // we have to paint fixed column grid line anyway.

                                if not CellIsTouchingClientRight or ColumnIsFixed then

                                begin

                                  if (BidiMode = bdLeftToRight) or not ColumnIsEmpty(Node, Column) then

                                  begin

                                    Canvas.Font.Color := FColors.GridLineColor;

                                    lUseSelectedBkColor := (poDrawSelection in PaintOptions) and (toFullRowSelect in FOptions.FSelectionOptions) and

                                                          (vsSelected in Node.States) and not (toUseBlendedSelection in FOptions.PaintOptions) and not

                                                          (tsUseExplorerTheme in FStates);

                                    DrawDottedVLine(PaintInfo, CellRect.Top, CellRect.Bottom, CellRect.Right - 1, lUseSelectedBkColor);

                                  end;



                                  Dec(CellRect.Right);

                                  Dec(ContentRect.Right);

                                end;

                              end;

                            end;

                          end;



                          // Prepare background and focus rect for the current cell.

                          PrepareCell(PaintInfo, Window.Left, PaintWidth);



                          // Some parts are only drawn for the main column.

                          if IsMainColumn then

                          begin

                            if (toShowTreeLines in FOptions.FPaintOptions) and

                               (not (toHideTreeLinesIfThemed in FOptions.FPaintOptions) or

                                not (tsUseThemes in FStates)) then

                              PaintTreeLines(PaintInfo, VAlign, IfThen(toFixedIndent in FOptions.FPaintOptions, 1,

                                             IndentSize), LineImage);

                            // Show node button if allowed, if there child nodes and at least one of the child

                            // nodes is visible or auto button hiding is disabled.

                            if (toShowButtons in FOptions.FPaintOptions) and (vsHasChildren in Node.States) and

                              not ((vsAllChildrenHidden in Node.States) and

                              (toAutoHideButtons in TreeOptions.FAutoOptions)) then

                              PaintNodeButton(Canvas, Node, Column, CellRect, ButtonX, ButtonY, BidiMode);



                            if ImageInfo[iiCheck].Index > -1 then

                              PaintCheckImage(Canvas, PaintInfo.ImageInfo[iiCheck], vsSelected in PaintInfo.Node.States);

                          end;



                          if ImageInfo[iiState].Index > -1 then

                            PaintImage(PaintInfo, iiState, False);

                          if ImageInfo[iiNormal].Index > -1 then

                            PaintImage(PaintInfo, iiNormal, True);



                          // Now let descendants or applications draw whatever they want,

                          // but don't draw the node if it is currently being edited.

                          if not ((tsEditing in FStates) and (Node = FFocusedNode) and

                            ((Column = FEditColumn) or not UseColumns)) then

                            DoPaintNode(PaintInfo);



                          DoAfterCellPaint(Canvas, Node, Column, CellRect);

                        end;

                      end;



                      // leave after first run if columns aren't used

                      if not UseColumns then

                        Break;

                    end

                    else

                      NextColumn := GetNextVisibleColumn(PaintInfo.Column);



                    SelectClipRgn(PaintInfo.Canvas.Handle, 0);

                    // Stop column loop if there are no further columns in the given window.

                    if (PaintInfo.CellRect.Left >= Window.Right) or (NextColumn = InvalidColumn) then

                      Break;



                    // Move on to next column which might not be the one immediately following the current one

                    // because of auto span feature.

                    PaintInfo.Position := Items[NextColumn].Position;



                    // Move clip rectangle and continue.

                    if coVisible in Items[NextColumn].FOptions then

                      with PaintInfo do

                      begin

                        Items[NextColumn].GetAbsoluteBounds(CellRect.Left, CellRect.Right);

                        CellRect.Bottom := Node.NodeHeight;

                        ContentRect.Bottom := Node.NodeHeight;

                      end;

                  end;

                end;



                // This node is finished, notify descendants/application.

                with PaintInfo do

                begin

                  DoAfterItemPaint(Canvas, Node, R);



                  // Final touch for this node: mark it if it is the current drop target node.

                  if (Node = FDropTargetNode) and (toShowDropmark in FOptions.FPaintOptions) and

                    (poDrawDropMark in PaintOptions) then

                    DoPaintDropMark(Canvas, Node, R);

                end;

              end;



              with PaintInfo.Canvas do

              begin

                if DrawSelectionRect then

                begin

                  PaintSelectionRectangle(PaintInfo.Canvas, Window.Left, SelectionRect, Rect(0, 0, PaintWidth,

                    CurrentNodeHeight));

                end;



                // Put the constructed node image onto the target canvas.

                if not (poUnbuffered in PaintOptions) then

                  with TWithSafeRect(TargetRect), NodeBitmap do

                    BitBlt(TargetCanvas.Handle, Left, Top, Width, Height, Canvas.Handle, Window.Left, 0, SRCCOPY);

              end;

            end;



            Inc(TargetRect.Top, PaintInfo.Node.NodeHeight);

            if TargetRect.Top >= MaximumBottom then

              Break;



            // Keep selection rectangle coordinates in sync.

            if DrawSelectionRect then

              OffsetRect(SelectionRect, 0, -PaintInfo.Node.NodeHeight);



            // Advance to next visible node.

            PaintInfo.Node := GetNextVisible(PaintInfo.Node, True);

          end;

        end;



        // Erase rest of window not covered by a node.

        if TargetRect.Top < MaximumBottom then

        begin

          // Keep the horizontal target position to determine the selection rectangle offset later (if necessary).

          BaseOffset := Target.X;

          Target := TargetRect.TopLeft;

          R := Rect(TargetRect.Left, 0, TargetRect.Left, MaximumBottom - Target.Y);

          TargetRect := Rect(0, 0, MaximumRight - Target.X, MaximumBottom - Target.Y);



          if not (poUnbuffered in PaintOptions) then

          begin

            // Avoid unnecessary copying of bitmap content. This will destroy the DC handle too.

            NodeBitmap.Height := 0;

            NodeBitmap.PixelFormat := pf32Bit;

            NodeBitmap.Width := TargetRect.Right - TargetRect.Left;

            NodeBitmap.Height := TargetRect.Bottom - TargetRect.Top;

          end;



          // Call back application/descendants whether they want to erase this area.

          if not DoPaintBackground(PaintInfo.Canvas, TargetRect) then

          begin

            if UseBackground then

            begin

              SetCanvasOrigin(PaintInfo.Canvas, 0, 0);

              if toStaticBackground in TreeOptions.PaintOptions then

                StaticBackground(FBackground.Bitmap, PaintInfo.Canvas, Target, TargetRect)

              else

                TileBackground(FBackground.Bitmap, PaintInfo.Canvas, Target, TargetRect);

            end

            else

            begin

              // Consider here also colors of the columns.

              SetCanvasOrigin(PaintInfo.Canvas, Target.X, 0); // This line caused issue #313 when it was placed above the if-statement

              if UseColumns then

              begin

                with FHeader.FColumns do

                begin

                  // If there is no content in the tree then the first column has not yet been determined.

                  if FirstColumn = InvalidColumn then

                  begin

                    FirstColumn := GetFirstVisibleColumn;

                    repeat

                      if FirstColumn <> InvalidColumn then

                      begin

                        R.Left := Items[FirstColumn].Left;

                        R.Right := R.Left +  Items[FirstColumn].FWidth;

                        if R.Right > TargetRect.Left then

                          Break;

                        FirstColumn := GetNextVisibleColumn(FirstColumn);

                      end;

                    until FirstColumn = InvalidColumn;

                  end

                  else

                  begin

                    R.Left := Items[FirstColumn].Left;

                    R.Right := R.Left +  Items[FirstColumn].FWidth;

                  end;



                  // Initialize MaxRight.

                  MaxRight := Target.X - 1;



                  PaintInfo.Canvas.Font.Color := FColors.GridLineColor;

                  while (FirstColumn <> InvalidColumn) and (MaxRight < TargetRect.Right + Target.X) do

                  begin

                    // Determine left and right coordinate of the current column

                    ColLeft := Items[FirstColumn].Left;

                    ColRight := (ColLeft + Items[FirstColumn].FWidth);



                    // Check wether this column needs to be painted at all.

                    if (ColRight >= MaxRight) then

                    begin

                      R.Left := MaxRight;     // Continue where we left off

                      R.Right := ColRight;    // Paint to the right of the column

                      MaxRight := ColRight;   // And record were to start the next column.



                      if (poGridLines in PaintOptions) and

                         (toFullVertGridLines in FOptions.FPaintOptions) and

                         (toShowVertGridLines in FOptions.FPaintOptions) and

                         (not (hoAutoResize in FHeader.FOptions) or (Cardinal(FirstColumn) < TColumnPosition(Count - 1))) then

                      begin

                        DrawDottedVLine(PaintInfo, R.Top, R.Bottom, R.Right - 1);

                        Dec(R.Right);

                      end;



                      if not (coParentColor in Items[FirstColumn].FOptions) then

                        PaintInfo.Canvas.Brush.Color := Items[FirstColumn].FColor

                      else

                        PaintInfo.Canvas.Brush.Color := FColors.BackGroundColor;

                      PaintInfo.Canvas.FillRect(R);

                    end;

                    FirstColumn := GetNextVisibleColumn(FirstColumn);

                  end;



                  // Erase also the part of the tree not covert by a column.

                  if R.Right < TargetRect.Right + Target.X then

                  begin

                    R.Left := R.Right;

                    R.Right := TargetRect.Right + Target.X;

                    // Prevent erasing the last vertical grid line.

                    if (poGridLines in PaintOptions) and

                       (toFullVertGridLines in FOptions.FPaintOptions) and (toShowVertGridLines in FOptions.FPaintOptions) and

                       (not (hoAutoResize in FHeader.FOptions)) then

                      Inc(R.Left);

                    PaintInfo.Canvas.Brush.Color := FColors.BackGroundColor;

                    PaintInfo.Canvas.FillRect(R);

                  end;

                end;

                SetCanvasOrigin(PaintInfo.Canvas, 0, 0);

              end

              else

              begin

                // No columns nor bitmap background. Simply erase it with the tree color.

                SetCanvasOrigin(PaintInfo.Canvas, 0, 0);

                PaintInfo.Canvas.Brush.Color := FColors.BackGroundColor;

                PaintInfo.Canvas.FillRect(TargetRect);

              end;

            end;

          end;

          SetCanvasOrigin(PaintInfo.Canvas, 0, 0);



          if DrawSelectionRect then

          begin

            R := OrderRect(FNewSelRect);

            // Remap the selection rectangle to the current window of the tree.

            // Since Target has been used for other tasks BaseOffset got the left extent of the target position here.

            OffsetRect(R, -Target.X + BaseOffset - Window.Left, -Target.Y + FOffsetY);

            SetBrushOrigin(PaintInfo.Canvas, 0, Target.X and 1);

            PaintSelectionRectangle(PaintInfo.Canvas, 0, R, TargetRect);

          end;



          if not (poUnBuffered in PaintOptions) then

            with Target, NodeBitmap do

              BitBlt(TargetCanvas.Handle, X, Y, Width, Height, Canvas.Handle, 0, 0, SRCCOPY);

        end;

      finally

        PaintInfo.Canvas.Unlock;

        if poUnbuffered in PaintOptions then

          RestoreDC(TargetCanvas.Handle, SavedTargetDC)

        else

          NodeBitmap.Free;

      end;

      

      if (ChildCount[nil] = 0) and (FEmptyListMessage <> '') then

      begin

        // output a message if no items are to display

        Canvas.Font := Self.Font;

        SetBkMode(TargetCanvas.Handle, TRANSPARENT);

        R.Left := OffSetX + 2;

        R.Top := 2;

        R.Right := R.Left + Width - 2;

        R.Bottom := Height -2;

        TargetCanvas.Font.Color := clGrayText;

        {$if CompilerVersion >= 20}

        TargetCanvas.TextRect(R, FEmptyListMessage, [tfNoClip, tfLeft, tfWordBreak]);

        {$else}

        TextOutW(TargetCanvas.Handle, 2 - Window.Left, 2 - Window.Top, PWideChar(FEmptyListMessage), Length(FEmptyListMessage));

        {$ifend}

      end;



      DoAfterPaint(TargetCanvas);

    finally

      DoStateChange([], [tsPainting]);

    end;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.PasteFromClipboard: Boolean;



// Reads what is currently on the clipboard into the tree (if the format is supported).

// Note: If the application wants to have text or special formats to be inserted then it must implement

//       its own code (OLE). Here only the native tree format is accepted.



var

  Data: IDataObject;

  Source: TBaseVirtualTree;



begin

  Result := False;

  if not (toReadOnly in FOptions.FMiscOptions) then

  begin

    if OleGetClipboard(Data) <> S_OK then

      ShowError(SClipboardFailed, hcTFClipboardFailed)

    else

    begin

      // Try to get the source tree of the operation to optimize the operation.

      Source := GetTreeFromDataObject(Data);

      Result := ProcessOLEData(Source, Data, FFocusedNode, FDefaultPasteMode, Assigned(Source) and

        (tsCutPending in Source.FStates));

      if Assigned(Source) then

      begin

        if Source <> Self then

          Source.FinishCutOrCopy

        else

          DoStateChange([], [tsCutPending]);

      end;    

    end;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.PrepareDragImage(HotSpot: TPoint; const DataObject: IDataObject);



// Initiates an image drag operation. HotSpot is the position of the mouse in client coordinates.



var

  PaintOptions: TVTInternalPaintOptions;

  TreeRect,

  PaintRect: TRect;

  LocalSpot,

  ImagePos,

  PaintTarget: TPoint;

  Image: TBitmap;



begin

  if CanShowDragImage then

  begin

    // Determine the drag rectangle which is a square around the hot spot. Operate in virtual tree space.

    LocalSpot := HotSpot;

    Dec(LocalSpot.X, -FEffectiveOffsetX);

    Dec(LocalSpot.Y, FOffsetY);

    TreeRect := Rect(LocalSpot.X - FDragWidth div 2, LocalSpot.Y - FDragHeight div 2, LocalSpot.X + FDragWidth div 2,

      LocalSpot.Y + FDragHeight div 2);



    // Check that we have a valid rectangle.

    PaintRect := TreeRect;

    with TWithSafeRect(TreeRect) do

    begin

      if Left < 0 then

      begin

        PaintTarget.X := -Left;

        PaintRect.Left := 0;

      end

      else

        PaintTarget.X := 0;

      if Top < 0 then

      begin

        PaintTarget.Y := -Top;

        PaintRect.Top := 0;

      end

      else

        PaintTarget.Y := 0;

    end;



    Image := TBitmap.Create;

    with Image do

    try

      PixelFormat := pf32Bit;

      Width := TreeRect.Right - TreeRect.Left;

      Height := TreeRect.Bottom - TreeRect.Top;

      // Erase the entire image with the color key value, for the case not everything

      // in the image is covered by the tree image.

      Canvas.Brush.Color := FColors.BackGroundColor;

      Canvas.FillRect(Rect(0, 0, Width, Height));



      PaintOptions := [poDrawSelection, poSelectedOnly];

      if FDragImageKind = diMainColumnOnly then

        Include(PaintOptions, poMainOnly);

      PaintTree(Image.Canvas, PaintRect, PaintTarget, PaintOptions);



      // Once we have got the drag image we can convert all necessary coordinates into screen space.

      OffsetRect(TreeRect, -FEffectiveOffsetX, FOffsetY);

      ImagePos := ClientToScreen(TreeRect.TopLeft);

      HotSpot := ClientToScreen(HotSpot);



      FDragImage.ColorKey := FColors.BackGroundColor;

      FDragImage.PrepareDrag(Image, ImagePos, HotSpot, DataObject);

    finally

      Image.Free;

    end;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.Print(Printer: TPrinter; PrintHeader: Boolean);



var

  SaveTreeFont: TFont;                 // Remembers the tree's current font.

  SaveHeaderFont: TFont;               // Remembers the header's current font.

  ImgRect,                             // Describes the dimensions of Image.

  TreeRect,                            // The total VTree dimensions.

  DestRect,                            // Dimensions of PrinterImage.

  SrcRect: TRect;                      // Clip dimensions from Image -> PrinterImage

  P: TPoint;                           // Used by PaintTree.

  Options: TVTInternalPaintOptions;    // Used by PaintTree.

  Image,                               // Complete Tree is drawn to this image.

  PrinterImage: TBitmap;               // This is the image that gets printed.

  SaveColor: TColor;                   // Remembers the VTree Color.

  pTxtHeight,                          // Height of font in the TPrinter.Canvas

  vTxtHeight,                          // Height of font in the VTree Canvas

  vPageWidth,

  vPageHeight,                         // Printer height in VTree resolution

  xPageNum, yPageNum,                  // # of pages (except the occasional last one)

  xPage, yPage: Integer;               // Loop counter

  Scale: Extended;                     // Scale factor between Printer Canvas and VTree Canvas

  LogFont: TLogFont;



begin

  if Assigned(Printer) then

  begin

    BeginUpdate;



    // Grid lines are the only parts which are desirable when printing.

    Options := [poGridLines];



    // Remember the tree font.

    SaveTreeFont := TFont.Create;

    SaveTreeFont.Assign(Font);

    // Create a new font for printing which does not use clear type output (but is antialiased, if possible)

    // and which has the highest possible quality.

    GetObject(Font.Handle, SizeOf(TLogFont), @LogFont);

    LogFont.lfQuality := ANTIALIASED_QUALITY;

    Font.Handle := CreateFontIndirect(LogFont);



    // Create an image that will hold the complete VTree

    Image := TBitmap.Create;

    Image.PixelFormat := pf32Bit;

    PrinterImage := nil;

    try

      TreeRect := GetTreeRect;



      Image.Width := TreeRect.Right - TreeRect.Left;

      P := Point(0, 0);

      if (hoVisible in FHeader.Options) and PrintHeader then

      begin

        Inc(TreeRect.Bottom, FHeader.Height);

        Inc(P.Y, FHeader.Height);

      end;

      Image.Height := TreeRect.Bottom - TreeRect.Top;



      ImgRect.Left := 0;

      ImgRect.Top := 0;

      ImgRect.Right := Image.Width;



      // Force the background to white color during the rendering.

      SaveColor := FColors.BackGroundColor;

      Color := clWhite;

      // Print header if it is visible.

      if (hoVisible in FHeader.Options) and PrintHeader then

      begin

        SaveHeaderFont := TFont.Create;

        try

          SaveHeaderFont.Assign(FHeader.Font);

          // Create a new font for printing which does not use clear type output (but is antialiased, if possible)

          // and which has the highest possible quality.

          GetObject(FHeader.Font.Handle, SizeOf(TLogFont), @LogFont);

          LogFont.lfQuality := ANTIALIASED_QUALITY;

          FHeader.Font.Handle := CreateFontIndirect(LogFont);

          ImgRect.Bottom := FHeader.Height;

          FHeader.FColumns.PaintHeader(Image.Canvas.Handle, ImgRect, 0);

          FHeader.Font := SaveHeaderFont;

        finally

          SaveHeaderFont.Free;

        end;

      end;

      // The image's height is already adjusted for the header if it is visible.

      ImgRect.Bottom := Image.Height;



      PaintTree(Image.Canvas, ImgRect, P, Options, pf32Bit);

      Color := SaveColor;



      // Activate the printer

      Printer.BeginDoc;

      Printer.Canvas.Font := Font;



      // Now we can calculate the scaling :

      pTxtHeight := Printer.Canvas.TextHeight('Tj');

      vTxtHeight := Canvas.TextHeight('Tj');



      Scale := pTxtHeight / vTxtHeight;



      // Create an Image that has the same dimensions as the printer canvas but

      // scaled to the VTree resolution:

      PrinterImage := TBitmap.Create;



      vPageHeight := Round(Printer.PageHeight / Scale);

      vPageWidth := Round(Printer.PageWidth / Scale);



      // We do a minumum of one page.

      xPageNum := Trunc(Image.Width / vPageWidth);

      yPageNum := Trunc(Image.Height / vPageHeight);



      PrinterImage.Width := vPageWidth;

      PrinterImage.Height := vPageHeight;



      // Split vertically:

      for yPage := 0 to yPageNum do

      begin

        DestRect.Left := 0;

        DestRect.Top := 0;

        DestRect.Right := PrinterImage.Width;

        DestRect.Bottom := PrinterImage.Height;



        // Split horizontally:

        for xPage := 0 to xPageNum do

          begin

            SrcRect.Left := vPageWidth * xPage;

            SrcRect.Top := vPageHeight * yPage;

            SrcRect.Right := vPageWidth * xPage + PrinterImage.Width;

            SrcRect.Bottom := SrcRect.Top + vPageHeight;



            // Clear the image

            PrinterImage.Canvas.Brush.Color := clWhite;

            PrinterImage.Canvas.FillRect(Rect(0, 0, PrinterImage.Width, PrinterImage.Height));

            PrinterImage.Canvas.CopyRect(DestRect, Image.Canvas, SrcRect);

            PrtStretchDrawDIB(Printer.Canvas, Rect(0, 0, Printer.PageWidth, Printer.PageHeight - 1), PrinterImage);

            if xPage <> xPageNum then

              Printer.NewPage;

          end;

        if yPage <> yPageNum then

          Printer.NewPage;

      end;



      // Restore tree font.

      Font := SaveTreeFont;

      SaveTreeFont.Free;

      Printer.EndDoc;

    finally

      PrinterImage.Free;

      Image.Free;

      EndUpdate;

    end;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.ProcessDrop(DataObject: IDataObject; TargetNode: PVirtualNode; var Effect: Integer;

  Mode: TVTNodeAttachMode): Boolean;



// Recreates the (sub) tree structure serialized into memory and provided by DataObject. The new nodes are attached to

// the passed node or FRoot if TargetNode is nil.

// Returns True on success, i.e. the CF_VIRTUALTREE format is supported by the data object and the structure could be

// recreated, otherwise False.



var

  Source: TBaseVirtualTree;



begin

  Result := False;

  if Mode = amNoWhere then

    Effect := DROPEFFECT_NONE

  else

  begin

    BeginUpdate;

    // try to get the source tree of the operation

    Source := GetTreeFromDataObject(DataObject);

    if Assigned(Source) then

      Source.BeginUpdate;

    try

      try

        // Before adding the new nodes try to optimize the operation if source and target tree reside in

        // the same application and operation is a move.

        if ((Effect and DROPEFFECT_MOVE) <> 0) and Assigned(Source) then

        begin

          // If both copy and move are specified then prefer a copy because this is not destructing.

          Result := ProcessOLEData(Source, DataObject, TargetNode, Mode, (Effect and DROPEFFECT_COPY) = 0);

          // Since we made an optimized move or a copy there's no reason to act further after DoDragging returns.

          Effect := DROPEFFECT_NONE;

        end

        else

          // Act only if move or copy operation is requested.

          if (Effect and (DROPEFFECT_MOVE or DROPEFFECT_COPY)) <> 0 then

            Result := ProcessOLEData(Source, DataObject, TargetNode, Mode, False)

          else

            Result := False;

      except

        Effect := DROPEFFECT_NONE;

      end;

    finally

      if Assigned(Source) then

        Source.EndUpdate;

      EndUpdate;

    end;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



type

  // needed to handle OLE global memory objects

  TOLEMemoryStream = class(TCustomMemoryStream)

  public

    function Write(const Buffer; Count: Integer): Longint; override;

  end;



//----------------------------------------------------------------------------------------------------------------------



function TOLEMemoryStream.Write(const Buffer; Count: Integer): Integer;



begin

  raise EStreamError.CreateRes(PResStringRec(@SCantWriteResourceStreamError));

end;



//----------------- TBaseVirtualTree -----------------------------------------------------------------------------



procedure TBaseVirtualTree.DoDrawHint(Canvas: TCanvas; Node: PVirtualNode; R:

    TRect; Column: TColumnIndex);



begin

  if Assigned(FOnDrawHint) then

    FOnDrawHint(Self, Canvas, Node, R, Column);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.DoGetHintSize(Node: PVirtualNode; Column:

    TColumnIndex; var R: TRect);



begin

  if Assigned(FOnGetHintSize) then

    FOnGetHintSize(Self, Node, Column, R);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.DoGetHintKind(Node: PVirtualNode; Column:

    TColumnIndex; var Kind: TVTHintKind);



begin

  if Assigned(FOnGetHintKind) then

    FOnGetHintKind(Self, Node, Column, Kind)

  else

    Kind := DefaultHintKind;

end;



function TBaseVirtualTree.GetDefaultHintKind: TVTHintKind;



begin

  Result := vhkText;

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.ProcessOLEData(Source: TBaseVirtualTree; DataObject: IDataObject; TargetNode: PVirtualNode;

  Mode: TVTNodeAttachMode; Optimized: Boolean): Boolean;



// Recreates the (sub) tree structure serialized into memory and provided by DataObject. The new nodes are attached to

// the passed node or FRoot if TargetNode is nil according to Mode. Optimized can be set to True if the entire operation

// happens within the same process (i.e. sender and receiver of the OLE operation are located in the same process).

// Optimize = True makes only sense if the operation to carry out is a move hence it is also the indication of the

// operation to be done here. Source is the source of the OLE data and only of use (and usually assigned) when

// an OLE operation takes place in the same application.

// Returns True on success, i.e. the CF_VIRTUALTREE format is supported by the data object and the structure could be

// recreated, otherwise False.



var

  Medium: TStgMedium;

  Stream: TStream;

  Data: Pointer;

  Node: PVirtualNode;

  Nodes: TNodeArray;

  I: Integer;

  Res: HRESULT;

  ChangeReason: TChangeReason;



begin

  Nodes := nil;

  // Check the data format available by the data object.

  with StandardOLEFormat do

  begin

    // Read best format.

    cfFormat := CF_VIRTUALTREE;

  end;

  Result := DataObject.QueryGetData(StandardOLEFormat) = S_OK;

  if Result and not (toReadOnly in FOptions.FMiscOptions) then

  begin

    BeginUpdate;

    Result := False;

    try

      if TargetNode = nil then

        TargetNode := FRoot;

      if TargetNode = FRoot then

      begin

        case Mode of

          amInsertBefore:

            Mode := amAddChildFirst;

          amInsertAfter:

            Mode := amAddChildLast;

        end;

      end;



      // Optimized means source is known and in the same process so we can access its pointers, which avoids duplicating

      // the data while doing a serialization. Can only be used with cut'n paste and drag'n drop with move effect.

      if Optimized then

      begin

        if tsOLEDragging in Source.FStates then

          Nodes := Source.FDragSelection

        else

          Nodes := Source.GetSortedCutCopySet(True);



        if Mode in [amInsertBefore,amAddChildLast] then

        begin

          for I := 0 to High(Nodes) do

            if not HasAsParent(TargetNode, Nodes[I]) then

              Source.MoveTo(Nodes[I], TargetNode, Mode, False);

        end

        else

        begin

          for I := High(Nodes) downto 0 do

            if not HasAsParent(TargetNode, Nodes[I]) then

              Source.MoveTo(Nodes[I], TargetNode, Mode, False);

        end;

        Result := True;

      end

      else

      begin

        if Source = Self then

          ChangeReason := crNodeCopied

        else

          ChangeReason := crNodeAdded;

        Res := DataObject.GetData(StandardOLEFormat, Medium);

        if Res = S_OK then

        begin

          case Medium.tymed of

            TYMED_ISTREAM, // IStream interface

            TYMED_HGLOBAL: // global memory block

              begin

                Stream := nil;

                if Medium.tymed = TYMED_ISTREAM then

                  Stream := TOLEStream.Create(IUnknown(Medium.stm) as IStream)

                else

                begin

                  Data := GlobalLock(Medium.hGlobal);

                  if Assigned(Data) then

                  begin

                    // Get the total size of data to retrieve.

                    I := PCardinal(Data)^;

                    Inc(PCardinal(Data));

                    Stream := TOLEMemoryStream.Create;

                    TOLEMemoryStream(Stream).SetPointer(Data, I);

                  end;

                end;



                if Assigned(Stream) then

                try

                  while Stream.Position < Stream.Size do

                  begin

                    Node := MakeNewNode;

                    InternalConnectNode(Node, TargetNode, Self, Mode);

                    InternalAddFromStream(Stream, VTTreeStreamVersion, Node);

                    // This seems a bit strange because of the callback for granting to add the node

                    // which actually comes after the node has been added. The reason is that the node must

                    // contain valid data otherwise I don't see how the application can make a funded decision.

                    if not DoNodeCopying(Node, TargetNode) then

                    begin

                      DeleteNode(Node);

                    end

                    else

                    begin

                      DoNodeCopied(Node);

                      StructureChange(Node, ChangeReason);

                      // In order to maintain the same node order when restoring nodes in the case of amInsertAfter

                      // we have to move the reference node continously. Othwise we would end up with reversed node order.

                      if Mode = amInsertAfter then

                        TargetNode := Node;

                    end;

                  end;

                  Result := True;

                finally

                  Stream.Free;

                  if Medium.tymed = TYMED_HGLOBAL then

                    GlobalUnlock(Medium.hGlobal);

                end;

              end;

          end;

          ReleaseStgMedium(Medium);

        end;

      end;

    finally

      EndUpdate;

    end;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.ReinitChildren(Node: PVirtualNode; Recursive: Boolean);



// Forces all child nodes of Node to be reinitialized.

// If Recursive is True then also the grandchildren are reinitialized.



var

  Run: PVirtualNode;



begin

  if Assigned(Node) then

  begin

    InitChildren(Node);

    Run := Node.FirstChild;

  end

  else

  begin

    InitChildren(FRoot);

    Run := FRoot.FirstChild;

  end;



  while Assigned(Run) do

  begin

    ReinitNode(Run, Recursive);

    Run := Run.NextSibling;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.ReinitNode(Node: PVirtualNode; Recursive: Boolean);



// Forces the given node and all its children (if recursive is True) to be initialized again without

// modifying any data in the nodes nor deleting children (unless the application requests a different amount).



begin

  if Assigned(Node) and (Node <> FRoot) then

  begin

    // Remove dynamic styles.

    Node.States := Node.States - [vsChecking, vsCutOrCopy, vsDeleting, vsHeightMeasured];

    InitNode(Node);

  end;



  if Recursive then

    ReinitChildren(Node, True);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.RepaintNode(Node: PVirtualNode);



// Causes an immediate repaint of the given node.



var

  R: Trect;



begin

  if Assigned(Node) and (Node <> FRoot) then

  begin

    R := GetDisplayRect(Node, -1, False);

    RedrawWindow(Handle, @R, 0, RDW_INVALIDATE or RDW_UPDATENOW or RDW_NOERASE or RDW_VALIDATE or RDW_NOCHILDREN);

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.ResetNode(Node: PVirtualNode);



// Deletes all children of the given node and marks it as being uninitialized.



begin

  DoCancelEdit;

  if (Node = nil) or (Node = FRoot) then

    Clear

  else

  begin

    DoReset(Node);

    DeleteChildren(Node);

    // Remove initialized and other dynamic styles, keep persistent styles.

    Node.States := Node.States - [vsInitialized, vsChecking, vsCutOrCopy, vsDeleting, vsHasChildren, vsExpanded,

      vsHeightMeasured];

    InvalidateNode(Node);

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.SaveToFile(const FileName: TFileName);



// Saves the entire content of the tree into a file (see further notes in SaveToStream).



var

  FileStream: TFileStream;



begin

  FileStream := TFileStream.Create(FileName, fmCreate);

  try

    SaveToStream(FileStream);

  finally

    FileStream.Free;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.SaveToStream(Stream: TStream; Node: PVirtualNode = nil);



// Saves Node and all its children to Stream. If Node is nil then all top level nodes will be stored.

// Note: You should be careful about assuming what is actually saved. The problem here is that we are dealing with

//       virtual data. The tree can so not know what it has to save. The only fact we reliably know is the tree's

//       structure. To be flexible for future enhancements as well as unknown content (unknown to the tree class which

//       is saving/loading the stream) a chunk based approach is used here. Every tree class handles only those

//       chunks which are not handled by an anchestor class and are known by the class.

//

// The base tree class saves only the structure of the tree along with application provided data. descendants may

// optionally add their own chunks to store additional information. See: WriteChunks.



var

  Count: Cardinal;



begin

  Stream.Write(MagicID, SizeOf(MagicID));

  if Node = nil then

  begin

    // Keep number of top level nodes for easy restauration.

    Count := FRoot.ChildCount;

    Stream.WriteBuffer(Count, SizeOf(Count));



    // Save entire tree here.

    Node := FRoot.FirstChild;

    while Assigned(Node) do

    begin

      WriteNode(Stream, Node);

      Node := Node.NextSibling;

    end;

  end

  else

  begin

    Count := 1;

    Stream.WriteBuffer(Count, SizeOf(Count));

    WriteNode(Stream, Node);

  end;

  if Assigned(FOnSaveTree) then

    FOnSaveTree(Self, Stream);

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.ScrollIntoView(Node: PVirtualNode; Center: Boolean; Horizontally: Boolean = False): Boolean;



// Scrolls the tree so that the given node is in the client area and returns True if the tree really has been

// scrolled (e.g. to avoid further updates) else returns False. If extened focus is enabled then the tree will also

// be horizontally scrolled if needed.

// Note: All collapsed parents of the node are expanded.



var

  R: TRect;

  Run: PVirtualNode;

  UseColumns,

  HScrollBarVisible: Boolean;

  ScrolledVertically,

  ScrolledHorizontally: Boolean;



begin

  ScrolledVertically := False;

  ScrolledHorizontally := False;



  if Assigned(Node) and (Node <> FRoot) then

  begin

    // Make sure all parents of the node are expanded.

    Run := Node.Parent;

    while Run <> FRoot do

    begin

      if not (vsExpanded in Run.States) then

        ToggleNode(Run);

      Run := Run.Parent;

    end;

    UseColumns := FHeader.UseColumns;

    if UseColumns and FHeader.FColumns.IsValidColumn(FFocusedColumn) then

      R := GetDisplayRect(Node, FFocusedColumn, not (toGridExtensions in FOptions.FMiscOptions))

    else

      R := GetDisplayRect(Node, NoColumn, not (toGridExtensions in FOptions.FMiscOptions));



    // The returned rectangle can never be empty after the expand code above.

    // 1) scroll vertically

    if R.Top < 0 then

    begin

      if Center then

        SetOffsetY(FOffsetY - R.Top + ClientHeight div 2)

      else

        SetOffsetY(FOffsetY - R.Top);

      ScrolledVertically := True;

    end

    else

      if (R.Bottom > ClientHeight) or Center then

      begin

        HScrollBarVisible := (ScrollBarOptions.ScrollBars in [{$if CompilerVersion >= 24}System.UITypes.TScrollStyle.{$ifend}ssBoth, {$if CompilerVersion >= 24}System.UITypes.TScrollStyle.{$ifend}ssHorizontal]) and

          (ScrollBarOptions.AlwaysVisible or (Integer(FRangeX) > ClientWidth));

        if Center then

          SetOffsetY(FOffsetY - R.Bottom + ClientHeight div 2)

        else

          SetOffsetY(FOffsetY - R.Bottom + ClientHeight);

        // When scrolling up and the horizontal scroll appears because of the operation

        // then we have to move up the node the horizontal scrollbar's height too

        // in order to avoid that the scroll bar hides the node which we wanted to have in view.

        if not UseColumns and not HScrollBarVisible and (Integer(FRangeX) > ClientWidth) then

          SetOffsetY(FOffsetY - GetSystemMetrics(SM_CYHSCROLL));

        ScrolledVertically := True;

      end;



    if Horizontally then

      // 2) scroll horizontally

      ScrolledHorizontally := ScrollIntoView(FFocusedColumn, Center, Node);



  end;



  Result := ScrolledVertically or ScrolledHorizontally;

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.ScrollIntoView(Column: TColumnIndex; Center: Boolean; Node: PVirtualNode = nil): Boolean;



// Scrolls the columns so that the given column is in the client area and returns True if the columns really have been

// scrolled (e.g. to avoid further updates) else returns False.



var

  ColumnLeft,

  ColumnRight: Integer;

  NewOffset: Integer;

  R: TRect;



begin

  Result := False;



  if FHeader.UseColumns and FHeader.Columns.IsValidColumn(Column) then begin
    ColumnLeft := Header.Columns.Items[Column].Left;

    ColumnRight := ColumnLeft + Header.Columns.Items[Column].Width;

  end else if Assigned(Node) then begin

    R := GetDisplayRect(Node, NoColumn, not (toGridExtensions in FOptions.FMiscOptions));

    ColumnLeft := R.Left;

    ColumnRight := R.Right;

  end else

    Exit;



  NewOffset := FEffectiveOffsetX;

  if (Header.Columns.GetVisibleFixedWidth > 0) and (not Center) then

  begin

    if ColumnRight > ClientWidth then

      NewOffset := FEffectiveOffsetX + (ColumnRight - ClientWidth)

    else if ColumnLeft < Header.Columns.GetVisibleFixedWidth then

      NewOffset := FEffectiveOffsetX - (Header.Columns.GetVisibleFixedWidth - ColumnLeft);

    if NewOffset <> FEffectiveOffsetX then

    begin

      if UseRightToLeftAlignment then

        SetOffsetX(-Integer(FRangeX) + ClientWidth + NewOffset)

      else

        SetOffsetX(-NewOffset);

    end;

    Result := True;

  end

  else

  begin

    NewOffset := FEffectiveOffsetX + ColumnLeft - (Header.Columns.GetVisibleFixedWidth div 2) - (ClientWidth div 2) + ((ColumnRight - ColumnLeft) div 2);

    if NewOffset <> FEffectiveOffsetX then

    begin

      if UseRightToLeftAlignment then

        SetOffsetX(-Integer(FRangeX) + ClientWidth + NewOffset)

      else

        SetOffsetX(-NewOffset);

    end;

    Result := True;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.SelectAll(VisibleOnly: Boolean);



// Select all nodes in the tree.

// If VisibleOnly is True then only visible nodes are selected.



var

  Run: PVirtualNode;

  NextFunction: TGetNextNodeProc;



begin

  if not FSelectionLocked and (toMultiSelect in FOptions.FSelectionOptions) then

  begin

    ClearTempCache;

    if VisibleOnly then

    begin

      Run := GetFirstVisible(nil, True);

      NextFunction := GetNextVisible;

    end

    else

    begin

      Run := GetFirst;

      NextFunction := GetNext;

    end;



    while Assigned(Run) do

    begin

      if not(vsSelected in Run.States) then

        InternalCacheNode(Run);

      Run := NextFunction(Run);

    end;

    if FTempNodeCount > 0 then

      AddToSelection(FTempNodeCache, FTempNodeCount);

    ClearTempCache;

    Invalidate;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.Sort(Node: PVirtualNode; Column: TColumnIndex; Direction: TSortDirection; DoInit: Boolean = True);



// Sorts the given node. The application is queried about how to sort via the OnCompareNodes event.

// Column is simply passed to the the compare function so the application can also sort in a particular column.

// In order to free the application from taking care about the sort direction the parameter Direction is used.

// This way the application can always sort in increasing order, while this method reorders nodes according to this flag.



  //--------------- local functions -------------------------------------------



  function MergeAscending(A, B: PVirtualNode): PVirtualNode;



  // Merges A and B (which both must be sorted via Compare) into one list.



  var

    Dummy: TVirtualNode;

    CompareResult: Integer;

  begin

    // This avoids checking for Result = nil in the loops.

    Result := @Dummy;

    while Assigned(A) and Assigned(B) do

    begin

      if OperationCanceled then

        CompareResult := 0

      else

        CompareResult := DoCompare(A, B, Column);



      if CompareResult <= 0 then

      begin

        Result.NextSibling := A;

        Result := A;

        A := A.NextSibling;

      end

      else

      begin

        Result.NextSibling := B;

        Result := B;

        B := B.NextSibling;

      end;

    end;



    // Just append the list which is not nil (or set end of result list to nil if both lists are nil).

    if Assigned(A) then

      Result.NextSibling := A

    else

      Result.NextSibling := B;

    // return start of the new merged list

    Result := Dummy.NextSibling;

  end;



  //---------------------------------------------------------------------------



  function MergeDescending(A, B: PVirtualNode): PVirtualNode;



  // Merges A and B (which both must be sorted via Compare) into one list.



  var

    Dummy: TVirtualNode;

    CompareResult: Integer;



  begin

    // this avoids checking for Result = nil in the loops

    Result := @Dummy;

    while Assigned(A) and Assigned(B) do

    begin

      if OperationCanceled then

        CompareResult := 0

      else

        CompareResult := DoCompare(A, B, Column);



      if CompareResult >= 0 then

      begin

        Result.NextSibling := A;

        Result := A;

        A := A.NextSibling;

      end

      else

      begin

        Result.NextSibling := B;

        Result := B;

        B := B.NextSibling;

      end;

    end;



    // Just append the list which is not nil (or set end of result list to nil if both lists are nil).

    if Assigned(A) then

      Result.NextSibling := A

    else

      Result.NextSibling := B;

    // Return start of the newly merged list.

    Result := Dummy.NextSibling;

  end;



  //---------------------------------------------------------------------------



  function MergeSortAscending(var Node: PVirtualNode; N: Cardinal): PVirtualNode;



  // Sorts the list of nodes given by Node (which must not be nil).



  var

    A, B: PVirtualNode;



  begin

    if N > 1 then

    begin

      A := MergeSortAscending(Node, N div 2);

      B := MergeSortAscending(Node, (N + 1) div 2);

      Result := MergeAscending(A, B);

    end

    else

    begin

      Result := Node;

      Node := Node.NextSibling;

      Result.NextSibling := nil;

    end;

  end;



  //---------------------------------------------------------------------------



  function MergeSortDescending(var Node: PVirtualNode; N: Cardinal): PVirtualNode;



  // Sorts the list of nodes given by Node (which must not be nil).



  var

    A, B: PVirtualNode;



  begin

    if N > 1 then

    begin

      A := MergeSortDescending(Node, N div 2);

      B := MergeSortDescending(Node, (N + 1) div 2);

      Result := MergeDescending(A, B);

    end

    else

    begin

      Result := Node;

      Node := Node.NextSibling;

      Result.NextSibling := nil;

    end;

  end;



  //--------------- end local functions ---------------------------------------



var

  Run: PVirtualNode;

  Index: Cardinal;



begin

  InterruptValidation;

  if tsEditPending in FStates then

  begin

    StopTimer(EditTimer);

    DoStateChange([], [tsEditPending]);

  end;



  if not (tsEditing in FStates) or DoEndEdit then

  begin

    if Node = nil then

      Node := FRoot;

    if vsHasChildren in Node.States then

    begin

      if (Node.ChildCount = 0) and DoInit then

        InitChildren(Node);

      // Make sure the children are valid, so they can be sorted at all.

      if DoInit and (Node.ChildCount > 0) then

        ValidateChildren(Node, False);

      // Child count might have changed.

      if Node.ChildCount > 1 then

      begin

        StartOperation(okSortNode);

        try

          // Sort the linked list, check direction flag only once.

          if Direction = sdAscending then

            Node.FirstChild := MergeSortAscending(Node.FirstChild, Node.ChildCount)

          else

            Node.FirstChild := MergeSortDescending(Node.FirstChild, Node.ChildCount);

        finally

          EndOperation(okSortNode);

        end;

        // Consolidate the child list finally.

        Run := Node.FirstChild;

        Run.PrevSibling := nil;

        Index := 0;

        repeat

          Run.Index := Index;

          Inc(Index);

          if Run.NextSibling = nil then

            Break;

          Run.NextSibling.PrevSibling := Run;

          Run := Run.NextSibling;

        until False;

        Node.LastChild := Run;



        InvalidateCache;

      end;

      if FUpdateCount = 0 then

      begin

        ValidateCache;

        Invalidate;

      end;

    end;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.SortTree(Column: TColumnIndex; Direction: TSortDirection; DoInit: Boolean = True);



  //--------------- local function --------------------------------------------



  procedure DoSort(Node: PVirtualNode);



  // Recursively sorts Node and its child nodes.



  var

    Run: PVirtualNode;



  begin

    Sort(Node, Column, Direction, DoInit);

    // Recurse to next level

    Run := Node.FirstChild;

    while Assigned(Run) and not FOperationCanceled do

    begin

      if DoInit and not (vsInitialized in Run.States) then

        InitNode(Run);

      if (vsInitialized in Run.States) and (not (toAutoSort in TreeOptions.AutoOptions) or Expanded[Run]) then // There is no need to sort collapsed branches

        DoSort(Run);

      Run := Run.NextSibling;

    end;

  end;



  //--------------- end local function ----------------------------------------



begin

  if RootNode.TotalCount <= 2 then

    Exit;//Nothing to do if there are one or zero nodes. RootNode.TotalCount is 1 if there are no nodes in the treee as the root node counts too here.

  // Instead of wrapping the sort using BeginUpdate/EndUpdate simply the update counter

  // is modified. Otherwise the EndUpdate call will recurse here.

  Inc(FUpdateCount);

  try

    if Column > InvalidColumn then

    begin

      StartOperation(okSortTree);

      try

        DoSort(FRoot);

      finally

        EndOperation(okSortTree);

      end; 

    end;

    InvalidateCache;

  finally

    if FUpdateCount > 0 then

      Dec(FUpdateCount);

    if FUpdateCount = 0 then

    begin

      ValidateCache;

      Invalidate;

    end;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.ToggleNode(Node: PVirtualNode);



// Changes a node's expand state to the opposite state.



var

  Child,

  FirstVisible: PVirtualNode;

  HeightDelta,

  StepsR1,

  StepsR2,

  Steps: Integer;

  TogglingTree,

  ChildrenInView,

  NeedFullInvalidate,

  NeedUpdate,

  NodeInView,

  PosHoldable,

  TotalFit: Boolean;

  ToggleData: TToggleAnimationData;



  //--------------- local function --------------------------------------------



  procedure PrepareAnimation;



  // Prepares ToggleData.



  var

    R: TRect;

    S: Integer;

    M: TToggleAnimationMode;



  begin

    with ToggleData do

    begin

      Window := Handle;

      DC := GetDC(Handle);

      Self.Brush.Color := FColors.BackGroundColor;

      Brush := Self.Brush.Handle;



      if (Mode1 <> tamNoScroll) and (Mode2 <> tamNoScroll) then

      begin

        if StepsR1 < StepsR2 then

        begin

          // As the primary rectangle is always R1 we will get a much smoother

          // animation if R1 is the one that will be scrolled more.

          R := R2;

          R2 := R1;

          R1 := R;



          M := Mode2;

          Mode2 := Mode1;

          Mode1 := M;



          S := StepsR2;

          StepsR2 := StepsR1;

          StepsR1 := S;

        end;

        ScaleFactor := StepsR2 / StepsR1;

        MissedSteps := 0;

      end;



      if Mode1 <> tamNoScroll then

        Steps := StepsR1

      else

        Steps := StepsR2;

    end;

  end;



  //--------------- end local function ----------------------------------------



begin

  Assert(Assigned(Node), 'Node must not be nil.');



  TogglingTree := tsToggling in FStates;

  ChildrenInView := False;

  HeightDelta := 0;

  NeedFullInvalidate := False;

  NeedUpdate := False;

  NodeInView := False;

  PosHoldable := False;

  TotalFit := False;



  // We don't need to switch the expand state if the node is being deleted otherwise some

  // updates (e.g. visible node count) are done twice with disasterous results).

  if [vsDeleting, vsToggling] * Node.States = [] then

  begin

    try

      DoStateChange([tsToggling]);

      Include(Node.States, vsToggling);



      if vsExpanded in Node.States then

      begin

        if DoCollapsing(Node) then

        begin

          NeedUpdate := True;



          // Calculate the height delta right now as we need it for toChildrenAbove anyway.

          HeightDelta := -Integer(Node.TotalHeight) + Integer(NodeHeight[Node]); 

          if (FUpdateCount = 0) and (toAnimatedToggle in FOptions.FAnimationOptions) and not

             (tsCollapsing in FStates) then

          begin

            if tsHint in Self.FStates then

              Application.CancelHint;

            UpdateWindow(Handle);



            // animated collapsing

            with ToggleData do

            begin

              // Determine the animation behaviour and rectangle. If toChildrenAbove is set, the behaviour is depending

              // on the position of the node to be collapsed.

              R1 := GetDisplayRect(Node, NoColumn, False);

              Mode2 := tamNoScroll;

              if toChildrenAbove in FOptions.FPaintOptions then

              begin

                PosHoldable := (FOffsetY + (Integer(Node.TotalHeight) - Integer(NodeHeight[Node]))) <= 0;

                NodeInView := R1.Top < ClientHeight;



                StepsR1 := 0;

                if NodeInView then

                begin

                  if PosHoldable or not (toAdvancedAnimatedToggle in FOptions.FAnimationOptions) then

                  begin

                    // Scroll the child nodes down.

                    Mode1 := tamScrollDown;

                    R1.Bottom := R1.Top;

                    R1.Top := 0;

                    StepsR1 := Min(R1.Bottom - R1.Top + 1, Integer(Node.TotalHeight) - Integer(NodeHeight[Node]));

                  end

                  else

                  begin

                    // The position cannot be kept. So scroll the node up to its future position.

                    Mode1 := tamScrollUp;

                    R1.Top := Max(0, R1.Top + HeightDelta);

                    R1.Bottom := ClientHeight;

                    StepsR1 := FOffsetY - HeightDelta;

                  end;

                end;

              end

              else

              begin

                if (Integer(FRangeY) + FOffsetY - R1.Bottom + HeightDelta >= ClientHeight - R1.Bottom) or

                   (Integer(FRangeY) <= ClientHeight) or (FOffsetY = 0) or not

                   (toAdvancedAnimatedToggle in FOptions.FAnimationOptions) then

                begin

                  // Do a simple scroll up over the child nodes.

                  Mode1 := tamScrollUp;

                  Inc(R1.Top, NodeHeight[Node]);

                  R1.Bottom := ClientHeight;

                  StepsR1 := Min(R1.Bottom - R1.Top + 1, -HeightDelta);

                end

                else

                begin

                  // Scroll the node down to its future position. As FOffsetY will change we need to invalidate the

                  // whole tree.

                  Mode1 := tamScrollDown;

                  StepsR1 := Min(-FOffsetY, ClientHeight - Integer(FRangeY) -FOffsetY - HeightDelta);

                  R1.Top := 0;

                  R1.Bottom := Min(ClientHeight, R1.Bottom + Steps);

                  NeedFullInvalidate := True;

                end;

              end;



              // No animation necessary if the node is below the current client height.

              if R1.Top < ClientHeight then

              begin

                PrepareAnimation;

                try

                  Animate(Steps, FAnimationDuration, ToggleCallback, @ToggleData);

                finally

                  ReleaseDC(Window, DC);

                end;

              end;

            end;

          end;



          // collapse the node

          AdjustTotalHeight(Node, IfThen(IsEffectivelyFiltered[Node], 0, NodeHeight[Node]));

          if FullyVisible[Node] then

            Dec(FVisibleCount, CountVisibleChildren(Node));

          Exclude(Node.States, vsExpanded);

          DoCollapsed(Node);



          // Remove child nodes now, if enabled.

          if (toAutoFreeOnCollapse in FOptions.FAutoOptions) and (Node.ChildCount > 0) then

          begin

            DeleteChildren(Node);

            Include(Node.States, vsHasChildren);

          end;

        end;

      end

      else

        if DoExpanding(Node) then

        begin

          NeedUpdate := True;

          // expand the node, need to adjust the height

          if not (vsInitialized in Node.States) then

            InitNode(Node);

          if (vsHasChildren in Node.States) and (Node.ChildCount = 0) then

            InitChildren(Node);



          // Avoid setting the vsExpanded style if there are no child nodes.

          if Node.ChildCount > 0 then

          begin

            // Iterate through the child nodes without initializing them. We have to determine the entire height.

            Child := Node.FirstChild;

            repeat

              if vsVisible in Child.States then

              begin

                // Ensure the item height is measured

                MeasureItemHeight(Canvas, Child);



                Inc(HeightDelta, Child.TotalHeight);

              end;

              Child := Child.NextSibling;

            until Child = nil;



            // Getting the display rectangle is already done here as it is needed for toChildrenAbove in any case.

            if (toChildrenAbove in FOptions.FPaintOptions) or (FUpdateCount = 0) then

            begin

              with ToggleData do

              begin

                R1 := GetDisplayRect(Node, NoColumn, False);

                Mode2 := tamNoScroll;

                TotalFit := HeightDelta + Integer(NodeHeight[Node]) <= ClientHeight;



                if toChildrenAbove in FOptions.FPaintOptions then

                begin

                  // The main goal with toChildrenAbove being set is to keep the nodes visual position so the user does

                  // not get confused. Therefore we need to scroll the view when the expanding is done.

                  PosHoldable := TotalFit and (Integer(FRangeY) - ClientHeight >= 0) ;

                  ChildrenInView := (R1.Top - HeightDelta) >= 0;

                  NodeInView := R1.Bottom <= ClientHeight;

                end

                else

                begin

                  PosHoldable := TotalFit;

                  ChildrenInView := R1.Bottom + HeightDelta <= ClientHeight;

                end;



                R1.Bottom := ClientHeight;

              end;

            end;



            if FUpdateCount = 0 then

            begin

              // Do animated expanding if enabled.

              if (ToggleData.R1.Top < ClientHeight) and ([tsPainting, tsExpanding] * FStates = []) and

                (toAnimatedToggle in FOptions.FAnimationOptions)then

              begin

                if tsHint in Self.FStates then

                  Application.CancelHint;

                UpdateWindow(Handle);

                // animated expanding

                with ToggleData do

                begin

                  if toChildrenAbove in FOptions.FPaintOptions then

                  begin

                    // At first check if we hold the position, which is the most common case.

                    if not (toAdvancedAnimatedToggle in FOptions.FAnimationOptions) or

                       (PosHoldable and ( (NodeInView and ChildrenInView) or not

                                          (toAutoScrollOnExpand in FOptions.FAutoOptions) )) then

                    begin

                      Mode1 := tamScrollUp;

                      R1 := Rect(R1.Left, 0, R1.Right, R1.Top);

                      StepsR1 := Min(HeightDelta, R1.Bottom);

                    end

                    else

                    begin

                      // If we will not hold the node's visual position we mostly scroll in both directions.

                      Mode1 := tamScrollDown;

                      Mode2 := tamScrollUp;

                      R2 := Rect(R1.Left, 0, R1.Right, R1.Top);

                      if not (toAutoScrollOnExpand in FOptions.FAutoOptions) then

                      begin

                        // If we shall not or cannot scroll to the desired extent we calculate the new position (with

                        // max FOffsetY applied) and animate it that way.

                        StepsR1 := -FOffsetY - Max(Integer(FRangeY) + HeightDelta - ClientHeight, 0) + HeightDelta;

                        if (Integer(FRangeY) + HeightDelta - ClientHeight) <= 0 then

                          Mode2 := tamNoScroll

                        else

                          StepsR2 := Min(Integer(FRangeY) + HeightDelta - ClientHeight, R2.Bottom);

                      end

                      else

                      begin

                        if TotalFit and NodeInView and (Integer(FRangeY) + HeightDelta > ClientHeight) then

                        begin

                          // If the whole subtree will fit into the client area and the node is currently fully visible,

                          // the first child will be made the top node if possible.

                          if HeightDelta >= R1.Top then

                            StepsR1 := Abs(R1.Top - HeightDelta)

                          else

                            StepsR1 := ClientHeight - Integer(FRangeY);

                        end

                        else

                          if Integer(FRangeY) + HeightDelta <= ClientHeight then

                          begin

                            // We cannot make the first child the top node as we cannot scroll to that extent,

                            // so we do a simple scroll down.

                            Mode2 := tamNoScroll;

                            StepsR1 := HeightDelta;

                          end

                          else

                            // If the subtree does not fit into the client area at once, the expanded node will

                            // be made the bottom node.

                            StepsR1 := ClientHeight - R1.Top - Integer(NodeHeight[Node]);



                        if Mode2 <> tamNoScroll then

                        begin

                          if StepsR1 > 0 then

                            StepsR2 := Min(R1.Top, HeightDelta - StepsR1)

                          else

                          begin

                            // If the node is already at the bottom scrolling is needed.

                            Mode1 := tamNoScroll;

                            StepsR2 := Min(HeightDelta, R1.Bottom);

                          end;

                        end;

                      end;

                    end;

                  end

                  else

                  begin

                    // toChildrenAbove is not set.

                    if (PosHoldable and ChildrenInView) or not (toAutoScrollOnExpand in FOptions.FAutoOptions) or not

                       (toAdvancedAnimatedToggle in FOptions.FAnimationOptions) or (R1.Top <= 0) then

                    begin

                      // If the node will stay at its visual position, do a simple down-scroll.

                      Mode1 := tamScrollDown;

                      Inc(R1.Top, NodeHeight[Node]);

                      StepsR1 := Min(R1.Bottom - R1.Top, HeightDelta);

                    end

                    else

                    begin

                      // We will not hold the nodes visual position so perform a double scroll.

                      Mode1 := tamScrollUp;

                      Mode2 := tamScrollDown;



                      R1.Bottom := R1.Top + Integer(NodeHeight[Node]) + 1;

                      R1.Top := 0;

                      R2 := Rect(R1.Left, R1.Bottom, R1.Right, ClientHeight);



                      StepsR1 := Min(HeightDelta - (ClientHeight - R2.Top), R1.Bottom - Integer(NodeHeight[Node]));

                      StepsR2 := ClientHeight - R2.Top;

                    end;

                  end;



                  if ClientHeight >= R1.Top then

                  begin

                    PrepareAnimation;

                    try

                      Animate(Steps, FAnimationDuration, ToggleCallback, @ToggleData);

                    finally

                      ReleaseDC(Window, DC);

                    end;

                  end;

                end;

              end;

              if toAutoSort in FOptions.FAutoOptions then

                Sort(Node, FHeader.FSortColumn, FHeader.FSortDirection, False);

            end;// if UpdateCount = 0



            Include(Node.States, vsExpanded);

            AdjustTotalHeight(Node, HeightDelta, True);

            if FullyVisible[Node] then

              Inc(FVisibleCount, CountVisibleChildren(Node));



            DoExpanded(Node);

          end;

        end;



      if NeedUpdate then

      begin

        InvalidateCache;

        if FUpdateCount = 0 then

        begin

          ValidateCache;

          if Node.ChildCount > 0 then

          begin

            UpdateRanges;

            UpdateScrollBars(True);

            if [tsPainting, tsExpanding] * FStates = [] then

            begin

              if (vsExpanded in Node.States) and ((toAutoScrollOnExpand in FOptions.FAutoOptions) or

                 (toChildrenAbove in FOptions.FPaintOptions)) then

              begin

                if toChildrenAbove in FOptions.FPaintOptions then

                begin

                  NeedFullInvalidate := True;

                  if (PosHoldable and ChildrenInView and NodeInView) or not

                     (toAutoScrollOnExpand in FOptions.FAutoOptions) then

                    SetOffsetY(FOffsetY - Integer(HeightDelta))

                  else

                    if TotalFit and NodeInView then

                    begin

                      FirstVisible := GetFirstVisible(Node, True);

                      if Assigned(FirstVisible) then // otherwise there is no visible child at all

                        SetOffsetY(FOffsetY - GetDisplayRect(FirstVisible, NoColumn, False).Top);

                    end

                    else

                      BottomNode := Node;

                end

                else

                begin

                  // Scroll as much child nodes into view as possible if the node has been expanded.

                  if PosHoldable then

                    NeedFullInvalidate := ScrollIntoView(GetLastVisible(Node, True), False)

                  else

                  begin

                    TopNode := Node;

                    NeedFullInvalidate := True;

                  end;

                end;

              end

              else

              begin

                // If we have collapsed the node or toAutoScrollOnExpand is not set, we try to keep the nodes

                // visual position.

                if toChildrenAbove in FOptions.FPaintOptions then

                  SetOffsetY(FOffsetY - Integer(HeightDelta));

                NeedFullInvalidate := True;

              end;

            end;



            //UpdateScrollBars(True); Moved up



            // Check for automatically scrolled tree.

            if NeedFullInvalidate then

              Invalidate

            else

              InvalidateToBottom(Node);

          end

          else

            InvalidateNode(Node);

        end

        else

          UpdateRanges;

      end;



    finally

      Exclude(Node.States, vsToggling);

      if not TogglingTree then

        DoStateChange([], [tsToggling]);

    end;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.UpdateAction(Action: TBasicAction): Boolean;



// Support for standard actions.



begin

  if not Focused then

    Result := inherited UpdateAction(Action)

  else

  begin

    Result := (Action is TEditCut) or (Action is TEditCopy) or (Action is TEditDelete);



    if Result then

      TAction(Action).Enabled := (FSelectionCount > 0) and ((Action is TEditDelete) or (FClipboardFormats.Count > 0))

    else

    begin

      Result := Action is TEditPaste;

      if Result then

        TAction(Action).Enabled := True

      else

      begin

        Result := Action is TEditSelectAll;

        if Result then

          TAction(Action).Enabled := (toMultiSelect in FOptions.FSelectionOptions) and (FVisibleCount > 0)

        else

          Result := inherited UpdateAction(Action);

      end;

    end;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.UpdateHorizontalRange;



begin

  if FHeader.UseColumns then

    FRangeX := FHeader.FColumns.TotalWidth

  else

    FRangeX := GetMaxRightExtend;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.UpdateHorizontalScrollBar(DoRepaint: Boolean);



var

  ScrollInfo: TScrollInfo;



begin

  UpdateHorizontalRange;



  if (tsUpdating in FStates) or not HandleAllocated then

    Exit;



  // Adjust effect scroll offset depending on bidi mode.

  if UseRightToLeftAlignment then

    FEffectiveOffsetX := Integer(FRangeX) - ClientWidth + FOffsetX

  else

    FEffectiveOffsetX := -FOffsetX;



  if FScrollBarOptions.ScrollBars in [{$if CompilerVersion >= 24}System.UITypes.TScrollStyle.{$ifend}ssHorizontal, {$if CompilerVersion >= 24}System.UITypes.TScrollStyle.{$ifend}ssBoth] then

  begin

    ZeroMemory (@ScrollInfo, SizeOf(ScrollInfo));

    ScrollInfo.cbSize := SizeOf(ScrollInfo);

    ScrollInfo.fMask := SIF_ALL;

    GetScrollInfo(Handle, SB_HORZ, ScrollInfo);



    if (Integer(FRangeX) > ClientWidth) or FScrollBarOptions.AlwaysVisible then

    begin

      DoShowScrollBar(SB_HORZ, True);



      ScrollInfo.nMin := 0;

      ScrollInfo.nMax := FRangeX;

      ScrollInfo.nPos := FEffectiveOffsetX;

      ScrollInfo.nPage := Max(0, ClientWidth + 1);



      ScrollInfo.fMask := SIF_ALL or ScrollMasks[FScrollBarOptions.AlwaysVisible];

      SetScrollInfo(Handle, SB_HORZ, ScrollInfo, DoRepaint);

    end

    else

    begin

      ScrollInfo.nMin := 0;

      ScrollInfo.nMax := 0;

      ScrollInfo.nPos := 0;

      ScrollInfo.nPage := 0;

      DoShowScrollBar(SB_HORZ, False);

      SetScrollInfo(Handle, SB_HORZ, ScrollInfo, False);

    end;



    // Since the position is automatically changed if it doesn't meet the range

    // we better read the current position back to stay synchronized.

    FEffectiveOffsetX := GetScrollPos(Handle, SB_HORZ);

    if UseRightToLeftAlignment then

      SetOffsetX(-Integer(FRangeX) + ClientWidth + FEffectiveOffsetX)

    else

      SetOffsetX(-FEffectiveOffsetX);

  end

  else

  begin

    DoShowScrollBar(SB_HORZ, False);



    // Reset the current horizontal offset to account for window resize etc.

    SetOffsetX(FOffsetX);

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.UpdateRanges;



begin

  UpdateVerticalRange;

  UpdateHorizontalRange;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.UpdateScrollBars(DoRepaint: Boolean);



// adjusts scrollbars to reflect current size and paint offset of the tree



begin

  if HandleAllocated then

  begin

    UpdateVerticalScrollBar(DoRepaint);

    UpdateHorizontalScrollBar(DoRepaint);

    Perform(CM_UPDATE_VCLSTYLE_SCROLLBARS,0,0);

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.UpdateVerticalRange;



begin

  // Total node height includes the height of the invisible root node.

  if FRoot.TotalHeight < FDefaultNodeHeight then

    FRoot.TotalHeight := FDefaultNodeHeight;

  FRangeY := FRoot.TotalHeight - FRoot.NodeHeight + FBottomSpace;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.UpdateVerticalScrollBar(DoRepaint: Boolean);



var

  ScrollInfo: TScrollInfo;



begin

  UpdateVerticalRange;



  if tsUpdating in FStates then

    Exit;



  if FScrollBarOptions.ScrollBars in [ssVertical, ssBoth] then

  begin

    ScrollInfo.cbSize := SizeOf(ScrollInfo);

    ScrollInfo.fMask := SIF_ALL;

    GetScrollInfo(Handle, SB_VERT, ScrollInfo);



    if (Integer(FRangeY) > ClientHeight) or FScrollBarOptions.AlwaysVisible then

    begin

      DoShowScrollBar(SB_VERT, True);



      ScrollInfo.nMin := 0;

      ScrollInfo.nMax := FRangeY;

      ScrollInfo.nPos := -FOffsetY;

      ScrollInfo.nPage := Max(0, ClientHeight + 1);



      ScrollInfo.fMask := SIF_ALL or ScrollMasks[FScrollBarOptions.AlwaysVisible];

      SetScrollInfo(Handle, SB_VERT, ScrollInfo, DoRepaint);

    end

    else

    begin

      ScrollInfo.nMin := 0;

      ScrollInfo.nMax := 0;

      ScrollInfo.nPos := 0;

      ScrollInfo.nPage := 0;

      DoShowScrollBar(SB_VERT, False);

      SetScrollInfo(Handle, SB_VERT, ScrollInfo, False);

    end;



    // Since the position is automatically changed if it doesn't meet the range

    // we better read the current position back to stay synchronized.

    SetOffsetY(-GetScrollPos(Handle, SB_VERT));

  end

  else

  begin

    DoShowScrollBar(SB_VERT, False);



    // Reset the current vertical offset to account for window resize etc.

    SetOffsetY(FOffsetY);

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



function TBaseVirtualTree.UseRightToLeftReading: Boolean;



// The tree can handle right-to-left reading also on non-middle-east systems, so we cannot use the same function as

// it is implemented in TControl.



begin

  Result := BiDiMode <> bdLeftToRight;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.ValidateChildren(Node: PVirtualNode; Recursive: Boolean);



// Ensures that the children of the given node (and all their children, if Recursive is True) are initialized.

// Node must already be initialized



var

  Child: PVirtualNode;



begin

  if Node = nil then

    Node := FRoot;



  if (vsHasChildren in Node.States) and (Node.ChildCount = 0) then

    InitChildren(Node);

  Child := Node.FirstChild;

  while Assigned(Child) do

  begin

    ValidateNode(Child, Recursive);

    Child := Child.NextSibling;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TBaseVirtualTree.ValidateNode(Node: PVirtualNode; Recursive: Boolean);



// Ensures that the given node (and all its children, if Recursive is True) are initialized.



var

  Child: PVirtualNode;



begin

  if Node = nil then

    Node := FRoot

  else

    if not (vsInitialized in Node.States) then

      InitNode(Node);



  if Recursive then

  begin

    if (vsHasChildren in Node.States) and (Node.ChildCount = 0) then

      InitChildren(Node);

    Child := Node.FirstChild;

    while Assigned(Child) do

    begin

      ValidateNode(Child, Recursive);

      Child := Child.NextSibling;

    end;

  end;

end;



//----------------- TCustomStringTreeOptions ---------------------------------------------------------------------------



constructor TCustomStringTreeOptions.Create(AOwner: TBaseVirtualTree);



begin

  inherited;



  FStringOptions := DefaultStringOptions;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TCustomStringTreeOptions.SetStringOptions(const Value: TVTStringOptions);



var

  ChangedOptions: TVTStringOptions;



begin

  if FStringOptions <> Value then

  begin

    // Exclusive ORing to get all entries wich are in either set but not in both.

    ChangedOptions := FStringOptions + Value - (FStringOptions * Value);

    FStringOptions := Value;

    with FOwner do

      if (toShowStaticText in ChangedOptions) and not (csLoading in ComponentState) and HandleAllocated then

        Invalidate;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TCustomStringTreeOptions.AssignTo(Dest: TPersistent);



begin

  if Dest is TCustomStringTreeOptions then

  begin

    with Dest as TCustomStringTreeOptions do

      StringOptions := Self.StringOptions;

  end;



  // Let ancestors assign their options to the destination class.

  inherited;

end;



//----------------- TVTEdit --------------------------------------------------------------------------------------------



// Implementation of a generic node caption editor.



constructor TVTEdit.Create(Link: TStringEditLink);



begin

  inherited Create(nil);

  ShowHint := False;

  ParentShowHint := False;

  // This assignment increases the reference count for the interface.

  FRefLink := Link;

  // This reference is used to access the link.

  FLink := Link;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TVTEdit.CMAutoAdjust(var Message: TMessage);



begin

  AutoAdjustSize;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TVTEdit.CMExit(var Message: TMessage);



begin

  if Assigned(FLink) and not FLink.FStopping then

    with FLink, FTree do

    begin

      if (toAutoAcceptEditChange in TreeOptions.StringOptions) then

        DoEndEdit

      else

        DoCancelEdit;

    end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TVTEdit.CMRelease(var Message: TMessage);



begin

  Free;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TVTEdit.CNCommand(var Message: TWMCommand);



begin

  if Assigned(FLink) and Assigned(FLink.FTree) and (Message.NotifyCode = EN_UPDATE) and

    not (vsMultiline in FLink.FNode.States) then

    // Instead directly calling AutoAdjustSize it is necessary on Win9x/Me to decouple this notification message

    // and eventual resizing. Hence we use a message to accomplish that.

    AutoAdjustSize()

  else

    inherited;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TVTEdit.WMChar(var Message: TWMChar);



begin

  if not (Message.CharCode in [VK_ESCAPE, VK_TAB]) then

    inherited;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TVTEdit.WMDestroy(var Message: TWMDestroy);



begin

  // If editing stopped by other means than accept or cancel then we have to do default processing for

  // pending changes.

  if Assigned(FLink) and not FLink.FStopping then

  begin

    with FLink, FTree do

    begin

      if (toAutoAcceptEditChange in TreeOptions.StringOptions) and Modified then

        Text[FNode, FColumn] := FEdit.Text;

    end;

    FLink := nil;

    FRefLink := nil;

  end;



  inherited;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TVTEdit.WMGetDlgCode(var Message: TWMGetDlgCode);



begin

  inherited;



  Message.Result := Message.Result or DLGC_WANTALLKEYS or DLGC_WANTTAB or DLGC_WANTARROWS;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TVTEdit.WMKeyDown(var Message: TWMKeyDown);



// Handles some control keys.



var

  Shift: TShiftState;

  EndEdit: Boolean;

  Tree: TBaseVirtualTree;

  NextNode: PVirtualNode;

begin

  Tree := FLink.FTree;

  case Message.CharCode of

    VK_ESCAPE:

      begin

        Tree.DoCancelEdit;

        Tree.SetFocus;

      end;

    VK_RETURN:

      begin

        EndEdit := not (vsMultiline in FLink.FNode.States);

        if not EndEdit then

        begin

          // If a multiline node is being edited the finish editing only if Ctrl+Enter was pressed,

          // otherwise allow to insert line breaks into the text.

          Shift := KeyDataToShiftState(Message.KeyData);

          EndEdit := ssCtrl in Shift;

        end;

        if EndEdit then

        begin

          Tree := FLink.FTree;

          FLink.FTree.InvalidateNode(FLink.FNode);

          FLink.FTree.DoEndEdit;

          Tree.SetFocus;

        end;

      end;

    VK_UP:

      begin

        if not (vsMultiline in FLink.FNode.States) then

          Message.CharCode := VK_LEFT;

        inherited;

      end;

    VK_DOWN:

      begin

        if not (vsMultiline in FLink.FNode.States) then

          Message.CharCode := VK_RIGHT;

        inherited;

      end;

    VK_TAB:

      begin

        if Tree.IsEditing then

        begin

          Tree.InvalidateNode(FLink.FNode);

          NextNode := Tree.GetNextVisible(FLink.FNode, True);

          Tree.EndEditNode;

          Tree.FocusedNode := NextNode;

          if Tree.CanEdit(Tree.FocusedNode, Tree.FocusedColumn) then

            Tree.DoEdit;

        end;

      end;

    Ord('A'):

      begin

        if Tree.IsEditing and ([ssCtrl] = KeyboardStateToShiftState) then

        begin

          Self.SelectAll();

          Message.CharCode := 0;

        end;

      end;

  else

    inherited;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TVTEdit.AutoAdjustSize;



// Changes the size of the edit to accomodate as much as possible of its text within its container window.

// NewChar describes the next character which will be added to the edit's text.



var

  DC: HDC;

  Size: TSize;

  LastFont: THandle;



begin

  if not (vsMultiline in FLink.FNode.States) and not (toGridExtensions in FLink.FTree.FOptions.FMiscOptions{see issue #252}) then

  begin

    // avoid flicker

    SendMessage(Handle, WM_SETREDRAW, 0, 0);



    DC := GetDC(Handle);

    LastFont := SelectObject(DC, Font.Handle);

    try

      // Read needed space for the current text.

      {$ifdef TntSupport}

        GetTextExtentPoint32W(DC, PWideChar(Text), Length(Text), Size);

      {$else}

        GetTextExtentPoint32(DC, PChar(Text+'yG'), Length(Text)+2, Size);

      {$endif TntSupport}

      Inc(Size.cx, 2 * FLink.FTree.FTextMargin);

      Inc(Size.cy, 2 * FLink.FTree.FTextMargin);

      Height := Max(Size.cy, Height); // Ensure a minimum height so that the edit field's content and cursor are displayed correctly. See #159

      // Repaint associated node if the edit becomes smaller.

      if Size.cx < Width then

        FLink.FTree.Invalidate();



      if FLink.FAlignment = taRightJustify then

        FLink.SetBounds(Rect(Left + Width - Size.cx, Top, Left + Width, Top + Height))

      else

        FLink.SetBounds(Rect(Left, Top, Left + Size.cx, Top + Height));

    finally

      SelectObject(DC, LastFont);

      ReleaseDC(Handle, DC);

      SendMessage(Handle, WM_SETREDRAW, 1, 0);

    end;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TVTEdit.CreateParams(var Params: TCreateParams);



begin

  inherited;



  // Only with multiline style we can use the text formatting rectangle.

  // This does not harm formatting as single line control, if we don't use word wrapping.

  with Params do

  begin

    Style := Style or ES_MULTILINE;

    if vsMultiline in FLink.FNode.States then

      Style := Style and not (ES_AUTOHSCROLL or WS_HSCROLL) or WS_VSCROLL or ES_AUTOVSCROLL;

    if tsUseThemes in FLink.FTree.FStates then

    begin

      Style := Style and not WS_BORDER;

      ExStyle := ExStyle or WS_EX_CLIENTEDGE;

    end

    else

    begin

      Style := Style or WS_BORDER;

      ExStyle := ExStyle and not WS_EX_CLIENTEDGE;

    end;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TVTEdit.Release;



begin

  if HandleAllocated then

    PostMessage(Handle, CM_RELEASE, 0, 0);

end;



//----------------- TStringEditLink ------------------------------------------------------------------------------------



constructor TStringEditLink.Create;



begin

  inherited;

  FEdit := TVTEdit.Create(Self);

  with FEdit do

  begin

    Visible := False;

    BorderStyle := bsSingle;

    AutoSize := False;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



destructor TStringEditLink.Destroy;



begin

  if Assigned(FEdit) then

    FEdit.Release;

  inherited;

end;



//----------------------------------------------------------------------------------------------------------------------



function TStringEditLink.BeginEdit: Boolean;



// Notifies the edit link that editing can start now. descendants may cancel node edit

// by returning False.



begin

  Result := not FStopping;

  if Result then

  begin

    FEdit.Show;

    FEdit.SelectAll;

    FEdit.SetFocus;

    FEdit.AutoAdjustSize;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TStringEditLink.SetEdit(const Value: TVTEdit);



begin

  if Assigned(FEdit) then

    FEdit.Free;

  FEdit := Value;

end;



//----------------------------------------------------------------------------------------------------------------------



function TStringEditLink.CancelEdit: Boolean;



begin

  Result := not FStopping;

  if Result then

  begin

    FStopping := True;

    FEdit.Hide;

    FTree.CancelEditNode;

    FEdit.FLink := nil;

    FEdit.FRefLink := nil;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



function TStringEditLink.EndEdit: Boolean;



begin

  Result := not FStopping;

  if Result then

  try

    FStopping := True;

    if FEdit.Modified then

      FTree.Text[FNode, FColumn] := FEdit.Text;

    FEdit.Hide;

    FEdit.FLink := nil;

    FEdit.FRefLink := nil;

  except

    FStopping := False;

    raise;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



function TStringEditLink.GetBounds: TRect;



begin

  Result := FEdit.BoundsRect;

end;



//----------------------------------------------------------------------------------------------------------------------



function TStringEditLink.PrepareEdit(Tree: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex): Boolean;



// Retrieves the true text bounds from the owner tree.



var

  Text: UnicodeString;



begin

  Result := Tree is TCustomVirtualStringTree;

  if Result then

  begin

    if not Assigned(FEdit) then

    begin

      FEdit := TVTEdit.Create(Self);

      FEdit.Visible := False;

      FEdit.BorderStyle := bsSingle;

      FEdit.AutoSize := False;

    end;

    FTree := Tree as TCustomVirtualStringTree;

    FNode := Node;

    FColumn := Column;

    // Initial size, font and text of the node.

    FTree.GetTextInfo(Node, Column, FEdit.Font, FTextBounds, Text);

    FEdit.Font.Color := clWindowText;

    FEdit.Parent := Tree;

    FEdit.RecreateWnd;

    FEdit.HandleNeeded;

    FEdit.Text := Text;



    if Column <= NoColumn then

    begin

      FEdit.BidiMode := FTree.BidiMode;

      FAlignment := FTree.Alignment;

    end

    else

    begin

      FEdit.BidiMode := FTree.Header.Columns[Column].BidiMode;

      FAlignment := FTree.Header.Columns[Column].Alignment;

    end;



    if FEdit.BidiMode <> bdLeftToRight then

      ChangeBidiModeAlignment(FAlignment);

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TStringEditLink.ProcessMessage(var Message: TMessage);



begin

  FEdit.WindowProc(Message);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TStringEditLink.SetBounds(R: TRect);



// Sets the outer bounds of the edit control and the actual edit area in the control.



var

  lOffset: Integer;



begin

  if not FStopping then

  begin

    // Set the edit's bounds but make sure there's a minimum width and the right border does not

    // extend beyond the parent's left/right border.

    if R.Left < 0 then

      R.Left := 0;

    if R.Right - R.Left < 30 then

    begin

      if FAlignment = taRightJustify then

        R.Left := R.Right - 30

      else

        R.Right := R.Left + 30;

    end;

    if R.Right > FTree.ClientWidth then

      R.Right := FTree.ClientWidth;

    FEdit.BoundsRect := R;



    // The selected text shall exclude the text margins and be centered vertically.

    // We have to take out the two pixel border of the edit control as well as a one pixel "edit border" the

    // control leaves around the (selected) text.

    R := FEdit.ClientRect;

    lOffset := IfThen(vsMultiline in FNode.States, 0, 2);

    if tsUseThemes in FTree.FStates then

      Inc(lOffset);

    InflateRect(R, -FTree.FTextMargin + lOffset, lOffset);

    if not (vsMultiline in FNode.States) then

      OffsetRect(R, 0, FTextBounds.Top - FEdit.Top);

    R.Top := Max(-1, R.Top); // A value smaller than -1 will prevent the edit cursor from being shown by Windows, see issue #159

    R.Left := Max(-1, R.Left);

    SendMessage(FEdit.Handle, EM_SETRECTNP, 0, LPARAM(@R));

  end;

end;



//----------------- TCustomVirtualString -------------------------------------------------------------------------------



constructor TCustomVirtualStringTree.Create(AOwner: TComponent);



begin

  inherited;

  FPreviouslySelected := nil;

  FDefaultText := 'Node';

  FInternalDataOffset := AllocateInternalDataArea(SizeOf(Cardinal));

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TCustomVirtualStringTree.GetRenderStartValues(Source: TVSTTextSourceType; var Node: PVirtualNode;

  var NextNodeProc: TGetNextNodeProc);



begin

  case Source of

    tstInitialized:

      begin

        Node := GetFirstInitialized;

        NextNodeProc := GetNextInitialized;

      end;

    tstSelected:

      begin

        Node := GetFirstSelected;

        NextNodeProc := GetNextSelected;

      end;

    tstCutCopySet:

      begin

        Node := GetFirstCutCopy;

        NextNodeProc := GetNextCutCopy;

      end;

    tstVisible:

      begin

        Node := GetFirstVisible(nil, True);

        NextNodeProc := GetNextVisible;

      end;

    tstChecked:

      begin

        Node := GetFirstChecked;

        NextNodeProc := GetNextChecked;

      end;

  else // tstAll

    Node := GetFirst;

    NextNodeProc := GetNext;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TCustomVirtualStringTree.GetDataFromGrid(const AStrings: TStringList;

  const IncludeHeading: Boolean);

var

  LColIndex   : Integer;

  LStartIndex : Integer;

  LAddString  : string;

  LCellText   : string;

  LChildNode  : PVirtualNode;

begin

  { Start from the First column. }

  LStartIndex := 0;



  { Do it for Header first }

  if IncludeHeading then

  begin

    LAddString := EmptyStr;

    for LColIndex := LStartIndex to Pred(Header.Columns.Count) do

    begin

      if (LColIndex > LStartIndex) then

        LAddString := LAddString + ',';

      LAddString := LAddString + AnsiQuotedStr(Header.Columns.Items[LColIndex].Text, '"');

    end;//for

    AStrings.Add(LAddString);

  end;//if



  { Loop thru the virtual tree for Data }

  LChildNode := GetFirst;

  while Assigned(LChildNode) do

  begin

    LAddString := EmptyStr;



    { Read for each column and then populate the text }

    for LColIndex := LStartIndex to Pred(Header.Columns.Count) do

    begin

      LCellText := Text[LChildNode, LColIndex];

      if (LCellText = EmptyStr) then

        LCellText := ' ';

      if (LColIndex > LStartIndex) then

        LAddString := LAddString + ',';

      LAddString := LAddString + AnsiQuotedStr(LCellText, '"');

    end;//for - Header.Columns.Count



    AStrings.Add(LAddString);

    LChildNode := LChildNode.NextSibling;

  end;//while Assigned(LChildNode);

end;



function TCustomVirtualStringTree.GetImageText(Node: PVirtualNode;

  Kind: TVTImageKind; Column: TColumnIndex): UnicodeString;

begin

  Assert(Assigned(Node), 'Node must not be nil.');



  if not (vsInitialized in Node.States) then

    InitNode(Node);

  Result := '';



  DoGetImageText(Node, Kind, Column, Result);

end;



//----------------------------------------------------------------------------------------------------------------------



function TCustomVirtualStringTree.GetOptions: TCustomStringTreeOptions;



begin

  Result := FOptions as TCustomStringTreeOptions;

end;



//----------------------------------------------------------------------------------------------------------------------



function TCustomVirtualStringTree.GetStaticText(Node: PVirtualNode; Column: TColumnIndex): UnicodeString;



begin

  Assert(Assigned(Node), 'Node must not be nil.');



  if not (vsInitialized in Node.States) then

    InitNode(Node);

  Result := '';



  DoGetText(Node, Column, ttStatic, Result);

end;





//----------------------------------------------------------------------------------------------------------------------



function TCustomVirtualStringTree.GetText(Node: PVirtualNode; Column: TColumnIndex): UnicodeString;



begin

  Assert(Assigned(Node), 'Node must not be nil.');



  if not (vsInitialized in Node.States) then

    InitNode(Node);

  Result := FDefaultText;



  DoGetText(Node, Column, ttNormal, Result);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TCustomVirtualStringTree.InitializeTextProperties(var PaintInfo: TVTPaintInfo);



// Initializes default values for customization in PaintNormalText.



begin

  with PaintInfo do

  begin

    // Set default font values first.

    Canvas.Font := Font;

    if Enabled then // Es werden sonst nur die Farben verwendet von Font die an  Canvas.Font übergeben wurden

       Canvas.Font.Color := FColors.NodeFontColor

    else

      Canvas.Font.Color := FColors.DisabledColor;



    if (toHotTrack in FOptions.FPaintOptions) and (Node = FCurrentHotNode) then

    begin

      if not (tsUseExplorerTheme in FStates) then

      begin

        Canvas.Font.Style := Canvas.Font.Style + [fsUnderline];

        Canvas.Font.Color := FColors.HotColor;

      end;

    end;



    // Change the font color only if the node also is drawn in selected style.

    if poDrawSelection in PaintOptions then

    begin

      if (Column = FFocusedColumn) or (toFullRowSelect in FOptions.FSelectionOptions) then

      begin

        if Node = FDropTargetNode then

        begin

          if ((FLastDropMode = dmOnNode) or (vsSelected in Node.States)) and not

             (tsUseExplorerTheme in FStates) then

            Canvas.Font.Color := FColors.SelectionTextColor;

        end

        else

          if vsSelected in Node.States then

          begin

            if (Focused or (toPopupMode in FOptions.FPaintOptions)) and not

               (tsUseExplorerTheme in FStates) then

            Canvas.Font.Color := FColors.SelectionTextColor;

          end;

      end;

    end;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TCustomVirtualStringTree.PaintNormalText(var PaintInfo: TVTPaintInfo; TextOutFlags: Integer;

  Text: UnicodeString);



// This method is responsible for painting the given text to target canvas (under consideration of the given rectangles).

// The text drawn here is considered as the normal text in a node.

// Note: NodeWidth is the actual width of the text to be drawn. This does not necessarily correspond to the width of

//       the node rectangle. The clipping rectangle comprises the entire node (including tree lines, buttons etc.).



var

  TripleWidth: Integer;

  R: TRect;

  DrawFormat: Cardinal;

  Size: TSize;

  Height: Integer;



begin

  InitializeTextProperties(PaintInfo);

  with PaintInfo do

  begin

    R := ContentRect;

    Canvas.TextFlags := 0;

    InflateRect(R, -FTextMargin, 0);



    // Multiline nodes don't need special font handling or text manipulation.

    // Note: multiline support requires the Unicode version of DrawText, which is able to do word breaking.

    //       The emulation in this unit does not support this so we have to use the OS version. However

    //       DrawTextW is only available on NT/2000/XP and up. Hence there is only partial multiline support

    //       for 9x/Me.

    if vsMultiline in Node.States then

    begin

      DoPaintText(Node, Canvas, Column, ttNormal);

      Height := ComputeNodeHeight(Canvas, Node, Column);

      // Disabled node color overrides all other variants.

      if (vsDisabled in Node.States) or not Enabled then

        Canvas.Font.Color := FColors.DisabledColor;



      // The edit control flag will ensure that no partial line is displayed, that is, only lines

      // which are (vertically) fully visible are drawn.

      DrawFormat := DT_NOPREFIX or DT_WORDBREAK or DT_END_ELLIPSIS or DT_EDITCONTROL or AlignmentToDrawFlag[Alignment];

      if BidiMode <> bdLeftToRight then

        DrawFormat := DrawFormat or DT_RTLREADING;



      // Center the text vertically if it fits entirely into the content rect.

      if R.Bottom - R.Top > Height then

        InflateRect(R, 0, (Height - R.Bottom - R.Top) div 2);

    end

    else

    begin

      FFontChanged := False;

      TripleWidth := FEllipsisWidth;

      DoPaintText(Node, Canvas, Column, ttNormal);

      if FFontChanged then

      begin

        // If the font has been changed then the ellipsis width must be recalculated.

        TripleWidth := 0;

        // Recalculate also the width of the normal text.

        GetTextExtentPoint32W(Canvas.Handle, PWideChar(Text), Length(Text), Size);

        NodeWidth := Size.cx + 2 * FTextMargin;

      end;



      // Disabled node color overrides all other variants.

      if (vsDisabled in Node.States) or not Enabled then

        Canvas.Font.Color := FColors.DisabledColor;



      DrawFormat := DT_NOPREFIX or DT_VCENTER or DT_SINGLELINE;

      if BidiMode <> bdLeftToRight then

        DrawFormat := DrawFormat or DT_RTLREADING;

      // Check if the text must be shortend.

      if (Column > -1) and ((NodeWidth - 2 * FTextMargin) > R.Right - R.Left) then

      begin

        Text := DoShortenString(Canvas, Node, Column, Text, R.Right - R.Left, TripleWidth);

        if Alignment = taRightJustify then

          DrawFormat := DrawFormat or DT_RIGHT

        else

          DrawFormat := DrawFormat or DT_LEFT;

      end

      else

        DrawFormat := DrawFormat or AlignmentToDrawFlag[Alignment];

    end;



    if Canvas.TextFlags and ETO_OPAQUE = 0 then

      SetBkMode(Canvas.Handle, TRANSPARENT)

    else

      SetBkMode(Canvas.Handle, OPAQUE);



    DoTextDrawing(PaintInfo, Text, R, DrawFormat);

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TCustomVirtualStringTree.PaintStaticText(const PaintInfo: TVTPaintInfo; TextOutFlags: Integer;

  const Text: UnicodeString);



// This method retrives and draws the static text bound to a particular node.



var

  R: TRect;

  DrawFormat: Cardinal;



begin

  with PaintInfo do

  begin

    Canvas.Font := Font;

    if toFullRowSelect in FOptions.FSelectionOptions then

    begin

      if Node = FDropTargetNode then

      begin

        if (FLastDropMode = dmOnNode) or (vsSelected in Node.States) then

          Canvas.Font.Color := FColors.SelectionTextColor

        else

          Canvas.Font.Color := FColors.NodeFontColor;

      end

      else

        if vsSelected in Node.States then

        begin

          if Focused or (toPopupMode in FOptions.FPaintOptions) then

          Canvas.Font.Color := FColors.SelectionTextColor

          else

            Canvas.Font.Color := FColors.NodeFontColor;

        end;

    end;



    DrawFormat := DT_NOPREFIX or DT_VCENTER or DT_SINGLELINE;

    Canvas.TextFlags := 0;

    DoPaintText(Node, Canvas, Column, ttStatic);



    // Disabled node color overrides all other variants.

    if (vsDisabled in Node.States) or not Enabled then

      Canvas.Font.Color := FColors.DisabledColor;



    R := ContentRect;

    if Alignment = taRightJustify then

      Dec(R.Right, NodeWidth + FTextMargin)

    else

      Inc(R.Left, NodeWidth + FTextMargin);



    if Canvas.TextFlags and ETO_OPAQUE = 0 then

      SetBkMode(Canvas.Handle, TRANSPARENT)

    else

      SetBkMode(Canvas.Handle, OPAQUE);

    Windows.DrawTextW(Canvas.Handle, PWideChar(Text), Length(Text), R, DrawFormat);

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TCustomVirtualStringTree.ReadText(Reader: TReader);



begin

  case Reader.NextValue of

    vaLString, vaString:

      SetDefaultText(Reader.ReadString);

  else

    SetDefaultText(Reader.{$if CompilerVersion >= 23}ReadString{$else}ReadWideString{$ifend});

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



function TCustomVirtualStringTree.SaveToCSVFile(

  const FileNameWithPath: TFileName; const IncludeHeading: Boolean): Boolean;

var

  LResultList : TStringList;

begin

  Result := False;

  if (FileNameWithPath = '') then

    Exit;



  LResultList := TStringList.Create;

  try

    { Get the data from grid. }

    GetDataFromGrid(LResultList, IncludeHeading);

    { Save File to Disk }

    LResultList.SaveToFile(FileNameWithPath);

    Result := True;

  finally

    FreeAndNil(LResultList);

  end;//try-finally

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TCustomVirtualStringTree.SetDefaultText(const Value: UnicodeString);



begin

  if FDefaultText <> Value then

  begin

    FDefaultText := Value;

    if not (csLoading in ComponentState) then

      Invalidate;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TCustomVirtualStringTree.SetOptions(const Value: TCustomStringTreeOptions);



begin

  FOptions.Assign(Value);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TCustomVirtualStringTree.SetText(Node: PVirtualNode; Column: TColumnIndex; const Value: UnicodeString);



begin

  DoNewText(Node, Column, Value);

  InvalidateNode(Node);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TCustomVirtualStringTree.WriteText(Writer: TWriter);



begin

  Writer.{$IF CompilerVersion >= 20}WriteString{$else}WriteWideString{$ifend}(FDefaultText);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TCustomVirtualStringTree.WMSetFont(var Msg: TWMSetFont);



// Whenever a new font is applied to the tree some default values are determined to avoid frequent

// determination of the same value.



var

  MemDC: HDC;

  Run: PVirtualNode;

  TM: TTextMetric;

  Size: TSize;

  Data: PInteger;



begin

  inherited;



  MemDC := CreateCompatibleDC(0);

  try

    SelectObject(MemDC, Msg.Font);

    GetTextMetrics(MemDC, TM);

    FTextHeight := TM.tmHeight;



    GetTextExtentPoint32W(MemDC, '...', 3, Size);

    FEllipsisWidth := Size.cx;

  finally

    DeleteDC(MemDC);

  end;



  // Have to reset all node widths.

  Run := FRoot.FirstChild;

  while Assigned(Run) do

  begin

    Data := InternalData(Run);

    if Assigned(Data) then

      Data^ := 0;

    Run := GetNextNoInit(Run);

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



function TCustomVirtualStringTree.AddChild(Parent: PVirtualNode; UserData: Pointer): PVirtualNode;

var

  NewNodeText: UnicodeString;

begin

  Result := inherited AddChild(Parent, UserData);

  // Restore the prviously restored node if the caption of this node is knwon and no other node was selected

  if (toRestoreSelection in TreeOptions.SelectionOptions) and Assigned(FPreviouslySelected) and Assigned(OnGetText) then

  begin

    // See if this was the previously selected node and restore it in this case

    Self.OnGetText(Self, Result, 0, ttNormal, NewNodeText);

    if FPreviouslySelected.IndexOf(NewNodeText) >= 0 then

    begin

      // Select this node and make sure that the parent node is expanded

      Include(FStates, tsPreviouslySelectedLocked);

      try

        Self.Selected[Result] := True;

      finally

        Exclude(FStates, tsPreviouslySelectedLocked);

      end;

      // if a there is a selected node now, then make sure that it is visible

      if Self.GetFirstSelected <> nil then

        Self.ScrollIntoView(Self.GetFirstSelected, True);

    end;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TCustomVirtualStringTree.AdjustPaintCellRect(var PaintInfo: TVTPaintInfo; var NextNonEmpty: TColumnIndex);



// In the case a node spans several columns (if enabled) we need to determine how many columns.

// Note: the autospan feature can only be used with left-to-right layout.



begin

  if (toAutoSpanColumns in FOptions.FAutoOptions) and FHeader.UseColumns and (PaintInfo.BidiMode = bdLeftToRight) then

    with FHeader.FColumns, PaintInfo do

    begin

      // Start with the directly following column.

      NextNonEmpty := GetNextVisibleColumn(Column);



      // Auto spanning columns can only be used for left-to-right directionality because the tree is drawn

      // from left to right. For RTL directionality it would be necessary to draw it from right to left.

      // While this could be managed, it becomes impossible when directionality is mixed.

      repeat

        if (NextNonEmpty = InvalidColumn) or not ColumnIsEmpty(Node, NextNonEmpty) or

          (Items[NextNonEmpty].BidiMode <> bdLeftToRight) then

          Break;

        Inc(CellRect.Right, Items[NextNonEmpty].Width);

        NextNonEmpty := GetNextVisibleColumn(NextNonEmpty);

      until False;

    end

    else

      inherited;

end;



//----------------------------------------------------------------------------------------------------------------------



function TCustomVirtualStringTree.CalculateStaticTextWidth(Canvas: TCanvas; Node: PVirtualNode; Column: TColumnIndex;

  Text: UnicodeString): Integer;



begin

  Result := 0;

  if (Length(Text) > 0) and (Alignment <> taCenter) and not

     (vsMultiline in Node.States) and (toShowStaticText in TreeOptions.FStringOptions) then

  begin

    DoPaintText(Node, Canvas, Column, ttStatic);



    Inc(Result, DoTextMeasuring(Canvas, Node, Column, Text).cx);

    Inc(Result, FTextMargin);

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



function TCustomVirtualStringTree.CalculateTextWidth(Canvas: TCanvas; Node: PVirtualNode; Column: TColumnIndex;

  Text: UnicodeString): Integer;



// Determines the width of the given text.



begin

  Result := 2 * FTextMargin;

  if Length(Text) > 0 then

  begin

    Canvas.Font := Font;

    DoPaintText(Node, Canvas, Column, ttNormal);



    Inc(Result, DoTextMeasuring(Canvas, Node, Column, Text).cx);

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



function TCustomVirtualStringTree.ColumnIsEmpty(Node: PVirtualNode; Column: TColumnIndex): Boolean;



// For hit tests it is necessary to consider cases where columns are empty and automatic column spanning is enabled.

// This method simply checks the given column's text and if this is empty then the column is considered as being empty.



begin

  Result := Length(Text[Node, Column]) = 0;

  // If there is no text then let the ancestor decide if the column is to be considered as being empty

  // (e.g. by asking the application). If there is text then the column is never be considered as being empty.

  if Result then

    Result := inherited ColumnIsEmpty(Node, Column);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TCustomVirtualStringTree.DefineProperties(Filer: TFiler);



begin

  inherited;



  // Delphi still cannot handle wide strings properly while streaming

  Filer.DefineProperty('WideDefaultText', ReadText, WriteText, FDefaultText <> 'Node');

  Filer.DefineProperty('StringOptions', ReadOldStringOptions, nil, False);

end;



//----------------------------------------------------------------------------------------------------------------------



destructor TCustomVirtualStringTree.Destroy;

begin

  FreeAndNil(FPreviouslySelected);

  inherited;

end;



//----------------------------------------------------------------------------------------------------------------------



function TCustomVirtualStringTree.DoCreateEditor(Node: PVirtualNode; Column: TColumnIndex): IVTEditLink;



begin

  Result := inherited DoCreateEditor(Node, Column);

  // Enable generic label editing support if the application does not have own editors.

  if Result = nil then

    Result := TStringEditLink.Create;

end;



//----------------------------------------------------------------------------------------------------------------------



function TCustomVirtualStringTree.DoGetNodeHint(Node: PVirtualNode; Column: TColumnIndex;

  var LineBreakStyle: TVTTooltipLineBreakStyle): UnicodeString;



begin

  Result := inherited DoGetNodeHint(Node, Column, LineBreakStyle);

  if Assigned(FOnGetHint) then

    FOnGetHint(Self, Node, Column, LineBreakStyle, Result);

end;



//----------------------------------------------------------------------------------------------------------------------



function TCustomVirtualStringTree.DoGetNodeTooltip(Node: PVirtualNode; Column: TColumnIndex;

  var LineBreakStyle: TVTTooltipLineBreakStyle): UnicodeString;



begin

  Result := inherited DoGetNodeToolTip(Node, Column, LineBreakStyle);

  if Assigned(FOnGetHint) then

    FOnGetHint(Self, Node, Column, LineBreakStyle, Result)

  else

    Result := Text[Node, Column];

end;



//----------------------------------------------------------------------------------------------------------------------



function TCustomVirtualStringTree.DoGetNodeExtraWidth(Node: PVirtualNode; Column: TColumnIndex;

  Canvas: TCanvas = nil): Integer;



begin

    if Canvas = nil then

      Canvas := Self.Canvas;

    Result := CalculateStaticTextWidth(Canvas, Node, Column, StaticText[Node, Column]);

end;



//----------------------------------------------------------------------------------------------------------------------



function TCustomVirtualStringTree.DoGetNodeWidth(Node: PVirtualNode; Column: TColumnIndex; Canvas: TCanvas = nil): Integer;



// Returns the text width of the given node in pixels.

// This width is stored in the node's data member to increase access speed.



var

  Data: PInteger;



begin

  if (Column > NoColumn) and (vsMultiline in Node.States) then

    Result := FHeader.Columns[Column].Width

  else

  begin

    if Canvas = nil then

      Canvas := Self.Canvas;



    if Column = FHeader.MainColumn then

    begin

      // Primary column or no columns.

      Data := InternalData(Node);

      if Assigned(Data) then

      begin

        Result := Data^;

        if Result = 0 then

        begin

          Data^ := CalculateTextWidth(Canvas, Node, Column, Text[Node, Column]);

          Result := Data^;

        end;

      end

      else

        Result := 0;

    end

    else

      // any other column

      Result := CalculateTextWidth(Canvas, Node, Column, Text[Node, Column]);

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TCustomVirtualStringTree.DoGetText(Node: PVirtualNode; Column: TColumnIndex; TextType: TVSTTextType;

  var Text: UnicodeString);



begin

  if Assigned(FOnGetText) then

    FOnGetText(Self, Node, Column, TextType, Text);

end;



//----------------------------------------------------------------------------------------------------------------------



function TCustomVirtualStringTree.DoIncrementalSearch(Node: PVirtualNode; const Text: UnicodeString): Integer;



// Since the string tree has access to node text it can do incremental search on its own. Use the event to

// override the default behavior.



begin

  Result := 0;

  if Assigned(FOnIncrementalSearch) then

    FOnIncrementalSearch(Self, Node, Text, Result)

  else

    // Default behavior is to match the search string with the start of the node text.

    if Pos(Text, GetText(Node, FocusedColumn)) <> 1 then

      Result := 1;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TCustomVirtualStringTree.DoNewText(Node: PVirtualNode; Column: TColumnIndex; Text: UnicodeString);



begin

  if Assigned(FOnNewText) then

    FOnNewText(Self, Node, Column, Text);



  // The width might have changed, so update the scrollbar.

  if FUpdateCount = 0 then

    UpdateHorizontalScrollBar(True);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TCustomVirtualStringTree.DoPaintNode(var PaintInfo: TVTPaintInfo);



// Main output routine to print the text of the given node using the space provided in PaintInfo.ContentRect.



var

  S: UnicodeString;

  TextOutFlags: Integer;



begin

  // Set a new OnChange event for the canvas' font so we know if the application changes it in the callbacks.

  // This long winded procedure is necessary because font changes (as well as brush and pen changes) are

  // unfortunately not announced via the Canvas.OnChange event.

  RedirectFontChangeEvent(PaintInfo.Canvas);

  try



    // Determine main text direction as well as other text properties.

    TextOutFlags := ETO_CLIPPED or RTLFlag[PaintInfo.BidiMode <> bdLeftToRight];

    S := Text[PaintInfo.Node, PaintInfo.Column];



    // Paint the normal text first...

    if Length(S) > 0 then

      PaintNormalText(PaintInfo, TextOutFlags, S);



    // ... and afterwards the static text if not centered and the node is not multiline enabled.

    if (Alignment <> taCenter) and not (vsMultiline in PaintInfo.Node.States) and (toShowStaticText in TreeOptions.FStringOptions) then

    begin

      S := '';

      with PaintInfo do

        DoGetText(Node, Column, ttStatic, S);

      if Length(S) > 0 then

        PaintStaticText(PaintInfo, TextOutFlags, S);

    end;

  finally

    RestoreFontChangeEvent(PaintInfo.Canvas);

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TCustomVirtualStringTree.DoPaintText(Node: PVirtualNode; const Canvas: TCanvas; Column: TColumnIndex;

  TextType: TVSTTextType);



begin

  if Assigned(FOnPaintText) then

    FOnPaintText(Self, Canvas, Node, Column, TextType);

end;



//----------------------------------------------------------------------------------------------------------------------



function TCustomVirtualStringTree.DoShortenString(Canvas: TCanvas; Node: PVirtualNode; Column: TColumnIndex;

  const S: UnicodeString; Width: Integer; EllipsisWidth: Integer = 0): UnicodeString;



var

  Done: Boolean;



begin

  Done := False;

  if Assigned(FOnShortenString) then

    FOnShortenString(Self, Canvas, Node, Column, S, Width, Result, Done);

  if not Done then

    Result := ShortenString(Canvas.Handle, S, Width, EllipsisWidth);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TCustomVirtualStringTree.DoTextDrawing(var PaintInfo: TVTPaintInfo; Text: UnicodeString; CellRect: TRect;

  DrawFormat: Cardinal);



var

  DefaultDraw: Boolean;



begin

  DefaultDraw := True;

  if Assigned(FOnDrawText) then

    FOnDrawText(Self, PaintInfo.Canvas, PaintInfo.Node, PaintInfo.Column, Text, CellRect, DefaultDraw);

  if DefaultDraw then

    Windows.DrawTextW(PaintInfo.Canvas.Handle, PWideChar(Text), Length(Text), CellRect, DrawFormat);

end;



//----------------------------------------------------------------------------------------------------------------------



function TCustomVirtualStringTree.DoTextMeasuring(Canvas: TCanvas; Node: PVirtualNode; Column: TColumnIndex;

  Text: UnicodeString): TSize;



var

  R: TRect;

  DrawFormat: Integer;



begin

  GetTextExtentPoint32W(Canvas.Handle, PWideChar(Text), Length(Text), Result);

  if vsMultiLine in Node.States then

  begin

    DrawFormat := DT_CALCRECT or DT_NOPREFIX or DT_WORDBREAK or DT_END_ELLIPSIS or DT_EDITCONTROL or AlignmentToDrawFlag[Alignment];

    if BidiMode <> bdLeftToRight then

      DrawFormat := DrawFormat or DT_RTLREADING;



    R := Rect(0, 0, Result.cx, MaxInt);

    Windows.DrawTextW(Canvas.Handle, PWideChar(Text), Length(Text), R, DrawFormat);

    Result.cx := R.Right - R.Left;

  end;

  if Assigned(FOnMeasureTextWidth) then

    FOnMeasureTextWidth(Self, Canvas, Node, Column, Text, Result.cx);

  if Assigned(FOnMeasureTextHeight) then

    FOnMeasureTextHeight(Self, Canvas, Node, Column, Text, Result.cy);

end;



//----------------------------------------------------------------------------------------------------------------------



function TCustomVirtualStringTree.GetOptionsClass: TTreeOptionsClass;



begin

  Result := TCustomStringTreeOptions;

end;



//----------------------------------------------------------------------------------------------------------------------



function TCustomVirtualStringTree.InternalData(Node: PVirtualNode): Pointer;



begin

  if (Node = FRoot) or (Node = nil) then

    Result := nil

  else

    Result := PByte(Node) + FInternalDataOffset;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TCustomVirtualStringTree.MainColumnChanged;



var

  Run: PVirtualNode;

  Data: PInteger;



begin

  inherited;



  // Have to reset all node widths.

  Run := FRoot.FirstChild;

  while Assigned(Run) do

  begin

    Data := InternalData(Run);

    if Assigned(Data) then

      Data^ := 0;

    Run := GetNextNoInit(Run);

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



function TCustomVirtualStringTree.ReadChunk(Stream: TStream; Version: Integer; Node: PVirtualNode; ChunkType,

  ChunkSize: Integer): Boolean;



// read in the caption chunk if there is one



var

  NewText: UnicodeString;



begin

  case ChunkType of

    CaptionChunk:

      begin

        NewText := '';

        if ChunkSize > 0 then

        begin

          SetLength(NewText, ChunkSize div 2);

          Stream.Read(PWideChar(NewText)^, ChunkSize);

        end;

        // Do a new text event regardless of the caption content to allow removing the default string.

        Text[Node, FHeader.MainColumn] := NewText;

        Result := True;

      end;

  else

    Result := inherited ReadChunk(Stream, Version, Node, ChunkType, ChunkSize);

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



type

  TOldVTStringOption = (soSaveCaptions, soShowStaticText);



procedure TCustomVirtualStringTree.ReadOldStringOptions(Reader: TReader);



// Migration helper routine to silently convert forms containing the old tree options member into the new

// sub-options structure.



var

  OldOption: TOldVTStringOption;

  EnumName: string;



begin

  // If we are at design time currently then let the designer know we changed something.

  UpdateDesigner;



  // It should never happen at this place that there is something different than the old set.

  if Reader.ReadValue = vaSet then

    with TreeOptions do

    begin

      // Remove all default values set by the constructor.

      StringOptions := [];



      while True do

      begin

        // Sets are stored with their members as simple strings. Read them one by one and map them to the new option

        // in the correct sub-option set.

        EnumName := Reader.ReadStr;

        if EnumName = '' then

          Break;

        OldOption := TOldVTStringOption(GetEnumValue(TypeInfo(TOldVTStringOption), EnumName));

        case OldOption of

          soSaveCaptions:

            StringOptions := FStringOptions + [toSaveCaptions];

          soShowStaticText:

            StringOptions := FStringOptions + [toShowStaticText];

        end;

      end;

    end;

end;



//----------------------------------------------------------------------------------------------------------------------



function TCustomVirtualStringTree.RenderOLEData(const FormatEtcIn: TFormatEtc; out Medium: TStgMedium;

  ForClipboard: Boolean): HResult;



// Returns string expressions of all currently selected nodes in the Medium structure.



begin

  Result := inherited RenderOLEData(FormatEtcIn, Medium, ForClipboard);

  if Failed(Result) then

  try

    if ForClipboard then

      Medium.hGlobal := ContentToClipboard(FormatEtcIn.cfFormat, tstCutCopySet)

    else

      Medium.hGlobal := ContentToClipboard(FormatEtcIn.cfFormat, tstSelected);



    // Fill rest of the Medium structure if rendering went fine.

    if Medium.hGlobal <> 0 then

    begin

      Medium.tymed := TYMED_HGLOBAL;

      Medium.unkForRelease := nil;



      Result := S_OK;

    end;

  except

    Result := E_FAIL;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TCustomVirtualStringTree.WriteChunks(Stream: TStream; Node: PVirtualNode);



// Adds another sibling chunk for Node storing the label if the node is initialized.

// Note: If the application stores a node's caption in the node's data member (which will be quite common) and needs to

//       store more node specific data then it should use the OnSaveNode event rather than the caption autosave function

//       (take out soSaveCaption from StringOptions). Otherwise the caption is unnecessarily stored twice.



var

  Header: TChunkHeader;

  S: UnicodeString;

  Len: Integer;



begin

  inherited;

  if (toSaveCaptions in TreeOptions.FStringOptions) and (Node <> FRoot) and

    (vsInitialized in Node.States) then

    with Stream do

    begin

      // Read the node's caption (primary column only).

      S := Text[Node, FHeader.MainColumn];

      Len := 2 * Length(S);

      if Len > 0 then

      begin

        // Write a new sub chunk.

        Header.ChunkType := CaptionChunk;

        Header.ChunkSize := Len;

        Write(Header, SizeOf(Header));

        Write(PWideChar(S)^, Len);

      end;

    end;

end;



//----------------------------------------------------------------------------------------------------------------------



function TCustomVirtualStringTree.ComputeNodeHeight(Canvas: TCanvas; Node: PVirtualNode; Column: TColumnIndex;

  S: UnicodeString): Integer;



// Default node height calculation for multi line nodes. This method can be used by the application to delegate the

// computation to the string tree.

// Canvas is used to compute that value by using its current font settings.

// Node and Column describe the cell to be used for the computation.

// S is the string for which the height must be computed. If this string is empty the cell text is used instead.



var

  DrawFormat: Cardinal;

  BidiMode: TBidiMode;

  Alignment: TAlignment;

  PaintInfo: TVTPaintInfo;

  Dummy: TColumnIndex;

  LineImage: TLineImage;

begin

  if Length(S) = 0 then

    S := Text[Node, Column];

  DrawFormat := DT_TOP or DT_NOPREFIX or DT_CALCRECT or DT_WORDBREAK;

  if Column <= NoColumn then

  begin

    BidiMode := Self.BidiMode;

    Alignment := Self.Alignment;

  end

  else

  begin

    BidiMode := Header.Columns[Column].BidiMode;

    Alignment := Header.Columns[Column].Alignment;

  end;



  if BidiMode <> bdLeftToRight then

    ChangeBidiModeAlignment(Alignment);



  // Allow for autospanning.

  PaintInfo.Node := Node;

  PaintInfo.BidiMode := BidiMode;

  PaintInfo.Column := Column;

  PaintInfo.CellRect := Rect(0, 0, 0, 0);

  if Column > NoColumn then

  begin

    PaintInfo.CellRect.Right := FHeader.Columns[Column].Width - FTextMargin;

    PaintInfo.CellRect.Left := FTextMargin + FMargin;

    if Column = Header.MainColumn then

    begin

      if toFixedIndent in FOptions.FPaintOptions then

        SetLength(LineImage, 1)

      else

        DetermineLineImageAndSelectLevel(Node, LineImage);

    Inc(PaintInfo.CellRect.Left, Length(LineImage) * Integer(Indent));

    end;

  end

  else

    PaintInfo.CellRect.Right := ClientWidth;

  AdjustPaintCellRect(PaintInfo, Dummy);



  if BidiMode <> bdLeftToRight then

    DrawFormat := DrawFormat or DT_RIGHT or DT_RTLREADING

  else

    DrawFormat := DrawFormat or DT_LEFT;

  Windows.DrawTextW(Canvas.Handle, PWideChar(S), Length(S), PaintInfo.CellRect, DrawFormat);

  Result := PaintInfo.CellRect.Bottom - PaintInfo.CellRect.Top;

end;



//----------------------------------------------------------------------------------------------------------------------



function TCustomVirtualStringTree.ContentToClipboard(Format: Word; Source: TVSTTextSourceType): HGLOBAL;



// This method constructs a shareable memory object filled with string data in the required format. Supported are:

// CF_TEXT - plain ANSI text (Unicode text is converted using the user's current locale)

// CF_UNICODETEXT - plain Unicode text

// CF_CSV - comma separated plain ANSI text

// CF_VRTF + CF_RTFNOOBS - rich text (plain ANSI)

// CF_HTML - HTML text encoded using UTF-8

//

// Result is the handle to a globally allocated memory block which can directly be used for clipboard and drag'n drop

// transfers. The caller is responsible for freeing the memory. If for some reason the content could not be rendered

// the Result is 0.



  //--------------- local function --------------------------------------------



  procedure MakeFragment(var HTML: AnsiString);



  // Helper routine to build a properly-formatted HTML fragment.



  const

    Version = 'Version:1.0'#13#10;

    StartHTML = 'StartHTML:';

    EndHTML = 'EndHTML:';

    StartFragment = 'StartFragment:';

    EndFragment = 'EndFragment:';

    DocType = '<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN">';

    HTMLIntro = '<html><head><META http-equiv=Content-Type content="text/html; charset=utf-8">' +

      '</head><body><!--StartFragment-->';

    HTMLExtro = '<!--EndFragment--></body></html>';

    NumberLengthAndCR = 10;



    // Let the compiler determine the description length.

    DescriptionLength = Length(Version) + Length(StartHTML) + Length(EndHTML) + Length(StartFragment) +

      Length(EndFragment) + 4 * NumberLengthAndCR;



  var

    Description: AnsiString;

    StartHTMLIndex,

    EndHTMLIndex,

    StartFragmentIndex,

    EndFragmentIndex: Integer;



  begin

    // The HTML clipboard format is defined by using byte positions in the entire block where HTML text and

    // fragments start and end. These positions are written in a description. Unfortunately the positions depend on the

    // length of the description but the description may change with varying positions.

    // To solve this dilemma the offsets are converted into fixed length strings which makes it possible to know

    // the description length in advance.

    StartHTMLIndex := DescriptionLength;              // position 0 after the description

    StartFragmentIndex := StartHTMLIndex + Length(DocType) + Length(HTMLIntro);

    EndFragmentIndex := StartFragmentIndex + Length(HTML);

    EndHTMLIndex := EndFragmentIndex + Length(HTMLExtro);



    Description := Version +

    SysUtils.Format('%s%.8d', [StartHTML, StartHTMLIndex]) + #13#10 +

    SysUtils.Format('%s%.8d', [EndHTML, EndHTMLIndex]) + #13#10 +

    SysUtils.Format('%s%.8d', [StartFragment, StartFragmentIndex]) + #13#10 +

    SysUtils.Format('%s%.8d', [EndFragment, EndFragmentIndex]) + #13#10;

    HTML := Description + DocType + HTMLIntro + HTML + HTMLExtro;

  end;



  //--------------- end local function ----------------------------------------



var

  Data: Pointer;

  DataSize: Cardinal;

  S: AnsiString;

  WS: UnicodeString;

  P: Pointer;



begin

  Result := 0;

  case Format of

    CF_TEXT:

      begin

        S := ContentToText(Source, #9) + #0;

        Data := PAnsiChar(S);

        DataSize := Length(S);

      end;

    CF_UNICODETEXT:

      begin

        WS := ContentToUnicode(Source, #9) + #0;

        Data := PWideChar(WS);

        DataSize := 2 * Length(WS);

      end;

  else

    if Format = CF_CSV then

      S := ContentToText(Source, AnsiChar ({$if CompilerVersion >= 22}FormatSettings.{$ifend}ListSeparator)) + #0

    else

      if (Format = CF_VRTF) or (Format = CF_VRTFNOOBJS) then

        S := ContentToRTF(Source) + #0

      else

        if Format = CF_HTML then

        begin

          S := ContentToHTML(Source);

          // Build a valid HTML clipboard fragment.

          MakeFragment(S);

          S := S + #0;

        end;

    Data := PAnsiChar(S);

    DataSize := Length(S);

  end;



  if DataSize > 0 then

  begin

    Result := GlobalAlloc(GHND or GMEM_SHARE, DataSize);

    P := GlobalLock(Result);

    Move(Data^, P^, DataSize);

    GlobalUnlock(Result);

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



function TCustomVirtualStringTree.ContentToHTML(Source: TVSTTextSourceType; Caption: UnicodeString = ''): RawByteString;



// Renders the current tree content (depending on Source) as HTML text encoded in UTF-8.

// If Caption is not empty then it is used to create and fill the header for the table built here.

// Based on ideas and code from Frank van den Bergh and Andreas Hörstemeier.



type

  UCS2 = Word;

  UCS4 = Cardinal;



const

  MaximumUCS4: UCS4 = $7FFFFFFF;

  ReplacementCharacter: UCS4 = $0000FFFD;



var

  Buffer: TBufferedAnsiString;



  //--------------- local functions -------------------------------------------



  function ConvertSurrogate(S1, S2: UCS2): UCS4;



  // Converts a pair of high and low surrogate into the corresponding UCS4 character.



  const

    SurrogateOffset = ($D800 shl 10) + $DC00 - $10000;



  begin

    Result := Word(S1) shl 10 + Word(S2) - SurrogateOffset;

  end;



  //---------------------------------------------------------------------------



  function UTF16ToUTF8(const S: UnicodeString): AnsiString;



  // Converts the given Unicode text (which may contain surrogates) into

  // the UTF-8 encoding used for the HTML clipboard format.



  const

    FirstByteMark: array[0..6] of Byte = ($00, $00, $C0, $E0, $F0, $F8, $FC);



  var

    Ch: UCS4;

    I, J, T: Integer;

    BytesToWrite: Cardinal;



  begin

    if Length(S) = 0 then

      Result := ''

    else

    begin

      // Make room for the result. Assume worst case, there are only short texts to convert.

      SetLength(Result, 6 * Length(S));

      T := 1;

      I := 1;

      while I <= Length(S) do

      begin

        Ch := UCS4(S[I]);



        // Is the character a surrogate?

        if (Ch and $FFFFF800) = $D800 then

        begin

          Inc(I);

          // Check the following char whether it forms a valid surrogate pair with the first character.

          if (I <= Length(S)) and ((UCS4(S[I]) and $FFFFFC00) = $DC00) then

            Ch := ConvertSurrogate(UCS2(Ch), UCS2(S[I]))

          else // Skip invalid surrogate value.

            Continue;

        end;



        if Ch < $80 then

          BytesToWrite := 1

        else

          if Ch < $800 then

            BytesToWrite := 2

          else

            if Ch < $10000 then

              BytesToWrite := 3

            else

              if Ch < $200000 then

                BytesToWrite := 4

              else

                if Ch < $4000000 then

                  BytesToWrite := 5

                else

                  if Ch <= MaximumUCS4 then

                    BytesToWrite := 6

                  else

                  begin

                    BytesToWrite := 2;

                    Ch := ReplacementCharacter;

                  end;



        for J := BytesToWrite downto 2 do

        begin

          Result[T + J - 1] := AnsiChar((Ch or $80) and $BF);

          Ch := Ch shr 6;

        end;

        Result[T] := AnsiChar(Ch or FirstByteMark[BytesToWrite]);

        Inc(T, BytesToWrite);



        Inc(I);

      end;

      SetLength(Result, T - 1); // set to actual length

    end;

  end;



  //---------------------------------------------------------------------------



  procedure WriteColorAsHex(Color: TColor);



  var

    WinColor: COLORREF;

    I: Integer;

    Component,

    Value: Byte;



  begin

    Buffer.Add('#');

    WinColor := ColorToRGB(Color);

    I := 1;

    while I <= 6 do

    begin

      Component := WinColor and $FF;



      Value := 48 + (Component shr 4);

      if Value > $39 then

        Inc(Value, 7);

      Buffer.Add(AnsiChar(Value));

      Inc(I);



      Value := 48 + (Component and $F);

      if Value > $39 then

        Inc(Value, 7);

      Buffer.Add(AnsiChar(Value));

      Inc(I);



      WinColor := WinColor shr 8;

    end;

  end;



  //---------------------------------------------------------------------------



  procedure WriteStyle(Name: AnsiString; Font: TFont);



  // Creates a CSS style entry with the given name for the given font.

  // If Name is empty then the entry is created as inline style.



  begin

    if Length(Name) = 0 then

      Buffer.Add(' style="{')

    else

    begin

      Buffer.Add('.');

      Buffer.Add(Name);

      Buffer.Add('{');

    end;



    Buffer.Add(Format('font-family: ''%s''; ', [Font.Name]));

    if Font.Size < 0 then

      Buffer.Add(Format('font-size: %dpx; ', [Font.Height]))

    else

      Buffer.Add(Format('font-size: %dpt; ', [Font.Size]));



    Buffer.Add(Format('font-style: %s; ', [IfThen(fsItalic in Font.Style, 'italic', 'normal')]));

    Buffer.Add(Format('font-weight: %s; ', [IfThen(fsBold in Font.Style, 'bold', 'normal')]));

    Buffer.Add(Format('text-decoration: %s; ', [IfThen(fsUnderline in Font.Style, 'underline', 'none')]));



    Buffer.Add('color: ');

    WriteColorAsHex(Font.Color);

    Buffer.Add(';}');

    if Length(Name) = 0 then

      Buffer.Add('"');

  end;



  //--------------- end local functions ---------------------------------------



var

  I, J : Integer;

  Level, MaxLevel: Cardinal;

  AddHeader: AnsiString;

  Save, Run: PVirtualNode;

  GetNextNode: TGetNextNodeProc;

  Text: UnicodeString;



  RenderColumns: Boolean;

  Columns: TColumnsArray;

  ColumnColors: array of AnsiString;

  Index: Integer;

  IndentWidth,

  LineStyleText: AnsiString;

  Alignment: TAlignment;

  BidiMode: TBidiMode;



  CellPadding: AnsiString;



begin

  Buffer := TBufferedAnsiString.Create;

  try

    // For customization by the application or descendants we use again the redirected font change event.

    RedirectFontChangeEvent(Canvas);



    CellPadding := Format('padding-left: %dpx; padding-right: %0:dpx;', [FMargin]);



    IndentWidth := IntToStr(FIndent);

    AddHeader := ' ';

    // Add title if adviced so by giving a caption.

    if Length(Caption) > 0 then

      AddHeader := AddHeader + 'caption="' + UTF16ToUTF8(Caption) + '"';

    if Borderstyle <> bsNone then

      AddHeader := AddHeader + Format(' border="%d" frame=box', [BorderWidth + 1]);



    Buffer.Add('<META http-equiv="Content-Type" content="text/html; charset=utf-8">');



    // Create HTML table based on the tree structure. To simplify formatting we use styles defined in a small CSS area.

    Buffer.Add('<style type="text/css">');

    Buffer.AddnewLine;

    WriteStyle('default', Font);

    Buffer.AddNewLine;

    WriteStyle('header', FHeader.Font);

    Buffer.AddNewLine;



    // Determine grid/table lines and create CSS for it.

    // Vertical and/or horizontal border to show.

    if FLineStyle = lsSolid then

      LineStyleText := 'solid;'

    else

      LineStyleText := 'dotted;';

    if toShowHorzGridLines in FOptions.FPaintOptions then

    begin

      Buffer.Add('.noborder{');

      Buffer.Add(' border-bottom:1px; border-left: 0px; border-right: 0px; border-top: 1px;');

      Buffer.Add('border-style:');

      Buffer.Add(LineStyleText);

      Buffer.Add(CellPadding);

      Buffer.Add('}');

    end

    else

    begin

      Buffer.Add('.noborder{border-style: none;');

      Buffer.Add(CellPadding);

      Buffer.Add('}');

    end;

    Buffer.AddNewLine;



    Buffer.Add('.normalborder {vertical-align: top; ');

    if toShowVertGridLines in FOptions.FPaintOptions then

      Buffer.Add('border-right: 1px; border-left: 1px; ')

    else

      Buffer.Add('border-right: none; border-left:none; ');

    if toShowHorzGridLines in FOptions.FPaintOptions then

      Buffer.Add('border-top: 1px; border-bottom: 1px; ')

    else

      Buffer.Add('border-top:none; border-bottom: none;');

    Buffer.Add('border-width: thin; border-style: ');

    Buffer.Add(LineStyleText);

    Buffer.Add(CellPadding);

    Buffer.Add('}');

    Buffer.Add('</style>');

    Buffer.AddNewLine;



    // General table properties.

    Buffer.Add('<table class="default" style="border-collapse: collapse;" bgcolor=');

    WriteColorAsHex(Color);

    Buffer.Add(AddHeader);

    Buffer.Add(' cellspacing="0">');

    Buffer.AddNewLine;



    Columns := nil;

    ColumnColors := nil;

    RenderColumns := FHeader.UseColumns;

    if RenderColumns then

    begin

      Columns := FHeader.FColumns.GetVisibleColumns;

      SetLength(ColumnColors, Length(Columns));

    end;



    GetRenderStartValues(Source, Run, GetNextNode);

    Save := Run;



    MaxLevel := 0;

    // The table consists of visible columns and rows as used in the tree, but the main tree column is splitted

    // into several HTML columns to accomodate the indentation.

    while Assigned(Run) do

    begin

      if (CanExportNode(Run)) then

      begin

          Level := GetNodeLevel(Run);

          if Level > MaxLevel then

            MaxLevel := Level;

      end;

      Run := GetNextNode(Run);

    end;



    if RenderColumns then

    begin

      if Assigned(FOnBeforeHeaderExport) then

        FOnBeforeHeaderExport(Self, etHTML);

      Buffer.Add('<tr class="header" style="');

      Buffer.Add(CellPadding);

      Buffer.Add('">');

      Buffer.AddNewLine;

      // Make the first row in the HTML table an image of the tree header.

      for I := 0 to High(Columns) do

      begin

        if Assigned(FOnBeforeColumnExport) then

            FOnBeforeColumnExport(Self, etHTML, Columns[I]);

        Buffer.Add('<th height="');

        Buffer.Add(IntToStr(FHeader.FHeight));

        Buffer.Add('px"');

        Alignment := Columns[I].CaptionAlignment;

        // Consider directionality.

        if Columns[I].FBiDiMode <> bdLeftToRight then

        begin

          ChangeBidiModeAlignment(Alignment);

          Buffer.Add(' dir="rtl"');

        end;



          // Consider aligment.

        case Alignment of

          taRightJustify:

            Buffer.Add(' align=right');

          taCenter:

            Buffer.Add(' align=center');

        else

          Buffer.Add(' align=left');

        end;



        Index := Columns[I].Index;

        // Merge cells of the header emulation in the main column.

        if (MaxLevel > 0) and (Index = Header.MainColumn) then

        begin

          Buffer.Add(' colspan="');

          Buffer.Add(IntToStr(MaxLevel + 1));

          Buffer.Add('"');

        end;



        // The color of the header is usually clBtnFace.

        Buffer.Add(' bgcolor=');

        WriteColorAsHex(clBtnFace);



        // Set column width in pixels.

        Buffer.Add(' width="');

        Buffer.Add(IntToStr(Columns[I].Width));

        Buffer.Add('px">');



        if Length(Columns[I].Text) > 0 then

          Buffer.Add(UTF16ToUTF8(Columns[I].Text));

        Buffer.Add('</th>');

        if Assigned(FOnAfterColumnExport) then

            FOnAfterColumnExport(Self, etHTML, Columns[I]);

      end;

      Buffer.Add('</tr>');

      Buffer.AddNewLine;

      if Assigned(FOnAfterHeaderExport) then

        FOnAfterHeaderExport(Self, etHTML);

    end;



    // Now go through the tree.

    Run := Save;

    while Assigned(Run) do

    begin

      if ((not CanExportNode(Run)) or (Assigned(FOnBeforeNodeExport) and (not FOnBeforeNodeExport(Self, etHTML, Run)))) then

      begin

        Run := GetNextNode(Run);

        Continue;

      end;

      Level := GetNodeLevel(Run);

      Buffer.Add(' <tr class="default">');

      Buffer.AddNewLine;



      I := 0;

      while (I < Length(Columns)) or not RenderColumns do

      begin

        if RenderColumns then

          Index := Columns[I].Index

        else

          Index := NoColumn;



        if not RenderColumns or (coVisible in Columns[I].FOptions) then

        begin

          // Call back the application to know about font customization.

          Canvas.Font := Font;

          FFontChanged := False;

          DoPaintText(Run, Canvas, Index, ttNormal);



          if Index = Header.MainColumn then

          begin

            // Create a cell for each indentation level.

            if RenderColumns and not (coParentColor in Columns[I].FOptions) then

            begin

              for J := 1 to Level do

              begin

                Buffer.Add('<td class="noborder" width="');

                Buffer.Add(IndentWidth);

                Buffer.Add('" height="');

                Buffer.Add(IntToStr(NodeHeight[Run]));

                Buffer.Add('px"');

                if not (coParentColor in Columns[I].FOptions) then

                begin

                  Buffer.Add(' bgcolor=');

                  WriteColorAsHex(Columns[I].Color);

                end;

                Buffer.Add('>&nbsp;</td>');

              end;

            end

            else

            begin

              for J := 1 to Level do

                if J = 1 then

                begin

                  Buffer.Add(' <td height="');

                  Buffer.Add(IntToStr(NodeHeight[Run]));

                  Buffer.Add('px" class="normalborder">&nbsp;</td>');

                end

                else

                  Buffer.Add(' <td>&nbsp;</td>');

            end;

          end;



          if FFontChanged then

          begin

            Buffer.Add(' <td class="normalborder" ');

            WriteStyle('', Canvas.Font);

            Buffer.Add(' height="');

            Buffer.Add(IntToStr(NodeHeight[Run]));

            Buffer.Add('px"');

          end

          else

          begin

            Buffer.Add(' <td class="normalborder"  height="');

            Buffer.Add(IntToStr(NodeHeight[Run]));

            Buffer.Add('px"');

          end;



          if RenderColumns then

          begin

            Alignment := Columns[I].Alignment;

            BidiMode := Columns[I].BidiMode;

          end

          else

          begin

            Alignment := Self.Alignment;

            BidiMode := Self.BidiMode;

          end;

          // Consider directionality.

          if BiDiMode <> bdLeftToRight then

          begin

            ChangeBidiModeAlignment(Alignment);

            Buffer.Add(' dir="rtl"');

          end;



          // Consider aligment.

          case Alignment of

            taRightJustify:

              Buffer.Add(' align=right');

            taCenter:

              Buffer.Add(' align=center');

          else

            Buffer.Add(' align=left');

          end;

          // Merge cells in the main column.

          if (MaxLevel > 0) and (Index = FHeader.MainColumn) and (Level < MaxLevel) then

          begin

            Buffer.Add(' colspan="');

            Buffer.Add(IntToStr(MaxLevel - Level + 1));

            Buffer.Add('"');

          end;

          if RenderColumns and not (coParentColor in Columns[I].FOptions) then

          begin

            Buffer.Add(' bgcolor=');

            WriteColorAsHex(Columns[I].Color);

          end;

          Buffer.Add('>');

          Text := Self.Text[Run, Index];

          if Length(Text) > 0 then

          begin

            Text := UTF16ToUTF8(Text);

            Buffer.Add(Text);

          end;

          Buffer.Add('</td>');

        end;



        if not RenderColumns then

          Break;

        Inc(I);

      end;

      if Assigned(FOnAfterNodeExport) then

        FOnAfterNodeExport(Self, etHTML, Run);

      Run := GetNextNode(Run);

      Buffer.Add(' </tr>');

      Buffer.AddNewLine;

    end;

    Buffer.Add('</table>');



    RestoreFontChangeEvent(Canvas);



    Result := Buffer.AsString;

  finally

    Buffer.Free;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



function TCustomVirtualStringTree.CanExportNode(Node: PVirtualNode): Boolean;



begin

  case FOptions.ExportMode of

    emChecked:

      Result := Node.CheckState = csCheckedNormal;

    emUnchecked:

      Result := Node.CheckState = csUncheckedNormal;

    emVisibleDueToExpansion: //Do not export nodes that are not visible because their parent is not expanded

      Result := not Assigned(Node.Parent) or Self.Expanded[Node.Parent];

    emSelected: // export selected nodes only

      Result := Selected[Node];

    else

      Result := True;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TCustomVirtualStringTree.AddToSelection(Node: PVirtualNode);

var

  lSelectedNodeCaption: UnicodeString;

begin

  inherited;

  if (toRestoreSelection in TreeOptions.SelectionOptions) and Assigned(Self.OnGetText) and Self.Selected[Node] and not (tsPreviouslySelectedLocked in FStates) then

  begin

    if not Assigned(FPreviouslySelected) then

    begin

      FPreviouslySelected := TStringList.Create();

      FPreviouslySelected.Duplicates := dupIgnore;

      FPreviouslySelected.Sorted := True; //Improves performance, required to use Find()

      FPreviouslySelected.CaseSensitive := False;

    end;

    if Self.SelectedCount = 1 then

      FPreviouslySelected.Clear();

    Self.OnGetText(Self, Node, 0, ttNormal, lSelectedNodeCaption);

    FPreviouslySelected.Add(lSelectedNodeCaption);

  end;//if

  UpdateNextNodeToSelect(Node);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TCustomVirtualStringTree.RemoveFromSelection(Node: PVirtualNode);

var

  lSelectedNodeCaption: UnicodeString;

  lIndex: Integer;

begin

  inherited;

  if (toRestoreSelection in TreeOptions.SelectionOptions) and Assigned(FPreviouslySelected) and not Self.Selected[Node] then

  begin

    if Self.SelectedCount = 0 then

      FPreviouslySelected.Clear()

    else

    begin

      Self.OnGetText(Self, Node, 0, ttNormal, lSelectedNodeCaption);

      if FPreviouslySelected.Find(lSelectedNodeCaption, lIndex) then

        FPreviouslySelected.Delete(lIndex);

    end;//else

  end;//if

end;



//----------------------------------------------------------------------------------------------------------------------



function TCustomVirtualStringTree.ContentToRTF(Source: TVSTTextSourceType): RawByteString;



// Renders the current tree content (depending on Source) as RTF (rich text).

// Based on ideas and code from Frank van den Bergh and Andreas Hörstemeier.



var

  Fonts: TStringList;

  Colors: TList;

  CurrentFontIndex,

  CurrentFontColor,

  CurrentFontSize: Integer;

  Buffer: TBufferedAnsiString;



  //--------------- local functions -------------------------------------------



  procedure SelectFont(Font: string);



  var

    I: Integer;



  begin

    I := Fonts.IndexOf(Font);

    if I > -1 then

    begin

      // Font has already been used

      if I <> CurrentFontIndex then

      begin

        Buffer.Add('\f');

        Buffer.Add(IntToStr(I));

        CurrentFontIndex := I;

      end;

    end

    else

    begin

      I := Fonts.Add(Font);

      Buffer.Add('\f');

      Buffer.Add(IntToStr(I));

      CurrentFontIndex := I;

    end;

  end;



  //---------------------------------------------------------------------------



  procedure SelectColor(Color: TColor);



  var

    I: Integer;



  begin

    I := Colors.IndexOf(Pointer(Color));

    if I > -1 then

    begin

      // Color has already been used

      if I <> CurrentFontColor then

      begin

        Buffer.Add('\cf');

        Buffer.Add(IntToStr(I + 1));

        CurrentFontColor := I;

      end;

    end

    else

    begin

      I := Colors.Add(Pointer(Color));

      Buffer.Add('\cf');

      Buffer.Add(IntToStr(I + 1));

      CurrentFontColor := I;

    end;

  end;



  //---------------------------------------------------------------------------



  procedure TextPlusFont(Text: UnicodeString; Font: TFont);



  var

    UseUnderline,

    UseItalic,

    UseBold: Boolean;

    I: Integer;



  begin

    if Length(Text) > 0 then

    begin

      UseUnderline := fsUnderline in Font.Style;

      if UseUnderline then

        Buffer.Add('\ul');

      UseItalic := fsItalic in Font.Style;

      if UseItalic then

        Buffer.Add('\i');

      UseBold := fsBold in Font.Style;

      if UseBold then

        Buffer.Add('\b');

      SelectFont(Font.Name);

      SelectColor(Font.Color);

      if Font.Size <> CurrentFontSize then

      begin

        // Font size must be given in half points.

        Buffer.Add('\fs');

        Buffer.Add(IntToStr(2 * Font.Size));

        CurrentFontSize := Font.Size;

      end;

      // Use escape sequences to note Unicode text.

      Buffer.Add(' ');

      // Note: Unicode values > 32767 must be expressed as negative numbers. This is implicitly done

      //       by interpreting the wide chars (word values) as small integers.

      for I := 1 to Length(Text) do

      begin

        if (Text[I] = WideLF) then

          Buffer.Add( '{\par}' )

        else

          if (Text[I] <> WideCR) then

          begin

            Buffer.Add(Format('\u%d\''3f', [SmallInt(Text[I])]));

            Continue;

          end;

      end;

      if UseUnderline then

        Buffer.Add('\ul0');

      if UseItalic then

        Buffer.Add('\i0');

      if UseBold then

        Buffer.Add('\b0');

    end;

  end;



  //--------------- end local functions ---------------------------------------



var

  Level, LastLevel: Integer;

  I, J: Integer;

  Save, Run: PVirtualNode;

  GetNextNode: TGetNextNodeProc;

  S, Tabs : RawByteString;

  Text: UnicodeString;

  Twips: Integer;



  RenderColumns: Boolean;

  Columns: TColumnsArray;

  Index: Integer;

  Alignment: TAlignment;

  BidiMode: TBidiMode;

  LocaleBuffer: array [0..1] of Char;



begin

  Buffer := TBufferedAnsiString.Create;

  try

    // For customization by the application or descendants we use again the redirected font change event.

    RedirectFontChangeEvent(Canvas);



    Fonts := TStringList.Create;

    Colors := TList.Create;

    CurrentFontIndex := -1;

    CurrentFontColor := -1;

    CurrentFontSize := -1;



    Columns := nil;

    Tabs := '';

    LastLevel := 0;



    RenderColumns := FHeader.UseColumns;

    if RenderColumns then

      Columns := FHeader.FColumns.GetVisibleColumns;



    GetRenderStartValues(Source, Run, GetNextNode);

    Save := Run;



    // First make a table structure. The \rtf and other header stuff is included

    // when the font and color tables are created.

    Buffer.Add('\uc1\trowd\trgaph70');

    J := 0;

    if RenderColumns then

    begin

      for I := 0 to High(Columns) do

      begin

        Inc(J, Columns[I].Width);

        // This value must be expressed in twips (1 inch = 1440 twips).

        Twips := Round(1440 * J / Screen.PixelsPerInch);

        Buffer.Add('\cellx');

        Buffer.Add(IntToStr(Twips));

      end;

    end

    else

    begin

      Twips := Round(1440 * ClientWidth / Screen.PixelsPerInch);

      Buffer.Add('\cellx');

      Buffer.Add(IntToStr(Twips));

    end;



    // Fill table header.

    if RenderColumns then

    begin

      if Assigned(FOnBeforeHeaderExport) then

        FOnBeforeHeaderExport(Self, etRTF);

      Buffer.Add('\pard\intbl');

      for I := 0 to High(Columns) do

      begin

        if Assigned(FOnBeforeColumnExport) then

          FOnBeforeColumnExport(Self, etRTF, Columns[I]);

        Alignment := Columns[I].CaptionAlignment;

        BidiMode := Columns[I].BidiMode;



        // Alignment is not supported with older RTF formats, however it will be ignored.

        if BidiMode <> bdLeftToRight then

          ChangeBidiModeAlignment(Alignment);

        case Alignment of

          taLeftJustify:

            Buffer.Add('\ql');

          taRightJustify:

            Buffer.Add('\qr');

          taCenter:

            Buffer.Add('\qc');

        end;



        TextPlusFont(Columns[I].Text, Header.Font);

        Buffer.Add('\cell');

        if Assigned(FOnAfterColumnExport) then

          FOnAfterColumnExport(Self, etRTF, Columns[I]);

      end;

      Buffer.Add('\row');

      if Assigned(FOnAfterHeaderExport) then

        FOnAfterHeaderExport(Self, etRTF);

    end;



    // Now write the contents.

    Run := Save;

    while Assigned(Run) do

    begin

      if ((not CanExportNode(Run)) or

         (Assigned(FOnBeforeNodeExport) and (not FOnBeforeNodeExport(Self, etRTF, Run)))) then

      begin

        Run := GetNextNode(Run);

        Continue;

      end;

      I := 0;

      while not RenderColumns or (I < Length(Columns)) do

      begin

        if RenderColumns then

        begin

          Index := Columns[I].Index;

          Alignment := Columns[I].Alignment;

          BidiMode := Columns[I].BidiMode;

        end

        else

        begin

          Index := NoColumn;

          Alignment := FAlignment;

          BidiMode := Self.BidiMode;

        end;



        if not RenderColumns or (coVisible in Columns[I].Options) then

        begin

          Text := Self.Text[Run, Index];

          Buffer.Add('\pard\intbl');



          // Alignment is not supported with older RTF formats, however it will be ignored.

          if BidiMode <> bdLeftToRight then

            ChangeBidiModeAlignment(Alignment);

          case Alignment of

            taRightJustify:

              Buffer.Add('\qr');

            taCenter:

              Buffer.Add('\qc');

          end;



          // Call back the application to know about font customization.

          Canvas.Font := Font;

          FFontChanged := False;

          DoPaintText(Run, Canvas, Index, ttNormal);



          if Index = Header.MainColumn then

          begin

            Level := GetNodeLevel(Run);

            if Level <> LastLevel then

            begin

              LastLevel := Level;

              Tabs := '';

              for J := 0 to Level - 1 do

                Tabs := Tabs + '\tab';

            end;

            if Level > 0 then

            begin

              Buffer.Add(Tabs);

              Buffer.Add(' ');

              TextPlusFont(Text, Canvas.Font);

              Buffer.Add('\cell');

            end

            else

            begin

              TextPlusFont(Text, Canvas.Font);

              Buffer.Add('\cell');

            end;

          end

          else

          begin

            TextPlusFont(Text, Canvas.Font);

            Buffer.Add('\cell');

          end;

        end;



        if not RenderColumns then

          Break;

        Inc(I);

      end;

      Buffer.Add('\row');

      Buffer.AddNewLine;

      if (Assigned(FOnAfterNodeExport)) then

        FOnAfterNodeExport(Self, etRTF, Run);

      Run := GetNextNode(Run);

    end;



    Buffer.Add('\pard\par');



    // Build lists with fonts and colors. They have to be at the start of the document.

    S := '{\rtf1\ansi\ansicpg1252\deff0\deflang1043{\fonttbl';

    for I := 0 to Fonts.Count - 1 do

      S := S + Format('{\f%d %s;}', [I, Fonts[I]]);

    S := S + '}';



    S := S + '{\colortbl;';

    for I := 0 to Colors.Count - 1 do

    begin

      J := ColorToRGB(TColor(Colors[I]));

      S := S + Format('\red%d\green%d\blue%d;', [J and $FF, (J shr 8) and $FF, (J shr 16) and $FF]);

    end;

    S := S + '}';

    if (GetLocaleInfo(LOCALE_USER_DEFAULT, LOCALE_IMEASURE, @LocaleBuffer[0], Length(LocaleBuffer)) <> 0) and (LocaleBuffer[0] = '0'{metric}) then

      S := S + '\paperw16840\paperh11907'// This sets A4 landscape format

    else

      S := S + '\paperw15840\paperh12240';//[JAM:marder]  This sets US Letter landscape format

    // Make sure a small margin is used so that a lot of the table fits on a paper. This defines a margin of 0.5"

    S := S + '\margl720\margr720\margt720\margb720';

    Result := S + Buffer.AsString + '}';

    Fonts.Free;

    Colors.Free;



    RestoreFontChangeEvent(Canvas);

  finally

    Buffer.Free;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TCustomVirtualStringTree.ContentToCustom(Source: TVSTTextSourceType);



// Generic export procedure which polls the application at every stage of the export.



var

  I: Integer;

  Save, Run: PVirtualNode;

  GetNextNode: TGetNextNodeProc;

  RenderColumns: Boolean;

  Columns: TColumnsArray;



begin

  Columns := nil;

  GetRenderStartValues(Source, Run, GetNextNode);

  Save := Run;



  RenderColumns := FHeader.UseColumns and ( hoVisible in FHeader.Options );



  if Assigned(FOnBeforeTreeExport) then

    FOnBeforeTreeExport(Self, etCustom);



  // Fill table header.

  if RenderColumns then

  begin

    if Assigned(FOnBeforeHeaderExport) then

      FOnBeforeHeaderExport(Self, etCustom);



    Columns := FHeader.FColumns.GetVisibleColumns;

    for I := 0 to High(Columns) do

    begin

      if Assigned(FOnBeforeColumnExport) then

        FOnBeforeColumnExport(Self, etCustom, Columns[I]);



      if Assigned(FOnColumnExport) then

        FOnColumnExport(Self, etCustom, Columns[I]);



      if Assigned(FOnAfterColumnExport) then

        FOnAfterColumnExport(Self, etCustom, Columns[I]);

    end;



    if Assigned(FOnAfterHeaderExport) then

      FOnAfterHeaderExport(Self, etCustom);

  end;



  // Now write the content.

  Run := Save;

  while Assigned(Run) do

  begin

    if CanExportNode(Run) then

    begin

      if Assigned(FOnBeforeNodeExport) then

        FOnBeforeNodeExport(Self, etCustom, Run);



      if Assigned(FOnNodeExport) then

        FOnNodeExport(Self, etCustom, Run);



      if Assigned(FOnAfterNodeExport) then

        FOnAfterNodeExport(Self, etCustom, Run);

    end;



    Run := GetNextNode(Run);

  end;



  if Assigned(FOnAfterTreeExport) then

    FOnAfterTreeExport(Self, etCustom);

end;



//----------------------------------------------------------------------------------------------------------------------



function TCustomVirtualStringTree.ContentToText(Source: TVSTTextSourceType; Separator: Char): AnsiString;



begin

  Result := ContentToText(Source, AnsiString(Separator));

end;



//----------------------------------------------------------------------------------------------------------------------



function TCustomVirtualStringTree.ContentToText(Source: TVSTTextSourceType; const Separator: AnsiString): AnsiString;



// Renders the current tree content (depending on Source) as plain ANSI text.

// If an entry contains the separator char or double quotes then it is wrapped with double quotes

// and existing double quotes are duplicated.

// Note: Unicode strings are implicitely converted to ANSI strings based on the currently active user locale.



var

  RenderColumns: Boolean;

  Tabs: AnsiString;

  GetNextNode: TGetNextNodeProc;

  Run, Save: PVirtualNode;

  Level, MaxLevel: Cardinal;

  Columns: TColumnsArray;

  LastColumn: TVirtualTreeColumn;

  Index,

  I: Integer;

  Text: AnsiString;

  Buffer: TBufferedAnsiString;



begin

  Columns := nil;

  Buffer := TBufferedAnsiString.Create;

  try

    RenderColumns := FHeader.UseColumns;

    if RenderColumns then

      Columns := FHeader.FColumns.GetVisibleColumns;



    GetRenderStartValues(Source, Run, GetNextNode);

    Save := Run;



    // The text consists of visible groups representing the columns, which are separated by one or more separator

    // characters. There are always MaxLevel separator chars in a line (main column only). Either before the caption

    // to ident it or after the caption to make the following column aligned.

    MaxLevel := 0;

    while Assigned(Run) do

    begin

      Level := GetNodeLevel(Run);

      if Level > MaxLevel then

        MaxLevel := Level;

      Run := GetNextNode(Run);

    end;



    Tabs := DupeString(Separator, MaxLevel);



    // First line is always the header if used.

    if RenderColumns then

    begin

      LastColumn := Columns[High(Columns)];

      for I := 0 to High(Columns) do

      begin

        Buffer.Add(Columns[I].Text);

        if Columns[I] <> LastColumn then

        begin

          if Columns[I].Index = Header.MainColumn then

          begin

            Buffer.Add(Tabs);

            Buffer.Add(Separator);

          end

          else

            Buffer.Add(Separator);

        end;

      end;

      Buffer.AddNewLine;

    end

    else

      LastColumn := nil;



    Run := Save;

    if RenderColumns then

    begin

      while Assigned(Run) do

      begin

        if (not CanExportNode(Run) or

           (Assigned(FOnBeforeNodeExport) and (not FOnBeforeNodeExport(Self, etText, Run)))) then

        begin

          Run := GetNextNode(Run);

          Continue;

        end;

        for I := 0 to High(Columns) do

        begin

          if coVisible in Columns[I].Options then

          begin

            Index := Columns[I].Index;

            // This line implicitly converts the Unicode text to ANSI.

            Text := Self.Text[Run, Index];

            if Index = Header.MainColumn then

            begin

              Level := GetNodeLevel(Run);

              Buffer.Add(Copy(Tabs, 1, Integer(Level) * Length(Separator)));

              // Wrap the text with quotation marks if it contains the separator character.

              if (Pos(Separator, Text) > 0) or (Pos('"', Text) > 0) then

                Buffer.Add(AnsiQuotedStr(Text, '"'))

              else

                Buffer.Add(Text);

              Buffer.Add(Copy(Tabs, 1, Integer(MaxLevel - Level) * Length(Separator)));

            end

            else

              if (Pos(Separator, Text) > 0) or (Pos('"', Text) > 0) then

                Buffer.Add(AnsiQuotedStr(Text, '"'))

              else

                Buffer.Add(Text);



            if Columns[I] <> LastColumn then

              Buffer.Add(Separator);

          end;

        end;

        if Assigned(FOnAfterNodeExport) then

          FOnAfterNodeExport(Self, etText, Run);

        Run := GetNextNode(Run);

        Buffer.AddNewLine;

      end;

    end

    else

    begin

      while Assigned(Run) do

      begin

        if ((not CanExportNode(Run)) or

           (Assigned(FOnBeforeNodeExport) and (not FOnBeforeNodeExport(Self, etText, Run)))) then

        begin

          Run := GetNextNode(Run);

          Continue;

        end;

        // This line implicitly converts the Unicode text to ANSI.

        Text := Self.Text[Run, NoColumn];

        Level := GetNodeLevel(Run);

        Buffer.Add(Copy(Tabs, 1, Integer(Level) * Length(Separator)));

        Buffer.Add(Text);

        Buffer.AddNewLine;



        if Assigned(FOnAfterNodeExport) then

          FOnAfterNodeExport(Self, etText, Run);

        Run := GetNextNode(Run);

      end;

    end;



    Result := Buffer.AsString;

  finally

    Buffer.Free;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



function TCustomVirtualStringTree.ContentToUnicode(Source: TVSTTextSourceType; Separator: WideChar): UnicodeString;



begin

  Result := ContentToUnicode(Source, UnicodeString(Separator));

end;



//----------------------------------------------------------------------------------------------------------------------



function TCustomVirtualStringTree.ContentToUnicode(Source: TVSTTextSourceType; const Separator: UnicodeString): UnicodeString;



// Renders the current tree content (depending on Source) as Unicode text.

// If an entry contains the separator char then it is wrapped with double quotation marks.

// Note: There is no QuotedStr function for Unicode in the VCL (like AnsiQuotedStr) so we have the limitation here

//       that an entry must not contain double quotation marks, otherwise import into other programs might fail!



const

  WideCRLF: UnicodeString = #13#10;



var

  RenderColumns: Boolean;

  Tabs: UnicodeString;

  GetNextNode: TGetNextNodeProc;

  Run, Save: PVirtualNode;



  Columns: TColumnsArray;

  LastColumn: TVirtualTreeColumn;

  Level, MaxLevel: Cardinal;

  Index,

  I: Integer;

  Text: UnicodeString;

  Buffer: TWideBufferedString;



begin

  Columns := nil;



  Buffer := TWideBufferedString.Create;

  try

    RenderColumns := FHeader.UseColumns;

    if RenderColumns then

      Columns := FHeader.FColumns.GetVisibleColumns;



    GetRenderStartValues(Source, Run, GetNextNode);

    Save := Run;



    // The text consists of visible groups representing the columns, which are separated by one or more separator

    // characters. There are always MaxLevel separator chars in a line (main column only). Either before the caption

    // to ident it or after the caption to make the following column aligned.

    MaxLevel := 0;

    while Assigned(Run) do

    begin

      Level := GetNodeLevel(Run);

      if Level > MaxLevel then

        MaxLevel := Level;

      Run := GetNextNode(Run);

    end;



    Tabs := DupeString(Separator, MaxLevel);



    // First line is always the header if used.

    if RenderColumns then

    begin

      LastColumn := Columns[High(Columns)];

      for I := 0 to High(Columns) do

      begin

        Buffer.Add(Columns[I].Text);

        if Columns[I] <> LastColumn then

        begin

          if Columns[I].Index = Header.MainColumn then

          begin

            Buffer.Add(Tabs);

            Buffer.Add(Separator);

          end

          else

            Buffer.Add(Separator);

        end;

      end;

      Buffer.AddNewLine;

    end

    else

      LastColumn := nil;



    Run := Save;

    if RenderColumns then

    begin

      while Assigned(Run) do

      begin

        for I := 0 to High(Columns) do

        begin

          if coVisible in Columns[I].Options then

          begin

            Index := Columns[I].Index;

            Text := Self.Text[Run, Index];

            if Index = Header.MainColumn then

            begin

              Level := GetNodeLevel(Run);

              Buffer.Add(Copy(Tabs, 1, Integer(Level) * Length(Separator)));

              // Wrap the text with quotation marks if it contains the separator character.

              if Pos(Separator, Text) > 0 then

              begin

                Buffer.Add('"');

                Buffer.Add(Text);

                Buffer.Add('"');

              end

              else

                Buffer.Add(Text);

              Buffer.Add(Copy(Tabs, 1, Integer(MaxLevel - Level) * Length(Separator)));

            end

            else

              if Pos(Separator, Text) > 0 then

              begin

                Buffer.Add('"');

                Buffer.Add(Text);

                Buffer.Add('"');

              end

              else

                Buffer.Add(Text);



            if Columns[I] <> LastColumn then

              Buffer.Add(Separator);

          end;

        end;

        Run := GetNextNode(Run);

        Buffer.AddNewLine;

      end;

    end

    else

    begin

      while Assigned(Run) do

      begin

        Text := Self.Text[Run, NoColumn];

        Level := GetNodeLevel(Run);

        Buffer.Add(Copy(Tabs, 1, Integer(Level) * Length(Separator)));

        Buffer.Add(Text);

        Buffer.AddNewLine;



        Run := GetNextNode(Run);

      end;

    end;

    Result := Buffer.AsString;

  finally

    Buffer.Free;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TCustomVirtualStringTree.GetTextInfo(Node: PVirtualNode; Column: TColumnIndex; const AFont: TFont; var R: TRect;

  var Text: UnicodeString);



// Returns the font, the text and its bounding rectangle to the caller. R is returned as the closest

// bounding rectangle around Text.



var

  NewHeight: Integer;

  TM: TTextMetric;



begin

  // Get default font and initialize the other parameters.

  inherited GetTextInfo(Node, Column, AFont, R, Text);



  Canvas.Font := AFont;



  FFontChanged := False;

  RedirectFontChangeEvent(Canvas);

  DoPaintText(Node, Canvas, Column, ttNormal);

  if FFontChanged then

  begin

    AFont.Assign(Canvas.Font);

    GetTextMetrics(Canvas.Handle, TM);

    NewHeight := TM.tmHeight;

  end

  else // Otherwise the correct font is already there and we only need to set the correct height.

    NewHeight := FTextHeight;

  RestoreFontChangeEvent(Canvas);



  // Alignment to the actual text.

  Text := Self.Text[Node, Column];

  R := GetDisplayRect(Node, Column, True, not (vsMultiline in Node.States));

  if toShowHorzGridLines in TreeOptions.PaintOptions then

    Dec(R.Bottom);

  InflateRect(R, 0, -(R.Bottom - R.Top - NewHeight) div 2);

end;



//----------------------------------------------------------------------------------------------------------------------



function TCustomVirtualStringTree.InvalidateNode(Node: PVirtualNode): TRect;



var

  Data: PInteger;



begin

  Result := inherited InvalidateNode(Node);

  // Reset node width so changed text attributes are applied correctly.

  if Assigned(Node) then

  begin

    Data := InternalData(Node);

    if Assigned(Data) then

      Data^ := 0;

    // Reset height measured flag too to cause a re-issue of the OnMeasureItem event.

    Exclude(Node.States, vsHeightMeasured);

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



function TCustomVirtualStringTree.Path(Node: PVirtualNode; Column: TColumnIndex; TextType: TVSTTextType;

  Delimiter: WideChar): UnicodeString;



// Constructs a string containing the node and all its parents. The last character in the returned path is always the

// given delimiter.



var

  S: UnicodeString;



begin

  if (Node = nil) or (Node = FRoot) then

    Result := Delimiter

  else

  begin

    Result := '';

    while Node <> FRoot do

    begin

      DoGetText(Node, Column, TextType, S);

      Result := S + Delimiter + Result;

      Node := Node.Parent;

    end;

  end;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TCustomVirtualStringTree.ReinitNode(Node: PVirtualNode; Recursive: Boolean);



var

  Data: PInteger;



begin

  inherited;

  // Reset node width so changed text attributes are applied correctly.

  if Assigned(Node) and (Node <> FRoot) then

  begin

    Data := InternalData(Node);

    if Assigned(Data) then

      Data^ := 0;

    // vsHeightMeasured is already removed in the base tree.

  end;

end;



//----------------- TVirtualStringTree ---------------------------------------------------------------------------------



function TVirtualStringTree.GetOptions: TStringTreeOptions;



begin

  Result := FOptions as TStringTreeOptions;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TVirtualStringTree.SetOptions(const Value: TStringTreeOptions);



begin

  FOptions.Assign(Value);

end;



//----------------------------------------------------------------------------------------------------------------------



function TVirtualStringTree.GetOptionsClass: TTreeOptionsClass;



begin

  Result := TStringTreeOptions;

end;



//----------------------------------------------------------------------------------------------------------------------



{$if CompilerVersion >= 23}

class constructor TVirtualStringTree.Create();

begin

  TCustomStyleEngine.RegisterStyleHook(TVirtualStringTree, TVclStyleScrollBarsHook);

end;

{$ifend}



//----------------------------------------------------------------------------------------------------------------------



function TCustomVirtualDrawTree.DoGetCellContentMargin(Node: PVirtualNode; Column: TColumnIndex;

  CellContentMarginType: TVTCellContentMarginType = ccmtAllSides; Canvas: TCanvas = nil): TPoint;



begin

  Result := Point(0, 0);

  if Canvas = nil then

    Canvas := Self.Canvas;



  if Assigned(FOnGetCellContentMargin) then

    FOnGetCellContentMargin(Self, Canvas, Node, Column, CellContentMarginType, Result);

end;



//----------------------------------------------------------------------------------------------------------------------



function TCustomVirtualDrawTree.DoGetNodeWidth(Node: PVirtualNode; Column: TColumnIndex; Canvas: TCanvas = nil): Integer;



begin

  Result := 2 * FTextMargin;

  if Canvas = nil then

    Canvas := Self.Canvas;



  if Assigned(FOnGetNodeWidth) then

    FOnGetNodeWidth(Self, Canvas, Node, Column, Result);

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TCustomVirtualDrawTree.DoPaintNode(var PaintInfo: TVTPaintInfo);



begin

  if Assigned(FOnDrawNode) then

    FOnDrawNode(Self, PaintInfo);

end;



function TCustomVirtualDrawTree.GetDefaultHintKind: TVTHintKind;



begin

  Result := vhkOwnerDraw;

end;



//----------------- TVirtualDrawTree -----------------------------------------------------------------------------------



function TVirtualDrawTree.GetOptions: TVirtualTreeOptions;



begin

  Result := FOptions as TVirtualTreeOptions;

end;



//----------------------------------------------------------------------------------------------------------------------



procedure TVirtualDrawTree.SetOptions(const Value: TVirtualTreeOptions);



begin

  FOptions.Assign(Value);

end;



//----------------------------------------------------------------------------------------------------------------------



function TVirtualDrawTree.GetOptionsClass: TTreeOptionsClass;



begin

  Result := TVirtualTreeOptions;

end;



//----------------------------------------------------------------------------------------------------------------------



{$if CompilerVersion >= 23}

class constructor TVirtualDrawTree.Create();

begin

  TCustomStyleEngine.RegisterStyleHook(TVirtualDrawTree, TVclStyleScrollBarsHook);

end;

{$ifend}



//----------------------------------------------------------------------------------------------------------------------



// XE2+ VCL Style

 {$if CompilerVersion >= 23 }



{ TVclStyleScrollBarsHook }



procedure TVclStyleScrollBarsHook.CalcScrollBarsRect;

var

  P: TPoint;

  BorderValue: TSize;

  BarInfo: TScrollBarInfo;

  I: Integer;



  procedure CalcVerticalRects;

  begin

    BarInfo.cbSize := SizeOf(BarInfo);

    GetScrollBarInfo(Handle, Integer(OBJID_VSCROLL), BarInfo);

    FVertScrollBarWindow.Visible := not(STATE_SYSTEM_INVISIBLE and BarInfo.rgstate[0] <> 0);

    FVertScrollBarWindow.Enabled := not(STATE_SYSTEM_UNAVAILABLE and BarInfo.rgstate[0] <> 0);

    if FVertScrollBarWindow.Visible then

    begin

      // ScrollBar Rect

      P := BarInfo.rcScrollBar.TopLeft;

      ScreenToClient(Handle, P);

      FVertScrollBarRect.TopLeft := P;

      P := BarInfo.rcScrollBar.BottomRight;

      ScreenToClient(Handle, P);

      FVertScrollBarRect.BottomRight := P;

      OffsetRect(FVertScrollBarRect, BorderValue.cx, BorderValue.cy);



      I := GetSystemMetrics(SM_CYVTHUMB);

      // Down Button

      FVertScrollBarDownButtonRect := FVertScrollBarRect;

      FVertScrollBarDownButtonRect.Top := FVertScrollBarDownButtonRect.Bottom - I;



      // UP Button

      FVertScrollBarUpButtonRect := FVertScrollBarRect;

      FVertScrollBarUpButtonRect.Bottom := FVertScrollBarUpButtonRect.Top + I;



      FVertScrollBarSliderTrackRect := FVertScrollBarRect;

      Inc(FVertScrollBarSliderTrackRect.Top, I);

      Dec(FVertScrollBarSliderTrackRect.Bottom, I);

    end;

  end;



  procedure CalcHorizontalRects;

  begin

    BarInfo.cbSize := SizeOf(BarInfo);

    GetScrollBarInfo(Handle, Integer(OBJID_HSCROLL), BarInfo);

    FHorzScrollBarWindow.Visible := not(STATE_SYSTEM_INVISIBLE and BarInfo.rgstate[0] <> 0);

    FHorzScrollBarWindow.Enabled := not(STATE_SYSTEM_UNAVAILABLE and BarInfo.rgstate[0] <> 0);

    if FHorzScrollBarWindow.Visible then

    begin

      // ScrollBar Rect

      P := BarInfo.rcScrollBar.TopLeft;

      ScreenToClient(Handle, P);

      FHorzScrollBarRect.TopLeft := P;

      P := BarInfo.rcScrollBar.BottomRight;

      ScreenToClient(Handle, P);

      FHorzScrollBarRect.BottomRight := P;

      OffsetRect(FHorzScrollBarRect, BorderValue.cx, BorderValue.cy);



      I := GetSystemMetrics(SM_CXHTHUMB);

      // Down Button

      FHorzScrollBarDownButtonRect := FHorzScrollBarRect;

      FHorzScrollBarDownButtonRect.Left := FHorzScrollBarDownButtonRect.Right - I;



      // UP Button

      FHorzScrollBarUpButtonRect := FHorzScrollBarRect;

      FHorzScrollBarUpButtonRect.Right := FHorzScrollBarUpButtonRect.Left + I;



      FHorzScrollBarSliderTrackRect := FHorzScrollBarRect;

      Inc(FHorzScrollBarSliderTrackRect.Left, I);

      Dec(FHorzScrollBarSliderTrackRect.Right, I);

    end;

  end;



begin

  BorderValue.cx := 0;

  BorderValue.cy := 0;

  if HasBorder then

    if HasClientEdge then

    begin

      BorderValue.cx := GetSystemMetrics(SM_CXEDGE);

      BorderValue.cy := GetSystemMetrics(SM_CYEDGE);

    end;

  CalcVerticalRects;

  CalcHorizontalRects;



end;



constructor TVclStyleScrollBarsHook.Create(AControl: TWinControl);

begin

  inherited;

  FVertScrollBarWindow := TVclStyleScrollBarWindow.CreateParented(GetParent(Control.Handle));

  FVertScrollBarWindow.ScrollBarWindowOwner := Self;

  FVertScrollBarWindow.ScrollBarVertical := True;



  FHorzScrollBarWindow := TVclStyleScrollBarWindow.CreateParented(GetParent(Control.Handle));

  FHorzScrollBarWindow.ScrollBarWindowOwner := Self;



  FVertScrollBarSliderState := tsThumbBtnVertNormal;

  FVertScrollBarUpButtonState := tsArrowBtnUpNormal;

  FVertScrollBarDownButtonState := tsArrowBtnDownNormal;

  FHorzScrollBarSliderState := tsThumbBtnHorzNormal;

  FHorzScrollBarUpButtonState := tsArrowBtnLeftNormal;

  FHorzScrollBarDownButtonState := tsArrowBtnRightNormal;

end;



destructor TVclStyleScrollBarsHook.Destroy;

begin

  FVertScrollBarWindow.ScrollBarWindowOwner := nil;

  FreeAndNil(FVertScrollBarWindow);

  FHorzScrollBarWindow.ScrollBarWindowOwner := nil;

  FreeAndNil(FHorzScrollBarWindow);

  inherited;

end;



procedure TVclStyleScrollBarsHook.DrawHorzScrollBar(DC: HDC);

var

  B: TBitmap;

  Details: TThemedElementDetails;

  R: TRect;

begin

  if ((Handle = 0) or (DC = 0)) then

    Exit;

  if FHorzScrollBarWindow.Visible and StyleServices.Available then

  begin

    B := TBitmap.Create;

    try

      B.Width := FHorzScrollBarRect.Width;

      B.Height := FHorzScrollBarRect.Height;

      MoveWindowOrg(B.Canvas.Handle, -FHorzScrollBarRect.Left, -FHorzScrollBarRect.Top);

      R := FHorzScrollBarRect;

      R.Left := FHorzScrollBarUpButtonRect.Right;

      R.Right := FHorzScrollBarDownButtonRect.Left;



      Details := StyleServices.GetElementDetails(tsUpperTrackHorzNormal);

      StyleServices.DrawElement(B.Canvas.Handle, Details, R);



      if FHorzScrollBarWindow.Enabled then

        Details := StyleServices.GetElementDetails(FHorzScrollBarSliderState);

      StyleServices.DrawElement(B.Canvas.Handle, Details, GetHorzScrollBarSliderRect);



      if FHorzScrollBarWindow.Enabled then

        Details := StyleServices.GetElementDetails(FHorzScrollBarUpButtonState)

      else

        Details := StyleServices.GetElementDetails(tsArrowBtnLeftDisabled);

      StyleServices.DrawElement(B.Canvas.Handle, Details, FHorzScrollBarUpButtonRect);



      if FHorzScrollBarWindow.Enabled then

        Details := StyleServices.GetElementDetails(FHorzScrollBarDownButtonState)

      else

        Details := StyleServices.GetElementDetails(tsArrowBtnRightDisabled);

      StyleServices.DrawElement(B.Canvas.Handle, Details, FHorzScrollBarDownButtonRect);



      MoveWindowOrg(B.Canvas.Handle, FHorzScrollBarRect.Left, FHorzScrollBarRect.Top);

      with FHorzScrollBarRect do

        BitBlt(DC, Left, Top, B.Width, B.Height, B.Canvas.Handle, 0, 0, SRCCOPY);

    finally

      B.Free;

    end;

  end;

end;



procedure TVclStyleScrollBarsHook.DrawVertScrollBar(DC: HDC);

var

  B: TBitmap;

  Details: TThemedElementDetails;

  R: TRect;

begin

  if ((Handle = 0) or (DC = 0)) then

    Exit;

  if FVertScrollBarWindow.Visible and StyleServices.Available then

  begin

    B := TBitmap.Create;

    try

      B.Width := FVertScrollBarRect.Width;

      B.Height := FVertScrollBarWindow.Height;

      MoveWindowOrg(B.Canvas.Handle, -FVertScrollBarRect.Left, -FVertScrollBarRect.Top);

      R := FVertScrollBarRect;

      R.Bottom := B.Height + FVertScrollBarRect.Top;

      Details := StyleServices.GetElementDetails(tsUpperTrackVertNormal);

      StyleServices.DrawElement(B.Canvas.Handle, Details, R);

      R.Top := FVertScrollBarUpButtonRect.Bottom;

      R.Bottom := FVertScrollBarDownButtonRect.Top;



      Details := StyleServices.GetElementDetails(tsUpperTrackVertNormal);

      StyleServices.DrawElement(B.Canvas.Handle, Details, R);



      if FVertScrollBarWindow.Enabled then

        Details := StyleServices.GetElementDetails(FVertScrollBarSliderState);

      StyleServices.DrawElement(B.Canvas.Handle, Details, GetVertScrollBarSliderRect);



      if FVertScrollBarWindow.Enabled then

        Details := StyleServices.GetElementDetails(FVertScrollBarUpButtonState)

      else

        Details := StyleServices.GetElementDetails(tsArrowBtnUpDisabled);

      StyleServices.DrawElement(B.Canvas.Handle, Details, FVertScrollBarUpButtonRect);



      if FVertScrollBarWindow.Enabled then

        Details := StyleServices.GetElementDetails(FVertScrollBarDownButtonState)

      else

        Details := StyleServices.GetElementDetails(tsArrowBtnDownDisabled);

      StyleServices.DrawElement(B.Canvas.Handle, Details, FVertScrollBarDownButtonRect);



      MoveWindowOrg(B.Canvas.Handle, FVertScrollBarRect.Left, FVertScrollBarRect.Top);

      with FVertScrollBarRect do

        BitBlt(DC, Left, Top, B.Width, B.Height, B.Canvas.Handle, 0, 0, SRCCOPY);

    finally

      B.Free;

    end;

  end;

end;



function TVclStyleScrollBarsHook.GetHorzScrollBarSliderRect: TRect;

var

  P: TPoint;

  BarInfo: TScrollBarInfo;

begin

  if FHorzScrollBarWindow.Visible and FHorzScrollBarWindow.Enabled then

  begin

    BarInfo.cbSize := SizeOf(BarInfo);

    GetScrollBarInfo(Handle, Integer(OBJID_HSCROLL), BarInfo);

    P := BarInfo.rcScrollBar.TopLeft;

    ScreenToClient(Handle, P);

    Result.TopLeft := P;

    P := BarInfo.rcScrollBar.BottomRight;

    ScreenToClient(Handle, P);

    Result.BottomRight := P;

    Result.Left := BarInfo.xyThumbTop;

    Result.Right := BarInfo.xyThumbBottom;

    if HasBorder then

      if HasClientEdge then

        OffsetRect(Result, 2, 2)

      else

        OffsetRect(Result, 1, 1);

  end

  else

    Result := Rect(0, 0, 0, 0);

end;



function TVclStyleScrollBarsHook.GetVertScrollBarSliderRect: TRect;

var

  P: TPoint;

  BarInfo: TScrollBarInfo;

begin

  if FVertScrollBarWindow.Visible and FVertScrollBarWindow.Enabled then

  begin

    BarInfo.cbSize := SizeOf(BarInfo);

    GetScrollBarInfo(Handle, Integer(OBJID_VSCROLL), BarInfo);

    P := BarInfo.rcScrollBar.TopLeft;

    ScreenToClient(Handle, P);

    Result.TopLeft := P;

    P := BarInfo.rcScrollBar.BottomRight;

    ScreenToClient(Handle, P);

    Result.BottomRight := P;

    Result.Top := BarInfo.xyThumbTop;

    Result.Bottom := BarInfo.xyThumbBottom;

    if HasBorder then

      if HasClientEdge then

        OffsetRect(Result, 2, 2)

      else

        OffsetRect(Result, 1, 1);

  end

  else

    Result := Rect(0, 0, 0, 0);

end;



procedure TVclStyleScrollBarsHook.MouseLeave;

begin

   inherited;

  if FVertScrollBarSliderState = tsThumbBtnVertHot then

    FVertScrollBarSliderState := tsThumbBtnVertNormal;



  if FHorzScrollBarSliderState = tsThumbBtnHorzHot then

    FHorzScrollBarSliderState := tsThumbBtnHorzNormal;



  if FVertScrollBarUpButtonState = tsArrowBtnUpHot then

    FVertScrollBarUpButtonState := tsArrowBtnUpNormal;



  if FVertScrollBarDownButtonState = tsArrowBtnDownHot then

    FVertScrollBarDownButtonState := tsArrowBtnDownNormal;



  if FHorzScrollBarUpButtonState = tsArrowBtnLeftHot then

    FHorzScrollBarUpButtonState := tsArrowBtnLeftNormal;



  if FHorzScrollBarDownButtonState = tsArrowBtnRightHot then

    FHorzScrollBarDownButtonState := tsArrowBtnRightNormal;



  PaintScrollBars;

end;



procedure TVclStyleScrollBarsHook.PaintScrollBars;

begin

  FVertScrollBarWindow.Repaint;

  FHorzScrollBarWindow.Repaint;

end;



function TVclStyleScrollBarsHook.PointInTreeHeader(const P: TPoint): Boolean;

begin

  Result := TBaseVirtualTree(Control).FHeader.InHeader(P);

end;



procedure TVclStyleScrollBarsHook.UpdateScrollBarWindow;

var

  R: TRect;

  Owner: TBaseVirtualTree;

  HeaderHeight: Integer;

  BorderWidth: Integer;

begin

  Owner := TBaseVirtualTree(Control);

  if (hoVisible in Owner.Header.Options) then

    HeaderHeight := Owner.FHeader.Height

  else

    HeaderHeight := 0;

  BorderWidth := 0;

  // VertScrollBarWindow

  if FVertScrollBarWindow.Visible then

  begin

    R := FVertScrollBarRect;

    if Control.BidiMode = bdRightToLeft then

    begin

      OffsetRect(R, -R.Left, 0);

      if HasBorder then

        OffsetRect(R, GetSystemMetrics(SM_CXEDGE), 0);

    end;

    if HasBorder then

      BorderWidth := GetSystemMetrics(SM_CYEDGE) * 2;

    ShowWindow(FVertScrollBarWindow.Handle, SW_SHOW);

    SetWindowPos(FVertScrollBarWindow.Handle, HWND_TOP, Control.Left + R.Left, Control.Top + R.Top + HeaderHeight, R.Right - R.Left,

      Control.Height - HeaderHeight  - BorderWidth, SWP_SHOWWINDOW);

  end

  else

    ShowWindow(FVertScrollBarWindow.Handle, SW_HIDE);



  // HorzScrollBarWindow

  if FHorzScrollBarWindow.Visible then

  begin

    R := FHorzScrollBarRect;

    if Control.BidiMode = bdRightToLeft then

      OffsetRect(R, FVertScrollBarRect.Width, 0);

    ShowWindow(FHorzScrollBarWindow.Handle, SW_SHOW);

    SetWindowPos(FHorzScrollBarWindow.Handle, HWND_TOP, Control.Left + R.Left, Control.Top + R.Top + HeaderHeight, R.Right - R.Left,

      R.Bottom - R.Top, SWP_SHOWWINDOW);

  end

  else

    ShowWindow(FHorzScrollBarWindow.Handle, SW_HIDE);

end;



procedure TVclStyleScrollBarsHook.WMCaptureChanged(var Msg: TMessage);

begin

   if FVertScrollBarWindow.Visible and FVertScrollBarWindow.Enabled then

  begin

    if FVertScrollBarUpButtonState = tsArrowBtnUpPressed then

    begin

      FVertScrollBarUpButtonState := tsArrowBtnUpNormal;

      PaintScrollBars;

    end;



    if FVertScrollBarDownButtonState = tsArrowBtnDownPressed then

    begin

      FVertScrollBarDownButtonState := tsArrowBtnDownNormal;

      PaintScrollBars;

    end;

  end;



  if FHorzScrollBarWindow.Visible and FHorzScrollBarWindow.Enabled then

  begin

    if FHorzScrollBarUpButtonState = tsArrowBtnLeftPressed then

    begin

      FHorzScrollBarUpButtonState := tsArrowBtnLeftNormal;

      PaintScrollBars;

    end;



    if FHorzScrollBarDownButtonState = tsArrowBtnRightPressed then

    begin

      FHorzScrollBarDownButtonState := tsArrowBtnRightNormal;

      PaintScrollBars;

    end;

  end;



  CallDefaultProc(TMessage(Msg));

  Handled := True;

end;



procedure TVclStyleScrollBarsHook.WMHScroll(var Msg: TMessage);

begin

  CallDefaultProc(TMessage(Msg));

  PaintScrollBars;

  Handled := True;

end;



procedure TVclStyleScrollBarsHook.CMUpdateVclStyleScrollBars(var Message: TMessage);

begin

   CalcScrollBarsRect;

   PaintScrollBars;

end;



procedure TVclStyleScrollBarsHook.WMKeyDown(var Msg: TMessage);

begin

  CallDefaultProc(TMessage(Msg));

  PaintScrollBars;

  Handled := True;

end;



procedure TVclStyleScrollBarsHook.WMKeyUp(var Msg: TMessage);

begin

  CallDefaultProc(TMessage(Msg));

  PaintScrollBars;

  Handled := True;

end;



procedure TVclStyleScrollBarsHook.WMLButtonDown(var Msg: TWMMouse);

begin

  CallDefaultProc(TMessage(Msg));

  PaintScrollBars;

  Handled := True;

end;



procedure TVclStyleScrollBarsHook.WMLButtonUp(var Msg: TWMMouse);

var

  P: TPoint;

begin

  P := Point(Msg.XPos, Msg.YPos);

  ScreenToClient(Handle, P);

  if not PointInTreeHeader(P) then

  begin

    if FVertScrollBarWindow.Visible then

    begin

      if FVertScrollBarSliderState = tsThumbBtnVertPressed then

      begin

        PostMessage(Handle, WM_VSCROLL, Integer(SmallPoint(SB_ENDSCROLL, 0)), 0);

        FLeftMouseButtonDown := False;

        FVertScrollBarSliderState := tsThumbBtnVertNormal;

        PaintScrollBars;

        Handled := True;

        ReleaseCapture;

        Exit;

      end;



      if FVertScrollBarUpButtonState = tsArrowBtnUpPressed then

        FVertScrollBarUpButtonState := tsArrowBtnUpNormal;



      if FVertScrollBarDownButtonState = tsArrowBtnDownPressed then

        FVertScrollBarDownButtonState := tsArrowBtnDownNormal;

    end;



    if FHorzScrollBarWindow.Visible then

    begin

      if FHorzScrollBarSliderState = tsThumbBtnHorzPressed then

      begin

        PostMessage(Handle, WM_HSCROLL, Integer(SmallPoint(SB_ENDSCROLL, 0)), 0);

        FLeftMouseButtonDown := False;

        FHorzScrollBarSliderState := tsThumbBtnHorzNormal;

        PaintScrollBars;

        Handled := True;

        ReleaseCapture;

        Exit;

      end;



      if FHorzScrollBarUpButtonState = tsArrowBtnLeftPressed then

        FHorzScrollBarUpButtonState := tsArrowBtnLeftNormal;



      if FHorzScrollBarDownButtonState = tsArrowBtnRightPressed then

        FHorzScrollBarDownButtonState := tsArrowBtnRightNormal;

    end;

    PaintScrollBars;

  end;

  FLeftMouseButtonDown := False;

end;



procedure TVclStyleScrollBarsHook.WMMouseMove(var Msg: TWMMouse);

var

  SF: TScrollInfo;

begin

  inherited;

  if FVertScrollBarSliderState = tsThumbBtnVertPressed then

  begin

    SF.fMask := SIF_ALL;

    SF.cbSize := SizeOf(SF);

    GetScrollInfo(Handle, SB_VERT, SF);

    if SF.nPos <> Round(FScrollPos) then

      FScrollPos := SF.nPos;



    FScrollPos := FScrollPos + (SF.nMax - SF.nMin) * ((Mouse.CursorPos.Y - FPrevScrollPos) / FVertScrollBarSliderTrackRect.Height);

    if FScrollPos < SF.nMin then

      FScrollPos := SF.nMin;

    if FScrollPos > SF.nMax then

      FScrollPos := SF.nMax;

    if SF.nPage <> 0 then

      if Round(FScrollPos) > SF.nMax - Integer(SF.nPage) + 1 then

        FScrollPos := SF.nMax - Integer(SF.nPage) + 1;

    FPrevScrollPos := Mouse.CursorPos.Y;

    SF.nPos := Round(FScrollPos);



    SetScrollInfo(Handle, SB_VERT, SF, False);

    PostMessage(Handle, WM_VSCROLL, Integer(SmallPoint(SB_THUMBPOSITION, Min(Round(FScrollPos), High(SmallInt)))), 0); // Min() prevents range check error



    PaintScrollBars;

    Handled := True;

    Exit;

  end;



  if FHorzScrollBarSliderState = tsThumbBtnHorzPressed then

  begin

    SF.fMask := SIF_ALL;

    SF.cbSize := SizeOf(SF);

    GetScrollInfo(Handle, SB_HORZ, SF);

    if SF.nPos <> Round(FScrollPos) then

      FScrollPos := SF.nPos;



    FScrollPos := FScrollPos + (SF.nMax - SF.nMin) * ((Mouse.CursorPos.X - FPrevScrollPos) / FHorzScrollBarSliderTrackRect.Width);

    if FScrollPos < SF.nMin then

      FScrollPos := SF.nMin;

    if FScrollPos > SF.nMax then

      FScrollPos := SF.nMax;

    if SF.nPage <> 0 then

      if Round(FScrollPos) > SF.nMax - Integer(SF.nPage) + 1 then

        FScrollPos := SF.nMax - Integer(SF.nPage) + 1;

    FPrevScrollPos := Mouse.CursorPos.X;

    SF.nPos := Round(FScrollPos);



    SetScrollInfo(Handle, SB_HORZ, SF, False);

    PostMessage(Handle, WM_HSCROLL, Integer(SmallPoint(SB_THUMBPOSITION, Round(FScrollPos))), 0);



    PaintScrollBars;

    Handled := True;

    Exit;

  end;



  if FHorzScrollBarSliderState = tsThumbBtnHorzHot then

  begin

    FHorzScrollBarSliderState := tsThumbBtnHorzNormal;

    PaintScrollBars;

  end

  else

    if FVertScrollBarSliderState = tsThumbBtnVertHot then

     begin

       FVertScrollBarSliderState := tsThumbBtnVertNormal;

       PaintScrollBars;

     end  

     else

       if FHorzScrollBarUpButtonState = tsArrowBtnLeftHot then

       begin

         FHorzScrollBarUpButtonState := tsArrowBtnLeftNormal;

         PaintScrollBars;

       end

       else

         if FHorzScrollBarDownButtonState = tsArrowBtnRightHot then

         begin

           FHorzScrollBarDownButtonState := tsArrowBtnRightNormal;

           PaintScrollBars;

         end

         else

          if FVertScrollBarUpButtonState = tsArrowBtnUpHot then

          begin

            FVertScrollBarUpButtonState := tsArrowBtnUpNormal;

            PaintScrollBars;

          end

          else

            if FVertScrollBarDownButtonState = tsArrowBtnDownHot then

            begin

              FVertScrollBarDownButtonState := tsArrowBtnDownNormal;

              PaintScrollBars;

            end;



  CallDefaultProc(TMessage(Msg));

  if FLeftMouseButtonDown then

    PaintScrollBars;

  Handled := True;

end;



procedure TVclStyleScrollBarsHook.WMMouseWheel(var Msg: TMessage);

begin

   CallDefaultProc(TMessage(Msg));

  PaintScrollBars;

  Handled := True;

end;



procedure TVclStyleScrollBarsHook.WMNCLButtonDblClk(var Msg: TWMMouse);

begin

  WMNCLButtonDown(Msg);

end;



procedure TVclStyleScrollBarsHook.WMNCLButtonDown(var Msg: TWMMouse);

var

  P: TPoint;

  SF: TScrollInfo;

begin

  P := Point(Msg.XPos, Msg.YPos);

  ScreenToClient(Handle, P);



  if HasBorder then

    if HasClientEdge then

    begin

      P.X := P.X + 2;

      P.Y := P.Y + 2;

    end

    else

    begin

      P.X := P.X + 1;

      P.Y := P.Y + 1;

    end;



  if not PointInTreeHeader(P) then

  begin

    if FVertScrollBarWindow.Visible then

    begin

      if PtInRect(GetVertScrollBarSliderRect, P) then

      begin

        FLeftMouseButtonDown := True;

        SF.fMask := SIF_ALL;

        SF.cbSize := SizeOf(SF);

        GetScrollInfo(Handle, SB_VERT, SF);

        // FListPos := SF.nPos;

        FScrollPos := SF.nPos;

        FPrevScrollPos := Mouse.CursorPos.Y;

        FVertScrollBarSliderState := tsThumbBtnVertPressed;

        PaintScrollBars;

        SetCapture(Handle);

        Handled := True;

        Exit;

      end;



      if FVertScrollBarWindow.Enabled then

      begin

        if PtInRect(FVertScrollBarDownButtonRect, P) then

          FVertScrollBarDownButtonState := tsArrowBtnDownPressed;

        if PtInRect(FVertScrollBarUpButtonRect, P) then

          FVertScrollBarUpButtonState := tsArrowBtnUpPressed;

      end;

    end;



    if FHorzScrollBarWindow.Visible then

    begin

      if PtInRect(GetHorzScrollBarSliderRect, P) then

      begin

        FLeftMouseButtonDown := True;

        SF.fMask := SIF_ALL;

        SF.cbSize := SizeOf(SF);

        GetScrollInfo(Handle, SB_HORZ, SF);

        // FListPos := SF.nPos;

        FScrollPos := SF.nPos;

        FPrevScrollPos := Mouse.CursorPos.X;

        FHorzScrollBarSliderState := tsThumbBtnHorzPressed;

        PaintScrollBars;

        SetCapture(Handle);

        Handled := True;

        Exit;

      end;



      if FHorzScrollBarWindow.Enabled then

      begin

        if PtInRect(FHorzScrollBarDownButtonRect, P) then

          FHorzScrollBarDownButtonState := tsArrowBtnRightPressed;

        if PtInRect(FHorzScrollBarUpButtonRect, P) then

          FHorzScrollBarUpButtonState := tsArrowBtnLeftPressed;

      end;

    end;

    FLeftMouseButtonDown := True;

    PaintScrollBars;

  end;

end;



procedure TVclStyleScrollBarsHook.WMNCLButtonUp(var Msg: TWMMouse);

var

  P: TPoint;

  B: Boolean;

begin

  P := Point(Msg.XPos, Msg.YPos);

  ScreenToClient(Handle, P);



  if HasBorder then

    if HasClientEdge then

    begin

      P.X := P.X + 2;

      P.Y := P.Y + 2;

    end

    else

    begin

      P.X := P.X + 1;

      P.Y := P.Y + 1;

    end;



  B := PointInTreeHeader(P);



  if not B then

  begin

    if FVertScrollBarWindow.Visible then

      if FVertScrollBarWindow.Enabled then

      begin

        if FVertScrollBarSliderState = tsThumbBtnVertPressed then

        begin

          FLeftMouseButtonDown := False;

          FVertScrollBarSliderState := tsThumbBtnVertNormal;

          PaintScrollBars;

          Handled := True;

          Exit;

        end;



        if PtInRect(FVertScrollBarDownButtonRect, P) then

          FVertScrollBarDownButtonState := tsArrowBtnDownHot

        else

          FVertScrollBarDownButtonState := tsArrowBtnDownNormal;



        if PtInRect(FVertScrollBarUpButtonRect, P) then

          FVertScrollBarUpButtonState := tsArrowBtnUpHot

        else

          FVertScrollBarUpButtonState := tsArrowBtnUpNormal;

      end;



    if FHorzScrollBarWindow.Visible then

      if FHorzScrollBarWindow.Enabled then

      begin

        if FHorzScrollBarSliderState = tsThumbBtnHorzPressed then

        begin

          FLeftMouseButtonDown := False;

          FHorzScrollBarSliderState := tsThumbBtnHorzNormal;

          PaintScrollBars;

          Handled := True;

          Exit;

        end;



        if PtInRect(FHorzScrollBarDownButtonRect, P) then

          FHorzScrollBarDownButtonState := tsArrowBtnRightHot

        else

          FHorzScrollBarDownButtonState := tsArrowBtnRightNormal;



        if PtInRect(FHorzScrollBarUpButtonRect, P) then

          FHorzScrollBarUpButtonState := tsArrowBtnLeftHot

        else

          FHorzScrollBarUpButtonState := tsArrowBtnLeftNormal;

      end;

    CallDefaultProc(TMessage(Msg));

  end;

  

  if not B and (FHorzScrollBarWindow.Visible) or (FVertScrollBarWindow.Visible) then

    PaintScrollBars;

  Handled := True;

end;



procedure TVclStyleScrollBarsHook.WMNCMouseMove(var Msg: TWMMouse);

var

  P: TPoint;

  MustUpdateScroll: Boolean;

  B: Boolean;

begin

  inherited;

  P := Point(Msg.XPos, Msg.YPos);

  ScreenToClient(Handle, P);



  if PointInTreeHeader(P) then

  begin

    CallDefaultProc(TMessage(Msg));

    PaintScrollBars;

    Handled := True;

    Exit;

  end;



  if HasBorder then

    if HasClientEdge then

    begin

      P.X := P.X + 2;

      P.Y := P.Y + 2;

    end

    else

    begin

      P.X := P.X + 1;

      P.Y := P.Y + 1;

    end;



  MustUpdateScroll := False;

  if FVertScrollBarWindow.Enabled then

  begin

    B := PtInRect(GetVertScrollBarSliderRect, P);

    if B and (FVertScrollBarSliderState = tsThumbBtnVertNormal) then

    begin

      FVertScrollBarSliderState := tsThumbBtnVertHot;

      MustUpdateScroll := True;

    end

    else if not B and (FVertScrollBarSliderState = tsThumbBtnVertHot) then

    begin

      FVertScrollBarSliderState := tsThumbBtnVertNormal;

      MustUpdateScroll := True;

    end;



    B := PtInRect(FVertScrollBarDownButtonRect, P);

    if B and (FVertScrollBarDownButtonState = tsArrowBtnDownNormal) then

    begin

      FVertScrollBarDownButtonState := tsArrowBtnDownHot;

      MustUpdateScroll := True;

    end

    else if not B and (FVertScrollBarDownButtonState = tsArrowBtnDownHot) then

    begin

      FVertScrollBarDownButtonState := tsArrowBtnDownNormal;

      MustUpdateScroll := True;

    end;

    B := PtInRect(FVertScrollBarUpButtonRect, P);

    if B and (FVertScrollBarUpButtonState = tsArrowBtnUpNormal) then

    begin

      FVertScrollBarUpButtonState := tsArrowBtnUpHot;

      MustUpdateScroll := True;

    end

    else if not B and (FVertScrollBarUpButtonState = tsArrowBtnUpHot) then

    begin

      FVertScrollBarUpButtonState := tsArrowBtnUpNormal;

      MustUpdateScroll := True;

    end;

  end;



  if FHorzScrollBarWindow.Enabled then

  begin

    B := PtInRect(GetHorzScrollBarSliderRect, P);

    if B and (FHorzScrollBarSliderState = tsThumbBtnHorzNormal) then

    begin

      FHorzScrollBarSliderState := tsThumbBtnHorzHot;

      MustUpdateScroll := True;

    end

    else if not B and (FHorzScrollBarSliderState = tsThumbBtnHorzHot) then

    begin

      FHorzScrollBarSliderState := tsThumbBtnHorzNormal;

      MustUpdateScroll := True;

    end;



    B := PtInRect(FHorzScrollBarDownButtonRect, P);

    if B and (FHorzScrollBarDownButtonState = tsArrowBtnRightNormal) then

    begin

      FHorzScrollBarDownButtonState := tsArrowBtnRightHot;

      MustUpdateScroll := True;

    end

    else if not B and (FHorzScrollBarDownButtonState = tsArrowBtnRightHot) then

    begin

      FHorzScrollBarDownButtonState := tsArrowBtnRightNormal;

      MustUpdateScroll := True;

    end;



    B := PtInRect(FHorzScrollBarUpButtonRect, P);

    if B and (FHorzScrollBarUpButtonState = tsArrowBtnLeftNormal) then

    begin

      FHorzScrollBarUpButtonState := tsArrowBtnLeftHot;

      MustUpdateScroll := True;

    end

    else if not B and (FHorzScrollBarUpButtonState = tsArrowBtnLeftHot) then

    begin

      FHorzScrollBarUpButtonState := tsArrowBtnLeftNormal;

      MustUpdateScroll := True;

    end;

  end;



  if MustUpdateScroll then

    PaintScrollBars;

end;



procedure TVclStyleScrollBarsHook.WMNCPaint(var Msg: TMessage);

begin

  CalcScrollBarsRect;

  UpdateScrollBarWindow;

 //  PaintScrollBars;

//  Handled := True;

end;



procedure TVclStyleScrollBarsHook.WMSize(var Msg: TMessage);

begin

  CallDefaultProc(TMessage(Msg));

  CalcScrollBarsRect;

  UpdateScrollBarWindow;

  PaintScrollBars;

  Handled := True;

end;



procedure TVclStyleScrollBarsHook.WMMove(var Msg: TMessage);

begin

  CallDefaultProc(TMessage(Msg));

  if not (tsWindowCreating in TBaseVirtualTree(Control).FStates) then

  begin

    CalcScrollBarsRect;

    UpdateScrollBarWindow;

    PaintScrollBars;

  end;

  Handled := True;

end;



procedure TVclStyleScrollBarsHook.WMPosChanged(var Msg: TMessage);

begin

  WMMove(Msg);

end;



procedure TVclStyleScrollBarsHook.WMVScroll(var Msg: TMessage);

begin

  CallDefaultProc(TMessage(Msg));

  PaintScrollBars;

  Handled := True;

end;



{ TVclStyleScrollBarsHook.TVclStyleScrollBarWindow }



constructor TVclStyleScrollBarsHook.TVclStyleScrollBarWindow.Create(AOwner: TComponent);

begin

  inherited;

  ControlStyle := ControlStyle + [csOverrideStylePaint];

  FScrollBarWindowOwner := nil;

  FScrollBarVertical := False;

  FScrollBarVisible := False;

  FScrollBarEnabled := False;

end;



procedure TVclStyleScrollBarsHook.TVclStyleScrollBarWindow.CreateParams(var Params: TCreateParams);

begin

  inherited;

  Params.Style := Params.Style or WS_CHILDWINDOW or WS_CLIPCHILDREN or WS_CLIPSIBLINGS;

  Params.ExStyle := Params.ExStyle or WS_EX_NOPARENTNOTIFY;

end;



procedure TVclStyleScrollBarsHook.TVclStyleScrollBarWindow.WMEraseBkgnd(var Msg: TMessage);

begin

   Msg.Result := 1;

end;



procedure TVclStyleScrollBarsHook.TVclStyleScrollBarWindow.WMNCHitTest(var Msg: TWMNCHitTest);

begin

   Msg.Result := HTTRANSPARENT;

end;



procedure TVclStyleScrollBarsHook.TVclStyleScrollBarWindow.WMPaint(var Msg: TWMPaint);

var

  PS: TPaintStruct;

  DC: HDC;

begin

  BeginPaint(Handle, PS);

  try

    if FScrollBarWindowOwner <> nil then

    begin

      DC := GetWindowDC(Handle);

      try

        if FScrollBarVertical then

        begin

          MoveWindowOrg(DC, -FScrollBarWindowOwner.FVertScrollBarRect.Left, -FScrollBarWindowOwner.FVertScrollBarRect.Top);

          FScrollBarWindowOwner.DrawVertScrollBar(DC);

        end

        else

        begin

          MoveWindowOrg(DC, -FScrollBarWindowOwner.FHorzScrollBarRect.Left, -FScrollBarWindowOwner.FHorzScrollBarRect.Top);

          FScrollBarWindowOwner.DrawHorzScrollBar(DC);

        end;

      finally

        ReleaseDC(Handle, DC);

      end;

    end;

  finally

    EndPaint(Handle, PS);

  end;

end;

{$ifend}



initialization

  // Necessary for dynamic package loading.

  Initialized := False;

  NeedToUnitialize := False;



  // This watcher is used whenever a global structure could be modified by more than one thread.

  Watcher := TCriticalSection.Create;



finalization

  if Initialized then

    FinalizeGlobalStructures;



  InternalClipboardFormats.Free;

  InternalClipboardFormats := nil;

  Watcher.Free;

  Watcher := nil;



end.