paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-11-04 15:32:00 +01:00
Code Issues Packages Projects Releases Wiki Activity
0c22a2c5a8
lazarus/components/virtualtreeview/VirtualTrees.pas
balazs 8cb178de2c VTV: Initial commit. 
git-svn-id: trunk@56963 -
2018-01-05 09:03:08 +00:00

36054 lines
1.2 MiB
Raw Blame History

unit VirtualTrees;
{$mode delphi}{$H+}
{$packset 1}
{$if not (defined(CPU386) or Defined(CPUX64))}
{$define PACKARRAYPASCAL}
{$endif}
// 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)
// LCL Port:
// Luiz Américo Pereira Câmara
//----------------------------------------------------------------------------------------------------------------------
interface
{$I VTConfig.inc}
uses
{$ifdef Windows}
Windows,
ActiveX,
CommCtrl,
{$else}
FakeActiveX,
{$endif}
OleUtils,
LCLIntf,
{$ifdef USE_DELPHICOMPAT}
DelphiCompat,
LclExt,
{$endif}
virtualpanningwindow,
VTGraphics, //alpha blend functions
{$ifdef DEBUG_VTV}
VTLogger,
{$endif}
LCLType, LMessages, Types,
SysUtils, Classes, Graphics, Controls, Forms, ImgList, StdCtrls, Menus, Printers,
SyncObjs, // Thread support
Clipbrd // Clipboard support
{$ifdef ThemeSupport}
, Themes , TmSchema
{$endif ThemeSupport}
{$ifdef EnableAccessible}
, oleacc // for MSAA IAccessible support
{$endif};
const
{$I lclconstants.inc}
{$if defined(LCLGtk) or defined(LCLGtk2)}
{$define Gtk}
{$endif}
{$if defined(Gtk)}
{$define ManualClipNeeded}
{$endif}
{$if defined(LCLGtk2) or defined(LCLCarbon) or defined(LCLQt)}
{$define ContextMenuBeforeMouseUp}
{$endif}
VTMajorVersion = 5;
VTMinorVersion = 5;
VTReleaseVersion = 3;
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;
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));
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}';
// 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);
//Panning Cursors
crVT_MOVEALL = TCursor(64);
crVT_MOVEEW = TCursor(65);
crVT_MOVENS = TCursor(66);
crVT_MOVENW = TCursor(67);
crVT_MOVESW = TCursor(68);
crVT_MOVENE = TCursor(69);
crVT_MOVESE = TCursor(70);
crVT_MOVEW = TCursor(71);
crVT_MOVEE = TCursor(72);
crVT_MOVEN = TCursor(73);
crVT_MOVES = TCursor(74);
UtilityImageSize = 16; // Needed by descendants for hittests.
{$if defined(LCLCarbon) or defined(LCLCocoa)}
ssCtrlOS = ssMeta; // Mac OS X fix
{$else}
ssCtrlOS = ssCtrl;
{$endif}
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;
type
// The exception used by the trees.
EVirtualTreeError = class(Exception);
// 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.
TRealWMNCPaint = packed record
Msg: UINT;
Rgn: HRGN;
lParam: LPARAM;
Result: LRESULT;
end;
// 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;
TVTScrollBarStyle = (
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 = 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: LongWord; out elt: FormatEtc;pceltFetched:pULong=nil): HResult; stdcall;
function Reset: HResult; stdcall;
function Skip(celt: LongWord): HResult; stdcall;
end;
// ----- OLE drag'n drop handling
IDropTargetHelper = interface(IUnknown)
[SID_IDropTargetHelper]
function DragEnter(hwndTarget: HWND; pDataObject: IDataObject; var ppt: TPoint; dwEffect: LongWord): HRESULT; stdcall;
function DragLeave: HRESULT; stdcall;
function DragOver(var ppt: TPoint; dwEffect: LongWord): HRESULT; stdcall;
function Drop(pDataObject: IDataObject; var ppt: TPoint; dwEffect: LongWord): 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}
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: DWord; const advSink: IAdviseSink; out dwConnection: DWord):
HResult; virtual; stdcall;
function DUnadvise(dwConnection: DWord): HResult; virtual; stdcall;
Function EnumDAdvise(out enumAdvise : IEnumStatData):HResult;virtual;StdCall;
function EnumFormatEtc(Direction: DWord; out EnumFormatEtc: IEnumFormatEtc): HResult; virtual; stdcall;
function GetCanonicalFormatEtc(const pformatetcIn : FORMATETC;Out pformatetcOut : FORMATETC):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; const 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: LongWord; Pt: TPoint;
var Effect: LongWord): HResult; stdcall;
function DragLeave: HResult; stdcall;
function DragOver(KeyState: LongWord; Pt: TPoint; var Effect: LongWord): HResult; stdcall;
function Drop(const DataObject: IDataObject; KeyState: LongWord; Pt: TPoint; var Effect: LongWord): HResult; stdcall;
procedure ForceDragLeave; stdcall;
{$IF (FPC_FULLVERSION < 020601) and DEFINED(LCLWin32)}
function GiveFeedback(Effect: Longint): HResult; stdcall;
function QueryContinueDrag(EscapePressed: BOOL; KeyState: Longint): HResult; stdcall;
{$ELSE}
function GiveFeedback(Effect: LongWord): HResult; stdcall;
function QueryContinueDrag(EscapePressed: BOOL; KeyState: LongWord): HResult; stdcall;
{$ENDIF}
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: String; // used only if there is no node specific hint string available
// or a header hint is about to appear
HintText: String; // set when size of the hint window is calculated
HintInfo: PHintInfo;
end;
// The trees need an own hint window class because of Unicode output and adjusted font.
{ TVirtualTreeHintWindow }
TVirtualTreeHintWindow = class(THintWindow)
private
FHintData: TVTHintData;
procedure WMShowWindow(var Message: TLMShowWindow); message LM_SHOWWINDOW;
public
function CalcHintRect(MaxWidth: Integer; const AHint: string; AData: Pointer): TRect; override;
procedure Paint; 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(const P: TPoint; ForceRepaint: Boolean): Boolean;
procedure EndDrag;
function GetDragImageRect: TRect;
procedure HideDragImage;
procedure PrepareDrag(DragImage: TBitmap; const ImagePosition, HotSpot: TPoint; const DataObject: IDataObject);
procedure RecaptureBackground(Tree: TBaseVirtualTree; R: TRect; VisibleRegion: HRGN; CaptureNCArea,
ReshowDragImage: Boolean);
procedure ShowDragImage;
function WillMove(const 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: TTranslateString;
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: String;
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; const Client: TRect; UseHeaderGlyph, UseSortGlyph: Boolean;
var HeaderGlyphPos, SortGlyphPos: TPoint; var SortGlyphSize: TSize; var TextBounds: TRect; DrawFormat: Cardinal;
CalculateTextRect: Boolean = False);
procedure GetAbsoluteBounds(var Left, Right: Integer);
function GetDisplayName: string; override;
function GetText: String; virtual; // [IPK]
procedure SetText(const Value: TTranslateString); virtual; // [IPK] private to protected & virtual
function GetOwner: TVirtualTreeColumns; reintroduce;
property HasImage: Boolean read FHasImage;
property ImageRect: TRect read FImageRect;
public
constructor Create(Collection: TCollection); override;
destructor Destroy; override;
procedure Assign(Source: TPersistent); override;
function Equals(OtherColumnObj: TObject): Boolean; override;
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: String 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: TTranslateString 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: TTranslateString read GetText write SetText;
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 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(const 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: String; Bounds: TRect; Enabled, Hot: Boolean; DrawFormat: Cardinal;
WrapCaption: Boolean);
procedure FixPositions;
function GetColumnAndBounds(const 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(const P: TPoint; Relative: Boolean = True): TColumnIndex; overload; virtual;
function ColumnFromPosition(PositionIndex: TColumnPosition): TColumnIndex; overload; virtual;
function Equals(OtherColumnsObj: TObject): Boolean; override;
procedure GetColumnBounds(Column: TColumnIndex; out 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; const 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 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(const 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(const P: TPoint);
procedure FixedAreaConstraintsChanged(Sender: TObject);
function GetColumnsClass: TVirtualTreeColumnsClass; virtual;
function GetOwner: TPersistent; override;
function GetShiftState: TShiftState;
function HandleHeaderMouseMove(var Message: TLMMouseMove): Boolean;
function HandleMessage(var Message: TLMessage): Boolean; virtual;
procedure ImageListChange(Sender: TObject);
procedure PrepareDrag(P, Start: TPoint);
procedure RecalculateHeader; virtual;
procedure RescaleHeader;
procedure UpdateMainColumn;
procedure UpdateSpringColumns;
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(const 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;
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: TLMessage); 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: TVTScrollBarStyle; // 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: TVTScrollBarStyle);
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: TVTScrollBarStyle 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
TVTGetNodeProc = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode; Data: Pointer; var Abort: Boolean) of object;
// 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: String) 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; const DropPosition: TPoint) of object;
TVTHeaderPaintEvent = procedure(Sender: TVTHeader; HeaderCanvas: TCanvas; Column: TVirtualTreeColumn; const 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;
const Pt: TPoint; Mode: TDropMode; var Effect: LongWord; var Accept: Boolean) of object;
TVTDragDropEvent = procedure(Sender: TBaseVirtualTree; Source: TObject; DataObject: IDataObject;
Formats: TFormatArray; Shift: TShiftState; const Pt: TPoint; var Effect: LongWord; 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; const ItemRect: TRect;
var ItemColor: TColor; var EraseAction: TItemEraseAction) of object;
TVTAfterItemEraseEvent = procedure(Sender: TBaseVirtualTree; TargetCanvas: TCanvas; Node: PVirtualNode;
const ItemRect: TRect) of object;
TVTBeforeItemPaintEvent = procedure(Sender: TBaseVirtualTree; TargetCanvas: TCanvas; Node: PVirtualNode;
const ItemRect: TRect; var CustomDraw: Boolean) of object;
TVTAfterItemPaintEvent = procedure(Sender: TBaseVirtualTree; TargetCanvas: TCanvas; Node: PVirtualNode;
const 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; const CellRect: TRect) of object;
TVTPaintEvent = procedure(Sender: TBaseVirtualTree; TargetCanvas: TCanvas) of object;
TVTBackgroundPaintEvent = procedure(Sender: TBaseVirtualTree; TargetCanvas: TCanvas; const 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: String;
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 = {$ifdef COMPILER_10_UP}record{$else}class{$endif}
private
FNode: PVirtualNode;
FCanModeNext: Boolean;
FEnumeration: PVTVirtualNodeEnumeration;
function GetCurrent: PVirtualNode; {$ifdef COMPILER_10_UP}inline;{$endif}
public
function MoveNext: Boolean; {$ifdef COMPILER_10_UP}inline;{$endif}
property Current: PVirtualNode read GetCurrent;
end;
TVTVirtualNodeEnumeration = {$ifdef COMPILER_10_UP}record{$else}object{$endif}
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
{$ifdef VCLStyleSupport}
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
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: String; // 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: LongWord; // 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: LongWord; // 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: String; // 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: TVirtualPanningWindow; // Helper window for wheel panning
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.
{$ifdef EnableAccessible}
// 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.
{$endif}
// 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;
{$ifdef VCLStyleSupport}
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; out VAlign,
VButtonAlign: Integer);
function ChangeCheckState(Node: PVirtualNode; Value: TCheckState): Boolean;
function CollectSelectedNodesLTR(MainColumn, NodeLeft, NodeRight: Integer; Alignment: TAlignment; OldRect: TRect;
const NewRect: TRect): Boolean;
function CollectSelectedNodesRTL(MainColumn, NodeLeft, NodeRight: Integer; Alignment: TAlignment; OldRect: TRect;
const 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;
//lcl
procedure LoadPanningCursors;
function MakeNewNode: PVirtualNode;
{$ifdef PACKARRAYPASCAL}
function PackArray(const TheArray: TNodeArray; Count: Integer): Integer;
{$else}
function PackArray(TheArray: TNodeArray; Count: Integer): Integer;
{$endif}
procedure PrepareBitmaps(NeedButtons, NeedLines: Boolean);
procedure SetAlignment(const Value: TAlignment);
procedure SetAnimationDuration(const Value: Cardinal);
procedure SetBackground(const Value: TPicture);
procedure SetBackgroundOffset(const Index, Value: Integer);
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: String);
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; const OffsetPosition: TPoint; const R: TRect);
procedure SetWindowTheme(const Theme: String);
procedure TileBackground(Source: TBitmap; Target: TCanvas; const Offset: TPoint; R: TRect);
function ToggleCallback(Step, StepSize: Integer; Data: Pointer): Boolean;
protected
procedure CMColorChange(var Message: TLMessage); message CM_COLORCHANGED;
procedure CMBiDiModeChanged(var Message: TLMessage); message CM_BIDIMODECHANGED;
procedure CMDenySubclassing(var Message: TLMessage); message CM_DENYSUBCLASSING;
//procedure CMDrag(var Message: TCMDrag); message CM_DRAG;
procedure CMFontChanged(var Message: TLMessage); message CM_FONTCHANGED;
procedure CMHintShow(var Message: TCMHintShow); message CM_HINTSHOW;
procedure CMMouseEnter(var Message: TLMessage); message CM_MOUSEENTER;
procedure CMMouseLeave(var Message: TLMessage); message CM_MOUSELEAVE;
procedure CMMouseWheel(var Message: TLMMouseEvent); message LM_MOUSEWHEEL;
{$ifdef EnableNativeTVM}
procedure TVMGetItem(var Message: TLMessage); message TVM_GETITEM;
procedure TVMGetItemRect(var Message: TLMessage); message TVM_GETITEMRECT;
procedure TVMGetNextItem(var Message: TLMessage); message TVM_GETNEXTITEM;
{$endif}
procedure WMCancelMode(var Message: TLMessage); message LM_CANCELMODE;
procedure WMChangeState(var Message: TLMessage); message WM_CHANGESTATE;
procedure WMChar(var Message: TLMChar); message LM_CHAR;
procedure WMContextMenu(var Message: TLMContextMenu); message LM_CONTEXTMENU;
procedure WMCopy(var Message: TLMNoParams); message LM_COPY;
procedure WMCut(var Message: TLMNoParams); message LM_CUT;
procedure WMEnable(var Message: TLMNoParams); message LM_ENABLE;
procedure WMEraseBkgnd(var Message: TLMEraseBkgnd); message LM_ERASEBKGND;
procedure WMGetDlgCode(var Message: TLMNoParams); message LM_GETDLGCODE;
{$ifdef EnableAccessible}
procedure WMGetObject(var Message: TLMessage);{ message WM_GETOBJECT;}
{$endif}
procedure WMHScroll(var Message: TLMHScroll); message LM_HSCROLL;
procedure WMKeyDown(var Message: TLMKeyDown); message LM_KEYDOWN;
procedure WMKeyUp(var Message: TLMKeyUp); message LM_KEYUP;
procedure WMKillFocus(var Msg: TLMKillFocus); message LM_KILLFOCUS;
procedure WMLButtonDblClk(var Message: TLMLButtonDblClk); message LM_LBUTTONDBLCLK;
procedure WMLButtonDown(var Message: TLMLButtonDown); message LM_LBUTTONDOWN;
procedure WMLButtonUp(var Message: TLMLButtonUp); message LM_LBUTTONUP;
procedure WMMButtonDblClk(var Message: TLMMButtonDblClk); message LM_MBUTTONDBLCLK;
procedure WMMButtonDown(var Message: TLMMButtonDown); message LM_MBUTTONDOWN;
procedure WMMButtonUp(var Message: TLMMButtonUp); message LM_MBUTTONUP;
{$ifdef EnableNCFunctions}
procedure WMNCCalcSize(var Message: TWMNCCalcSize); message WM_NCCALCSIZE;
procedure WMNCHitTest(var Message: TWMNCHitTest); message WM_NCHITTEST;
procedure WMNCPaint(var Message: TRealWMNCPaint); message WM_NCPAINT;
{$endif}
procedure WMPaint(var Message: TLMPaint); message LM_PAINT;
procedure WMPaste(var Message: TLMNoParams); message LM_PASTE;
{$ifdef EnablePrintFunctions}
procedure WMPrint(var Message: TWMPrint); message WM_PRINT;
procedure WMPrintClient(var Message: TWMPrintClient); message WM_PRINTCLIENT;
{$endif}
procedure WMRButtonDblClk(var Message: TLMRButtonDblClk); message LM_RBUTTONDBLCLK;
procedure WMRButtonDown(var Message: TLMRButtonDown); message LM_RBUTTONDOWN;
procedure WMRButtonUp(var Message: TLMRButtonUp); message LM_RBUTTONUP;
procedure WMSetFocus(var Msg: TLMSetFocus); message LM_SETFOCUS;
procedure WMSize(var Message: TLMSize); message LM_SIZE;
procedure WMTimer(var Message: TLMTimer); message LM_TIMER;
{$ifdef ThemeSupport}
{$ifdef Windows}
procedure WMThemeChanged(var Message: TLMessage); message WM_THEMECHANGED;
{$endif}
{$endif ThemeSupport}
procedure WMVScroll(var Message: TLMVScroll); message LM_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; overload;
procedure AdjustImageBorder(ImageWidth, ImageHeight: Integer; BidiMode: TBidiMode; VAlign: Integer; var R: TRect;
var ImageInfo: TVTImageInfo); overload;
procedure AdjustPaintCellRect(var PaintInfo: TVTPaintInfo; out 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 DestroyHandle; 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; const CellRect: TRect); virtual;
procedure DoAfterItemErase(Canvas: TCanvas; Node: PVirtualNode; const ItemRect: TRect); virtual;
procedure DoAfterItemPaint(Canvas: TCanvas; Node: PVirtualNode; const ItemRect: TRect); virtual;
procedure DoAfterPaint(Canvas: TCanvas); virtual;
procedure DoAutoScroll(X, Y: Integer); virtual;
procedure DoAutoSize; override;
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; const ItemRect: TRect; var Color: TColor;
var EraseAction: TItemEraseAction); virtual;
function DoBeforeItemPaint(Canvas: TCanvas; Node: PVirtualNode; const 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 DoDragMsg(ADragMessage: TDragMessage; APosition: TPoint;
ADragObject: TDragObject; ATarget: TControl; ADocking: Boolean): LRESULT; override;
function DoDragOver(Source: TObject; Shift: TShiftState; State: TDragState; const Pt: TPoint; Mode: TDropMode;
var Effect: LongWord): Boolean; virtual;
procedure DoDragDrop(Source: TObject; DataObject: IDataObject; Formats: TFormatArray; Shift: TShiftState; const Pt: TPoint;
var Effect: LongWord; 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 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: String); virtual;
procedure DoGetLineStyle(var Bits: Pointer); virtual;
function DoGetNodeHint(Node: PVirtualNode; Column: TColumnIndex; var LineBreakStyle: TVTTooltipLineBreakStyle): String; virtual;
function DoGetNodeTooltip(Node: PVirtualNode; Column: TColumnIndex; var LineBreakStyle: TVTTooltipLineBreakStyle): String; 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; const 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; const DropPosition: TPoint); virtual;
function DoHeaderDragging(Column: TColumnIndex): Boolean; virtual;
procedure DoHeaderDraw(Canvas: TCanvas; Column: TVirtualTreeColumn; const 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: String): 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; const R: TRect): Boolean; virtual;
procedure DoPaintDropMark(Canvas: TCanvas; Node: PVirtualNode; const R: TRect); virtual;
procedure DoPaintNode(var PaintInfo: TVTPaintInfo); virtual;
procedure DoPopupMenu(Node: PVirtualNode; Column: TColumnIndex; const 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: LongWord; DataObject: IDataObject;
var DragEffect: LongWord); virtual;
procedure DragCanceled; override;
function DragDrop(const DataObject: IDataObject; KeyState: LongWord; Pt: TPoint;
var Effect: LongWord): HResult; reintroduce; virtual;
function DragEnter(KeyState: LongWord; Pt: TPoint; var Effect: LongWord): HResult; virtual;
procedure DragFinished; virtual;
procedure DragLeave; virtual;
function DragOver(Source: TObject; KeyState: LongWord; DragState: TDragState; Pt: TPoint;
var Effect: LongWord): 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 GetClientRect: TRect; override;
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: TLMMouse; const HitInfo: THitInfo); virtual;
procedure HandleMouseDown(var Message: TLMMouse; var HitInfo: THitInfo); virtual;
procedure HandleMouseUp(Keys: PtrUInt; const HitInfo: THitInfo); virtual;
function HasImage(Node: PVirtualNode; Kind: TVTImageKind; Column: TColumnIndex): Boolean; virtual;
function HasPopupMenu(Node: PVirtualNode; Column: TColumnIndex; const 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;
function InternalGetNodeAt(X, Y: Integer): PVirtualNode; overload;
function InternalGetNodeAt(X, Y: Integer; Relative: Boolean; var NodeTop: Integer): PVirtualNode; overload;
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;
{$ifdef EnableNCFunctions}
procedure OriginalWMNCPaint(DC: HDC); virtual;
{$endif}
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 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(const Position: TPoint); virtual;
procedure StopWheelPanning; virtual;
procedure StructureChange(Node: PVirtualNode; Reason: TChangeReason); virtual;
function SuggestDropEffect(Source: TObject; Shift: TShiftState; const Pt: TPoint; AllowedEffects: LongWord): LongWord; 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: TLMessage); override;
procedure WriteChunks(Stream: TStream; Node: PVirtualNode); virtual;
procedure WriteNode(Stream: TStream; Node: PVirtualNode); virtual;
{$ifdef VCLStyleSupport}
procedure VclStyleChanged;
{$ifend}
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: LongWord 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 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;
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 DefaultHandler(var AMessage); override;
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;
{$ifndef fpc}
function GetControlsAlignment: TAlignment; override;
{$endif}
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; inline;
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;
out Text: String); 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; const Window: TRect; Target: TPoint; PaintOptions: TVTInternalPaintOptions;
PixelFormat: TPixelFormat = pfDevice); virtual;
function PasteFromClipboard: Boolean; virtual;
procedure PrepareDragImage(HotSpot: TPoint; const DataObject: IDataObject);
{$ifdef EnablePrint}
procedure Print(Printer: TPrinter; PrintHeader: Boolean);
{$endif}
function ProcessDrop(DataObject: IDataObject; TargetNode: PVirtualNode; var Effect: LongWord; 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): 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);
//lcl: reenable in case TControl implementation change to match Delphi
// 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;
{$ifdef EnableAccessible}
property Accessible: IAccessible read FAccessible write FAccessible;
property AccessibleItem: IAccessible read FAccessibleItem write FAccessibleItem;
property AccessibleName: string read FAccessibleName write FAccessibleName;
{$endif}
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 VTVDragManager: IVTDragManager read GetDragManager;
property DropTargetNode: PVirtualNode read FDropTargetNode write FDropTargetNode;
property EditLink: IVTEditLink read FEditLink;
property EmptyListMessage: String 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: String 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;
{ TVTEdit }
TVTEdit = class(TCustomEdit)
private
procedure CMAutoAdjust(var Message: TLMessage); message CM_AUTOADJUST;
procedure CMExit(var Message: TLMessage); message CM_EXIT;
procedure CNCommand(var Message: TLMCommand); message CN_COMMAND;
procedure DoRelease(Data: PtrInt);
procedure WMChar(var Message: TLMChar); message LM_CHAR;
procedure WMDestroy(var Message: TLMDestroy); message LM_DESTROY;
procedure WMGetDlgCode(var Message: TLMNoParams); message LM_GETDLGCODE;
procedure WMKeyDown(var Message: TLMKeyDown); message LM_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: TLMessage); 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: String) of object;
TVSTGetHintEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex;
var LineBreakStyle: TVTTooltipLineBreakStyle; var HintText: String) of object;
// New text can only be set for variable caption.
TVSTNewTextEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex;
const NewText: String) of object;
TVSTShortenStringEvent = procedure(Sender: TBaseVirtualTree; TargetCanvas: TCanvas; Node: PVirtualNode;
Column: TColumnIndex; const S: String; TextSpace: Integer; var Result: String;
var Done: Boolean) of object;
TVTMeasureTextEvent = procedure(Sender: TBaseVirtualTree; TargetCanvas: TCanvas; Node: PVirtualNode;
Column: TColumnIndex; const CellText: String; var Extent: Integer) of object;
TVTDrawTextEvent = procedure(Sender: TBaseVirtualTree; TargetCanvas: TCanvas; Node: PVirtualNode;
Column: TColumnIndex; const CellText: String; const CellRect: TRect; var DefaultDraw: Boolean) of object;
// Helper class to speed up rendering text formats for clipboard and drag'n drop transfers.
{ TBufferedUTF8String }
TBufferedUTF8String = class
private
FStart,
FPosition,
FEnd: PChar;
function GetAsAnsiString: AnsiString;
function GetAsUTF16String: UnicodeString;
function GetAsUTF8String: String;
function GetAsString: String;
public
destructor Destroy; override;
procedure Add(const S: String);
procedure AddNewLine;
property AsAnsiString: AnsiString read GetAsAnsiString;
property AsString: String read GetAsString;
property AsUTF8String: String read GetAsUTF8String;
property AsUTF16String: UnicodeString read GetAsUTF16String;
end;
{ TCustomVirtualStringTree }
TCustomVirtualStringTree = class(TBaseVirtualTree)
private
FDefaultText: String; // 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
procedure AddContentToBuffer(Buffer: TBufferedUTF8String; Source: TVSTTextSourceType; const Separator: String);
function GetImageText(Node: PVirtualNode; Kind: TVTImageKind;
Column: TColumnIndex): String;
procedure GetRenderStartValues(Source: TVSTTextSourceType; out Node: PVirtualNode;
out NextNodeProc: TGetNextNodeProc);
function GetOptions: TCustomStringTreeOptions;
function GetStaticText(Node: PVirtualNode; Column: TColumnIndex): String;
function GetText(Node: PVirtualNode; Column: TColumnIndex): String;
procedure SetDefaultText(const Value: String);
procedure SetOptions(const Value: TCustomStringTreeOptions);
procedure SetText(Node: PVirtualNode; Column: TColumnIndex; const Value: String);
procedure CMFontChanged(var Msg: TLMessage); message CM_FONTCHANGED;
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: String); virtual; // [IPK] - private to protected
procedure PaintStaticText(const PaintInfo: TVTPaintInfo; TextOutFlags: Integer; const Text: String); virtual; // [IPK] - private to protected
procedure AdjustPaintCellRect(var PaintInfo: TVTPaintInfo; out NextNonEmpty: TColumnIndex); override;
function CanExportNode(Node: PVirtualNode): Boolean;
function CalculateStaticTextWidth(Canvas: TCanvas; Node: PVirtualNode; Column: TColumnIndex; const Text: String): Integer; virtual;
function CalculateTextWidth(Canvas: TCanvas; Node: PVirtualNode; Column: TColumnIndex; const Text: String): Integer; virtual;
function ColumnIsEmpty(Node: PVirtualNode; Column: TColumnIndex): Boolean; override;
function DoCreateEditor(Node: PVirtualNode; Column: TColumnIndex): IVTEditLink; override;
function DoGetNodeHint(Node: PVirtualNode; Column: TColumnIndex; var LineBreakStyle: TVTTooltipLineBreakStyle): String; override;
function DoGetNodeTooltip(Node: PVirtualNode; Column: TColumnIndex; var LineBreakStyle: TVTTooltipLineBreakStyle): String; 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: String); virtual;
function DoIncrementalSearch(Node: PVirtualNode; const Text: String): Integer; override;
procedure DoNewText(Node: PVirtualNode; Column: TColumnIndex; const Text: String); 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: String; Width: Integer;
EllipsisWidth: Integer = 0): String; virtual;
procedure DoTextDrawing(var PaintInfo: TVTPaintInfo; const Text: String; CellRect: TRect; DrawFormat: Cardinal); virtual;
function DoTextMeasuring(Canvas: TCanvas; Node: PVirtualNode; Column: TColumnIndex; const Text: String): 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;
function RenderOLEData(const FormatEtcIn: TFormatEtc; out Medium: TStgMedium; ForClipboard: Boolean): HResult; override;
procedure WriteChunks(Stream: TStream; Node: PVirtualNode); override;
property DefaultText: String read FDefaultText write SetDefaultText;
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: String = ''): Integer; virtual;
function ContentToClipboard(Format: Word; Source: TVSTTextSourceType): HGLOBAL;
procedure ContentToCustom(Source: TVSTTextSourceType);
function ContentToHTML(Source: TVSTTextSourceType; const Caption: String = ''): String;
function ContentToRTF(Source: TVSTTextSourceType): AnsiString;
function ContentToAnsi(Source: TVSTTextSourceType; const Separator: String): AnsiString;
function ContentToText(Source: TVSTTextSourceType; const Separator: String): AnsiString; inline;
function ContentToUnicode(Source: TVSTTextSourceType; const Separator: String): UnicodeString; inline;
function ContentToUTF16(Source: TVSTTextSourceType; const Separator: String): UnicodeString;
function ContentToUTF8(Source: TVSTTextSourceType; const Separator: String): String;
{$ifndef LCLWin32}
procedure CopyToClipBoard; override;
procedure CutToClipBoard; override;
{$endif}
procedure GetTextInfo(Node: PVirtualNode; Column: TColumnIndex; const AFont: TFont; var R: TRect;
out Text: String); override;
function InvalidateNode(Node: PVirtualNode): TRect; override;
function Path(Node: PVirtualNode; Column: TColumnIndex; TextType: TVSTTextType; Delimiter: Char): String;
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]: String read GetImageText;
property StaticText[Node: PVirtualNode; Column: TColumnIndex]: String read GetStaticText;
property Text[Node: PVirtualNode; Column: TColumnIndex]: String 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
{$ifdef EnableAccessible}
property AccessibleName;
{$endif}
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 BorderSpacing;
property BorderStyle default bsSingle;
property BottomSpace;
property ButtonFillMode;
property ButtonStyle;
property BorderWidth;
property ChangeDelay;
property CheckImageKind;
property ClipboardFormats;
property Color;
property Colors;
property Constraints;
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 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 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;
property OnUTF8KeyPress;
//delphi only
//property OnCanResize;
//property OnGesture;
//property Touch;
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 BorderSpacing;
property BorderStyle default bsSingle;
property BottomSpace;
property ButtonFillMode;
property ButtonStyle;
property BorderWidth;
property ChangeDelay;
property CheckImageKind;
property ClipboardFormats;
property Color;
property Colors;
property Constraints;
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 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 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;
property OnUTF8KeyPress;
{$if CompilerVersion >= 24}
property StyleElements;
{$ifend}
end;
// 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
{$ifdef EnablePrint}
procedure PrtStretchDrawDIB(Canvas: TCanvas; DestRect: TRect; ABitmap: TBitmap);
{$endif}
function ShortenString(DC: HDC; const S: String; Width: Integer; EllipsisWidth: Integer = 0): String;
function TreeFromNode(Node: PVirtualNode): TBaseVirtualTree;
procedure GetStringDrawRect(DC: HDC; const S: String; var Bounds: TRect; DrawFormat: Cardinal);
function WrapString(DC: HDC; const S: String; const Bounds: TRect; RTL: Boolean;
DrawFormat: Cardinal): String;
procedure ShowError(const Msg: String; HelpContext: Integer); // [IPK] Surface this to interface
//----------------------------------------------------------------------------------------------------------------------
implementation
{$R VirtualTrees.res}
uses
StrUtils, Math,
{$ifdef EnableOLE}
//AxCtrls, // TOLEStream
{$endif}
{$ifdef Windows}
MMSystem, // for animation timer (does not include further resources)
{$else}
FakeMMSystem,
{$endif}
TypInfo, // for migration stuff
ActnList,
StdActns, // for standard action support
GraphType,
LCLProc
{$ifdef EnableAccessible}
,VTAccessibilityFactory
{$endif}; // accessibility helper class
resourcestring
// Localizable strings.
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
//Workaround to LCL bug 8553
{$ifndef LCLWin32}
pf32bit: TPixelFormat = pfDevice;
{$endif}
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;
);
type
TElementEdge = (
eeRaisedOuter
);
TElementEdges = set of TElementEdge;
TElementEdgeFlag = (
efRect
);
TElementEdgeFlags = set of TElementEdgeFlag;
//lcl: StyleServices is not implemented in LCL. If there's no plan to support it. Remove references here
// 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;
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 Char;
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;
const
MagicID: TMagicID = (#$45, 'V', 'T', Char(VTTreeStreamVersion), ' ', #$46);
// 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
{$ifndef COMPILER_11_UP}
const
TVP_HOTGLYPH = 4;
{$endif COMPILER_11_UP}
RTLFlag: array[Boolean] of Integer = (0, ETO_RTLREADING);
AlignmentToDrawFlag: array[TAlignment] of Cardinal = (DT_LEFT, DT_RIGHT, DT_CENTER);
WideCR = WideChar(#13);
WideLF = WideChar(#10);
CheckImagesStrings: array [TCheckImageKind] of String =
('VT_CHECK_LIGHT',
'VT_CHECK_DARK',
'VT_TICK_LIGHT',
'VT_TICK_DARK',
'VT_FLAT',
'VT_XP',
'',//ckCustom,
// Only the button images are used for ckSystem *
// The check buttons are draw at fly as requested
'VT_FLAT',//ckSystemFlat
'VT_CHECK_DARK' //ckSystemDefault
);
type
// 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;
var
WorkerThread: TWorkerThread;
WorkEvent: TEvent;
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
SystemCheckImages, // global system check images
SystemFlatCheckImages: TImageList; // global flat system check images
UtilityImages: TBitmap; // some small additional images (e.g for header dragging)
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: TFpList;
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; out Description: string): TVirtualTreeClass; overload;
end;
var
InternalClipboardFormats: TClipboardFormatList;
//----------------------------------------------------------------------------------------------------------------------
constructor TClipboardFormatList.Create;
begin
FList := TFpList.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; out 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
{
,(ID: CF_DIBV5; Description: 'DIB image V5') // Do not localize
}
);
//----------------------------------------------------------------------------------------------------------------------
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;
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
InternalClipboardFormats.Add(ClipboardFormatToMimeType(AFormat), 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 := ClipboardRegisterFormat(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 ----------------------------------------------------------------------------------
procedure ShowError(const Msg: String; 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;
//----------------------------------------------------------------------------------------------------------------------
//todo: Unify the procedure or change to widgetset specific
// Currently the UTF-8 version is broken.
// the unicode version is used when all winapi is available
{$ifndef INCOMPLETE_WINAPI}
function ShortenString(DC: HDC; const S: String; Width: Integer; EllipsisWidth: Integer = 0): String;
// 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;
WideStr: UnicodeString;
begin
WideStr := UTF8Decode(S);
Len := Length(WideStr);
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(WideStr), N, Size);
W := Size.cx + EllipsisWidth;
if W <= Width then
L := N
else
H := N - 1;
end;
Result := UTF8Encode(Copy(WideStr, 1, L) + '...');
end;
end;
end;
{$else}
function ShortenString(DC: HDC; const S: String; Width: Integer; EllipsisWidth: Integer = 0): String;
// 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
GetTextExtentPoint32(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;
GetTextExtentPoint32(DC, PAnsiChar(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;
{$endif}
//----------------------------------------------------------------------------------------------------------------------
function WrapString(DC: HDC; const S: String; const Bounds: TRect; RTL: Boolean;
DrawFormat: Cardinal): String;
// 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: String;
Words: array of String;
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 + LineEnding;
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 + LineEnding;
end;
end;
Len := Length(Result) - Length(LineEnding);
if CompareByte(Result[Len + 1], String(LineEnding)[1], Length(LineEnding)) = 0 then
SetLength(Result, Len);
end;
//----------------------------------------------------------------------------------------------------------------------
procedure GetStringDrawRect(DC: HDC; const S: String; 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;
DrawText(DC, PChar(S), Length(S), Bounds, DrawFormat or DT_CALCRECT);
end;
//----------------------------------------------------------------------------------------------------------------------
procedure FillDragRectangles(DragWidth, DragHeight, DeltaX, DeltaY: Integer; out 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;
//----------------------------------------------------------------------------------------------------------------------
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;
//----------------------------------------------------------------------------------------------------------------------
function CreateCheckImageList(CheckKind: TCheckImageKind): TImageList;
begin
Result := TImageList.Create(nil);
Result.Height := 16;
Result.Width := 16;
Result.AddResourceName(0, CheckImagesStrings[CheckKind], clFuchsia);
end;
function GetCheckImageList(var ImageList: TImageList; CheckKind: TCheckImageKind): TImageList;
begin
if ImageList = nil then
ImageList := CreateCheckImageList(CheckKind);
Result := ImageList;
end;
//----------------------------------------------------------------------------------------------------------------------
{$ifdef CPU64}
function HasMMX: Boolean;
begin
Result := True;
end;
{$else}
function HasMMX: Boolean;
// Helper method to determine whether the current processor supports MMX.
{$if not (defined(CPU386) or Defined(CPUX64))}
begin
result := false;
{$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
{$endif}
end;
{$endif}
//----------------------------------------------------------------------------------------------------------------------
{$ifdef EnablePrint}
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;
{$endif}
//----------------------------------------------------------------------------------------------------------------------
{$ifdef EnableAccessible}
procedure GetAccessibilityFactory;
// Accessibility helper function to create a singleton class that will create or return
// the IAccessible interface for the tree and the focused node.
begin
// Check to see if the class has already been created.
if VTAccessibleFactory = nil then
VTAccessibleFactory := TVTAccessibilityFactory.Create;
end;
{$endif}
//----------------------------------------------------------------------------------------------------------------------
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
TheInstance: THandle;
begin
Initialized := True;
// For the drag image a fast MMX blend routine is used. We have to make sure MMX is available.
MMXAvailable := HasMMX;
{$ifdef Windows}
IsWinVistaOrAbove := (Win32MajorVersion >= 6);
{$else}
IsWinVistaOrAbove := False;
{$endif}
TheInstance := HINSTANCE;
{$ifdef EnableOLE}
// Initialize OLE subsystem for drag'n drop and clipboard operations.
//todo: replace by Suceeded (see in windows unit)
NeedToUnitialize := not IsLibrary and (OleInitialize(nil) in [S_FALSE,S_OK]);
{$endif}
// Register the tree reference clipboard format. Others will be handled in InternalClipboarFormats.
CF_VTREFERENCE := ClipboardRegisterFormat(CFSTR_VTREFERENCE);
UtilityImages := TBitmap.Create;
UtilityImages.Transparent := True;
UtilityImages.LoadFromResourceName(0, 'VT_UTILITIES');
SystemCheckImages := CreateCheckImageList(ckSystemDefault);
// 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(TheInstance, 'VT_HEADERSPLIT');
Screen.Cursors[crVertSplit] := LoadCursor(TheInstance, '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;
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;
SystemCheckImages.Free;
SystemCheckImages := nil;
SystemFlatCheckImages.Free;
SystemFlatCheckImages := nil;
FreeAndNil(UtilityImages);
if NeedToUnitialize then
OleUninitialize;
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 := TEvent.Create(nil, False, False, '');
//todo: see how to check if a event was succesfully created under linux since handle is allways 0
{$ifdef Windows}
if WorkEvent.Handle = TEventHandle(0) then
Raise Exception.Create('VirtualTreeView - Error creating TEvent instance');
{$endif}
// 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;
WorkEvent.SetEvent;
WorkerThread.Free;
end;
WorkerThread := nil;
WorkEvent.Free;
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
//todo: see if is correct / will work
Application.ProcessMessages;
continue;
//TranslateMessage(Msg);
//DispatchMessage(Msg);
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
while not Terminated do
begin
WorkEvent.WaitFor(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
WorkEvent.SetEvent;
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
Synchronize(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;
//----------------- TBufferedUTF8String --------------------------------------------------------------------------------
const
AllocIncrement = 2 shl 11; // Must be a power of 2.
destructor TBufferedUTF8String.Destroy;
begin
FreeMem(FStart);
inherited;
end;
//----------------------------------------------------------------------------------------------------------------------
function TBufferedUTF8String.GetAsAnsiString: AnsiString;
begin
//an implicit conversion is done
Result := AsUTF16String;
end;
//----------------------------------------------------------------------------------------------------------------------
function TBufferedUTF8String.GetAsUTF16String: UnicodeString;
begin
//todo: optimize
Result := UTF8Decode(AsUTF8String);
end;
//----------------------------------------------------------------------------------------------------------------------
function TBufferedUTF8String.GetAsUTF8String: String;
begin
SetString(Result, FStart, FPosition - FStart);
end;
function TBufferedUTF8String.GetAsString: String;
begin
SetString(Result, FStart, FPosition - FStart);
end;
//----------------------------------------------------------------------------------------------------------------------
procedure TBufferedUTF8String.Add(const S: String);
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, NewLen);
FPosition := FStart + LastOffset;
FEnd := FStart + NewLen;
end;
Move(PChar(S)^, FPosition^, Len);
Inc(FPosition, Len);
end;
//----------------------------------------------------------------------------------------------------------------------
procedure TBufferedUTF8String.AddNewLine;
var
NewLen,
LastOffset: Integer;
begin
// Make room for the CR/LF characters.
if FEnd - FPosition <= 4 then
begin
//todo: see in calculation of NewLen is correct for String
// 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;
//----------------- 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;
{$ifndef Windows}
Exclude(FMiscOptions,toAcceptOLEDrop);
Exclude(ToBeCleared,toAcceptOLEDrop);
Exclude(ToBeSet,toAcceptOLEDrop);
{$endif}
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
//todo_lcl_check
RecreateWnd(FOwner);
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 TCustomVirtualTreeOptions(Dest) do
begin
PaintOptions := Self.PaintOptions;
AnimationOptions := Self.AnimationOptions;
AutoOptions := Self.AutoOptions;
SelectionOptions := Self.SelectionOptions;
MiscOptions := Self.MiscOptions;
end;
end
else
inherited;
end;
{$i vtvdragmanager.inc}
//----------------- TVirtualTreeHintWindow -----------------------------------------------------------------------------
procedure TVirtualTreeHintWindow.WMShowWindow(var Message: TLMShowWindow);
// 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);
FillChar(FHintData, SizeOf(FHintData), 0);
end;
end;
//----------------------------------------------------------------------------------------------------------------------
procedure TVirtualTreeHintWindow.Paint;
begin
with FHintData do
begin
if Tree is TCustomVirtualDrawTree and Assigned(Node) then
begin
// The draw tree has by default no hint text so let it draw the hint itself.
// HintBorderWidth is a private constant in hint code and is set to two
TCustomVirtualDrawTree(Tree).DoDrawHint(Canvas, Node,
Rect(0, 0, Width - 2, Height - 2), Column);
end
else
inherited;
end;
end;
//----------------------------------------------------------------------------------------------------------------------
function TVirtualTreeHintWindow.CalcHintRect(MaxWidth: Integer; const AHint: string; AData: Pointer): TRect;
var
P: TPoint;
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
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).
// This size has already been determined in CMHintShow.
if (Tree is TCustomVirtualDrawTree) and Assigned(Node) then
Result := HintRect
else
begin
//todo remove this define as soon as 0.9.30 is released to avoid future problems
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;
//select font according to the type of hint
if (Node = nil) or (Tree.FHintMode <> hmToolTip) then
Canvas.Font := Screen.HintFont
else
begin
Canvas.Font := Tree.Font;
//necessary to set customized fonts
if Tree is TCustomVirtualStringTree then
with TCustomVirtualStringTree(Tree) do
DoPaintText(Node, Self.Canvas, Column, ttNormal);
//force the default hint font color
Canvas.Font.Color := Screen.HintFont.Color;
end;
//let THintWindow do the job
Result := inherited CalcHintRect(MaxWidth, AHint, AData);
//fix position taking into account bidimode and control bounds
if (Tree.HintMode <> hmTooltip) or ((Result.Right - Result.Left) < Tree.Width) then
begin
if BiDiMode = bdLeftToRight then
begin
P := Tree.ClientToScreen(Point(0, 0));
HintInfo^.HintPos.X := Max(P.X, HintInfo^.HintPos.X);
end
else
begin
if (Tree.HintMode = hmTooltip) and (Node <> nil) then
begin
P := Tree.ClientToScreen(Point(Min(Tree.ClientWidth, HintInfo^.CursorRect.Right), 0));
Dec(P.X, Result.Right);
HintInfo^.HintPos.X := Max(P.X, HintInfo^.HintPos.X);
end
else
Dec(HintInfo^.HintPos.X, Result.Right - 20);
end;
end;
end;
end;
end;
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;
SourceBits, TargetBits: Pointer;
begin
{$ifdef EnableAdvancedGraphics}
SourceBits := GetBitmapBitsFromBitmap(Source.Handle);
TargetBits := GetBitmapBitsFromBitmap(Target.Handle);
if (SourceBits = nil) or (TargetBits = nil) then
Exit;
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 := CalculateScanline(TargetBits, Width, Height, Y);
SourceRun := CalculateScanline(SourceBits, Source.Width, Source.Height, 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;
{$endif}
end;
//----------------------------------------------------------------------------------------------------------------------
function TVTDragImage.DragTo(const 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;
//todo: implement ScrollDC. Alternatively reimplement drag operations
{$ifndef INCOMPLETE_WINAPI}
// move existent background
ScrollDC(Handle, DeltaX, DeltaY, RScroll, RClip, 0, nil);
{$endif}
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; const 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;
//lcl
//todo: replace CopyImage. Alternatively reimplement Drag support
{$ifndef INCOMPLETE_WINAPI}
DragInfo.hbmpDragImage := CopyImage(DragImage.Handle, IMAGE_BITMAP, Width, Height, LR_COPYRETURNORG);
{$else}
DragInfo.hbmpDragImage := 0;
{$endif}
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.
{$ifndef INCOMPLETE_WINAPI}
var
DragRect,
ClipRect: TRect;
PaintTarget: TPoint;
PaintOptions: TVTInternalPaintOptions;
ScreenDC: HDC;
{$endif}
begin
//todo: reimplement
{$ifndef INCOMPLETE_WINAPI}
// 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);
{$ifdef UseSetCanvasOrigin}
SetCanvasOrigin(Canvas, DragRect.Left - ClipRect.Left, DragRect.Top - ClipRect.Top);
{$else}
SetWindowOrgEx(Canvas.Handle, DragRect.Left - ClipRect.Left, DragRect.Top - ClipRect.Top, nil);
{$endif}
//todo: see what todo here
//Tree.Perform(WM_PRINT, WPARAM(Canvas.Handle), PRF_NONCLIENT);
{$ifdef UseSetCanvasOrigin}
SetCanvasOrigin(Canvas, 0, 0);
{$else}
SetWindowOrgEx(Canvas.Handle, 0, 0, nil);
{$endif}
end;
SelectClipRgn(Canvas.Handle, 0);
if ReshowDragImage then
begin
GDIFlush;
ScreenDC := GetDC(0);
try
InternalShowDragImage(ScreenDC);
finally
ReleaseDC(0, ScreenDC);
end;
end;
end;
end;
{$endif}
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.
{$ifndef INCOMPLETE_WINAPI}
var
ScreenDC: HDC;
{$endif}
begin
{$ifndef INCOMPLETE_WINAPI}
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;
{$endif}
end;
//----------------------------------------------------------------------------------------------------------------------
function TVTDragImage.WillMove(const 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
{$ifdef COMPILER_10_UP}
{$else}
Result := TVTVirtualNodeEnumerator.Create;
{$endif COMPILER_10_UP}
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;
//lcl: setting FPosition here will override the Design time value
//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;
AVisibleChanged,
ColorChanged: Boolean;
begin
if FOptions <> Value then
begin
ToBeCleared := FOptions - Value;
ToBeSet := Value - FOptions;
FOptions := Value;
AVisibleChanged := 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.
//lcl: fpc refuses to compile the original code by no aparent reason.
//Found: Was confounding TControl.VisibleChanged
with Owner, Header.Treeview do
if not (csLoading in ComponentState) and (AVisibleChanged or ColorChanged) and (UpdateCount = 0) and
HandleAllocated then
begin
Invalidate;
if AVisibleChanged 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: TTranslateString);
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; const 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;
//todo
//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.Height;
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;
GetTextExtentPoint32(DC, PChar(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.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 otherwise the column id is returned
begin
if Length(FText) > 0 then
Result := FText
else
Result := Format('Column %d', [Index]);
end;
//----------------------------------------------------------------------------------------------------------------------
function TVirtualTreeColumn.GetOwner: TVirtualTreeColumns;
begin
Result := Collection as TVirtualTreeColumns;
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: String;
begin
Result := FText;
end;
//----------------------------------------------------------------------------------------------------------------------
procedure TVirtualTreeColumn.LoadFromStream(const Stream: TStream; Version: Integer);
var
Dummy: Integer;
S: String;
begin
with Stream do
begin
ReadBuffer(Dummy, SizeOf(Dummy));
SetLength(S, Dummy);
ReadBuffer(PChar(S)^, Dummy);
Text := S;
ReadBuffer(Dummy, SizeOf(Dummy));
SetLength(FHint, Dummy);
ReadBuffer(PChar(FHint)^, 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 := TVTColumnOptions(Word(Dummy and $FFFF));
// Parts which have been introduced/changed with header stream version 1+.
// LCL port started with header stream version 6 so no need to do the check here
ReadBuffer(Dummy, SizeOf(Dummy));
Tag := Dummy;
ReadBuffer(Dummy, SizeOf(Dummy));
Alignment := TAlignment(Dummy);
ReadBuffer(Dummy, SizeOf(Dummy));
Color := TColor(Dummy);
if coUseCaptionAlignment in FOptions then
begin
ReadBuffer(Dummy, SizeOf(Dummy));
CaptionAlignment := TAlignment(Dummy);
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;
TreeViewColor: TColor;
begin
if coParentColor in FOptions then
begin
Columns := GetOwner as TVirtualTreeColumns;
if Assigned(Columns) then
begin
TreeViewColor := Columns.FHeader.Treeview.Brush.Color;
if FColor <> TreeViewColor then
begin
FColor := TreeViewColor;
Changed(False);
end;
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(PChar(FText)^, Dummy);
Dummy := Length(FHint);
WriteBuffer(Dummy, SizeOf(Dummy));
WriteBuffer(PChar(FHint)^, 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.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(const 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: String; Bounds: TRect; Enabled, Hot: Boolean;
DrawFormat: Cardinal; WrapCaption: Boolean);
var
TextSpace: Integer;
TextColor: TColor;
Size: TSize;
begin
if not WrapCaption then
begin
// Do we need to shorten the caption due to limited space?
GetTextExtentPoint32(DC, PChar(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
TextColor := FHeader.Treeview.FColors.HeaderFontColor;
if TextColor = clDefault then
TextColor := clBtnText;
SetTextColor(DC, ColorToRGB(TextColor));
DrawText(DC, PChar(Caption), Length(Caption), Bounds, DrawFormat);
end
else
begin
OffsetRect(Bounds, 1, 1);
SetTextColor(DC, ColorToRGB(clBtnHighlight));
DrawText(DC, PChar(Caption), Length(Caption), Bounds, DrawFormat);
OffsetRect(Bounds, -1, -1);
SetTextColor(DC, ColorToRGB(clBtnShadow));
DrawText(DC, PChar(Caption), Length(Caption), Bounds, DrawFormat);
end
else
begin
if Hot then
TextColor := FHeader.Treeview.FColors.HeaderHotColor
else
TextColor := FHeader.Treeview.FColors.HeaderFontColor;
if TextColor = clDefault then
TextColor := clBtnText;
SetTextColor(DC, ColorToRGB(TextColor));
DrawText(DC, PChar(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(const 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.
//lclheader
//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
//lcl
// Skip while Destroying
if csDestroying in FHeader.TreeView.ComponentState then
Exit;
// 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.
{$ifndef INCOMPLETE_WINAPI}
var
OldWidth: Integer;
DC: HDC;
I,
Steps,
DX: Integer;
HeaderScrollRect,
ScrollRect,
R: TRect;
NewBrush,
LastBrush: HBRUSH;
{$endif}
begin
//todo: reimplement
{$ifndef INCOMPLETE_WINAPI}
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(Brush.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;
{$endif}
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(const 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; out 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
// LCL port started with header stream version 6 so no need to do the check here
Stream.ReadBuffer(FDefaultWidth, SizeOf(FDefaultWidth));
end;
//----------------------------------------------------------------------------------------------------------------------
procedure TVirtualTreeColumns.PaintHeader(DC: HDC; const 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
//lclheader
//Under Delphi/VCL, unlike LCL, the hover index is not changed while dragging.
//Here we check if dragging and not draw as hover
IsHoverIndex := (AColumn = FHoverIndex) and (hoHotTrack in FHeader.FOptions) and
(coEnabled in FOptions) and not (hsDragging in FHeader.States);
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];
{$ifdef USE_DELPHICOMPAT}
DirectMaskBlt(FHeaderBitmap.Canvas.Handle, SortGlyphPos.X, SortGlyphPos.Y, UtilityImageSize, UtilityImageSize, UtilityImages.Canvas.Handle,
SortIndex * UtilityImageSize, 0, UtilityImages.MaskHandle);
{$else}
StretchMaskBlt(FHeaderBitmap.Canvas.Handle, SortGlyphPos.X, SortGlyphPos.Y, UtilityImageSize, UtilityImageSize, UtilityImages.Canvas.Handle,
SortIndex * UtilityImageSize, 0, UtilityImageSize, UtilityImageSize, UtilityImages.MaskHandle,SortIndex * UtilityImageSize, 0, SRCCOPY);
{$endif}
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
{$ifdef USE_DELPHICOMPAT}
DirectMaskBlt(FHeaderBitmap.Canvas.Handle, PaintRectangle.Left, Y, UtilityImageSize, UtilityImageSize, UtilityImages.Canvas.Handle,
0, 0, UtilityImages.MaskHandle)
{$else}
StretchMaskBlt(FHeaderBitmap.Canvas.Handle, PaintRectangle.Left, Y, UtilityImageSize, UtilityImageSize, UtilityImages.Canvas.Handle,
0, 0, UtilityImageSize, UtilityImageSize, UtilityImages.MaskHandle, 0, 0, SRCCOPY)
{$endif}
else
{$ifdef USE_DELPHICOMPAT}
DirectMaskBlt(FHeaderBitmap.Canvas.Handle, PaintRectangle.Right - 16, Y, UtilityImageSize, UtilityImageSize, UtilityImages.Canvas.Handle,
UtilityImageSize, 0, UtilityImages.MaskHandle);
{$else}
StretchMaskBlt(FHeaderBitmap.Canvas.Handle, PaintRectangle.Right - 16, Y, UtilityImageSize, UtilityImageSize, UtilityImages.Canvas.Handle,
UtilityImageSize, 0, UtilityImageSize, UtilityImageSize, UtilityImages.MaskHandle, UtilityImageSize, 0, SRCCOPY);
{$endif}
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;
FillChar(PaintInfo, SizeOf(PaintInfo), #0);
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);
// 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 := 19;
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 Treeview.HandleAllocated then
begin
Treeview.MainColumnChanged;
if not (toExtendedFocus in Treeview.FOptions.FSelectionOptions) then
Treeview.FocusedColumn := Value;
Treeview.Invalidate;
end
else
begin
if not (toExtendedFocus in Treeview.FOptions.FSelectionOptions) then
Treeview.FFocusedColumn := Value;
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(const 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(const 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_LWIN) < 0 then // Mac OS X substitute of ssCtrl
Include(Result, ssMeta);
if GetKeyState(VK_CONTROL) < 0 then
Include(Result, ssCtrl);
if GetKeyState(VK_MENU) < 0 then
Include(Result, ssAlt);
end;
//----------------------------------------------------------------------------------------------------------------------
function TVTHeader.HandleHeaderMouseMove(var Message: TLMMouseMove): 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
FStates := FStates - [hsColumnWidthTrackPending] + [hsColumnWidthTracking];
HandleHeaderMouseMove := True;
Result := 0;
end
else
if hsHeightTrackPending in FStates then
begin
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
//lclheader
//fixes setting height
Dec(P.Y, FHeight);
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) > DragManager.DragThreshold) or
(Abs(FDragStart.Y - P.Y) > DragManager.DragThreshold)) then
begin
{$ifdef DEBUG_VTV}Logger.Send([lcDrag], 'HandleHeaderMouseMove - DragIndex: %d - DownIndex: %d',
[FColumns.FDragIndex, FColumns.FDownIndex]);{$endif}
I := FColumns.FDownIndex;
FColumns.FDownIndex := NoColumn;
FColumns.FHoverIndex := NoColumn;
if I > NoColumn then
Invalidate(FColumns[I]);
//todo: implement drag image under gtk
PrepareDrag(P, FDragStart);
FStates := FStates - [hsDragPending] + [hsDragging];
HandleHeaderMouseMove := True;
Result := 0;
end;
end;
end
else
if hsDragging in FStates then
begin
DragTo(Treeview.ClientToScreen(P));
HandleHeaderMouseMove := True;
Result := 0;
end;
end;
end;
end;
//----------------------------------------------------------------------------------------------------------------------
function TVTHeader.HandleMessage(var Message: TLMessage): 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
LM_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;
LM_MBUTTONDOWN:
begin
//lclheader: NCMessages are given in screen coordinates unlike the ordinary
with TLMMButtonDown(Message) do
P:= Point(XPos, YPos);
//P := Treeview.ScreenToClient(Point(XPos, YPos));
//lclheader
if InHeader(P) then
FOwner.DoHeaderMouseDown(mbMiddle, GetShiftState, P.X, P.Y { + Integer(FHeight)});
end;
LM_MBUTTONUP:
begin
with TLMMButtonUp(Message) do
P:= Point(XPos, YPos);
//P := FOwner.ScreenToClient(Point(XPos, YPos));
if InHeader(P) then
begin
FColumns.HandleClick(P, mbMiddle, True, False);
//lclheader
FOwner.DoHeaderMouseUp(mbMiddle, GetShiftState, P.X, P.Y { + Integer(FHeight)});
FColumns.FDownIndex := NoColumn;
FColumns.FCheckBoxHit := False;
end;
end;
LM_LBUTTONDBLCLK,
LM_MBUTTONDBLCLK,
LM_RBUTTONDBLCLK:
begin
with TLMLButtonDblClk(Message) do
P := Point(XPos, YPos);
IsInHeader := InHeader(P);
Result := IsInHeader;
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 = LM_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 IsInHeader and (Message.Msg <> LM_LBUTTONDBLCLK) then
begin
case Message.Msg of
LM_MBUTTONDBLCLK:
Button := mbMiddle;
LM_RBUTTONDBLCLK:
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.
LM_LBUTTONDOWN:
begin
Application.CancelHint;
if not (csDesigning in Treeview.ComponentState) then
begin
// make sure no auto scrolling is active...
KillTimer(Treeview.Handle, ScrollTimer);
Treeview.DoStateChange([], [tsScrollPending, tsScrolling]);
// ... pending editing is cancelled (actual editing remains active)
KillTimer(Treeview.Handle, EditTimer);
Treeview.DoStateChange([], [tsEditPending]);
end;
with TLMLButtonDown(Message) do
begin
// want the drag start point in screen coordinates
P := Point(XPos, YPos);
FDragStart := Treeview.ClientToScreen(P);
//FDragStart := Point(XPos, YPos);
//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);
Message.Result := 0;
end;
Result := True;
end;
// This is a good opportunity to notify the application.
//lclheader
if not (csDesigning in Treeview.ComponentState) and IsInHeader then
FOwner.DoHeaderMouseDown(mbLeft, GetShiftState, P.X, P.Y { + Integer(FHeight)});
end;
LM_RBUTTONDOWN:
begin
with TLMRButtonDown(Message) do
P:=Point(XPos,YPos);
//P := FOwner.ScreenToClient(Point(XPos, YPos));
//lclheader
if InHeader(P) then
FOwner.DoHeaderMouseDown(mbRight, GetShiftState, P.X, P.Y { + Integer(FHeight)});
end;
LM_RBUTTONUP:
if not (csDesigning in FOwner.ComponentState) then
with TLMRButtonUp(Message) do
begin
Application.CancelHint;
P := Point(XPos,YPos);
//P := FOwner.ScreenToClient(Point(XPos, YPos));
if InHeader(P) then
begin
FColumns.HandleClick(P, mbRight, True, False);
//lclheader
FOwner.DoHeaderMouseUp(mbRight, GetShiftState, P.X, P.Y { + Integer(FHeight)});
FColumns.FDownIndex := NoColumn;
FColumns.FTrackIndex := NoColumn;
FColumns.FCheckBoxHit := False;
Menu := FPopupMenu;
//lclheader
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
KillTimer(Treeview.Handle, ScrollTimer);
FColumns.FHoverIndex := NoColumn;
Treeview.DoStateChange([], [tsScrollPending, tsScrolling]);
Menu.PopupComponent := Treeview;
P := Treeview.ClientToScreen(Point(XPos, YPos));
Menu.Popup(P.X, P.Y);
HandleMessage := True;
Message.Result := 1;
end;
end;
end;
// When the tree window has an active mouse capture then we only get "client-area" messages.
LM_LBUTTONUP:
begin
Application.CancelHint;
if FStates <> [] then
begin
ReleaseCapture;
//lcl
if hsColumnWidthTracking in FStates then
begin
if not InHeader(SmallPointToPoint(TLMLButtonUp(Message).Pos)) then
TreeView.Cursor := crDefault;
end;
if hsDragging in FStates then
begin
// successfull dragging moves columns
with TLMLButtonUp(Message) do
P := Treeview.ClientToScreen(Point(XPos, YPos));
GetWindowRect(Treeview.Handle, R);
{$ifdef DEBUG_VTV}Logger.Send([lcDrag],'Header - EndDrag / R',R);{$endif}
with FColumns do
begin
{$ifdef DEBUG_VTV}Logger.Send([lcDrag],'Header - EndDrag / FDropTarget: %d FDragIndex: %d FDragIndexPosition: %d',
[FDropTarget, FDragIndex, FColumns[FDragIndex].Position]);{$endif}
{$ifdef DEBUG_VTV}Logger.Send([lcDrag],'Header - EndDrag / FDropBefore', FColumns.FDropBefore);{$endif}
FDragImage.EndDrag;
if (FDropTarget > -1) and (FDropTarget <> FDragIndex) and PtInRect(R, P) then
begin
{$ifdef DEBUG_VTV}Logger.Send([lcDrag],'Header - EndDrag / FDropTargetPosition', FColumns[FDropTarget].Position);{$endif}
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
LM_LBUTTONUP:
with TLMLButtonUp(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;
//todo: there's a difference here
{
LM_NCLBUTTONUP:
with TLMLButtonUp(Message) do
begin
P := FOwner.ScreenToClient(Point(XPos, YPos));
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
CM_MOUSELEAVE:
with FColumns do
begin
if FHoverIndex > NoColumn then
Invalidate(Items[FHoverIndex]);
FHoverIndex := NoColumn;
FClickIndex := NoColumn;
FDownIndex := NoColumn;
end;
//todo: see the difference to below
LM_MOUSEMOVE:
with TLMMouseMove(Message), FColumns do
begin
//lcl
HandleMessage := HandleHeaderMouseMove(TLMMouseMove(Message));
P := Point(XPos,YPos);
//P := Treeview.ScreenToClient(Point(XPos, YPos));
IsInHeader := InHeader(P);
if IsInHeader then
begin
Treeview.DoHeaderMouseMove(GetShiftState, P.X, P.Y);
if ((AdjustHoverColumn(P)) or ((FDownIndex > NoColumn) and (FHoverIndex <> FDownIndex))) then
begin
Invalidate(nil);
// todo: under lcl, the hint is show even if HintMouseMessage is not implemented
// Is it necessary here?
// use Delphi's internal hint handling for header hints too
if hoShowHint in FOptions then
begin
// client coordinates!
XPos := P.X;
YPos := P.Y;
Application.HintMouseMessage(Treeview, Message);
end;
end;
end
else
begin
if FHoverIndex > NoColumn then
Invalidate(Items[FHoverIndex]);
FHoverIndex := NoColumn;
FClickIndex := NoColumn;
FDownIndex := NoColumn;
FCheckBoxHit := False;
end;
//Adjust Cursor
// Feature: design-time header
if (FStates = []) then
begin
//todo: see a way to store the user defined cursor.
IsHSplitterHit := HSplitterHit;
// in design-time header columns are always resizable
if (csDesigning in Treeview.ComponentState) then
IsVSplitterHit := InHeaderSplitterArea(P)
else
IsVSplitterHit := InHeaderSplitterArea(P) and FHeader.CanSplitterResize(P);
if IsVSplitterHit or IsHSplitterHit then
begin
NewCursor := crDefault;
if IsVSplitterHit and (hoHeightResize in FOptions) then
NewCursor := crVertSplit
else if IsHSplitterHit then
NewCursor := crHeaderSplit;
Treeview.DoGetHeaderCursor(NewCursor);
if NewCursor <> crDefault then
begin
Treeview.Cursor := NewCursor;
HandleMessage := True;
Message.Result := 1;
end;
end;
end
else
begin
Message.Result := 1;
HandleMessage := True;
end;
end;
LM_KEYDOWN,
LM_KILLFOCUS:
if (Message.Msg = LM_KILLFOCUS) or
(TLMKeyDown(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);
//lclheader
//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));
//lclheader
// Column rectangles are given in local window coordinates not client coordinates.
// The above statement is not valid under LCL
//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.RecalculateHeader;
// Initiate a recalculation of the non-client area of the owner tree.
begin
if Treeview.HandleAllocated then
begin
Treeview.UpdateHeaderRect;
//lclheader
//not necessary since header is draw inside client area
//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;
//----------------------------------------------------------------------------------------------------------------------
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(const P: TPoint): Boolean;
// Determines whether the given point (client coordinates!) is within the header rectangle (non-client coordinates).
begin
//lclheader
//todo: remove this function and use PtInRect directly ??
Result := PtInRect(TreeView.FHeaderRect, 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: TRect;
begin
Result := (hoVisible in FOptions);
if Result then
begin
R := Treeview.FHeaderRect;
R.Top := R.Bottom - 2;
Inc(R.Bottom, 2);
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: 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;
//lclheader
RedrawWindow(Handle, @R, 0, RDW_FRAME or RDW_INVALIDATE or RDW_VALIDATE or RDW_NOINTERNALPAINT or
RDW_NOERASE or RDW_NOCHILDREN);
{
// 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);
Name := S;
ReadBuffer(Dummy, SizeOf(Dummy));
Pitch := TFontPitch(Dummy);
ReadBuffer(Dummy, SizeOf(Dummy));
Style := TFontStyles(LongWord(Dummy));
end;
// LCL port started with header stream version 6 so no need to do the check here
// Read data introduced by stream version 1+.
ReadBuffer(Dummy, SizeOf(Dummy));
MainColumn := Dummy;
ReadBuffer(Dummy, SizeOf(Dummy));
SortColumn := Dummy;
ReadBuffer(Dummy, SizeOf(Dummy));
SortDirection := TSortDirection(Byte(Dummy));
// Read data introduced by stream version 5+.
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;
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 := Name;
Dummy := Length(Tmp);
WriteBuffer(Dummy, SizeOf(Dummy));
WriteBuffer(PAnsiChar(Tmp)^, Dummy);
Dummy := Ord(Pitch);
WriteBuffer(Dummy, SizeOf(Dummy));
Dummy := Integer(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;
//todo_lcl_check
if not (csLoading in FOwner.ComponentState) and FOwner.HandleAllocated then
RecreateWnd(FOwner);
end;
end;
//----------------------------------------------------------------------------------------------------------------------
procedure TScrollBarOptions.SetScrollBars(Value: TScrollStyle);
begin
if FScrollBars <> Value then
begin
FScrollBars := Value;
//todo_lcl_check
if not (csLoading in FOwner.ComponentState) and FOwner.HandleAllocated then
RecreateWnd(FOwner);
end;
end;
//----------------------------------------------------------------------------------------------------------------------
procedure TScrollBarOptions.SetScrollBarStyle(Value: TVTScrollBarStyle);
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.Brush.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;
FSelectionBlendFactor := 128;
FIndent := 18;
FPlusBM := TBitmap.Create;
FHotPlusBM := TBitmap.Create;
FMinusBM := TBitmap.Create;
FHotMinusBM := TBitmap.Create;
BorderStyle := 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);
{$ifdef EnableThreadSupport}
AddThreadReference;
{$endif}
//FVclStyleEnabled := False;
// XE2+ VCL Style
{$ifdef VCLStyleSupport}
FSetOrRestoreBevelKindAndBevelWidth := False;
FSavedBevelKind := bkNone;
FSavedBorderWidth := 0;
{$ifend}
end;
//----------------------------------------------------------------------------------------------------------------------
destructor TBaseVirtualTree.Destroy;
begin
InterruptValidation();
Exclude(FOptions.FMiscOptions, toReadOnly);
{$ifdef EnableThreadSupport}
ReleaseThreadReference(Self);
{$endif}
StopWheelPanning;
//lcl
FPanningWindow.Free;
// 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.
//todo_lcl_check
{
if HandleAllocated then
DestroyWindowHandle;
}
// Release FDottedBrush in case WM_NCDESTROY hasn't been triggered.
if FDottedBrush <> 0 then
DeleteObject(FDottedBrush);
FDottedBrush := 0;
FOptions.Free;
FreeAndNil(FHeader);
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;
out 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: TRect; const 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 := ssCtrlOS 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 := InternalGetNodeAt(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: TRect; const 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 := ssCtrlOS 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 := InternalGetNodeAt(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
{$ifdef DEBUG_VTV}Logger.EnterMethod([lcPaintDetails],'ClearNodeBackground');{$endif}
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
//clear the node background
//note there's a bug in original VTV that can lead to wrong node paint
//so, here the node is always cleared even if is selected
Brush.Color := BackColor;
FillRect(R);
{$ifdef DEBUG_VTV}Logger.SendColor([lcPaintDetails],'Clearing a node background - Brush.Color', Brush.Color);{$endif}
{$ifdef DEBUG_VTV}Logger.Send([lcPaintDetails],'Clearing Rectangle (R)', R);{$endif}
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
{$ifdef DEBUG_VTV}Logger.Send([lcPaintDetails, lcDrag], 'Draw the background of a selected node');{$endif}
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
//lcl
//see note above
{
Brush.Color := BackColor;
FillRect(R);
}
end;
end;
end;
DoAfterItemErase(Canvas, Node, R);
end;
end;
{$ifdef DEBUG_VTV}Logger.ExitMethod([lcPaintDetails],'ClearNodeBackground');{$endif}
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 := InternalGetNodeAt(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;
begin
Result := InternalGetNodeAt(0, 0);
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 ssCtrlOS 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);
FillChar(PAnsiChar(PAnsiChar(FRoot) + OldSize)^, NewSize - OldSize, 0);
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]);
{$ifdef EnableThreadSupport}
// 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;
{$endif}
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;
//----------------------------------------------------------------------------------------------------------------------
procedure TBaseVirtualTree.LoadPanningCursors;
var
TheInstance: THandle;
begin
TheInstance := HINSTANCE;
with Screen do
begin
Cursors[crVT_MOVEALL]:=LoadCursor(TheInstance, 'VT_MOVEALL');
Cursors[crVT_MOVEEW]:=LoadCursor(TheInstance, 'VT_MOVEEW');
Cursors[crVT_MOVENS]:=LoadCursor(TheInstance, 'VT_MOVENS');
Cursors[crVT_MOVENW]:=LoadCursor(TheInstance, 'VT_MOVENW');
Cursors[crVT_MOVESW]:=LoadCursor(TheInstance, 'VT_MOVESW');
Cursors[crVT_MOVESE]:=LoadCursor(TheInstance, 'VT_MOVESE');
Cursors[crVT_MOVENE]:=LoadCursor(TheInstance, 'VT_MOVENE');
Cursors[crVT_MOVEW]:=LoadCursor(TheInstance, 'VT_MOVEW');
Cursors[crVT_MOVEE]:=LoadCursor(TheInstance, 'VT_MOVEE');
Cursors[crVT_MOVEN]:=LoadCursor(TheInstance, 'VT_MOVEN');
Cursors[crVT_MOVES]:=LoadCursor(TheInstance, 'VT_MOVES');
end;
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;
{$ifdef PACKARRAYPASCAL}
function TBaseVirtualTree.PackArray(const TheArray: TNodeArray; Count: Integer): Integer;
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}
//----------------------------------------------------------------------------------------------------------------------
{$IMPLICITEXCEPTIONS OFF}
function TBaseVirtualTree.PackArray(TheArray: TNodeArray; Count: Integer): Integer; assembler;
// 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.
asm
PUSH EBX
PUSH EDI
PUSH ESI
{$if FPC_FULLVERSION >= 30100}
MOV ESI, EDX
{$else}
MOV ECX, EDX //fpc < 3.1: count is in EDX. Move to ECX
MOV ESI, [EBP+8] //fpc < 3.1: TheArray is in EBP+8
{$endif}
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;
{$IMPLICITEXCEPTIONS ON}
{$endif}
//----------------------------------------------------------------------------------------------------------------------
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;
{$ifdef ThemeSupport}
//Theme: HTHEME;
{$EndIf ThemeSupport}
R: TRect;
//--------------- local function --------------------------------------------
procedure FillBitmap (ABitmap: TBitmap);
begin
with ABitmap, Canvas do
begin
ABitmap.SetSize(Size.cx, 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;
MaskHandle := 0;
Transparent := True;
TransparentColor := Brush.Color;
FillRect(Rect(0, 0, ABitmap.Width, ABitmap.Height));
end;
end;
//--------------- end local function ----------------------------------------
begin
Size.cx := 9;
Size.cy := 9;
{$ifdef ThemeSupport}
//todo
{
if tsUseThemes in FStates then
begin
Theme := OpenThemeData(Handle, 'TREEVIEW');
if IsWinVistaOrAbove and (toUseExplorerTheme in FOptions.FPaintOptions) then
begin
R := Rect(0, 0, 100, 100);
GetThemePartSize(Theme, FPlusBM.Canvas.Handle, TVP_GLYPH, GLPS_OPENED, @R, TS_TRUE, Size);
end;
end
else
Theme := 0;
}
{$endif ThemeSupport}
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? 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;
if BiDiMode = bdLeftToRight then
Polygon([Point(2, 0), Point(6, 4), Point(2, 8)])
else
Polygon([Point(6, 0), Point(2, 4), Point(6, 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);
end
else
FMinusBM.LoadFromResourceName(0, '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.LoadFromResourceName(0, 'VT_XPBUTTONPLUS');
FHotPlusBM.Canvas.Draw(0, 0, FPlusBM);
end;
end;
end;
end;
{$ifdef ThemeSupport}
//todo
// 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;
}
{$endif ThemeSupport}
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;
{$ifdef ThemeSupport}
// if Theme <> 0 then
// CloseThemeData(Theme);
{$endif}
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: String);
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
KillTimer(Handle, 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);
//lclheader
if hoVisible in FHeader.Options then
Dec(R.Top, FHeader.Height);
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.
//lcl todo
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; const OffsetPosition: TPoint; const 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 := Brush.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.SetWindowTheme(const Theme: String);
begin
FChangingTheme := True;
//lcl: todo
//UxTheme.SetWindowTheme(Handle, PAnsiChar(Theme), nil);
end;
//----------------------------------------------------------------------------------------------------------------------
procedure TBaseVirtualTree.TileBackground(Source: TBitmap; Target: TCanvas; const 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
{$ifndef INCOMPLETE_WINAPI}
ScrollDC(DC, 0, -Steps, Area, Area, 0, nil);
{$endif}
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
{$ifndef INCOMPLETE_WINAPI}
ScrollDC(DC, 0, Steps, Area, Area, 0, nil);
{$endif}
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: TLMessage);
begin
{$ifdef DEBUG_VTV}Logger.EnterMethod([lcMessages],'CMColorChange');{$endif}
if not (csLoading in ComponentState) then
begin
PrepareBitmaps(True, False);
if HandleAllocated then
Invalidate;
end;
{$ifdef DEBUG_VTV}Logger.ExitMethod([lcMessages],'CMColorChange');{$endif}
end;
//----------------------------------------------------------------------------------------------------------------------
procedure TBaseVirtualTree.CMBiDiModeChanged(var Message: TLMessage);
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);
{$ifdef DEBUG_VTV}Logger.Send([lcPaintDetails],'FEffectiveOffsetX after CMBidiModeChanged',FEffectiveOffsetX);{$endif}
end;
// TODO: Compilerversion Ein/Ausschalten < Ist Eingeschaltet >
{$ifdef VCLStyleSupport}
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: TLMessage);
// 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;
//----------------------------------------------------------------------------------------------------------------------
function TBaseVirtualTree.DoDragMsg(ADragMessage: TDragMessage; APosition: TPoint;
ADragObject: TDragObject; ATarget: TControl; ADocking: Boolean): LRESULT;
var
S: TObject;
KeyState: LongWord;
P: TPoint;
Formats: TFormatArray;
begin
{$ifdef DEBUG_VTV}Logger.EnterMethod([lcDrag],'DoDragMsg');{$endif}
S := ADragObject;
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 TDragControlObject) then
S := (S as TDragControlObject).Control;
case ADragMessage of
dmDragEnter, dmDragLeave, dmDragMove:
begin
if ADragMessage = dmDragEnter then
DoStateChange([tsVCLDragging]);
if ADragMessage = dmDragLeave then
DoStateChange([tsVCLDragFinished], [tsVCLDragging]);
if ADragMessage = dmDragMove then
with ScreenToClient(APosition) do
DoAutoScroll(X, Y);
KeyState := 0;
// Alt key will be queried by the KeysToShiftState function in DragOver.
if GetKeyState(VK_SHIFT) < 0 then
KeyState := KeyState or MK_SHIFT;
if GetKeyState(VK_CONTROL) < 0 then
KeyState := KeyState or MK_CONTROL;
// Allowed drop effects are simulated for VCL dd.
FVCLDragEffect := DROPEFFECT_MOVE or DROPEFFECT_COPY;
DragOver(S, KeyState, TDragState(ADragMessage), APosition, FVCLDragEffect);
Result := LRESULT(FVCLDragEffect);
FLastVCLDragTarget := FDropTargetNode;
if (ADragMessage = dmDragLeave) and Assigned(FDropTargetNode) then
begin
InvalidateNode(FDropTargetNode);
FDropTargetNode := nil;
end;
end;
dmDragDrop:
begin
KeyState := 0;
// Alt key will be queried by the KeysToShiftState function in DragOver
if GetKeyState(VK_SHIFT) < 0 then
KeyState := KeyState or MK_SHIFT;
if GetKeyState(VK_CONTROL) < 0 then
KeyState := KeyState 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 := ScreenToClient(APosition);
DoDragDrop(S, nil, Formats, KeysToShiftState(KeyState), P, FVCLDragEffect, FLastDropMode);
if Assigned(FDropTargetNode) then
begin
InvalidateNode(FDropTargetNode);
FDropTargetNode := nil;
end;
end;
dmFindTarget:
begin
Result := LRESULT(ControlAtPos(ScreenToClient(APosition), 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;
{$ifdef DEBUG_VTV}Logger.ExitMethod([lcDrag],'DoDragMsg');{$endif}
end;
//----------------------------------------------------------------------------------------------------------------------
//----------------------------------------------------------------------------------------------------------------------
procedure TBaseVirtualTree.CMFontChanged(var Message: TLMessage);
var
HeaderMessage: TLMessage;
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;
// 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
HintStr := GetShortHint(Hint)
else
Result := 1;
end;
end;
end;
{$ifdef DEBUG_VTV}Logger.Send([lcHint], 'ShowOwnHint: %s Result: %d', [BoolToStr(ShowOwnHint, True), Result]);{$endif}
{$ifdef DEBUG_VTV}Logger.Send([lcHint], 'CursorRect', CursorRect);{$endif}
{$ifdef DEBUG_VTV}Logger.Send([lcHint], 'CursorPos', CursorPos);{$endif}
{$ifdef DEBUG_VTV}Logger.Send([lcHint], 'HintMaxWidth', HintMaxWidth);{$endif}
// If hint must be show and is not the control's hint then get the hint
// from the node or from the DefaultHint
if ShowOwnHint and (Result = 0) then
begin
DummyLineBreakStyle := hlbDefault;
FLastHintRect := CursorRect;
if Length(FHintData.DefaultHint) > 0 then
HintStr := FHintData.DefaultHint
else
if FHintMode = hmToolTip then
HintStr := DoGetNodeToolTip(HitInfo.HitNode, HitInfo.HitColumn, DummyLineBreakStyle)
else
HintStr := DoGetNodeHint(HitInfo.HitNode, HitInfo.HitColumn, DummyLineBreakStyle);
// Determine actual line break style depending on what was returned by the methods and what's in the node.
if (DummyLineBreakStyle = hlbDefault) and Assigned(HitInfo.HitNode)
and (vsMultiline in HitInfo.HitNode.States) then
DummyLineBreakStyle := hlbForceMultiLine;
if DummyLineBreakStyle = hlbForceMultiLine then
begin
// NodeRect is already calculated for ToolTip
if FHintMode <> hmTooltip then
NodeRect := GetDisplayRect(HitInfo.HitNode, HitInfo.HitColumn, True, False);
HintMaxWidth := NodeRect.Right - NodeRect.Left;
end;
HintWindowClass := GetHintWindowClass;
FHintData.Tree := Self;
FHintData.Column := HitInfo.HitColumn;
FHintData.Node := HitInfo.HitNode;
FHintData.HintInfo := HintInfo;
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.CMMouseEnter(var Message: TLMessage);
begin
DoMouseEnter();
inherited;
end;
//----------------------------------------------------------------------------------------------------------------------
procedure TBaseVirtualTree.CMMouseLeave(var Message: TLMessage);
var
LeaveStates: TVirtualTreeStates;
begin
{$ifdef DEBUG_VTV}Logger.EnterMethod([lcMessages],'CMMouseLeave');{$endif}
{$ifdef DEBUG_VTV}Logger.Send([lcMessages],'FCurrentHotNode',hexStr(FCurrentHotNode));{$endif}
// 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
KillTimer(Handle, 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 CMMouseLeave(Message);
{$ifdef DEBUG_VTV}Logger.ExitMethod([lcMessages],'CMMouseLeave');{$endif}
end;
//----------------------------------------------------------------------------------------------------------------------
procedure TBaseVirtualTree.CMMouseWheel(var Message: TLMMouseEvent);
var
ScrollAmount: Integer;
ScrollLines: DWORD;
RTLFactor: Integer;
WheelFactor: Double;
begin
//todo: rename to WM*
{$ifdef DEBUG_VTV}Logger.EnterMethod([lcScroll],'CMMouseWheel');{$endif}
StopWheelPanning;
inherited WMMouseWheel(Message);
if Message.Result = 0 then
begin
with Message do
begin
Result := 1;
WheelFactor := WheelDelta / WHEEL_DELTA;
if (FRangeY > Cardinal(ClientHeight)) and (not (ssShift in State)) then
begin
{$ifdef DEBUG_VTV}Logger.Send([lcScroll],'Scroll Vertical - WheelDelta', WheelDelta);{$endif}
// Scroll vertically if there's something to scroll...
if ssCtrlOS in State then
ScrollAmount := Trunc(WheelFactor * ClientHeight)
else
begin
SystemParametersInfo(SPI_GETWHEELSCROLLLINES, 0, @ScrollLines, 0);
if ScrollLines = WHEEL_PAGESCROLL then
ScrollAmount := Integer(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 ssCtrlOS in State 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;
{$ifdef DEBUG_VTV}Logger.ExitMethod([lcScroll],'CMMouseWheel');{$endif}
end;
//----------------------------------------------------------------------------------------------------------------------
{$ifdef EnableNativeTVM}
procedure TBaseVirtualTree.TVMGetItem(var Message: TLMessage);
// 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: String;
{$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, PChar(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: TLMessage);
// 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: TLMessage);
// 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;
{$endif}
//----------------------------------------------------------------------------------------------------------------------
procedure TBaseVirtualTree.WMCancelMode(var Message: TLMessage);
begin
{$ifdef DEBUG_VTV}Logger.EnterMethod([lcMessages],'WMCancelMode');{$endif}
// Clear any transient state.
KillTimer(Handle, ExpandTimer);
KillTimer(Handle, EditTimer);
KillTimer(Handle, ScrollTimer);
KillTimer(Handle, SearchTimer);
KillTimer(Handle, ThemeChangedTimer);
FSearchBuffer := '';
FLastSearchNode := nil;
DoStateChange([], [tsClearPending, tsEditPending, tsOLEDragPending, tsVCLDragPending, tsDrawSelecting,
tsDrawSelPending, tsIncrementalSearching]);
inherited WMCancelMode(Message);
{$ifdef DEBUG_VTV}Logger.ExitMethod([lcMessages],'WMCancelMode');{$endif}
end;
//----------------------------------------------------------------------------------------------------------------------
procedure TBaseVirtualTree.WMChangeState(var Message: TLMessage);
var
EnterStates,
LeaveStates: TVirtualTreeStates;
begin
{$ifdef DEBUG_VTV}Logger.EnterMethod([lcMessages],'WMChangeState');{$endif}
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);
{$ifdef DEBUG_VTV}Logger.ExitMethod([lcMessages],'WMChangeState');{$endif}
end;
//----------------------------------------------------------------------------------------------------------------------
procedure TBaseVirtualTree.WMChar(var Message: TLMChar);
begin
{$ifdef DEBUG_VTV}Logger.EnterMethod([lcMessages],'WMChar');{$endif}
if tsIncrementalSearchPending in FStates then
begin
HandleIncrementalSearch(Message.CharCode);
DoStateChange([], [tsIncrementalSearchPending]);
end;
inherited WMChar(Message);
{$ifdef DEBUG_VTV}Logger.ExitMethod([lcMessages],'WMChar');{$endif}
end;
//----------------------------------------------------------------------------------------------------------------------
procedure TBaseVirtualTree.WMContextMenu(var Message: TLMContextMenu);
// This method is called when a popup menu is about to be displayed.
// We have to cancel some pending states here to avoid interferences.
//lcl: handle mouse up here because MouseUp is not called when popup is show
var
HitInfo: THitInfo;
begin
{$ifdef DEBUG_VTV}Logger.EnterMethod([lcMessages],'WMContextMenu');{$endif}
DoStateChange([], [tsClearPending, tsEditPending, tsOLEDragPending, tsVCLDragPending]);
{$ifdef ContextMenuBeforeMouseUp}
if Assigned(PopupMenu) then
begin
if FHeader.FStates = [] then
begin
Application.CancelHint;
if IsMouseSelecting then
begin
// Reset selection state already here, before the inherited handler opens the default menu.
DoStateChange([], [tsDrawSelecting, tsDrawSelPending]);
Invalidate;
end;
inherited WMContextMenu(Message);
if (toRightClickSelect in FOptions.FSelectionOptions) then
begin
// get information about the hit
GetHitTestInfoAt(Message.XPos, Message.YPos, True, HitInfo);
HandleMouseUp(0, HitInfo);
end;
end;
end
else
inherited WMContextMenu(Message);
{$else}
if not (tsPopupMenuShown in FStates) then
inherited WMContextMenu(Message);
{$endif}
{$ifdef DEBUG_VTV}Logger.ExitMethod([lcMessages],'WMContextMenu');{$endif}
end;
//----------------------------------------------------------------------------------------------------------------------
procedure TBaseVirtualTree.WMCopy(var Message: TLMNoParams);
begin
{$ifdef DEBUG_VTV}Logger.EnterMethod([lcMessages],'WMCopy');{$endif}
CopyToClipboard;
{$ifdef DEBUG_VTV}Logger.ExitMethod([lcMessages],'WMCopy');{$endif}
end;
//----------------------------------------------------------------------------------------------------------------------
procedure TBaseVirtualTree.WMCut(var Message: TLMNoParams);
begin
{$ifdef DEBUG_VTV}Logger.EnterMethod([lcMessages],'WMCut');{$endif}
CutToClipboard;
{$ifdef DEBUG_VTV}Logger.ExitMethod([lcMessages],'WMCut');{$endif}
end;
//----------------------------------------------------------------------------------------------------------------------
procedure TBaseVirtualTree.WMEnable(var Message: TLMNoParams);
begin
{$ifdef DEBUG_VTV}Logger.EnterMethod([lcMessages],'WMEnable');{$endif}
//LCL does not has inherited WMEnable
//inherited WMEnable(Message);
RedrawWindow(Handle, nil, 0, RDW_FRAME or RDW_INVALIDATE or RDW_NOERASE or RDW_NOCHILDREN);
{$ifdef DEBUG_VTV}Logger.EnterMethod([lcMessages],'WMEnable');{$endif}
end;
//----------------------------------------------------------------------------------------------------------------------
procedure TBaseVirtualTree.WMEraseBkgnd(var Message: TLMEraseBkgnd);
begin
{$ifdef DEBUG_VTV}Logger.EnterMethod([lcEraseBkgnd],'WMEraseBkgnd');{$endif}
Message.Result := 1;
{$ifdef DEBUG_VTV}Logger.ExitMethod([lcEraseBkgnd],'WMEraseBkgnd');{$endif}
end;
//----------------------------------------------------------------------------------------------------------------------
procedure TBaseVirtualTree.WMGetDlgCode(var Message: TLMNoParams);
begin
{$ifdef DEBUG_VTV}Logger.Send([lcMessages],'WMGetDlgCode');{$endif}
Message.Result := DLGC_WANTCHARS or DLGC_WANTARROWS;
if FWantTabs then
Message.Result := Message.Result or DLGC_WANTTAB;
end;
//----------------------------------------------------------------------------------------------------------------------
{$ifdef EnableAccessible}
procedure TBaseVirtualTree.WMGetObject(var Message: TLMessage);
begin
{$ifdef DEBUG_VTV}Logger.EnterMethod([lcMessages],'WMGetObject');{$endif}
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 Assigned(Accessible) then
Message.Result := LresultFromObject(IID_IAccessible, Message.WParam, FAccessible)
else
Message.Result := 0;
{$ifdef DEBUG_VTV}Logger.ExitMethod([lcMessages],'WMGetObject');{$endif}
end;
{$endif}
//----------------------------------------------------------------------------------------------------------------------
procedure TBaseVirtualTree.WMHScroll(var Message: TLMHScroll);
//--------------- 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
{$ifdef DEBUG_VTV}Logger.EnterMethod([lcMessages],'WMHScroll');{$endif}
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 DEFINED(LCLQt) OR DEFINED(LCLCarbon)}
if UseRightToLeftAlignment then
SetOffsetX(-Integer(FRangeX) + ClientWidth + Message.Pos)
else
SetOffsetX(-Message.Pos);
{$else}
if UseRightToLeftAlignment then
SetOffsetX(-Integer(FRangeX) + ClientWidth + GetRealScrollPosition)
else
SetOffsetX(-GetRealScrollPosition);
{$endif}
end;
SB_TOP:
SetOffsetX(0);
end;
Message.Result := 0;
{$ifdef DEBUG_VTV}Logger.ExitMethod([lcMessages],'WMHScroll');{$endif}
end;
//----------------------------------------------------------------------------------------------------------------------
procedure TBaseVirtualTree.WMKeyDown(var Message: TLMKeyDown);
// 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
{$ifdef DEBUG_VTV}Logger.EnterMethod([lcMessages],'WMKeyDown');{$endif}
// Make form key preview work and let application modify the key if it wants this.
inherited WMKeyDown(Message);
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 = [ssCtrlOS]) 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 (ssCtrlOS 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 ssCtrlOS 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 ssCtrlOS 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 ssCtrlOS 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 ssCtrlOS 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 ssCtrlOS 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 ssCtrlOS 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;
{$ifdef LCLGtk2}
//workaround for changing focus bug
if CharCode <> VK_TAB then
CharCode := 0;
{$endif}
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.
//todo: reimplement
{$ifndef INCOMPLETE_WINAPI}
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, @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, @Buffer, 0);
{$endif}
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 ssCtrlOS 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 ssCtrlOS 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
//gtk1 does not like to free a component in KeyDown
{$ifndef LCLGtk}
else
if IsEditing then
CancelEditNode;
{$endif}
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 ssCtrlOS 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 * [ssCtrlOS, ssAlt] = []) or ((Shift * [ssCtrlOS, ssAlt] = [ssCtrlOS, ssAlt]))) and (CharCode >= 32) then
DoStateChange([tsIncrementalSearchPending]);
end;
end;
end;
end;
end;
{$ifdef DEBUG_VTV}Logger.ExitMethod([lcMessages],'WMKeyDown');{$endif}
end;
//----------------------------------------------------------------------------------------------------------------------
procedure TBaseVirtualTree.WMKeyUp(var Message: TLMKeyUp);
begin
{$ifdef DEBUG_VTV}Logger.EnterMethod([lcMessages],'WMKeyUp');{$endif}
inherited WMKeyUp(Message);
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;
{$ifdef DEBUG_VTV}Logger.ExitMethod([lcMessages],'WMKeyUp');{$endif}
end;
//----------------------------------------------------------------------------------------------------------------------
procedure TBaseVirtualTree.WMKillFocus(var Msg: TLMKillFocus);
begin
{$ifdef DEBUG_VTV}Logger.EnterMethod([lcMessages],'WMKillFocus');{$endif}
inherited WMKillFocus(Msg);
// 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).
KillTimer(Handle, ExpandTimer);
KillTimer(Handle, EditTimer);
KillTimer(Handle, ScrollTimer);
KillTimer(Handle, 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);
{$ifdef DEBUG_VTV}Logger.ExitMethod([lcMessages],'WMKillFocus');{$endif}
end;
//----------------------------------------------------------------------------------------------------------------------
procedure TBaseVirtualTree.WMLButtonDblClk(var Message: TLMLButtonDblClk);
var
HitInfo: THitInfo;
begin
{$ifdef DEBUG_VTV}Logger.EnterMethod([lcMessages],'WMLButtonDblClk');{$endif}
DoStateChange([tsLeftDblClick]);
inherited WMLButtonDblClk(Message);
// get information about the hit
GetHitTestInfoAt(Message.XPos, Message.YPos, True, HitInfo);
HandleMouseDblClick(Message, HitInfo);
DoStateChange([], [tsLeftDblClick]);
{$ifdef DEBUG_VTV}Logger.ExitMethod([lcMessages],'WMLButtonDblClk');{$endif}
end;
//----------------------------------------------------------------------------------------------------------------------
procedure TBaseVirtualTree.WMLButtonDown(var Message: TLMLButtonDown);
var
HitInfo: THitInfo;
begin
{$ifdef DEBUG_VTV}Logger.EnterMethod([lcMessages],'WMLButtonDown');{$endif}
DoStateChange([tsLeftButtonDown]);
inherited WMLButtonDown(Message);
// get information about the hit
GetHitTestInfoAt(Message.XPos, Message.YPos, True, HitInfo);
{$ifdef DEBUG_VTV}
if HitInfo.HitNode <> nil then
Logger.Send([lcPaintHeader, lcMouseEvent],'WMLButtonDown - HitNode.Index', HitInfo.HitNode^.Index);
{$endif}
HandleMouseDown(Message, HitInfo);
{$ifdef DEBUG_VTV}Logger.ExitMethod([lcMessages],'WMLButtonDown');{$endif}
end;
//----------------------------------------------------------------------------------------------------------------------
procedure TBaseVirtualTree.WMLButtonUp(var Message: TLMLButtonUp);
var
HitInfo: THitInfo;
begin
DoStateChange([], [tsLeftButtonDown, tsNodeHeightTracking, tsNodeHeightTrackPending]);
// get information about the hit
GetHitTestInfoAt(Message.XPos, Message.YPos, True, HitInfo);
HandleMouseUp(Message.Keys, HitInfo);
inherited WMLButtonUp(Message);
{$ifdef DEBUG_VTV}Logger.ExitMethod([lcMessages],'WMLButtonUp');{$endif}
end;
//----------------------------------------------------------------------------------------------------------------------
procedure TBaseVirtualTree.WMMButtonDblClk(var Message: TLMMButtonDblClk);
var
HitInfo: THitInfo;
begin
{$ifdef DEBUG_VTV}Logger.EnterMethod([lcMessages],'WMMButtonDblClk');{$endif}
DoStateChange([tsMiddleDblClick]);
inherited WMMButtonDblClk(Message);
// 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]);
{$ifdef DEBUG_VTV}Logger.ExitMethod([lcMessages],'WMMButtonDblClk');{$endif}
end;
//----------------------------------------------------------------------------------------------------------------------
procedure TBaseVirtualTree.WMMButtonDown(var Message: TLMMButtonDown);
var
HitInfo: THitInfo;
begin
{$ifdef DEBUG_VTV}Logger.EnterMethod([lcMessages],'WMMButtonDown');{$endif}
DoStateChange([tsMiddleButtonDown]);
if FHeader.FStates = [] then
begin
inherited WMMButtonDown(Message);
// 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;
{$ifdef DEBUG_VTV}Logger.ExitMethod([lcMessages],'WMMButtonDown');{$endif}
end;
//----------------------------------------------------------------------------------------------------------------------
procedure TBaseVirtualTree.WMMButtonUp(var Message: TLMMButtonUp);
var
HitInfo: THitInfo;
begin
{$ifdef DEBUG_VTV}Logger.EnterMethod([lcMessages],'WMMButtonUp');{$endif}
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 WMMButtonUp(Message);
// get information about the hit
if toMiddleClickSelect in FOptions.FSelectionOptions then
begin
GetHitTestInfoAt(Message.XPos, Message.YPos, True, HitInfo);
HandleMouseUp(Message.Keys, HitInfo);
end;
end;
{$ifdef DEBUG_VTV}Logger.ExitMethod('WMMButtonUp');{$endif}
end;
//----------------------------------------------------------------------------------------------------------------------
{$ifdef EnableNCFunctions}
procedure TBaseVirtualTree.WMNCCalcSize(var Message: TLMNCCalcSize);
begin
{$ifdef DEBUG_VTV}Logger.EnterMethod([lcMessages],'WMNCCalcSize');{$endif}
inherited WMNCCalcSize(Message);
with FHeader do
if hoVisible in FHeader.FOptions then
with Message.CalcSize_Params^ do
Inc(rgrc[0].Top, FHeight);
{$ifdef DEBUG_VTV}Logger.ExitMethod([lcMessages],'WMNCCalcSize');{$endif}
end;
//----------------------------------------------------------------------------------------------------------------------
procedure TBaseVirtualTree.WMNCHitTest(var Message: TWMNCHitTest);
begin
{$ifdef DEBUG_VTV}Logger.EnterMethod([lcMessages],'WMNCHitTest');{$endif}
inherited WMNCHitTest(Message);
if (hoVisible in FHeader.FOptions) and
FHeader.InHeader(ScreenToClient(SmallPointToPoint(Message.Pos))) then
Message.Result := HTBORDER;
{$ifdef DEBUG_VTV}Logger.ExitMethod([lcMessages],'WMNCHitTest');{$endif}
end;
//----------------------------------------------------------------------------------------------------------------------
procedure TBaseVirtualTree.WMNCPaint(var Message: TRealWMNCPaint);
var
DC: HDC;
R: TRect;
Flags: DWORD;
{$ifdef ThemeSupport}
ExStyle: Integer;
TempRgn: HRGN;
BorderWidth,
BorderHeight: Integer;
{$endif ThemeSupport}
begin
{$ifdef DEBUG_VTV}Logger.EnterMethod([lcMessages],'WMNCPaint');{$endif}
{$ifdef ThemeSupport}
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, Integer(TempRgn), 0);
DeleteObject(TempRgn);
end
else
DefaultHandler(Message);
end
else
{$endif ThemeSupport}
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);
{$ifdef DEBUG_VTV}Logger.ExitMethod([lcMessages],'WMNCPaint');{$endif}
end;
{$endif}
//----------------------------------------------------------------------------------------------------------------------
procedure TBaseVirtualTree.WMPaint(var Message: TLMPaint);
begin
{$ifdef DEBUG_VTV}Logger.EnterMethod([lcMessages],'WMPaint');{$endif}
//todo:
//Windows.GetUpdateRect is always empty because BeginPaint was called
//see if PaintStruct has the same rect
{$ifndef INCOMPLETE_WINAPI}
if tsVCLDragging in FStates then
ImageList_DragShowNolock(False);
{$endif}
if csPaintCopy in ControlState then
FUpdateRect := ClientRect
else
FUpdateRect := Message.PaintStruct^.rcPaint;
{$ifdef DEBUG_VTV}Logger.Send([lcPaint],'FUpdateRect', FUpdateRect);{$endif}
inherited WMPaint(Message);
{$ifndef INCOMPLETE_WINAPI}
if tsVCLDragging in FStates then
ImageList_DragShowNolock(True);
{$endif}
{$ifdef DEBUG_VTV}Logger.ExitMethod([lcMessages],'WMPaint');{$endif}
end;
//----------------------------------------------------------------------------------------------------------------------
procedure TBaseVirtualTree.WMPaste(var Message: TLMNoParams);
begin
{$ifdef DEBUG_VTV}Logger.EnterMethod([lcMessages],'WMPaste');{$endif}
PasteFromClipboard;
{$ifdef DEBUG_VTV}Logger.ExitMethod([lcMessages],'WMPaste');{$endif}
end;
//----------------------------------------------------------------------------------------------------------------------
{$ifdef EnablePrintFunctions}
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
{$ifdef DEBUG_VTV}Logger.EnterMethod([lcMessages],'WMPrint');{$endif}
// 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 WMPrint(Message);
{$ifdef DEBUG_VTV}Logger.ExitMethod([lcMessages],'WMPrint');{$endif}
end;
//----------------------------------------------------------------------------------------------------------------------
procedure TBaseVirtualTree.WMPrintClient(var Message: TWMPrintClient);
var
Window: TRect;
Target: TPoint;
Canvas: TCanvas;
begin
{$ifdef DEBUG_VTV}Logger.EnterMethod([lcMessages],'WMPrintClient');{$endif}
// 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;
{$ifdef DEBUG_VTV}Logger.ExitMethod([lcMessages],'WMPrintClient');{$endif}
end;
{$endif}
//----------------------------------------------------------------------------------------------------------------------
procedure TBaseVirtualTree.WMRButtonDblClk(var Message: TLMRButtonDblClk);
var
HitInfo: THitInfo;
begin
{$ifdef DEBUG_VTV}Logger.EnterMethod([lcMessages],'WMRButtonDblClk');{$endif}
DoStateChange([tsRightDblClick]);
inherited WMRButtonDblClk(Message);
// 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]);
{$ifdef DEBUG_VTV}Logger.ExitMethod([lcMessages],'WMRButtonDblClk');{$endif}
end;
//----------------------------------------------------------------------------------------------------------------------
procedure TBaseVirtualTree.WMRButtonDown(var Message: TLMRButtonDown);
var
HitInfo: THitInfo;
begin
{$ifdef DEBUG_VTV}Logger.EnterMethod([lcMessages],'WMRButtonDown');{$endif}
DoStateChange([tsRightButtonDown]);
if FHeader.FStates = [] then
begin
inherited WMRButtonDown(Message);
// get information about the hit
if toRightClickSelect in FOptions.FSelectionOptions then
begin
GetHitTestInfoAt(Message.XPos, Message.YPos, True, HitInfo);
HandleMouseDown(Message, HitInfo);
end;
end;
{$ifdef DEBUG_VTV}Logger.ExitMethod([lcMessages],'WMRButtonDown');{$endif}
end;
//----------------------------------------------------------------------------------------------------------------------
procedure TBaseVirtualTree.WMRButtonUp(var Message: TLMRButtonUp);
// handle right click selection and node specific popup menu
var
HitInfo: THitInfo;
begin
{$ifdef DEBUG_VTV}Logger.EnterMethod([lcMessages],'WMRButtonUp');{$endif}
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 WMRButtonUp(Message);
// get information about the hit
GetHitTestInfoAt(Message.XPos, Message.YPos, True, HitInfo);
if toRightClickSelect in FOptions.FSelectionOptions then
HandleMouseUp(Message.Keys, HitInfo);
if not Assigned(PopupMenu) then
DoPopupMenu(HitInfo.HitNode, HitInfo.HitColumn, Point(Message.XPos, Message.YPos));
end;
{$ifdef DEBUG_VTV}Logger.ExitMethod([lcMessages],'WMRButtonUp');{$endif}
end;
//----------------------------------------------------------------------------------------------------------------------
procedure TBaseVirtualTree.WMSetFocus(var Msg: TLMSetFocus);
begin
{$ifdef DEBUG_VTV}Logger.EnterMethod([lcMessages],'WMSetFocus') ;{$endif}
inherited WMSetFocus(Msg);
if (FSelectionCount > 0) or not (toGhostedIfUnfocused in FOptions.FPaintOptions) then
Invalidate;
{$ifdef DEBUG_VTV}Logger.ExitMethod([lcMessages],'WMSetFocus');{$endif}
end;
//----------------------------------------------------------------------------------------------------------------------
procedure TBaseVirtualTree.WMSize(var Message: TLMSize);
begin
{$ifdef DEBUG_VTV}Logger.EnterMethod([lcMessages],'WMSize');{$endif}
inherited WMSize(Message);
// 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;
{$ifdef DEBUG_VTV}Logger.ExitMethod([lcMessages],'WMSize');{$endif}
end;
//----------------------------------------------------------------------------------------------------------------------
{$ifdef ThemeSupport}
{$ifdef Windows}
//todo
procedure TBaseVirtualTree.WMThemeChanged(var Message: TLMessage);
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;
{$endif}
{$endif ThemeSupport}
//----------------------------------------------------------------------------------------------------------------------
procedure TBaseVirtualTree.WMTimer(var Message: TLMTimer);
// centralized timer handling happens here
begin
{$ifdef DEBUG_VTV}Logger.EnterMethod([lcMessages,lcTimer],'WMTimer');{$endif}
with Message do
begin
{$ifdef DEBUG_VTV}Logger.Send([lcTimer],'TimerId',TimerId);{$endif}
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]);
KillTimer(Handle, SearchTimer);
FSearchBuffer := '';
FLastSearchNode := nil;
end;
ThemeChangedTimer:
begin
KillTimer(Handle, ThemeChangedTimer);
RecreateWnd(Self);
end;
end;
end;
{$ifdef DEBUG_VTV}Logger.ExitMethod([lcMessages,lcTimer],'WMTimer');{$endif}
end;
//----------------------------------------------------------------------------------------------------------------------
procedure TBaseVirtualTree.WMVScroll(var Message: TLMVScroll);
//--------------- 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;
{$ifdef DEBUG_VTV}Logger.Send([lcScroll],'GetRealScrollPosition',Result);{$endif}
end;
//--------------- end local functions ---------------------------------------
begin
{$ifdef DEBUG_VTV}Logger.EnterMethod([lcScroll],'WMVScroll');{$endif}
//{$ifdef DEBUG_VTV}Logger.SendCallStack([lcScroll],'CallStack');{$endif}
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]);
{$if DEFINED(LCLQt) OR DEFINED(LCLCarbon)}
SetOffsetY(-Message.Pos);
{$else}
SetOffsetY(-GetRealScrollPosition);
{$endif}
end;
SB_TOP:
SetOffsetY(0);
end;
Message.Result := 0;
{$ifdef DEBUG_VTV}Logger.ExitMethod([lcScroll],'WMVScroll');{$endif}
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
AdjustImageBorder(Images.Width, Images.Height, BidiMode, VAlign, R, ImageInfo);
end;
//----------------------------------------------------------------------------------------------------------------------
procedure TBaseVirtualTree.AdjustImageBorder(ImageWidth, ImageHeight: Integer; 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, ImageWidth + 2);
end
else
begin
ImageInfo.XPos := R.Right - Images.Width;
Dec(R.Right, ImageWidth + 2);
end;
ImageInfo.YPos := R.Top + VAlign - ImageHeight div 2;
end;
//----------------------------------------------------------------------------------------------------------------------
procedure TBaseVirtualTree.AdjustPaintCellRect(var PaintInfo: TVTPaintInfo; out 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
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
NewCursor := crVT_MOVEALL
else
NewCursor := crVT_MOVEEW
end
else
NewCursor := crVT_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
NewCursor := crVT_MOVENW
else
if Y - FLastClickPos.Y > 8 then
NewCursor := crVT_MOVESW
else
NewCursor := crVT_MOVEW;
end
else
if X - FLastClickPos.X > 8 then
begin
// Right hand side.
if Y - FLastClickPos.Y < -8 then
NewCursor := crVT_MOVENE
else
if Y - FLastClickPos.Y > 8 then
NewCursor := crVT_MOVESE
else
NewCursor := crVT_MOVEE;
end
else
begin
// Up or down.
if Y < FLastClickPos.Y then
NewCursor := crVT_MOVEN
else
NewCursor := crVT_MOVES;
end;
end
else
if ScrollHorizontal then
begin
// Only horizontal movement allowed.
if X < FLastClickPos.X then
Name := 'VT_MOVEW'
else
NewCursor := crVT_MOVEE;
end
else
begin
// Only vertical movement allowed.
if Y < FLastClickPos.Y then
NewCursor := crVT_MOVEN
else
NewCursor := crVT_MOVES;
end;
end;
// Now load the cursor and apply it.
{$ifdef Windows}
LCLIntf.SetCursor(Screen.Cursors[NewCursor]);
{$else}
Cursor := NewCursor;
{$endif}
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
begin
if HandleAllocated then
KillTimer(Handle,StructureChangeTimer);
end
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
KillTimer(Handle, 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.');
{$ifdef DEBUG_VTV}Logger.Send('FTotalInternalDataSize BEFORE',FTotalInternalDataSize);{$endif}
{$ifdef DEBUG_VTV}Logger.Send('Size',Size);{$endif}
{$ifdef DEBUG_VTV}Logger.Send('TreeNodeSize',TreeNodeSize);{$endif}
Result := TreeNodeSize + FTotalInternalDataSize;
{$ifdef DEBUG_VTV}Logger.Send('Result',Result);{$endif}
Inc(FTotalInternalDataSize, (Size + (SizeOf(Pointer) - 1)) and not (SizeOf(Pointer) - 1));
{$ifdef DEBUG_VTV}Logger.Send('FTotalInternalDataSize AFTER', FTotalInternalDataSize);{$endif}
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
{$ifndef Windows}
//Is necessary to properly implement timeGetTime in non Windows
Exit;
{$endif}
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
//lclheader
if hoVisible in FHeader.Options then
Dec(Y, FHeader.Height);
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 VTVDragManager.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,
0,0,0);
begin
//todo_lcl
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);
//lcl: Ctl3D is not used in LCL. Has the same meaning of BorderStyle = bsSingle
{
if BorderStyle = 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;
}
//todo_lcl_low
//AddBiDiModeExStyle(ExStyle);
end;
end;
//----------------------------------------------------------------------------------------------------------------------
procedure TBaseVirtualTree.CreateWnd;
// Initializes data which depends on a valid window handle.
begin
DoStateChange([tsWindowCreating]);
inherited;
{$ifdef DEBUG_VTV}Logger.Send([lcInfo],'Handle (CreateWnd)',Handle);{$endif}
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;
//lcl: Call with Force argument to true since AdjustAutoSize is not called in Loaded
if hoAutoResize in FHeader.FOptions then
FHeader.FColumns.AdjustAutoSize(InvalidColumn, True);
PrepareBitmaps(True, True);
{$ifdef Windows}
// 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, VTVDragManager as IDropTarget);
{$endif}
UpdateScrollBars(True);
UpdateHeaderRect;
end;
//----------------------------------------------------------------------------------------------------------------------
procedure TBaseVirtualTree.DestroyHandle;
begin
{$ifdef DEBUG_VTV}Logger.EnterMethod([lcMessages],'DestroyHandle');{$endif}
//lcl: this code was originally called is response to WM_NCDESTROY
// see if there will be issues calling here
InterruptValidation;
KillTimer(Handle, ChangeTimer);
KillTimer(Handle, StructureChangeTimer);
{$ifdef Windows}
if not (csDesigning in ComponentState) and (toAcceptOLEDrop in FOptions.FMiscOptions) then
RevokeDragDrop(Handle);
{$endif}
// Clean up other stuff.
DeleteObject(FDottedBrush);
FDottedBrush := 0;
CancelEditNode;
inherited;
{$ifdef DEBUG_VTV}Logger.ExitMethod([lcMessages],'DestroyHandle');{$endif}
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);
//lclheader
if (ClientHeight - FOffsetY < Integer(FRangeY)) and (Y > inherited GetClientRect.Bottom - Integer(FDefaultNodeHeight)) then
Include(Result, sdDown);
if hoVisible in FHeader.FOptions then
Dec(Y, FHeader.Height);
if (Y > 0) and (Y < Integer(FDefaultNodeHeight)) and (FOffsetY <> 0) then
Include(Result, sdUp);
//todo: probably the code below is bug due to poor timeGetTime implementation
// 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 VTVDragManager.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; const CellRect: TRect);
begin
if Assigned(FOnAfterCellPaint) then
FOnAfterCellPaint(Self, Canvas, Node, Column, CellRect);
end;
//----------------------------------------------------------------------------------------------------------------------
procedure TBaseVirtualTree.DoAfterItemErase(Canvas: TCanvas; Node: PVirtualNode; const ItemRect: TRect);
begin
if Assigned(FOnAfterItemErase) then
FOnAfterItemErase(Self, Canvas, Node, ItemRect);
end;
//----------------------------------------------------------------------------------------------------------------------
procedure TBaseVirtualTree.DoAfterItemPaint(Canvas: TCanvas; Node: PVirtualNode; const 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
KillTimer(Handle, 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;
procedure TBaseVirtualTree.DoAutoSize;
begin
//The default DoAutoSize makes the editors be placed wrongly when scrolling
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);
{$ifdef LCLWin32}
var
UpdateRect: TRect;
{$endif}
begin
//todo: implement under non win32
if Assigned(FOnBeforeCellPaint) then
begin
{$ifdef LCLWin32}
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;
{$endif}
Canvas.Font := Self.Font; // Fixes issue #298
FOnBeforeCellPaint(Self, Canvas, Node, Column, CellPaintMode, CellRect, ContentRect);
{$ifdef LCLWin32}
if CellPaintMode = cpmGetContentMargin then
begin
SetUpdateState(False);
InvalidateRect(Handle, @UpdateRect, False);
end;
{$endif}
end;
end;
//----------------------------------------------------------------------------------------------------------------------
procedure TBaseVirtualTree.DoBeforeItemErase(Canvas: TCanvas; Node: PVirtualNode; const 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; const 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
KillTimer(Handle, EditTimer);
DoStateChange([], [tsEditPending]);
Result := (tsEditing in FStates) and FEditLink.CancelEdit;
if Result then
begin
DoStateChange([], [tsEditing]);
if Assigned(FOnEditCancelled) then
FOnEditCancelled(Self, FEditColumn);
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
KillTimer(Handle, 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);
{$ifdef EnableAccessible}
NotifyWinEvent(EVENT_OBJECT_STATECHANGE, Handle, OBJID_CLIENT, CHILDID_SELF);
{$endif}
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);
{$ifdef EnableAccessible}
if Assigned(FAccessibleItem) then
NotifyWinEvent(EVENT_OBJECT_STATECHANGE, Handle, OBJID_CLIENT, CHILDID_SELF);
{$endif}
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;
//lclheader
if hoVisible in FHeader.FOptions then
Inc(R.Bottom, FHeader.Height);
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: LongWord;
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: LongWord;
DragObject: TDragObject;
DataObject: IDataObject;
begin
{$ifdef DEBUG_VTV}Logger.EnterMethod([lcDrag],'DoDragging');{$endif}
{$ifdef DEBUG_VTV}Logger.SendCallStack([lcDrag],'Stack');{$endif}
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 := VTVDragManager.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);
VTVDragManager.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;
{$ifdef DEBUG_VTV}Logger.ExitMethod([lcDrag],'DoDragging');{$endif}
end;
//----------------------------------------------------------------------------------------------------------------------
procedure TBaseVirtualTree.DoDragExpand;
var
SourceTree: TBaseVirtualTree;
begin
KillTimer(Handle, ExpandTimer);
if Assigned(FDropTargetNode) and (vsHasChildren in FDropTargetNode.States) and
not (vsExpanded in FDropTargetNode.States) then
begin
if Assigned(FDragManager) then
SourceTree := TBaseVirtualTree(VTVDragManager.DragSource)
else
SourceTree := nil;
if not VTVDragManager.DropTargetHelperSupported and Assigned(SourceTree) then
SourceTree.FDragImage.HideDragImage;
ToggleNode(FDropTargetNode);
UpdateWindow(Handle);
if not VTVDragManager.DropTargetHelperSupported and Assigned(SourceTree) then
SourceTree.FDragImage.ShowDragImage;
end;
end;
//----------------------------------------------------------------------------------------------------------------------
function TBaseVirtualTree.DoDragOver(Source: TObject; Shift: TShiftState; State: TDragState; const Pt: TPoint; Mode: TDropMode;
var Effect: LongWord): 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; const Pt: TPoint; var Effect: LongWord; 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;
KillTimer(Handle, ScrollTimer);
KillTimer(Handle, 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, 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
KillTimer(Handle, 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);
{$ifdef EnableAccessible}
NotifyWinEvent(EVENT_OBJECT_STATECHANGE, Handle, OBJID_CLIENT, CHILDID_SELF);
{$endif}
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);
{$ifdef EnableAccessible}
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);
{$endif}
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;
//----------------------------------------------------------------------------------------------------------------------
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: String);
// 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): String;
begin
Result := Hint;
LineBreakStyle := hlbDefault;
end;
//----------------------------------------------------------------------------------------------------------------------
function TBaseVirtualTree.DoGetNodeTooltip(Node: PVirtualNode; Column: TColumnIndex;
var LineBreakStyle: TVTTooltipLineBreakStyle): String;
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; const 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; const 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; const 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: String): 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; const R: TRect): Boolean;
begin
Result := False;
if Assigned(FOnPaintBackground) then
FOnPaintBackground(Self, Canvas, R, Result);
end;
//----------------------------------------------------------------------------------------------------------------------
procedure TBaseVirtualTree.DoPaintDropMark(Canvas: TCanvas; Node: PVirtualNode; const 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
{$ifdef DEBUG_VTV}Logger.EnterMethod([lcDrag],'DoPaintDropMark');{$endif}
if FLastDropMode in [dmAbove, dmBelow] then
with Canvas do
begin
{$ifdef DEBUG_VTV}Logger.Send([lcDrag],'DropMode in [dmAbove,dmBelow]');{$endif}
SavePenStyle := Pen.Style;
Pen.Style := psClear;
SaveBrushColor := Brush.Color;
Brush.Color := FColors.DropMarkColor;
{$ifdef DEBUG_VTV}Logger.SendColor([lcDrag],'Brush.Color',Brush.Color);{$endif}
{$ifdef DEBUG_VTV}Logger.Send([lcDrag],'R',R);{$endif}
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;
{$ifdef DEBUG_VTV}Logger.ExitMethod([lcDrag],'DoPaintDropMark');{$endif}
end;
//----------------------------------------------------------------------------------------------------------------------
procedure TBaseVirtualTree.DoPaintNode(var PaintInfo: TVTPaintInfo);
begin
end;
//----------------------------------------------------------------------------------------------------------------------
procedure TBaseVirtualTree.DoPopupMenu(Node: PVirtualNode; Column: TColumnIndex; const Position: TPoint);
// Support for node dependent popup menus.
var
Menu: TPopupMenu;
begin
Menu := DoGetPopupMenu(Node, Column, Position);
if Assigned(Menu) then
begin
DoStateChange([tsPopupMenuShown]);
KillTimer(Handle, 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: THandle;//HDWP;
I: Integer;
P: TPoint;
R: TRect;
begin
{$ifdef DEBUG_VTV}Logger.EnterMethod([lcScroll],'DoSetOffsetXY');{$endif}
{$ifdef DEBUG_VTV}Logger.Send([lcScroll],'Value',Value);{$endif}
//{$ifdef DEBUG_VTV}Logger.SendCallStack([lcScroll],'CallStack');{$endif}
// 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;
{$ifdef DEBUG_VTV}Logger.Send([lcScroll],'FOffsetX: %d FOffsetY: %d',[FOffsetX,FOffsetY]);{$endif}
{$ifdef DEBUG_VTV}Logger.Send([lcScroll],'DeltaX: %d DeltaY: %d',[DeltaX,DeltaY]);{$endif}
Result := (DeltaX <> 0) or (DeltaY <> 0);
if Result then
begin
FOffsetX := Value.X;
FOffsetY := Value.Y;
if tsHint in Self.FStates then
Application.CancelHint;
if FUpdateCount = 0 then
begin
// The drag image from VCL controls need special consideration.
{$ifndef INCOMPLETE_WINAPI}
if tsVCLDragging in FStates then
ImageList_DragShowNolock(False);
{$endif}
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
//todo: reimplement
{$ifndef INCOMPLETE_WINAPI}
// 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);
{$endif}
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;
//lclheader
if hoVisible in FHeader.FOptions then
begin
Inc(R.Top,FHeader.Height);
Inc(R.Bottom,FHeader.Height);
end;
//scrollwindow implementation under gtk is broken
{$ifdef Gtk}
InvalidateRect(Handle, nil, True);
{$else}
ScrollWindow(Handle, DeltaX, 0, @R, @R);
if DeltaY <> 0 then
ScrollWindow(Handle, 0, DeltaY, @R, @R);
{$endif}
end
else
begin
//lclheader
if ClipRect <> nil then
begin
{$ifdef DEBUG_VTV}Logger.SendWarning([lcWarning], 'DoSetOffsetXY called with a non nil ClipRect');{$endif}
R := ClipRect^;
end
else
R := ClientRect;
if hoVisible in FHeader.FOptions then
begin
Inc(R.Top, FHeader.Height);
Inc(R.Bottom, FHeader.Height);
end;
{$ifdef DEBUG_VTV}Logger.Send([lcScroll], 'Rect to Scroll', R);{$endif}
//todo: temporary hack to avoid some drawing problems.
//Will be removed when scrollwindowex is properly implemented in all widgets
{$ifdef LCLQt}
ScrollWindow(Handle, DeltaX, DeltaY, @R, @R);
{$else}
{$ifdef Gtk}
InvalidateRect(Handle, nil, True);
{$else}
ScrollWindowEx(Handle, DeltaX, DeltaY, @R, @R,0, nil, SW_INVALIDATE or SW_SCROLLCHILDREN);
{$endif}
{$endif}
end;
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 [ssHorizontal, 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 [ssHorizontal, ssBoth]) then
UpdateHorizontalScrollBar(suoRepaintScrollBars in Options);
end;
end;
{$ifndef INCOMPLETE_WINAPI}
if tsVCLDragging in FStates then
ImageList_DragShowNolock(True);
{$endif}
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;
{$ifdef DEBUG_VTV}Logger.ExitMethod([lcScroll],'DoSetOffsetXY');{$endif}
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
{$ifdef DEBUG_VTV}Logger.EnterMethod([lcDrag],'DoStartDrag');{$endif}
{$ifdef DEBUG_VTV}Logger.SendCallStack([lcDrag],'Stack');{$endif}
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]);
{$ifdef DEBUG_VTV}Logger.ExitMethod([lcDrag],'DoStartDrag');{$endif}
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
if HandleAllocated then
KillTimer(Handle, 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);
//lclheader
R := inherited GetClientRect;
ClipRect := R;
{$ifndef INCOMPLETE_WINAPI}
MapWindowPoints(Handle, 0, R, 2);
{$endif}
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 VTVDragManager.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
KillTimer(Handle, 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: LongWord;
DataObject: IDataObject; var DragEffect: LongWord);
begin
{$ifdef Windows}
//lcl
//todo
{
if IsWinVistaOrAbove then begin
SHDoDragDrop(Self.Handle, DataObject, nil, AllowedEffects, DragEffect); // supports drag hints on Windows Vista and later
end
else
}
ActiveX.DoDragDrop(DataObject, VTVDragManager as IDropSource, AllowedEffects, @DragEffect);
{$endif}
end;
//----------------------------------------------------------------------------------------------------------------------
procedure TBaseVirtualTree.DragCanceled;
// Does some housekeeping for VCL drag'n drop;
begin
inherited;
DragFinished;
end;
//----------------------------------------------------------------------------------------------------------------------
function TBaseVirtualTree.DragDrop(const DataObject: IDataObject; KeyState: LongWord; Pt: TPoint;
var Effect: LongWord): HResult;
var
Shift: TShiftState;
EnumFormat: IEnumFormatEtc;
Fetched: LongWord;
OLEFormat: TFormatEtc;
Formats: TFormatArray;
begin
{$ifdef DEBUG_VTV}Logger.EnterMethod([lcDrag],'DragDrop');{$endif}
KillTimer(Handle, ExpandTimer);
KillTimer(Handle, 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(VTVDragManager.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(VTVDragManager.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;
{$ifdef DEBUG_VTV}Logger.ExitMethod([lcDrag],'DragDrop');{$endif}
end;
//----------------------------------------------------------------------------------------------------------------------
function TBaseVirtualTree.DragEnter(KeyState: LongWord; Pt: TPoint; var Effect: LongWord): HResult;
// callback routine for the drop target interface
var
Shift: TShiftState;
Accept: Boolean;
R: TRect;
HitInfo: THitInfo;
begin
{$ifdef DEBUG_VTV}Logger.EnterMethod([lcDrag],'DragEnter');{$endif}
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(VTVDragManager.DragSource, Shift, Pt, Effect);
Accept := DoDragOver(VTVDragManager.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 VTVDragManager.DropTargetHelperSupported and Assigned(VTVDragManager.DragSource) then
TBaseVirtualTree(VTVDragManager.DragSource).FDragImage.ShowDragImage;
Result := NOERROR;
except
Result := E_UNEXPECTED;
end;
{$ifdef DEBUG_VTV}Logger.ExitMethod([lcDrag],'DragEnter');{$endif}
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
{$ifdef DEBUG_VTV}Logger.EnterMethod([lcDrag],'DragFinished');{$endif}
if [tsOLEDragging, tsVCLDragPending, tsVCLDragging, tsVCLDragFinished] * FStates = [] then
Exit;
DoStateChange([], [tsVCLDragPending, tsVCLDragging, tsUserDragObject, tsVCLDragFinished]);
GetCursorPos(P);
P := ScreenToClient(P);
if tsRightButtonDown in FStates then
Perform(LM_RBUTTONUP, 0, LPARAM(Cardinal(PointToSmallPoint(P))))
else
if tsMiddleButtonDown in FStates then
Perform(LM_MBUTTONUP, 0, LPARAM(Cardinal(PointToSmallPoint(P))))
else
Perform(LM_LBUTTONUP, 0, LPARAM(Cardinal(PointToSmallPoint(P))));
{$ifdef DEBUG_VTV}Logger.ExitMethod([lcDrag],'DragFinished');{$endif}
end;
//----------------------------------------------------------------------------------------------------------------------
procedure TBaseVirtualTree.DragLeave;
var
Effect: LongWord;
begin
KillTimer(Handle, ExpandTimer);
if not VTVDragManager.DropTargetHelperSupported and Assigned(VTVDragManager.DragSource) then
TBaseVirtualTree(VTVDragManager.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: LongWord; DragState: TDragState; Pt: TPoint;
var Effect: LongWord): 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
//{$ifdef DEBUG_VTV}Logger.EnterMethod([lcDrag],'DragOver');{$endif}
//todo: the check to FDragManager disable drag images in non windows.
//This should be reviewed as soon as drag image is implemented in non windows
if Assigned(FDragManager) and not VTVDragManager.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);
//{$ifdef DEBUG_VTV}Logger.Send([lcDrag],'Pt',Pt);{$endif}
// 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
KillTimer(Handle, 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 LongWord(DROPEFFECT_SCROLL);
Result := NOERROR;
except
Result := E_UNEXPECTED;
end;
//{$ifdef DEBUG_VTV}Logger.ExitMethod([lcDrag],'DragOver');{$endif}
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);
LCLIntf.FillRect(Handle, R, FDottedBrush);
end;
end;
//----------------------------------------------------------------------------------------------------------------------
procedure TBaseVirtualTree.DrawDottedVLine(const PaintInfo: TVTPaintInfo; Top, Bottom, Left: Integer; UseSelectedBkColor: Boolean = False);
// Draws a vertical 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);
LCLIntf.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: PtrInt;
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;
//----------------------------------------------------------------------------------------------------------------------
//lcl
//todo: implement GetCheckImageListFor or change the part where is called
class function TBaseVirtualTree.GetCheckImageListFor(Kind: TCheckImageKind): TCustomImageList;
begin
case Kind of
ckDarkCheck:
Result := GetCheckImageList(DarkCheckImages, ckDarkCheck);
ckLightTick:
Result := GetCheckImageList(LightTickImages, ckLightTick);
ckDarkTick:
Result := GetCheckImageList(DarkTickImages, ckDarkTick);
ckLightCheck:
Result := GetCheckImageList(LightCheckImages, ckLightCheck);
ckFlat:
Result := GetCheckImageList(FlatImages, ckFlat);
ckXP:
Result := GetCheckImageList(XPImages, ckXP);
ckSystemDefault:
Result := GetCheckImageList(SystemCheckImages, ckSystemDefault);
ckSystemFlat:
Result := GetCheckImageList(SystemFlatCheckImages, ckSystemFlat);
else
Result := nil;
end;
end;
//----------------------------------------------------------------------------------------------------------------------
function TBaseVirtualTree.GetClientRect: TRect;
begin
Result := inherited;
//lclheader
if HandleAllocated and (hoVisible in FHeader.FOptions) then
Dec(Result.Bottom, FHeader.Height);
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 := InternalGetNodeAt(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]);
//lclheader: Height -> ClientHeight
if TopPosition > ClientHeight 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: Boolean;
begin
Result := FOperationCanceled and (FOperationCount > 0);
end;
//----------------------------------------------------------------------------------------------------------------------
function TBaseVirtualTree.GetOptionsClass: TTreeOptionsClass;
begin
Result := TCustomVirtualTreeOptions;
end;
//----------------------------------------------------------------------------------------------------------------------
{$i olemethods.inc}
//----------------------------------------------------------------------------------------------------------------------
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: String;
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;
//---------------------------------------------------------------------------
//todo: reimplement
{$ifndef INCOMPLETE_WINAPI}
function CodePageFromLocale(Language: DWord): 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
MultiByteToWideChar(CodePageFromLocale(GetKeyboardLayout(0) and $FFFF),
MB_USEGLYPHCHARS, @C, 1, @Result, 1);
end;
{$endif}
//--------------- end local functions ---------------------------------------
var
FoundMatch: Boolean;
NewChar: WideChar;
begin
//todo: handle correctly unicode char after WideString -> String conversion
KillTimer(Handle, 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.
//todo: reimplement
{$ifndef INCOMPLETE_WINAPI}
NewChar := KeyUnicode(Char(CharCode));
{$else}
NewChar := Char(CharCode);
{$endif}
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: TLMMouse; 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
KillTimer(Handle, 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: TLMMouse; 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;
FocusCanChange: Boolean;
begin
if [tsWheelPanning, tsWheelScrolling] * FStates <> [] then
begin
StopWheelPanning;
Exit;
end;
if tsEditPending in FStates then
begin
KillTimer(Handle, 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
LCLIntf.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, ssCtrlOS, 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);
//lclheader
if hoVisible in FHeader.Options then
OffsetRect(FNewSelRect, 0, -FHeader.Height);
{$ifdef DEBUG_VTV}Logger.Send([lcSelection],'FNewSelRect', FNewSelRect);{$endif}
FLastSelRect := Rect(0, 0, 0, 0);
end;
//lcl
FocusCanChange := DoFocusChanging(FFocusedNode, HitInfo.HitNode, FFocusedColumn, Column);
if not FSelectionLocked and FocusCanChange 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
KillTimer(Handle, 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(Keys: PtrUInt; 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]);
KillTimer(Handle, 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(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; const 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;
//----------------------------------------------------------------------------------------------------------------------
function TBaseVirtualTree.InternalGetNodeAt(X, Y: Integer): PVirtualNode;
var
Dummy: Integer;
begin
Result := InternalGetNodeAt(X, Y, True, Dummy);
end;
//----------------------------------------------------------------------------------------------------------------------
function TBaseVirtualTree.InternalGetNodeAt(X, Y: Integer; Relative: Boolean; var NodeTop: Integer): PVirtualNode;
//lclheader this is the original version of GetNodeAt used internally since expects coordinates
// relative to the image tree. In LCL the image tree and control coordinates are different
// when header is visible
// This method returns the node that occupies the specified point, or nil if there's none.
// If Relative 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);
//{$ifdef DEBUG_VTV}Logger.Send([lcPaintHeader],'GetNodeAt Result: ',Result^.Index);{$endif}
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, VTVDragManager as IDropTarget);
{$ifdef VCLStyleSupport}
FSavedBorderWidth := BorderWidth;
FSavedBevelKind := BevelKind;
VclStyleChanged;
{$IFEND}
// 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;
//lclheader
//AdjustAutoSize is called inside CreateWnd. Don't call here
//Keep the commented code until we get sure of not being necessary
//if hoAutoResize in FHeader.FOptions then
// FHeader.FColumns.AdjustAutoSize(InvalidColumn, True);
finally
Updated;
end;
end;
//----------------------------------------------------------------------------------------------------------------------
procedure TBaseVirtualTree.MainColumnChanged;
begin
DoCancelEdit;
{$ifdef EnableAccessible}
NotifyWinEvent(EVENT_OBJECT_NAMECHANGE, Handle, OBJID_CLIENT, CHILDID_SELF);
{$endif}
end;
//----------------------------------------------------------------------------------------------------------------------
procedure TBaseVirtualTree.MouseMove(Shift: TShiftState; X, Y: Integer);
var
R: TRect;
NewCursor: TCursor;
HitInfo: THitInfo;
P: TPoint;
Node: PVirtualNode;
begin
// lcl: Adjust cursor
if ([tsWheelPanning, tsWheelScrolling] * FStates = []) then
begin
// Apply own cursors only if there is no global cursor set.
if Screen.Cursor = crDefault 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) and (toHotTrack in FOptions.PaintOptions) and Assigned(FCurrentHotNode) then
NewCursor := FHotCursor;
DoGetCursor(NewCursor);
Cursor := NewCursor;
end;
end;
if tsNodeHeightTrackPending in FStates then
begin
// Remove hint if shown currently.
Application.CancelHint;
// Stop wheel panning if active.
StopWheelPanning;
// Stop timers
KillTimer(Handle, ExpandTimer);
KillTimer(Handle, EditTimer);
KillTimer(Handle, ScrollTimer);
KillTimer(Handle, 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
//lclheader
R := FNewSelRect;
if hoVisible in FHeader.Options then
OffsetRect(R, 0, FHeader.Height);
InvalidateRect(Handle, @R, False);
UpdateWindow(Handle);
if (Abs(FNewSelRect.Right - FNewSelRect.Left) > DragManager.DragThreshold) or
(Abs(FNewSelRect.Bottom - FNewSelRect.Top) > DragManager.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) >= DragManager.DragThreshold) or (Abs(FLastClickPos.Y - Y) >= DragManager.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);
if hoVisible in FHeader.Options then
OffsetRect(R, 0, FHeader.Height);
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;
//----------------------------------------------------------------------------------------------------------------------
{$ifdef EnableNCFunctions}
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;
{$endif}
//----------------------------------------------------------------------------------------------------------------------
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
{$ifdef DEBUG_VTV}Logger.EnterMethod([lcPaint],'Paint');{$endif}
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;
{$ifdef DEBUG_VTV}Logger.Send([lcHeaderOffset], 'FUpdateRect', FUpdateRect);{$endif}
Target := Window.TopLeft;
//lclheader
if hoVisible in FHeader.FOptions then
begin
if Target.Y < FHeader.Height then
begin
Window.Top := 0;
Target.Y := FHeader.Height;
end
else
begin
Dec(Window.Top, FHeader.Height);
end;
Dec(Window.Bottom, FHeader.Height);
if RectVisible(Canvas.Handle, FHeaderRect) then
begin
{$ifdef DEBUG_VTV}Logger.Send([lcPaintHeader],'RectVisible = True');{$endif}
FHeader.FColumns.PaintHeader(Canvas.Handle, FHeaderRect, -FEffectiveOffsetX);
end;
with FHeaderRect do
ExcludeClipRect(Canvas.Handle, Left, Top, Right, Bottom);
end;
// The clipping rectangle is given in client coordinates of the window. We have to convert it into
// a sliding window of the tree image.
{$ifdef DEBUG_VTV}Logger.Send([lcPaintDetails],'FEffectiveOffsetX: %d, RTLOffset: %d, OffsetY: %d',[FEffectiveOffsetX,RTLOffset,FOffsetY]);{$endif}
OffsetRect(Window, FEffectiveOffsetX - RTLOffset, -FOffsetY);
//{$ifdef DEBUG_VTV}Logger.Active:=Logger.CalledBy('DoDragging');{$endif}
PaintTree(Canvas, Window, Target, Options);
//{$ifdef DEBUG_VTV}Logger.Active:=True;{$endif}
end
else
begin
{$ifdef DEBUG_VTV}Logger.Send([lcPaint],'VisibleFixedWidth > 0');{$endif}
// First part, fixed columns
Window := ClientRect;
Window.Right := Temp;
Target := Window.TopLeft;
//lclheader
if hoVisible in FHeader.FOptions then
begin
//Target is always (0,0) due to call to ClientRect, so no need set Top to 0
//also no need to decrease bottom because ClientRect already computes header
Inc(Target.Y, FHeader.Height);
if RectVisible(Canvas.Handle, FHeaderRect) then
begin
{$ifdef DEBUG_VTV}Logger.Send([lcPaintHeader], 'RectVisible = True');{$endif}
FHeader.FColumns.PaintHeader(Canvas.Handle, FHeaderRect, -FEffectiveOffsetX);
end;
with FHeaderRect do
ExcludeClipRect(Canvas.Handle,Left,Top,Right,Bottom);
end;
OffsetRect(Window, -RTLOffset, -FOffsetY);
PaintTree(Canvas, Window, Target, Options);
// Second part, other columns
Window := GetClientRect;
if Temp > Window.Right then
begin
{$ifdef DEBUG_VTV}Logger.ExitMethod([lcPaint],'Paint');{$endif}
Exit;
end;
Window.Left := Temp;
Target := Window.TopLeft;
//lclheader
if hoVisible in FHeader.FOptions then
Inc(Target.Y, FHeader.Height);
{$ifdef DEBUG_VTV}Logger.Send([lcDrag],'FEffectiveOffsetX: %d, RTLOffset: %d, OffsetY: %d',[FEffectiveOffsetX,RTLOffset,FOffsetY]);{$endif}
OffsetRect(Window, FEffectiveOffsetX - RTLOffset, -FOffsetY);
PaintTree(Canvas, Window, Target, Options);
end;
end;
{$ifdef DEBUG_VTV}Logger.ExitMethod([lcPaint],'Paint');{$endif}
end;
//----------------------------------------------------------------------------------------------------------------------
//lcl: implementation of PaintCheckImage differs from Delphi
procedure TBaseVirtualTree.PaintCheckImage(Canvas: TCanvas; const ImageInfo: TVTImageInfo; Selected: Boolean);
procedure DrawCheckButton(Canvas: TCanvas; Index: Integer; const R: TRect; Flat: Boolean);
var
ButtonState: Cardinal;
ButtonType: Cardinal;
begin
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(Canvas.Handle, R, DFC_BUTTON, ButtonType or ButtonState);
end;
var
R: TRect;
{$ifdef ThemeSupport}
Details: TThemedElementDetails;
{$endif}
UseThemes: Boolean;
DrawEffect: TGraphicsDrawEffect;
begin
{$ifdef DEBUG_VTV}Logger.EnterMethod([lcCheck],'PaintCheckImage');{$endif}
with ImageInfo do
begin
UseThemes := (tsUseThemes in FStates) and (FCheckImageKind = ckSystemDefault);
if UseThemes or ((FCheckImageKind in [ckSystemFlat, ckSystemDefault]) and not (Index in [21..24])) then
begin
if UseThemes then
begin
R := Rect(XPos - 1, YPos, XPos + 16, YPos + 16);
Details.Element := teButton;
case Index of
0..8: // radio buttons
begin
Details.Part := BP_RADIOBUTTON;
Details.State := Index;
end;
9..20: // check boxes
begin
Details.Part := BP_CHECKBOX;
Details.State := Index - 8;
end;
21..24: // buttons
begin
Details.Part := BP_PUSHBUTTON;
Details.State := Index - 20;
end;
else
Details.Part := 0;
Details.State := 0;
end;
ThemeServices.DrawElement(Canvas.Handle, Details, R);
{$ifdef USE_DELPHICOMPAT}
if Index in [21..24] then
with UtilityImages do
DirectMaskBlt(Canvas.Handle, XPos - 1, YPos, Height, Height,
Canvas.Handle, 4 * Height, 0, MaskHandle);
{$else}
if Index in [21..24] then
with UtilityImages do
StretchMaskBlt(Canvas.Handle, XPos - 1, YPos, Height, Height,
Canvas.Handle, 4 * Height, 0, Height, Height, MaskHandle, 4 * Height, 0, SRCCOPY);
{$endif}
end
else
begin
R := Rect(XPos + 1, YPos + 1, XPos + 14, YPos + 14);
DrawCheckButton(Canvas, Index - 1, R, FCheckImageKind = ckSystemFlat);
end;
end
else
with FCheckImages do
begin
if not Ghosted then
DrawEffect := gdeNormal
else
DrawEffect := gdeShadowed;
Draw(Canvas, XPos, YPos, Index, DrawEffect);
end;
end;
{$ifdef DEBUG_VTV}Logger.ExitMethod([lcCheck],'PaintCheckImage');{$endif}
end;
//----------------------------------------------------------------------------------------------------------------------
procedure TBaseVirtualTree.PaintImage(var PaintInfo: TVTPaintInfo; ImageInfoIndex: TVTImageInfoIndex; DoOverlay: Boolean);
var
CutNode: Boolean;
PaintFocused: Boolean;
DrawEffect: TGraphicsDrawEffect;
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;
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 (vsDisabled in Node.States) or not Enabled then
DrawEffect := gdeDisabled
else
// 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
DrawEffect := gdeShadowed
else
DrawEffect := gdeNormal;
if (vsSelected in Node.States) and not Ghosted then
Images.BlendColor := clDefault;
Images.Draw(Canvas, XPos, YPos, Index, DrawEffect);
// Now, draw the overlay.
// Delphi version has the ability to use the built in overlay indices of windows system image lists
// Since this is system dependent the LCL version will support only custom overlays
// Note: XPos and YPos are those of the normal images.
if PaintInfo.ImageInfo[iiOverlay].Index >= 0 then
ImageInfo[iiOverlay].Images.Draw(Canvas, XPos, YPos, ImageInfo[iiOverlay].Index);
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
{$ifdef DEBUG_VTV}Logger.EnterMethod([lcPaintDetails],'PaintTreeLines');{$endif}
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
{$ifdef DEBUG_VTV}Logger.Send([lcPaintDetails],'FLineMode = lmBands');{$endif}
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
{$ifdef DEBUG_VTV}Logger.Send([lcPaintDetails],'FLineMode = lmNormal');{$endif}
{$ifdef DEBUG_VTV}Logger.Send([lcPaintDetails],'Brush.Color',PaintInfo.Canvas.Brush.Color);{$endif}
PaintInfo.Canvas.Font.Color := FColors.TreeLineColor;
{$ifdef DEBUG_VTV}Logger.Send([lcPaintDetails],'Brush.Color',PaintInfo.Canvas.Font.Color);{$endif}
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;
{$ifdef DEBUG_VTV}Logger.ExitMethod([lcPaintDetails],'PaintTreeLines');{$endif}
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
{$ifdef DEBUG_VTV}Logger.Send([lcSelection], 'SelectionRect at PaintSelection', SelectionRect);{$endif}
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.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;
{$ifdef ThemeSupport}
//RowRect: TRect;
//Theme: HTHEME;
{$endif ThemeSupport}
//--------------- 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;
//---------------------------------------------------------------------------
//lcl: todo
{
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.Handle, '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
{$ifdef ThemeSupport}
//todo
{
if tsUseExplorerTheme in FStates then
begin
Theme := OpenThemeData(Application.Handle, '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;
}
{$endif ThemeSupport}
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
//todo
{
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
//lcl: Is not necessary to set the style here
//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
{$ifdef ThemeSupport}
//todo
{
if Theme <> 0 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
}
{$endif ThemeSupport}
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;
{$ifdef ThemeSupport}
//todo
{
if (Theme <> 0) 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));
}
{$endif ThemeSupport}
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);
{$ifdef ThemeSupport}
//todo
{
if not (toExtendedFocus in FOptions.FSelectionOptions) and (toFullRowSelect in FOptions.FSelectionOptions) and
(Theme <> 0) then
FocusRect := RowRect
else
}
{$endif ThemeSupport}
if toGridExtensions in FOptions.FMiscOptions then
FocusRect := CellRect
else
FocusRect := InnerRect;
{$ifdef ThemeSupport}
//todo
{
if tsUseExplorerTheme in FStates then
InflateRect(FocusRect, -1, -1);
}
{$endif ThemeSupport}
if (tsUseExplorerTheme in FStates) and IsWinVistaOrAbove then
begin
//Draw focused unselected style like Windows 7 Explorer
//lcl: todo
{
if not (vsSelected in Node.States) then
DrawThemedFocusRect(LIS_NORMAL)
else
DrawBackground(TREIS_HOTSELECTED);
}
end
else
LCLIntf.DrawFocusRect(Handle, FocusRect);
SetTextColor(Handle, TextColorBackup);
SetBkColor(Handle, BackColorBackup);
end;
end;
end;
{$ifdef ThemeSupport}
//todo
{
if Theme <> 0 then
CloseThemeData(Theme);
}
{$endif ThemeSupport}
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).
Stream.Read(ChunkBody, SizeOf(ChunkBody));
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);
//----------------------------------------------------------------------------------------------------------------------
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;
//----------------------------------------------------------------------------------------------------------------------
procedure TBaseVirtualTree.StartWheelPanning(const 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, ImageHeight, ImageWidth: Integer;
Temp: HRGN;
begin
Assert(not FPanningWindow.Image.Empty, 'Invalid wheel panning image.');
ImageWidth := FPanningWindow.Image.Width;
ImageHeight := FPanningWindow.Image.Height;
// Create an initial region on which we operate.
Result := CreateRectRgn(0, 0, 0, 0);
with FPanningWindow.Image.Canvas do
begin
for Y := 0 to ImageHeight - 1 do
begin
Start := -1;
for X := 0 to ImageWidth - 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, ImageWidth, 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
ImageName: string;
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.
KillTimer(Handle, ScrollTimer);
DoStateChange([tsWheelPanning, tsWheelScrolling]);
if FPanningWindow = nil then
begin
FPanningWindow := TVirtualPanningWindow.Create;
LoadPanningCursors;
end;
FPanningWindow.Start(Handle, ClientToScreen(Position));
if Integer(FRangeX) > ClientWidth then
begin
if Integer(FRangeY) > ClientHeight then
ImageName := 'VT_MOVEALL_BMP'
else
ImageName := 'VT_MOVEEW_BMP';
end
else
ImageName := 'VT_MOVENS_BMP';
FPanningWindow.Image.LoadFromResourceName(0, ImageName);
FPanningWindow.Show(CreateClipRegion);
// Setup the panscroll timer and capture all mouse input.
SetFocus;
SetCapture(Handle);
AdjustPanningCursor(Position.X, Position.Y);
SetTimer(Handle, ScrollTimer, 20, nil);
end;
//----------------------------------------------------------------------------------------------------------------------
procedure TBaseVirtualTree.StopWheelPanning;
// Stops panning if currently active and destroys the helper window.
begin
if [tsWheelPanning, tsWheelScrolling] * FStates <> [] then
begin
// Release the mouse capture and stop the panscroll timer.
KillTimer(Handle, ScrollTimer);
ReleaseCapture;
DoStateChange([], [tsWheelPanning, tsWheelScrolling]);
FPanningWindow.Stop;
{$ifndef Windows}
Cursor := crDefault;
{$endif}
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; const Pt: TPoint;
AllowedEffects: LongWord): LongWord;
// 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 ssCtrlOS 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
{$ifdef DEBUG_VTV}Logger.EnterMethod([lcPaintHeader],'UpdateHeaderRect');{$endif}
FHeaderRect := Rect(0, 0, Width, Height);
// Consider borders...
Size := GetBorderDimensions;
//lclheader
//Adjust rect size
Inc(FHeaderRect.Right,Size.cx*2);
// ... and bevels.
OffsetX := BorderWidth;
OffsetY := BorderWidth;
//todo_lcl
{
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;
{$ifdef DEBUG_VTV}Logger.Send([lcPaintHeader],'FHeaderRect',FHeaderRect);{$endif}
{$ifdef DEBUG_VTV}Logger.ExitMethod([lcPaintHeader],'UpdateHeaderRect');{$endif}
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;
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).
{$ifndef INCOMPLETE_WINAPI}
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;
{$endif}
begin
//todo: reimplement
{$ifndef INCOMPLETE_WINAPI}
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;
{$endif}
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;
{$ifdef EnableThreadSupport}
if (tsValidationNeeded in FStates) and (FVisibleCount > CacheThreshold) then
begin
// Tell the thread this tree needs actually something to do.
WorkerThread.AddTree(Self);
WorkEvent.SetEvent;
end;
{$endif}
end;
//----------------------------------------------------------------------------------------------------------------------
procedure TBaseVirtualTree.ValidateNodeDataSize(var Size: Integer);
begin
Size := SizeOf(Pointer);
if Assigned(FOnGetNodeDataSize) then
FOnGetNodeDataSize(Self, Size);
end;
//----------------------------------------------------------------------------------------------------------------------
{$ifdef VCLStyleSupport}
procedure TBaseVirtualTree.VclStyleChanged;
begin
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;
end;
{$endif}
//----------------------------------------------------------------------------------------------------------------------
procedure TBaseVirtualTree.WndProc(var Message: TLMessage);
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 = LM_LBUTTONDOWN) or (Message.Msg = LM_LBUTTONDBLCLK)) then
begin
Handled := (DragMode = dmAutomatic) and (DragKind = dkDrag);
if Handled then
begin
if not IsControlMouseMsg(TLMMouse(Message)) then
begin
//lclheader
//let the header handle the message here
//otherwise no header click event will be fired
if not FHeader.HandleMessage(Message) then
begin
ControlState := ControlState + [csLButtonDown];
Dispatch(Message); // overrides TControl's BeginDrag
end;
end;
end;
end;
if not Handled and Assigned(FHeader) then
Handled := FHeader.HandleMessage(Message);
if not Handled then
inherited;
end;
end;
//----------------------------------------------------------------------------------------------------------------------
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);
//lcl
//Calling UpdateHorizontalScrollBar without a header leads to a
//wrong NodeWidth because the node is not initialized at this time.
//As result the horizontal scrollbar is not correctly
//sized and the node can not be selected by a click.
if HandleAllocated then
UpdateVerticalScrollBar(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;
//todo_lcl
{
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.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.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.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
{$ifdef DEBUG_VTV}Logger.EnterMethod([lcDrag],'BeginDrag');{$endif}
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 := DragManager.DragThreshold
else
FDragThreshold := Threshold;
if Immediate then
DoDragging(FLastClickPos)
else
DoStateChange([tsOLEDragPending]);
end;
{$ifdef DEBUG_VTV}Logger.ExitMethod([lcDrag],'BeginDrag');{$endif}
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...
KillTimer(Handle, ChangeTimer);
KillTimer(Handle, StructureChangeTimer);
KillTimer(Handle, ExpandTimer);
KillTimer(Handle, EditTimer);
KillTimer(Handle, ScrollTimer);
KillTimer(Handle, 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;
//----------------------------------------------------------------------------------------------------------------------
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;
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 := TopNode;
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.DefaultHandler(var AMessage);
begin
//used to avoid default handler of LM_MOUSEWHEEL
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, ToDelete: PVirtualNode;
begin
if tsCutPending in FStates then
begin
Run := FRoot.FirstChild;
while Assigned(Run) do
begin
if vsCutOrCopy in Run.States then
begin
ToDelete := Run;
Run := GetNextNoInit(Run);
DeleteNode(ToDelete);
end
else
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;
//----------------------------------------------------------------------------------------------------------------------
{$ifndef fpc}
function TBaseVirtualTree.GetControlsAlignment: TAlignment;
begin
Result := FAlignment;
end;
{$endif}
//----------------------------------------------------------------------------------------------------------------------
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
//{$ifdef DEBUG_VTV}Logger.EnterMethod([lcPaintHeader],'GetDisplayRect');{$endif}
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;
//lclheader
//todo: add a parameter to decide if the result must be returned as
//a tree offset or a control offset
if hoVisible in FHeader.FOptions then
OffsetRect(Result, 0, FHeader.Height);
//{$ifdef DEBUG_VTV}Logger.Send([lcPaintHeader],'DisplayRect for Node '+IntToStr(Node^.Index),Result);{$endif}
//{$ifdef DEBUG_VTV}Logger.ExitMethod([lcPaintHeader],'GetDisplayRect');{$endif}
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);
//lclheader
if Y < IfThen(hoVisible in FHeader.Options, FHeader.Height) then
Include(HitInfo.HitPositions, hiAbove)
else
if Y > Max(FRangeY, inherited GetClientRect.Bottom) 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);
//lclheader
if hoVisible in FHeader.Options then
Dec(Y, FHeader.Height);
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 := InternalGetNodeAt(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;
var
OffsetByHeader: Boolean;
begin
//lclheader
OffsetByHeader := Relative and (hoVisible in FHeader.Options);
if OffsetByHeader then
Dec(Y, FHeader.Height);
Result := InternalGetNodeAt(X, Y, Relative, NodeTop);
//lclheader
if OffsetByHeader then
Inc(NodeTop, FHeader.Height);
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;
out Text: String);
// 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;
//lclheader
if hoVisible in FHeader.FOptions then
OffsetRect(R, 0, FHeader.Height);
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;
//lclheader
if hoVisible in FHeader.FOptions then
Inc(R.Bottom, FHeader.Height);
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
// LCL port started with tree stream version 2 so no need to do the check here
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; const 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;
{$ifdef ManualClipNeeded}
YCorrect,
{$endif}
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
{$ifdef DEBUG_VTV}Logger.EnterMethod([lcPaint],'PaintTree');{$endif}
{$ifdef DEBUG_VTV}Logger.Send([lcPaint, lcHeaderOffset],'Window',Window);{$endif}
{$ifdef DEBUG_VTV}Logger.Send([lcPaint, lcHeaderOffset],'Target',Target);{$endif}
{$ifdef DEBUG_VTV}Logger.Send([lcPaintHeader],'ClientRect',ClientRect);{$endif}
{$ifdef DEBUG_VTV}Logger.Send([lcPaintHeader],'TreeRect',GetTreeRect);{$endif}
{$ifdef DEBUG_VTV}Logger.Send([lcPaintHeader],'OffsetX: %d OffsetY: %d',[OffsetX,OffsetY]);{$endif}
//lcl changes to 24bit color depth when screen depth is 32 bit
//todo: remove when this limitation is removed
{$ifdef Windows}
if (PixelFormat = pfDevice) and (ScreenInfo.ColorDepth = 32) then
PixelFormat := pf32bit;
{$endif}
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 and lock the back bitmap canvas to avoid that it gets freed on the way.
FillChar(PaintInfo, SizeOf(PaintInfo), 0);
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.
{$ifndef Gtk}
SetMapMode(NodeBitmap.Canvas.Handle, GetMapMode(TargetCanvas.Handle));
{$endif}
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
{$ifdef DEBUG_VTV}Logger.Send([lcPaintDetails],'FNewSelRect', FNewSelRect);{$endif}
// Prepare the current selection rectangle once. The corner points are absolute tree coordinates.
SelectionRect := OrderRect(FNewSelRect);
{$ifdef DEBUG_VTV}Logger.Send([lcPaintDetails, lcSelection],'SelectionRect', SelectionRect);{$endif}
DrawSelectionRect := IsMouseSelecting and not IsRectEmpty(SelectionRect) and (GetKeyState(VK_LBUTTON) < 0);
{$ifdef DEBUG_VTV}Logger.Watch([lcPaintDetails],'DrawSelectionRect',DrawSelectionRect);{$endif}
// 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);
{$ifdef DEBUG_VTV}Logger.Send([lcCheck],'ShowCheckImages',ShowCheckImages);{$endif}
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 := InternalGetNodeAt(0, Window.Top, False, BaseOffset);
if PaintInfo.Node = nil then
BaseOffset := Window.Top;
{$ifdef DEBUG_VTV}Logger.Send([lcPaint, lcHeaderOffset],'BaseOffset',BaseOffset);{$endif}
// Transform selection rectangle into node bitmap coordinates.
if DrawSelectionRect then
OffsetRect(SelectionRect, 0, -BaseOffset);
{$ifdef DEBUG_VTV}Logger.Send([lcSelection], 'SelectionRect fixed by BaseOffset', SelectionRect);{$endif}
// 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);
{$ifdef DEBUG_VTV}Logger.Send([lcPaintHeader, lcHeaderOffset],'MaximumRight: %d MaximumBottom: %d',[MaximumRight,MaximumBottom]);{$endif}
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
{$ifdef DEBUG_VTV}Logger.EnterMethod([lcPaintDetails],'PaintNode');{$endif}
{$ifdef DEBUG_VTV}Logger.Send([lcPaintDetails],'NodeIndex',PaintInfo.Node^.Index);{$endif}
{$ifdef DEBUG_VTV}Logger.Watch([lcPaintDetails],'BaseOffset',BaseOffset);{$endif}
{$ifdef DEBUG_VTV}Logger.Watch([lcPaintDetails],'Brush.Color',PaintInfo.Canvas.Brush.Color);{$endif}
// 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;
{$ifdef DEBUG_VTV}Logger.Send([lcHeaderOffset], 'TargetRect for Node ' + IntToStr(PaintInfo.Node.Index), TargetRect);{$endif}
// 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 := PaintInfo.Node.NodeHeight;
{$ifdef UseSetCanvasOrigin}
SetCanvasOrigin(Canvas, Window.Left, 0);
{$else}
SetWindowOrgEx(Canvas.Handle, Window.Left, 0, nil);
{$endif}
end;
end;
end
else
begin
// Set the origin of the canvas' brush. This depends on the node heights.
//todo: see if is necessary. According to docs is only necessary when HALFTONE is set
{$ifdef UseSetCanvasOrigin}
SetCanvasOrigin(PaintInfo.Canvas, -TargetRect.Left + Window.Left, -TargetRect.Top);
{$else}
SetWindowOrgEx(PaintInfo.Canvas.Handle, -TargetRect.Left + Window.Left, -TargetRect.Top, nil);
{$endif}
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;
{$ifdef DEBUG_VTV}Logger.Watch([lcPaintDetails],'Brush.Color',PaintInfo.Canvas.Brush.Color);{$endif}
// 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));
{$ifdef DEBUG_VTV}Logger.SendBitmap([lcPaintBitmap],'After Clear BackGround',NodeBitmap);{$endif}
{$ifdef DEBUG_VTV}Logger.Watch([lcPaintDetails],'Brush.Color',PaintInfo.Canvas.Brush.Color);{$endif}
// Prepare column, position and node clipping rectangle.
PaintInfo.CellRect := R;
{$ifdef DEBUG_VTV}Logger.Send([lcPaintDetails],'PaintInfo.CellRect',PaintInfo.CellRect);{$endif}
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;
{$ifdef DEBUG_VTV}Logger.Send([lcPaintDetails],
'Column Paint - PaintInfo.Position: %d PaintInfo.Column: %d',[PaintInfo.Position,PaintInfo.Column]);{$endif}
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.Width, FStateImages.Height, 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);
{$ifdef DEBUG_VTV}Logger.Watch([lcPaintDetails],'Brush.Color',PaintInfo.Canvas.Brush.Color);{$endif}
// 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;
{$ifdef DEBUG_VTV}Logger.Watch([lcPaintDetails],'Brush.Color',PaintInfo.Canvas.Brush.Color);{$endif}
if ImageInfo[iiState].Index > -1 then
PaintImage(PaintInfo, iiState, False);
if ImageInfo[iiNormal].Index > -1 then
PaintImage(PaintInfo, iiNormal, True);
{$ifdef DEBUG_VTV}Logger.Watch([lcPaintDetails],'Brush.Color',PaintInfo.Canvas.Brush.Color);{$endif}
// 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);
{$ifdef DEBUG_VTV}Logger.Watch([lcPaintDetails],'Brush.Color',PaintInfo.Canvas.Brush.Color);{$endif}
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;
{$ifdef DEBUG_VTV}Logger.SendBitmap([lcPaintBitmap],'NodeBitmap ' + IntToStr(PaintInfo.Node^.Index), NodeBitmap);{$endif}
{$ifdef DEBUG_VTV}Logger.SendIf([lcPaintDetails, lcHeaderOffset],'TargetRect.Top < Target.Y '+ Logger.RectToStr(TargetRect)
+' '+Logger.PointToStr(Target),TargetRect.Top < Target.Y);{$endif}
{$ifdef Gtk}
//lclheader
// This is a brute force fix AKA hack to prevent the header being cleared
// when the tree is scrolled (YOffset < 0) and the mouse is over the header
// Other widgetsets are not affected because excludecliprect works different (better?)
// this must be removed when/if the paint coordinate is modified to be header aware
YCorrect := 0;
if hoVisible in FHeader.Options then
begin
if TargetRect.Top < FHeader.Height then
YCorrect := FHeader.Height - TargetRect.Top;
end;
{$ifdef DEBUG_VTV}Logger.SendIf([lcPaintDetails],'YCorrect ' + IntToStr(YCorrect), YCorrect > 0);{$endif}
{$endif}
// 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 {$ifdef ManualClipNeeded} + YCorrect{$endif}, Width, Height, Canvas.Handle, Window.Left,
{$ifdef ManualClipNeeded}YCorrect{$else}0{$endif}, SRCCOPY);
end;
end;
Inc(TargetRect.Top, PaintInfo.Node.NodeHeight);
{$ifdef DEBUG_VTV}Logger.SendIf([lcPaintHeader,lcDrag],'Last Node to be painted: '+ IntToStr(PaintInfo.Node^.Index)
+' (TargetRect.Top >= MaximumBottom)',TargetRect.Top >= MaximumBottom);{$endif}
if TargetRect.Top >= MaximumBottom then
begin
{$ifdef DEBUG_VTV}Logger.ExitMethod([lcPaintDetails],'PaintNode');{$endif}
Break;
end;
// 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);
{$ifdef DEBUG_VTV}Logger.ExitMethod([lcPaintDetails],'PaintNode');{$endif}
end;
end;
// Erase rest of window not covered by a node.
if TargetRect.Top < MaximumBottom then
begin
{$ifdef DEBUG_VTV}Logger.Watch([lcPaintDetails],'UseBackground',UseBackground);{$endif}
{$ifdef DEBUG_VTV}Logger.Watch([lcPaintDetails],'UseColumns',UseColumns);{$endif}
// 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);
{$ifdef DEBUG_VTV}Logger.Send([lcPaintDetails],'NodeBitmap.Handle',NodeBitmap.Handle);{$endif}
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;
{$ifdef DEBUG_VTV}Logger.Send([lcPaintDetails],'NodeBitmap.Handle after changing height to background',NodeBitmap.Handle);{$endif}
{$ifdef DEBUG_VTV}Logger.Send([lcPaintDetails],'TargetRect',TargetRect);{$endif}
{$ifdef DEBUG_VTV}Logger.Send([lcPaintDetails],'NodeBitmap Width: %d Height: %d',[NodeBitmap.Width,NodeBitmap.Height]);{$endif}
// Call back application/descendants whether they want to erase this area.
if not DoPaintBackground(PaintInfo.Canvas, TargetRect) then
begin
if UseBackground then
begin
{$ifdef UseSetCanvasOrigin}
SetCanvasOrigin(PaintInfo.Canvas, 0, 0);
{$else}
SetWindowOrgEx(PaintInfo.Canvas.Handle, 0, 0, nil);
{$endif}
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.
{$ifdef UseSetCanvasOrigin}
SetCanvasOrigin(PaintInfo.Canvas, Target.X, 0); // This line caused issue #313 when it was placed above the if-statement
{$else}
SetWindowOrgEx(PaintInfo.Canvas.Handle, Target.X, 0, nil);
{$endif}
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;
{$ifdef UseSetCanvasOrigin}
SetCanvasOrigin(PaintInfo.Canvas, 0, 0);
{$else}
SetWindowOrgEx(PaintInfo.Canvas.Handle, 0, 0, nil);
{$endif}
end
else
begin
{$ifdef DEBUG_VTV}Logger.Send([lcPaintDetails],'ErasingBackGround');{$endif}
{$ifdef DEBUG_VTV}Logger.Send([lcPaintDetails],'TargetRect',TargetRect);{$endif}
// No columns nor bitmap background. Simply erase it with the tree color.
{$ifdef UseSetCanvasOrigin}
SetCanvasOrigin(PaintInfo.Canvas, 0, 0);
{$else}
SetWindowOrgEx(PaintInfo.Canvas.Handle, 0, 0, nil);
{$endif}
PaintInfo.Canvas.Brush.Color := FColors.BackGroundColor;
PaintInfo.Canvas.FillRect(TargetRect);
end;
end;
end;
{$ifdef UseSetCanvasOrigin}
SetCanvasOrigin(PaintInfo.Canvas, 0, 0);
{$else}
SetWindowOrgEx(PaintInfo.Canvas.Handle, 0, 0, nil);
{$endif}
{$ifdef DEBUG_VTV}Logger.Watch([lcPaintDetails],'DrawSelectionRect',DrawSelectionRect);{$endif}
if DrawSelectionRect then
begin
R := OrderRect(FNewSelRect);
//lclheader
if hoVisible in FHeader.Options then
OffsetRect(R, 0, FHeader.Height);
// 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);
//todo: see if is necessary
{$ifndef INCOMPLETE_WINAPI}
SetBrushOrigin(PaintInfo.Canvas, 0, Target.X and 1);
{$endif}
PaintSelectionRectangle(PaintInfo.Canvas, 0, R, TargetRect);
end;
{$ifdef DEBUG_VTV}Logger.Send([lcPaintDetails],'NodeBitmap.Canvas.Height',NodeBitmap.Canvas.Height);{$endif}
{$ifdef DEBUG_VTV}Logger.Send([lcPaintDetails],'NodeBitmap.Canvas.ClipRect',NodeBitmap.Canvas.ClipRect);{$endif}
{$ifdef DEBUG_VTV}Logger.Send([lcPaintDetails],'Target',Target);{$endif}
{$ifdef DEBUG_VTV}Logger.SendBitmap([lcPaintBitmap],'BackGroundBitmap',NodeBitmap);{$endif}
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;
//lcl: LCL has no support for tfNoClip, tfLeft
//TargetCanvas.TextRect(R, FEmptyListMessage, [tfNoClip, tfLeft]);
TextOut(TargetCanvas.Handle, 2 - Window.Left, 2 - Window.Top, PAnsiChar(FEmptyListMessage), Length(FEmptyListMessage));
end;
DoAfterPaint(TargetCanvas);
finally
DoStateChange([], [tsPainting]);
end;
end;
{$ifdef DEBUG_VTV}Logger.ExitMethod([lcPaint],'PaintTree');{$endif}
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
//lclheader
if hoVisible in FHeader.Options then
OffsetRect(PaintRect, 0, -FHeader.Height);
if Left < 0 then
begin
PaintTarget.X := -Left;
PaintRect.Left := 0;
end
else
PaintTarget.X := 0;
if Top < 0 then
begin
PaintTarget.Y := -PaintRect.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;
//----------------------------------------------------------------------------------------------------------------------
{$ifdef EnablePrint}
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;
{$endif}
//----------------------------------------------------------------------------------------------------------------------
function TBaseVirtualTree.ProcessDrop(DataObject: IDataObject; TargetNode: PVirtualNode; var Effect: LongWord;
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;
//----------------- 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;
//----------------------------------------------------------------------------------------------------------------------
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
//todo: minimize calls to ClientHeight and ClientWidth
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
//lclheader
if hoVisible in FHeader.FOptions then
OffsetRect(R, 0, -FHeader.Height);
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 [ssBoth, 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);
end;
Result := ScrolledVertically or ScrolledHorizontally;
end;
//----------------------------------------------------------------------------------------------------------------------
function TBaseVirtualTree.ScrollIntoView(Column: TColumnIndex; Center: Boolean): 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;
begin
Result := False;
if not FHeader.UseColumns then
Exit;
if not FHeader.Columns.IsValidColumn(Column) then
Exit; // Just in case.
ColumnLeft := Header.Columns.Items[Column].Left;
ColumnRight := ColumnLeft + Header.Columns.Items[Column].Width;
NewOffset := FEffectiveOffsetX;
if Center then
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
else if not (coFixed in Header.Columns[Column].Options) 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
Result := True;
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
KillTimer(Handle, 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);
//lcl: setting Color to Brush seems not necessary
//Self.Brush.Color := FColors.BackGroundColor;;
Brush := Self.Brush.Reference.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 [ssHorizontal, ssBoth] then
begin
FillChar(ScrollInfo, SizeOf(ScrollInfo), 0);
//LCL automatically set cbSize field
//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);
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;
{$ifdef DEBUG_VTV}Logger.Send([lcPaintDetails],'FEffectiveOffsetX after UpdateHScrollbar',FEffectiveOffsetX);{$endif}
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
//LCL automatically set cbSize field
//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);
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;
//----------------------------------------------------------------------------------------------------------------------
//lcl: the current implementation in TControl is exactly equal to this.
// disable for now and reenable in the case the TControl implementation change
{
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 TCustomStringTreeOptions(Dest) 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: TLMessage);
begin
AutoAdjustSize;
end;
//----------------------------------------------------------------------------------------------------------------------
procedure TVTEdit.CMExit(var Message: TLMessage);
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.CNCommand(var Message: TLMCommand);
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.DoRelease(Data: PtrInt);
begin
Free;
end;
//----------------------------------------------------------------------------------------------------------------------
procedure TVTEdit.WMChar(var Message: TLMChar);
begin
if not (Message.CharCode in [VK_ESCAPE, VK_TAB]) then
inherited;
end;
//----------------------------------------------------------------------------------------------------------------------
procedure TVTEdit.WMDestroy(var Message: TLMDestroy);
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: TLMNoParams);
begin
inherited;
Message.Result := Message.Result or DLGC_WANTALLKEYS or DLGC_WANTTAB or DLGC_WANTARROWS;
end;
//----------------------------------------------------------------------------------------------------------------------
procedure TVTEdit.WMKeyDown(var Message: TLMKeyDown);
// 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] = KeyDataToShiftState(Message.KeyData) {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
DC := GetDC(Handle);
LastFont := SelectObject(DC, Font.Reference.Handle);
try
// Read needed space for the current text.
GetTextExtentPoint32(DC, PChar(Text), Length(Text), Size);
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);
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
//todo: delphi uses Multiline for all
//Style := Style or ES_MULTILINE;
if vsMultiline in FLink.FNode.States then
begin
Style := Style and not (ES_AUTOHSCROLL or WS_HSCROLL) or WS_VSCROLL or ES_AUTOVSCROLL;
Style := Style or ES_MULTILINE;
end;
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
Application.QueueAsyncCall(DoRelease, 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: String;
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.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: TLMessage);
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;
if (Owner = nil) or (([csReading, csDesigning] * Owner.ComponentState) = [csDesigning]) then
FDefaultText := 'Node';
FInternalDataOffset := AllocateInternalDataArea(SizeOf(Cardinal));
end;
//----------------------------------------------------------------------------------------------------------------------
procedure TCustomVirtualStringTree.GetRenderStartValues(Source: TVSTTextSourceType; out Node: PVirtualNode;
out 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): String;
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): String;
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): String;
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;
if Canvas.Font.Color = clDefault then
Canvas.Font.Color := clWindowText;
end;
end;
//----------------------------------------------------------------------------------------------------------------------
procedure TCustomVirtualStringTree.PaintNormalText(var PaintInfo: TVTPaintInfo; TextOutFlags: Integer;
Text: String);
// 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
{$ifdef DEBUG_VTV}Logger.EnterMethod([lcPaintDetails],'PaintNormalText') ;{$endif}
InitializeTextProperties(PaintInfo);
with PaintInfo do
begin
R := ContentRect;
//todo_lcl See how TextStyle should be set
//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.
GetTextExtentPoint32(Canvas.Handle, PChar(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;
//todo_lcl_check
if not Canvas.TextStyle.Opaque then
SetBkMode(Canvas.Handle, TRANSPARENT)
else
SetBkMode(Canvas.Handle, OPAQUE);
{$ifdef DEBUG_VTV}Logger.Send([lcPaintDetails],'Canvas.Brush.Color',Canvas.Brush.Color);{$endif}
DoTextDrawing(PaintInfo, Text, R, DrawFormat);
end;
{$ifdef DEBUG_VTV}Logger.ExitMethod([lcPaintDetails],'PaintNormalText');{$endif}
end;
//----------------------------------------------------------------------------------------------------------------------
procedure TCustomVirtualStringTree.PaintStaticText(const PaintInfo: TVTPaintInfo; TextOutFlags: Integer;
const Text: String);
// This method retrives and draws the static text bound to a particular node.
var
R: TRect;
DrawFormat: Cardinal;
begin
{$ifdef DEBUG_VTV}Logger.EnterMethod([lcPaintDetails],'PaintStaticText');{$endif}
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;
//todo_lcl See how Canvas.TextStyle should be
//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);
//todo_lcl_check
if not Canvas.TextStyle.Opaque then
SetBkMode(Canvas.Handle, TRANSPARENT)
else
SetBkMode(Canvas.Handle, OPAQUE);
DrawText(Canvas.Handle, PChar(Text), Length(Text), R, DrawFormat)
end;
{$ifdef DEBUG_VTV}Logger.ExitMethod([lcPaintDetails],'PaintStaticText');{$endif}
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: String);
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: String);
begin
DoNewText(Node, Column, Value);
InvalidateNode(Node);
end;
//----------------------------------------------------------------------------------------------------------------------
//----------------------------------------------------------------------------------------------------------------------
procedure TCustomVirtualStringTree.CMFontChanged(var Msg: TLMessage);
// 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, Font.Reference.Handle);
GetTextMetrics(MemDC, TM);
FTextHeight := TM.tmHeight;
GetTextExtentPoint32(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: String;
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; out 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;
const Text: String): 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;
const Text: String): 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;
//----------------------------------------------------------------------------------------------------------------------
{$ifndef LCLWin32}
procedure TCustomVirtualStringTree.CopyToClipBoard;
begin
if FSelectionCount > 0 then
begin
MarkCutCopyNodes;
DoStateChange([tsCopyPending]);
Clipboard.AsText := ContentToUTF8(tstCutCopySet, #9);
DoStateChange([], [tsCopyPending]);
end;
end;
//----------------------------------------------------------------------------------------------------------------------
procedure TCustomVirtualStringTree.CutToClipBoard;
begin
//todo: currently there's no way in LCL to know when the clipboard was used
CopyToClipBoard;
end;
{$endif}
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): String;
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): String;
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: String);
begin
if Assigned(FOnGetText) then
FOnGetText(Self, Node, Column, TextType, Text);
end;
//----------------------------------------------------------------------------------------------------------------------
function TCustomVirtualStringTree.DoIncrementalSearch(Node: PVirtualNode; const Text: String): 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; const Text: String);
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: String;
TextOutFlags: Integer;
begin
{$ifdef DEBUG_VTV}Logger.EnterMethod([lcPaintDetails],'TCustomVirtualStringTree.DoPaintNode');{$endif}
// 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;
{$ifdef DEBUG_VTV}Logger.ExitMethod([lcPaintDetails],'TCustomVirtualStringTree.DoPaintNode');{$endif}
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: String; Width: Integer; EllipsisWidth: Integer = 0): String;
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; const Text: String; 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
DrawText(PaintInfo.Canvas.Handle, PChar(Text), Length(Text), CellRect, DrawFormat);
end;
//----------------------------------------------------------------------------------------------------------------------
function TCustomVirtualStringTree.DoTextMeasuring(Canvas: TCanvas; Node: PVirtualNode; Column: TColumnIndex;
const Text: String): TSize;
var
R: TRect;
DrawFormat: Integer;
begin
GetTextExtentPoint32(Canvas.Handle, PChar(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);
DrawText(Canvas.Handle, PChar(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: String;
begin
case ChunkType of
CaptionChunk:
begin
NewText := '';
if ChunkSize > 0 then
begin
SetLength(NewText, ChunkSize);
Stream.Read(PChar(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;
//----------------------------------------------------------------------------------------------------------------------
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.PunkForRelease := 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: String;
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 := Length(S);
if Len > 0 then
begin
// Write a new sub chunk.
Header.ChunkType := CaptionChunk;
Header.ChunkSize := Len;
Write(Header, SizeOf(Header));
Write(PChar(S)^, Len);
end;
end;
end;
//----------------------------------------------------------------------------------------------------------------------
function TCustomVirtualStringTree.ComputeNodeHeight(Canvas: TCanvas; Node: PVirtualNode; Column: TColumnIndex;
S: String): 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;
DrawText(Canvas.Handle, PChar(S), Length(S), PaintInfo.CellRect, DrawFormat);
Result := PaintInfo.CellRect.Bottom - PaintInfo.CellRect.Top;
if toShowHorzGridLines in TreeOptions.PaintOptions then
Inc(Result);
end;
//----------------------------------------------------------------------------------------------------------------------
function TCustomVirtualStringTree.ContentToHTML(Source: TVSTTextSourceType; const Caption: String = ''): String;
// 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??emeier.
var
Buffer: TBufferedUTF8String;
//---------------------------------------------------------------------------
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(const 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: String;
Save, Run: PVirtualNode;
GetNextNode: TGetNextNodeProc;
Text: String;
RenderColumns: Boolean;
Columns: TColumnsArray;
Index: Integer;
IndentWidth,
LineStyleText: String;
Alignment: TAlignment;
BidiMode: TBidiMode;
CellPadding: String;
begin
Buffer := TBufferedUTF8String.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="' + 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;
RenderColumns := FHeader.UseColumns;
if RenderColumns then
begin
Columns := FHeader.FColumns.GetVisibleColumns;
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(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
Buffer.Add(Text);
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.AsUTF8String;
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: String;
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: String;
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): String;
// 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??emeier.
var
Fonts: TStringList;
Colors: TFpList;
CurrentFontIndex,
CurrentFontColor,
CurrentFontSize: Integer;
Buffer: TBufferedUTF8String;
//--------------- 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(const Text: String; Font: TFont);
var
UseUnderline,
UseItalic,
UseBold: Boolean;
I: Integer;
WText: UnicodeString;
begin
if Length(Text) > 0 then
begin
WText := UTF8Decode(Text);
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(WText) do
begin
if (Text[I] = WideLF) then
Buffer.Add( '{\par}' )
else
if (Text[I] <> WideCR) then
begin
Buffer.Add(Format('\u%d\''3f', [SmallInt(WText[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 : String;
Text: String;
Twips: Integer;
RenderColumns: Boolean;
Columns: TColumnsArray;
Index: Integer;
Alignment: TAlignment;
BidiMode: TBidiMode;
LocaleBuffer: array [0..1] of Char;
begin
Buffer := TBufferedUTF8String.Create;
try
// For customization by the application or descendants we use again the redirected font change event.
RedirectFontChangeEvent(Canvas);
Fonts := TStringList.Create;
Colors := TFpList.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 + '}';
{$ifndef INCOMPLETE_WINAPI}
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
{$else}
S := S + '\paperw16840\paperh11907';// This sets A4 landscape format
{$endif}
// 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.ContentToAnsi(Source: TVSTTextSourceType; const Separator: String): AnsiString;
var
Buffer: TBufferedUTF8String;
begin
Buffer := TBufferedUTF8String.Create;
try
AddContentToBuffer(Buffer, Source, Separator);
finally
Result := Buffer.AsAnsiString;
Buffer.Destroy;
end;
end;
function TCustomVirtualStringTree.ContentToText(Source: TVSTTextSourceType;
const Separator: String): AnsiString;
begin
Result := ContentToAnsi(Source, Separator);
end;
function TCustomVirtualStringTree.ContentToUnicode(Source: TVSTTextSourceType;
const Separator: String): UnicodeString;
begin
Result := ContentToUTF16(Source, Separator);
end;
//----------------------------------------------------------------------------------------------------------------------
procedure TCustomVirtualStringTree.AddContentToBuffer(Buffer: TBufferedUTF8String; Source: TVSTTextSourceType; const Separator: String);
// Renders the current tree content (depending on Source) as UTF8 text.
// If an entry contains the separator char or double quotes then it is wrapped with double quotes
// and existing double quotes are duplicated.
var
RenderColumns: Boolean;
Tabs: String;
GetNextNode: TGetNextNodeProc;
Run, Save: PVirtualNode;
Level, MaxLevel: Cardinal;
Columns: TColumnsArray;
LastColumn: TVirtualTreeColumn;
Index,
I: Integer;
Text: String;
begin
Columns := nil;
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;
end;
//----------------------------------------------------------------------------------------------------------------------
function TCustomVirtualStringTree.ContentToUTF16(Source: TVSTTextSourceType; const Separator: String): UnicodeString;
var
Buffer: TBufferedUTF8String;
begin
Buffer := TBufferedUTF8String.Create;
try
AddContentToBuffer(Buffer, Source, Separator);
finally
Result := Buffer.AsUTF16String;
Buffer.Destroy;
end;
end;
//----------------------------------------------------------------------------------------------------------------------
function TCustomVirtualStringTree.ContentToUTF8(Source: TVSTTextSourceType;
const Separator: String): String;
var
Buffer: TBufferedUTF8String;
begin
Buffer := TBufferedUTF8String.Create;
try
AddContentToBuffer(Buffer, Source, Separator);
finally
Result := Buffer.AsUTF8String;
Buffer.Destroy;
end;
end;
//----------------------------------------------------------------------------------------------------------------------
procedure TCustomVirtualStringTree.GetTextInfo(Node: PVirtualNode; Column: TColumnIndex; const AFont: TFont; var R: TRect;
out Text: String);
// 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: Char): String;
// Constructs a string containing the node and all its parents. The last character in the returned path is always the
// given delimiter.
var
S: String;
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;
finalization
if Initialized then
FinalizeGlobalStructures;
InternalClipboardFormats.Free;
InternalClipboardFormats := nil;
end.
Reference in New Issue View Git Blame Copy Permalink