diff --git a/components/virtualtreeview/CHANGES.txt b/components/virtualtreeview/CHANGES.txt deleted file mode 100644 index 8d2e5fc1..00000000 --- a/components/virtualtreeview/CHANGES.txt +++ /dev/null @@ -1,1805 +0,0 @@ -V7.x: -https://github.com/JAM-Software/Virtual-TreeView/milestones?state=closed - -V7.0: (22 Jul 2018) - * The support for Windows XP/2003 has been dropped (issue #707). This means: - - We did not intentionally break XP support. - - We do no longer test on Windows XP/2003 - - We may accept pull request for XP support if the code quality is sufficient. - - We recommend to use the V6 branch on Windows XP - * BREAKING CHANGE: Removed property TBaseVirtualTree.HintAnimation. Issue #730. - * BREAKING CHANGE: Renamed unit "VTHeaderPopup" to "VirtualTrees.HeaderPopup" - Renamed unit "VTAccessibility" to "VirtualTrees.Accessibility" - Renamed unit "VTAccessibilityFactory" to "VirtualTrees.AccessibilityFactory" - * Fixed issue #804: Remove MMXAvailable and related stuff - * Fixed issue #736: TVTDragManager.GetDataObject() should not use TVTDataObject in case the OnCreateDataObject event handler returned nil - * Fixed issue #756: OnMeasureItem called before data is assigned to node - * Fixed issue #745: Pressing SPACE should change the check-state of all selected nodes - * Fixed Issue #369: Centralize Left Content Margin calculation - * Pull Request #800: Fixed an incorrect calculation of the string edit link height. - * Pull request #796: Fixed a bug where hints of type hmTooltip had incorrect (random) position when when HitPosition was not hiOnItemLabel. - * Fixed issue #796: Utility images are not DPI Scaled - * Fixed issue #794: ScrollIntoView() by column centers column also when center is false - * Fixed issue #789: Issues with toHideSelection - * Fixed issue #792: "Invalid window handle" when using styles - * Fixed issue #788: Wrong logic in GetEffectiveColor. coStyleColor has been added to DefaultColumnOptions. - * Fixed issue #783: TVirtualTreeColumns.HandleClick() may trigger sorting twice - * Fixed issue #781: "~" not working on German keyboard - * Fixed issue #779: Overlay Images with Index < 15 not drawn when OnGetImageIndexEx is used - * Fixed issue #777: Margin is applied right of tree lines, but should be applied left of them. - * Pull request #776: ScrollIntoView centers horizontally enen without Columns defined - * Fixed issue #764: When toAlwaysSelectNode is on, no node is auto-selected after the tree is cleared. - * Fixed issue #769: GetImageSize Fails if kind ikState and not assigned(StateImages) - * Fixed issue #766: Incorrect HotTrack with Touch-Scrolling - * Pull request #761: Add TBaseVirtualTree.OnAddHeaderPopupItem event and 'Size Column to Fit' menu item to TVTHeaderPopupMenu. - * Fixed issue #760: TVirtualTreeColumns.GetFirstVisibleColumn() cause AV if called between BeginUpdate() and EndUpdate() - * Fixed issue #759: TBaseVirtualTree.InitNode() overrides check state of top level nodes set in OnInitNode event handler - * Fixed issue #757: Header popup menu opens twice - * Fixed issue #758: The OnColumnVisibilityChanged event is not always fired - * Fixed issue #754: TBaseVirtualTree.InternalAddToSelection() may cause access violation. Thx@nminkov for the patch. - * Fixed issue #753: TVirtualTreeColumns.EndUpdate() resets column order - * Fixed issue #752: HandleDrawSelection() does not correctly take horizontal scroll position into account - * Fixed issue #750: Plus/Minus sizes are not scaled in DPI aware applications - * Fixed issue #748: Per Monitor Dpi Scaling - Scrollbar Not Correct after Dpi Change - * Enhancement #735: Add event that is fired when a check state is needed. - * Fixed issue #743: Ugly drawing of selection in report mode when VCL Styles are used - * Fixed issue #742: TVTHeader.ParentFont should be True by default - * Fixed issue #740: TVTHeaderPopupMenu should not delete menu items added at designtime - * Fixed issue #739: TVTHeader should use a popup menu if assigned - * Fixed issue #738: Deadlock on application close in ReleaseThreadReference - * Fixed issue #737: Export problem when OnBeforeNodeExport is not assigned - * Fixed issue #723: Turn event OnAfterNodeExport into a procedure. This is a BREAKING CHNAGE. - * Fixed issue #734: DefaultText property ignored - * Fixed issue #724: Error when reading "old" streams - * Fixed issue #397: Horizontal autoscroll on focus does not properly scroll node into view if column width is larger than client width - * Fixed issue #727: Header not repainted after loading from stream - * Fixed issue #726: Incorrect header hot painting - * Fixed issue #722: Simplify custom header drawing while keeping default drawing - * Fixed issue #467: Multi level checkboxes and BeginUpdate/EndUpdate issue - * Fixed issue #391: Change property HotNode: Add a setter - * Fixed issue #767: Remove type TOldVTOption and ReadOldOptions() - * Removed flag toDisableAutoscrollOnFocus from default configuration of a new Virtual TreeView to achieve a more common behavior with default properties. - * poResizeToFitItem is now set by default in TVTHeaderPopupMenu.Options - -V6.7: (29 May 2017) - * Fixed issue #714: Integer overflow in TBaseVirtualTree's InternalAddFromStream - * Fixed issue #500: Issue with node selection "from code" for disabled nodes with toLevelSelectConstraint option - * Fixed issue #499: Incorrect behavior with toLevelSelectConstraint and ctrl+A - * Fixed issue #649: Cell navigation problems with toAutoSpanColumns for left and right keys - * Fixed issue #712: Strange behaviour of AutoFitColumns - * Fixed issue #718: Shift + Right-Click should not extend selection - * Fixed issue #706: Integer overflow in DetermineScrollDirections when timeGetTime wraps - * Fixed issue #407: TVirtualDrawTree.InvalidateNode does not clear vsHeightMeasured - * Enhancement #669: Create sample project for C++ Builder - * Enhancement #708: New option toSyncCheckboxesWithSelection improves multi-selection for touch UI that synchonizes selection and check-state - * Fixed issue #717: The option toUseExplorerTheme does not draw lines in place of buttons removed by toAutoHideButtons - * Fixed issue #716: Tab key navigation does not work properly with Auto Span Columns - * Fixed issue #720: A review of all Demos is needed to fix GetText, GetHint, etc to assign in DFM instead of assigning in FormCreate - -V6.6 (04 Apr 2017) - * Fixed issue #705: Added support for RAD Studio 10.2 Tokyo - * Fixed issue #702: Access Violation at designtime when RootNodeCount is >0 - * Fixed issue #703: Possibly wrong selection if nodes are selected during DeleteChildren() - * Fixed issue #700: If the user clicked a node, we are no longer centering this node if the option toCenterScrollIntoView is set. - * Fixed issue #691: When the user uses Cursor-Left/Right, the Virtual TreeView should perform horizontal scrolling if there is no other operation - * Fixed issue #699: TVTColors.GetColor: Honor user defined colors also when StyleServices are enabled (Thx to luebbe for PR) - * Fixed issue #698: Horizontal scrollbar may not update when turning on or off columns - * Fixed issue #350: TVirtualTreeColumn.fLeft should be in protected part - * Fixed issue #312: When unfocusing a node while the Spacebar is still pressed, the check state should be toggled - * Fixed issue #161: Shift+End does not work as expected with toGridExtension + toFullRowSelect options set - * Fixed issue #697: OnChange not fired when unselecting nodes - * Fixed issue #692: HitInfo for OnNodeClick event may differ much from HandleMouseDown - * Fixed issue #687 by extracting new method DeleteNodes() from existing DeleteSelectedNodes(). - * Fixed issue #689: Possible Integer overflow in PaintColumnHeader() when dragging a column to first position. - * Fixed issue #693: TVirtualTreeAccessibility.accSelect() should handle the flag SELFLAG_EXTENDSELECTION - * Fixed issue #690: Tree shouldn't keep selected elements, if toAlwaysSelectNode is set and other elements are selected without ctrl-modifier - * Improved non-breaking implementation of #622: The deprecated property CheckImageKind is no longer written to DFM files, - but read properly from old DFMs. Thx to the-Aroich for providing it. - * Some minor tweaks on Virtual TreeView source code and sample projects - -V6.5: (18 Jan 2017) - * License change from LGPL to "LGPL with static linking exception". See issue #673 for details. - * Enhancement #662: Background image now supports transparency - * Fixed #677: Improved per monitor dpi awareness. NodeHeight is now scaled as well if toAutoScale is set. - * Fixed #289: HintMode hmHintAndDefault: Default Hint does not change to node specific hint when the mouse is moved to a node. - * Fixed #674: HintMode hmHintAndDefault: If the BidiMode is right to left, the Default Hint fails to appear - * Fixed #139: hoDblClickResize doesn't work correctly with InitalState ivsMultiline - * Fixed #668: Removed unnecessary #include - * Fixed #670: Make it possible to override RangeX - * Fixed #676: VCL themed scrollbar does not update correctly after adding children - * Fixed #626: Wrong hot node selection during mouse movement over different nodes - * Fixed #679: The OnChange event when right clicking a node should always be fired before the OnPopup event - * Fixed #678: Occasional Access Violation in GetDisplayRect - * Fixed #682: Drag & Drop range exception - -V6.4.1: (26 Oct 2016) - * Fixed #549: Drawing issue with toCheckSupport an toExtendedFocus - * Fixed #663: Exception pressing return on an edited item with no columns) - * Fixed #661: Minimal Demo 2 different problems, can't select on start up, multiple clicks causes error - * Fixed problem with wrongly drawn checkbox in column headers. - * VirtualTreePerItemAction now initializes all nodes before it works with them and changes e.g. the check state. - * TBaseVirtualTree.DoGetImageIndex() now always tries to assign a default image list as result, even if OnGetImage and OnGetImageEx are not assigned. So derived controls do not need to make this step. - -V6.4: (28 Sep 2016) - * Fixed #622: [BREAKING CHANGE] Removed all 16x16 fixed sized checkbox-imagelists. - The property CheckImageKind supports the values ckSystemDefault and ckCustom only and should be considered deprecated. - * Fixed #640: Edit control for in-place editing wrongly scaled in high-dpi scenarios - * Fixed #627: It should be possible to use OnGetImageIndexEx without having imagelists assigned - * Added assertion that verifies if an imageindex is supplied but no valid imagelist is available for this imageindex - * Fixed #148: Background Images now support other formats than just bitmaps. - * Fixed #623: GetHint calculates wrong width for HintText - * Fixed #633: High dpi scaling was performed two times - * Fixed #544, #427: Header painting problem with BiDiMode right to left - * TBaseVirtualTree.EnsureNodeSelected() only scrolls the selected node into the view, if no one was previously selected. - * Fixed #248: VT Header draws smudged - * Fixed #643: VT Header dropmark appears even if dragged column won't change position - * Fixed #310: Incorrect selection paint when toAutoSpanColumns, toGridExtensions and toExtendedFocus are set - * Fixed #653: GetFirstVisibleChild/NoInit check for wrong node if IncludeFiltered=True (thx to A. Hausladen) - * Fixed #659: GetLastVisibleChild/NoInit checks wrong node - * Fixed #647: New option to set the way of selecting next cell for editing in grid mode - * Fixed #645: Can't link 64 bit VCL app with VirtualTreeView in C++ Builder 10.1 Berlin - * Fixed #656: Fixed memory leaks in Advanced Demo - * Enhancement #631: Added new Demo project CharityEvents to demonstrate the use of Interfaces for node's data and for data presentation - * Fixed #658: Column Header does not paint correctly after a drop in certain conditions - * Fixed #639: Scrolbars are not correctly themed under certain cirumstances when using a VCL theme. - * Fixed #624: Wrong y-postion of checkboxes in high-dpi display mode - * Fixed #548: Add flag coStyleColor to TVirtualTreeColumn.Options (prefer background color of VCL style over TVirtualTreeColumn.Color) - * Fixed #660: Fix AV when tree is modified in OnEdited event - * Some minor tweaks on Virtual TreeView source code and sample projects - -V6.3: (17 May 2016) - * Added support for RAD Studio 10.1 Berlin - * Implemented #607: Disabled checkbox images should be available - * Fixed #612: hotkey handing and toReverseFullExpandHotKey - * Fixed #602: Dangling WM_Timer and doubled OnChange calls - * Fixed #606: High DPI Inheritance of Form. TBaseVirtualTree.ChangeScale() now respects inherited property ScalingFlags - * Fixed #608: Horizontal lines paint bug on scroll. - * Fixed #605 : If a new node is selected by left click, OnChange event should not fire with `nil` in-between. - * TBaseVirtualTree.EnsureNodeSelected() no longer changes scroll position unless necessary to make the selected node visible. - * Pull request #609: Updated unit "Contributions/GenericWrapper/VirtualTreeWrapper.pas" - * Started adding unit tests with DUnitX. - * Minor tweaks. - -V6.2.3 (11 Feb 2016) - * Fixed accidental remove of vsReleaseCallOnUserDataRequired flag which can cause mem leaks. - * TVirtualNode.SetData() now sets the vsOnFreeNodeCallRequired flag for all types of user data and so is consisted with other SetData / GetData methods. - * TCustomVirtualStringTree.SetChildCount() now calls ResetInternalData()= with Recurse = False to avoid that all siblings of the new children are reseted recursively. See isuue #576 - * TCustomVirtualStringTree.ResetInternalData() now respects the Recursive parameter - -V6.2.2 (20 Jan 2016) - * Issue #603: If the node already has children, then its nodeheight is valid and we must not remove its total height, but rather its height - * Fixed issue #599: Possible infinite loop in GetPreviousVisibleNoInit() - * Added new method TBaseVirtualTree.InitRecursive() as workaround for issue #597: Initializes a node and optionally its children up to a certain level. - * Issue #598: SetData, like GetData no longer forces the "class" constraint on its generic parameter - * Fixed issue #596 by moving initialization of global variable Watcher also to InitializeGlobalStructures() - Now ensuring using interlocked function that InitializeGlobalStructures() is executed only once - * Fixed issue #458: If the Virtual TreeView control is placed on a control that has the StyleEx flag WS_EX_COMPOSITED set, horizontal scrolloing does not update the header - * Fixed issue #595: Before using SetTimer, check for valid WindowHandle - * Fixed issue #594: Basic TVirtualStringTree Colors does not apply - * Fixed issue #591: Now calling UnRegisterStyleHook() for the style class in "VirtualTrees.StyleHooks". - * Fixed #590: Allow to store InternalData also for (internal) root node - * if only one node is selected, make sure the focused node changes with the selected node - * Added assertion that ensures that BeginUpdate() is called from main thread only. - * Getter function GetCheckedCount() is protected now instead of public - -V6.2.1 (06 Nov 2015) - * #585: Checkboxes now have the correct size and scale properly on high dpi systems. - * #588: Fixed HTML clipboard export - * #586: TBaseVirtualTree.SetChildCount() no longer calls to ReInitNode(Node, True). This caused the OnInitChildren-Event to be fired twice. - * Adjusted GetNodeDataAt() and GetFirstSelectedNodeData() to work with interfaces. - * If multi selection is not allowed and so only one node can be selected, make sure the focused node changes with the selected node in SetSelected() - * Added packages for the C++Builder 10. - -V6.2 (09 Sep 2015) - * Issue #582: Added support and packages for RAD Studio 10 Seattle - * Issue #580: Added support for Delphi package manager Delphinus - * Fixed issue #571: Grid mode and extended selection leads to drawing inconsistencies - * Fixed issue #569 which includes a fix for AddChild(). - * Fixed issue #568: Integer overflow when reiniting nodes and using ivsFiltered - * Merged pull request #564 which includes a fix for ComputeNodeHeight() and single line nodes - * Merged pull request #563 which prevents an access violation when using custom check images in column headers - * Merged pull request #561 which makes VclStyleChanged() virtual - * Fixed issue #557: Using isFiltered in InitNode leads to integer overflows or bogus rendering - * Fixed issue #556: Variable height and more than 1 level results in incorrect RangeY - * Fixed issue #555: The OnChange event is not fired in case the selected node is deleted through DeleteChildren(). Although no the option toAlwaysSelectNode is set, the parent node was not selected afterwards. - * Fixed issue #553: painting failure with variable NodeHeight - * Fixed issue #551: Some overlay images were drawn ghosted like the main image, some not. - * TBaseVirtualTree.PrepareBitmaps() now fires the OnPrepareButtonImages event also in case VCL styles are used. - * Added implementation for TVirtualTreeAccessibility.accSelect() so that screen readers and especially UI testing tools can use MSAA to select specific elements in the control. - * Property OnColumnVisibilityChanged is now published. - * Now using type TImageIndex instead of integer for variables and parameters that store an image index. - -V6.1 (02 June 2015) - * Implemented Issue #530: Removed all AnsiString code from export routines. Breaking changes: - - TCustomVirtualStringTree.ContentToText() is now based on (Unicode)string and no longer on AnsiString. - - TCustomVirtualStringTree.ContentToUnicode() is now deprecated, use ContentToText() instead. - * Implemented issue #536: Add export event that is triggered for each cell - - Added new event OnGetCellText which has new TVSTGetCellTextEventArgs record as parameter. - This event could supersede the OnGetText event in a future version. - - All export formats now also export static text, in case the toShowStaticText flag is set - * Fixed issue #545: VCL Themes: Background of scrollbars is erased with wrong color - * Fixed issue #487: When OnAddToSelection is called, GetFirstSelected returns nil - * Fixed issue #542: AllocateInternalDataArea() was broken for derived classes - This was a result of issue #507. Now the user node data comes before the internal data. - Therefore it is important to use the function InternalData() to access the internal data of a node. - * Fixed issue #541: Duplicate call of EndEdit() - * Fixed issue #123: Triangle button is not shown for hot node - * Fixed issue #347: With VCL-Themes: No expand-pluses seen under Windows classic theme - * Fixed copy&paste error is source code related to issue #519 - -V6.0 (13 Apr 2015) - * Issue #509: Added new option hoAutoColumnPopupMenu to TVTHeaderOption. - * Issue #457: Virtual TreeView no longer react on standard actions for TEdit controls - We added standard actions for copy, cut, paste, delete, select all, check, uncheck in the new unit "VirtualTrees.Actions". - * Issue #484: ContentToHTML() no longer pre-encodes the HTML in UTF-8 but returns a Unicodestring - * Issue #507: Added to TBaseVirtualTree: - function GetNodeData(pNode: PVirtualNode): T; - function GetNodeDataAt(pXCoord: Integer; pYCoord: Integer): T; - function GetFirstSelectedNodeData(): T; overload; - function GetInterfaceFromNodeData(pNode: PVirtualNode): T; - procedure SetNodeData(pNode: PVirtualNode; pUserData: Pointer); - procedure SetNodeData(pNode: PVirtualNode; const pUserData: IInterface); - procedure SetNodeData(pNode: PVirtualNode; pUserData: T); - Similar functions have also been added to the TVirtualNode record. - * The grid demo of the "Advanced" project now uses a class instead of a record and the new generic functions from issue #502. - * Issue #519: Changed plus/minus buttons so that hot tracking of the buttons is always on, independent of toHotTrack. - * Issue #514: The splitter area in the column header should be configurable - * Issue #515: The value for Indent should get scaled too if the toAutoScale flag is set - * Issue #511: From the unit VirtualTres new units have been extracted to reduce its size. - * Issue #483 for TVTOperationKind.okExport: All exports can now be cancelled using CancelOperation() - * Issue #362: InternalConnectNode: AdjustTotalHeight not called if Node not FullyVisible - * Issue #506: Autosort is being triggered at design-time. - * Issue #486: AutoScroll is performed although toAutoScroll is not set. - * DoMeasureItem() now ensures that the node was initialized. - * Issue #493: Editing with DblClick should always open editor immediately. - * TVirtualTreeColumns.UpdatePositions() now exits immediately if the control is destroying, ths prevents AVs. - * Added support for CBuilder XE7. - * A larger patch from Diemtar Rösler was applied which addresses various issue regarding VCL styles (especially #478 and #491). - * Supporting only Delphi / C++ Builder XE3 and higher - * Improved support for C++ Builder - -V5.5.3: (08 Jan 2015) - * Fixed issue #495: Incorrect text vertical align when changing font in OnPaintText - * Fixed Issue #496: Access violation at VT destroy - * Fixed issue #498: Node totalheight not initialized properly when adding new node and using toVariableNodeHeight - -V5.5.2: (10 Nov 2014) - * Various improvements regarding code style - * Implemented #471: Add emVisibleDueToExpansion and emSelected to TVTExportMode - * Fixed issue #488: XE7 packages should depend on one another and use suffix 21 - * Fixed issue #462: Undo r636, make VirtualTreesD require VirtualTreesR again - * Fixed issue #489 XE2 compiler switch error - -V5.5.1: (13 Oct 2014) - * Fixed issue #479: The style hooks for the VCL styles are now registered for TVirtualStringTree and TVirtualDrawTree instead of TBaseVirtualTree, which makes it easier to use own style hooks in derived classes. - * Partial fix for issue #478: The standard VCL property StyleElemets (public in TControl in RAD Studio XE3 and higher) is now supported and published for TVirtualStringTree and TVirtualDrawTree (XE3 and higher). This means you can define if the font and the backgrounbd color is taken from the VCL style or the control's properties. Leaving out seBorder is not yet working well, more work will be necessary. - * Fixed issue #473: Return type of GetUtilityImages should be TCustomImageList - * Fix for issue #470: VCL Styles and sorting failure - * Added missing inherited to CMMouseEnter() - * Fixed issue #468: Redundant code in CreateSystemImageSet() - * Fixed issue #482: AutoScale() could cause exception during form load. - * Added fix for #466: No parent window if column created in constructor - * Fixed issue #446: ScrollIntoView does not work properly after applying patch from issue #339 - * Improvements for toAlwaysSelectNode option: Selection of next sibling has been improved in case the currently selected node is being removed. - * Added missing begin/end-block in MeasureItemHeight() - * Improved fix for issue #438: Now correctly initializing member of property TVTColors.UnfocusedColor - * Improved fix for issue #447: DoMeasureItem() was called for Node instead of Child. - * Minor improvement in appearance of border lines in HTML export. - * Fixed issue #480: Warning when compiling Delphi XE2 packages - * Fixed #472: Redundant conditions in TVclStyleScrollBarsHook.WMMouseMove - * Fixed #476: Simplify TVTDragImage.WillMove() - * Fixed issue #485: unit VirtualTrees does not compile with {$TYPEDADDRESS ON} - -V5.5: (11 Sep 2014) - * Added packages for RAD Studio XE7 / Delphi XE7 - * Fixed issue #464: Vertical grid lines not computed correctly for spanned cells with header auto resize - * Fixed issue #442: Scrollbars are not updated for active VCL Style under XE2 - * Fixed issue #463: HTML export shows grid lines in IE and Chrome, but not in Firefox - * Fixed issue #460: Access violation in design time when setting "CheckBox" to True for a Virtual Treeview Column - * Fixed issue #72: Call Application.CancelHint only if the current control is showing the hint - * Fixed issue #461: corrected condition in TBaseVirtualTree.ScrollIntoView, so that not only partially (by the fixed area) covered columns but also totally covered columns are scrolled in view - * Fixed issue #450: Regional letters entered using Right+Alt should also trigger the incremental search. - * Improvemtns for toAlwaysSelectNode: - Clicking the free space below the tree nodes no longer deselects the selected node. - We now prevent toggling of the selection of the last selected node if toAlwaysSelectNode is set in TreeOptions. - * Fixed issue #447: SetChildCount() now calls DoMeasureItem() instead of using DefaultNodeHeight. - * Fixed issue #444: ERangeError in TBaseVirtualTree.CMMouseWheel - * TBaseVirtualTree.MeasureItemHeight() is virtual now. - * Fixed issue #445 MultiSelect behavior: Can't drag node which is not selected - * Fixed Issue #443: TVirtualTreeColumns.ColumnFromPosition on right border of fixed column - * Fixed issue #339: Problems with fixed column - * Implemented #410: Small extension of TStringEditLink: Allow creating own edit control by moving the creation of TVTEdit from constructor to virtual PrepareEdit with assigned check. - * Implemented #409: Extend THitInfo record with hit coordinates - * Added suggestions of #438: Make some members visible to derived classes - * Fixed issue #440: Context menu does not pop up if there is no selected node - * Added C++ Builder link demand to VirtualTreesR.Lib as {$HPPEMIT} - * Improved installation instructions, especially for C++ Builder - -V5.4.1: (26 May 2014) - * Added packages for C++ Builder XE6 - * If toAutoChangeScale is set in AutoOptions, the Virtual TreeView control now - increases the DefaultNodeHeight if the font size is too large to fit. - * If toAutoChangeScale is set in AutoOptions, the columns widths are now adjusted too. - * Improved implementation for toRestoreSelection option - * Fixed possible AV in PaintNodeButton() - * Now ensuring that both GetHorzScrollBarSliderRect() and - GetVertScrollBarSliderRect() return a valid value for every code path (Thx to - Dmitri Dmitrienko). This could cause strange out of resources exceptions with VCL - styles enabled. - * Fixed issue #434: Application compiled with Delphi 7 stops responding when you call AddChild - * A few minor changes - -V5.4.0: (22 Apr 2014) - * Added support for XE6. - * Added new option toRestoreSelection to TVTSelectionOptions: Set to true if upon refill the previously - elected nodes should be selected again. The nodes will be identified by its caption only. - * Added new option toAlwaysSelectNode to TVTSelectionOption enum. If this flag is set, the treeview tries to - lways have a node selected. This behavior is closer to the Windows TreeView and useful in Windows Explorer - tyle applications. It is also useful for accessible applications which can indicate having the focus by - isplaying a selection. - * Added function TBaseVirtualTree.IsEmpty which returns True if the control has no nodes. - * Fixed a wrongly drawn selection after the user scrolled horizontally. - * Fixed issue #423: Change property TVirtualTreeColumn.Tag to NativeInt. - * Implemented #415: Added feature for design time column header dragging and resizing. (Thx to fr0st.brutal) - * Fixed issue #180: Memory leak in grid demo of Advanced project - * Implemented #422: Added TBaseVirtualTree.GetFirstChildNoInit() - * Fixed issue #420: Add coEditable to TVTColumnOption) by applying the supplied path. Thx to Stefan Glienke. - * Fixed issue #419: Some issues with changing to edit mode with clicking - * Fixed issue #430: TVTDragManager memory leak with visual inheritance. Thx to Andreas Hausladen for the patch. - * Fixed issue #431: Visual bug when using TStringEditLink with large node heights - * TVclStyleScrollBarsHook.WMMouseMove(): Now preventing possible range check error exception. - * Now handling WM_MOVE and WM_POSCHNAGED correctly in TVclStyleScrollBarsHook (Thx to Dmitri Dmitrienko) - * Preventing possible stack overflow in TVirtualTreeHintWindow.ActivateHint (Thx to Dmitri Dmitrienko) - * Added packages for C++ Builder XE5. - * Some minor changes, improvements and fixes have been incorporated - -V5.3.0: (04 Jan 2014) - * Fix for issue #159 (Cursor missing in edit with non-standard DPI): Ensuring a minimum size of the edit control - * Fixed issue #403: Declare TVTGetNodeProc as reference to procedure (for D2009+) - * Fixed issue #402: TVTEdit.CNCommand discard all notification except EN_UPDATE due to missing inherited - * Corrected fix for issue #376 (Incorrect selection paint when toGridExtensions is included in the MiscOptions) - * Fixed issue #401: OnNodeClick event doesn't trigger in some case, coFixed set for a column - * Modified #316 (concerning r498). The fix for #316 will only be applied in case toMultiSelect is set. - If toMultiSelect is not set we can start a drag anywhere in the row. - * ContentToHTML() and ContentToRTF() now return a string of type RawByteString. - Because the generated strings are pre-encoded in UTF-8, the previous type AnsiString caused - problems in Delphi 2009+ e.g. when this string was written using the VCL TStreamWriter class. - The helper class TBufferedAnsiString therefore uses RywByteString now as type too. - * Fixed issue #399: EditDelay not working - * Fixed issue #400: AltGr+A does not behave as expected for foreign keyboard layouts in VTEdit - * Fixed issue #388: VirtualStringTree with toFixedIndent causes range check error - * Edit box when editing a node in a tree with toFixedIndent now has the correct indent - * Fixed issue #392: Now ensuring that MeasureItemHeight() is only called from the main thread. - * Fixed #383: Clear vsHasChildren for a node without children even if the children count didn't change. - * Fixed #377: Wrong font (size, etc) in TargetCanvas in MeasureItem for first node - * Fixed issue #398 (hoAutoResize causes DFM designer to be modified after loading) by calling TControl.Updating()/Updated() in AdjustAutoSize() - * Preventing possible AV in TBaseVirtualTree.FontChanged() - * Fixed 32Bit Integer overflows in Win64 build in TBufferedAnsiString. - -V5.2.2: (30 Oct 2013) -- Added support for Delphi / RAD Studio XE5 -- Fixed issue #371: property OnGesture is now published. -- Fixed issue #365: No longer changing timer resolution globally -- Fixed issue #347: No expand-pluses seen under Windopws classic theme for a vcl styled application -- Fixed issue #373: Scrollbar does not size properly for more than 2000 nodes with variable node height: - The OnMeasureItem event is triggered only in case the toVariableNode flags in included in MiscOptions -- Fixed issue #376: Incorrect selection paint when toGridExtensions is included in the MiscOptions -- Improved displaying of EmptyListMessage text, especially when scrolling horizontally. -- Fixed issue #61: EditCursor missing with manifest + toThemeAware + vsMultiline -- Fixed issue #352: Minor improvement in calculation of right margin of hint window. - -V5.2.1: (06 Sep 2013) -- Fixed #352 and #354 by modifying the implementation of #237 so that a focused node is ensured only if the - control is being entered using the TAB key. This is consistent with the behavior of the Windows Explorer. -- Fixed issue #360 (In the calculation of the horizontal scroll bar static text should be considered) by - calling DoGetNodeExtraWidth() in TBaseVirtualTree.GetMaxRightExtend() -- Used fix proposed in issue #361 to fix issue #357 (AV in advanced demo - PropertiesDemo form in XE3+) -- Removed call to TCustomStyleEngine.UnRegisterStyleHook() to fix issue #359/#355 -- Fixed issue #358: Horizontal Scrollbar issue when expand ing and scrollbars get visible -- Fixed issue #355/#345: exception regarding style services - -V5.2: (09 Aug 2013) -- OnMouseEnter and OnMouseLeave events have been added (#238) -- Improved dpi scaling for VirtualTreeView and Header -- toAutoChangeScale and toAutoSort are now among the defualt values for TCustomVirtualTreeOptions.AutoOptions -- Fixed issue #237: Auto focus the first node on enter if there is no focused node -- Fixed issue #344: Cannot select row by Ctrl+Click on empty column -- Fixed issue #206: Column painting issue with coWrapCaption in Options -- Fixed issue #128: OleUninitialize in FinalizeGlobalStructures can hang when using Virtual Treeview in a DLL -- Added new public property LastDragEffect which supplies the last executed drag effect. -- Added virtual method GetNodeImageSize() which can be overridden if one needs different sized images. -- Added new public property LastDragEffect which supplies the last executed drag effect. -- Fixed issue #206: Column painting issue with coWrapCaption in Options -- Fixed issue #336 by ignoring PARENTDOUBLEBUFFEREDCHANGED message. -- Fixed issue #342 by adding a new implementation of the VCL's DoubleBuffered property. - The inherited DoubleBuffered property of TWinControl must not be set to True! -- A few minor improvements have been added. - -V5.1.3: (17 Apr 2013) -- Fixed #340: GetHitTestInfoAt on right border of fixed column. -- Fixed #337: Cannot "grab" item for dragging, odd behaviour of multi selecting with the selection - rectangle when toFullRowSelect is True but toSimpleDrawSelection is False. (thx to Stefan Glienke) -- Fixed #341: Error when unloading DLL due to missing UnRegisterStyleHook -- Improved fix for #323: The fix applied in V5.1.2 was a breaking change for some projects, especially - if not all the initialization was done in the OnInitNode event (reported as #338). vsInitialUserData - has been renamed to vsOnFreeNodeCallRequired and is now set when GetNodeData is called. This fixes - the possible memory leak reported in #323 and has better backward compatibility. -- Fixed #316: These fixes are to make the treeview behave more like the windows explorer regarding - selecting and dragging. Thanks to Stefan Glienke. -- Fixed #333: Possible Integer overflow in 64Bit builds. -- Compatibility with / packages for Delphi Xe$ / RAD Studio XE4 have been added. - -V5.1.2 (04 Apr 2013): - - Added function TVirtualTreeColumns.GetFirstColumn that returns the first column in display order. - - Fixed issue #322: CaptionAlignment is not being restored by Header.LoadFromStream(). - - TBaseVirtualTree.GetNodeData() now calls InitNode() if the node had not beend initialized. - This fixes issue #323 (Memory leak when the Node has children ) - - Fixed issue #326: Application hangs when aborting OLE Copy/Paste Operation - - Added new option poResizeToFitItem to TVTHeaderPopupOption: Adds an item which, if clicked, - resizes all columns to fit by calling TVTHeader.AutoFitColumns() - - Property RangeX is now public in the class TVirtualStringTree (#327) - - TVirtualTreeColumns.HandleClick(): No longer triggering auto sort if just the checkbox in the header was clicked - - TBaseVirtualTree.SetCheckType new resets PVirtualNode.CheckState only if the check state does not fit the new check type - - Fixed issue #321: Delphi2009: undeclared identifier: 'fState' in VirtualTrees.pas:DrawDisabledImage() - - Fixed issue #315: hoHeaderClickAutoSort was only working if toAutoSort is also set - -V5.1.1 (07 Feb 2013): - - Fixed issue #313: Translucent selection rectangle completely broken when PaintBackground is used - - Fixed issue #314: Only if toAutoSort is True non-expanded nodes will be excluded from sorting. - This restores the behavior of V5.0.X. - - Fixed issue #306: Drag image was broken except for CF_HDROP - - Fixed issue #305: Broken hint drawing with classic windows theme and toUseExplorerTheme - - Fixed issue #298: Bad canvas parameters in OnBeforeCellPaint method - - If NodeDataSize has its default value -1, now sizeof(Pointer) is used at runtime as actual value. - This makes it easier to store a simple Pointer with each node indepedent of the target platform (32/64Bit). - - Fixed issue #300: Made the hint text more centered in the hint window - - If TVirtualTreeColumn.CheckBox is set to True in Designer, then hoShowImages is now added to Header.Options - - Fixed issue #302: AV when painting sorted header column containing checkbox - - Now soring subnodes when they get expanded and the toAutoSort flag is set - - Added fix for ugly drawn disabled images (thx to S. Glienke). See also: - http://stackoverflow.com/questions/6003018/make-disabled-menu-and-toolbar-images-look-better - http://qc.embarcadero.com/wc/qcmain.aspx?d=86879 - - Fixed issue #299: Draw themed focus rectangle with toUseExplorerTheme - - Fixed issue #198: Wrong check images - - Removed file VTConfig.inc. The former $ifdef ReverseFullExpandHotKey is now a flag in the - TVTMiscOption enumeration. The $ifdef TntSupport can be defined at the beginning of the unit VirtualTrees. - - Added new optional parameter "Recursive" to TBaseVirtualTree.Sort() - -V5.1.0 (05 Nov 2012): - - Fixed issue #291: Empty hint strings are shown when using custom hint window classes - - Added support for VCl styles of RAD Studio XE2 and higher. (Thanks to Dietmar Rösler, issue #288) - - Fixed issue #285: access violation when mouse down over checkbox sometimes - - Fixed issue #293: OnAdvancedHeaderDraw is called with wrong PaintInfo.PaintRectangle - - Improved creation of IDragSourceHelper and added support for IDragSourceHelper2 - - Fixed problem with drawing selection rectangle after canceled rename - - Improved creation of IDragSourceHelper and added support for IDragSourceHelper2 - - Fixed issue regarding activating explorer theme - - Fixed issue #222: FDottedBrush is never released in the tree is never shown - - Fixed issue #52: Misalignement of CheckBox and TreeLine/Buttons - - Fixed issue #43: VT stop repaint after Windows visual style change - - Fixed issue #66: column auto-resize makes not aware of StaticText - - Fixed issue #53: Misalignment Images Columns > 0 - - Fixed issue #176: Multiline Aligment Problem - - Fixed issue #283: VTV no longer allows to drop above or below when using Full row selection - - Fixed issue #173: Two suggestions about class member visibilities - - Fixed issue #192: Fixed column painting bug when OffsetX > 0 - - Fixed Delphi 2007 Designer package - -V5.0.1 (06 Sep 2012): - - Added Support for RAD Studio XE3 - - Fixed definition of event OnAfterHeaderExport, it used the same member variable as OnBeforeHeaderExport. - - Fixed problem with Delphi 2007 package - - Delphi 2009 and 2010 packages are also implicit build packages now, like those for XE and XE2 (issue #279) - - Fixed #251: Added supoort for C++ Builder XE2 - - Fixed #274: Wrong stop condition in TBaseVirtualTree.GetLastVisible - - Fixed runtime package of Delphi 7 - - Fixed issue #273: Incremental search for international symbols not working in Delphi 2009-XE2 - - A few minor bug fixes have been incorporated - -July 03, 2012 - - Release of V5.0.0 final -June 11-30, 2012 - - Release of V5.0.0 RC2 - - Removed dependecy on file Compilers.inc - - Removed dependency on file MSAAIntf.pas - - Removed folder Common - - Fixed issue #252: Incorrect width of edit control rectangle when grid extensions are set - - Fixed issue #259: Hit position wrong when Indent is not default - - Fixed issue #253: Compatibility issues with XE2's VCL style checkboxes - - Fixed issue #265: Lib suffix not set for all configurations in Delphi XE2 package - - Bug fix: Functions GetLastVisible and GetLastVisibleNoInit return correct results even if some anchestor of the last visible node is not effectively visible - - Improvement: Added functions GetNextSiblingNoInit and GetPreviousSiblingNoInit - - "Res" folder of Advanced sample was not included in ZIP archive - - Added folder "Contributions" to release -June 01-10, 2012 - - Release of V5.0.0 RC1 - - Updated help file for V5.0 -April 2012 - - Added support for theming of hint window (thanks to Arno Garrels and Uwe Schuster) - - TBaseVirtualTree.CheckParentCheckState: Fixed duplicate recursion to parent nodes -March 2012 - - Fixed painting of Windows7/Vista style Explorer selection in case tsUseExplorerTheme is in TreeOptions - - Ctrl + A now selects all items -January 2012 - - Bug fix: Fixed a potential access violation in TBaseVirtualTree.FullCollapse in case of toChildrenAbove -December 2011 - - Fixed compiler warning in RAD Studio XE2 regarding deprecated ThemeServices -September 2011 - - The property EmptyListMessage may now contain linebreaks in Delphi 2009 and higher, the text in now printed in dark gray. - - Support for flat scroll bars has been removed. - - Global variables InWin2k and IsWinXP, enum member hsXPStyle, function DrawXPButton() and support for Windows 2000 has been removed. - - Global variable IsWinNT and support for Windows 9x has been removed. - - Improvement: Added support for Delphi XE2 and 64Bit compiler. - - Support for Delphi 5/6 and C++ Builder 5/6 has been dropped. - - Bug fix: Fixed a potential integer overflow in TBaseVirtualTree.ToggleNode in case of toChildrenAbove and NodeInView - - Bug fix: Fixed a potential Assertion in TBaseVirtualTree.ToggleNode by checking GetFirstVisible before calling GetDisplayRect - - Bug fix: TCustomVirtualTreeOptions.SetPaintOptions correctly changes the VisibleCount when toShowFilteredNodes is toggled - - Improvement: Added new functions TBaseVirtualTree.DetermineDropMode - - Improvement: Added usage of TBaseVirtualTree.DetermineDropMode in TBaseVirtualTree.DragOver - - Improvement: Made EffectiveOffsetX accessible via read-only protected property for easier subclassing - - Improvement: Moved TBaseVirtualTree.DetermineLineImageAndSelectLevel from private to protected for easier subclassing - - Improvement: Sorted TBaseVirtualTree.SetEmptyListMessage -August 2011 - - Improvement: Minor code improvements -April 2011 - - Bug fix: Reverted change of November 2010 (Creating the WorkerThread will no longer change System.IsMultiThread) - it caused sporadic AVs during app start which disappeared after revering the change. This code can lead to a wrong value - of System.IsMultiThread which causes the memory manager to assume a single threaded application. - - Bug fix: When advancing to the next item while in edit mode, we are now also calling CanEdit(). -February 2011 - - Bug fix: In case the LastStructureChangeNode is deleted before the StructureChange event is fired, - the reference to the LastStructureChangeNode is cleared to avoid providing an invalid node -January 2011 - - Improvement: RTF export now uses landscape paper format and smaller margins, so that more of the contents - fits on the page - - Improvement: New Option hoHeaderClickAutoSort for TVTHeader.Options: Clicks on the header will make the - clicked column the SortColumn or toggle sort direction if it already was the sort column - - Improvement: Pressing the tab key in edit mode advances to the next node in edit node, just like the - Windows 7 Explorer does it. - - Bug fix: No longer auto-scrolling horizontally when the focused node changes if toFullRowSelect is turned on. - - Bug fix: Fixed a clipping issue when drawing unbuffered -December 2010 - - Improvement: TBaseVirtualTree.HandleMouseUp now checks CanEdit just in case toEditOnClick - - Bug fix: TotalNodeHeights are now correctly adjusted when toggling toShowHiddenNodes - - Bug fix: Fixed BCB compiler error due to re-defining IDropTargetHelper - - Improvement: New TVTInternalPaintOption poUnbuffered to directly paint onto a given canvas (especially useful - when printing and/or scaling via world transformations) - - Improvement: Refactored header painting to be more flexible (e.g. for printing) - - Improvement: Made additional fields accessible via protected read-only properties for easier subclassing -November 2010 - - Improvement: All calls to SetWindowOrgEx now respect the canvas' transformation - - Improvement: TBaseVirtualTree.GetNodeHeight will no longer measure the node height, if the node is about - to be deleted - - Improvement: Made TBaseVirtualTree.FRangeX and FRangeY accessible via read-only protected property - - Improvement: Unified clipping handling - - Improvement: Added new color setting "SelectionTextColor" - - Improvement: Creating the WorkerThread will no longer change System.IsMultiThread - - Bug fix: Fixed a potential integer overflow in TBaseVirtualTree.ToggleNode - - Bug fix: TBaseVirtualTree.ToggleNode now measures the child node heights before summing them - - Improvement: Made some private field of TVTHeader and TVirtualTreeColumns protected to make writing - derived classes easier - - Improvement: Enclosed call to DoDragDrop in TBaseVirtualTree.CMDrag in a try..finally block - - Improvement: The default inplace editor now resizes itself even when the tree is in grid mode - - Bug fix: TBaseVirtualTree.PrepareBitmaps now checks the existance of the main column correctly - - Bug fix: TBaseVirtualTree.UpdateEditBounds now checks wether the focused node is assigned - - Improvement: TBaseVirtualTree.FHintData is now available to derived classes via the protected property HintData -October 2010 - - Bug fix: Now taking horizontal scroll position into account when drawing text of EmptyListMessage property - - Bug fix: Prevented potential "index out of bounds" exception in TVirtualTreeHintWindow.CalcHintRect - - Bug fix - Issue #187: Showing a dialog in OnChange or OnRemoveSelection event handlers can cause the VT to - enter mode for drawing selection rectangle. - - Improvement: Made inherited event OnCanResize published for TVirtualStringTree for Delphi 2010 and later - - Improvement: TBaseVirtualTree.ToggleNode now tries to keep the visual position of the toggled node, - even when toChildrenAbove is set -September 2010 - - Improvement: Added additional check regarding the tree reference to TVirtualTreeHintWindow.AnimationCallback - - Improvement: Made TBaseVirtualTree.AdjustImageBorder protected and virtual - - Improvement: TVirtualTreeColumns now observes if the focused column is removed - - Improvement: Made compatible with Delphi XE (Thanks to Roman Kassebaum) -August 2010 - - Improvement: TCustomVirtualStringTree.DoTextMeasuring now returns TSize - - Improvement: Renamed TVTMeasureTextWidthEvent to TVTMeasureTextEvent and introduced new - event TCustomVirtualStringTree.OnMeasureTextHeight - - Improvement: Made TBaseVirtualTree.GetMaxColumnWidth virtual - - Bug fix: TBaseVirtualTree.OnRemoveFromSelection is now triggered by TBaseVirtualTree.RemoveFromSelection - as intended -July 2010 - - Bug fix: Toggling toShowFilteredNodes will now update the node counts in the tree even if its handle has not - been allocated so far - - Bug fix: TBaseVirtualTree.FindNodeInSelection should now work correctly with nodes above the 2gb boundary - - Bug fix: Nodes that are about to be deleted are now removed from TBaseVirtualTree.FDragSelection - - Bug fix: Changed TBaseVirtualTree.WMKeyDown to correctly handle special keys in Unicode based Delphi versions - - Bug fix: Changed declaration of TBaseVirtualTree.EmptyListMessage to UnicodeString - - Improvement: Added new property TBaseVirtualTree.EmptyListMessage. If this property is not empty, the assigned - text will be displayed if there are no nodes to display, similar to the Windows XP file search. - - Improvement: Added tstChecked to TVSTTextSourceType enumeration and support for the new flag to - GetRenderStartValues(). So you can export only checked nodes. -June 2010 - - Bug fix: range select with no nodes will no longer result in an access violation - - Bug fix: TBaseVirtualTree.SetVisible now correctly decrements the visible node count - - Bug fix: TStringEditLink.BeginEdit now calls AutoAdjustSize to ensure a consistent size of the edit field - - Improvement: TVTHeader.AutoFitColumns is now declared virtual - - Bug fix: header captions were badly positioned text if Extra Large fonts have been activated in the Windows - display options -May 2010 - - Improvement: TBaseVirtualTree.PaintTree is now declared virtual - - Bug fix: corrected calculations regarding tree height and visible count when using filtered nodes -April 2010 - - Bug fix: Changed TBaseVirtualTree.SetChildCount and TBaseVirtualTree.InitNode to correctly handle filtered nodes - - Bug fix: Ctrl+Click on a node often cause a delayed update of the displayed selection due to a missing (or - misplaced) call to Invalidate() in HandleClickSelection(). - - Bug fix: Shift+PgUp and Shift+PgDown now behave like a usual List(View) and select the node of the previous/ - next page. The behaviourly that was formerly assigned to these shortcuts is now triggeres when using - Shift+Alt+PgUp / Shift+Alt+PgDown -March 2010 - - Bug fix: TBaseVirtualTree.CMMouseLeave now checks if the header is assigned before working with it - - Bug fix: TCustomVirtualTreeOptions.SetPaintOptions will now invalidate the node cache if toChildrenAbove is - changed - - Bug fix: TBaseVirtualTree.HandleMouseUp will no longer cause an AV if HitInfo.HitNode is not assigned and - tsToggleFocusedSelection is set - - Improvement: new properties TBaseVirtualTree.OnAddToSelection and TBaseVirtualTree.OnRemoveFromSelection - - Bug fix: fixed a whole bunch of painting issues regarding drag & drop - - Bug fix: fixed TBaseVirtualTree.DragFinished to generate a button up event in case of using OLE drag & drop - - Bug fix: TBaseVirtualTree.DeleteChildren no longer fails if the given node is nil -January 2010 - - Bug fix: Removed defaults from TVirtualTreeColumn.BiDiMode and TVirtualTreeColumn.Color - - Bug fix: Clearing the columns while editing no longer raises an exception - - Improvement: refactored handling of long running operations - - Bug fix: TBaseVirtualTree.OnGetHelpContext now delivers the currently focused column instead of always 0 - - Improvement: the sort operation can now be canceled - - Improvement: all BeginOperation/EndOperation pairs are now enclosed in try..finally blocks - - Bug fix: the combination of toUseExplorerTheme and toFullRowSelect now also works correct when no columns are - defined -December 2009 - - Bug fix: TVTHeader.HandleMessage now correctly handles double click autosizing when the index differs from - its position -November 2009 - - Bug fix: TBaseVirtualTree.AdjustTotalHeight didn't change the height of invisible nodes which caused some trouble - when making those nodes visible again - - Improvement: a column is no longer painted 'down' if its check box was clicked - - Bug fix: one can no longer toggle the check state of a column with the right mouse button - - Bug fix: one can no longer toggle the check state of a node with the right mouse button - - Bug fix: TCustomVirtualTreeOptions.SetPaintOptions no longer accidentally removed the the explorer theme - - Bug fix: Fixed a potential Integer overflow in TBaseVirtualTree.CalculateVerticalAlignments -October 2009 - - Bug fix: enabling checkbox support for a column is now possible without assigning a dummy imagelist - - Bug fix: checkboxes in the header are now correctly aligned - - Improvement: changed TBaseVirtualTree.PaintCheckImage to be usable by TVirtualTreeColumns.PaintHeader to be - able to paint themed header checkboxes - - Bug fix: TBaseVirtualTree.GetCheckImage now correctly handles cases when Node is nil and ImgCheckType is either - ctTriStateCheckBox or ctNone - - Bug fix: TBaseVirtualTree.HasImage now implicitly initializes the given node if needed to avoid requesting the - imageindex for nodes that are not initialized - - Bug fix: fixed possible AV when setting toExplorerTheme with no columns defined - - Improvement: new events TBaseVirtualTree.OnSaveTree and TBaseVirtualTree.OnLoadTree -September 2009 - - Bug fix: TBaseVirtualTree.OnColumnClick will no longer be triggered twice - - Improvement: new TVirtualNodeInitState ivsReInit to indicate that a node is about to be re-initialized - - Bug fix: TCustomVirtualStringTree.DoTextMeasuring now makes use of the parameter Width of the - OnMeasureTextWidth event - - Bug fix: TBaseVirtualTree.DetermineLineImageAndSelectLevel will no longer access LineImage[-1] - - Bug fix: clearing the columns now correctly reset TBaseVirtualTree.FFocusedColumn - - Improvement: explorer style painting is now more close to the real explorer - - Bug fix: TCustomVirtualStringTree.TContentToHTML.WriteStyle will no longer produce invalid CSS - - Bug fix: the parameter DragEffect of TBaseVirtualTree.DragAndDrop is now var as it should be -August 2009 - - Bug fix: TBaseVirtualTree.MoveTo now initializes the target node using the target tree - - Bug fix: TBaseVirtualTree.FVisibleCount is now calculated correctly when using filtered nodes - - Improvement: introduced new initial node state ivsFiltered -July 2009 - - Improvement: modified TVTHeader.HandleHeaderMouseMove to make resizing the autosize column with the - mouse possible - - Improvement: modified TBaseVirtualTree.DoCreateEditor so that applications can now return NIL in OnCreateEditor - to use the standard editor of the tree - - Bug fix: pressing CTRL + PgUp/PgDown no longer leads to an index-out-of-bounds exception if no columns are used - - Bug fix: avoided race condition between TBaseVirtualTree.DeleteNode and the worker thread - - Bug fix: TBaseVirtualTree.ToggleNode could produce an overflow if range checking was enabled - - Bug fix: TWorkerThread will no longer reference the tree after it has been destroyed (Mantis issue #384) - - Improvement: removed support for Delphi versions older than Delphi 7 - - Improvement: removed local memory manager -June 2009 - - Bug fix: TBaseVirtualTree.InternalConnectNode checked the expanded state of the wrong node if Mode was - amAddChildFirst or amAddChildLast - - Improvement: 'hidden nodes' are now called 'filtered nodes' - - Improvement: converted line endings back to CR/LF - - Improvement: new events TBaseVirtualTree.OnCanSplitterResizeNode and TBaseVirtualTree.OnCanSplitterResizeHeader - - Improvement: made TVirtualTreeColumns.DoCanSplitterResize virtual - - Improvement: made some methods of TVirtualTreeHintWindow protected to make subclassing easier - - Bug fix: fixed some issues concerning the vista theme handling - - Improvement: unified source code indentation -May 2009 - - Improvement: new TVTMiscOption toEditOnClick, toEditOnDblClick to control if editing can be started with a single - click or a double click - - Bug fix: the internal pointers of TBufferedAnsiString are now PAnsiChar to work correctly with Delphi 2009 -April 2009 - - Bug fix: TBaseVirtualTree.GetVisibleParent no longer returns the given node in case it is fully visible - - Improvement: fixed a potential issue in TVirtualTreeColumns.TotalWidth in case it is called before - FPositionToIndex is initialized - - Bug fix: TBaseVirtualTree.CollectSelectedNodesLTR and TBaseVirtualTree.CollectSelectedNodesRTL handle straight - vertical selection rectangles no longer as empty - - Bug fix: TCheckImageKind.ckSystemDefault now works as intended - - Improvement: made the following methods of TBaseVirtualTree virtual: PrepareCell, AddChild, BeginUpdate, - EndUpdate and SortTree - - Improvement: made TBaseVirtualTree.PrepareCell protected - - Improvement: moved some members of TVTEdit and TStringEditLink from private to protected - - Improvement: re-designed header click handling - - Improvement: new TVTPaintOption toShowHiddenNodes to globally ignore the hidden state of nodes - - Improvement: individual nodes can now be hidden without affecting their children - - Improvement: re-designed Explorer theme drawing - - Bug fix: corrected allocation problems in TBufferedAnsiString and TWideBufferedString -March 2009 - - Bug fix: fixed an issue in TVirtualTreeColumns.HandleClick that could lead to a case where no header click event - is triggered - - Bug fix: fixed an issue in TBaseVirtualTree.HandleHotTrack that could lead to an endless loop under certain - conditions - - Improvement: removed unused variables in TVirtualTreeColumn.ComputeHeaderLayout - - Bug fix: corrected TBaseVirtualTree.GetVisibleParent - - Improvement: extended hot node tracking to track the hot column too - - Improvement: new THitPosition hiOnItemButtonExact used to draw hot buttons when using Windows Vista's Explorer - theme - - Improvement: new TVTPaintOption toHideTreeLinesIfThemed to consider toShowTreeLines only if running unthemed - - Improvement: new TVTPaintOption toUseExplorerTheme to draw the tree like Windows Vista's Explorer treeview -February 2009 - - Bug fix: reverted the implementation of DrawTextW back to the one prior to 4.8.1 as the line end detection - lead to a compiler warning under Delphi 2009 - - Bug fix: corrected implementation of GetStringDrawRect to match its declaration (UnicodeString vs WideString) - - Bug fix: the node focus will no longer change if a TVTMiscOption.toGridExtensions is set and one clicks right of - (or left of, if right-to-left reading) the last column - - Bug fix: fixed an issue with TVTHeader.Assign that could lead to an access violation if the header is created at - runtime - - Bug fix: one can no longer change a node's height with the right mouse button even if toNodeHeightResize and - toRightClickSelect are set - - Improvement: TVTAutoOption.toDisableAutoScrollOnFocus now works for nodes too - - Improvement: new property TBaseVirtualTree.SelectionLocked to disable changing the selection - - Improvement: made the dual-scroll effect in TBaseVirtualTree.ToggleNode much smoother - - Bug fix: removed off-by-1 errors in TBaseVirtualTree.ToggleNode - - Bug fix: added a check for FUpdateCount to TBaseVirtualTree.SetUpdateState as otherwise every call to - TBaseVirtualTree.DoBeforeCellPaint to get the cell content margin within an Begin/EndUpdate-block would - re-enable painting - - Bug fix: TVTHeader.HandleMessage could provide a wrong column index to OnBeforeColumnWidthTracking in some cases - - Improvement: new properties TBaseVirtualTree.OnBeforeAutoFitColumn, TBaseVirtualTree.OnAfterAutoFitColumn - - Improvement: new procedures TBaseVirtualTree.CancelOperation, TBaseVirtualTree.BeginOperation, - TBaseVirtualTree.EndOperation and new property TBaseVirtualTree.OperationCanceled to enable the - application to stop (possibly) long-running operations - - Improvement: integrated changes from Andreas Hausladen - - Improvement: integrated changes from Dmitry Zegebart where applicable - - Bug fix: removed off-by-1 error in TBaseVirtualTree.GetDisplayRect - - Bug fix: changed the size of the buffer used in TBaseVirtualTree.PaintTree to paint the area below the last node - as the bitmap was not completely erased using previous size under certain conditions - - Bug fix: fixed TBaseVirtualTree.GetPreviousLevel -January 2009 - - Bug fix: removed off-by-1 error in TBaseVirtualTree.GetBottomNode - - Improvement: improved speed of TBaseVirtualTree.GetMaxColumnWidth when using UseSmartColumnWidth - - Version is now 4.8.0 -December 2008 - - Bug fix: modified TBaseVirtualTree.UpdateHorizontalScrollbar and TBaseVirtualTree.UpdateVerticalScrollbar to - recalculate the tree's dimensions even if an update is in progress - - Improvement: renamed TVTHeaderState hsTracking and hsTrackPending to hsColumnWidthTracking and - hsColumnWidthTrackPending - - Improvement: modified TBaseVirtualTree.GetFirstVisible and TBaseVirtualTree.GetFirstVisibleNoInit to optionally - take a node to specify where to start - - Improvement: modified TVTAfterGetMaxColumnWidthEvent to make the result of TBaseVirtualTree.GetMaxColumnWidth - changable - - Bug fix: corrected TBaseVirtualTree.GetMaxColumnWidth to consider toFixedIndent and no longer take nodes into - account that are just above or below the visible area - - Improvement: new property TVirtualTreeColumns.DefaultWidth - - Improvement: new property TVTHeader.FixedAreaConstraints (new class TVTFixedAreaConstraints) to limit the - fixed area (header, fixed columns) to a percentage of the client area -November 2008 - - Improvement: new cursor added: crVertSplit used for height tracking - - Improvement: changed type of TVTHeader.Height from Cardinal to Integer to make boundary checks easier - - Improvement: new properties TVTHeader.MinHeight and TVTHeader.MaxHeight - - Improvement: new VirtualTreeStates tsNodeHeightTracking and tsNodeHeightTrackPending - - Improvement: new HeaderStates hsHeightTracking and hsHeightTrackPending - - Improvement: new TVTMiscOption toNodeHeightResize to allow changing node heights via mouse - - Improvement: new TVTHeaderOption hoHeightResize to allow changing header height via mouse - - Improvement: new properties TBaseVirtualTree.OnHeaderHeightTracking, TBaseVirtualTree.OnHeaderDblClickResize, - TBaseVirtualTree.OnColumnWidthTracking, TBaseVirtualTree.OnColumnWidthDblClickResize, - TBaseVirtualTree.OnNodeHeightTracking, TBaseVirtualTree.OnNodeHeightDblClickResize - - Improvement: new function TVTHeader.ResizeColumns to resize multiple columns at once - - Improvement: TVTHeader.DetermineSplitterIndex is no longer influenced by non-resizable columns - - Bug fix: TBaseVirtualTree.ToggleNode now uses DoStateChange to modify FStates - - Bug fix: TBaseVirtualTree.DoBeforeCellPaint now saves the update rect if CellPaintMode is cpmGetContentMargin - and restores it afterwards - - Improvement: modified TBaseVirtualTree.CmMouseWheel to handle mice with wheel delta < 120 correctly - - Improvement: modified TVTHeader.LoadFromStream and WriteToStream to save ParentFont - - Improvement: TVTHeader.Font is now only stored by Delphi if ParentFont is False (Mantis issue #217) - - Bug fix: corrected TVTHeader.Create to set TVTHeader.FOptions correctly to the default value (Mantis issue #333) - - Improvement: new TVTAnimationOption toAdvancedAnimatedToggle to scroll the node to be toggled animatedly instead - of just scroll its child nodes animatedly - - Improvement: added VirtualTreeState tsToggling to eliminate artefacts caused by TBaseVirtualTree.DoSetOffsetXY - while toggling - - Bug fix: corrected button handling when toFixedIndent is set - - Improvement: redesigned TBaseVirtualTree.ToggleNode to harmonize the visual toggle behaviour independent of - toChildrenAbove - - Improvement: made TBaseVirtualTree.CanEdit public - - Improvement: added parameter ConsiderChildrenAbove to TGetNextNodeProc - - Improvement: modified all variants of TBaseVirtualTree.GetFirst and TBaseVirtualTree.GetLast to optionally - consider toChildrenAbove -October 2008 - - Bug fix: removed 'FVisibleCount := 0' from TBaseVirtualTree.Clear as this would lead to incorrect VisibleCount in - read-only mode - - Bug fix: fixed a condition in TBaseVirtualTree.ToggleCallback that could lead to artefacts - - Improvement: changed the implementation of TBaseVirtualTree.GetNext/GetPrevious so that no penalties occur if - toChildrenAbove is not set - - Improvement: TBaseVirtualTree.ToggleNode will no longer leave nodes with state vsToggeling if an exception - occurs - - Improvement: improved behaviour of TBaseVirtualTree.ToggleNode in case toChildrenAbove is set - - Bug fix: corrected TBaseVirtualTree.ScrollIntoView to behave as expected when no fixed columns exist - - Bug fix: extended TBaseVirtualTree.InitializeLineImageAndSelectLevel to eliminate artifacts while scrolling with - toChildrenAbove set - - Bug fix: corrected CompareNodePositions to consider toChildrenAbove - - Bug fix: corrected ToggleNode to scroll correctly if toChildrenAbove and toAnimatedToggle are set - - Improvement: new TVTPaintOption toFixedIndent to draw the tree with a fixed ident (instead of node level - dependent indents) - - Improvement: new TVTPaintOption toChildrenAbove to draw children nodes above their parent -August 2008 - - Improvement: redesigned and overloaded TBaseVirtualTree.ScrollIntoView in order to use vertical scrolling - separately - - Improvement: optimized TBaseVirtualTree.ScrollIntoView for horizontal scrolling - - Improvement: in TBaseVirtualTree.WMKeyDown column navigation for VK_PRIOR and VK_NEXT is now handled in same way - as row navigation - - Improvement: new TVTHeaderOption hoDisableAnimatedResize to disable animated resize for all columns - - Improvement: new TVTColumnOption coDisableAnimatedResize to disable animated resize for a specific column - - Improvement: in TBaseVirtualTree.UpdateHorizontalScrollBar and TBaseVirtualTree.UpdateVerticalScrollBar scrollbar - updates now avoided for tsUpdating in FStates -July 2008 - - Improvement: in TBaseVirtualTree.WMHScroll the horizontal page scrolling now considers fixed columns - - Improvement: in TBaseVirtualTree.ScrollIntoView the case of FFocusedColumn being invalid is considered - - Improvement: in TBaseVirtualTree.HandleMouseDown DoFocusNode is not called if node focus did not change - - Improvement: in TBaseVirtualTree.SetFocusedColumn the focused node will only be invalidate if it was actually - scrolled into view - - Improvement: new TVTColumnOption coAllowFocus to affect column focus behaviour - - Improvement: new function TVTHeader.AllowFocus to check wether a column can be focused - - Improvement: in TBaseVirtualTree.SetFocusedColumn the old colunm and the new column are both invalidated - - Improvement: merged latest changes from Jim into current code base. -June 2008 - - Improvement: new property TVirtualTreeColumns.Count - - Bug fix: in TVirtualTreeColumns.AnimatedResize the column is validated (to avoid "List index out of bounds") - - Improvement: the content retangle of the cell can be modified via the OnBeforeCellPaint event, the cell paint - mode indicates wether OnBeforeCellPaint is called for painting the cell or just for getting the - cell content margin - - Improvement: new functions added: TBaseVirtualTree.DoGetCellContentMargins, - TCustomVirtualDrawTree.DoGetCellContentMargin - - Improvement: new property: TCustomVirtualDrawTree.OnGetCellContentMargin - - Improvement: in TBaseVirtualTree.GetMaxColumnWidth the cell content margin is considered - - Improvement: in TBaseVirtualTree.CMHintShow the cell content margin is considered for singleline tooltips - - Improvement: new function added: TVTHeader.DoGetPopupMenu (to query the application via TreeView.FOnGetPopupMenu - for a column specific header popup menu) - - Improvement: new property added: TBaseVirtualTree.OnCanSplitterResizeColumn, - new function added: TVirtualTreeColumns.GetScrollWidth - - Improvement: horizontal page scrolling now uses the average column width (of all visible, non-fixed columns) as - scroll amount - - Improvement: procedure TBaseVirtualTree.CMMouseWheel redesigned - - Bug fix: TVTHeader.DetermineSplitterIndex works correctly even when using fixed columns - - Bug fix: on right-to-left BiDiMode TVirtualTreeColumns.PaintHeader respects (left) scroll bar correctly - - Bug fix: for multiline tooltips also the column width is checked to determine the tooltip is needed or - unnecessary - - Improvement: the result value of GetUseSmartColumnWidth is initialized correctly - - Improvement: added hoFullRepaintOnResize to TVTHeaderOption to enable full header repainting (instead of - repainting all subsequent columns only) on resizing a column - - Bug fix: horizontal page scrolling via mouse wheel now works correctly, i.e. in TBaseVirtualTree.CMMouseWheel - ScrollCount includes GetVisibleFixedWidth and FIndent - - Improvement: new TVTColumnOption coSmartResize to avoid contradicting the virtual paradigm - - Improvement: horizontal scrolling via mouse wheel can be forced by holding the shift key - - Improvement: new parameter for function TBaseVirtualTree.GetMaxColumnWidth added: UseSmartColumnWidth (to - avoid contradicting the virtual paradigm, i.e. leave nodes out of consideration which are not in - view) - - Improvement: new parameters for TVTHeader.AutoFitColumns added: SmartAutoFitType, RangeStartCol and - RangeEndCol - - Improvement: new parameters for events FOnAfterAutoFitColumns, FOnBeforeAutoFitColumns, FOnAfterGetMaxColumnWidth - and FOnBeforeGetMaxColumnWidth added - - Version is now 4.6.0 -May 2008 - - Improvement: new properties: FOnAfterAutoFitColumns, FOnBeforeAutoFitColumns, FOnAfterGetMaxColumnWidth and - FOnBeforeGetMaxColumnWidth - - Bug fix: FDropTargetNode is considered in TBaseVirtualTree.DoFreeNode -August 2007 - - for accessibility, added an OnGetImageText event that can be used to give accessible text to images used in nodes. - - Implemented an ImageText property used by the VTAccessibility unit to retrieve text for a given node and its column. - - Switched loading of accessibility libraries to dynamic from static to avoid problems in Win95 -June 2007 - - Bug fix: Fixed a problem with potentially large amount of nodes (larger than 2 billion) in - TBaseVirtualTree.SetChildCount. - - Bug fix: remove hint if any in case the tree loses the focus. - - Improvement: TVirtualTreeColumns.HandleClick is now virtual, introduced TVTHeader.DoSetSortColumn. - - Bug fix: compiler error due to old variable reference when enabling flat scrollbars. -May 2007 - - Improvement: new functions: GetPreviousSelected, GetPreviousChecked, GetCheckedCount, - GetPreviousCutCopy, GetCutCopyCount, GetFirstLeaf, GetNextLeaf, - GetPreviousLeaf, GetFirstLevel, GetNextLevel, GetPreviousLevel - - Improvement: new properties: CheckedCount, CutCopyCount - - Improvement: DoFocusChanging for finding a valid column (TBaseVirtualTree.WMKeyDown) -March 2007 - - Improvement: adjusted accessibility implementation to compile with pre-BDS IDEs. - - If a column is not visible, MultiColumnAccessibility now will not include it. -January 2007 - - Improvement: added code donation from Marco Zehe (with help from Sebastian Modersohn) which implements the - MS accessibility interface for Virtual Treeview. -December 2006 - - Improvement: bidi mode implementation finished (toAutoBidiColumnOrdering introduced) - - Change: right-to-left flag removed from shorten string methods/events (not necessary) - - Version is now 4.5.0 -November 2006 - - Bug fix: Total height is wrong on reading from stream -September 2006 - - Bug fix: Mantis issue #326 -July 2006 -- Change: value for crHeaderSplit cursor conflicts with other resource IDs, so I changed it. -- Published OnStartDrag in VirtualDrawTree. -April 2006 - - Bug fix: check for MMX availabiltiy is missing in some places before calling MMX code - - Bug fix: flag for VCL dragging was removed too late causing all kind of problems with mouse up code in VCL drag mode. - - Bug fix: If the past mode in ProcessOLEData is amInsertAfter then nodes where inserted in the wrong order. -March 2006 - - Bug fix: total count and total height is wrong after loading from stream - - Bug fix: variable node height computation - - Bug fix: FLastChangedNode was not reset in DoFreeNode -February 2006 - - Improvement: GetFirstChecked now also has a default value for its state parameter. - - Improvement: avoid potential reentrancy problems in paint code by checking for the paint state there. -January 2006 - - Bug fix: disabled images are now drawn like enabled ones (with respect to position, indices etc.). - - Improvement: New property BottomSpace, allows to specify an additional area below the last node in the tree. - - Bug fix: VT.EndUpdate did not invalidate the cache so the cache was never used again after that. - - Improvement: tree states for double clicks (left, middle, right). -December 2005 - - Bug fix: check for column index for auto setting main column if the current one is deleted. - -For full document history see help file. - * Fixed issue #692: HitInfo for OnNodeClick event may differ much from HandleMouseDown - * Fixed issue #687 by extracting new method DeleteNodes() from existing DeleteSelectedNodes(). - * Fixed issue #689: Possible Integer overflow in PaintColumnHeader() when dragging a column to first position. - * Fixed issue #693: TVirtualTreeAccessibility.accSelect() should handle the flag SELFLAG_EXTENDSELECTION - * Fixed issue #690: Tree shouldn't keep selected elements, if toAlwaysSelectNode is set and other elements are selected without ctrl-modifier - -V6.5: (18 Jan 2017) - * License change from LGPL to "LGPL with static linking exception". See issue #673 for details. - * Enhancement #662: Background image now supports transparency - * Fixed #677: Improved per monitor dpi awareness. NodeHeight is now scaled as well if toAutoScale is set. - * Fixed #289: HintMode hmHintAndDefault: Default Hint does not change to node specific hint when the mouse is moved to a node. - * Fixed #674: HintMode hmHintAndDefault: If the BidiMode is right to left, the Default Hint fails to appear - * Fixed #139: hoDblClickResize doesn't work correctly with InitalState ivsMultiline - * Fixed #668: Removed unnecessary #include - * Fixed #670: Make it possible to override RangeX - * Fixed #676: VCL themed scrollbar does not update correctly after adding children - * Fixed #626: Wrong hot node selection during mouse movement over different nodes - * Fixed #679: The OnChange event when right clicking a node should always be fired before the OnPopup event - * Fixed #678: Occasional Access Violation in GetDisplayRect - * Fixed #682: Drag & Drop range exception - -V6.4.1: (26 Oct 2016) - * Fixed #549: Drawing issue with toCheckSupport an toExtendedFocus - * Fixed #663: Exception pressing return on an edited item with no columns) - * Fixed #661: Minimal Demo 2 different problems, can't select on start up, multiple clicks causes error - * Fixed problem with wrongly drawn checkbox in column headers. - * VirtualTreePerItemAction now initializes all nodes before it works with them and changes e.g. the check state. - * TBaseVirtualTree.DoGetImageIndex() now always tries to assign a default image list as result, even if OnGetImage and OnGetImageEx are not assigned. So derived controls do not need to make this step. - -V6.4: (28 Sep 2016) - * Fixed #622: [BREAKING CHANGE] Removed all 16x16 fixed sized checkbox-imagelists. - The property CheckImageKind supports the values ckSystemDefault and ckCustom only and should be considered deprecated. - * Fixed #640: Edit control for in-place editing wrongly scaled in high-dpi scenarios - * Fixed #627: It should be possible to use OnGetImageIndexEx without having imagelists assigned - * Added assertion that verifies if an imageindex is supplied but no valid imagelist is available for this imageindex - * Fixed #148: Background Images now support other formats than just bitmaps. - * Fixed #623: GetHint calculates wrong width for HintText - * Fixed #633: High dpi scaling was performed two times - * Fixed #544, #427: Header painting problem with BiDiMode right to left - * TBaseVirtualTree.EnsureNodeSelected() only scrolls the selected node into the view, if no one was previously selected. - * Fixed #248: VT Header draws smudged - * Fixed #643: VT Header dropmark appears even if dragged column won't change position - * Fixed #310: Incorrect selection paint when toAutoSpanColumns, toGridExtensions and toExtendedFocus are set - * Fixed #653: GetFirstVisibleChild/NoInit check for wrong node if IncludeFiltered=True (thx to A. Hausladen) - * Fixed #659: GetLastVisibleChild/NoInit checks wrong node - * Fixed #647: New option to set the way of selecting next cell for editing in grid mode - * Fixed #645: Can't link 64 bit VCL app with VirtualTreeView in C++ Builder 10.1 Berlin - * Fixed #656: Fixed memory leaks in Advanced Demo - * Enhancement #631: Added new Demo project CharityEvents to demonstrate the use of Interfaces for node's data and for data presentation - * Fixed #658: Column Header does not paint correctly after a drop in certain conditions - * Fixed #639: Scrolbars are not correctly themed under certain cirumstances when using a VCL theme. - * Fixed #624: Wrong y-postion of checkboxes in high-dpi display mode - * Fixed #548: Add flag coStyleColor to TVirtualTreeColumn.Options (prefer background color of VCL style over TVirtualTreeColumn.Color) - * Fixed #660: Fix AV when tree is modified in OnEdited event - * Some minor tweaks on Virtual TreeView source code and sample projects - -V6.3: (17 May 2016) - * Added support for RAD Studio 10.1 Berlin - * Implemented #607: Disabled checkbox images should be available - * Fixed #612: hotkey handing and toReverseFullExpandHotKey - * Fixed #602: Dangling WM_Timer and doubled OnChange calls - * Fixed #606: High DPI Inheritance of Form. TBaseVirtualTree.ChangeScale() now respects inherited property ScalingFlags - * Fixed #608: Horizontal lines paint bug on scroll. - * Fixed #605 : If a new node is selected by left click, OnChange event should not fire with `nil` in-between. - * TBaseVirtualTree.EnsureNodeSelected() no longer changes scroll position unless necessary to make the selected node visible. - * Pull request #609: Updated unit "Contributions/GenericWrapper/VirtualTreeWrapper.pas" - * Started adding unit tests with DUnitX. - * Minor tweaks. - -V6.2.3 (11 Feb 2016) - * Fixed accidental remove of vsReleaseCallOnUserDataRequired flag which can cause mem leaks. - * TVirtualNode.SetData() now sets the vsOnFreeNodeCallRequired flag for all types of user data and so is consisted with other SetData / GetData methods. - * TCustomVirtualStringTree.SetChildCount() now calls ResetInternalData()= with Recurse = False to avoid that all siblings of the new children are reseted recursively. See isuue #576 - * TCustomVirtualStringTree.ResetInternalData() now respects the Recursive parameter - -V6.2.2 (20 Jan 2016) - * Issue #603: If the node already has children, then its nodeheight is valid and we must not remove its total height, but rather its height - * Fixed issue #599: Possible infinite loop in GetPreviousVisibleNoInit() - * Added new method TBaseVirtualTree.InitRecursive() as workaround for issue #597: Initializes a node and optionally its children up to a certain level. - * Issue #598: SetData, like GetData no longer forces the "class" constraint on its generic parameter - * Fixed issue #596 by moving initialization of global variable Watcher also to InitializeGlobalStructures() - Now ensuring using interlocked function that InitializeGlobalStructures() is executed only once - * Fixed issue #458: If the Virtual TreeView control is placed on a control that has the StyleEx flag WS_EX_COMPOSITED set, horizontal scrolloing does not update the header - * Fixed issue #595: Before using SetTimer, check for valid WindowHandle - * Fixed issue #594: Basic TVirtualStringTree Colors does not apply - * Fixed issue #591: Now calling UnRegisterStyleHook() for the style class in "VirtualTrees.StyleHooks". - * Fixed #590: Allow to store InternalData also for (internal) root node - * if only one node is selected, make sure the focused node changes with the selected node - * Added assertion that ensures that BeginUpdate() is called from main thread only. - * Getter function GetCheckedCount() is protected now instead of public - -V6.2.1 (06 Nov 2015) - * #585: Checkboxes now have the correct size and scale properly on high dpi systems. - * #588: Fixed HTML clipboard export - * #586: TBaseVirtualTree.SetChildCount() no longer calls to ReInitNode(Node, True). This caused the OnInitChildren-Event to be fired twice. - * Adjusted GetNodeDataAt() and GetFirstSelectedNodeData() to work with interfaces. - * If multi selection is not allowed and so only one node can be selected, make sure the focused node changes with the selected node in SetSelected() - * Added packages for the C++Builder 10. - -V6.2 (09 Sep 2015) - * Issue #582: Added support and packages for RAD Studio 10 Seattle - * Issue #580: Added support for Delphi package manager Delphinus - * Fixed issue #571: Grid mode and extended selection leads to drawing inconsistencies - * Fixed issue #569 which includes a fix for AddChild(). - * Fixed issue #568: Integer overflow when reiniting nodes and using ivsFiltered - * Merged pull request #564 which includes a fix for ComputeNodeHeight() and single line nodes - * Merged pull request #563 which prevents an access violation when using custom check images in column headers - * Merged pull request #561 which makes VclStyleChanged() virtual - * Fixed issue #557: Using isFiltered in InitNode leads to integer overflows or bogus rendering - * Fixed issue #556: Variable height and more than 1 level results in incorrect RangeY - * Fixed issue #555: The OnChange event is not fired in case the selected node is deleted through DeleteChildren(). Although no the option toAlwaysSelectNode is set, the parent node was not selected afterwards. - * Fixed issue #553: painting failure with variable NodeHeight - * Fixed issue #551: Some overlay images were drawn ghosted like the main image, some not. - * TBaseVirtualTree.PrepareBitmaps() now fires the OnPrepareButtonImages event also in case VCL styles are used. - * Added implementation for TVirtualTreeAccessibility.accSelect() so that screen readers and especially UI testing tools can use MSAA to select specific elements in the control. - * Property OnColumnVisibilityChanged is now published. - * Now using type TImageIndex instead of integer for variables and parameters that store an image index. - -V6.1 (02 June 2015) - * Implemented Issue #530: Removed all AnsiString code from export routines. Breaking changes: - - TCustomVirtualStringTree.ContentToText() is now based on (Unicode)string and no longer on AnsiString. - - TCustomVirtualStringTree.ContentToUnicode() is now deprecated, use ContentToText() instead. - * Implemented issue #536: Add export event that is triggered for each cell - - Added new event OnGetCellText which has new TVSTGetCellTextEventArgs record as parameter. - This event could supersede the OnGetText event in a future version. - - All export formats now also export static text, in case the toShowStaticText flag is set - * Fixed issue #545: VCL Themes: Background of scrollbars is erased with wrong color - * Fixed issue #487: When OnAddToSelection is called, GetFirstSelected returns nil - * Fixed issue #542: AllocateInternalDataArea() was broken for derived classes - This was a result of issue #507. Now the user node data comes before the internal data. - Therefore it is important to use the function InternalData() to access the internal data of a node. - * Fixed issue #541: Duplicate call of EndEdit() - * Fixed issue #123: Triangle button is not shown for hot node - * Fixed issue #347: With VCL-Themes: No expand-pluses seen under Windows classic theme - * Fixed copy&paste error is source code related to issue #519 - -V6.0 (13 Apr 2015) - * Issue #509: Added new option hoAutoColumnPopupMenu to TVTHeaderOption. - * Issue #457: Virtual TreeView no longer react on standard actions for TEdit controls - We added standard actions for copy, cut, paste, delete, select all, check, uncheck in the new unit "VirtualTrees.Actions". - * Issue #484: ContentToHTML() no longer pre-encodes the HTML in UTF-8 but returns a Unicodestring - * Issue #507: Added to TBaseVirtualTree: - function GetNodeData(pNode: PVirtualNode): T; - function GetNodeDataAt(pXCoord: Integer; pYCoord: Integer): T; - function GetFirstSelectedNodeData(): T; overload; - function GetInterfaceFromNodeData(pNode: PVirtualNode): T; - procedure SetNodeData(pNode: PVirtualNode; pUserData: Pointer); - procedure SetNodeData(pNode: PVirtualNode; const pUserData: IInterface); - procedure SetNodeData(pNode: PVirtualNode; pUserData: T); - Similar functions have also been added to the TVirtualNode record. - * The grid demo of the "Advanced" project now uses a class instead of a record and the new generic functions from issue #502. - * Issue #519: Changed plus/minus buttons so that hot tracking of the buttons is always on, independent of toHotTrack. - * Issue #514: The splitter area in the column header should be configurable - * Issue #515: The value for Indent should get scaled too if the toAutoScale flag is set - * Issue #511: From the unit VirtualTres new units have been extracted to reduce its size. - * Issue #483 for TVTOperationKind.okExport: All exports can now be cancelled using CancelOperation() - * Issue #362: InternalConnectNode: AdjustTotalHeight not called if Node not FullyVisible - * Issue #506: Autosort is being triggered at design-time. - * Issue #486: AutoScroll is performed although toAutoScroll is not set. - * DoMeasureItem() now ensures that the node was initialized. - * Issue #493: Editing with DblClick should always open editor immediately. - * TVirtualTreeColumns.UpdatePositions() now exits immediately if the control is destroying, ths prevents AVs. - * Added support for CBuilder XE7. - * A larger patch from Diemtar Rösler was applied which addresses various issue regarding VCL styles (especially #478 and #491). - * Supporting only Delphi / C++ Builder XE3 and higher - * Improved support for C++ Builder - -V5.5.3: (08 Jan 2015) - * Fixed issue #495: Incorrect text vertical align when changing font in OnPaintText - * Fixed Issue #496: Access violation at VT destroy - * Fixed issue #498: Node totalheight not initialized properly when adding new node and using toVariableNodeHeight - -V5.5.2: (10 Nov 2014) - * Various improvements regarding code style - * Implemented #471: Add emVisibleDueToExpansion and emSelected to TVTExportMode - * Fixed issue #488: XE7 packages should depend on one another and use suffix 21 - * Fixed issue #462: Undo r636, make VirtualTreesD require VirtualTreesR again - * Fixed issue #489 XE2 compiler switch error - -V5.5.1: (13 Oct 2014) - * Fixed issue #479: The style hooks for the VCL styles are now registered for TVirtualStringTree and TVirtualDrawTree instead of TBaseVirtualTree, which makes it easier to use own style hooks in derived classes. - * Partial fix for issue #478: The standard VCL property StyleElemets (public in TControl in RAD Studio XE3 and higher) is now supported and published for TVirtualStringTree and TVirtualDrawTree (XE3 and higher). This means you can define if the font and the backgrounbd color is taken from the VCL style or the control's properties. Leaving out seBorder is not yet working well, more work will be necessary. - * Fixed issue #473: Return type of GetUtilityImages should be TCustomImageList - * Fix for issue #470: VCL Styles and sorting failure - * Added missing inherited to CMMouseEnter() - * Fixed issue #468: Redundant code in CreateSystemImageSet() - * Fixed issue #482: AutoScale() could cause exception during form load. - * Added fix for #466: No parent window if column created in constructor - * Fixed issue #446: ScrollIntoView does not work properly after applying patch from issue #339 - * Improvements for toAlwaysSelectNode option: Selection of next sibling has been improved in case the currently selected node is being removed. - * Added missing begin/end-block in MeasureItemHeight() - * Improved fix for issue #438: Now correctly initializing member of property TVTColors.UnfocusedColor - * Improved fix for issue #447: DoMeasureItem() was called for Node instead of Child. - * Minor improvement in appearance of border lines in HTML export. - * Fixed issue #480: Warning when compiling Delphi XE2 packages - * Fixed #472: Redundant conditions in TVclStyleScrollBarsHook.WMMouseMove - * Fixed #476: Simplify TVTDragImage.WillMove() - * Fixed issue #485: unit VirtualTrees does not compile with {$TYPEDADDRESS ON} - -V5.5: (11 Sep 2014) - * Added packages for RAD Studio XE7 / Delphi XE7 - * Fixed issue #464: Vertical grid lines not computed correctly for spanned cells with header auto resize - * Fixed issue #442: Scrollbars are not updated for active VCL Style under XE2 - * Fixed issue #463: HTML export shows grid lines in IE and Chrome, but not in Firefox - * Fixed issue #460: Access violation in design time when setting "CheckBox" to True for a Virtual Treeview Column - * Fixed issue #72: Call Application.CancelHint only if the current control is showing the hint - * Fixed issue #461: corrected condition in TBaseVirtualTree.ScrollIntoView, so that not only partially (by the fixed area) covered columns but also totally covered columns are scrolled in view - * Fixed issue #450: Regional letters entered using Right+Alt should also trigger the incremental search. - * Improvemtns for toAlwaysSelectNode: - Clicking the free space below the tree nodes no longer deselects the selected node. - We now prevent toggling of the selection of the last selected node if toAlwaysSelectNode is set in TreeOptions. - * Fixed issue #447: SetChildCount() now calls DoMeasureItem() instead of using DefaultNodeHeight. - * Fixed issue #444: ERangeError in TBaseVirtualTree.CMMouseWheel - * TBaseVirtualTree.MeasureItemHeight() is virtual now. - * Fixed issue #445 MultiSelect behavior: Can't drag node which is not selected - * Fixed Issue #443: TVirtualTreeColumns.ColumnFromPosition on right border of fixed column - * Fixed issue #339: Problems with fixed column - * Implemented #410: Small extension of TStringEditLink: Allow creating own edit control by moving the creation of TVTEdit from constructor to virtual PrepareEdit with assigned check. - * Implemented #409: Extend THitInfo record with hit coordinates - * Added suggestions of #438: Make some members visible to derived classes - * Fixed issue #440: Context menu does not pop up if there is no selected node - * Added C++ Builder link demand to VirtualTreesR.Lib as {$HPPEMIT} - * Improved installation instructions, especially for C++ Builder - -V5.4.1: (26 May 2014) - * Added packages for C++ Builder XE6 - * If toAutoChangeScale is set in AutoOptions, the Virtual TreeView control now - increases the DefaultNodeHeight if the font size is too large to fit. - * If toAutoChangeScale is set in AutoOptions, the columns widths are now adjusted too. - * Improved implementation for toRestoreSelection option - * Fixed possible AV in PaintNodeButton() - * Now ensuring that both GetHorzScrollBarSliderRect() and - GetVertScrollBarSliderRect() return a valid value for every code path (Thx to - Dmitri Dmitrienko). This could cause strange out of resources exceptions with VCL - styles enabled. - * Fixed issue #434: Application compiled with Delphi 7 stops responding when you call AddChild - * A few minor changes - -V5.4.0: (22 Apr 2014) - * Added support for XE6. - * Added new option toRestoreSelection to TVTSelectionOptions: Set to true if upon refill the previously - elected nodes should be selected again. The nodes will be identified by its caption only. - * Added new option toAlwaysSelectNode to TVTSelectionOption enum. If this flag is set, the treeview tries to - lways have a node selected. This behavior is closer to the Windows TreeView and useful in Windows Explorer - tyle applications. It is also useful for accessible applications which can indicate having the focus by - isplaying a selection. - * Added function TBaseVirtualTree.IsEmpty which returns True if the control has no nodes. - * Fixed a wrongly drawn selection after the user scrolled horizontally. - * Fixed issue #423: Change property TVirtualTreeColumn.Tag to NativeInt. - * Implemented #415: Added feature for design time column header dragging and resizing. (Thx to fr0st.brutal) - * Fixed issue #180: Memory leak in grid demo of Advanced project - * Implemented #422: Added TBaseVirtualTree.GetFirstChildNoInit() - * Fixed issue #420: Add coEditable to TVTColumnOption) by applying the supplied path. Thx to Stefan Glienke. - * Fixed issue #419: Some issues with changing to edit mode with clicking - * Fixed issue #430: TVTDragManager memory leak with visual inheritance. Thx to Andreas Hausladen for the patch. - * Fixed issue #431: Visual bug when using TStringEditLink with large node heights - * TVclStyleScrollBarsHook.WMMouseMove(): Now preventing possible range check error exception. - * Now handling WM_MOVE and WM_POSCHNAGED correctly in TVclStyleScrollBarsHook (Thx to Dmitri Dmitrienko) - * Preventing possible stack overflow in TVirtualTreeHintWindow.ActivateHint (Thx to Dmitri Dmitrienko) - * Added packages for C++ Builder XE5. - * Some minor changes, improvements and fixes have been incorporated - -V5.3.0: (04 Jan 2014) - * Fix for issue #159 (Cursor missing in edit with non-standard DPI): Ensuring a minimum size of the edit control - * Fixed issue #403: Declare TVTGetNodeProc as reference to procedure (for D2009+) - * Fixed issue #402: TVTEdit.CNCommand discard all notification except EN_UPDATE due to missing inherited - * Corrected fix for issue #376 (Incorrect selection paint when toGridExtensions is included in the MiscOptions) - * Fixed issue #401: OnNodeClick event doesn't trigger in some case, coFixed set for a column - * Modified #316 (concerning r498). The fix for #316 will only be applied in case toMultiSelect is set. - If toMultiSelect is not set we can start a drag anywhere in the row. - * ContentToHTML() and ContentToRTF() now return a string of type RawByteString. - Because the generated strings are pre-encoded in UTF-8, the previous type AnsiString caused - problems in Delphi 2009+ e.g. when this string was written using the VCL TStreamWriter class. - The helper class TBufferedAnsiString therefore uses RywByteString now as type too. - * Fixed issue #399: EditDelay not working - * Fixed issue #400: AltGr+A does not behave as expected for foreign keyboard layouts in VTEdit - * Fixed issue #388: VirtualStringTree with toFixedIndent causes range check error - * Edit box when editing a node in a tree with toFixedIndent now has the correct indent - * Fixed issue #392: Now ensuring that MeasureItemHeight() is only called from the main thread. - * Fixed #383: Clear vsHasChildren for a node without children even if the children count didn't change. - * Fixed #377: Wrong font (size, etc) in TargetCanvas in MeasureItem for first node - * Fixed issue #398 (hoAutoResize causes DFM designer to be modified after loading) by calling TControl.Updating()/Updated() in AdjustAutoSize() - * Preventing possible AV in TBaseVirtualTree.FontChanged() - * Fixed 32Bit Integer overflows in Win64 build in TBufferedAnsiString. - -V5.2.2: (30 Oct 2013) -- Added support for Delphi / RAD Studio XE5 -- Fixed issue #371: property OnGesture is now published. -- Fixed issue #365: No longer changing timer resolution globally -- Fixed issue #347: No expand-pluses seen under Windopws classic theme for a vcl styled application -- Fixed issue #373: Scrollbar does not size properly for more than 2000 nodes with variable node height: - The OnMeasureItem event is triggered only in case the toVariableNode flags in included in MiscOptions -- Fixed issue #376: Incorrect selection paint when toGridExtensions is included in the MiscOptions -- Improved displaying of EmptyListMessage text, especially when scrolling horizontally. -- Fixed issue #61: EditCursor missing with manifest + toThemeAware + vsMultiline -- Fixed issue #352: Minor improvement in calculation of right margin of hint window. - -V5.2.1: (06 Sep 2013) -- Fixed #352 and #354 by modifying the implementation of #237 so that a focused node is ensured only if the - control is being entered using the TAB key. This is consistent with the behavior of the Windows Explorer. -- Fixed issue #360 (In the calculation of the horizontal scroll bar static text should be considered) by - calling DoGetNodeExtraWidth() in TBaseVirtualTree.GetMaxRightExtend() -- Used fix proposed in issue #361 to fix issue #357 (AV in advanced demo - PropertiesDemo form in XE3+) -- Removed call to TCustomStyleEngine.UnRegisterStyleHook() to fix issue #359/#355 -- Fixed issue #358: Horizontal Scrollbar issue when expand ing and scrollbars get visible -- Fixed issue #355/#345: exception regarding style services - -V5.2: (09 Aug 2013) -- OnMouseEnter and OnMouseLeave events have been added (#238) -- Improved dpi scaling for VirtualTreeView and Header -- toAutoChangeScale and toAutoSort are now among the defualt values for TCustomVirtualTreeOptions.AutoOptions -- Fixed issue #237: Auto focus the first node on enter if there is no focused node -- Fixed issue #344: Cannot select row by Ctrl+Click on empty column -- Fixed issue #206: Column painting issue with coWrapCaption in Options -- Fixed issue #128: OleUninitialize in FinalizeGlobalStructures can hang when using Virtual Treeview in a DLL -- Added new public property LastDragEffect which supplies the last executed drag effect. -- Added virtual method GetNodeImageSize() which can be overridden if one needs different sized images. -- Added new public property LastDragEffect which supplies the last executed drag effect. -- Fixed issue #206: Column painting issue with coWrapCaption in Options -- Fixed issue #336 by ignoring PARENTDOUBLEBUFFEREDCHANGED message. -- Fixed issue #342 by adding a new implementation of the VCL's DoubleBuffered property. - The inherited DoubleBuffered property of TWinControl must not be set to True! -- A few minor improvements have been added. - -V5.1.3: (17 Apr 2013) -- Fixed #340: GetHitTestInfoAt on right border of fixed column. -- Fixed #337: Cannot "grab" item for dragging, odd behaviour of multi selecting with the selection - rectangle when toFullRowSelect is True but toSimpleDrawSelection is False. (thx to Stefan Glienke) -- Fixed #341: Error when unloading DLL due to missing UnRegisterStyleHook -- Improved fix for #323: The fix applied in V5.1.2 was a breaking change for some projects, especially - if not all the initialization was done in the OnInitNode event (reported as #338). vsInitialUserData - has been renamed to vsOnFreeNodeCallRequired and is now set when GetNodeData is called. This fixes - the possible memory leak reported in #323 and has better backward compatibility. -- Fixed #316: These fixes are to make the treeview behave more like the windows explorer regarding - selecting and dragging. Thanks to Stefan Glienke. -- Fixed #333: Possible Integer overflow in 64Bit builds. -- Compatibility with / packages for Delphi Xe$ / RAD Studio XE4 have been added. - -V5.1.2 (04 Apr 2013): - - Added function TVirtualTreeColumns.GetFirstColumn that returns the first column in display order. - - Fixed issue #322: CaptionAlignment is not being restored by Header.LoadFromStream(). - - TBaseVirtualTree.GetNodeData() now calls InitNode() if the node had not beend initialized. - This fixes issue #323 (Memory leak when the Node has children ) - - Fixed issue #326: Application hangs when aborting OLE Copy/Paste Operation - - Added new option poResizeToFitItem to TVTHeaderPopupOption: Adds an item which, if clicked, - resizes all columns to fit by calling TVTHeader.AutoFitColumns() - - Property RangeX is now public in the class TVirtualStringTree (#327) - - TVirtualTreeColumns.HandleClick(): No longer triggering auto sort if just the checkbox in the header was clicked - - TBaseVirtualTree.SetCheckType new resets PVirtualNode.CheckState only if the check state does not fit the new check type - - Fixed issue #321: Delphi2009: undeclared identifier: 'fState' in VirtualTrees.pas:DrawDisabledImage() - - Fixed issue #315: hoHeaderClickAutoSort was only working if toAutoSort is also set - -V5.1.1 (07 Feb 2013): - - Fixed issue #313: Translucent selection rectangle completely broken when PaintBackground is used - - Fixed issue #314: Only if toAutoSort is True non-expanded nodes will be excluded from sorting. - This restores the behavior of V5.0.X. - - Fixed issue #306: Drag image was broken except for CF_HDROP - - Fixed issue #305: Broken hint drawing with classic windows theme and toUseExplorerTheme - - Fixed issue #298: Bad canvas parameters in OnBeforeCellPaint method - - If NodeDataSize has its default value -1, now sizeof(Pointer) is used at runtime as actual value. - This makes it easier to store a simple Pointer with each node indepedent of the target platform (32/64Bit). - - Fixed issue #300: Made the hint text more centered in the hint window - - If TVirtualTreeColumn.CheckBox is set to True in Designer, then hoShowImages is now added to Header.Options - - Fixed issue #302: AV when painting sorted header column containing checkbox - - Now soring subnodes when they get expanded and the toAutoSort flag is set - - Added fix for ugly drawn disabled images (thx to S. Glienke). See also: - http://stackoverflow.com/questions/6003018/make-disabled-menu-and-toolbar-images-look-better - http://qc.embarcadero.com/wc/qcmain.aspx?d=86879 - - Fixed issue #299: Draw themed focus rectangle with toUseExplorerTheme - - Fixed issue #198: Wrong check images - - Removed file VTConfig.inc. The former $ifdef ReverseFullExpandHotKey is now a flag in the - TVTMiscOption enumeration. The $ifdef TntSupport can be defined at the beginning of the unit VirtualTrees. - - Added new optional parameter "Recursive" to TBaseVirtualTree.Sort() - -V5.1.0 (05 Nov 2012): - - Fixed issue #291: Empty hint strings are shown when using custom hint window classes - - Added support for VCl styles of RAD Studio XE2 and higher. (Thanks to Dietmar Rösler, issue #288) - - Fixed issue #285: access violation when mouse down over checkbox sometimes - - Fixed issue #293: OnAdvancedHeaderDraw is called with wrong PaintInfo.PaintRectangle - - Improved creation of IDragSourceHelper and added support for IDragSourceHelper2 - - Fixed problem with drawing selection rectangle after canceled rename - - Improved creation of IDragSourceHelper and added support for IDragSourceHelper2 - - Fixed issue regarding activating explorer theme - - Fixed issue #222: FDottedBrush is never released in the tree is never shown - - Fixed issue #52: Misalignement of CheckBox and TreeLine/Buttons - - Fixed issue #43: VT stop repaint after Windows visual style change - - Fixed issue #66: column auto-resize makes not aware of StaticText - - Fixed issue #53: Misalignment Images Columns > 0 - - Fixed issue #176: Multiline Aligment Problem - - Fixed issue #283: VTV no longer allows to drop above or below when using Full row selection - - Fixed issue #173: Two suggestions about class member visibilities - - Fixed issue #192: Fixed column painting bug when OffsetX > 0 - - Fixed Delphi 2007 Designer package - -V5.0.1 (06 Sep 2012): - - Added Support for RAD Studio XE3 - - Fixed definition of event OnAfterHeaderExport, it used the same member variable as OnBeforeHeaderExport. - - Fixed problem with Delphi 2007 package - - Delphi 2009 and 2010 packages are also implicit build packages now, like those for XE and XE2 (issue #279) - - Fixed #251: Added supoort for C++ Builder XE2 - - Fixed #274: Wrong stop condition in TBaseVirtualTree.GetLastVisible - - Fixed runtime package of Delphi 7 - - Fixed issue #273: Incremental search for international symbols not working in Delphi 2009-XE2 - - A few minor bug fixes have been incorporated - -July 03, 2012 - - Release of V5.0.0 final -June 11-30, 2012 - - Release of V5.0.0 RC2 - - Removed dependecy on file Compilers.inc - - Removed dependency on file MSAAIntf.pas - - Removed folder Common - - Fixed issue #252: Incorrect width of edit control rectangle when grid extensions are set - - Fixed issue #259: Hit position wrong when Indent is not default - - Fixed issue #253: Compatibility issues with XE2's VCL style checkboxes - - Fixed issue #265: Lib suffix not set for all configurations in Delphi XE2 package - - Bug fix: Functions GetLastVisible and GetLastVisibleNoInit return correct results even if some anchestor of the last visible node is not effectively visible - - Improvement: Added functions GetNextSiblingNoInit and GetPreviousSiblingNoInit - - "Res" folder of Advanced sample was not included in ZIP archive - - Added folder "Contributions" to release -June 01-10, 2012 - - Release of V5.0.0 RC1 - - Updated help file for V5.0 -April 2012 - - Added support for theming of hint window (thanks to Arno Garrels and Uwe Schuster) - - TBaseVirtualTree.CheckParentCheckState: Fixed duplicate recursion to parent nodes -March 2012 - - Fixed painting of Windows7/Vista style Explorer selection in case tsUseExplorerTheme is in TreeOptions - - Ctrl + A now selects all items -January 2012 - - Bug fix: Fixed a potential access violation in TBaseVirtualTree.FullCollapse in case of toChildrenAbove -December 2011 - - Fixed compiler warning in RAD Studio XE2 regarding deprecated ThemeServices -September 2011 - - The property EmptyListMessage may now contain linebreaks in Delphi 2009 and higher, the text in now printed in dark gray. - - Support for flat scroll bars has been removed. - - Global variables InWin2k and IsWinXP, enum member hsXPStyle, function DrawXPButton() and support for Windows 2000 has been removed. - - Global variable IsWinNT and support for Windows 9x has been removed. - - Improvement: Added support for Delphi XE2 and 64Bit compiler. - - Support for Delphi 5/6 and C++ Builder 5/6 has been dropped. - - Bug fix: Fixed a potential integer overflow in TBaseVirtualTree.ToggleNode in case of toChildrenAbove and NodeInView - - Bug fix: Fixed a potential Assertion in TBaseVirtualTree.ToggleNode by checking GetFirstVisible before calling GetDisplayRect - - Bug fix: TCustomVirtualTreeOptions.SetPaintOptions correctly changes the VisibleCount when toShowFilteredNodes is toggled - - Improvement: Added new functions TBaseVirtualTree.DetermineDropMode - - Improvement: Added usage of TBaseVirtualTree.DetermineDropMode in TBaseVirtualTree.DragOver - - Improvement: Made EffectiveOffsetX accessible via read-only protected property for easier subclassing - - Improvement: Moved TBaseVirtualTree.DetermineLineImageAndSelectLevel from private to protected for easier subclassing - - Improvement: Sorted TBaseVirtualTree.SetEmptyListMessage -August 2011 - - Improvement: Minor code improvements -April 2011 - - Bug fix: Reverted change of November 2010 (Creating the WorkerThread will no longer change System.IsMultiThread) - it caused sporadic AVs during app start which disappeared after revering the change. This code can lead to a wrong value - of System.IsMultiThread which causes the memory manager to assume a single threaded application. - - Bug fix: When advancing to the next item while in edit mode, we are now also calling CanEdit(). -February 2011 - - Bug fix: In case the LastStructureChangeNode is deleted before the StructureChange event is fired, - the reference to the LastStructureChangeNode is cleared to avoid providing an invalid node -January 2011 - - Improvement: RTF export now uses landscape paper format and smaller margins, so that more of the contents - fits on the page - - Improvement: New Option hoHeaderClickAutoSort for TVTHeader.Options: Clicks on the header will make the - clicked column the SortColumn or toggle sort direction if it already was the sort column - - Improvement: Pressing the tab key in edit mode advances to the next node in edit node, just like the - Windows 7 Explorer does it. - - Bug fix: No longer auto-scrolling horizontally when the focused node changes if toFullRowSelect is turned on. - - Bug fix: Fixed a clipping issue when drawing unbuffered -December 2010 - - Improvement: TBaseVirtualTree.HandleMouseUp now checks CanEdit just in case toEditOnClick - - Bug fix: TotalNodeHeights are now correctly adjusted when toggling toShowHiddenNodes - - Bug fix: Fixed BCB compiler error due to re-defining IDropTargetHelper - - Improvement: New TVTInternalPaintOption poUnbuffered to directly paint onto a given canvas (especially useful - when printing and/or scaling via world transformations) - - Improvement: Refactored header painting to be more flexible (e.g. for printing) - - Improvement: Made additional fields accessible via protected read-only properties for easier subclassing -November 2010 - - Improvement: All calls to SetWindowOrgEx now respect the canvas' transformation - - Improvement: TBaseVirtualTree.GetNodeHeight will no longer measure the node height, if the node is about - to be deleted - - Improvement: Made TBaseVirtualTree.FRangeX and FRangeY accessible via read-only protected property - - Improvement: Unified clipping handling - - Improvement: Added new color setting "SelectionTextColor" - - Improvement: Creating the WorkerThread will no longer change System.IsMultiThread - - Bug fix: Fixed a potential integer overflow in TBaseVirtualTree.ToggleNode - - Bug fix: TBaseVirtualTree.ToggleNode now measures the child node heights before summing them - - Improvement: Made some private field of TVTHeader and TVirtualTreeColumns protected to make writing - derived classes easier - - Improvement: Enclosed call to DoDragDrop in TBaseVirtualTree.CMDrag in a try..finally block - - Improvement: The default inplace editor now resizes itself even when the tree is in grid mode - - Bug fix: TBaseVirtualTree.PrepareBitmaps now checks the existance of the main column correctly - - Bug fix: TBaseVirtualTree.UpdateEditBounds now checks wether the focused node is assigned - - Improvement: TBaseVirtualTree.FHintData is now available to derived classes via the protected property HintData -October 2010 - - Bug fix: Now taking horizontal scroll position into account when drawing text of EmptyListMessage property - - Bug fix: Prevented potential "index out of bounds" exception in TVirtualTreeHintWindow.CalcHintRect - - Bug fix - Issue #187: Showing a dialog in OnChange or OnRemoveSelection event handlers can cause the VT to - enter mode for drawing selection rectangle. - - Improvement: Made inherited event OnCanResize published for TVirtualStringTree for Delphi 2010 and later - - Improvement: TBaseVirtualTree.ToggleNode now tries to keep the visual position of the toggled node, - even when toChildrenAbove is set -September 2010 - - Improvement: Added additional check regarding the tree reference to TVirtualTreeHintWindow.AnimationCallback - - Improvement: Made TBaseVirtualTree.AdjustImageBorder protected and virtual - - Improvement: TVirtualTreeColumns now observes if the focused column is removed - - Improvement: Made compatible with Delphi XE (Thanks to Roman Kassebaum) -August 2010 - - Improvement: TCustomVirtualStringTree.DoTextMeasuring now returns TSize - - Improvement: Renamed TVTMeasureTextWidthEvent to TVTMeasureTextEvent and introduced new - event TCustomVirtualStringTree.OnMeasureTextHeight - - Improvement: Made TBaseVirtualTree.GetMaxColumnWidth virtual - - Bug fix: TBaseVirtualTree.OnRemoveFromSelection is now triggered by TBaseVirtualTree.RemoveFromSelection - as intended -July 2010 - - Bug fix: Toggling toShowFilteredNodes will now update the node counts in the tree even if its handle has not - been allocated so far - - Bug fix: TBaseVirtualTree.FindNodeInSelection should now work correctly with nodes above the 2gb boundary - - Bug fix: Nodes that are about to be deleted are now removed from TBaseVirtualTree.FDragSelection - - Bug fix: Changed TBaseVirtualTree.WMKeyDown to correctly handle special keys in Unicode based Delphi versions - - Bug fix: Changed declaration of TBaseVirtualTree.EmptyListMessage to UnicodeString - - Improvement: Added new property TBaseVirtualTree.EmptyListMessage. If this property is not empty, the assigned - text will be displayed if there are no nodes to display, similar to the Windows XP file search. - - Improvement: Added tstChecked to TVSTTextSourceType enumeration and support for the new flag to - GetRenderStartValues(). So you can export only checked nodes. -June 2010 - - Bug fix: range select with no nodes will no longer result in an access violation - - Bug fix: TBaseVirtualTree.SetVisible now correctly decrements the visible node count - - Bug fix: TStringEditLink.BeginEdit now calls AutoAdjustSize to ensure a consistent size of the edit field - - Improvement: TVTHeader.AutoFitColumns is now declared virtual - - Bug fix: header captions were badly positioned text if Extra Large fonts have been activated in the Windows - display options -May 2010 - - Improvement: TBaseVirtualTree.PaintTree is now declared virtual - - Bug fix: corrected calculations regarding tree height and visible count when using filtered nodes -April 2010 - - Bug fix: Changed TBaseVirtualTree.SetChildCount and TBaseVirtualTree.InitNode to correctly handle filtered nodes - - Bug fix: Ctrl+Click on a node often cause a delayed update of the displayed selection due to a missing (or - misplaced) call to Invalidate() in HandleClickSelection(). - - Bug fix: Shift+PgUp and Shift+PgDown now behave like a usual List(View) and select the node of the previous/ - next page. The behaviourly that was formerly assigned to these shortcuts is now triggeres when using - Shift+Alt+PgUp / Shift+Alt+PgDown -March 2010 - - Bug fix: TBaseVirtualTree.CMMouseLeave now checks if the header is assigned before working with it - - Bug fix: TCustomVirtualTreeOptions.SetPaintOptions will now invalidate the node cache if toChildrenAbove is - changed - - Bug fix: TBaseVirtualTree.HandleMouseUp will no longer cause an AV if HitInfo.HitNode is not assigned and - tsToggleFocusedSelection is set - - Improvement: new properties TBaseVirtualTree.OnAddToSelection and TBaseVirtualTree.OnRemoveFromSelection - - Bug fix: fixed a whole bunch of painting issues regarding drag & drop - - Bug fix: fixed TBaseVirtualTree.DragFinished to generate a button up event in case of using OLE drag & drop - - Bug fix: TBaseVirtualTree.DeleteChildren no longer fails if the given node is nil -January 2010 - - Bug fix: Removed defaults from TVirtualTreeColumn.BiDiMode and TVirtualTreeColumn.Color - - Bug fix: Clearing the columns while editing no longer raises an exception - - Improvement: refactored handling of long running operations - - Bug fix: TBaseVirtualTree.OnGetHelpContext now delivers the currently focused column instead of always 0 - - Improvement: the sort operation can now be canceled - - Improvement: all BeginOperation/EndOperation pairs are now enclosed in try..finally blocks - - Bug fix: the combination of toUseExplorerTheme and toFullRowSelect now also works correct when no columns are - defined -December 2009 - - Bug fix: TVTHeader.HandleMessage now correctly handles double click autosizing when the index differs from - its position -November 2009 - - Bug fix: TBaseVirtualTree.AdjustTotalHeight didn't change the height of invisible nodes which caused some trouble - when making those nodes visible again - - Improvement: a column is no longer painted 'down' if its check box was clicked - - Bug fix: one can no longer toggle the check state of a column with the right mouse button - - Bug fix: one can no longer toggle the check state of a node with the right mouse button - - Bug fix: TCustomVirtualTreeOptions.SetPaintOptions no longer accidentally removed the the explorer theme - - Bug fix: Fixed a potential Integer overflow in TBaseVirtualTree.CalculateVerticalAlignments -October 2009 - - Bug fix: enabling checkbox support for a column is now possible without assigning a dummy imagelist - - Bug fix: checkboxes in the header are now correctly aligned - - Improvement: changed TBaseVirtualTree.PaintCheckImage to be usable by TVirtualTreeColumns.PaintHeader to be - able to paint themed header checkboxes - - Bug fix: TBaseVirtualTree.GetCheckImage now correctly handles cases when Node is nil and ImgCheckType is either - ctTriStateCheckBox or ctNone - - Bug fix: TBaseVirtualTree.HasImage now implicitly initializes the given node if needed to avoid requesting the - imageindex for nodes that are not initialized - - Bug fix: fixed possible AV when setting toExplorerTheme with no columns defined - - Improvement: new events TBaseVirtualTree.OnSaveTree and TBaseVirtualTree.OnLoadTree -September 2009 - - Bug fix: TBaseVirtualTree.OnColumnClick will no longer be triggered twice - - Improvement: new TVirtualNodeInitState ivsReInit to indicate that a node is about to be re-initialized - - Bug fix: TCustomVirtualStringTree.DoTextMeasuring now makes use of the parameter Width of the - OnMeasureTextWidth event - - Bug fix: TBaseVirtualTree.DetermineLineImageAndSelectLevel will no longer access LineImage[-1] - - Bug fix: clearing the columns now correctly reset TBaseVirtualTree.FFocusedColumn - - Improvement: explorer style painting is now more close to the real explorer - - Bug fix: TCustomVirtualStringTree.TContentToHTML.WriteStyle will no longer produce invalid CSS - - Bug fix: the parameter DragEffect of TBaseVirtualTree.DragAndDrop is now var as it should be -August 2009 - - Bug fix: TBaseVirtualTree.MoveTo now initializes the target node using the target tree - - Bug fix: TBaseVirtualTree.FVisibleCount is now calculated correctly when using filtered nodes - - Improvement: introduced new initial node state ivsFiltered -July 2009 - - Improvement: modified TVTHeader.HandleHeaderMouseMove to make resizing the autosize column with the - mouse possible - - Improvement: modified TBaseVirtualTree.DoCreateEditor so that applications can now return NIL in OnCreateEditor - to use the standard editor of the tree - - Bug fix: pressing CTRL + PgUp/PgDown no longer leads to an index-out-of-bounds exception if no columns are used - - Bug fix: avoided race condition between TBaseVirtualTree.DeleteNode and the worker thread - - Bug fix: TBaseVirtualTree.ToggleNode could produce an overflow if range checking was enabled - - Bug fix: TWorkerThread will no longer reference the tree after it has been destroyed (Mantis issue #384) - - Improvement: removed support for Delphi versions older than Delphi 7 - - Improvement: removed local memory manager -June 2009 - - Bug fix: TBaseVirtualTree.InternalConnectNode checked the expanded state of the wrong node if Mode was - amAddChildFirst or amAddChildLast - - Improvement: 'hidden nodes' are now called 'filtered nodes' - - Improvement: converted line endings back to CR/LF - - Improvement: new events TBaseVirtualTree.OnCanSplitterResizeNode and TBaseVirtualTree.OnCanSplitterResizeHeader - - Improvement: made TVirtualTreeColumns.DoCanSplitterResize virtual - - Improvement: made some methods of TVirtualTreeHintWindow protected to make subclassing easier - - Bug fix: fixed some issues concerning the vista theme handling - - Improvement: unified source code indentation -May 2009 - - Improvement: new TVTMiscOption toEditOnClick, toEditOnDblClick to control if editing can be started with a single - click or a double click - - Bug fix: the internal pointers of TBufferedAnsiString are now PAnsiChar to work correctly with Delphi 2009 -April 2009 - - Bug fix: TBaseVirtualTree.GetVisibleParent no longer returns the given node in case it is fully visible - - Improvement: fixed a potential issue in TVirtualTreeColumns.TotalWidth in case it is called before - FPositionToIndex is initialized - - Bug fix: TBaseVirtualTree.CollectSelectedNodesLTR and TBaseVirtualTree.CollectSelectedNodesRTL handle straight - vertical selection rectangles no longer as empty - - Bug fix: TCheckImageKind.ckSystemDefault now works as intended - - Improvement: made the following methods of TBaseVirtualTree virtual: PrepareCell, AddChild, BeginUpdate, - EndUpdate and SortTree - - Improvement: made TBaseVirtualTree.PrepareCell protected - - Improvement: moved some members of TVTEdit and TStringEditLink from private to protected - - Improvement: re-designed header click handling - - Improvement: new TVTPaintOption toShowHiddenNodes to globally ignore the hidden state of nodes - - Improvement: individual nodes can now be hidden without affecting their children - - Improvement: re-designed Explorer theme drawing - - Bug fix: corrected allocation problems in TBufferedAnsiString and TWideBufferedString -March 2009 - - Bug fix: fixed an issue in TVirtualTreeColumns.HandleClick that could lead to a case where no header click event - is triggered - - Bug fix: fixed an issue in TBaseVirtualTree.HandleHotTrack that could lead to an endless loop under certain - conditions - - Improvement: removed unused variables in TVirtualTreeColumn.ComputeHeaderLayout - - Bug fix: corrected TBaseVirtualTree.GetVisibleParent - - Improvement: extended hot node tracking to track the hot column too - - Improvement: new THitPosition hiOnItemButtonExact used to draw hot buttons when using Windows Vista's Explorer - theme - - Improvement: new TVTPaintOption toHideTreeLinesIfThemed to consider toShowTreeLines only if running unthemed - - Improvement: new TVTPaintOption toUseExplorerTheme to draw the tree like Windows Vista's Explorer treeview -February 2009 - - Bug fix: reverted the implementation of DrawTextW back to the one prior to 4.8.1 as the line end detection - lead to a compiler warning under Delphi 2009 - - Bug fix: corrected implementation of GetStringDrawRect to match its declaration (UnicodeString vs WideString) - - Bug fix: the node focus will no longer change if a TVTMiscOption.toGridExtensions is set and one clicks right of - (or left of, if right-to-left reading) the last column - - Bug fix: fixed an issue with TVTHeader.Assign that could lead to an access violation if the header is created at - runtime - - Bug fix: one can no longer change a node's height with the right mouse button even if toNodeHeightResize and - toRightClickSelect are set - - Improvement: TVTAutoOption.toDisableAutoScrollOnFocus now works for nodes too - - Improvement: new property TBaseVirtualTree.SelectionLocked to disable changing the selection - - Improvement: made the dual-scroll effect in TBaseVirtualTree.ToggleNode much smoother - - Bug fix: removed off-by-1 errors in TBaseVirtualTree.ToggleNode - - Bug fix: added a check for FUpdateCount to TBaseVirtualTree.SetUpdateState as otherwise every call to - TBaseVirtualTree.DoBeforeCellPaint to get the cell content margin within an Begin/EndUpdate-block would - re-enable painting - - Bug fix: TVTHeader.HandleMessage could provide a wrong column index to OnBeforeColumnWidthTracking in some cases - - Improvement: new properties TBaseVirtualTree.OnBeforeAutoFitColumn, TBaseVirtualTree.OnAfterAutoFitColumn - - Improvement: new procedures TBaseVirtualTree.CancelOperation, TBaseVirtualTree.BeginOperation, - TBaseVirtualTree.EndOperation and new property TBaseVirtualTree.OperationCanceled to enable the - application to stop (possibly) long-running operations - - Improvement: integrated changes from Andreas Hausladen - - Improvement: integrated changes from Dmitry Zegebart where applicable - - Bug fix: removed off-by-1 error in TBaseVirtualTree.GetDisplayRect - - Bug fix: changed the size of the buffer used in TBaseVirtualTree.PaintTree to paint the area below the last node - as the bitmap was not completely erased using previous size under certain conditions - - Bug fix: fixed TBaseVirtualTree.GetPreviousLevel -January 2009 - - Bug fix: removed off-by-1 error in TBaseVirtualTree.GetBottomNode - - Improvement: improved speed of TBaseVirtualTree.GetMaxColumnWidth when using UseSmartColumnWidth - - Version is now 4.8.0 -December 2008 - - Bug fix: modified TBaseVirtualTree.UpdateHorizontalScrollbar and TBaseVirtualTree.UpdateVerticalScrollbar to - recalculate the tree's dimensions even if an update is in progress - - Improvement: renamed TVTHeaderState hsTracking and hsTrackPending to hsColumnWidthTracking and - hsColumnWidthTrackPending - - Improvement: modified TBaseVirtualTree.GetFirstVisible and TBaseVirtualTree.GetFirstVisibleNoInit to optionally - take a node to specify where to start - - Improvement: modified TVTAfterGetMaxColumnWidthEvent to make the result of TBaseVirtualTree.GetMaxColumnWidth - changable - - Bug fix: corrected TBaseVirtualTree.GetMaxColumnWidth to consider toFixedIndent and no longer take nodes into - account that are just above or below the visible area - - Improvement: new property TVirtualTreeColumns.DefaultWidth - - Improvement: new property TVTHeader.FixedAreaConstraints (new class TVTFixedAreaConstraints) to limit the - fixed area (header, fixed columns) to a percentage of the client area -November 2008 - - Improvement: new cursor added: crVertSplit used for height tracking - - Improvement: changed type of TVTHeader.Height from Cardinal to Integer to make boundary checks easier - - Improvement: new properties TVTHeader.MinHeight and TVTHeader.MaxHeight - - Improvement: new VirtualTreeStates tsNodeHeightTracking and tsNodeHeightTrackPending - - Improvement: new HeaderStates hsHeightTracking and hsHeightTrackPending - - Improvement: new TVTMiscOption toNodeHeightResize to allow changing node heights via mouse - - Improvement: new TVTHeaderOption hoHeightResize to allow changing header height via mouse - - Improvement: new properties TBaseVirtualTree.OnHeaderHeightTracking, TBaseVirtualTree.OnHeaderDblClickResize, - TBaseVirtualTree.OnColumnWidthTracking, TBaseVirtualTree.OnColumnWidthDblClickResize, - TBaseVirtualTree.OnNodeHeightTracking, TBaseVirtualTree.OnNodeHeightDblClickResize - - Improvement: new function TVTHeader.ResizeColumns to resize multiple columns at once - - Improvement: TVTHeader.DetermineSplitterIndex is no longer influenced by non-resizable columns - - Bug fix: TBaseVirtualTree.ToggleNode now uses DoStateChange to modify FStates - - Bug fix: TBaseVirtualTree.DoBeforeCellPaint now saves the update rect if CellPaintMode is cpmGetContentMargin - and restores it afterwards - - Improvement: modified TBaseVirtualTree.CmMouseWheel to handle mice with wheel delta < 120 correctly - - Improvement: modified TVTHeader.LoadFromStream and WriteToStream to save ParentFont - - Improvement: TVTHeader.Font is now only stored by Delphi if ParentFont is False (Mantis issue #217) - - Bug fix: corrected TVTHeader.Create to set TVTHeader.FOptions correctly to the default value (Mantis issue #333) - - Improvement: new TVTAnimationOption toAdvancedAnimatedToggle to scroll the node to be toggled animatedly instead - of just scroll its child nodes animatedly - - Improvement: added VirtualTreeState tsToggling to eliminate artefacts caused by TBaseVirtualTree.DoSetOffsetXY - while toggling - - Bug fix: corrected button handling when toFixedIndent is set - - Improvement: redesigned TBaseVirtualTree.ToggleNode to harmonize the visual toggle behaviour independent of - toChildrenAbove - - Improvement: made TBaseVirtualTree.CanEdit public - - Improvement: added parameter ConsiderChildrenAbove to TGetNextNodeProc - - Improvement: modified all variants of TBaseVirtualTree.GetFirst and TBaseVirtualTree.GetLast to optionally - consider toChildrenAbove -October 2008 - - Bug fix: removed 'FVisibleCount := 0' from TBaseVirtualTree.Clear as this would lead to incorrect VisibleCount in - read-only mode - - Bug fix: fixed a condition in TBaseVirtualTree.ToggleCallback that could lead to artefacts - - Improvement: changed the implementation of TBaseVirtualTree.GetNext/GetPrevious so that no penalties occur if - toChildrenAbove is not set - - Improvement: TBaseVirtualTree.ToggleNode will no longer leave nodes with state vsToggeling if an exception - occurs - - Improvement: improved behaviour of TBaseVirtualTree.ToggleNode in case toChildrenAbove is set - - Bug fix: corrected TBaseVirtualTree.ScrollIntoView to behave as expected when no fixed columns exist - - Bug fix: extended TBaseVirtualTree.InitializeLineImageAndSelectLevel to eliminate artifacts while scrolling with - toChildrenAbove set - - Bug fix: corrected CompareNodePositions to consider toChildrenAbove - - Bug fix: corrected ToggleNode to scroll correctly if toChildrenAbove and toAnimatedToggle are set - - Improvement: new TVTPaintOption toFixedIndent to draw the tree with a fixed ident (instead of node level - dependent indents) - - Improvement: new TVTPaintOption toChildrenAbove to draw children nodes above their parent -August 2008 - - Improvement: redesigned and overloaded TBaseVirtualTree.ScrollIntoView in order to use vertical scrolling - separately - - Improvement: optimized TBaseVirtualTree.ScrollIntoView for horizontal scrolling - - Improvement: in TBaseVirtualTree.WMKeyDown column navigation for VK_PRIOR and VK_NEXT is now handled in same way - as row navigation - - Improvement: new TVTHeaderOption hoDisableAnimatedResize to disable animated resize for all columns - - Improvement: new TVTColumnOption coDisableAnimatedResize to disable animated resize for a specific column - - Improvement: in TBaseVirtualTree.UpdateHorizontalScrollBar and TBaseVirtualTree.UpdateVerticalScrollBar scrollbar - updates now avoided for tsUpdating in FStates -July 2008 - - Improvement: in TBaseVirtualTree.WMHScroll the horizontal page scrolling now considers fixed columns - - Improvement: in TBaseVirtualTree.ScrollIntoView the case of FFocusedColumn being invalid is considered - - Improvement: in TBaseVirtualTree.HandleMouseDown DoFocusNode is not called if node focus did not change - - Improvement: in TBaseVirtualTree.SetFocusedColumn the focused node will only be invalidate if it was actually - scrolled into view - - Improvement: new TVTColumnOption coAllowFocus to affect column focus behaviour - - Improvement: new function TVTHeader.AllowFocus to check wether a column can be focused - - Improvement: in TBaseVirtualTree.SetFocusedColumn the old colunm and the new column are both invalidated - - Improvement: merged latest changes from Jim into current code base. -June 2008 - - Improvement: new property TVirtualTreeColumns.Count - - Bug fix: in TVirtualTreeColumns.AnimatedResize the column is validated (to avoid "List index out of bounds") - - Improvement: the content retangle of the cell can be modified via the OnBeforeCellPaint event, the cell paint - mode indicates wether OnBeforeCellPaint is called for painting the cell or just for getting the - cell content margin - - Improvement: new functions added: TBaseVirtualTree.DoGetCellContentMargins, - TCustomVirtualDrawTree.DoGetCellContentMargin - - Improvement: new property: TCustomVirtualDrawTree.OnGetCellContentMargin - - Improvement: in TBaseVirtualTree.GetMaxColumnWidth the cell content margin is considered - - Improvement: in TBaseVirtualTree.CMHintShow the cell content margin is considered for singleline tooltips - - Improvement: new function added: TVTHeader.DoGetPopupMenu (to query the application via TreeView.FOnGetPopupMenu - for a column specific header popup menu) - - Improvement: new property added: TBaseVirtualTree.OnCanSplitterResizeColumn, - new function added: TVirtualTreeColumns.GetScrollWidth - - Improvement: horizontal page scrolling now uses the average column width (of all visible, non-fixed columns) as - scroll amount - - Improvement: procedure TBaseVirtualTree.CMMouseWheel redesigned - - Bug fix: TVTHeader.DetermineSplitterIndex works correctly even when using fixed columns - - Bug fix: on right-to-left BiDiMode TVirtualTreeColumns.PaintHeader respects (left) scroll bar correctly - - Bug fix: for multiline tooltips also the column width is checked to determine the tooltip is needed or - unnecessary - - Improvement: the result value of GetUseSmartColumnWidth is initialized correctly - - Improvement: added hoFullRepaintOnResize to TVTHeaderOption to enable full header repainting (instead of - repainting all subsequent columns only) on resizing a column - - Bug fix: horizontal page scrolling via mouse wheel now works correctly, i.e. in TBaseVirtualTree.CMMouseWheel - ScrollCount includes GetVisibleFixedWidth and FIndent - - Improvement: new TVTColumnOption coSmartResize to avoid contradicting the virtual paradigm - - Improvement: horizontal scrolling via mouse wheel can be forced by holding the shift key - - Improvement: new parameter for function TBaseVirtualTree.GetMaxColumnWidth added: UseSmartColumnWidth (to - avoid contradicting the virtual paradigm, i.e. leave nodes out of consideration which are not in - view) - - Improvement: new parameters for TVTHeader.AutoFitColumns added: SmartAutoFitType, RangeStartCol and - RangeEndCol - - Improvement: new parameters for events FOnAfterAutoFitColumns, FOnBeforeAutoFitColumns, FOnAfterGetMaxColumnWidth - and FOnBeforeGetMaxColumnWidth added - - Version is now 4.6.0 -May 2008 - - Improvement: new properties: FOnAfterAutoFitColumns, FOnBeforeAutoFitColumns, FOnAfterGetMaxColumnWidth and - FOnBeforeGetMaxColumnWidth - - Bug fix: FDropTargetNode is considered in TBaseVirtualTree.DoFreeNode -August 2007 - - for accessibility, added an OnGetImageText event that can be used to give accessible text to images used in nodes. - - Implemented an ImageText property used by the VTAccessibility unit to retrieve text for a given node and its column. - - Switched loading of accessibility libraries to dynamic from static to avoid problems in Win95 -June 2007 - - Bug fix: Fixed a problem with potentially large amount of nodes (larger than 2 billion) in - TBaseVirtualTree.SetChildCount. - - Bug fix: remove hint if any in case the tree loses the focus. - - Improvement: TVirtualTreeColumns.HandleClick is now virtual, introduced TVTHeader.DoSetSortColumn. - - Bug fix: compiler error due to old variable reference when enabling flat scrollbars. -May 2007 - - Improvement: new functions: GetPreviousSelected, GetPreviousChecked, GetCheckedCount, - GetPreviousCutCopy, GetCutCopyCount, GetFirstLeaf, GetNextLeaf, - GetPreviousLeaf, GetFirstLevel, GetNextLevel, GetPreviousLevel - - Improvement: new properties: CheckedCount, CutCopyCount - - Improvement: DoFocusChanging for finding a valid column (TBaseVirtualTree.WMKeyDown) -March 2007 - - Improvement: adjusted accessibility implementation to compile with pre-BDS IDEs. - - If a column is not visible, MultiColumnAccessibility now will not include it. -January 2007 - - Improvement: added code donation from Marco Zehe (with help from Sebastian Modersohn) which implements the - MS accessibility interface for Virtual Treeview. -December 2006 - - Improvement: bidi mode implementation finished (toAutoBidiColumnOrdering introduced) - - Change: right-to-left flag removed from shorten string methods/events (not necessary) - - Version is now 4.5.0 -November 2006 - - Bug fix: Total height is wrong on reading from stream -September 2006 - - Bug fix: Mantis issue #326 -July 2006 -- Change: value for crHeaderSplit cursor conflicts with other resource IDs, so I changed it. -- Published OnStartDrag in VirtualDrawTree. -April 2006 - - Bug fix: check for MMX availabiltiy is missing in some places before calling MMX code - - Bug fix: flag for VCL dragging was removed too late causing all kind of problems with mouse up code in VCL drag mode. - - Bug fix: If the past mode in ProcessOLEData is amInsertAfter then nodes where inserted in the wrong order. -March 2006 - - Bug fix: total count and total height is wrong after loading from stream - - Bug fix: variable node height computation - - Bug fix: FLastChangedNode was not reset in DoFreeNode -February 2006 - - Improvement: GetFirstChecked now also has a default value for its state parameter. - - Improvement: avoid potential reentrancy problems in paint code by checking for the paint state there. -January 2006 - - Bug fix: disabled images are now drawn like enabled ones (with respect to position, indices etc.). - - Improvement: New property BottomSpace, allows to specify an additional area below the last node in the tree. - - Bug fix: VT.EndUpdate did not invalidate the cache so the cache was never used again after that. - - Improvement: tree states for double clicks (left, middle, right). -December 2005 - - Bug fix: check for column index for auto setting main column if the current one is deleted. - -For full document history see help file. diff --git a/components/virtualtreeview/Design/VirtualTreesReg.pas b/components/virtualtreeview/Design/VirtualTreesReg.pas index 094fe635..141d49a8 100644 --- a/components/virtualtreeview/Design/VirtualTreesReg.pas +++ b/components/virtualtreeview/Design/VirtualTreesReg.pas @@ -1,400 +1,400 @@ -unit VirtualTreesReg; - -// This unit is an addendum to VirtualTrees.pas and contains code of design time editors as well as -// for theirs and the tree's registration. - -interface - -// For some things to work we need code, which is classified as being unsafe for .NET. -{$warn UNSAFE_TYPE off} -{$warn UNSAFE_CAST off} -{$warn UNSAFE_CODE off} - -uses - Windows, Classes, DesignIntf, DesignEditors, VCLEditors, PropertyCategories, - ColnEdit, VirtualTrees, VirtualTrees.HeaderPopup; - -type - TVirtualTreeEditor = class (TDefaultEditor) - public - procedure Edit; override; - end; - -procedure Register; - -//---------------------------------------------------------------------------------------------------------------------- - -implementation - -uses - StrEdit, Dialogs, TypInfo, SysUtils, Graphics, CommCtrl, ImgList, Controls, - VirtualTrees.ClipBoard, VirtualTrees.Actions; - -type - // The usual trick to make a protected property accessible in the ShowCollectionEditor call below. - TVirtualTreeCast = class(TBaseVirtualTree); - - TClipboardElement = class(TNestedProperty, ICustomPropertyDrawing) - private - FElement: string; - protected - constructor Create(Parent: TPropertyEditor; AElement: string); reintroduce; - public - function AllEqual: Boolean; override; - function GetAttributes: TPropertyAttributes; override; - function GetName: string; override; - function GetValue: string; override; - procedure GetValues(Proc: TGetStrProc); override; - procedure SetValue(const Value: string); override; - - procedure PropDrawName(ACanvas: TCanvas; const ARect: TRect; ASelected: Boolean); - procedure PropDrawValue(ACanvas: TCanvas; const ARect: TRect; ASelected: Boolean); - end; - - // This is a special property editor to make the strings in the clipboard format string list - // being shown as subproperties in the object inspector. This way it is shown what formats are actually available - // and the user can pick them with a simple yes/no choice. - - TGetPropEditProc = TGetPropProc; - - TClipboardFormatsProperty = class(TStringListProperty, ICustomPropertyDrawing) - public - function GetAttributes: TPropertyAttributes; override; - procedure GetProperties(Proc: TGetPropEditProc); override; - procedure PropDrawName(ACanvas: TCanvas; const ARect: TRect; ASelected: Boolean); - procedure PropDrawValue(ACanvas: TCanvas; const ARect: TRect; ASelected: Boolean); - end; - - resourcestring - sVTHeaderCategoryName = 'Header'; - sVTPaintingCategoryName = 'Custom painting'; - sVTIncremenalCategoryName = 'Incremental search'; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeEditor.Edit; - -begin - ShowCollectionEditor(Designer, Component, TVirtualTreeCast(Component).Header.Columns, 'Columns'); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -constructor TClipboardElement.Create(Parent: TPropertyEditor; AElement: string); - -begin - inherited Create(Parent); - FElement := AElement; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TClipboardElement.AllEqual: Boolean; - -// Determines if this element is included or excluded in all selected components it belongs to. - -var - I, Index: Integer; - List: TClipboardFormats; - V: Boolean; - -begin - Result := False; - if PropCount > 1 then - begin - List := TClipboardFormats(GetOrdValue); - V := List.Find(FElement, Index); - for I := 1 to PropCount - 1 do - begin - List := TClipboardFormats(GetOrdValue); - if List.Find(FElement, Index) <> V then - Exit; - end; - end; - Result := True; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TClipboardElement.GetAttributes: TPropertyAttributes; - -begin - Result := [paMultiSelect, paValueList, paSortList]; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TClipboardElement.GetName: string; - -begin - Result := FElement; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TClipboardElement.GetValue: string; - -var - List: TClipboardFormats; - -begin - List := TClipboardFormats(GetOrdValue); - Result := BooleanIdents[List.IndexOf(FElement) > -1]; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TClipboardElement.GetValues(Proc: TGetStrProc); - -begin - Proc(BooleanIdents[False]); - Proc(BooleanIdents[True]); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TClipboardElement.SetValue(const Value: string); - -var - List: TClipboardFormats; - I, Index: Integer; - -begin - if CompareText(Value, 'True') = 0 then - begin - for I := 0 to PropCount - 1 do - begin - List := TClipboardFormats(GetOrdValueAt(I)); - List.Add(FElement); - end; - end - else - begin - for I := 0 to PropCount - 1 do - begin - List := TClipboardFormats(GetOrdValueAt(I)); - if List.Find(FElement, Index) then - List.Delete(Index); - end; - end; - Modified; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure DrawBoolean(Checked: Boolean; ACanvas: TCanvas; const ARect: TRect; ASelected: Boolean); - -var - BoxSize, - EntryWidth: Integer; - R: TRect; - State: Cardinal; - -begin - with ACanvas do - begin - FillRect(ARect); - - BoxSize := ARect.Bottom - ARect.Top; - EntryWidth := ARect.Right - ARect.Left; - - R := Rect(ARect.Left + (EntryWidth - BoxSize) div 2, ARect.Top, ARect.Left + (EntryWidth + BoxSize) div 2, - ARect.Bottom); - InflateRect(R, -1, -1); - State := DFCS_BUTTONCHECK; - if Checked then - State := State or DFCS_CHECKED; - DrawFrameControl(Handle, R, DFC_BUTTON, State); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TClipboardElement.PropDrawName(ACanvas: TCanvas; const ARect: TRect; ASelected: Boolean); - -begin - DefaultPropertyDrawName(Self, ACanvas, ARect); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TClipboardElement.PropDrawValue(ACanvas: TCanvas; const ARect: TRect; ASelected: Boolean); - -begin - DrawBoolean(CompareText(GetVisualValue, 'True') = 0, ACanvas, ARect, ASelected); -end; - -//----------------- TClipboardFormatsProperty -------------------------------------------------------------------------- - -function TClipboardFormatsProperty.GetAttributes: TPropertyAttributes; - -begin - Result := inherited GetAttributes + [paSubProperties, paFullWidthName]; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TClipboardFormatsProperty.GetProperties(Proc: TGetPropEditProc); - -var - List: TStringList; - I: Integer; - Tree: TBaseVirtualTree; - -begin - List := TStringList.Create; - Tree := TClipboardFormats(GetOrdValue).Owner; - EnumerateVTClipboardFormats(TVirtualTreeClass(Tree.ClassType), List); - for I := 0 to List.Count - 1 do - Proc(TClipboardElement.Create(Self, List[I])); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TClipboardFormatsProperty.PropDrawName(ACanvas: TCanvas; const ARect: TRect; ASelected: Boolean); - -var - S: string; - Width: Integer; - R: TRect; - -begin - with ACanvas do - begin - Font.Name := 'Arial'; - R := ARect; - Font.Color := clBlack; - S := GetName; - Width := TextWidth(S); - TextRect(R, R.Left + 1, R.Top + 1, S); - - Inc(R.Left, Width + 8); - Font.Height := 14; - Font.Color := clBtnHighlight; - S := '(OLE drag and clipboard)'; - SetBkMode(Handle, TRANSPARENT); - ExtTextOut(Handle, R.Left + 1, R.Top + 1, ETO_CLIPPED, @R, PChar(S), Length(S), nil); - Font.Color := clBtnShadow; - ExtTextOut(Handle, R.Left, R.Top, ETO_CLIPPED, @R, PChar(S), Length(S), nil); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TClipboardFormatsProperty.PropDrawValue(ACanvas: TCanvas; const ARect: TRect; ASelected: Boolean); - -begin - // Nothing to do here. -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure Register; - -begin - RegisterComponents('Virtual Controls', [TVirtualStringTree, TVirtualDrawTree, TVTHeaderPopupMenu]); - RegisterComponentEditor(TVirtualStringTree, TVirtualTreeEditor); - RegisterComponentEditor(TVirtualDrawTree, TVirtualTreeEditor); - RegisterPropertyEditor(TypeInfo(TClipboardFormats), nil, '', TClipboardFormatsProperty); - - // Categories: - RegisterPropertiesInCategory(sActionCategoryName, TBaseVirtualTree, ['ChangeDelay', 'EditDelay']); - - RegisterPropertiesInCategory(sDataCategoryName, - TBaseVirtualTree, - ['NodeDataSize', - 'RootNodeCount', - 'OnCompareNodes', - 'OnGetNodeDataSize', - 'OnInitNode', - 'OnInitChildren', - 'OnFreeNode', - 'OnGetNodeWidth', - 'OnGetPopupMenu', - 'OnLoadNode', - 'OnSaveNode', - 'OnResetNode', - 'OnNodeMov*', - 'OnStructureChange', - 'OnUpdating', - 'OnGetText', - 'OnNewText', - 'OnShortenString']); - - RegisterPropertiesInCategory(slayoutCategoryName, - TBaseVirtualTree, - ['AnimationDuration', - 'AutoExpandDelay', - 'AutoScroll*', - 'ButtonStyle', - 'DefaultNodeHeight', - '*Images*', 'OnGetImageIndex', 'OnGetImageText', - 'Header', - 'Indent', - 'LineStyle', 'OnGetLineStyle', - 'CheckImageKind', - 'Options', - 'Margin', - 'NodeAlignment', - 'ScrollBarOptions', - 'SelectionCurveRadius', - 'TextMargin']); - - RegisterPropertiesInCategory(sVisualCategoryName, - TBaseVirtualTree, - ['Background*', - 'ButtonFillMode', - 'CustomCheckimages', - 'Colors', - 'LineMode']); - - RegisterPropertiesInCategory(sHelpCategoryName, - TBaseVirtualTree, - ['AccessibleName', 'Hint*', 'On*Hint*', 'On*Help*']); - - RegisterPropertiesInCategory(sDragNDropCategoryName, - TBaseVirtualTree, - ['ClipboardFormats', - 'DefaultPasteMode', - 'OnCreateDataObject', - 'OnCreateDragManager', - 'OnGetUserClipboardFormats', - 'OnNodeCop*', - 'OnDragAllowed', - 'OnRenderOLEData']); - - RegisterPropertiesInCategory(sInputCategoryName, - TBaseVirtualTree, - ['DefaultText', - 'DrawSelectionMode', - 'WantTabs', - 'OnChang*', - 'OnCollaps*', - 'OnExpand*', - 'OnCheck*', - 'OnEdit*', - 'On*Click', - 'OnFocus*', - 'OnCreateEditor', - 'OnScroll', - 'OnNodeHeightTracking', - 'OnHotChange']); - - RegisterPropertiesInCategory(sVTHeaderCategoryName, - TBaseVirtualTree, - ['OnHeader*', 'OnGetHeader*']); - - RegisterPropertiesInCategory(sVTPaintingCategoryName, - TBaseVirtualTree, - ['On*Paint*', - 'OnDraw*', - 'On*Erase*']); - - RegisterPropertiesInCategory(sVTIncremenalCategoryName, - TBaseVirtualTree, - ['*Incremental*']); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -end. +unit VirtualTreesReg; + +// This unit is an addendum to VirtualTrees.pas and contains code of design time editors as well as +// for theirs and the tree's registration. + +interface + +// For some things to work we need code, which is classified as being unsafe for .NET. +{$warn UNSAFE_TYPE off} +{$warn UNSAFE_CAST off} +{$warn UNSAFE_CODE off} + +uses + Windows, Classes, DesignIntf, DesignEditors, VCLEditors, PropertyCategories, + ColnEdit, VirtualTrees, VirtualTrees.DrawTree, VirtualTrees.HeaderPopup; + +type + TVirtualTreeEditor = class (TDefaultEditor) + public + procedure Edit; override; + end; + +procedure Register; + +//---------------------------------------------------------------------------------------------------------------------- + +implementation + +uses + StrEdit, Dialogs, TypInfo, SysUtils, Graphics, CommCtrl, ImgList, Controls, + VirtualTrees.ClipBoard, VirtualTrees.Actions; + +type + // The usual trick to make a protected property accessible in the ShowCollectionEditor call below. + TVirtualTreeCast = class(TBaseVirtualTree); + + TClipboardElement = class(TNestedProperty, ICustomPropertyDrawing) + private + FElement: string; + protected + constructor Create(Parent: TPropertyEditor; AElement: string); reintroduce; + public + function AllEqual: Boolean; override; + function GetAttributes: TPropertyAttributes; override; + function GetName: string; override; + function GetValue: string; override; + procedure GetValues(Proc: TGetStrProc); override; + procedure SetValue(const Value: string); override; + + procedure PropDrawName(ACanvas: TCanvas; const ARect: TRect; ASelected: Boolean); + procedure PropDrawValue(ACanvas: TCanvas; const ARect: TRect; ASelected: Boolean); + end; + + // This is a special property editor to make the strings in the clipboard format string list + // being shown as subproperties in the object inspector. This way it is shown what formats are actually available + // and the user can pick them with a simple yes/no choice. + + TGetPropEditProc = TGetPropProc; + + TClipboardFormatsProperty = class(TStringListProperty, ICustomPropertyDrawing) + public + function GetAttributes: TPropertyAttributes; override; + procedure GetProperties(Proc: TGetPropEditProc); override; + procedure PropDrawName(ACanvas: TCanvas; const ARect: TRect; ASelected: Boolean); + procedure PropDrawValue(ACanvas: TCanvas; const ARect: TRect; ASelected: Boolean); + end; + + resourcestring + sVTHeaderCategoryName = 'Header'; + sVTPaintingCategoryName = 'Custom painting'; + sVTIncremenalCategoryName = 'Incremental search'; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeEditor.Edit; + +begin + ShowCollectionEditor(Designer, Component, TVirtualTreeCast(Component).Header.Columns, 'Columns'); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +constructor TClipboardElement.Create(Parent: TPropertyEditor; AElement: string); + +begin + inherited Create(Parent); + FElement := AElement; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TClipboardElement.AllEqual: Boolean; + +// Determines if this element is included or excluded in all selected components it belongs to. + +var + I, Index: Integer; + List: TClipboardFormats; + V: Boolean; + +begin + Result := False; + if PropCount > 1 then + begin + List := TClipboardFormats(GetOrdValue); + V := List.Find(FElement, Index); + for I := 1 to PropCount - 1 do + begin + List := TClipboardFormats(GetOrdValue); + if List.Find(FElement, Index) <> V then + Exit; + end; + end; + Result := True; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TClipboardElement.GetAttributes: TPropertyAttributes; + +begin + Result := [paMultiSelect, paValueList, paSortList]; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TClipboardElement.GetName: string; + +begin + Result := FElement; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TClipboardElement.GetValue: string; + +var + List: TClipboardFormats; + +begin + List := TClipboardFormats(GetOrdValue); + Result := BooleanIdents[List.IndexOf(FElement) > -1]; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TClipboardElement.GetValues(Proc: TGetStrProc); + +begin + Proc(BooleanIdents[False]); + Proc(BooleanIdents[True]); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TClipboardElement.SetValue(const Value: string); + +var + List: TClipboardFormats; + I, Index: Integer; + +begin + if CompareText(Value, 'True') = 0 then + begin + for I := 0 to PropCount - 1 do + begin + List := TClipboardFormats(GetOrdValueAt(I)); + List.Add(FElement); + end; + end + else + begin + for I := 0 to PropCount - 1 do + begin + List := TClipboardFormats(GetOrdValueAt(I)); + if List.Find(FElement, Index) then + List.Delete(Index); + end; + end; + Modified; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure DrawBoolean(Checked: Boolean; ACanvas: TCanvas; const ARect: TRect; ASelected: Boolean); + +var + BoxSize, + EntryWidth: Integer; + R: TRect; + State: Cardinal; + +begin + with ACanvas do + begin + FillRect(ARect); + + BoxSize := ARect.Bottom - ARect.Top; + EntryWidth := ARect.Right - ARect.Left; + + R := Rect(ARect.Left + (EntryWidth - BoxSize) div 2, ARect.Top, ARect.Left + (EntryWidth + BoxSize) div 2, + ARect.Bottom); + InflateRect(R, -1, -1); + State := DFCS_BUTTONCHECK; + if Checked then + State := State or DFCS_CHECKED; + DrawFrameControl(Handle, R, DFC_BUTTON, State); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TClipboardElement.PropDrawName(ACanvas: TCanvas; const ARect: TRect; ASelected: Boolean); + +begin + DefaultPropertyDrawName(Self, ACanvas, ARect); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TClipboardElement.PropDrawValue(ACanvas: TCanvas; const ARect: TRect; ASelected: Boolean); + +begin + DrawBoolean(CompareText(GetVisualValue, 'True') = 0, ACanvas, ARect, ASelected); +end; + +//----------------- TClipboardFormatsProperty -------------------------------------------------------------------------- + +function TClipboardFormatsProperty.GetAttributes: TPropertyAttributes; + +begin + Result := inherited GetAttributes + [paSubProperties, paFullWidthName]; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TClipboardFormatsProperty.GetProperties(Proc: TGetPropEditProc); + +var + List: TStringList; + I: Integer; + Tree: TBaseVirtualTree; + +begin + List := TStringList.Create; + Tree := TClipboardFormats(GetOrdValue).Owner; + EnumerateVTClipboardFormats(TVirtualTreeClass(Tree.ClassType), List); + for I := 0 to List.Count - 1 do + Proc(TClipboardElement.Create(Self, List[I])); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TClipboardFormatsProperty.PropDrawName(ACanvas: TCanvas; const ARect: TRect; ASelected: Boolean); + +var + S: string; + Width: Integer; + R: TRect; + +begin + with ACanvas do + begin + Font.Name := 'Arial'; + R := ARect; + Font.Color := clBlack; + S := GetName; + Width := TextWidth(S); + TextRect(R, R.Left + 1, R.Top + 1, S); + + Inc(R.Left, Width + 8); + Font.Height := 14; + Font.Color := clBtnHighlight; + S := '(OLE drag and clipboard)'; + SetBkMode(Handle, TRANSPARENT); + ExtTextOut(Handle, R.Left + 1, R.Top + 1, ETO_CLIPPED, @R, PChar(S), Length(S), nil); + Font.Color := clBtnShadow; + ExtTextOut(Handle, R.Left, R.Top, ETO_CLIPPED, @R, PChar(S), Length(S), nil); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TClipboardFormatsProperty.PropDrawValue(ACanvas: TCanvas; const ARect: TRect; ASelected: Boolean); + +begin + // Nothing to do here. +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure Register; + +begin + RegisterComponents('Virtual Controls', [TVirtualStringTree, TVirtualDrawTree, TVTHeaderPopupMenu]); + RegisterComponentEditor(TVirtualStringTree, TVirtualTreeEditor); + RegisterComponentEditor(TVirtualDrawTree, TVirtualTreeEditor); + RegisterPropertyEditor(TypeInfo(TClipboardFormats), nil, '', TClipboardFormatsProperty); + + // Categories: + RegisterPropertiesInCategory(sActionCategoryName, TBaseVirtualTree, ['ChangeDelay', 'EditDelay']); + + RegisterPropertiesInCategory(sDataCategoryName, + TBaseVirtualTree, + ['NodeDataSize', + 'RootNodeCount', + 'OnCompareNodes', + 'OnGetNodeDataSize', + 'OnInitNode', + 'OnInitChildren', + 'OnFreeNode', + 'OnGetNodeWidth', + 'OnGetPopupMenu', + 'OnLoadNode', + 'OnSaveNode', + 'OnResetNode', + 'OnNodeMov*', + 'OnStructureChange', + 'OnUpdating', + 'OnGetText', + 'OnNewText', + 'OnShortenString']); + + RegisterPropertiesInCategory(slayoutCategoryName, + TBaseVirtualTree, + ['AnimationDuration', + 'AutoExpandDelay', + 'AutoScroll*', + 'ButtonStyle', + 'DefaultNodeHeight', + '*Images*', 'OnGetImageIndex', 'OnGetImageText', + 'Header', + 'Indent', + 'LineStyle', 'OnGetLineStyle', + 'CheckImageKind', + 'Options', + 'Margin', + 'NodeAlignment', + 'ScrollBarOptions', + 'SelectionCurveRadius', + 'TextMargin']); + + RegisterPropertiesInCategory(sVisualCategoryName, + TBaseVirtualTree, + ['Background*', + 'ButtonFillMode', + 'CustomCheckimages', + 'Colors', + 'LineMode']); + + RegisterPropertiesInCategory(sHelpCategoryName, + TBaseVirtualTree, + ['AccessibleName', 'Hint*', 'On*Hint*', 'On*Help*']); + + RegisterPropertiesInCategory(sDragNDropCategoryName, + TBaseVirtualTree, + ['ClipboardFormats', + 'DefaultPasteMode', + 'OnCreateDataObject', + 'OnCreateDragManager', + 'OnGetUserClipboardFormats', + 'OnNodeCop*', + 'OnDragAllowed', + 'OnRenderOLEData']); + + RegisterPropertiesInCategory(sInputCategoryName, + TBaseVirtualTree, + ['DefaultText', + 'DrawSelectionMode', + 'WantTabs', + 'OnChang*', + 'OnCollaps*', + 'OnExpand*', + 'OnCheck*', + 'OnEdit*', + 'On*Click', + 'OnFocus*', + 'OnCreateEditor', + 'OnScroll', + 'OnNodeHeightTracking', + 'OnHotChange']); + + RegisterPropertiesInCategory(sVTHeaderCategoryName, + TBaseVirtualTree, + ['OnHeader*', 'OnGetHeader*']); + + RegisterPropertiesInCategory(sVTPaintingCategoryName, + TBaseVirtualTree, + ['On*Paint*', + 'OnDraw*', + 'On*Erase*']); + + RegisterPropertiesInCategory(sVTIncremenalCategoryName, + TBaseVirtualTree, + ['*Incremental*']); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +end. diff --git a/components/virtualtreeview/MAKEFILE b/components/virtualtreeview/MAKEFILE index aba6f01c..e10d0294 100644 --- a/components/virtualtreeview/MAKEFILE +++ b/components/virtualtreeview/MAKEFILE @@ -3,9 +3,6 @@ EMBARCADERO = $(PROGRAMFILES)\Embarcadero\RAD Studio STUDIO = $(PROGRAMFILES)\Embarcadero\Studio BDSCOMMONDIRMAIN = %PUBLIC%\Documents\Embarcadero\Studio # Default MS Build version -!IF EXIST("$(PROGRAMFILESX64)\Microsoft Visual Studio\2022\Enterprise\MSBuild\Current\Bin\msbuild.exe") -BUILDEXE = "$(PROGRAMFILESX64)\Microsoft Visual Studio\2022\Enterprise\MSBuild\Current\Bin\msbuild.exe" -!ELSE !IF EXIST("$(PROGRAMFILES)\Microsoft Visual Studio\2019\Enterprise\MSBuild\Current\Bin\msbuild.exe") BUILDEXE = "$(PROGRAMFILES)\Microsoft Visual Studio\2019\Enterprise\MSBuild\Current\Bin\msbuild.exe" !ELSE @@ -15,7 +12,6 @@ BUILDEXE = "$(PROGRAMFILES)\Microsoft Visual Studio\2019\Professional\MSBuild\Cu BUILDEXE = "$(PROGRAMFILES)\Microsoft Visual Studio\2017\BuildTools\MSBuild\15.0\Bin\msbuild.exe" !ENDIF !ENDIF -!ENDIF BUILD = $(BUILDEXE) /t:Rebuild clean: @@ -54,6 +50,7 @@ _release: #Download e.g. from: ftp://ftp.info-zip.org/pub/infozip/win32/ ZIP -9 -r .\VirtualTreeView.zip INSTALL.txt Changes.txt Source Design Packages Demos Contributions Help\VirtualTreeview.chm -i *.pas -i *.dpk -i *.groupproj -i *.dproj -i *.cbproj -i *.hlp -i *.rc -i *.res -i *.cfg -i *.dpr -i *.dof -i *.bpr -i *.dfm -i *.cpp -i *.inc -i *.dcr -i *.chm -i *.png -i *.js -i *.txt -i *.bmp -i *.uni ECHO Source code zip archive "VirtualTreeView.zip" created. + ECHO !!! Please ensure that the const TVTVersion is correct or remove const!!! ECHO !!! Please add version number to ZIP file name!!! ECHO !!! Please create release at: https://github.com/Virtual-TreeView/Virtual-TreeView/releases ECHO !!! Let JAM web-team upload the file to our server at https://www.jam-software.com/virtual-treeview diff --git a/components/virtualtreeview/README.md b/components/virtualtreeview/README.md index d05cef65..b4d981bf 100644 --- a/components/virtualtreeview/README.md +++ b/components/virtualtreeview/README.md @@ -5,7 +5,7 @@ Virtual Treeview is a Delphi treeview control built from ground up. Many years o I don't use C++ Builder and my experience with it is very limited. This makes it difficult to take care about bugs that are reported in C++ Builder and to maintain the C++ Builder packages. I would be great if someone would volunteer to do this. ### Downloads -**V7.6.x** official release for **RAD Studio XE3 to 10.4.2 Rio**: [JAM Software](https://www.jam-software.com/virtual-treeview/VirtualTreeView.zip) +**V7.5** official release for **RAD Studio XE3 to 10.4.2 Rio**: [JAM Software](https://www.jam-software.com/virtual-treeview/VirtualTreeView.zip) ([Changes](https://github.com/JAM-Software/Virtual-TreeView/issues?q=is%3Aissue+milestone%3AV7.5+is%3Aclosed)) An experimental **FireMonkey** port can be found here: [livius2/Virtual-TreeView](https://github.com/livius2/Virtual-TreeView) diff --git a/components/virtualtreeview/Source/VirtualTrees.Accessibility.pas b/components/virtualtreeview/Source/VirtualTrees.Accessibility.pas index 04b516d2..8e5d19ab 100644 --- a/components/virtualtreeview/Source/VirtualTrees.Accessibility.pas +++ b/components/virtualtreeview/Source/VirtualTrees.Accessibility.pas @@ -99,7 +99,8 @@ type implementation uses - System.SysUtils, Vcl.Forms, System.Variants, System.Math; + System.SysUtils, Vcl.Forms, System.Variants, System.Math, + VirtualTrees.Types; type diff --git a/components/virtualtreeview/Source/VirtualTrees.AccessibilityFactory.pas b/components/virtualtreeview/Source/VirtualTrees.AccessibilityFactory.pas index 5c772d81..d6270313 100644 --- a/components/virtualtreeview/Source/VirtualTrees.AccessibilityFactory.pas +++ b/components/virtualtreeview/Source/VirtualTrees.AccessibilityFactory.pas @@ -1,178 +1,178 @@ -unit VirtualTrees.AccessibilityFactory; - -// 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. -//---------------------------------------------------------------------------------------------------------------------- - - -// class to create IAccessibles for the tree passed into it. -// If not already assigned, creates IAccessibles for the tree itself -// and the focused item -// the tree accessible is returned when the tree receives an WM_GETOBJECT message -// the AccessibleItem is returned when the Accessible is being asked for the first child -// To create your own IAccessibles, use the VTStandardAccessible unit as a reference, -// and assign your Accessibles to the variables in the unit's initialization. -// You only need to add the unit to your project, and voilá, you have an accessible string tree! -// -// Written by Marco Zehe. (c) 2007 - -interface - -uses - System.Classes, Winapi.oleacc, VirtualTrees; - -type - IVTAccessibleProvider = interface - function CreateIAccessible(ATree: TBaseVirtualTree): IAccessible; - end; - - TVTAccessibilityFactory = class(TObject) - strict private class var - FAccessibilityAvailable: Boolean; - FVTAccessibleFactory: TVTAccessibilityFactory; - strict private - FAccessibleProviders: TInterfaceList; - private - class procedure FreeFactory; - public - constructor Create; - destructor Destroy; override; - function CreateIAccessible(ATree: TBaseVirtualTree): IAccessible; - class function GetAccessibilityFactory: TVTAccessibilityFactory; static; - procedure RegisterAccessibleProvider(const AProvider: IVTAccessibleProvider); - procedure UnRegisterAccessibleProvider(const AProvider: IVTAccessibleProvider); - end; - - -implementation - -{ TVTAccessibilityFactory } - -constructor TVTAccessibilityFactory.Create; -begin - inherited Create; - FAccessibleProviders := TInterfaceList.Create; - FAccessibleProviders.Clear; -end; - -function TVTAccessibilityFactory.CreateIAccessible( - ATree: TBaseVirtualTree): IAccessible; -var - I: Integer; - TmpIAccessible: IAccessible; -// returns an IAccessible. -// 1. If the Accessible property of the passed-in tree is nil, -// the first registered element will be returned. -// Usually, this is the IAccessible that provides information about the tree itself. -// If it is not nil, we'll check whether the AccessibleItem is nil. -// If it is, we'll look in the registered IAccessibles for the appropriate one. -// Each IAccessibleProvider will check the tree for properties to determine whether it is responsible. -// We'll work top to bottom, from the most complicated to the most simple. -// The index for these should all be greater than 0, e g the IAccessible for the tree itself should always be registered first, then any IAccessible items. -begin - Result := nil; - if ATree <> nil then - begin - if ATree.Accessible = nil then - begin - if FAccessibleProviders.Count > 0 then - begin - Result := IVTAccessibleProvider(FAccessibleProviders.Items[0]).CreateIAccessible(ATree); - Exit; - end; - end; - if ATree.AccessibleItem = nil then - begin - if FAccessibleProviders.Count > 0 then - begin - for I := FAccessibleProviders.Count - 1 downto 1 do - begin - TmpIAccessible := IVTAccessibleProvider(FAccessibleProviders.Items[I]).CreateIAccessible(ATree); - if TmpIAccessible <> nil then - begin - Result := TmpIAccessible; - Break; - end; - end; - if TmpIAccessible = nil then - begin - Result := IVTAccessibleProvider(FAccessibleProviders.Items[0]).CreateIAccessible(ATree); - end; - end; - end - else - Result := ATree.AccessibleItem; - end; -end; - -destructor TVTAccessibilityFactory.Destroy; -begin - FAccessibleProviders.Free; - FAccessibleProviders := nil; - inherited Destroy; -end; - -class procedure TVTAccessibilityFactory.FreeFactory; -begin - FVTAccessibleFactory.Free; -end; - -procedure TVTAccessibilityFactory.RegisterAccessibleProvider(const AProvider: IVTAccessibleProvider); -// Ads a provider if it is not already registered -begin - if FAccessibleProviders.IndexOf(AProvider) < 0 then - FAccessibleProviders.Add(AProvider) -end; - -procedure TVTAccessibilityFactory.UnRegisterAccessibleProvider(const AProvider: IVTAccessibleProvider); -// Unregisters/removes an IAccessible provider if it is present -begin - if FAccessibleProviders.IndexOf(AProvider) >= 0 then - FAccessibleProviders.Remove(AProvider); -end; - -class function TVTAccessibilityFactory.GetAccessibilityFactory: TVTAccessibilityFactory; -// Accessibility helper function to create a singleton class that will create or return -// the IAccessible interface for the tree and the focused node. - -begin - // first, check if we've loaded the library already - if not FAccessibilityAvailable then - FAccessibilityAvailable := True; - if FAccessibilityAvailable then - begin - // Check to see if the class has already been created. - if FVTAccessibleFactory = nil then - FVTAccessibleFactory := TVTAccessibilityFactory.Create; - Result := FVTAccessibleFactory; - end - else - Result := nil; -end; - -initialization - -finalization - TVTAccessibilityFactory.FreeFactory; - -end. - - +unit VirtualTrees.AccessibilityFactory; + +// 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. +//---------------------------------------------------------------------------------------------------------------------- + + +// class to create IAccessibles for the tree passed into it. +// If not already assigned, creates IAccessibles for the tree itself +// and the focused item +// the tree accessible is returned when the tree receives an WM_GETOBJECT message +// the AccessibleItem is returned when the Accessible is being asked for the first child +// To create your own IAccessibles, use the VTStandardAccessible unit as a reference, +// and assign your Accessibles to the variables in the unit's initialization. +// You only need to add the unit to your project, and voilá, you have an accessible string tree! +// +// Written by Marco Zehe. (c) 2007 + +interface + +uses + System.Classes, Winapi.oleacc, VirtualTrees; + +type + IVTAccessibleProvider = interface + function CreateIAccessible(ATree: TBaseVirtualTree): IAccessible; + end; + + TVTAccessibilityFactory = class(TObject) + strict private class var + FAccessibilityAvailable: Boolean; + FVTAccessibleFactory: TVTAccessibilityFactory; + strict private + FAccessibleProviders: TInterfaceList; + private + class procedure FreeFactory; + public + constructor Create; + destructor Destroy; override; + function CreateIAccessible(ATree: TBaseVirtualTree): IAccessible; + class function GetAccessibilityFactory: TVTAccessibilityFactory; static; + procedure RegisterAccessibleProvider(const AProvider: IVTAccessibleProvider); + procedure UnRegisterAccessibleProvider(const AProvider: IVTAccessibleProvider); + end; + + +implementation + +{ TVTAccessibilityFactory } + +constructor TVTAccessibilityFactory.Create; +begin + inherited Create; + FAccessibleProviders := TInterfaceList.Create; + FAccessibleProviders.Clear; +end; + +function TVTAccessibilityFactory.CreateIAccessible( + ATree: TBaseVirtualTree): IAccessible; +var + I: Integer; + TmpIAccessible: IAccessible; +// returns an IAccessible. +// 1. If the Accessible property of the passed-in tree is nil, +// the first registered element will be returned. +// Usually, this is the IAccessible that provides information about the tree itself. +// If it is not nil, we'll check whether the AccessibleItem is nil. +// If it is, we'll look in the registered IAccessibles for the appropriate one. +// Each IAccessibleProvider will check the tree for properties to determine whether it is responsible. +// We'll work top to bottom, from the most complicated to the most simple. +// The index for these should all be greater than 0, e g the IAccessible for the tree itself should always be registered first, then any IAccessible items. +begin + Result := nil; + if ATree <> nil then + begin + if ATree.Accessible = nil then + begin + if FAccessibleProviders.Count > 0 then + begin + Result := IVTAccessibleProvider(FAccessibleProviders.Items[0]).CreateIAccessible(ATree); + Exit; + end; + end; + if ATree.AccessibleItem = nil then + begin + if FAccessibleProviders.Count > 0 then + begin + for I := FAccessibleProviders.Count - 1 downto 1 do + begin + TmpIAccessible := IVTAccessibleProvider(FAccessibleProviders.Items[I]).CreateIAccessible(ATree); + if TmpIAccessible <> nil then + begin + Result := TmpIAccessible; + Break; + end; + end; + if TmpIAccessible = nil then + begin + Result := IVTAccessibleProvider(FAccessibleProviders.Items[0]).CreateIAccessible(ATree); + end; + end; + end + else + Result := ATree.AccessibleItem; + end; +end; + +destructor TVTAccessibilityFactory.Destroy; +begin + FAccessibleProviders.Free; + FAccessibleProviders := nil; + inherited Destroy; +end; + +class procedure TVTAccessibilityFactory.FreeFactory; +begin + FVTAccessibleFactory.Free; +end; + +procedure TVTAccessibilityFactory.RegisterAccessibleProvider(const AProvider: IVTAccessibleProvider); +// Ads a provider if it is not already registered +begin + if FAccessibleProviders.IndexOf(AProvider) < 0 then + FAccessibleProviders.Add(AProvider) +end; + +procedure TVTAccessibilityFactory.UnRegisterAccessibleProvider(const AProvider: IVTAccessibleProvider); +// Unregisters/removes an IAccessible provider if it is present +begin + if FAccessibleProviders.IndexOf(AProvider) >= 0 then + FAccessibleProviders.Remove(AProvider); +end; + +class function TVTAccessibilityFactory.GetAccessibilityFactory: TVTAccessibilityFactory; +// Accessibility helper function to create a singleton class that will create or return +// the IAccessible interface for the tree and the focused node. + +begin + // first, check if we've loaded the library already + if not FAccessibilityAvailable then + FAccessibilityAvailable := True; + if FAccessibilityAvailable then + begin + // Check to see if the class has already been created. + if FVTAccessibleFactory = nil then + FVTAccessibleFactory := TVTAccessibilityFactory.Create; + Result := FVTAccessibleFactory; + end + else + Result := nil; +end; + +initialization + +finalization + TVTAccessibilityFactory.FreeFactory; + +end. + + diff --git a/components/virtualtreeview/Source/VirtualTrees.Actions.pas b/components/virtualtreeview/Source/VirtualTrees.Actions.pas index 8e607810..3800d77d 100644 --- a/components/virtualtreeview/Source/VirtualTrees.Actions.pas +++ b/components/virtualtreeview/Source/VirtualTrees.Actions.pas @@ -7,7 +7,8 @@ uses System.Actions, Vcl.Controls, Vcl.ActnList, - VirtualTrees; + VirtualTrees, + VirtualTrees.Types; type TVirtualTreeAction = class(TCustomAction) diff --git a/components/virtualtreeview/Source/VirtualTrees.BaseTree.pas b/components/virtualtreeview/Source/VirtualTrees.BaseTree.pas deleted file mode 100644 index e96872d6..00000000 --- a/components/virtualtreeview/Source/VirtualTrees.BaseTree.pas +++ /dev/null @@ -1,8 +0,0 @@ -unit VirtualTrees.BaseTree; -// Dummy unit to make migeration between V7 and V8 easier. - -interface - -implementation - -end. \ No newline at end of file diff --git a/components/virtualtreeview/Source/VirtualTrees.ClipBoard.pas b/components/virtualtreeview/Source/VirtualTrees.ClipBoard.pas index e995a877..b35c9416 100644 --- a/components/virtualtreeview/Source/VirtualTrees.ClipBoard.pas +++ b/components/virtualtreeview/Source/VirtualTrees.ClipBoard.pas @@ -32,7 +32,8 @@ uses Winapi.Windows, Winapi.ActiveX, System.Classes, - VirtualTrees; + VirtualTrees, + VirtualTrees.Types; type TClipboardFormatEntry = record @@ -98,6 +99,16 @@ type class function FindFormat(Fmt: Word; var Description: string): TVirtualTreeClass; overload; end; +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; + implementation diff --git a/components/virtualtreeview/Source/VirtualTrees.Colors.pas b/components/virtualtreeview/Source/VirtualTrees.Colors.pas new file mode 100644 index 00000000..dcb859fa --- /dev/null +++ b/components/virtualtreeview/Source/VirtualTrees.Colors.pas @@ -0,0 +1,252 @@ +unit VirtualTrees.Colors; + +interface + +uses + System.Classes, + Vcl.Graphics, + Vcl.Themes, + Vcl.Controls; + +type + //class to collect all switchable colors into one place + TVTColors = class(TPersistent) + private type + TVTColorEnum = (cDisabledColor, cDropMarkColor, cDropTargetColor, cFocusedSelectionColor, cGridLineColor, cTreeLineColor, cUnfocusedSelectionColor, cBorderColor, cHotColor, + cFocusedSelectionBorderColor, cUnfocusedSelectionBorderColor, cDropTargetBorderColor, cSelectionRectangleBlendColor, cSelectionRectangleBorderColor, cHeaderHotColor, + cSelectionTextColor, cUnfocusedColor); + + //Please make sure that the published Color properties at the corresponding index + //have the same color if you change anything here! + const + cDefaultColors : array [TVTColorEnum] of TColor = (clBtnShadow, //DisabledColor + clHighlight, //DropMarkColor + clHighlight, //DropTargetColor + clHighlight, //FocusedSelectionColor + clBtnFace, //GridLineColor + clBtnShadow, //TreeLineColor + clInactiveCaption, //UnfocusedSelectionColor + clBtnFace, //BorderColor + clWindowText, //HotColor + clHighlight, //FocusedSelectionBorderColor + clInactiveCaption, //UnfocusedSelectionBorderColor + clHighlight, //DropTargetBorderColor + clHighlight, //SelectionRectangleBlendColor + clHighlight, //SelectionRectangleBorderColor + clBtnShadow, //HeaderHotColor + clHighlightText, //SelectionTextColor + clInactiveCaptionText); //UnfocusedColor [IPK] + + private + FOwner : TCustomControl; + FColors : array [TVTColorEnum] of TColor; //[IPK] 15 -> 16 + function GetColor(const Index : TVTColorEnum) : TColor; + procedure SetColor(const Index : TVTColorEnum; const Value : TColor); + function GetBackgroundColor : TColor; + function GetHeaderFontColor : TColor; + function GetNodeFontColor : TColor; + public + constructor Create(AOwner : TCustomControl); + + procedure Assign(Source : TPersistent); override; + function GetSelectedNodeFontColor(Focused : boolean) : TColor; + property BackGroundColor : TColor read GetBackgroundColor; + property HeaderFontColor : TColor read GetHeaderFontColor; + property NodeFontColor : TColor read GetNodeFontColor; + //Mitigator function to use the correct style service for this context (either the style assigned to the control for Delphi > 10.4 or the application style) + function StyleServices(AControl : TControl = nil) : TCustomStyleServices; + published + property BorderColor : TColor index cBorderColor read GetColor write SetColor default clBtnFace; + property DisabledColor : TColor index cDisabledColor read GetColor write SetColor default clBtnShadow; + property DropMarkColor : TColor index cDropMarkColor read GetColor write SetColor default clHighlight; + property DropTargetColor : TColor index cDropTargetColor read GetColor write SetColor default clHighlight; + property DropTargetBorderColor : TColor index cDropTargetBorderColor read GetColor write SetColor default clHighlight; + ///The background color of selected nodes in case the tree has the focus, or the toPopupMode flag is set. + property FocusedSelectionColor : TColor index cFocusedSelectionColor read GetColor write SetColor default clHighlight; + ///The border color of selected nodes when the tree has the focus. + property FocusedSelectionBorderColor : TColor index cFocusedSelectionBorderColor read GetColor write SetColor default clHighlight; + property GridLineColor : TColor index cGridLineColor read GetColor write SetColor default clBtnFace; + property HeaderHotColor : TColor index cHeaderHotColor read GetColor write SetColor default clBtnShadow; + property HotColor : TColor index cHotColor read GetColor write SetColor default clWindowText; + property SelectionRectangleBlendColor : TColor index cSelectionRectangleBlendColor read GetColor write SetColor default clHighlight; + property SelectionRectangleBorderColor : TColor index cSelectionRectangleBorderColor read GetColor write SetColor default clHighlight; + ///The text color of selected nodes + property SelectionTextColor : TColor index cSelectionTextColor read GetColor write SetColor default clHighlightText; + property TreeLineColor : TColor index cTreeLineColor read GetColor write SetColor default clBtnShadow; + property UnfocusedColor : TColor index cUnfocusedColor read GetColor write SetColor default clInactiveCaptionText; //[IPK] Added + ///The background color of selected nodes in case the tree does not have the focus and the toPopupMode flag is not set. + property UnfocusedSelectionColor : TColor index cUnfocusedSelectionColor read GetColor write SetColor default clInactiveCaption; + ///The border color of selected nodes in case the tree does not have the focus and the toPopupMode flag is not set. + property UnfocusedSelectionBorderColor : TColor index cUnfocusedSelectionBorderColor read GetColor write SetColor default clInactiveCaption; + end; + +implementation + +uses + WinApi.Windows, + VirtualTrees, + VirtualTrees.Utils, + VirtualTrees.StyleHooks; + +type + TBaseVirtualTreeCracker = class(TBaseVirtualTree); + + TVTColorsHelper = class helper for TVTColors + function TreeView : TBaseVirtualTreeCracker; + end; + + //----------------- TVTColors ------------------------------------------------------------------------------------------ + +constructor TVTColors.Create(AOwner : TCustomControl); +var + CE : TVTColorEnum; +begin + FOwner := AOwner; + for CE := Low(TVTColorEnum) to High(TVTColorEnum) do + FColors[CE] := cDefaultColors[CE]; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTColors.GetBackgroundColor : TColor; +begin + //XE2 VCL Style + if TreeView.VclStyleEnabled and (seClient in FOwner.StyleElements) then + Result := StyleServices.GetStyleColor(scTreeView) + else + Result := TreeView.Color; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTColors.GetColor(const Index : TVTColorEnum) : TColor; +begin + //Only try to fetch the color via StyleServices if theses are enabled + //Return default/user defined color otherwise + if TreeView.VclStyleEnabled then + begin + //If the ElementDetails are not defined, fall back to the SystemColor + case Index of + cDisabledColor : + if not StyleServices.GetElementColor(StyleServices.GetElementDetails(ttItemDisabled), ecTextColor, Result) then + Result := StyleServices.GetSystemColor(FColors[Index]); + cTreeLineColor : + if not StyleServices.GetElementColor(StyleServices.GetElementDetails(ttBranch), ecBorderColor, Result) then + Result := StyleServices.GetSystemColor(FColors[Index]); + cBorderColor : + if (seBorder in FOwner.StyleElements) then + Result := StyleServices.GetSystemColor(FColors[Index]) + else + Result := FColors[Index]; + cHotColor : + if not StyleServices.GetElementColor(StyleServices.GetElementDetails(ttItemHot), ecTextColor, Result) then + Result := StyleServices.GetSystemColor(FColors[Index]); + cHeaderHotColor : + if not StyleServices.GetElementColor(StyleServices.GetElementDetails(thHeaderItemHot), ecTextColor, Result) then + Result := StyleServices.GetSystemColor(FColors[Index]); + cSelectionTextColor : + if not StyleServices.GetElementColor(StyleServices.GetElementDetails(ttItemSelected), ecTextColor, Result) then + Result := StyleServices.GetSystemColor(clHighlightText); + cUnfocusedColor : + if not StyleServices.GetElementColor(StyleServices.GetElementDetails(ttItemSelectedNotFocus), ecTextColor, Result) then + Result := StyleServices.GetSystemColor(FColors[Index]); + else + Result := StyleServices.GetSystemColor(FColors[Index]); + end; + end + else + Result := FColors[Index]; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTColors.GetHeaderFontColor : TColor; +begin + //XE2+ VCL Style + if TreeView.VclStyleEnabled and (seFont in FOwner.StyleElements) then + StyleServices.GetElementColor(StyleServices.GetElementDetails(thHeaderItemNormal), ecTextColor, Result) + else + Result := TreeView.Header.Font.Color; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTColors.GetNodeFontColor : TColor; +begin + if TreeView.VclStyleEnabled and (seFont in FOwner.StyleElements) then + StyleServices.GetElementColor(StyleServices.GetElementDetails(ttItemNormal), ecTextColor, Result) + else + Result := TreeView.Font.Color; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTColors.GetSelectedNodeFontColor(Focused : boolean) : TColor; +begin + if Focused then + begin + if (tsUseExplorerTheme in TreeView.TreeStates) and not IsHighContrastEnabled then + begin + Result := NodeFontColor + end + else + Result := SelectionTextColor + end//if Focused + else + Result := UnfocusedColor; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTColors.SetColor(const Index : TVTColorEnum; 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 + cTreeLineColor : + begin + TreeView.PrepareBitmaps(True, False); + FOwner.Invalidate; + end; + cBorderColor : + RedrawWindow(FOwner.Handle, nil, 0, RDW_FRAME or RDW_INVALIDATE or RDW_NOERASE or RDW_NOCHILDREN) + else + FOwner.Invalidate; + end; + end; + end; +end; + +function TVTColors.StyleServices(AControl : TControl) : TCustomStyleServices; +begin + if AControl = nil then + AControl := FOwner; + Result := VTStyleServices(AControl); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTColors.Assign(Source : TPersistent); +begin + if Source is TVTColors then + begin + FColors := TVTColors(Source).FColors; + if TreeView.UpdateCount = 0 then + TreeView.Invalidate; + end + else + inherited; +end; + +{ TVTColorsHelper } + +function TVTColorsHelper.TreeView : TBaseVirtualTreeCracker; +begin + Result := TBaseVirtualTreeCracker(FOwner); +end; + +end. diff --git a/components/virtualtreeview/Source/VirtualTrees.DataObject.pas b/components/virtualtreeview/Source/VirtualTrees.DataObject.pas new file mode 100644 index 00000000..368e3763 --- /dev/null +++ b/components/virtualtreeview/Source/VirtualTrees.DataObject.pas @@ -0,0 +1,482 @@ +unit VirtualTrees.DataObject; + +interface + +uses + WinApi.ActiveX, + WinApi.Windows, + VirtualTrees.Types, + Vcl.Controls; + +type + // IDataObject.SetData support + TInternalStgMedium = packed record + Format : TClipFormat; + Medium : TStgMedium; + end; + + TInternalStgMediumArray = array of TInternalStgMedium; + + // 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 : TCustomControl; // 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(const 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; const DataObject : IDataObject) : HResult; + + property ForClipboard : Boolean read FForClipboard; + property FormatEtcArray : TFormatEtcArray read FFormatEtcArray write FFormatEtcArray; + property InternalStgMediumArray : TInternalStgMediumArray read FInternalStgMediumArray write FInternalStgMediumArray; + property Owner : TCustomControl read FOwner; + public + constructor Create(AOwner : TCustomControl; ForClipboard : Boolean); virtual; + destructor Destroy; override; + + function DAdvise(const FormatEtc : TFormatEtc; advf : integer; const advSink : IAdviseSink; out dwConnection : integer) : HResult; virtual; stdcall; + function DUnadvise(dwConnection : integer) : HResult; virtual; stdcall; + function EnumDAdvise(out enumAdvise : IEnumStatData) : HResult; virtual; stdcall; + function EnumFormatEtc(Direction : integer; out EnumFormatEtc : IEnumFormatEtc) : HResult; virtual; stdcall; + function GetCanonicalFormatEtc(const FormatEtc : TFormatEtc; out FormatEtcOut : TFormatEtc) : HResult; virtual; stdcall; + function GetData(const FormatEtcIn : TFormatEtc; out Medium : TStgMedium) : HResult; virtual; stdcall; + function GetDataHere(const FormatEtc : TFormatEtc; out Medium : TStgMedium) : HResult; virtual; stdcall; + function QueryGetData(const FormatEtc : TFormatEtc) : HResult; virtual; stdcall; + function SetData(const FormatEtc : TFormatEtc; var Medium : TStgMedium; DoRelease : BOOL) : HResult; virtual; stdcall; + end; + +implementation + +uses + VirtualTrees, + VirtualTrees.ClipBoard, + VirtualTrees.DragnDrop; + +type + TVTCracker = class(TBaseVirtualTree); + + //----------------- TVTDataObject -------------------------------------------------------------------------------------- + +constructor TVTDataObject.Create(AOwner : TCustomControl; ForClipboard : Boolean); +begin + inherited Create; + + FOwner := AOwner; + FForClipboard := ForClipboard; + TVTCracker(FOwner).GetNativeClipboardFormats(FFormatEtcArray); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +destructor TVTDataObject.Destroy; +var + I : integer; + StgMedium : PStgMedium; +begin + // Cancel a pending clipboard operation if this data object was created for the clipboard and + // is freed because something else is placed there. + if FForClipboard and not (tsClipboardFlushing in TBaseVirtualTree(FOwner).TreeStates) then + TBaseVirtualTree(FOwner).CancelCutOrCopy; + + // Release any internal clipboard formats + for I := 0 to High(FormatEtcArray) do + begin + StgMedium := FindInternalStgMedium(FormatEtcArray[I].cfFormat); + if Assigned(StgMedium) then + ReleaseStgMedium(StgMedium^); + end; + + FormatEtcArray := nil; + inherited; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTDataObject.CanonicalIUnknown(const TestUnknown : IUnknown) : IUnknown; +// Uses COM object identity: An explicit call to the IUnknown::QueryInterface method, requesting the IUnknown +// interface, will always return the same pointer. +begin + if Assigned(TestUnknown) then + begin + if TestUnknown.QueryInterface(IUnknown, Result) = 0 then + Result._Release // Don't actually need it just need the pointer value + else + Result := TestUnknown; + end + else + Result := TestUnknown; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTDataObject.EqualFormatEtc(FormatEtc1, FormatEtc2 : TFormatEtc) : Boolean; +begin + Result := (FormatEtc1.cfFormat = FormatEtc2.cfFormat) and (FormatEtc1.ptd = FormatEtc2.ptd) and (FormatEtc1.dwAspect = FormatEtc2.dwAspect) and + (FormatEtc1.lindex = FormatEtc2.lindex) and (FormatEtc1.tymed and FormatEtc2.tymed <> 0); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTDataObject.FindFormatEtc(TestFormatEtc : TFormatEtc; const FormatEtcArray : TFormatEtcArray) : integer; +var + I : integer; +begin + Result := - 1; + for I := 0 to High(FormatEtcArray) do + begin + if EqualFormatEtc(TestFormatEtc, FormatEtcArray[I]) then + begin + Result := I; + Break; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTDataObject.FindInternalStgMedium(Format : TClipFormat) : PStgMedium; +var + I : integer; +begin + Result := nil; + for I := 0 to High(InternalStgMediumArray) do + begin + if Format = InternalStgMediumArray[I].Format then + begin + Result := @InternalStgMediumArray[I].Medium; + Break; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTDataObject.HGlobalClone(HGlobal : THandle) : THandle; +// Returns a global memory block that is a copy of the passed memory block. +var + Size : Cardinal; + Data, NewData : PByte; +begin + Size := GlobalSize(HGlobal); + Result := GlobalAlloc(GPTR, Size); + Data := GlobalLock(HGlobal); + try + NewData := GlobalLock(Result); + try + Move(Data^, NewData^, Size); + finally + GlobalUnLock(Result); + end; + finally + GlobalUnLock(HGlobal); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTDataObject.RenderInternalOLEData(const FormatEtcIn : TFormatEtc; var Medium : TStgMedium; var OLEResult : HResult) : Boolean; +// Tries to render one of the formats which have been stored via the SetData method. +// Since this data is already there it is just copied or its reference count is increased (depending on storage medium). +var + InternalMedium : PStgMedium; +begin + Result := True; + InternalMedium := FindInternalStgMedium(FormatEtcIn.cfFormat); + if Assigned(InternalMedium) then + OLEResult := StgMediumIncRef(InternalMedium^, Medium, False, Self as IDataObject) + else + Result := False; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTDataObject.StgMediumIncRef(const InStgMedium : TStgMedium; var OutStgMedium : TStgMedium; CopyInMedium : Boolean; const DataObject : IDataObject) : HResult; +// InStgMedium is the data that is requested, OutStgMedium is the data that we are to return either a copy of or +// increase the IDataObject's reference and send ourselves back as the data (unkForRelease). The InStgMedium is usually +// the result of a call to find a particular FormatEtc that has been stored locally through a call to SetData. +// If CopyInMedium is not true we already have a local copy of the data when the SetData function was called (during +// that call the CopyInMedium must be true). Then as the caller asks for the data through GetData we do not have to make +// copy of the data for the caller only to have them destroy it then need us to copy it again if necessary. +// This way we increase the reference count to ourselves and pass the STGMEDIUM structure initially stored in SetData. +// This way when the caller frees the structure it sees the unkForRelease is not nil and calls Release on the object +// instead of destroying the actual data. +var + Len : integer; +begin + Result := S_OK; + + // Simply copy all fields to start with. + OutStgMedium := InStgMedium; + // The data handled here always results from a call of SetData we got. This ensures only one storage format + // is indicated and hence the case statement below is safe (IDataObject.GetData can optionally use several + // storage formats). + case InStgMedium.tymed of + TYMED_HGLOBAL : + begin + if CopyInMedium then + begin + // Generate a unique copy of the data passed + OutStgMedium.HGlobal := HGlobalClone(InStgMedium.HGlobal); + if OutStgMedium.HGlobal = 0 then + Result := E_OUTOFMEMORY; + end + else + // Don't generate a copy just use ourselves and the copy previously saved. + OutStgMedium.unkForRelease := Pointer(DataObject); // Does not increase RefCount. + end; + TYMED_FILE : + begin + Len := lstrLenW(InStgMedium.lpszFileName) + 1; // Don't forget the terminating null character. + OutStgMedium.lpszFileName := CoTaskMemAlloc(2 * Len); + Move(InStgMedium.lpszFileName^, OutStgMedium.lpszFileName^, 2 * Len); + end; + TYMED_ISTREAM : + IUnknown(OutStgMedium.stm)._AddRef; + TYMED_ISTORAGE : + IUnknown(OutStgMedium.stg)._AddRef; + TYMED_GDI : + if not CopyInMedium then + // Don't generate a copy just use ourselves and the previously saved data. + OutStgMedium.unkForRelease := Pointer(DataObject) // Does not increase RefCount. + else + Result := DV_E_TYMED; // Don't know how to copy GDI objects right now. + TYMED_MFPICT : + if not CopyInMedium then + // Don't generate a copy just use ourselves and the previously saved data. + OutStgMedium.unkForRelease := Pointer(DataObject) // Does not increase RefCount. + else + Result := DV_E_TYMED; // Don't know how to copy MetaFile objects right now. + TYMED_ENHMF : + if not CopyInMedium then + // Don't generate a copy just use ourselves and the previously saved data. + OutStgMedium.unkForRelease := Pointer(DataObject) // Does not increase RefCount. + else + Result := DV_E_TYMED; // Don't know how to copy enhanced metafiles objects right now. + else + Result := DV_E_TYMED; + end; + + if (Result = S_OK) and Assigned(OutStgMedium.unkForRelease) then + IUnknown(OutStgMedium.unkForRelease)._AddRef; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTDataObject.DAdvise(const FormatEtc : TFormatEtc; advf : integer; const advSink : IAdviseSink; out dwConnection : integer) : HResult; +// Advise sink management is greatly simplified by the IDataAdviseHolder interface. +// We use this interface and forward all concerning calls to it. +begin + Result := S_OK; + if FAdviseHolder = nil then + Result := CreateDataAdviseHolder(FAdviseHolder); + if Result = S_OK then + Result := FAdviseHolder.Advise(Self as IDataObject, FormatEtc, advf, advSink, dwConnection); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTDataObject.DUnadvise(dwConnection : integer) : HResult; +begin + if FAdviseHolder = nil then + Result := E_NOTIMPL + else + Result := FAdviseHolder.Unadvise(dwConnection); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTDataObject.EnumDAdvise(out enumAdvise : IEnumStatData) : HResult; +begin + if FAdviseHolder = nil then + Result := OLE_E_ADVISENOTSUPPORTED + else + Result := FAdviseHolder.enumAdvise(enumAdvise); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTDataObject.EnumFormatEtc(Direction : integer; out EnumFormatEtc : IEnumFormatEtc) : HResult; +var + NewList : TEnumFormatEtc; +begin + Result := E_FAIL; + if Direction = DATADIR_GET then + begin + NewList := TEnumFormatEtc.Create(FormatEtcArray); + EnumFormatEtc := NewList as IEnumFormatEtc; + Result := S_OK; + end + else + EnumFormatEtc := nil; + if EnumFormatEtc = nil then + Result := OLE_S_USEREG; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTDataObject.GetCanonicalFormatEtc(const FormatEtc : TFormatEtc; out FormatEtcOut : TFormatEtc) : HResult; +begin + Result := DATA_S_SAMEFORMATETC; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTDataObject.GetData(const FormatEtcIn : TFormatEtc; out Medium : TStgMedium) : HResult; +// Data is requested by clipboard or drop target. This method dispatchs the call +// depending on the data being requested. +var + I : integer; + Data : PVTReference; +begin + // The tree reference format is always supported and returned from here. + if FormatEtcIn.cfFormat = CF_VTREFERENCE then + begin + // Note: this format is not used while flushing the clipboard to avoid a dangling reference + // when the owner tree is destroyed before the clipboard data is replaced with something else. + if tsClipboardFlushing in TBaseVirtualTree(FOwner).TreeStates then + Result := E_FAIL + else + begin + Medium.HGlobal := GlobalAlloc(GHND or GMEM_SHARE, SizeOf(TVTReference)); + Data := GlobalLock(Medium.HGlobal); + Data.Process := GetCurrentProcessID; + Data.Tree := TBaseVirtualTree(FOwner); + GlobalUnLock(Medium.HGlobal); + Medium.tymed := TYMED_HGLOBAL; + Medium.unkForRelease := nil; + Result := S_OK; + end; + end + else + begin + try + // See if we accept this type and if not get the correct return value. + Result := QueryGetData(FormatEtcIn); + if Result = S_OK then + begin + for I := 0 to High(FormatEtcArray) do + begin + if EqualFormatEtc(FormatEtcIn, FormatEtcArray[I]) then + begin + if not RenderInternalOLEData(FormatEtcIn, Medium, Result) then + Result := TVTCracker(FOwner).RenderOLEData(FormatEtcIn, Medium, FForClipboard); + Break; + end; + end; + end; + except + ZeroMemory(@Medium, SizeOf(Medium)); + Result := E_FAIL; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTDataObject.GetDataHere(const FormatEtc : TFormatEtc; out Medium : TStgMedium) : HResult; +begin + Result := E_NOTIMPL; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTDataObject.QueryGetData(const FormatEtc : TFormatEtc) : HResult; +var + I : integer; +begin + Result := DV_E_CLIPFORMAT; + for I := 0 to High(FFormatEtcArray) do + begin + if FormatEtc.cfFormat = FFormatEtcArray[I].cfFormat then + begin + if (FormatEtc.tymed and FFormatEtcArray[I].tymed) <> 0 then + begin + if FormatEtc.dwAspect = FFormatEtcArray[I].dwAspect then + begin + if FormatEtc.lindex = FFormatEtcArray[I].lindex then + begin + Result := S_OK; + Break; + end + else + Result := DV_E_LINDEX; + end + else + Result := DV_E_DVASPECT; + end + else + Result := DV_E_TYMED; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTDataObject.SetData(const FormatEtc : TFormatEtc; var Medium : TStgMedium; DoRelease : BOOL) : HResult; +// Allows dynamic adding to the IDataObject during its existance. Most noteably it is used to implement +// IDropSourceHelper and allows to set a special format for optimized moves during a shell transfer. +var + Index : integer; + LocalStgMedium : PStgMedium; +begin + // See if we already have a format of that type available. + Index := FindFormatEtc(FormatEtc, FormatEtcArray); + if Index > - 1 then + begin + // Just use the TFormatEct in the array after releasing the data. + LocalStgMedium := FindInternalStgMedium(FormatEtcArray[Index].cfFormat); + if Assigned(LocalStgMedium) then + begin + ReleaseStgMedium(LocalStgMedium^); + ZeroMemory(LocalStgMedium, SizeOf(LocalStgMedium^)); + end; + end + else + begin + // It is a new format so create a new TFormatCollectionItem, copy the + // FormatEtc parameter into the new object and and put it in the list. + SetLength(FFormatEtcArray, Length(FormatEtcArray) + 1); + FormatEtcArray[High(FormatEtcArray)] := FormatEtc; + + // Create a new InternalStgMedium and initialize it and associate it with the format. + SetLength(FInternalStgMediumArray, Length(InternalStgMediumArray) + 1); + InternalStgMediumArray[High(InternalStgMediumArray)].Format := FormatEtc.cfFormat; + LocalStgMedium := @InternalStgMediumArray[High(InternalStgMediumArray)].Medium; + ZeroMemory(LocalStgMedium, SizeOf(LocalStgMedium^)); + end; + + if DoRelease then + begin + // We are simply being given the data and we take control of it. + LocalStgMedium^ := Medium; + Result := S_OK; + end + else + begin + // We need to reference count or copy the data and keep our own references to it. + Result := StgMediumIncRef(Medium, LocalStgMedium^, True, Self as IDataObject); + + // Can get a circular reference if the client calls GetData then calls SetData with the same StgMedium. + // Because the unkForRelease for the IDataObject can be marshalled it is necessary to get pointers that + // can be correctly compared. See the IDragSourceHelper article by Raymond Chen at MSDN. + if Assigned(LocalStgMedium.unkForRelease) then + begin + if CanonicalIUnknown(Self) = CanonicalIUnknown(IUnknown(LocalStgMedium.unkForRelease)) then + IUnknown(LocalStgMedium.unkForRelease) := nil; // release the interface + end; + end; + + // Tell all registered advice sinks about the data change. + if Assigned(FAdviseHolder) then + FAdviseHolder.SendOnDataChange(Self as IDataObject, 0, 0); +end; + +end. diff --git a/components/virtualtreeview/Source/VirtualTrees.DragImage.pas b/components/virtualtreeview/Source/VirtualTrees.DragImage.pas new file mode 100644 index 00000000..1b6b3a4d --- /dev/null +++ b/components/virtualtreeview/Source/VirtualTrees.DragImage.pas @@ -0,0 +1,564 @@ +unit VirtualTrees.DragImage; + +interface + +uses + WinApi.Windows, + WinApi.ActiveX, + System.Types, + Vcl.Controls, + Vcl.Graphics; + +{$MINENUMSIZE 1, make enumerations as small as possible} + + +type + // 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 : TCustomControl; + 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) + procedure InternalShowDragImage(ScreenDC : HDC); + procedure MakeAlphaChannel(Source, Target : TBitmap); + public + constructor Create(AOwner : TCustomControl); + destructor Destroy; override; + + function DragTo(P : TPoint; ForceRepaint : Boolean) : Boolean; + procedure EndDrag; + function GetDragImageRect : TRect; + procedure HideDragImage; + procedure PrepareDrag(DragImage : TBitmap; ImagePosition, HotSpot : TPoint; const DataObject : IDataObject); + procedure RecaptureBackground(Tree : TCustomControl; R : TRect; VisibleRegion : HRGN; CaptureNCArea, ReshowDragImage : Boolean); + procedure ShowDragImage; + function WillMove(P : TPoint) : Boolean; + property ColorKey : TColor read FColorKey write FColorKey default clWindow; + property Fade : Boolean read FFade write FFade default False; + property ImagePosition : TPoint read FImagePosition; + property LastPosition : TPoint read FLastPosition; + property MoveRestriction : TVTDragMoveRestriction read FRestriction write FRestriction default dmrNone; + property PreBlendBias : TVTBias read FPreBlendBias write FPreBlendBias default 0; + property Transparency : TVTTransparency read FTransparency write FTransparency default 128; + property Visible : Boolean read GetVisible; + end; + +implementation + +uses + WinApi.ShlObj, + WinApi.Messages, + System.SysUtils, + System.Math, + VirtualTrees, + VirtualTrees.DragnDrop, + VirtualTrees.Types, + VirtualTrees.Utils; + +//----------------- TVTDragImage --------------------------------------------------------------------------------------- + +constructor TVTDragImage.Create(AOwner : TCustomControl); +begin + FOwner := AOwner; + FTransparency := 128; + FPreBlendBias := 0; + FPostBlendBias := 0; + FFade := False; + FRestriction := dmrNone; + FColorKey := clNone; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +destructor TVTDragImage.Destroy; +begin + EndDrag; + + inherited; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTDragImage.GetVisible : Boolean; +// Returns True if the internal drag image is used (i.e. the system does not natively support drag images) and +// the internal image is currently visible on screen. +begin + Result := FStates * [disHidden, disInDrag, disPrepared, disSystemSupport] = [disInDrag, disPrepared]; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTDragImage.InternalShowDragImage(ScreenDC : HDC); +// Frequently called helper routine to actually do the blend and put it onto the screen. +// Only used if the system does not support drag images. +var + BlendMode : TBlendMode; +begin + with FAlphaImage do + BitBlt(Canvas.Handle, 0, 0, Width, Height, FBackImage.Canvas.Handle, 0, 0, SRCCOPY); + if not FFade and (FColorKey = clNone) then + BlendMode := bmConstantAlpha + else + BlendMode := bmMasterAlpha; + with FDragImage do + AlphaBlend(Canvas.Handle, FAlphaImage.Canvas.Handle, Rect(0, 0, Width, Height), Point(0, 0), BlendMode, FTransparency, FPostBlendBias); + + with FAlphaImage do + BitBlt(ScreenDC, FImagePosition.X, FImagePosition.Y, Width, Height, Canvas.Handle, 0, 0, SRCCOPY); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTDragImage.MakeAlphaChannel(Source, Target : TBitmap); +// Helper method to create a proper alpha channel in Target (which must be in 32 bit pixel format), depending +// on the settings for the drag image and the color values in Source. +// Only used if the system does not support drag images. +type + PBGRA = ^TBGRA; + + TBGRA = packed record + case Boolean of + False : + (Color : Cardinal); + True : + (BGR : array [0 .. 2] of Byte; + Alpha : Byte); + end; + +var + Color, ColorKeyRef : COLORREF; + UseColorKey : Boolean; + SourceRun, TargetRun : PBGRA; + X, Y, MaxDimension, HalfWidth, HalfHeight : Integer; + T : Extended; +begin + UseColorKey := ColorKey <> clNone; + ColorKeyRef := ColorToRGB(ColorKey) and $FFFFFF; + // Color values are in the form BGR (red on LSB) while bitmap colors are in the form ARGB (blue on LSB) + // hence we have to swap red and blue in the color key. + with TBGRA(ColorKeyRef) do + begin + X := BGR[0]; + BGR[0] := BGR[2]; + BGR[2] := X; + end; + + with Target do + begin + MaxDimension := Max(Width, Height); + + HalfWidth := Width div 2; + HalfHeight := Height div 2; + for Y := 0 to Height - 1 do + begin + TargetRun := Scanline[Y]; + SourceRun := Source.Scanline[Y]; + for X := 0 to Width - 1 do + begin + Color := SourceRun.Color and $FFFFFF; + if UseColorKey and (Color = ColorKeyRef) then + TargetRun.Alpha := 0 + else + begin + // If the color is not the given color key (or none is used) then do full calculation of a bell curve. + T := Exp( - 8 * Sqrt(Sqr((X - HalfWidth) / MaxDimension) + Sqr((Y - HalfHeight) / MaxDimension))); + TargetRun.Alpha := Round(255 * T); + end; + Inc(SourceRun); + Inc(TargetRun); + end; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTDragImage.DragTo(P : TPoint; ForceRepaint : Boolean) : Boolean; +// Moves the drag image to a new position, which is determined from the passed point P and the previous +// mouse position. +// ForceRepaint is True if something on the screen changed and the back image must be refreshed. + +var + ScreenDC : HDC; + DeltaX, DeltaY : Integer; + + // optimized drag image move support + RSamp1, RSamp2, // newly added parts from screen which will be overwritten + RDraw1, RDraw2, // parts to be restored to screen + RScroll, RClip : TRect; // ScrollDC of the existent background +begin + // Determine distances to move the drag image. Take care for restrictions. + case FRestriction of + dmrHorizontalOnly : + begin + DeltaX := FLastPosition.X - P.X; + DeltaY := 0; + end; + dmrVerticalOnly : + begin + DeltaX := 0; + DeltaY := FLastPosition.Y - P.Y; + end; + else // dmrNone + DeltaX := FLastPosition.X - P.X; + DeltaY := FLastPosition.Y - P.Y; + end; + + Result := (DeltaX <> 0) or (DeltaY <> 0) or ForceRepaint; + if Result then + begin + if Visible then + begin + // All this stuff is only called if we have to handle the drag image ourselves. If the system supports + // drag image then this is all never executed. + ScreenDC := GetDC(0); + try + if (Abs(DeltaX) >= FDragImage.Width) or (Abs(DeltaY) >= FDragImage.Height) or ForceRepaint then + begin + // If moved more than image size then just restore old screen and blit image to new position. + BitBlt(ScreenDC, FImagePosition.X, FImagePosition.Y, FBackImage.Width, FBackImage.Height, FBackImage.Canvas.Handle, 0, 0, SRCCOPY); + + if ForceRepaint then + UpdateWindow(FOwner.Handle); + + Inc(FImagePosition.X, - DeltaX); + Inc(FImagePosition.Y, - DeltaY); + + BitBlt(FBackImage.Canvas.Handle, 0, 0, FBackImage.Width, FBackImage.Height, ScreenDC, FImagePosition.X, FImagePosition.Y, SRCCOPY); + end + else + begin + // overlapping copy + FillDragRectangles(FDragImage.Width, FDragImage.Height, DeltaX, DeltaY, RClip, RScroll, RSamp1, RSamp2, RDraw1, RDraw2); + + with FBackImage.Canvas do + begin + // restore uncovered areas of the screen + if DeltaX = 0 then + begin + BitBlt(ScreenDC, FImagePosition.X + RDraw2.Left, FImagePosition.Y + RDraw2.Top, RDraw2.Right, RDraw2.Bottom, Handle, RDraw2.Left, RDraw2.Top, SRCCOPY); + end + else + begin + if DeltaY = 0 then + begin + BitBlt(ScreenDC, FImagePosition.X + RDraw1.Left, FImagePosition.Y + RDraw1.Top, RDraw1.Right, RDraw1.Bottom, Handle, RDraw1.Left, RDraw1.Top, SRCCOPY); + end + else + begin + BitBlt(ScreenDC, FImagePosition.X + RDraw1.Left, FImagePosition.Y + RDraw1.Top, RDraw1.Right, RDraw1.Bottom, Handle, RDraw1.Left, RDraw1.Top, SRCCOPY); + BitBlt(ScreenDC, FImagePosition.X + RDraw1.Left, FImagePosition.Y + RDraw1.Top, RDraw1.Right, RDraw1.Bottom, Handle, RDraw1.Left, RDraw1.Top, SRCCOPY); + end; + end; + + // move existent background + ScrollDC(Handle, DeltaX, DeltaY, RScroll, RClip, 0, nil); + + Inc(FImagePosition.X, - DeltaX); + Inc(FImagePosition.Y, - DeltaY); + + // Get first and second additional rectangle from screen. + if DeltaX = 0 then + begin + BitBlt(Handle, RSamp2.Left, RSamp2.Top, RSamp2.Right, RSamp2.Bottom, ScreenDC, FImagePosition.X + RSamp2.Left, FImagePosition.Y + RSamp2.Top, SRCCOPY); + end + else if DeltaY = 0 then + begin + BitBlt(Handle, RSamp1.Left, RSamp1.Top, RSamp1.Right, RSamp1.Bottom, ScreenDC, FImagePosition.X + RSamp1.Left, FImagePosition.Y + RSamp1.Top, SRCCOPY); + end + else + begin + BitBlt(Handle, RSamp1.Left, RSamp1.Top, RSamp1.Right, RSamp1.Bottom, ScreenDC, FImagePosition.X + RSamp1.Left, FImagePosition.Y + RSamp1.Top, SRCCOPY); + BitBlt(Handle, RSamp2.Left, RSamp2.Top, RSamp2.Right, RSamp2.Bottom, ScreenDC, FImagePosition.X + RSamp2.Left, FImagePosition.Y + RSamp2.Top, SRCCOPY); + end; + end; + end; + InternalShowDragImage(ScreenDC); + finally + ReleaseDC(0, ScreenDC); + end; + end; + FLastPosition.X := P.X; + FLastPosition.Y := P.Y; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTDragImage.EndDrag; +begin + HideDragImage; + FStates := FStates - [disInDrag, disPrepared]; + + FBackImage.Free; + FBackImage := nil; + FDragImage.Free; + FDragImage := nil; + FAlphaImage.Free; + FAlphaImage := nil; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTDragImage.GetDragImageRect : TRect; +// Returns the current size and position of the drag image (screen coordinates). +begin + if Visible then + begin + with FBackImage do + Result := Rect(FImagePosition.X, FImagePosition.Y, FImagePosition.X + Width, FImagePosition.Y + Height); + end + else + Result := Rect(0, 0, 0, 0); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTDragImage.HideDragImage; +var + ScreenDC : HDC; +begin + if Visible then + begin + Include(FStates, disHidden); + ScreenDC := GetDC(0); + try + // restore screen + with FBackImage do + BitBlt(ScreenDC, FImagePosition.X, FImagePosition.Y, Width, Height, Canvas.Handle, 0, 0, SRCCOPY); + finally + ReleaseDC(0, ScreenDC); + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTDragImage.PrepareDrag(DragImage : TBitmap; ImagePosition, HotSpot : TPoint; const DataObject : IDataObject); +// Creates all necessary structures to do alpha blended dragging using the given image. +// ImagePostion and HotSpot are given in screen coordinates. The first determines where to place the drag image while +// the second is the initial mouse position. +// This method also determines whether the system supports drag images natively. If so then only minimal structures +// are created. + +var + Width, Height : Integer; + DragSourceHelper : IDragSourceHelper; + DragInfo : TSHDragImage; + lDragSourceHelper2 : IDragSourceHelper2; // Needed to get Windows Vista+ style drag hints. + lNullPoint : TPoint; +begin + Width := DragImage.Width; + Height := DragImage.Height; + + // Determine whether the system supports the drag helper interfaces. + if Assigned(DataObject) and Succeeded(CoCreateInstance(CLSID_DragDropHelper, nil, CLSCTX_INPROC_SERVER, IDragSourceHelper, DragSourceHelper)) then + begin + Include(FStates, disSystemSupport); + lNullPoint := Point(0, 0); + if Supports(DragSourceHelper, IDragSourceHelper2, lDragSourceHelper2) then + lDragSourceHelper2.SetFlags(DSH_ALLOWDROPDESCRIPTIONTEXT); // Show description texts + // First let the system try to initialze the DragSourceHelper, this works fine for file system objects (CF_HDROP) + StandardOLEFormat.cfFormat := CF_HDROP; + if not Succeeded(DataObject.QueryGetData(StandardOLEFormat)) or not Succeeded(DragSourceHelper.InitializeFromWindow(0, lNullPoint, DataObject)) then + begin + // Supply the drag source helper with our drag image. + DragInfo.sizeDragImage.cx := Width; + DragInfo.sizeDragImage.cy := Height; + DragInfo.ptOffset.X := Width div 2; + DragInfo.ptOffset.Y := Height div 2; + DragInfo.hbmpDragImage := CopyImage(DragImage.Handle, IMAGE_BITMAP, Width, Height, LR_COPYRETURNORG); + DragInfo.crColorKey := ColorToRGB(FColorKey); + if not Succeeded(DragSourceHelper.InitializeFromBitmap(@DragInfo, DataObject)) then + begin + DeleteObject(DragInfo.hbmpDragImage); + Exclude(FStates, disSystemSupport); + end; + end; + end + else + Exclude(FStates, disSystemSupport); + + if not (disSystemSupport in FStates) then + begin + FLastPosition := HotSpot; + + FDragImage := TBitmap.Create; + FDragImage.PixelFormat := pf32Bit; + FDragImage.SetSize(Width, Height); + + FAlphaImage := TBitmap.Create; + FAlphaImage.PixelFormat := pf32Bit; + FAlphaImage.SetSize(Width, Height); + + FBackImage := TBitmap.Create; + FBackImage.PixelFormat := pf32Bit; + FBackImage.SetSize(Width, 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 : TCustomControl; R : TRect; VisibleRegion : HRGN; CaptureNCArea, ReshowDragImage : Boolean); +// Notification by the drop target tree to update the background image because something in the tree has changed. +// Note: The passed rectangle is given in client coordinates of the current drop target tree (given in Tree). +// The caller does not check if the given rectangle is actually within the drag image. Hence this method must do +// all the checks. +// This method does nothing if the system manages the drag image. + +var + DragRect, ClipRect : TRect; + PaintTarget : TPoint; + PaintOptions : TVTInternalPaintOptions; + ScreenDC : HDC; + +begin + // Recapturing means we want the tree to paint the new part into our back bitmap instead to the screen. + if Visible then + begin + // Create the minimum rectangle to be recaptured. + MapWindowPoints(Tree.Handle, 0, R, 2); + DragRect := GetDragImageRect; + IntersectRect(R, R, DragRect); + + OffsetRgn(VisibleRegion, - DragRect.Left, - DragRect.Top); + + // The target position for painting in the drag image is relative and can be determined from screen coordinates too. + PaintTarget.X := R.Left - DragRect.Left; + PaintTarget.Y := R.Top - DragRect.Top; + + // The source rectangle is determined by the offsets in the tree. + MapWindowPoints(0, Tree.Handle, R, 2); + OffsetRect(R, - TBaseVirtualTree(Tree).OffsetX, - TBaseVirtualTree(Tree).OffsetY); + + // 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; + // TODO: somehow with clipping, the background image is not drawn on the + // backup image. Need to be diagnosed and fixed. For now, we have coded + // a work around in DragTo where this is used by using the condition + // IsInHeader. (found when solving issue 248) + ClipCanvas(Canvas, ClipRect, VisibleRegion); + TBaseVirtualTree(Tree).PaintTree(Canvas, R, PaintTarget, PaintOptions); + + if CaptureNCArea then + begin + // Header is painted in this part only so when you use this routine and want + // to capture the header in backup image, this flag should be ON. + // For the non-client area we only need the visible region of the window as limit for painting. + SelectClipRgn(Canvas.Handle, VisibleRegion); + // Since WM_PRINT cannot be given a position where to draw we simply move the window origin and + // get the same effect. + GetWindowRect(Tree.Handle, ClipRect); + SetCanvasOrigin(Canvas, DragRect.Left - ClipRect.Left, DragRect.Top - ClipRect.Top); + Tree.Perform(WM_PRINT, WPARAM(Canvas.Handle), PRF_NONCLIENT); + SetCanvasOrigin(Canvas, 0, 0); + end; + SelectClipRgn(Canvas.Handle, 0); + + if ReshowDragImage then + begin + GDIFlush; + ScreenDC := GetDC(0); + try + InternalShowDragImage(ScreenDC); + finally + ReleaseDC(0, ScreenDC); + end; + end; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTDragImage.ShowDragImage; +// Shows the drag image after it has been hidden by HideDragImage. +// Note: there might be a new background now. +// Also this method does nothing if the system manages the drag image. + +var + ScreenDC : HDC; +begin + if FStates * [disInDrag, disHidden, disPrepared, disSystemSupport] = [disInDrag, disHidden, disPrepared] then + begin + Exclude(FStates, disHidden); + + GDIFlush; + ScreenDC := GetDC(0); + try + BitBlt(FBackImage.Canvas.Handle, 0, 0, FBackImage.Width, FBackImage.Height, ScreenDC, FImagePosition.X, FImagePosition.Y, SRCCOPY); + + InternalShowDragImage(ScreenDC); + finally + ReleaseDC(0, ScreenDC); + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTDragImage.WillMove(P : TPoint) : Boolean; +// This method determines whether the drag image would "physically" move when DragTo would be called with the same +// target point. +// Always returns False if the system drag image support is available. +begin + Result := Visible; + if Result then + begin + // Determine distances to move the drag image. Take care for restrictions. + case FRestriction of + dmrHorizontalOnly : + Result := FLastPosition.X <> P.X; + dmrVerticalOnly : + Result := FLastPosition.Y <> P.Y; + else // dmrNone + Result := (FLastPosition.X <> P.X) or (FLastPosition.Y <> P.Y); + end; + end; +end; + +end. diff --git a/components/virtualtreeview/Source/VirtualTrees.DragnDrop.pas b/components/virtualtreeview/Source/VirtualTrees.DragnDrop.pas new file mode 100644 index 00000000..4b56a456 --- /dev/null +++ b/components/virtualtreeview/Source/VirtualTrees.DragnDrop.pas @@ -0,0 +1,342 @@ +unit VirtualTrees.DragnDrop; + +interface + +uses + WinApi.Windows, + WinApi.ActiveX, + WinApi.ShlObj, + System.Types, + Vcl.Graphics, + Vcl.Controls, + VirtualTrees.Types, + VirtualTrees; + +type + TEnumFormatEtc = class(TInterfacedObject, IEnumFormatEtc) + private + FFormatEtcArray : TFormatEtcArray; + FCurrentIndex : Integer; + public + constructor Create(const AFormatEtcArray : TFormatEtcArray); + + function Clone(out Enum : IEnumFormatEtc) : HResult; stdcall; + function Next(celt : Integer; out elt; pceltFetched : PLongint) : HResult; stdcall; + function Reset : HResult; stdcall; + function Skip(celt : Integer) : HResult; stdcall; + end; + + // ----- OLE drag'n drop handling + + 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; + + // TVTDragManager is a class to manage drag and drop in a Virtual Treeview. + TVTDragManager = class(TInterfacedObject, IVTDragManager, IDropSource, IDropTarget) + private + FOwner, // The tree which is responsible for drag management. + FDragSource : TBaseVirtualTree; // Reference to the source tree if the source was a VT, might be different than the owner tree. + FIsDropTarget : Boolean; // True if the owner is currently the drop target. + FDataObject : IDataObject; // A reference to the data object passed in by DragEnter (only used when the owner tree is the current drop target). + FDropTargetHelper : IDropTargetHelper; // Win2k > Drag image support + FFullDragging : BOOL; // True, if full dragging is currently enabled in the system. + + function GetDataObject : IDataObject; stdcall; + function GetDragSource : TBaseVirtualTree; stdcall; + function GetDropTargetHelperSupported : Boolean; stdcall; + function GetIsDropTarget : Boolean; stdcall; + public + constructor Create(AOwner : TBaseVirtualTree); virtual; + destructor Destroy; override; + + function DragEnter(const DataObject : IDataObject; KeyState : Integer; Pt : TPoint; var Effect : Longint) : HResult; stdcall; + function DragLeave : HResult; stdcall; + function DragOver(KeyState : Integer; Pt : TPoint; var Effect : Longint) : HResult; stdcall; + function Drop(const DataObject : IDataObject; KeyState : Integer; Pt : TPoint; var Effect : Integer) : HResult; stdcall; + procedure ForceDragLeave; stdcall; + function GiveFeedback(Effect : Integer) : HResult; stdcall; + function QueryContinueDrag(EscapePressed : BOOL; KeyState : Integer) : HResult; stdcall; + end; + +var + StandardOLEFormat : TFormatEtc = ( + // Format must later be set. + cfFormat : 0; + // No specific target device to render on. + ptd : nil; + // Normal content to render. + dwAspect : DVASPECT_CONTENT; + // No specific page of multipage data (we don't use multipage data by default). + lindex : - 1; + // Acceptable storage formats are IStream and global memory. The first is preferred. + tymed : TYMED_ISTREAM or TYMED_HGLOBAL;); + +implementation + +uses + VirtualTrees.DataObject; + +type + TBaseVirtualTreeCracker = class(TBaseVirtualTree); + + TVTDragManagerHelper = class helper for TVTDragManager + function TreeView : TBaseVirtualTreeCracker; + end; + + + //----------------- TEnumFormatEtc ------------------------------------------------------------------------------------- + +constructor TEnumFormatEtc.Create(const AFormatEtcArray : TFormatEtcArray); +var + I : Integer; +begin + inherited Create; + // Make a local copy of the format data. + SetLength(FFormatEtcArray, Length(AFormatEtcArray)); + for I := 0 to High(AFormatEtcArray) do + FFormatEtcArray[I] := AFormatEtcArray[I]; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TEnumFormatEtc.Clone(out Enum : IEnumFormatEtc) : HResult; +var + AClone : TEnumFormatEtc; +begin + Result := S_OK; + try + AClone := TEnumFormatEtc.Create(FFormatEtcArray); + AClone.FCurrentIndex := FCurrentIndex; + Enum := AClone as IEnumFormatEtc; + except + Result := E_FAIL; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TEnumFormatEtc.Next(celt : Integer; out elt; pceltFetched : PLongint) : HResult; +var + CopyCount : Integer; +begin + Result := S_FALSE; + CopyCount := Length(FFormatEtcArray) - FCurrentIndex; + if celt < CopyCount then + CopyCount := celt; + if CopyCount > 0 then + begin + Move(FFormatEtcArray[FCurrentIndex], elt, CopyCount * SizeOf(TFormatEtc)); + Inc(FCurrentIndex, CopyCount); + Result := S_OK; + end; + if Assigned(pceltFetched) then + pceltFetched^ := CopyCount; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TEnumFormatEtc.Reset : HResult; +begin + FCurrentIndex := 0; + Result := S_OK; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TEnumFormatEtc.Skip(celt : Integer) : HResult; +begin + if FCurrentIndex + celt < High(FFormatEtcArray) then + begin + Inc(FCurrentIndex, celt); + Result := S_OK; + end + else + Result := S_FALSE; +end; + + +//---------------------------------------------------------------------------------------------------------------------- + +// OLE drag and drop support classes +// This is quite heavy stuff (compared with the VCL implementation) but is much better suited to fit the needs +// of DD'ing various kinds of virtual data and works also between applications. + + +//----------------- TVTDragManager ------------------------------------------------------------------------------------- + +constructor TVTDragManager.Create(AOwner : TBaseVirtualTree); +begin + inherited Create; + FOwner := AOwner; + + // Create an instance of the drop target helper interface. This will fail but not harm on systems which do + // not support this interface (everything below Windows 2000); + CoCreateInstance(CLSID_DragDropHelper, nil, CLSCTX_INPROC_SERVER, IID_IDropTargetHelper, FDropTargetHelper); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +destructor TVTDragManager.Destroy; +begin + // Set the owner's reference to us to nil otherwise it will access an invalid pointer + // after our desctruction is complete. + TreeView.ClearDragManager; + inherited; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTDragManager.GetDataObject : IDataObject; +begin + // When the owner tree starts a drag operation then it gets a data object here to pass it to the OLE subsystem. + // In this case there is no local reference to a data object and one is created (but not stored). + // If there is a local reference then the owner tree is currently the drop target and the stored interface is + // that of the drag initiator. + if Assigned(FDataObject) then + Result := FDataObject + else + begin + Result := TreeView.DoCreateDataObject; + if (Result = nil) and not Assigned(TreeView.OnCreateDataObject) then + // Do not create a TVTDataObject if the event handler explicitely decided not to supply one, issue #736. + Result := TVTDataObject.Create(FOwner, False) as IDataObject; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTDragManager.GetDragSource : TBaseVirtualTree; +begin + Result := FDragSource; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTDragManager.GetDropTargetHelperSupported : Boolean; +begin + Result := Assigned(FDropTargetHelper); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTDragManager.GetIsDropTarget : Boolean; +begin + Result := FIsDropTarget; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTDragManager.DragEnter(const DataObject : IDataObject; KeyState : Integer; Pt : TPoint; var Effect : Integer) : HResult; +begin + FDataObject := DataObject; + FIsDropTarget := True; + + SystemParametersInfo(SPI_GETDRAGFULLWINDOWS, 0, @FFullDragging, 0); + // If full dragging of window contents is disabled in the system then our tree windows will be locked + // and cannot be updated during a drag operation. With the following call painting is again enabled. + if not FFullDragging then + LockWindowUpdate(0); + if Assigned(FDropTargetHelper) and FFullDragging then + begin + if toAutoScroll in TreeView.TreeOptions.AutoOptions then + FDropTargetHelper.DragEnter(FOwner.Handle, DataObject, Pt, Effect) + else + FDropTargetHelper.DragEnter(0, DataObject, Pt, Effect); // Do not pass handle, otherwise the IDropTargetHelper will perform autoscroll. Issue #486 + end; + FDragSource := TreeView.GetTreeFromDataObject(DataObject); + Result := TreeView.DragEnter(KeyState, Pt, Effect); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTDragManager.DragLeave : HResult; +begin + if Assigned(FDropTargetHelper) and FFullDragging then + FDropTargetHelper.DragLeave; + + TreeView.DragLeave; + FIsDropTarget := False; + FDragSource := nil; + FDataObject := nil; + Result := NOERROR; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTDragManager.DragOver(KeyState : Integer; Pt : TPoint; var Effect : Integer) : HResult; +begin + if Assigned(FDropTargetHelper) and FFullDragging then + FDropTargetHelper.DragOver(Pt, Effect); + + Result := TreeView.DragOver(FDragSource, KeyState, dsDragMove, Pt, Effect); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTDragManager.Drop(const DataObject : IDataObject; KeyState : Integer; Pt : TPoint; var Effect : Integer) : HResult; +begin + if Assigned(FDropTargetHelper) and FFullDragging then + FDropTargetHelper.Drop(DataObject, Pt, Effect); + + Result := TreeView.DragDrop(DataObject, KeyState, Pt, Effect); + FIsDropTarget := False; + FDataObject := nil; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTDragManager.ForceDragLeave; +// Some drop targets, e.g. Internet Explorer leave a drag image on screen instead removing it when they receive +// a drop action. This method calls the drop target helper's DragLeave method to ensure it removes the drag image from +// screen. Unfortunately, sometimes not even this does help (e.g. when dragging text from VT to a text field in IE). +begin + if Assigned(FDropTargetHelper) and FFullDragging then + FDropTargetHelper.DragLeave; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTDragManager.GiveFeedback(Effect : Integer) : HResult; +begin + Result := DRAGDROP_S_USEDEFAULTCURSORS; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTDragManager.QueryContinueDrag(EscapePressed : BOOL; KeyState : Integer) : HResult; +var + RButton, LButton : Boolean; +begin + LButton := (KeyState and MK_LBUTTON) <> 0; + RButton := (KeyState and MK_RBUTTON) <> 0; + + // Drag'n drop canceled by pressing both mouse buttons or Esc? + if (LButton and RButton) or EscapePressed then + Result := DRAGDROP_S_CANCEL + else + // Drag'n drop finished? + if not (LButton or RButton) then + Result := DRAGDROP_S_DROP + else + Result := S_OK; +end; + +{ TVTDragManagerHelper } + +function TVTDragManagerHelper.TreeView : TBaseVirtualTreeCracker; +begin + Result := TBaseVirtualTreeCracker(FOwner); +end; + +end. diff --git a/components/virtualtreeview/Source/VirtualTrees.DrawTree.pas b/components/virtualtreeview/Source/VirtualTrees.DrawTree.pas new file mode 100644 index 00000000..357394b6 --- /dev/null +++ b/components/virtualtreeview/Source/VirtualTrees.DrawTree.pas @@ -0,0 +1,331 @@ +unit VirtualTrees.DrawTree; + +interface + +uses + System.Types, + System.Classes, + VirtualTrees.Types, + VirtualTrees; + + +type + // 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; + + [ComponentPlatformsAttribute(pidWin32 or pidWin64)] + TVirtualDrawTree = class(TCustomVirtualDrawTree) + private + function GetOptions: TVirtualTreeOptions; + procedure SetOptions(const Value: TVirtualTreeOptions); + protected + function GetOptionsClass: TTreeOptionsClass; override; + public + property Canvas; + property LastDragEffect; + property CheckImageKind; // should no more be published to make #622 fix working + published + property Action; + property Align; + property Alignment; + property Anchors; + property AnimationDuration; + property AutoExpandDelay; + property AutoScrollDelay; + property AutoScrollInterval; + property Background; + property BackgroundOffsetX; + property BackgroundOffsetY; + property BiDiMode; + property BevelEdges; + property BevelInner; + property BevelOuter; + property BevelKind; + property BevelWidth; + property BorderStyle; + property BottomSpace; + property ButtonFillMode; + property ButtonStyle; + property BorderWidth; + property ChangeDelay; + property ClipboardFormats; + property Color; + property Colors; + property Constraints; + property Ctl3D; + property CustomCheckImages; + property DefaultNodeHeight; + property DefaultPasteMode; + property DragCursor; + property DragHeight; + property DragKind; + property DragImageKind; + property DragMode; + property DragOperations; + property DragType; + property DragWidth; + property DrawSelectionMode; + property EditDelay; + property Enabled; + property Font; + property Header; + property HintMode; + property HotCursor; + property Images; + property IncrementalSearch; + property IncrementalSearchDirection; + property IncrementalSearchStart; + property IncrementalSearchTimeout; + property Indent; + property LineMode; + property LineStyle; + property Margin; + property NodeAlignment; + property NodeDataSize; + property OperationCanceled; + property ParentBiDiMode; + property ParentColor default False; + property ParentCtl3D; + property ParentFont; + property ParentShowHint; + property PopupMenu; + property RootNodeCount; + property ScrollBarOptions; + property SelectionBlendFactor; + property SelectionCurveRadius; + property ShowHint; + property StateImages; + property TabOrder; + property TabStop default True; + property TextMargin; + property TreeOptions: TVirtualTreeOptions read GetOptions write SetOptions; + property Visible; + property WantTabs; + + property OnAddToSelection; + property OnAdvancedHeaderDraw; + property OnAfterAutoFitColumn; + property OnAfterAutoFitColumns; + property OnAfterCellPaint; + property OnAfterColumnExport; + property OnAfterColumnWidthTracking; + property OnAfterGetMaxColumnWidth; + property OnAfterHeaderExport; + property OnAfterHeaderHeightTracking; + property OnAfterItemErase; + property OnAfterItemPaint; + property OnAfterNodeExport; + property OnAfterPaint; + property OnAfterTreeExport; + property OnBeforeAutoFitColumn; + property OnBeforeAutoFitColumns; + property OnBeforeCellPaint; + property OnBeforeColumnExport; + property OnBeforeColumnWidthTracking; + property OnBeforeDrawTreeLine; + property OnBeforeGetMaxColumnWidth; + property OnBeforeHeaderExport; + property OnBeforeHeaderHeightTracking; + property OnBeforeItemErase; + property OnBeforeItemPaint; + property OnBeforeNodeExport; + property OnBeforePaint; + property OnBeforeTreeExport; + property OnCanSplitterResizeColumn; + property OnCanSplitterResizeHeader; + property OnCanSplitterResizeNode; + property OnChange; + property OnChecked; + property OnChecking; + property OnClick; + property OnCollapsed; + property OnCollapsing; + property OnColumnClick; + property OnColumnDblClick; + property OnColumnExport; + property OnColumnResize; + property OnColumnVisibilityChanged; + 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 OnHeaderAddPopupItem; + 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 OnPrepareButtonBitmaps; + 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 OnCanResize; + property OnGesture; + property Touch; + property StyleElements; + end; + + +implementation + +//---------------------------------------------------------------------------------------------------------------------- + +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 * TextMargin; + 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 := inherited TreeOptions as TVirtualTreeOptions; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualDrawTree.SetOptions(const Value: TVirtualTreeOptions); + +begin + TreeOptions.Assign(Value); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVirtualDrawTree.GetOptionsClass: TTreeOptionsClass; + +begin + Result := TVirtualTreeOptions; +end; + + + +end. diff --git a/components/virtualtreeview/Source/VirtualTrees.EditLink.pas b/components/virtualtreeview/Source/VirtualTrees.EditLink.pas new file mode 100644 index 00000000..0a64ce7f --- /dev/null +++ b/components/virtualtreeview/Source/VirtualTrees.EditLink.pas @@ -0,0 +1,893 @@ +unit VirtualTrees.EditLink; + +// Base class for inplace node editors implementing IVTEditLink interface +// and default node editor. + +interface + +uses + WinApi.Messages, + System.Types, + System.Classes, + Vcl.Controls, + Vcl.StdCtrls, + VirtualTrees, + VirtualTrees.Types; + +type + //Edit support Classes. + TStringEditLink = class; + + TVTEdit = class(TCustomEdit) + private + procedure CMAutoAdjust(var Message : TMessage); message CM_AUTOADJUST; + procedure CMExit(var Message : TMessage); message CM_EXIT; + procedure CMRelease(var Message : TMessage); message CM_RELEASE; + procedure CNCommand(var Message : TWMCommand); message CN_COMMAND; + procedure WMChar(var Message : TWMChar); message WM_CHAR; + procedure WMDestroy(var Message : TWMDestroy); message WM_DESTROY; + procedure WMGetDlgCode(var Message : TWMGetDlgCode); message WM_GETDLGCODE; + procedure WMKeyDown(var Message : TWMKeyDown); message WM_KEYDOWN; + protected + FRefLink : IVTEditLink; + FLink : TStringEditLink; + procedure AutoAdjustSize; virtual; + function CalcMinHeight : Integer; virtual; + procedure CreateParams(var Params : TCreateParams); override; + function GetTextSize : TSize; virtual; + procedure KeyPress(var Key : Char); override; + public + constructor Create(Link : TStringEditLink); reintroduce; + procedure ClearLink; + procedure ClearRefLink; + procedure Release; virtual; + + property AutoSelect; + property AutoSize; + property BorderStyle; + property CharCase; + property HideSelection; + property MaxLength; + property OEMConvert; + property PasswordChar; + end; + + TBaseEditLink = class; + + TEditLinkEditEvent = procedure (Sender: TBaseEditLink; var Result: Boolean) of object; + TEditLinkPrepareEditEvent = procedure (Sender: TBaseEditLink; var Edit: TControl; var Result: Boolean) of object; + + // Most abstract base class for implementing IVTEditLink. + // Knows almost nothing about associated Edit control and doesn't perform any + // actions on it. Contains some properties that are not used directly but could + // be useful in descendant classes. Follows general extension approach - all + // IVTEditLink methods are virtual and most of them call DoXXX virtual methods + // which in turn call event handlers so these extension options possible: + // - overriding main API methods to run additional actions before, after or + // instead of basic class code. + // (+) Lesser modification of existing classes + // (-) Event handlers are already launched after calling parent method + // (-) It's critical to check Result of parent method and exit immediately + // on False - this value means no action is done. + // (-) Returning Result is necessary + // - overriding DoXXX methods to run additional actions inside basic class code + // (+) No need in returning - lesser boilerplate code + // (-) Should call inherited to launch event handlers (OK if not using them) + // - assign event handlers in end-user code + // (+) Access to external classes with data to copy to EditLink editor. + // (-) Lesser encapsulation + TBaseEditLink = class(TInterfacedObject, IVTEditLink) + strict protected + FEdit: TControl; // One of the property editor classes. + FTree : TCustomVirtualStringTree; //A back reference to the tree calling. + FNode : PVirtualNode; //The node to be edited. + FColumn : TColumnIndex; //The column of the node. + FStopping : Boolean; //Set to True when the edit link requests stopping the edit action. + FAlignment : TAlignment; + FBiDiMode: TBiDiMode; + + // custom event handlers + FOnPrepareEdit: TEditLinkPrepareEditEvent; + FOnBeginEdit, + FOnEndEdit, + FOnCancelEdit: TEditLinkEditEvent; + + procedure SetEdit(const Value : TControl); //Setter for the FEdit member; + public + // IVTEditLink API + function BeginEdit : Boolean; virtual; stdcall; + function CancelEdit : Boolean; virtual; stdcall; + function EndEdit : Boolean; virtual; stdcall; + function GetBounds : TRect; virtual; stdcall; abstract; + function PrepareEdit(Tree : TBaseVirtualTree; Node : PVirtualNode; Column : TColumnIndex) : Boolean; virtual; stdcall; + procedure ProcessMessage(var Message : TMessage); virtual; stdcall; abstract; + procedure SetBounds(R : TRect); virtual; stdcall; abstract; + + // Methods to plug custom actions into main ones. In base class only call event handlers. + // Descendants may modify Result to cancel further flow. + procedure DoBeginEdit(var Result: Boolean); virtual; + procedure DoCancelEdit(var Result: Boolean); virtual; + procedure DoEndEdit(var Result: Boolean); virtual; + procedure DoPrepareEdit(var Result: Boolean); virtual; + + property Alignment : TAlignment read FAlignment; + property BiDiMode: TBiDiMode read FBiDiMode; + property Column : TColumnIndex read FColumn; //[IPK] Make Column(Index) accessible + property Node : PVirtualNode read FNode; //[IPK] Make FNode accessible + property Tree : TCustomVirtualStringTree read FTree; + property Stopping : Boolean read FStopping; + + property OnBeginEdit: TEditLinkEditEvent read FOnBeginEdit write FOnBeginEdit; + property OnCancelEdit: TEditLinkEditEvent read FOnCancelEdit write FOnCancelEdit; + property OnEndEdit: TEditLinkEditEvent read FOnEndEdit write FOnEndEdit; + property OnPrepareEdit: TEditLinkPrepareEditEvent read FOnPrepareEdit write FOnPrepareEdit; + end; + + // Edit link that has TWinControl-based Edit. Performs visibility and focus actions, + // transfers window messages to Edit control. + TWinControlEditLink = class(TBaseEditLink) + protected + function GetEdit: TWinControl; //Getter for the FEdit member; + procedure SetEdit(const Value : TWinControl); //Setter for the FEdit member; + public + destructor Destroy; override; + + function BeginEdit : Boolean; override; stdcall; + function CancelEdit : Boolean; override; stdcall; + function EndEdit : Boolean; override; stdcall; + function GetBounds : TRect; override; stdcall; + procedure ProcessMessage(var Message : TMessage); override; stdcall; + + property Edit : TWinControl read GetEdit write SetEdit; + end; + + // Edit link that implements default node text editor. + TStringEditLink = class(TWinControlEditLink) + protected + FTextBounds : TRect; //Smallest rectangle around the text. + function GetEdit: TVTEdit; //Getter for the FEdit member; + procedure SetEdit(const Value : TVTEdit); //Setter for the FEdit member; + public + constructor Create; + + function BeginEdit : Boolean; override; stdcall; + function CancelEdit : Boolean; override; stdcall; + function EndEdit : Boolean; override; stdcall; + function PrepareEdit(Tree : TBaseVirtualTree; Node : PVirtualNode; Column : TColumnIndex) : Boolean; override; stdcall; + procedure SetBounds(R : TRect); override; stdcall; + + property Edit : TVTEdit read GetEdit write SetEdit; + end; + +implementation + +uses + WinApi.Windows, + System.SysUtils, + System.Math, + Vcl.Graphics, + Vcl.Forms; + +type + TCustomVirtualStringTreeCracker = class(TCustomVirtualStringTree); + +//----------------- TVTEdit -------------------------------------------------------------------------------------------- + +//Implementation of a generic node caption editor. + +constructor TVTEdit.Create(Link : TStringEditLink); +begin + inherited Create(nil); + if not Assigned(Link) then + raise EArgumentException.Create('Parameter Link must not be 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.ClearLink; +begin + FLink := nil +end; + +//---------------------------------------------------------------------------------------------------------------------- +procedure TVTEdit.ClearRefLink; +begin + FRefLink := nil +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTEdit.CalcMinHeight : Integer; +var + textHeight : Integer; +begin + //Get the actual text height. + textHeight := GetTextSize.cy; + //The minimal height is the actual text height in pixels plus the the non client area. + Result := textHeight + (Height - ClientHeight); + //Also, proportionally to the text size, additional pixel(s) needs to be added for the caret. + Result := Result + Trunc(textHeight * 0.05); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTEdit.CMAutoAdjust(var Message : TMessage); +begin + AutoAdjustSize; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTEdit.CMExit(var Message : TMessage); +begin + if Assigned(FLink) and not FLink.Stopping then + with TCustomVirtualStringTreeCracker(FLink.Tree) do + begin + if (toAutoAcceptEditChange in TreeOptions.StringOptions) then + DoEndEdit + else + DoCancelEdit; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTEdit.CMRelease(var Message : TMessage); +begin + Free; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTEdit.CNCommand(var Message : TWMCommand); +begin + if Assigned(FLink) and Assigned(FLink.Tree) and (Message.NotifyCode = EN_UPDATE) and not (vsMultiline in FLink.Node.States) then + //Instead directly calling AutoAdjustSize it is necessary on Win9x/Me to decouple this notification message + //and eventual resizing. Hence we use a message to accomplish that. + AutoAdjustSize() + else + inherited; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTEdit.WMChar(var Message : TWMChar); +begin + if not (Message.CharCode in [VK_ESCAPE, VK_TAB]) then + inherited; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTEdit.WMDestroy(var Message : TWMDestroy); +begin + //If editing stopped by other means than accept or cancel then we have to do default processing for + //pending changes. + if Assigned(FLink) and not FLink.Stopping and not (csRecreating in Self.ControlState) then + begin + with TCustomVirtualStringTreeCracker(FLink.Tree) do + begin + if (toAutoAcceptEditChange in TreeOptions.StringOptions) and Modified then + Text[FLink.Node, FLink.Column] := FLink.Edit.Text; + end; + FLink := nil; + FRefLink := nil; + end; + + inherited; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTEdit.WMGetDlgCode(var Message : TWMGetDlgCode); +begin + inherited; + + Message.Result := Message.Result or DLGC_WANTALLKEYS or DLGC_WANTTAB or DLGC_WANTARROWS; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTEdit.WMKeyDown(var Message : TWMKeyDown); +//Handles some control keys. + +var + Shift : TShiftState; + EndEdit : Boolean; + Tree : TBaseVirtualTree; + NextNode : PVirtualNode; + ColumnCandidate : Integer; + EditOptions : TVTEditOptions; + Column : TVirtualTreeColumn; +begin + Tree := FLink.Tree; + case Message.CharCode of + VK_ESCAPE : + begin + TCustomVirtualStringTreeCracker(Tree).DoCancelEdit; + end; + VK_RETURN : + begin + EndEdit := not (vsMultiline in FLink.Node.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.Tree; + FLink.Tree.InvalidateNode(FLink.Node); + NextNode := Tree.GetNextVisible(FLink.Node, True); + TCustomVirtualStringTreeCracker(FLink.Tree).DoEndEdit; + + //get edit options for column as priority. If column has toDefaultEdit + //use global edit options for tree + EditOptions := TCustomVirtualStringTreeCracker(Tree).TreeOptions.EditOptions; //default + ColumnCandidate := - 1; + if Tree.Header.Columns.Count > 0 then //are there any columns? + begin + Column := Tree.Header.Columns[Tree.FocusedColumn]; + if Column.EditOptions <> toDefaultEdit then + EditOptions := Column.EditOptions; + + //next column candidate for toVerticalEdit and toHorizontalEdit + if Column.EditNextColumn <> - 1 then + ColumnCandidate := Column.EditNextColumn; + end; + + case EditOptions of + toDefaultEdit : + TCustomVirtualStringTreeCracker(Tree).TrySetFocus; + toVerticalEdit : + if NextNode <> nil then + begin + Tree.FocusedNode := NextNode; + + //for toVerticalEdit ColumnCandidate is also proper, + //select ColumnCandidate column in row below + if ColumnCandidate <> - 1 then + begin + Tree.FocusedColumn := ColumnCandidate; + TCustomVirtualStringTreeCracker(Tree).EditColumn := ColumnCandidate; + end; + + if Tree.CanEdit(Tree.FocusedNode, Tree.FocusedColumn) then + TCustomVirtualStringTreeCracker(Tree).DoEdit; + end; + toHorizontalEdit : + begin + if ColumnCandidate = - 1 then + begin + //for toHorizontalEdit if property EditNextColumn is not used + //try to use just next column + ColumnCandidate := Tree.FocusedColumn + 1; + while (ColumnCandidate < Tree.Header.Columns.Count) and not Tree.CanEdit(Tree.FocusedNode, ColumnCandidate) do + Inc(ColumnCandidate); + end + else if not Tree.CanEdit(Tree.FocusedNode, ColumnCandidate) then + ColumnCandidate := Tree.Header.Columns.Count; //omit "focus/edit column" (see below) + + if ColumnCandidate < Tree.Header.Columns.Count then + begin + Tree.FocusedColumn := ColumnCandidate; + TCustomVirtualStringTreeCracker(Tree).EditColumn := ColumnCandidate; + TCustomVirtualStringTreeCracker(Tree).DoEdit; + end; + end; + end; + end; + end; + VK_UP : + begin + if not (vsMultiline in FLink.Node.States) then + Message.CharCode := VK_LEFT; + inherited; + end; + VK_DOWN : + begin + if not (vsMultiline in FLink.Node.States) then + Message.CharCode := VK_RIGHT; + inherited; + end; + VK_TAB : + begin + if Tree.IsEditing then + begin + Tree.InvalidateNode(FLink.Node); + if ssShift in KeyDataToShiftState(Message.KeyData) then + NextNode := Tree.GetPreviousVisible(FLink.Node, True)//Shift+Tab goes to previous mode + else + NextNode := Tree.GetNextVisible(FLink.Node, True); + Tree.EndEditNode; + //check NextNode, otherwise we got AV + if NextNode <> nil then + begin + //Continue editing next node + Tree.ClearSelection(); + Tree.Selected[NextNode] := True; + if Tree.CanEdit(Tree.FocusedNode, Tree.FocusedColumn) then + TCustomVirtualStringTreeCracker(Tree).DoEdit; + end; + end; + end; + Ord('A') : + begin + if Tree.IsEditing and ([ssCtrl] = KeyboardStateToShiftState) then + begin + Self.SelectAll(); + Message.CharCode := 0; + end; + end; + else + inherited; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTEdit.AutoAdjustSize; +//Changes the size of the edit to accomodate as much as possible of its text within its container window. +//NewChar describes the next character which will be added to the edit's text. + +var + Size : TSize; +begin + if not (vsMultiline in FLink.Node.States) and not (toGridExtensions in TCustomVirtualStringTreeCracker(FLink.Tree).TreeOptions.MiscOptions { see issue #252 } ) then + begin + //avoid flicker + SendMessage(Handle, WM_SETREDRAW, 0, 0); + try + Size := GetTextSize; + Inc(Size.cx, 2 * TCustomVirtualStringTreeCracker(FLink.Tree).TextMargin); + //Repaint associated node if the edit becomes smaller. + if Size.cx < Width then + FLink.Tree.Invalidate(); + + if FLink.Alignment = taRightJustify then + FLink.SetBounds(Rect(Left + Width - Size.cx, Top, Left + Width, Top + Max(Size.cy, Height))) + else + FLink.SetBounds(Rect(Left, Top, Left + Size.cx, Top + Max(Size.cy, Height))); + finally + SendMessage(Handle, WM_SETREDRAW, 1, 0); + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTEdit.CreateParams(var Params : TCreateParams); +begin + inherited; + if not Assigned(FLink.Node) then + exit; //Prevent AV exceptions occasionally seen in code below + + //Only with multiline style we can use the text formatting rectangle. + //This does not harm formatting as single line control, if we don't use word wrapping. + with Params do + begin + Style := Style or ES_MULTILINE; + if vsMultiline in FLink.Node.States then + Style := Style and not (ES_AUTOHSCROLL or WS_HSCROLL) or WS_VSCROLL or ES_AUTOVSCROLL; + if tsUseThemes in FLink.Tree.TreeStates 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; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTEdit.GetTextSize : TSize; +var + DC : HDC; + LastFont : THandle; +begin + DC := GetDC(Handle); + LastFont := SelectObject(DC, Font.Handle); + try + //Read needed space for the current text. + GetTextExtentPoint32(DC, PChar(Text + 'yG'), Length(Text) + 2, Result); + finally + SelectObject(DC, LastFont); + ReleaseDC(Handle, DC); + end; +end; + +procedure TVTEdit.KeyPress(var Key : Char); +begin + if (Key = #13) and Assigned(FLink) and not (vsMultiline in FLink.Node.States) then + Key := #0; //Filter out return keys as they will be added to the text, avoids #895 + inherited; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTEdit.Release; +begin + if HandleAllocated then + PostMessage(Handle, CM_RELEASE, 0, 0); +end; + +//----------------- TBaseEditLink ------------------------------------------------------------------------------------ + +procedure TBaseEditLink.SetEdit(const Value : TControl); +begin + if Assigned(FEdit) then + FEdit.Free; + FEdit := Value; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseEditLink.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 + DoBeginEdit(Result); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseEditLink.CancelEdit : Boolean; + +// Performs edit cancelling. + +begin + Result := not FStopping; + if Result then + begin + // Let descendants cancel the cancel + DoCancelEdit(Result); + if not Result then + Exit; + FStopping := True; + FTree.CancelEditNode; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseEditLink.EndEdit : Boolean; + +// Performs edit ending. + +begin + Result := not FStopping; + if Result then + begin + // Let descendants cancel the end + DoEndEdit(Result); + if not Result then + Exit; + FStopping := True; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseEditLink.PrepareEdit(Tree : TBaseVirtualTree; Node : PVirtualNode; Column : TColumnIndex) : Boolean; + +// Performs general init: assign Tree, Node, Column, other properties; destroys previous +// edit instance. + +begin + Result := Tree is TCustomVirtualStringTree; + if not Result then Exit; // should not happen + + FTree := Tree as TCustomVirtualStringTree; + FNode := Node; + FColumn := Column; + if Column <= NoColumn then + begin + FBidiMode := FTree.BidiMode; + FAlignment := TCustomVirtualStringTreeCracker(FTree).Alignment; + end + else + begin + FBidiMode := FTree.Header.Columns[Column].BidiMode; + FAlignment := FTree.Header.Columns[Column].Alignment; + end; + SetEdit(nil); // always dispose edit + + DoPrepareEdit(Result); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseEditLink.DoBeginEdit(var Result: Boolean); +begin + if Assigned(OnBeginEdit) then + OnBeginEdit(Self, Result); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseEditLink.DoCancelEdit(var Result: Boolean); +begin + if Assigned(OnCancelEdit) then + OnCancelEdit(Self, Result); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseEditLink.DoEndEdit(var Result: Boolean); +begin + if Assigned(OnEndEdit) then + OnEndEdit(Self, Result); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseEditLink.DoPrepareEdit(var Result: Boolean); +begin + if Assigned(OnPrepareEdit) then + OnPrepareEdit(Self, FEdit, Result); +end; + +//----------------- TWinControlEditLink ------------------------------------------------------------------------------------ + +destructor TWinControlEditLink.Destroy; +begin + //FEdit.Free; casues issue #357. Fix: + if Assigned(FEdit) and Edit.HandleAllocated then + PostMessage(Edit.Handle, CM_RELEASE, 0, 0); + inherited; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TWinControlEditLink.GetEdit: TWinControl; +begin + Result := TWinControl(FEdit); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TWinControlEditLink.SetEdit(const Value: TWinControl); +begin + inherited SetEdit(Value); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TWinControlEditLink.BeginEdit: Boolean; +begin + Result := inherited; + if Result then + begin + Edit.Show; + Edit.SetFocus; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TWinControlEditLink.CancelEdit: Boolean; +begin + Result := inherited; + if Result then + begin + Edit.Hide; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TWinControlEditLink.GetBounds : TRect; +begin + Result := FEdit.BoundsRect; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TWinControlEditLink.ProcessMessage(var Message : TMessage); +begin + FEdit.WindowProc(Message); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TWinControlEditLink.EndEdit: Boolean; +begin + Result := inherited; + if Result then + begin + Edit.Hide; + end; +end; + +//----------------- TStringEditLink ------------------------------------------------------------------------------------ + +constructor TStringEditLink.Create; +begin + inherited; + FEdit := TVTEdit.Create(Self); + with Edit do + begin + Visible := False; + BorderStyle := bsSingle; + AutoSize := False; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TStringEditLink.GetEdit: TVTEdit; +begin + Result := TVTEdit(FEdit); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TStringEditLink.SetEdit(const Value : TVTEdit); +begin + inherited SetEdit(Value); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TStringEditLink.BeginEdit : Boolean; +begin + Result := inherited; + if Result then + begin + Edit.SelectAll; + Edit.AutoAdjustSize; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TStringEditLink.CancelEdit : Boolean; +begin + Result := inherited; + if Result then + begin + Edit.ClearLink; + Edit.ClearRefLink; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TStringEditLink.EndEdit : Boolean; +begin + Result := inherited; + if Result then + try + if Edit.Modified then + FTree.Text[FNode, FColumn] := Edit.Text; + Edit.ClearLink; + Edit.ClearRefLink; + except + FStopping := False; + raise; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TStringEditLink.PrepareEdit(Tree : TBaseVirtualTree; Node : PVirtualNode; Column : TColumnIndex) : Boolean; +var + Text : string; +begin + Result := inherited; + if Result then + begin + Edit := TVTEdit.Create(Self); + Edit.Visible := False; + Edit.BorderStyle := bsSingle; + Edit.AutoSize := True; + Edit.Parent := Tree; + //Initial size, font and text of the node. + FTree.GetTextInfo(Node, Column, Edit.Font, FTextBounds, Text); + Edit.Font.Color := clWindowText; + Edit.RecreateWnd; + Edit.AutoSize := False; + Edit.Text := Text; + Edit.BidiMode := FBidiMode; + if Edit.BidiMode <> bdLeftToRight then + ChangeBidiModeAlignment(FAlignment); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TStringEditLink.SetBounds(R : TRect); +//Sets the outer bounds of the edit control and the actual edit area in the control. + +var + lOffset, tOffset, Height : Integer; + offsets : TVTOffsets; +begin + if not FStopping then + begin + //Check if the provided rect height is smaller than the edit control height. + Height := R.Bottom - R.Top; + if Height < Edit.ClientHeight then + begin + //If the height is smaller than the minimal height we must correct it, otherwise the caret will be invisible. + tOffset := Edit.CalcMinHeight - Height; + if tOffset > 0 then + Inc(R.Bottom, tOffset); + end; + + //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; + Edit.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 := Edit.ClientRect; + + //If toGridExtensions are turned on, we can fine tune the left margin (or the right margin if RTL is on) + //of the text to exactly match the text in the tree cell. + if (toGridExtensions in TCustomVirtualStringTreeCracker(FTree).TreeOptions.MiscOptions) and + ((FAlignment = taLeftJustify) and (Edit.BidiMode = bdLeftToRight) or (FAlignment = taRightJustify) and (Edit.BidiMode <> bdLeftToRight)) then + begin + //Calculate needed text area offset. + FTree.GetOffsets(FNode, offsets, ofsText, FColumn); + if FColumn = FTree.Header.MainColumn then + begin + if offsets[ofsToggleButton] < 0 then + lOffset := - (offsets[ofsToggleButton] + 2) + else + lOffset := 0; + end + else + lOffset := offsets[ofsText] - offsets[ofsMargin] + 1; + //Apply the offset. + if Edit.BidiMode = bdLeftToRight then + Inc(R.Left, lOffset) + else + Dec(R.Right, lOffset); + end; + + lOffset := IfThen(vsMultiline in FNode.States, 0, 2); + if tsUseThemes in FTree.TreeStates then + Inc(lOffset); + InflateRect(R, - TCustomVirtualStringTreeCracker(FTree).TextMargin + lOffset, lOffset); + if not (vsMultiline in FNode.States) then + begin + tOffset := FTextBounds.Top - Edit.Top; + //Do not apply a negative offset, the cursor will disappear. + if tOffset > 0 then + OffsetRect(R, 0, tOffset); + end; + 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(Edit.Handle, EM_SETRECTNP, 0, LPARAM(@R)); + end; +end; + +end. diff --git a/components/virtualtreeview/Source/VirtualTrees.Export.pas b/components/virtualtreeview/Source/VirtualTrees.Export.pas index 8ae32cd0..3ce4a9fb 100644 --- a/components/virtualtreeview/Source/VirtualTrees.Export.pas +++ b/components/virtualtreeview/Source/VirtualTrees.Export.pas @@ -26,7 +26,10 @@ uses System.SysUtils, System.StrUtils, System.Generics.Collections, - System.UITypes; + System.UITypes, + VirtualTrees.Types, + VirtualTrees.ClipBoard, + VirtualTrees.Header; type TCustomVirtualStringTreeCracker = class(TCustomVirtualStringTree) diff --git a/components/virtualtreeview/Source/VirtualTrees.Header.pas b/components/virtualtreeview/Source/VirtualTrees.Header.pas new file mode 100644 index 00000000..6d6568e9 --- /dev/null +++ b/components/virtualtreeview/Source/VirtualTrees.Header.pas @@ -0,0 +1,5922 @@ +unit VirtualTrees.Header; + +interface + +uses + System.Classes, + System.Types, + System.Generics.Collections, + WinApi.Windows, + WinApi.Messages, + Vcl.Graphics, + Vcl.Menus, + Vcl.ImgList, + Vcl.Controls, + Vcl.Themes, + Vcl.GraphUtil, + System.UITypes, + VirtualTrees.StyleHooks, + VirtualTrees.Utils, + VirtualTrees.Types, + VirtualTrees.DragImage; + + +{$MINENUMSIZE 1, make enumerations as small as possible} + + +const + DefaultColumnOptions = [coAllowClick, coDraggable, coEnabled, coParentColor, coParentBidiMode, coResizable, + coShowDropMark, coVisible, coAllowFocus, coEditable, coStyleColor]; + +type + TVTHeader = class; + TVirtualTreeColumn = class; + + // 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; + SortGlyphSize : TSize; + procedure DrawSortArrow(pDirection : TSortDirection); + procedure DrawDropMark(); + end; + + TVirtualTreeColumns = class; + + TVirtualTreeColumn = class(TCollectionItem) + private + const + cDefaultColumnSpacing = 3; + private + FText, + FHint : string; + FWidth : TDimension; + FPosition : TColumnPosition; + FMinWidth : TDimension; + FMaxWidth : TDimension; + FStyle : TVirtualTreeColumnStyle; + FImageIndex : TImageIndex; + FBiDiMode : TBiDiMode; + FLayout : TVTHeaderColumnLayout; + FMargin, + FSpacing : TDimension; + FOptions : TVTColumnOptions; + FEditOptions : TVTEditOptions; + FEditNextColumn : TDimension; + FTag : NativeInt; + FAlignment : TAlignment; + FCaptionAlignment : TAlignment; // Alignment of the caption. + FLastWidth : TDimension; + 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 GetCaptionWidth : TDimension; + function GetLeft : TDimension; + 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 : TDimension); + procedure SetMaxWidth(Value : TDimension); + procedure SetMinWidth(Value : TDimension); + procedure SetOptions(Value : TVTColumnOptions); + procedure SetPosition(Value : TColumnPosition); + procedure SetSpacing(Value : TDimension); + procedure SetStyle(Value : TVirtualTreeColumnStyle); + + protected + FLeft : TDimension; + procedure ChangeScale(M, D : TDimension; isDpiChange : Boolean); virtual; + procedure ComputeHeaderLayout(var PaintInfo : THeaderPaintInfo; DrawFormat : Cardinal; CalculateTextRect : Boolean = False); + procedure DefineProperties(Filer : TFiler); override; + procedure GetAbsoluteBounds(var Left, Right : TDimension); + function GetDisplayName : string; override; + function GetText : string; virtual; // [IPK] + procedure SetText(const Value : string); virtual; // [IPK] private to protected & virtual + function GetOwner : TVirtualTreeColumns; reintroduce; + procedure InternalSetWidth(const Value : TDimension); //bypass side effects in SetWidth + procedure ReadHint(Reader : TReader); + procedure ReadText(Reader : TReader); + procedure SetCollection(Value : TCollection); override; + procedure SetWidth(Value : TDimension); + public + constructor Create(Collection : TCollection); override; + destructor Destroy; override; + + procedure Assign(Source : TPersistent); override; + function Equals(OtherColumnObj : TObject) : Boolean; override; + function GetRect : TRect; virtual; + property HasImage : Boolean read FHasImage; + property ImageRect : TRect read FImageRect; + procedure LoadFromStream(const Stream : TStream; Version : Integer); + procedure ParentBiDiModeChanged; + procedure ParentColorChanged; + procedure RestoreLastWidth; + function GetEffectiveColor() : TColor; + procedure SaveToStream(const Stream : TStream); + function UseRightToLeftReading : Boolean; + + property BonusPixel : Boolean read FBonusPixel write FBonusPixel; + property CaptionText : string read FCaptionText; + property LastWidth : TDimension read FLastWidth; + property Left : TDimension read GetLeft; + property Owner : TVirtualTreeColumns read GetOwner; + property SpringRest : Single read FSpringRest write FSpringRest; + 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 CaptionWidth : TDimension read GetCaptionWidth; + 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 : string read FHint write FHint; + property ImageIndex : TImageIndex read FImageIndex write SetImageIndex default - 1; + property Layout : TVTHeaderColumnLayout read FLayout write SetLayout default blGlyphLeft; + property Margin : TDimension read FMargin write SetMargin default 4; + property MaxWidth : TDimension read FMaxWidth write SetMaxWidth default 10000; + property MinWidth : TDimension read FMinWidth write SetMinWidth default 10; + property Options : TVTColumnOptions read FOptions write SetOptions default DefaultColumnOptions; + property EditOptions : TVTEditOptions read FEditOptions write FEditOptions default toDefaultEdit; + property EditNextColumn : TDimension read FEditNextColumn write FEditNextColumn default - 1; + property Position : TColumnPosition read FPosition write SetPosition; + property Spacing : TDimension read FSpacing write SetSpacing default cDefaultColumnSpacing; + property Style : TVirtualTreeColumnStyle read FStyle write SetStyle default vsText; + property Tag : NativeInt read FTag write FTag default 0; + property Text : string read GetText write SetText; + property Width : TDimension 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 : TDimension; // 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. + FColumnPopupMenu : TPopupMenu; // Member for storing the TVTHeaderPopupMenu + + function GetCount : TDimension; + function GetItem(Index : TColumnIndex) : TVirtualTreeColumn; + function GetNewIndex(P : TPoint; var OldIndex : TColumnIndex) : Boolean; + procedure SetDefaultWidth(Value : TDimension); + procedure SetItem(Index : TColumnIndex; Value : TVirtualTreeColumn); + function GetTreeView: TCustomControl; + protected + // drag support + FDragIndex : TColumnIndex; // index of column currently being dragged + FDropTarget : TColumnIndex; // current target column (index) while dragging + FDropBefore : Boolean; // True if drop position is in the left half of a column, False for the right + // side to drop the dragged column to + + procedure AdjustAutoSize(CurrentIndex : TColumnIndex; Force : Boolean = False); + function AdjustDownColumn(P : TPoint) : TColumnIndex; + function AdjustHoverColumn(P : TPoint) : Boolean; + procedure AdjustPosition(Column : TVirtualTreeColumn; Position : Cardinal); + function CanSplitterResize(P : TPoint; Column : TColumnIndex) : Boolean; + procedure DoCanSplitterResize(P : TPoint; Column : TColumnIndex; var Allowed : Boolean); virtual; + procedure DrawButtonText(DC : HDC; Caption : string; Bounds : TRect; Enabled, Hot : Boolean; DrawFormat : Cardinal; + WrapCaption : Boolean); + procedure FixPositions; + function GetColumnAndBounds(P : TPoint; var ColumnLeft, ColumnRight : TDimension; Relative : Boolean = True) : Integer; + function GetOwner : TPersistent; override; + function HandleClick(P : TPoint; Button : TMouseButton; Force, DblClick : Boolean) : Boolean; virtual; + procedure HeaderPopupMenuAddHeaderPopupItem(const Sender : TObject; const Column : TColumnIndex; var Cmd : TAddPopupItemType); + procedure IndexChanged(OldIndex, NewIndex : Integer); + procedure InitializePositionArray; + procedure Notify(Item : TCollectionItem; Action : System.Classes.TCollectionNotification); override; + procedure ReorderColumns(RTL : Boolean); + procedure SetHoverIndex(Index : TColumnIndex); + 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 write FHoverIndex; + property DownIndex : TColumnIndex read FDownIndex write FDownIndex; + property CheckBoxHit : Boolean read FCheckBoxHit write FCheckBoxHit; + // Mitigator function to use the correct style service for this context (either the style assigned to the control for Delphi > 10.4 or the application style) + function StyleServices(AControl : TControl = nil) : TCustomStyleServices; + public + constructor Create(AOwner : TVTHeader); virtual; + destructor Destroy; override; + + function Add : TVirtualTreeColumn; virtual; + procedure AnimatedResize(Column : TColumnIndex; NewWidth : TDimension); + procedure Assign(Source : TPersistent); override; + procedure Clear; virtual; + function ColumnFromPosition(P : TPoint; Relative : Boolean = True) : TColumnIndex; overload; virtual; + function ColumnFromPosition(PositionIndex : TColumnPosition) : TColumnIndex; overload; virtual; + function Equals(OtherColumnsObj : TObject) : Boolean; override; + procedure GetColumnBounds(Column : TColumnIndex; var Left, Right : TDimension); + 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 : TDimension; + function GetVisibleColumns : TColumnsArray; + function GetVisibleFixedWidth : TDimension; + function IsValidColumn(Column : TColumnIndex) : Boolean; + procedure LoadFromStream(const Stream : TStream; Version : Integer); + procedure PaintHeader(DC : HDC; R : TRect; HOffset : TDimension); overload; virtual; + procedure PaintHeader(TargetCanvas : TCanvas; R : TRect; const Target : TPoint; + RTLOffset : TDimension = 0); overload; virtual; + procedure SaveToStream(const Stream : TStream); + procedure EndUpdate(); override; + function TotalWidth : TDimension; + + property Count : Integer read GetCount; + property ClickIndex : TColumnIndex read FClickIndex write FClickIndex; + property DefaultWidth : TDimension read FDefaultWidth write SetDefaultWidth; + property DragIndex : TColumnIndex read FDragIndex write FDragIndex; + property DropBefore : Boolean read FDropBefore write FDropBefore; + property DropTarget : TColumnIndex read FDropTarget write FDropTarget; + property Items[Index : TColumnIndex] : TVirtualTreeColumn read GetItem write SetItem; default; + property Header: TVTHeader read FHeader; + property TrackIndex : TColumnIndex read FTrackIndex write FTrackIndex; + property TreeView : TCustomControl read GetTreeView; + 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 95; + 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 + hoAutoColumnPopupMenu, //Show a context menu for activating and deactivating columns on right click + hoAutoResizeInclCaption //Includes the header caption for the auto resizing + ); + 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; + + TVTHeader = class(TPersistent) + private + FOwner : TCustomControl; + FColumns : TVirtualTreeColumns; + FHeight : TDimension; + FFont : TFont; + FParentFont : Boolean; + FOptions : TVTHeaderOptions; + FStyle : TVTHeaderStyle; //button style + FBackgroundColor : TColor; + FAutoSizeIndex : TColumnIndex; + FPopupMenu : TPopupMenu; + FMainColumn : TColumnIndex; //the column which holds the tree + FMaxHeight : TDimension; + FMinHeight : TDimension; + FDefaultHeight : TDimension; + FFixedAreaConstraints : TVTFixedAreaConstraints; //Percentages for the fixed area (header, fixed columns). + FImages : TCustomImageList; + FImageChangeLink : TChangeLink; //connections to the image list to get notified about changes + fSplitterHitTolerance : TDimension; //For property SplitterHitTolerance + FSortColumn : TColumnIndex; + FSortDirection : TSortDirection; + FDragImage : TVTDragImage; //drag image management during header drag + FLastWidth : TDimension; //Used to adjust spring columns. This is the width of all visible columns, not the header rectangle. + FRestoreSelectionColumnIndex : Integer; //The column that is used to implement the coRestoreSelection option + function GetMainColumn : TColumnIndex; + function GetUseColumns : Boolean; + function IsFontStored : Boolean; + procedure SetAutoSizeIndex(Value : TColumnIndex); + procedure SetBackground(Value : TColor); + procedure SetColumns(Value : TVirtualTreeColumns); + procedure SetDefaultHeight(Value : TDimension); + procedure SetFont(const Value : TFont); + procedure SetHeight(Value : TDimension); + procedure SetImages(const Value : TCustomImageList); + procedure SetMainColumn(Value : TColumnIndex); + procedure SetMaxHeight(Value : TDimension); + procedure SetMinHeight(Value : TDimension); + procedure SetOptions(Value : TVTHeaderOptions); + procedure SetParentFont(Value : Boolean); + procedure SetSortColumn(Value : TColumnIndex); + procedure SetSortDirection(const Value : TSortDirection); + procedure SetStyle(Value : TVTHeaderStyle); + function GetRestoreSelectionColumnIndex : Integer; + 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. + FDoingAutoFitColumns : Boolean; //Flag to avoid using the stored width for Main column + + procedure FontChanged(Sender : TObject); virtual; + procedure AutoScale(isDpiChange: Boolean); virtual; + function CanSplitterResize(P : TPoint) : Boolean; + function CanWriteColumns : Boolean; virtual; + procedure ChangeScale(M, D : TDimension; isDpiChange : Boolean); virtual; + function DetermineSplitterIndex(P : TPoint) : Boolean; virtual; + procedure DoAfterAutoFitColumn(Column : TColumnIndex); virtual; + procedure DoAfterColumnWidthTracking(Column : TColumnIndex); virtual; + procedure DoAfterHeightTracking; virtual; + function DoBeforeAutoFitColumn(Column : TColumnIndex; SmartAutoFitType : TSmartAutoFitType) : Boolean; virtual; + procedure DoBeforeColumnWidthTracking(Column : TColumnIndex; Shift : TShiftState); virtual; + procedure DoBeforeHeightTracking(Shift : TShiftState); virtual; + procedure DoCanSplitterResize(P : TPoint; var Allowed : Boolean); virtual; + function DoColumnWidthDblClickResize(Column : TColumnIndex; P : TPoint; Shift : TShiftState) : Boolean; virtual; + function DoColumnWidthTracking(Column : TColumnIndex; Shift : TShiftState; var TrackPoint : TPoint; P : TPoint) : Boolean; virtual; + function DoGetPopupMenu(Column : TColumnIndex; Position : TPoint) : TPopupMenu; virtual; + function DoHeightTracking(var P : TPoint; Shift : TShiftState) : Boolean; virtual; + function DoHeightDblClickResize(var P : TPoint; Shift : TShiftState) : Boolean; virtual; + procedure DoSetSortColumn(Value : TColumnIndex; pSortDirection : TSortDirection); virtual; + procedure DragTo(P : TPoint); virtual; + procedure FixedAreaConstraintsChanged(Sender : TObject); + function GetColumnsClass : TVirtualTreeColumnsClass; virtual; + function GetOwner : TPersistent; override; + function GetShiftState : TShiftState; + function HandleHeaderMouseMove(var Message : TWMMouseMove) : Boolean; + function HandleMessage(var Message : TMessage) : Boolean; virtual; + procedure ImageListChange(Sender : TObject); + procedure PrepareDrag(P, Start : TPoint); + procedure ReadColumns(Reader : TReader); + procedure RecalculateHeader; virtual; + procedure RescaleHeader; + procedure UpdateMainColumn; + procedure UpdateSpringColumns; + procedure WriteColumns(Writer : TWriter); + procedure InternalSetMainColumn(const Index : TColumnIndex); + procedure InternalSetAutoSizeIndex(const Index : TColumnIndex); + procedure InternalSetSortColumn(const Index : TColumnIndex); + public + constructor Create(AOwner : TCustomControl); virtual; + destructor Destroy; override; + + function AllowFocus(ColumnIndex : TColumnIndex) : Boolean; + procedure Assign(Source : TPersistent); override; + procedure AutoFitColumns(); overload; + procedure AutoFitColumns(Animated : Boolean; SmartAutoFitType : TSmartAutoFitType = smaUseColumnOption; RangeStartCol : Integer = NoColumn; RangeEndCol : Integer = NoColumn); overload; virtual; + function InHeader(P : TPoint) : Boolean; virtual; + function InHeaderSplitterArea(P : TPoint) : Boolean; virtual; + procedure Invalidate(Column : TVirtualTreeColumn; ExpandToBorder : Boolean = False; UpdateNowFlag : Boolean = False); + procedure LoadFromStream(const Stream : TStream); virtual; + function ResizeColumns(ChangeBy : TDimension; RangeStartCol : TColumnIndex; RangeEndCol : TColumnIndex; Options : TVTColumnOptions = [coVisible]) : TDimension; + procedure RestoreColumns; + procedure SaveToStream(const Stream : TStream); virtual; + procedure StyleChanged(); virtual; + + property DragImage : TVTDragImage read FDragImage; + property RestoreSelectionColumnIndex : Integer read GetRestoreSelectionColumnIndex write FRestoreSelectionColumnIndex default NoColumn; + property States : THeaderStates read FStates; + property Treeview : TCustomControl read FOwner; + property UseColumns : Boolean read GetUseColumns; + property doingAutoFitColumns : Boolean read FDoingAutoFitColumns; + published + property AutoSizeIndex : TColumnIndex read FAutoSizeIndex write SetAutoSizeIndex; + property Background : TColor read FBackgroundColor write SetBackground default clBtnFace; + property Columns : TVirtualTreeColumns read FColumns write SetColumns stored False; //Stored by the owner tree to support VFI. + property DefaultHeight : Integer read FDefaultHeight write SetDefaultHeight default 19; + property Font : TFont read FFont write SetFont stored IsFontStored; + property FixedAreaConstraints : TVTFixedAreaConstraints read FFixedAreaConstraints write FFixedAreaConstraints; + property Height : Integer read FHeight write SetHeight default 19; + property Images : TCustomImageList read FImages write SetImages; + property MainColumn : TColumnIndex read GetMainColumn write SetMainColumn default 0; + property MaxHeight : Integer read FMaxHeight write SetMaxHeight default 10000; + property MinHeight : Integer read FMinHeight write SetMinHeight default 10; + property Options : TVTHeaderOptions read FOptions write SetOptions default [hoColumnResize, hoDrag, hoShowSortGlyphs]; + property ParentFont : Boolean read FParentFont write SetParentFont default True; + 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 SplitterHitTolerance : Integer read fSplitterHitTolerance write fSplitterHitTolerance default 8; + //The area in pixels around a spliter which is sensitive for resizing + property Style : TVTHeaderStyle read FStyle write SetStyle default hsThickButtons; + end; + + TVTHeaderClass = class of TVTHeader; + +implementation + +uses + WinApi.ShlObj, + WinApi.UxTheme, + System.Math, + System.SysUtils, + Vcl.Forms, + VirtualTrees, + VirtualTrees.HeaderPopup; + +type + TVirtualTreeColumnsCracker = class(TVirtualTreeColumns); + TVirtualTreeColumnCracker = class(TVirtualTreeColumn); + TBaseVirtualTreeCracker = class(TBaseVirtualTree); + + TVTHeaderHelper = class helper for TVTHeader + public + function Tree : TBaseVirtualTreeCracker; + end; + + TVirtualTreeColumnHelper = class helper for TVirtualTreeColumn + function TreeViewControl : TBaseVirtualTreeCracker; + function Header : TVTHeader; + end; + + TVirtualTreeColumnsHelper = class helper for TVirtualTreeColumns + function TreeViewControl : TBaseVirtualTreeCracker; + end; + + + + //----------------- TVTFixedAreaConstraints ---------------------------------------------------------------------------- + +constructor TVTFixedAreaConstraints.Create(AOwner : TVTHeader); + +begin + inherited Create; + FMaxWidthPercent := 95; + 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 : TCustomControl); + +begin + inherited Create; + FOwner := AOwner; + FColumns := GetColumnsClass.Create(Self); + FHeight := 19; + FDefaultHeight := FHeight; + FMinHeight := 10; + FMaxHeight := 10000; + FFont := TFont.Create; + FFont.OnChange := FontChanged; + FParentFont := True; + FBackgroundColor := 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; + PreBlendBias := - 50; + Transparency := 140; + end; + + fSplitterHitTolerance := 8; + FFixedAreaConstraints := TVTFixedAreaConstraints.Create(Self); + FFixedAreaConstraints.OnChange := FixedAreaConstraintsChanged; + + FDoingAutoFitColumns := False; +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); +begin + inherited; + {$IF CompilerVersion < 31} + AutoScale(false); + {$IFEND} +end; + +procedure TVTHeader.AutoScale(isDpiChange: Boolean); +var + I : Integer; + lMaxHeight : Integer; +begin + if (toAutoChangeScale in TBaseVirtualTreeCracker(Tree).TreeOptions.AutoOptions) and not isDpiChange then + begin + //Ensure a minimum header size based on the font, so that all text is visible. + //First 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 height based on the font, this is important as the user might just have increased the size of the system 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 and the minimum needed header height. + lMaxHeight := Max(lMaxHeight, FHeight); + //Set the calculated size + Self.SetHeight(lMaxHeight); + end; +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 + TVirtualTreeColumnsCracker(Columns).AdjustAutoSize(InvalidColumn); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTHeader.SetBackground(Value : TColor); +begin + if FBackgroundColor <> Value then + begin + FBackgroundColor := 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 Tree.HandleAllocated then + begin + FHeight := Value; + Include(FStates, hsNeedScaling); + end + else + begin + with FFixedAreaConstraints do + begin + RelativeMaxHeight := ((Tree.ClientHeight + FHeight) * FMaxHeightPercent) div 100; + RelativeMinHeight := ((Tree.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 Tree.ComponentState) and not (hsScaling in FStates) then + RecalculateHeader; + Tree.Invalidate; + 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 Tree.ComponentState) then + Invalidate(nil); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTHeader.SetMainColumn(Value : TColumnIndex); + +begin + if (csLoading in Tree.ComponentState) or (csDestroying in Tree.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; + Tree.MainColumnChanged; + if not (toExtendedFocus in Tree.TreeOptions.SelectionOptions) then + Tree.FocusedColumn := FMainColumn; + Tree.Invalidate; + 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 + TVirtualTreeColumnsCracker(FColumns).AdjustAutoSize(InvalidColumn); + if Tree.HandleAllocated then + begin + Tree.UpdateHorizontalScrollBar(False); + if hoAutoResize in ToBeSet then + Tree.Invalidate; + end; + end; + + if not (csLoading in Tree.ComponentState) and Tree.HandleAllocated then + begin + if hoVisible in (ToBeSet + ToBeCleared) then + RecalculateHeader; + Invalidate(nil); + Tree.Invalidate; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTHeader.SetParentFont(Value : Boolean); + +begin + if FParentFont <> Value then + begin + FParentFont := Value; + if FParentFont then + FFont.Assign(TBaseVirtualTree(FOwner).Font); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTHeader.SetSortColumn(Value : TColumnIndex); + +begin + if csLoading in Tree.ComponentState then + FSortColumn := Value + else + DoSetSortColumn(Value, FSortDirection); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTHeader.SetSortDirection(const Value : TSortDirection); + +begin + if Value <> FSortDirection then + begin + FSortDirection := Value; + Invalidate(nil); + if ((toAutoSort in Tree.TreeOptions.AutoOptions) or (hoHeaderClickAutoSort in Options)) and (Tree.UpdateCount = 0) then + Tree.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 Tree.ComponentState) then + Invalidate(nil); + end; +end; + +procedure TVTHeader.StyleChanged(); +begin + {$IF CompilerVersion < 31} + AutoScale(False); //Elements may have changed in size + {$IFEND} +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; isDpiChange : Boolean); +var + I : Integer; +begin + //This method is only executed if toAutoChangeScale is set + FMinHeight := MulDiv(FMinHeight, M, D); + FMaxHeight := MulDiv(FMaxHeight, M, D); + Self.Height := MulDiv(FHeight, M, D); + if not ParentFont then + Font.Height := MulDiv(Font.Height, M, D); + //Scale the columns widths too + for I := 0 to FColumns.Count - 1 do + TVirtualTreeColumnCracker(Self.FColumns[I]).ChangeScale(M, D, isDpiChange); + if not isDpiChange then + AutoScale(isDpiChange); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTHeader.DetermineSplitterIndex(P : TPoint) : Boolean; + +//Tries to find the index of that column whose right border corresponds to P. +//Result is True if column border was hit (with -3..+5 pixels tolerance). +//For continuous resizing the current track index and the column's left/right border are set. +//Note: The hit test is checking from right to left (or left to right in RTL mode) to make enlarging of zero-sized +//columns possible. + +var + VisibleFixedWidth : Integer; + SplitPoint : Integer; + + //--------------- local function -------------------------------------------- + + function IsNearBy(IsFixedCol : Boolean; LeftTolerance, RightTolerance : Integer) : Boolean; + + begin + if IsFixedCol then + Result := (P.X < SplitPoint + Tree.EffectiveOffsetX + RightTolerance) and (P.X > SplitPoint + Tree.EffectiveOffsetX - LeftTolerance) + else + Result := (P.X > VisibleFixedWidth) and (P.X < SplitPoint + RightTolerance) and (P.X > SplitPoint - LeftTolerance); + end; + +//--------------- end local function ---------------------------------------- + +var + I : Integer; + LeftTolerance : Integer; //The area left of the column divider which allows column resizing +begin + Result := False; + + if FColumns.Count > 0 then + begin + FColumns.TrackIndex := NoColumn; + VisibleFixedWidth := FColumns.GetVisibleFixedWidth; + LeftTolerance := Round(SplitterHitTolerance * 0.6); + if Tree.UseRightToLeftAlignment then + begin + SplitPoint := - Tree.EffectiveOffsetX; + if FColumns.TotalWidth < Tree.ClientWidth then + Inc(SplitPoint, Tree.ClientWidth - FColumns.TotalWidth); + + for I := 0 to FColumns.Count - 1 do + with TVirtualTreeColumnsCracker(FColumns), Items[PositionToIndex[I]] do + if coVisible in Options then + begin + if IsNearBy(coFixed in Options, LeftTolerance, SplitterHitTolerance - LeftTolerance) then + begin + if CanSplitterResize(P, PositionToIndex[I]) then + begin + Result := True; + TrackIndex := PositionToIndex[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 Options, Tree.EffectiveOffsetX) + Width; + FTrackPoint.Y := P.Y; + Break; + end; + end; + Inc(SplitPoint, Width); + end; + end + else + begin + SplitPoint := - Tree.EffectiveOffsetX + FColumns.TotalWidth; + + for I := FColumns.Count - 1 downto 0 do + with TVirtualTreeColumnsCracker(FColumns), Items[PositionToIndex[I]] do + if coVisible in Options then + begin + if IsNearBy(coFixed in Options, SplitterHitTolerance - LeftTolerance, LeftTolerance) then + begin + if CanSplitterResize(P, PositionToIndex[I]) then + begin + Result := True; + TrackIndex := PositionToIndex[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 Options, Tree.EffectiveOffsetX) - Width; + FTrackPoint.Y := P.Y; + Break; + end; + end; + Dec(SplitPoint, Width); + end; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTHeader.DoAfterAutoFitColumn(Column : TColumnIndex); + +begin + if Assigned(Tree.OnAfterAutoFitColumn) then + Tree.OnAfterAutoFitColumn(Self, Column); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTHeader.DoAfterColumnWidthTracking(Column : TColumnIndex); + +//Tell the application that a column width tracking operation has been finished. + +begin + if Assigned(Tree.OnAfterColumnWidthTracking) then + Tree.OnAfterColumnWidthTracking(Self, Column); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTHeader.DoAfterHeightTracking; + +//Tell the application that a height tracking operation has been finished. + +begin + if Assigned(Tree.OnAfterHeaderHeightTracking) then + Tree.OnAfterHeaderHeightTracking(Self); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTHeader.DoBeforeAutoFitColumn(Column : TColumnIndex; SmartAutoFitType : TSmartAutoFitType) : Boolean; + +//Query the application if we may autofit a column. + +begin + Result := True; + if Assigned(Tree.OnBeforeAutoFitColumn) then + Tree.OnBeforeAutoFitColumn(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(Tree.OnBeforeColumnWidthTracking) then + Tree.OnBeforeColumnWidthTracking(Self, Column, Shift); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTHeader.DoBeforeHeightTracking(Shift : TShiftState); + +//Tell the application that a height tracking operation may begin. + +begin + if Assigned(Tree.OnBeforeHeaderHeightTracking) then + Tree.OnBeforeHeaderHeightTracking(Self, Shift); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTHeader.DoCanSplitterResize(P : TPoint; var Allowed : Boolean); +begin + if Assigned(Tree.OnCanSplitterResizeHeader) then + Tree.OnCanSplitterResizeHeader(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(Tree.OnColumnWidthDblClickResize) then + Tree.OnColumnWidthDblClickResize(Self, Column, Shift, P, Result); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTHeader.DoColumnWidthTracking(Column : TColumnIndex; Shift : TShiftState; var TrackPoint : TPoint; P : TPoint) : Boolean; + +begin + Result := True; + if Assigned(Tree.OnColumnWidthTracking) then + Tree.OnColumnWidthTracking(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 := PopupMenu; + if Assigned(Tree.OnGetPopupMenu) then + Tree.OnGetPopupMenu(TBaseVirtualTree(FOwner), nil, Column, Position, AskParent, Result); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTHeader.DoHeightTracking(var P : TPoint; Shift : TShiftState) : Boolean; + +begin + Result := True; + if Assigned(Tree.OnHeaderHeightTracking) then + Tree.OnHeaderHeightTracking(Self, P, Shift, Result); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTHeader.DoHeightDblClickResize(var P : TPoint; Shift : TShiftState) : Boolean; + +begin + Result := True; + if Assigned(Tree.OnHeaderHeightDblClickResize) then + Tree.OnHeaderHeightDblClickResize(Self, P, Shift, Result); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTHeader.DoSetSortColumn(Value : TColumnIndex; pSortDirection : TSortDirection); + +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; + FSortDirection := pSortDirection; + if FSortColumn > NoColumn then + Invalidate(Columns[FSortColumn]); + if ((toAutoSort in Tree.TreeOptions.AutoOptions) or (hoHeaderClickAutoSort in Options)) and (Tree.UpdateCount = 0) then + Tree.SortTree(FSortColumn, FSortDirection, True); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTHeader.DragTo(P : TPoint); + +//Moves the drag image to a new position, which is determined from the passed point P and the previous +//mouse position. + +var + I, NewTarget : Integer; + //optimized drag image move support + ClientP : TPoint; + Left, Right : Integer; + NeedRepaint : Boolean; //True if the screen needs an update (changed drop target or drop side) + +begin + //Determine new drop target and which side of it is prefered. + ClientP := Tree.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.DropTarget); + if NewTarget >= 0 then + begin + FColumns.GetColumnBounds(NewTarget, Left, Right); + if (ClientP.X < ((Left + Right) div 2)) <> FColumns.DropBefore then + begin + NeedRepaint := True; + FColumns.DropBefore := not FColumns.DropBefore; + end; + end; + + if NeedRepaint then + begin + //Invalidate columns which need a repaint. + if FColumns.DropTarget > NoColumn then + begin + I := FColumns.DropTarget; + FColumns.DropTarget := NoColumn; + Invalidate(FColumns.Items[I]); + end; + if (NewTarget > NoColumn) and (NewTarget <> FColumns.DropTarget) then + begin + Invalidate(FColumns.Items[NewTarget]); + FColumns.DropTarget := NewTarget; + end; + end; + + //Fix for various problems mentioned in issue 248. + if NeedRepaint then + begin + UpdateWindow(FOwner.Handle); + //The new routine recaptures the backup image after the updatewindow + //Note: We could have called this unconditionally but when called + //over the tree, doesn't capture the background image. Since our + //problems are in painting of the header, we call it only when the + //drag image is over the header. + if + //determine the case when the drag image is or was on the header area + (InHeader(FOwner.ScreenToClient(FDragImage.LastPosition)) or InHeader(FOwner.ScreenToClient(FDragImage.ImagePosition))) then + begin + GDIFlush; + TBaseVirtualTreeCracker(FOwner).UpdateWindowAndDragImage(TBaseVirtualTree(FOwner), TBaseVirtualTreeCracker(FOwner).HeaderRect, True, True); + end; + //since we took care of UpdateWindow above, there is no need to do an + //update window again by sending NeedRepaint. So switch off the second parameter. + NeedRepaint := False; + end; + + FDragImage.DragTo(P, NeedRepaint); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTHeader.FixedAreaConstraintsChanged(Sender : TObject); + +//This method gets called when FFixedAreaConstraints is changed. + +begin + if Tree.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.GetRestoreSelectionColumnIndex : Integer; +begin + if FRestoreSelectionColumnIndex >= 0 then + Result := FRestoreSelectionColumnIndex + else + Result := MainColumn; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTHeader.GetShiftState : TShiftState; + +begin + Result := []; + if GetKeyState(VK_SHIFT) < 0 then + Include(Result, ssShift); + if GetKeyState(VK_CONTROL) < 0 then + Include(Result, ssCtrl); + if GetKeyState(VK_MENU) < 0 then + Include(Result, ssAlt); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTHeader.HandleHeaderMouseMove(var Message : TWMMouseMove) : Boolean; + +var + P : TPoint; + NextColumn, I : TColumnIndex; + NewWidth : Integer; + +begin + Result := False; + with Message do + begin + P := Point(XPos, YPos); + if hsColumnWidthTrackPending in FStates then + begin + Tree.StopTimer(HeaderTimer); + FStates := FStates - [hsColumnWidthTrackPending] + [hsColumnWidthTracking]; + HandleHeaderMouseMove := True; + Result := 0; + end + else if hsHeightTrackPending in FStates then + begin + Tree.StopTimer(HeaderTimer); + FStates := FStates - [hsHeightTrackPending] + [hsHeightTracking]; + HandleHeaderMouseMove := True; + Result := 0; + end + else if hsColumnWidthTracking in FStates then + begin + if DoColumnWidthTracking(FColumns.TrackIndex, GetShiftState, FTrackPoint, P) then + begin + if Tree.UseRightToLeftAlignment then + begin + NewWidth := FTrackPoint.X - XPos; + NextColumn := FColumns.GetPreviousVisibleColumn(FColumns.TrackIndex); + end + else + begin + NewWidth := XPos - FTrackPoint.X; + NextColumn := FColumns.GetNextVisibleColumn(FColumns.TrackIndex); + 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.TrackIndex = FAutoSizeIndex) and (NextColumn > NoColumn) and (coResizable in FColumns[NextColumn].Options) and + (FColumns[FColumns.TrackIndex].MinWidth < NewWidth) and (FColumns[FColumns.TrackIndex].MaxWidth > NewWidth) then + FColumns[NextColumn].Width := FColumns[NextColumn].Width - NewWidth + FColumns[FColumns.TrackIndex].Width + else + FColumns[FColumns.TrackIndex].Width := NewWidth; //1 EListError seen here (List index out of bounds (-1)) since 10/2013 + end; + HandleHeaderMouseMove := True; + Result := 0; + end + else if hsHeightTracking in FStates then + begin + if DoHeightTracking(P, GetShiftState) then + SetHeight(Integer(FHeight) + P.Y); + HandleHeaderMouseMove := True; + Result := 0; + end + else + begin + if hsDragPending in FStates then + begin + P := Tree.ClientToScreen(P); + //start actual dragging if allowed + if (hoDrag in FOptions) and Tree.DoHeaderDragging(TVirtualTreeColumnsCracker(FColumns).DownIndex) then + begin + if ((Abs(FDragStart.X - P.X) > Mouse.DragThreshold) or (Abs(FDragStart.Y - P.Y) > Mouse.DragThreshold)) then + begin + Tree.StopTimer(HeaderTimer); + with TVirtualTreeColumnsCracker(FColumns) do + begin + I := DownIndex; + DownIndex := NoColumn; + HoverIndex := NoColumn; + if I > NoColumn then + Invalidate(FColumns[I]); + end; + PrepareDrag(P, FDragStart); + FStates := FStates - [hsDragPending] + [hsDragging]; + HandleHeaderMouseMove := True; + Result := 0; + end; + end; + end + else if hsDragging in FStates then + begin + DragTo(Tree.ClientToScreen(Point(XPos, YPos))); + HandleHeaderMouseMove := True; + Result := 0; + end; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTHeader.HandleMessage(var Message : TMessage) : Boolean; + +//The header gets here the opportunity to handle certain messages before they reach the tree. This is important +//because the tree needs to handle various non-client area messages for the header as well as some dragging/tracking +//events. +//By returning True the message will not be handled further, otherwise the message is then dispatched +//to the proper message handlers. + +var + P : TPoint; + R : TRect; + I : TColumnIndex; + OldPosition : Integer; + HitIndex : TColumnIndex; + NewCursor : HCURSOR; + Button : TMouseButton; + IsInHeader, IsHSplitterHit, IsVSplitterHit : Boolean; + + //--------------- local function -------------------------------------------- + + function HSplitterHit : Boolean; + begin + Result := (hoColumnResize in FOptions) and DetermineSplitterIndex(P); + if Result and not InHeader(P) then + begin + // Code commented due to issue #1067. What was the orginal inention of this code? It does not make much sense unless you allow column resize outside the header. + //NextCol := FColumns.GetNextVisibleColumn(FColumns.TrackIndex); + //if not (coFixed in FColumns[FColumns.TrackIndex].Options) or (NextCol <= NoColumn) or + // (coFixed in FColumns[NextCol].Options) or (P.Y > Integer(Treeview.FRangeY)) then + Result := False; + end; + end; + +//--------------- end local function ---------------------------------------- + +begin + Result := False; + case Message.Msg of + WM_SIZE : + begin + if not (tsWindowCreating in TBaseVirtualTreeCracker(FOwner).TreeStates) then + if (hoAutoResize in FOptions) and not (hsAutoSizing in FStates) then + begin + TVirtualTreeColumnsCracker(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(TBaseVirtualTreeCracker(FOwner).Font); + CM_BIDIMODECHANGED : + for I := 0 to FColumns.Count - 1 do + if coParentBiDiMode in FColumns[I].Options then + FColumns[I].ParentBiDiModeChanged; + WM_NCMBUTTONDOWN : + begin + with TWMNCMButtonDown(Message) do + P := Tree.ScreenToClient(Point(XCursor, YCursor)); + if InHeader(P) then + TBaseVirtualTreeCracker(FOwner).DoHeaderMouseDown(mbMiddle, GetShiftState, P.X, P.Y + Integer(FHeight)); + end; + WM_NCMBUTTONUP : + begin + with TWMNCMButtonUp(Message) do + P := FOwner.ScreenToClient(Point(XCursor, YCursor)); + if InHeader(P) then + begin + with TVirtualTreeColumnsCracker(FColumns) do + begin + HandleClick(P, mbMiddle, True, False); + TBaseVirtualTreeCracker(FOwner).DoHeaderMouseUp(mbMiddle, GetShiftState, P.X, P.Y + Integer(Self.FHeight)); + DownIndex := NoColumn; + CheckBoxHit := False; + end; + end; + end; + WM_LBUTTONDBLCLK, WM_NCLBUTTONDBLCLK, WM_NCMBUTTONDBLCLK, WM_NCRBUTTONDBLCLK : + begin + if Message.Msg <> WM_LBUTTONDBLCLK then + with TWMNCLButtonDblClk(Message) do + P := FOwner.ScreenToClient(Point(XCursor, YCursor)) + else + with TWMLButtonDblClk(Message) do + P := Point(XPos, YPos); + + if (hoHeightDblClickResize in FOptions) and InHeaderSplitterArea(P) and (FDefaultHeight > 0) then + begin + if DoHeightDblClickResize(P, GetShiftState) and (FDefaultHeight > 0) then + SetHeight(FMinHeight); + Result := True; + end + else if HSplitterHit and ((Message.Msg = WM_NCLBUTTONDBLCLK) or (Message.Msg = WM_LBUTTONDBLCLK)) and (hoDblClickResize in FOptions) and (FColumns.TrackIndex > NoColumn) + then + begin + //If the click was on a splitter then resize column to smallest width. + if DoColumnWidthDblClickResize(FColumns.TrackIndex, P, GetShiftState) then + AutoFitColumns(True, smaUseColumnOption, FColumns[FColumns.TrackIndex].Position, FColumns[FColumns.TrackIndex].Position); + Message.Result := 0; + Result := True; + end + else if InHeader(P) and (Message.Msg <> WM_LBUTTONDBLCLK) then + begin + case Message.Msg of + WM_NCMBUTTONDBLCLK : + Button := mbMiddle; + WM_NCRBUTTONDBLCLK : + Button := mbRight; + else + //WM_NCLBUTTONDBLCLK + Button := mbLeft; + end; + if Button = mbLeft then + TVirtualTreeColumnsCracker(FColumns).AdjustDownColumn(P); + TVirtualTreeColumnsCracker(FColumns).HandleClick(P, Button, True, True); + end; + end; + //The "hot" area of the headers horizontal splitter is partly within the client area of the the tree, so we need + //to handle WM_LBUTTONDOWN here, too. + WM_LBUTTONDOWN, WM_NCLBUTTONDOWN : + begin + + Application.CancelHint; + + if not (csDesigning in Tree.ComponentState) then + begin + with Tree do + begin + //make sure no auto scrolling is active... + StopTimer(ScrollTimer); + DoStateChange([], [tsScrollPending, tsScrolling]); + //... pending editing is cancelled (actual editing remains active) + StopTimer(EditTimer); + DoStateChange([], [tsEditPending]); + end; + end; + + if Message.Msg = WM_LBUTTONDOWN then + //Coordinates are already client area based. + with TWMLButtonDown(Message) do + begin + P := Point(XPos, YPos); + //#909 + FDragStart := Tree.ClientToScreen(P); + end + else + with TWMNCLButtonDown(Message) do + begin + //want the drag start point in screen coordinates + FDragStart := Point(XCursor, YCursor); + P := Tree.ScreenToClient(FDragStart); + end; + + IsInHeader := InHeader(P); + //in design-time header columns are always resizable + if (csDesigning in Tree.ComponentState) then + IsVSplitterHit := InHeaderSplitterArea(P) + else + IsVSplitterHit := InHeaderSplitterArea(P) and CanSplitterResize(P); + IsHSplitterHit := HSplitterHit; + + if IsVSplitterHit or IsHSplitterHit then + begin + FTrackStart := P; + TVirtualTreeColumnsCracker(FColumns).HoverIndex := NoColumn; + if IsVSplitterHit then + begin + if not (csDesigning in Tree.ComponentState) then + DoBeforeHeightTracking(GetShiftState); + Include(FStates, hsHeightTrackPending); + end + else + begin + if not (csDesigning in Tree.ComponentState) then + DoBeforeColumnWidthTracking(FColumns.TrackIndex, GetShiftState); + Include(FStates, hsColumnWidthTrackPending); + end; + + SetCapture(Tree.Handle); + Result := True; + Message.Result := 0; + end + else if IsInHeader then + begin + HitIndex := TVirtualTreeColumnsCracker(FColumns).AdjustDownColumn(P); + //in design-time header columns are always draggable + if ((csDesigning in Tree.ComponentState) and (HitIndex > NoColumn)) or ((hoDrag in FOptions) and (HitIndex > NoColumn) and (coDraggable in FColumns[HitIndex].Options)) + then + begin + //Show potential drag operation. + //Disabled columns do not start a drag operation because they can't be clicked. + Include(FStates, hsDragPending); + SetCapture(Tree.Handle); + Result := True; + Message.Result := 0; + end; + end; + + //This is a good opportunity to notify the application. + if not (csDesigning in Tree.ComponentState) and IsInHeader then + TBaseVirtualTreeCracker(FOwner).DoHeaderMouseDown(mbLeft, GetShiftState, P.X, P.Y + Integer(FHeight)); + end; + WM_NCRBUTTONDOWN : + begin + with TWMNCRButtonDown(Message) do + P := FOwner.ScreenToClient(Point(XCursor, YCursor)); + if InHeader(P) then + TBaseVirtualTreeCracker(FOwner).DoHeaderMouseDown(mbRight, GetShiftState, P.X, P.Y + Integer(FHeight)); + end; + WM_NCRBUTTONUP : + if not (csDesigning in FOwner.ComponentState) then + with TWMNCRButtonUp(Message) do + begin + Application.CancelHint; + P := FOwner.ScreenToClient(Point(XCursor, YCursor)); + if InHeader(P) then + begin + HandleMessage := TVirtualTreeColumnsCracker(FColumns).HandleClick(P, mbRight, True, False); + TBaseVirtualTreeCracker(FOwner).DoHeaderMouseUp(mbRight, GetShiftState, P.X, P.Y + Integer(FHeight)); + end; + end; + //When the tree window has an active mouse capture then we only get "client-area" messages. + WM_LBUTTONUP, WM_NCLBUTTONUP : + begin + Application.CancelHint; + + if FStates <> [] then + begin + ReleaseCapture; + if hsDragging in FStates then + begin + //successfull dragging moves columns + with TWMLButtonUp(Message) do + P := Tree.ClientToScreen(Point(XPos, YPos)); + GetWindowRect(Tree.Handle, R); + with FColumns do + begin + FDragImage.EndDrag; + + //Problem fixed: + //Column Header does not paint correctly after a drop in certain conditions + // ** The conditions are, drag is across header, mouse is not moved after + //the drop and the graphics hardware is slow in certain operations (encountered + //on Windows 10). + //Fix for the problem on certain systems where the dropped column header + //does not appear in the new position if the mouse is not moved after + //the drop. The reason is that the restore backup image operation (BitBlt) + //in the above EndDrag is slower than the header repaint in the code below + //and overlaps the new changed header with the older image. + //This happens because BitBlt seems to operate in its own thread in the + //graphics hardware and finishes later than the following code. + // + //To solve this problem, we introduce a small delay here so that the + //changed header in the following code is correctly repainted after + //the delayed BitBlt above has finished operation to restore the old + //backup image. + sleep(50); + + if (DropTarget > - 1) and (DropTarget <> DragIndex) and PtInRect(R, P) then + begin + OldPosition := FColumns[DragIndex].Position; + if FColumns.DropBefore then + begin + if FColumns[DragIndex].Position < FColumns[DropTarget].Position then + FColumns[DragIndex].Position := Max(0, FColumns[DropTarget].Position - 1) + else + FColumns[DragIndex].Position := FColumns[DropTarget].Position; + end + else + begin + if FColumns[DragIndex].Position < FColumns[DropTarget].Position then + FColumns[DragIndex].Position := FColumns[DropTarget].Position + else + FColumns[DragIndex].Position := FColumns[DropTarget].Position + 1; + end; + Tree.DoHeaderDragged(DragIndex, OldPosition); + end + else + Tree.DoHeaderDraggedOut(DragIndex, P); + DropTarget := NoColumn; + end; + Invalidate(nil); + end; + Result := True; + Message.Result := 0; + end; + + case Message.Msg of + WM_LBUTTONUP : + with TWMLButtonUp(Message) do + begin + with TVirtualTreeColumnsCracker(FColumns) do + begin + if DownIndex > NoColumn then + HandleClick(Point(XPos, YPos), mbLeft, False, False); + end; + if FStates <> [] then + TBaseVirtualTreeCracker(FOwner).DoHeaderMouseUp(mbLeft, KeysToShiftState(Keys), XPos, YPos); + end; + WM_NCLBUTTONUP : + with TWMNCLButtonUp(Message) do + begin + P := FOwner.ScreenToClient(Point(XCursor, YCursor)); + TVirtualTreeColumnsCracker(FColumns).HandleClick(P, mbLeft, False, False); + TBaseVirtualTreeCracker(FOwner).DoHeaderMouseUp(mbLeft, GetShiftState, P.X, P.Y + Integer(FHeight)); + end; + end; + + if FColumns.TrackIndex > NoColumn then + begin + if hsColumnWidthTracking in FStates then + DoAfterColumnWidthTracking(FColumns.TrackIndex); + Invalidate(Columns[FColumns.TrackIndex]); + FColumns.TrackIndex := NoColumn; + end; + with TVirtualTreeColumnsCracker(FColumns) do + begin + if DownIndex > NoColumn then + begin + Invalidate(FColumns[DownIndex]); + DownIndex := NoColumn; + end; + end; + if hsHeightTracking in FStates then + DoAfterHeightTracking; + + FStates := FStates - [hsDragging, hsDragPending, hsColumnWidthTracking, hsColumnWidthTrackPending, hsHeightTracking, hsHeightTrackPending]; + end; //WM_NCLBUTTONUP + //hovering, mouse leave detection + WM_NCMOUSEMOVE : + with TWMNCMouseMove(Message), TVirtualTreeColumnsCracker(FColumns) do + begin + P := Tree.ScreenToClient(Point(XCursor, YCursor)); + Tree.DoHeaderMouseMove(GetShiftState, P.X, P.Y + Integer(FHeight)); + if InHeader(P) and ((AdjustHoverColumn(P)) or ((DownIndex >= 0) and (HoverIndex <> DownIndex))) then + begin + //We need a mouse leave detection from here for the non client area. + //TODO: The best solution available would be the TrackMouseEvent API. + //With the drop of the support of Win95 totally and WinNT4 we should replace the timer. + Tree.StopTimer(HeaderTimer); + SetTimer(Tree.Handle, HeaderTimer, 50, nil); + //use Delphi's internal hint handling for header hints too + if hoShowHint in FOptions then + begin + //client coordinates! + XCursor := P.X; + YCursor := P.Y + Integer(FHeight); + Application.HintMouseMessage(FOwner, Message); + end; + end; + end; + WM_TIMER : + if TWMTimer(Message).TimerID = HeaderTimer then + begin + //determine current mouse position to check if it left the window + GetCursorPos(P); + P := Tree.ScreenToClient(P); + with TVirtualTreeColumnsCracker(FColumns) do + begin + if not InHeader(P) or ((DownIndex > NoColumn) and (HoverIndex <> DownIndex)) then + begin + Tree.StopTimer(HeaderTimer); + HoverIndex := NoColumn; + ClickIndex := NoColumn; + DownIndex := NoColumn; + CheckBoxHit := False; + Result := True; + Message.Result := 0; + Invalidate(nil); + end; + end; + end; + WM_MOUSEMOVE : //mouse capture and general message redirection + Result := HandleHeaderMouseMove(TWMMouseMove(Message)); + WM_SETCURSOR : + //Feature: design-time header + if (FStates = []) then + begin + //Retrieve last cursor position (GetMessagePos does not work here, I don't know why). + GetCursorPos(P); + + //Is the mouse in the header rectangle and near the splitters? + P := Tree.ScreenToClient(P); + IsHSplitterHit := HSplitterHit; + //in design-time header columns are always resizable + if (csDesigning in Tree.ComponentState) then + IsVSplitterHit := InHeaderSplitterArea(P) + else + IsVSplitterHit := InHeaderSplitterArea(P) and CanSplitterResize(P); + + if IsVSplitterHit or IsHSplitterHit then + begin + NewCursor := Screen.Cursors[Tree.Cursor]; + if IsVSplitterHit and ((hoHeightResize in FOptions) or (csDesigning in Tree.ComponentState)) then + NewCursor := Screen.Cursors[crVSplit] + else if IsHSplitterHit then + NewCursor := Screen.Cursors[crHSplit]; + + if not (csDesigning in Tree.ComponentState) then + Tree.DoGetHeaderCursor(NewCursor); + Result := NewCursor <> Screen.Cursors[crDefault]; + if Result then + begin + WinApi.Windows.SetCursor(NewCursor); + Message.Result := 1; + end; + end; + end + else + begin + Message.Result := 1; + Result := True; + end; + WM_KEYDOWN, WM_KILLFOCUS : + if (Message.Msg = WM_KILLFOCUS) or (TWMKeyDown(Message).CharCode = VK_ESCAPE) then + begin + if hsDragging in FStates then + begin + ReleaseCapture; + FDragImage.EndDrag; + Exclude(FStates, hsDragging); + FColumns.DropTarget := 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.TrackIndex); + 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 Tree.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.DropTarget := NoColumn; + Start := Tree.ScreenToClient(Start); + Inc(Start.Y, FHeight); + FColumns.DragIndex := FColumns.ColumnFromPosition(Start); + DragColumn := FColumns[FColumns.DragIndex]; + + Image := TBitmap.Create; + with Image do + try + PixelFormat := pf32Bit; + SetSize(DragColumn.Width, 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 Tree.UseRightToLeftAlignment then + RTLOffset := Tree.ComputeRTLOffset + else + RTLOffset := 0; + with DragColumn do + FColumns.PaintHeader(Canvas, Rect(Left, 0, Left + Width, Height), Point( - RTLOffset, 0), RTLOffset); + + if Tree.UseRightToLeftAlignment then + ImagePos := Tree.ClientToScreen(Point(DragColumn.Left + Tree.ComputeRTLOffset(True), 0)) + else + ImagePos := Tree.ClientToScreen(Point(DragColumn.Left, 0)); + //Column rectangles are given in local window coordinates not client coordinates. + Dec(ImagePos.Y, FHeight); + + if hoRestrictDrag in FOptions then + FDragImage.MoveRestriction := dmrHorizontalOnly + else + FDragImage.MoveRestriction := dmrNone; + FDragImage.PrepareDrag(Image, ImagePos, P, nil); + FDragImage.ShowDragImage; + finally + Image.Free; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTHeader.ReadColumns(Reader : TReader); + +begin + Include(FStates, hsLoading); + Columns.Clear; + Reader.ReadValue; + Reader.ReadCollection(Columns); + Exclude(FStates, hsLoading); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTHeader.RecalculateHeader; + +//Initiate a recalculation of the non-client area of the owner tree. + +begin + if Tree.HandleAllocated then + begin + Tree.UpdateHeaderRect; + SetWindowPos(Tree.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 + TVirtualTreeColumnCracker(FColumns[I]).InternalSetWidth(FColumns[I].MinWidth); //SetWidth has side effects and this bypasses them + I := GetNextVisibleColumn(I); + end; + FixedWidth := GetVisibleFixedWidth; + end; + + with FFixedAreaConstraints do + begin + MinFixedWidth := (Tree.ClientWidth * FMinWidthPercent) div 100; + MaxFixedWidth := (Tree.ClientWidth * FMaxWidthPercent) div 100; + end; + end; + +//----------- end local function -------------------------------------------- + +begin + if ([csLoading, csReading, csWriting, csDestroying] * Tree.ComponentState = []) and not (hsLoading in FStates) and Tree.HandleAllocated then + begin + Include(FStates, hsScaling); + + SetHeight(FHeight); + RecalculateHeader; + + with FFixedAreaConstraints do + if (FMaxWidthPercent > 0) or (FMinWidthPercent > 0) or (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]); + + TVirtualTreeColumnsCracker(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 + MainColumn := 0; + if FMainColumn > FColumns.Count - 1 then + MainColumn := FColumns.Count - 1; + if (FMainColumn >= 0) and not (coVisible in Self.Columns[FMainColumn].Options) then + begin + //Issue #946: Choose new MainColumn if current one ist not visible + MainColumn := Self.Columns.GetFirstVisibleColumn(); + end +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTHeader.UpdateSpringColumns; + +var + I : TColumnIndex; + SpringCount : Integer; + Sign : Integer; + ChangeBy : Single; + Difference : Single; + NewAccumulator : Single; + +begin + with Tree do + ChangeBy := HeaderRect.Right - HeaderRect.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].Options = [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].Options = [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].SpringRest + Difference; + //Set new width if at least one pixel size difference is reached. + if NewAccumulator >= 1 then + TVirtualTreeColumnCracker(FColumns[I]).SetWidth(FColumns[I].Width + (Trunc(NewAccumulator) * Sign)); + FColumns[I].SpringRest := 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 Tree do + FLastWidth := HeaderRect.Right - HeaderRect.Left; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +type + //--- HACK WARNING! + //This type cast is a partial rewrite of the private section of TWriter. The purpose is to have access to + //the FPropPath member, which is otherwise not accessible. The reason why this access is needed is that + //with nested components this member contains unneeded property path information. These information prevent + //successful load of the stored properties later. + //In System.Classes.pas you can see that FPropPath is reset several times to '' to prevent this case for certain properies. + //Unfortunately, there is no clean way for us here to do the same. +{$HINTS off} + TWriterHack = class(TFiler) + private + FRootAncestor : TComponent; + FPropPath : string; + end; +{$HINTS on} + + +procedure TVTHeader.WriteColumns(Writer : TWriter); + +//Write out the columns but take care for the case VT is a nested component. + +var + LastPropPath : string; + +begin + //Save last property path for restoration. + LastPropPath := TWriterHack(Writer).FPropPath; + try + //If VT is a nested component then this path contains the name of the parent component at this time + //(otherwise it is already empty). This path is then combined with the property name under which the tree + //is defined in the parent component. Unfortunately, the load code in System.Classes.pas does not consider this case + //is then unable to load this property. + TWriterHack(Writer).FPropPath := ''; + Writer.WriteCollection(Columns); + finally + TWriterHack(Writer).FPropPath := LastPropPath; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTHeader.AllowFocus(ColumnIndex : TColumnIndex) : Boolean; +begin + Result := False; + if not FColumns.IsValidColumn(ColumnIndex) then + Exit; //Just in case. + + Result := (coAllowFocus in FColumns[ColumnIndex].Options); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTHeader.Assign(Source : TPersistent); + +begin + if Source is TVTHeader then + begin + AutoSizeIndex := TVTHeader(Source).AutoSizeIndex; + Background := TVTHeader(Source).Background; + Columns := TVTHeader(Source).Columns; + Font := TVTHeader(Source).Font; + FixedAreaConstraints.Assign(TVTHeader(Source).FixedAreaConstraints); + Height := TVTHeader(Source).Height; + Images := TVTHeader(Source).Images; + MainColumn := TVTHeader(Source).MainColumn; + Options := TVTHeader(Source).Options; + ParentFont := TVTHeader(Source).ParentFont; + PopupMenu := TVTHeader(Source).PopupMenu; + SortColumn := TVTHeader(Source).SortColumn; + SortDirection := TVTHeader(Source).SortDirection; + Style := TVTHeader(Source).Style; + + RescaleHeader; + end + else + inherited; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTHeader.AutoFitColumns(); +begin + AutoFitColumns(not Tree.IsUpdating); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTHeader.AutoFitColumns(Animated : Boolean; SmartAutoFitType : TSmartAutoFitType = smaUseColumnOption; RangeStartCol : Integer = NoColumn; + RangeEndCol : Integer = NoColumn); + +//--------------- local functions ------------------------------------------- + + function GetUseSmartColumnWidth(ColumnIndex : TColumnIndex) : Boolean; + + begin + case SmartAutoFitType of + smaAllColumns : + Result := True; + smaUseColumnOption : + Result := coSmartResize in FColumns.Items[ColumnIndex].Options; + else + Result := False; + end; + end; + +//---------------------------------------------------------------------------- + + procedure DoAutoFitColumn(Column : TColumnIndex); + + begin + with TVirtualTreeColumnsCracker(FColumns) do + if ([coResizable, coVisible] * Items[PositionToIndex[Column]].Options = [coResizable, coVisible]) and DoBeforeAutoFitColumn(PositionToIndex[Column], SmartAutoFitType) and + not Tree.OperationCanceled then + begin + if Animated then + AnimatedResize(PositionToIndex[Column], Tree.GetMaxColumnWidth(PositionToIndex[Column], GetUseSmartColumnWidth(PositionToIndex[Column]))) + else + FColumns[PositionToIndex[Column]].Width := Tree.GetMaxColumnWidth(PositionToIndex[Column], GetUseSmartColumnWidth(PositionToIndex[Column])); + + DoAfterAutoFitColumn(PositionToIndex[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 + + Tree.StartOperation(okAutoFitColumns); + FDoingAutoFitColumns := True; + try + if Assigned(Tree.OnBeforeAutoFitColumns) then + Tree.OnBeforeAutoFitColumns(Self, SmartAutoFitType); + + for I := StartCol to EndCol do + DoAutoFitColumn(I); + + if Assigned(Tree.OnAfterAutoFitColumns) then + Tree.OnAfterAutoFitColumns(Self); + + finally + Tree.EndOperation(okAutoFitColumns); + Tree.Invalidate(); + FDoingAutoFitColumns := False; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTHeader.InHeader(P : TPoint) : Boolean; + +//Determines whether the given point (client coordinates!) is within the header rectangle (non-client coordinates). + +var + R, RW : TRect; + +begin + R := Tree.HeaderRect; + + //Current position of the owner in screen coordinates. + GetWindowRect(Tree.Handle, RW); + + //Convert to client coordinates. + MapWindowPoints(0, Tree.Handle, RW, 2); + + //Consider the header within this rectangle. + OffsetRect(R, RW.Left, RW.Top); + Result := PtInRect(R, P); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTHeader.InHeaderSplitterArea(P : TPoint) : Boolean; + +//Determines whether the given point (client coordinates!) hits the horizontal splitter area of the header. + +var + R, RW : TRect; + +begin + if (P.Y > 2) or (P.Y < - 2) or not (hoVisible in FOptions) then + Result := False + else + begin + R := Tree.HeaderRect; + Inc(R.Bottom, 2); + + //Current position of the owner in screen coordinates. + GetWindowRect(Tree.Handle, RW); + + //Convert to client coordinates. + MapWindowPoints(0, Tree.Handle, RW, 2); + + //Consider the header within this rectangle. + OffsetRect(R, RW.Left, RW.Top); + Result := PtInRect(R, P); + end; +end; + +procedure TVTHeader.InternalSetAutoSizeIndex(const Index : TColumnIndex); +begin + FAutoSizeIndex := index; +end; + +procedure TVTHeader.InternalSetMainColumn(const Index : TColumnIndex); +begin + FMainColumn := index; +end; + +procedure TVTHeader.InternalSetSortColumn(const Index : TColumnIndex); +begin + FSortColumn := index; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTHeader.Invalidate(Column : TVirtualTreeColumn; ExpandToBorder : Boolean = False; UpdateNowFlag : Boolean = False); + +//Because the header is in the non-client area of the tree it needs some special handling in order to initiate its +//repainting. +//If ExpandToBorder is True then not only the given column but everything or (depending on hoFullRepaintOnResize) just +//everything to its right (or left, in RTL mode) will be invalidated (useful for resizing). This makes only sense when +//a column is given. + +var + R, RW : TRect; + Flags : Cardinal; + +begin + if (hoVisible in FOptions) and Tree.HandleAllocated then + with Tree do + begin + if Column = nil then + R := HeaderRect + else + begin + R := Column.GetRect; + if not (coFixed in Column.Options) then + OffsetRect(R, - EffectiveOffsetX, 0); + if UseRightToLeftAlignment then + OffsetRect(R, ComputeRTLOffset, 0); + if ExpandToBorder then + begin + if (hoFullRepaintOnResize in Header.Options) then + begin + R.Left := HeaderRect.Left; + R.Right := HeaderRect.Right; + end + else + begin + if UseRightToLeftAlignment then + R.Left := HeaderRect.Left + else + R.Right := HeaderRect.Right; + end; + end; + end; + R.Bottom := Tree.ClientHeight; //We want to repaint the entire column to bottom, not just the header + + //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); + Flags := RDW_FRAME or RDW_INVALIDATE or RDW_VALIDATE or RDW_NOINTERNALPAINT or RDW_NOERASE or RDW_NOCHILDREN; + if UpdateNowFlag then + Flags := Flags or RDW_UPDATENOW; + RedrawWindow(Handle, @R, 0, Flags); + 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 := UTF8ToString(S); + ReadBuffer(Dummy, SizeOf(Dummy)); + Pitch := TFontPitch(Dummy); + ReadBuffer(Dummy, SizeOf(Dummy)); + Style := TFontStyles(Byte(Dummy)); + end; + + //Read data introduced by stream version 1+. + if Version > 0 then + begin + ReadBuffer(Dummy, SizeOf(Dummy)); + MainColumn := Dummy; + ReadBuffer(Dummy, SizeOf(Dummy)); + SortColumn := Dummy; + ReadBuffer(Dummy, SizeOf(Dummy)); + SortDirection := TSortDirection(Byte(Dummy)); + end; + + //Read data introduced by stream version 5+. + if Version > 4 then + begin + ReadBuffer(Dummy, SizeOf(Dummy)); + ParentFont := Boolean(Dummy); + ReadBuffer(Dummy, SizeOf(Dummy)); + FMaxHeight := Integer(Dummy); + ReadBuffer(Dummy, SizeOf(Dummy)); + FMinHeight := Integer(Dummy); + ReadBuffer(Dummy, SizeOf(Dummy)); + FDefaultHeight := Integer(Dummy); + with FFixedAreaConstraints do + begin + ReadBuffer(Dummy, SizeOf(Dummy)); + FMaxHeightPercent := TVTConstraintPercent(Dummy); + ReadBuffer(Dummy, SizeOf(Dummy)); + FMaxWidthPercent := TVTConstraintPercent(Dummy); + ReadBuffer(Dummy, SizeOf(Dummy)); + FMinHeightPercent := TVTConstraintPercent(Dummy); + ReadBuffer(Dummy, SizeOf(Dummy)); + FMinWidthPercent := TVTConstraintPercent(Dummy); + end; + end; + finally + Exclude(FStates, hsLoading); + RecalculateHeader(); + Tree.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].Options = Options) and (FColumns[Column].Width > 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) and (RangeEndCol >= 0) then // RangeEndCol == -1 means no columns, so nothing to do + 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].Width; + 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].Options = 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].Options = Options) and IsResizable(I) then + ChangeWidth(I, Difference * Sign); + + //Now distribute Rest. + I := Start; + while Rest > 0 do + begin + if (Options * FColumns[I].Options = Options) and IsResizable(I) then + if FColumns[I].BonusPixel <> BonusPixel then + begin + Dec(Rest, ChangeWidth(I, Sign)); + FColumns[I].BonusPixel := 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].Options = Options then + FColumns[I].BonusPixel := not FColumns[I].BonusPixel; + 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].Options = Options) then + begin + Inc(Result, Widths[I - RangeStartCol] - FColumns[I].Width); + TVirtualTreeColumnCracker(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 TVirtualTreeColumnsCracker(FColumns) do + for I := Count - 1 downto 0 do + if [coResizable, coVisible] * Items[PositionToIndex[I]].Options = [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 := FBackgroundColor; + WriteBuffer(Dummy, SizeOf(Dummy)); + Dummy := FHeight; + WriteBuffer(Dummy, SizeOf(Dummy)); + Dummy := Integer(FOptions); + WriteBuffer(Dummy, SizeOf(Dummy)); + //PopupMenu is neither saved nor restored + Dummy := Ord(FStyle); + WriteBuffer(Dummy, SizeOf(Dummy)); + //TFont has no own save routine so we do it manually + with Font do + begin + Dummy := Color; + WriteBuffer(Dummy, SizeOf(Dummy)); + + //Need only to write one: size or height, I decided to write height. + Dummy := Height; + WriteBuffer(Dummy, SizeOf(Dummy)); + Tmp := UTF8Encode(Name); + Dummy := Length(Tmp); + WriteBuffer(Dummy, SizeOf(Dummy)); + WriteBuffer(PAnsiChar(Tmp)^, Dummy); + Dummy := Ord(Pitch); + WriteBuffer(Dummy, SizeOf(Dummy)); + Dummy := Byte(Style); + WriteBuffer(Dummy, SizeOf(Dummy)); + end; + + //Data introduced by stream version 1. + Dummy := FMainColumn; + WriteBuffer(Dummy, SizeOf(Dummy)); + Dummy := FSortColumn; + WriteBuffer(Dummy, SizeOf(Dummy)); + Dummy := Byte(FSortDirection); + WriteBuffer(Dummy, SizeOf(Dummy)); + + //Data introduced by stream version 5. + Dummy := Integer(ParentFont); + WriteBuffer(Dummy, SizeOf(Dummy)); + Dummy := Integer(FMaxHeight); + WriteBuffer(Dummy, SizeOf(Dummy)); + Dummy := Integer(FMinHeight); + WriteBuffer(Dummy, SizeOf(Dummy)); + Dummy := Integer(FDefaultHeight); + WriteBuffer(Dummy, SizeOf(Dummy)); + with FFixedAreaConstraints do + begin + Dummy := Integer(FMaxHeightPercent); + WriteBuffer(Dummy, SizeOf(Dummy)); + Dummy := Integer(FMaxWidthPercent); + WriteBuffer(Dummy, SizeOf(Dummy)); + Dummy := Integer(FMinHeightPercent); + WriteBuffer(Dummy, SizeOf(Dummy)); + Dummy := Integer(FMinWidthPercent); + WriteBuffer(Dummy, SizeOf(Dummy)); + end; + end; +end; + +{ TVTHeaderHelper } + +function TVTHeaderHelper.Tree : TBaseVirtualTreeCracker; +begin + Result := TBaseVirtualTreeCracker(Self.FOwner); +end; + + +//----------------- TVirtualTreeColumn --------------------------------------------------------------------------------- + +constructor TVirtualTreeColumn.Create(Collection : TCollection); + +begin + FMinWidth := 10; + FMaxWidth := 10000; + FImageIndex := - 1; + FMargin := 4; + FSpacing := cDefaultColumnSpacing; + 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; + FEditNextColumn := - 1; + + inherited Create(Collection); + + if Assigned(Owner) then + begin + FWidth := Owner.DefaultWidth; + FLastWidth := Owner.DefaultWidth; + FPosition := Owner.Count - 1; + end; +end; + +procedure TVirtualTreeColumn.SetCollection(Value : TCollection); +begin + inherited; + // Read parent bidi mode and color values as default values. + ParentBiDiModeChanged; + ParentColorChanged; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +destructor TVirtualTreeColumn.Destroy; + +var + I : Integer; + ai : TColumnIndex; + sc : TColumnIndex; + + //--------------- 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 + TreeViewControl.CancelEditNode; + IndexChanged(Index, - 1); + + AdjustColumnIndex(FHoverIndex); + AdjustColumnIndex(FDownIndex); + AdjustColumnIndex(FTrackIndex); + AdjustColumnIndex(FClickIndex); + + with Header do + begin + ai := AutoSizeIndex; + AdjustColumnIndex(ai); + InternalSetAutoSizeIndex(ai); + if Index = MainColumn then + begin + // If the current main column is about to be destroyed then we have to find a new main column. + InternalSetMainColumn(NoColumn); //SetColumn has side effects we want to avoid here. + for I := 0 to Count - 1 do + if I <> Index then + begin + InternalSetMainColumn(I); + Break; + end; + end; + sc := SortColumn; + AdjustColumnIndex(sc); + InternalSetSortColumn(sc); + end; + end; + end; + + inherited; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVirtualTreeColumn.GetCaptionAlignment : TAlignment; + +begin + if coUseCaptionAlignment in FOptions then + Result := FCaptionAlignment + else + Result := FAlignment; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVirtualTreeColumn.GetCaptionWidth : TDimension; +var + Theme : HTHEME; + AdvancedOwnerDraw : Boolean; + PaintInfo : THeaderPaintInfo; + RequestedElements : THeaderPaintElements; + + TextSize : TSize; + HeaderGlyphSize : TPoint; + UseText : Boolean; + R : TRect; +begin + AdvancedOwnerDraw := (hoOwnerDraw in Header.Options) and Assigned(TreeViewControl.OnAdvancedHeaderDraw) and Assigned(TreeViewControl.OnHeaderDrawQueryElements) and + not (csDesigning in TreeViewControl.ComponentState); + + PaintInfo.Column := Self; + PaintInfo.TargetCanvas := Owner.HeaderBitmap.Canvas; + + with PaintInfo, Column do + begin + ShowHeaderGlyph := (hoShowImages in Header.Options) and ((Assigned(Header.Images) and (FImageIndex > - 1)) or FCheckBox); + ShowSortGlyph := ((Header.SortColumn > - 1) and (Self = Owner.Items[Header.SortColumn])) and (hoShowSortGlyphs in Header.Options); + + // This path for text columns or advanced owner draw. + // See if the application wants to draw part of the header itself. + RequestedElements := []; + if AdvancedOwnerDraw then + begin + PaintInfo.Column := Self; + TreeViewControl.DoHeaderDrawQueryElements(PaintInfo, RequestedElements); + end; + end; + + UseText := Length(FText) > 0; + // If nothing is to show then don't waste time with useless preparation. + if not (UseText or PaintInfo.ShowHeaderGlyph or PaintInfo.ShowSortGlyph) then + Exit(0); + + // Calculate sizes of the involved items. + with Header do + begin + if PaintInfo.ShowHeaderGlyph then + if not FCheckBox then + begin + if Assigned(Images) then + HeaderGlyphSize := Point(Images.Width, Images.Height); + end + else + with Self.TreeViewControl do + begin + if Assigned(CheckImages) then + HeaderGlyphSize := Point(CheckImages.Width, CheckImages.Height); + end + else + HeaderGlyphSize := Point(0, 0); + if PaintInfo.ShowSortGlyph then + begin + if tsUseExplorerTheme in Self.TreeViewControl.TreeStates then + begin + R := Rect(0, 0, 100, 100); + Theme := OpenThemeData(Self.TreeViewControl.Handle, 'HEADER'); + GetThemePartSize(Theme, PaintInfo.TargetCanvas.Handle, HP_HEADERSORTARROW, HSAS_SORTEDUP, @R, TS_TRUE, PaintInfo.SortGlyphSize); + CloseThemeData(Theme); + end + else + begin + PaintInfo.SortGlyphSize.cx := Self.TreeViewControl.ScaledPixels(16); + PaintInfo.SortGlyphSize.cy := Self.TreeViewControl.ScaledPixels(4); + end; + end + else + begin + PaintInfo.SortGlyphSize.cx := 0; + PaintInfo.SortGlyphSize.cy := 0; + end; + end; + + if UseText then + begin + GetTextExtentPoint32W(PaintInfo.TargetCanvas.Handle, PWideChar(FText), Length(FText), TextSize); + Inc(TextSize.cx, 2); + end + else + begin + TextSize.cx := 0; + TextSize.cy := 0; + end; + + // if CalculateTextRect then + Result := TextSize.cx; + if PaintInfo.ShowHeaderGlyph then + if Layout in [blGlyphLeft, blGlyphRight] then + Inc(Result, HeaderGlyphSize.X + FSpacing) + else // if Layout in [ blGlyphTop, blGlyphBottom] then + Result := Max(Result, HeaderGlyphSize.X); + if PaintInfo.ShowSortGlyph then + Inc(Result, PaintInfo.SortGlyphSize.cx + FSpacing + 2); // without this +2, there is a slight movement of the sort glyph when expanding the column + +end; +//---------------------------------------------------------------------------------------------------------------------- + +function TVirtualTreeColumn.GetLeft : Integer; + +begin + Result := FLeft; + if [coVisible, coFixed] * FOptions <> [coVisible, coFixed] then + Dec(Result, TreeViewControl.EffectiveOffsetX); +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. + TreeViewControl.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. + TreeViewControl.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. + Header.Invalidate(Self); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumn.SetColor(const Value : TColor); + +begin + if FColor <> Value then + begin + FColor := Value; + Exclude(FOptions, coParentColor); + Exclude(FOptions, coStyleColor); // Issue #919 + Changed(False); + TreeViewControl.Invalidate; + end; +end; + +function TVirtualTreeColumn.GetEffectiveColor() : TColor; +// Returns the color that should effectively be used as background color for this +// column considering all flags in the TVirtualTreeColumn.Options property +begin + if (coParentColor in Options) or ((coStyleColor in Options) and TreeViewControl.VclStyleEnabled) then + Result := TreeViewControl.Colors.BackGroundColor + else + Result := Self.Color; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumn.SetCheckBox(Value : Boolean); + +begin + if Value <> FCheckBox then + begin + FCheckBox := Value; + if Value and (csDesigning in TreeViewControl.ComponentState) then + Header.Options := Header.Options + [hoShowImages]; + Changed(False); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumn.SetCheckState(Value : TCheckState); + +begin + if Value <> FCheckState then + begin + FCheckState := Value; + Changed(False); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumn.SetCheckType(Value : TCheckType); + +begin + if Value <> FCheckType then + begin + FCheckType := Value; + Changed(False); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumn.SetImageIndex(Value : TImageIndex); + +begin + if Value <> FImageIndex then + begin + FImageIndex := Value; + Changed(False); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumn.SetLayout(Value : TVTHeaderColumnLayout); + +begin + if FLayout <> Value then + begin + FLayout := Value; + Changed(False); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumn.SetMargin(Value : Integer); + +begin + // Compatibility setting for -1. + if Value < 0 then + Value := 4; + if FMargin <> Value then + begin + FMargin := Value; + Changed(False); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumn.SetMaxWidth(Value : Integer); + +begin + if Value < FMinWidth then + Value := FMinWidth; + FMaxWidth := Value; + SetWidth(FWidth); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumn.SetMinWidth(Value : Integer); + +begin + if Value < 0 then + Value := 0; + if Value > FMaxWidth then + Value := FMaxWidth; + FMinWidth := Value; + SetWidth(FWidth); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumn.SetOptions(Value : TVTColumnOptions); + +var + ToBeSet, + ToBeCleared : TVTColumnOptions; + VisibleChanged, + lParentColorSet : Boolean; +begin + if FOptions <> Value then + begin + ToBeCleared := FOptions - Value; + ToBeSet := Value - FOptions; + + FOptions := Value; + + VisibleChanged := coVisible in (ToBeSet + ToBeCleared); + lParentColorSet := coParentColor in ToBeSet; + + if coParentBidiMode in ToBeSet then + ParentBiDiModeChanged; + if lParentColorSet then + begin + Include(FOptions, coStyleColor); // Issue #919 + ParentColorChanged(); + end; + + if coAutoSpring in ToBeSet then + FSpringRest := 0; + + if coVisible in ToBeCleared then + Header.UpdateMainColumn(); // Fixes issue #946 + + if ((coFixed in ToBeSet) or (coFixed in ToBeCleared)) and (coVisible in FOptions) then + Header.RescaleHeader; + + Changed(False); + // Need to repaint and adjust the owner tree too. + if not (csLoading in TreeViewControl.ComponentState) and (VisibleChanged or lParentColorSet) and (Owner.UpdateCount = 0) and TreeViewControl.HandleAllocated then + begin + TreeViewControl.Invalidate(); + if VisibleChanged then + begin + TreeViewControl.DoColumnVisibilityChanged(Self.Index, coVisible in ToBeSet); + TreeViewControl.UpdateHorizontalScrollBar(False); + end; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumn.SetPosition(Value : TColumnPosition); + +var + Temp : TColumnIndex; + +begin + if (csLoading in TreeViewControl.ComponentState) or (Owner.UpdateCount > 0) 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; + TreeViewControl.CancelEditNode; + AdjustPosition(Self, Value); + Self.Changed(False); + + // Need to repaint. + with Self.Header do + begin + if (UpdateCount = 0) and TreeViewControl.HandleAllocated then + begin + Invalidate(Self); + TreeViewControl.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 : string); + +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 Header.States) then + if ([coVisible, coFixed] * FOptions = [coVisible, coFixed]) then + begin + with Header, FixedAreaConstraints, TreeView do + begin + TotalFixedMinWidth := 0; + TotalFixedMaxWidth := 0; + for I := 0 to Columns.Count - 1 do + if ([coVisible, coFixed] * Columns[I].Options = [coVisible, coFixed]) then + begin + Inc(TotalFixedMaxWidth, Columns[I].MaxWidth); + Inc(TotalFixedMinWidth, Columns[I].MinWidth); + end; + + if HandleAllocated then // Prevent premature creation of window handle, see issue #1073 + begin + // The percentage values have precedence over the pixel values. + If MaxWidthPercent > 0 then + TotalFixedMinWidth := Min((ClientWidth * MaxWidthPercent) div 100, TotalFixedMinWidth); + If MinWidthPercent > 0 then + TotalFixedMaxWidth := Max((ClientWidth * MinWidthPercent) div 100, TotalFixedMaxWidth); + + EffectiveMaxWidth := Min(TotalFixedMaxWidth - (Columns.GetVisibleFixedWidth - Self.FWidth), FMaxWidth); + EffectiveMinWidth := Max(TotalFixedMinWidth - (Columns.GetVisibleFixedWidth - Self.FWidth), FMinWidth); + Value := Min(Max(Value, EffectiveMinWidth), EffectiveMaxWidth); + + if MinWidthPercent > 0 then + Value := Max((ClientWidth * MinWidthPercent) div 100 - Columns.GetVisibleFixedWidth + Self.FWidth, Value); + if MaxWidthPercent > 0 then + Value := Min((ClientWidth * MaxWidthPercent) div 100 - Columns.GetVisibleFixedWidth + Self.FWidth, Value); + end;// if HandleAllocated + end; + end + else + Value := Min(Max(Value, FMinWidth), FMaxWidth); + + if FWidth <> Value then + begin + FLastWidth := FWidth; + if not (hsResizing in Header.States) then + FBonusPixel := False; + if not (hoAutoResize in Header.Options) or (Index <> Header.AutoSizeIndex) then + begin + FWidth := Value; + Owner.UpdatePositions; + end; + if not (csLoading in TreeViewControl.ComponentState) and (Owner.UpdateCount = 0) then + begin + if hoAutoResize in Header.Options then + Owner.AdjustAutoSize(Index); + TreeViewControl.DoColumnResize(Index); + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumn.ChangeScale(M, D : TDimension; isDpiChange : Boolean); +begin + FMinWidth := MulDiv(FMinWidth, M, D); + FMaxWidth := MulDiv(FMaxWidth, M, D); + FSpacing := MulDiv(FSpacing, M, D); + Self.Width := MulDiv(Self.Width, M, D); +end; + +procedure TVirtualTreeColumn.ComputeHeaderLayout(var PaintInfo : THeaderPaintInfo; DrawFormat : Cardinal; CalculateTextRect : Boolean = False); + +// The layout of a column header is determined by a lot of factors. This method takes them all into account and +// determines all necessary positions and bounds: +// - for the header text +// - the header glyph +// - the sort glyph + +var + TextSize : TSize; + TextPos, + ClientSize, + HeaderGlyphSize : TPoint; + CurrentAlignment : TAlignment; + MinLeft, + MaxRight, + TextSpacing : Integer; + UseText : Boolean; + R : TRect; + Theme : HTHEME; + +begin + UseText := Length(FText) > 0; + // If nothing is to show then don't waste time with useless preparation. + if not (UseText or PaintInfo.ShowHeaderGlyph or PaintInfo.ShowSortGlyph) then + Exit; + + CurrentAlignment := CaptionAlignment; + if FBiDiMode <> bdLeftToRight then + ChangeBiDiModeAlignment(CurrentAlignment); + + // Calculate sizes of the involved items. + ClientSize := Point(PaintInfo.PaintRectangle.Right - PaintInfo.PaintRectangle.Left, PaintInfo.PaintRectangle.Bottom - PaintInfo.PaintRectangle.Top); + with Owner, Header do + begin + if PaintInfo.ShowHeaderGlyph then + if not FCheckBox then + HeaderGlyphSize := Point(Images.Width, Images.Height) + else + with Self.TreeViewControl do + begin + if Assigned(CheckImages) then + HeaderGlyphSize := Point(CheckImages.Width, CheckImages.Height); + end + else + HeaderGlyphSize := Point(0, 0); + if PaintInfo.ShowSortGlyph then + begin + if tsUseExplorerTheme in Self.TreeViewControl.TreeStates then + begin + R := Rect(0, 0, 100, 100); + Theme := OpenThemeData(TreeViewControl.Handle, 'HEADER'); + GetThemePartSize(Theme, PaintInfo.TargetCanvas.Handle, HP_HEADERSORTARROW, HSAS_SORTEDUP, @R, TS_TRUE, PaintInfo.SortGlyphSize); + CloseThemeData(Theme); + end + else + begin + PaintInfo.SortGlyphSize.cx := Self.TreeViewControl.ScaledPixels(16); + PaintInfo.SortGlyphSize.cy := Self.TreeViewControl.ScaledPixels(4); + end; + + // In any case, the sort glyph is vertically centered. + PaintInfo.SortGlyphPos.Y := (ClientSize.Y - PaintInfo.SortGlyphSize.cy) div 2; + end + else + begin + PaintInfo.SortGlyphSize.cx := 0; + PaintInfo.SortGlyphSize.cy := 0; + end; + end; + + if UseText then + begin + if not (coWrapCaption in FOptions) then + begin + FCaptionText := FText; + GetTextExtentPoint32W(PaintInfo.TargetCanvas.Handle, PWideChar(FText), Length(FText), TextSize); + Inc(TextSize.cx, 2); + PaintInfo.TextRectangle := Rect(0, 0, TextSize.cx, TextSize.cy); + end + else + begin + R := PaintInfo.PaintRectangle; + if FCaptionText = '' then + FCaptionText := WrapString(PaintInfo.TargetCanvas.Handle, FText, R, DT_RTLREADING and DrawFormat <> 0, DrawFormat); + + GetStringDrawRect(PaintInfo.TargetCanvas.Handle, FCaptionText, R, DrawFormat); + TextSize.cx := PaintInfo.PaintRectangle.Right - PaintInfo.PaintRectangle.Left; + TextSize.cy := R.Bottom - R.Top; + PaintInfo.TextRectangle := 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 PaintInfo.ShowSortGlyph and not (UseText or PaintInfo.ShowHeaderGlyph) then + begin + // Center the sort glyph in the available area if nothing else is there. + PaintInfo.SortGlyphPos := Point((ClientSize.X - PaintInfo.SortGlyphSize.cx) div 2, (ClientSize.Y - PaintInfo.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 PaintInfo.ShowHeaderGlyph then + begin + PaintInfo.GlyphPos.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 + PaintInfo.GlyphPos.Y := (ClientSize.Y - HeaderGlyphSize.Y - TextSize.cy - TextSpacing) div 2; + TextPos.Y := PaintInfo.GlyphPos.Y + HeaderGlyphSize.Y + TextSpacing; + end + else + begin + TextPos.Y := (ClientSize.Y - HeaderGlyphSize.Y - TextSize.cy - TextSpacing) div 2; + PaintInfo.GlyphPos.Y := TextPos.Y + TextSize.cy + TextSpacing; + end; + end; + + // Each alignment needs special consideration. + case CurrentAlignment of + taLeftJustify : + begin + MinLeft := FMargin; + if PaintInfo.ShowSortGlyph and (FBiDiMode <> bdLeftToRight) then + begin + // In RTL context is the sort glyph placed on the left hand side. + PaintInfo.SortGlyphPos.X := MinLeft; + Inc(MinLeft, PaintInfo.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 PaintInfo.ShowHeaderGlyph then + begin + PaintInfo.GlyphPos.X := (ClientSize.X - HeaderGlyphSize.X) div 2; + if PaintInfo.GlyphPos.X < MinLeft then + PaintInfo.GlyphPos.X := MinLeft; + MinLeft := Max(TextPos.X + TextSize.cx + TextSpacing, PaintInfo.GlyphPos.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 PaintInfo.ShowHeaderGlyph and (Layout = blGlyphLeft) then + begin + PaintInfo.GlyphPos.X := MinLeft; + Inc(MinLeft, HeaderGlyphSize.X + FSpacing); + end; + TextPos.X := MinLeft; + Inc(MinLeft, TextSize.cx + TextSpacing); + if PaintInfo.ShowHeaderGlyph and (Layout = blGlyphRight) then + begin + PaintInfo.GlyphPos.X := MinLeft; + Inc(MinLeft, HeaderGlyphSize.X + FSpacing); + end; + end; + if PaintInfo.ShowSortGlyph and (FBiDiMode = bdLeftToRight) then + PaintInfo.SortGlyphPos.X := MinLeft; + end; + taCenter : + begin + if Layout in [blGlyphTop, blGlyphBottom] then + begin + PaintInfo.GlyphPos.X := (ClientSize.X - HeaderGlyphSize.X) div 2; + TextPos.X := (ClientSize.X - TextSize.cx) div 2; + if PaintInfo.ShowSortGlyph then + Dec(TextPos.X, PaintInfo.SortGlyphSize.cx div 2); + end + else + begin + MinLeft := (ClientSize.X - HeaderGlyphSize.X - TextSpacing - TextSize.cx) div 2; + if PaintInfo.ShowHeaderGlyph and (Layout = blGlyphLeft) then + begin + PaintInfo.GlyphPos.X := MinLeft; + Inc(MinLeft, HeaderGlyphSize.X + TextSpacing); + end; + TextPos.X := MinLeft; + Inc(MinLeft, TextSize.cx + TextSpacing); + if PaintInfo.ShowHeaderGlyph and (Layout = blGlyphRight) then + PaintInfo.GlyphPos.X := MinLeft; + end; + if PaintInfo.ShowHeaderGlyph then + begin + MinLeft := Min(PaintInfo.GlyphPos.X, TextPos.X); + MaxRight := Max(PaintInfo.GlyphPos.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 PaintInfo.ShowSortGlyph then + if FBiDiMode = bdLeftToRight then + begin + // Sort glyph on the right hand side. + PaintInfo.SortGlyphPos.X := MaxRight + FSpacing; + end + else + begin + // Sort glyph on the left hand side. + PaintInfo.SortGlyphPos.X := MinLeft - FSpacing - PaintInfo.SortGlyphSize.cx; + end; + end; + else + // taRightJustify + MaxRight := ClientSize.X - FMargin; + if PaintInfo.ShowSortGlyph and (FBiDiMode = bdLeftToRight) then + begin + // In LTR context is the sort glyph placed on the right hand side. + Dec(MaxRight, PaintInfo.SortGlyphSize.cx); + PaintInfo.SortGlyphPos.X := MaxRight; + Dec(MaxRight, FSpacing); + end; + if Layout in [blGlyphTop, blGlyphBottom] then + begin + TextPos.X := MaxRight - TextSize.cx; + if PaintInfo.ShowHeaderGlyph then + begin + PaintInfo.GlyphPos.X := (ClientSize.X - HeaderGlyphSize.X) div 2; + if PaintInfo.GlyphPos.X + HeaderGlyphSize.X + FSpacing > MaxRight then + PaintInfo.GlyphPos.X := MaxRight - HeaderGlyphSize.X - FSpacing; + MaxRight := Min(TextPos.X - TextSpacing, PaintInfo.GlyphPos.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 PaintInfo.ShowHeaderGlyph and (Layout = blGlyphRight) then + begin + PaintInfo.GlyphPos.X := MaxRight - HeaderGlyphSize.X; + MaxRight := PaintInfo.GlyphPos.X - FSpacing; + end; + TextPos.X := MaxRight - TextSize.cx; + MaxRight := TextPos.X - TextSpacing; + if PaintInfo.ShowHeaderGlyph and (Layout = blGlyphLeft) then + begin + PaintInfo.GlyphPos.X := MaxRight - HeaderGlyphSize.X; + MaxRight := PaintInfo.GlyphPos.X - FSpacing; + end; + end; + if PaintInfo.ShowSortGlyph and (FBiDiMode <> bdLeftToRight) then + PaintInfo.SortGlyphPos.X := MaxRight - PaintInfo.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 PaintInfo.ShowSortGlyph then + begin + if FBiDiMode = bdLeftToRight then + begin + // Sort glyph on the right hand side. + if PaintInfo.SortGlyphPos.X + PaintInfo.SortGlyphSize.cx > MaxRight then + PaintInfo.SortGlyphPos.X := MaxRight - PaintInfo.SortGlyphSize.cx; + MaxRight := PaintInfo.SortGlyphPos.X - FSpacing; + end; + + // Consider also the left side of the sort glyph regardless of the bidi mode. + if PaintInfo.SortGlyphPos.X < MinLeft then + PaintInfo.SortGlyphPos.X := MinLeft; + // Left border needs only adjustment if the sort glyph marks the left border. + if FBiDiMode <> bdLeftToRight then + MinLeft := PaintInfo.SortGlyphPos.X + PaintInfo.SortGlyphSize.cx + FSpacing; + + // Finally transform sort glyph to its actual position. + Inc(PaintInfo.SortGlyphPos.X, PaintInfo.PaintRectangle.Left); + Inc(PaintInfo.SortGlyphPos.Y, PaintInfo.PaintRectangle.Top); + end; + if PaintInfo.ShowHeaderGlyph then + begin + if PaintInfo.GlyphPos.X + HeaderGlyphSize.X > MaxRight then + PaintInfo.GlyphPos.X := MaxRight - HeaderGlyphSize.X; + if Layout = blGlyphRight then + MaxRight := PaintInfo.GlyphPos.X - FSpacing; + if PaintInfo.GlyphPos.X < MinLeft then + PaintInfo.GlyphPos.X := MinLeft; + if Layout = blGlyphLeft then + MinLeft := PaintInfo.GlyphPos.X + HeaderGlyphSize.X + FSpacing; + if FCheckBox and (Header.MainColumn = Self.Index) then + Dec(PaintInfo.GlyphPos.X, 2) + else + if Header.MainColumn <> Self.Index then + Dec(PaintInfo.GlyphPos.X, 2); + + // Finally transform header glyph to its actual position. + Inc(PaintInfo.GlyphPos.X, PaintInfo.PaintRectangle.Left); + Inc(PaintInfo.GlyphPos.Y, PaintInfo.PaintRectangle.Top); + end; + if UseText then + begin + if TextPos.X < MinLeft then + TextPos.X := MinLeft; + OffsetRect(PaintInfo.TextRectangle, TextPos.X, TextPos.Y); + if PaintInfo.TextRectangle.Right > MaxRight then + PaintInfo.TextRectangle.Right := MaxRight; + OffsetRect(PaintInfo.TextRectangle, PaintInfo.PaintRectangle.Left, PaintInfo.PaintRectangle.Top); + + if coWrapCaption in FOptions then + begin + // Wrap the column caption if necessary. + R := PaintInfo.TextRectangle; + FCaptionText := WrapString(PaintInfo.TargetCanvas.Handle, FText, R, DT_RTLREADING and DrawFormat <> 0, DrawFormat); + GetStringDrawRect(PaintInfo.TargetCanvas.Handle, FCaptionText, R, DrawFormat); + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumn.DefineProperties(Filer : TFiler); + +begin + inherited; + + // These properites are remains from non-Unicode Delphi versions, readers remain for backward compatibility. + Filer.DefineProperty('WideText', ReadText, nil, False); + Filer.DefineProperty('WideHint', ReadHint, nil, False); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumn.GetAbsoluteBounds(var Left, Right : Integer); + +// Returns the column's left and right bounds in header coordinates, that is, independant of the scrolling position. + +begin + Left := FLeft; + Right := FLeft + FWidth; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVirtualTreeColumn.GetDisplayName : string; + +// Returns the column text if it only contains ANSI characters, otherwise the column id is returned because the IDE +// still cannot handle Unicode strings. + +var + I : Integer; + +begin + // Check if the text of the column contains characters > 255 + I := 1; + while I <= Length(FText) do + begin + if Ord(FText[I]) > 255 then + Break; + Inc(I); + end; + + if I > Length(FText) then + Result := FText // implicit conversion + else + Result := Format('Column %d', [Index]); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVirtualTreeColumn.GetOwner : TVirtualTreeColumns; + +begin + Result := Collection as TVirtualTreeColumns; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumn.InternalSetWidth(const Value : TDimension); +begin + FWidth := Value; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumn.ReadText(Reader : TReader); + +begin + case Reader.NextValue of + vaLString, vaString : + SetText(Reader.ReadString); + else + SetText(Reader.ReadString); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumn.ReadHint(Reader : TReader); + +begin + case Reader.NextValue of + vaLString, vaString : + FHint := Reader.ReadString; + else + FHint := Reader.ReadString; + end; +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; + EditOptions := TVirtualTreeColumn(Source).EditOptions; + EditNextColumn := TVirtualTreeColumn(Source).EditNextColumn; + + // 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 := TreeViewControl.HeaderRect; + 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(PWideChar(S)^, 2 * Dummy); + Text := S; + ReadBuffer(Dummy, SizeOf(Dummy)); + SetLength(FHint, Dummy); + ReadBuffer(PWideChar(FHint)^, 2 * Dummy); + ReadBuffer(Dummy, SizeOf(Dummy)); + Width := Dummy; + ReadBuffer(Dummy, SizeOf(Dummy)); + MinWidth := Dummy; + ReadBuffer(Dummy, SizeOf(Dummy)); + MaxWidth := Dummy; + ReadBuffer(Dummy, SizeOf(Dummy)); + Style := TVirtualTreeColumnStyle(Dummy); + ReadBuffer(Dummy, SizeOf(Dummy)); + ImageIndex := Dummy; + ReadBuffer(Dummy, SizeOf(Dummy)); + Layout := TVTHeaderColumnLayout(Dummy); + ReadBuffer(Dummy, SizeOf(Dummy)); + Margin := Dummy; + ReadBuffer(Dummy, SizeOf(Dummy)); + Spacing := Dummy; + ReadBuffer(Dummy, SizeOf(Dummy)); + BiDiMode := TBiDiMode(Dummy); + + ReadBuffer(Dummy, SizeOf(Dummy)); + if Version >= 3 then + Options := TVTColumnOptions(Dummy); + + if Version > 0 then + begin + // Parts which have been introduced/changed with header stream version 1+. + ReadBuffer(Dummy, SizeOf(Dummy)); + Tag := Dummy; + ReadBuffer(Dummy, SizeOf(Dummy)); + Alignment := TAlignment(Dummy); + + if Version > 1 then + begin + ReadBuffer(Dummy, SizeOf(Dummy)); + Color := TColor(Dummy); + end; + + if Version > 5 then + begin + if coUseCaptionAlignment in FOptions then + begin + ReadBuffer(Dummy, SizeOf(Dummy)); + CaptionAlignment := TAlignment(Dummy); + end; + end; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumn.ParentBiDiModeChanged; + +var + Columns : TVirtualTreeColumns; + +begin + if coParentBidiMode in FOptions then + begin + Columns := GetOwner as TVirtualTreeColumns; + if Assigned(Columns) and (FBiDiMode <> TreeViewControl.BiDiMode) then + begin + FBiDiMode := TreeViewControl.BiDiMode; + Changed(False); + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumn.ParentColorChanged; + +var + Columns : TVirtualTreeColumns; + +begin + if coParentColor in FOptions then + begin + Columns := GetOwner as TVirtualTreeColumns; + if Assigned(Columns) and (FColor <> TreeViewControl.Color) then + begin + FColor := TreeViewControl.Color; + Changed(False); + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumn.RestoreLastWidth; + +begin + TVirtualTreeColumns(GetOwner).AnimatedResize(Index, FLastWidth); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumn.SaveToStream(const Stream : TStream); + +var + Dummy : Integer; + +begin + with Stream do + begin + Dummy := Length(FText); + WriteBuffer(Dummy, SizeOf(Dummy)); + WriteBuffer(PWideChar(FText)^, 2 * Dummy); + Dummy := Length(FHint); + WriteBuffer(Dummy, SizeOf(Dummy)); + WriteBuffer(PWideChar(FHint)^, 2 * Dummy); + WriteBuffer(FWidth, SizeOf(FWidth)); + WriteBuffer(FMinWidth, SizeOf(FMinWidth)); + WriteBuffer(FMaxWidth, SizeOf(FMaxWidth)); + Dummy := Ord(FStyle); + WriteBuffer(Dummy, SizeOf(Dummy)); + Dummy := FImageIndex; + WriteBuffer(Dummy, SizeOf(Dummy)); + Dummy := Ord(FLayout); + WriteBuffer(Dummy, SizeOf(Dummy)); + WriteBuffer(FMargin, SizeOf(FMargin)); + WriteBuffer(FSpacing, SizeOf(FSpacing)); + Dummy := Ord(FBiDiMode); + WriteBuffer(Dummy, SizeOf(Dummy)); + Dummy := Integer(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 := Self.TreeViewControl.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; + Self.FColumnPopupMenu := nil; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +destructor TVirtualTreeColumns.Destroy; + +begin + FreeAndNil(FColumnPopupMenu); + FreeAndNil(FHeaderBitmap); + inherited; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVirtualTreeColumns.GetCount : Integer; + +begin + Result := inherited Count; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVirtualTreeColumns.GetItem(Index : TColumnIndex) : TVirtualTreeColumn; + +begin + Result := TVirtualTreeColumn(inherited GetItem(Index)); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVirtualTreeColumns.GetNewIndex(P : TPoint; var OldIndex : TColumnIndex) : Boolean; + +var + NewIndex : Integer; + +begin + Result := False; + // convert to local coordinates + Inc(P.Y, Header.Height); + NewIndex := ColumnFromPosition(P); + if NewIndex <> OldIndex then + begin + if OldIndex > NoColumn then + Header.Invalidate(Items[OldIndex], False, True); + OldIndex := NewIndex; + if OldIndex > NoColumn then + Header.Invalidate(Items[OldIndex], False, True); + 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; + +function TVirtualTreeColumns.StyleServices(AControl : TControl) : TCustomStyleServices; +begin + if AControl = nil then + AControl := TreeView; + Result := VTStyleServices(AControl); +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 := Header.AutoSizeIndex; + if (AutoIndex < 0) or (AutoIndex >= Count) then + AutoIndex := Count - 1; + + if AutoIndex >= 0 then + begin + with 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].Options) 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 TreeViewControl.ComponentState; + if not WasUpdating then + TreeViewControl.Updating(); // Fixes #398 + try + TreeViewControl.DoColumnResize(AutoIndex); + finally + if not WasUpdating then + TreeViewControl.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, Header.Height); + Result := ColumnFromPosition(P); + if (Result > NoColumn) and (Result <> FDownIndex) and (coAllowClick in Items[Result].Options) and + (coEnabled in Items[Result].Options) then + begin + if FDownIndex > NoColumn then + Header.Invalidate(Items[FDownIndex]); + FDownIndex := Result; + FCheckBoxHit := Items[Result].HasImage and PtInRect(Items[Result].ImageRect, P) and Items[Result].CheckBox; + Header.Invalidate(Items[FDownIndex]); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVirtualTreeColumns.AdjustHoverColumn(P : TPoint) : Boolean; + +// Determines the new hover column index and returns True if the index actually changed else False. + +begin + Result := GetNewIndex(P, FHoverIndex); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumns.AdjustPosition(Column : TVirtualTreeColumn; Position : Cardinal); + +// Reorders the column position array so that the given column gets the given position. + +var + OldPosition : Cardinal; + +begin + OldPosition := Column.Position; + if OldPosition <> Position then + begin + if OldPosition < Position then + begin + // column will be moved up so move down other entries + Move(FPositionToIndex[OldPosition + 1], FPositionToIndex[OldPosition], (Position - OldPosition) * SizeOf(Cardinal)); + end + else + begin + // column will be moved down so move up other entries + Move(FPositionToIndex[Position], FPositionToIndex[Position + 1], (OldPosition - Position) * SizeOf(Cardinal)); + end; + FPositionToIndex[Position] := Column.Index; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVirtualTreeColumns.CanSplitterResize(P : TPoint; Column : TColumnIndex) : Boolean; + +begin + Result := (Column > NoColumn) and ([coResizable, coVisible] * Items[Column].Options = [coResizable, coVisible]); + DoCanSplitterResize(P, Column, Result); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumns.DoCanSplitterResize(P : TPoint; Column : TColumnIndex; var Allowed : Boolean); + +begin + if Assigned(TreeViewControl.OnCanSplitterResizeColumn) then + TreeViewControl.OnCanSplitterResizeColumn(Header, P, Column, Allowed); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumns.DrawButtonText(DC : HDC; Caption : string; Bounds : TRect; Enabled, Hot : Boolean; + DrawFormat : Cardinal; WrapCaption : Boolean); + +var + TextSpace : Integer; + Size : TSize; + +begin + if not WrapCaption then + begin + // Do we need to shorten the caption due to limited space? + GetTextExtentPoint32W(DC, PWideChar(Caption), Length(Caption), Size); + TextSpace := Bounds.Right - Bounds.Left; + if TextSpace < Size.cx then + Caption := ShortenString(DC, Caption, TextSpace); + end; + + SetBkMode(DC, TRANSPARENT); + if not Enabled then + if TreeViewControl.VclStyleEnabled then + begin + SetTextColor(DC, ColorToRGB(TreeViewControl.Colors.HeaderFontColor)); + WinApi.Windows.DrawTextW(DC, PWideChar(Caption), Length(Caption), Bounds, DrawFormat); + end + else + begin + OffsetRect(Bounds, 1, 1); + SetTextColor(DC, ColorToRGB(clBtnHighlight)); + WinApi.Windows.DrawTextW(DC, PWideChar(Caption), Length(Caption), Bounds, DrawFormat); + OffsetRect(Bounds, - 1, - 1); + SetTextColor(DC, ColorToRGB(clBtnShadow)); + WinApi.Windows.DrawTextW(DC, PWideChar(Caption), Length(Caption), Bounds, DrawFormat); + end + else + begin + if Hot then + SetTextColor(DC, ColorToRGB(TreeViewControl.Colors.HeaderHotColor)) + else + SetTextColor(DC, ColorToRGB(TreeViewControl.Colors.HeaderFontColor)); + WinApi.Windows.DrawTextW(DC, PWideChar(Caption), Length(Caption), Bounds, DrawFormat); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumns.FixPositions; + +// Fixes column positions after loading from DFM or Bidi mode change. + +var + I : Integer; + +begin + for I := 0 to Count - 1 do + FPositionToIndex[Items[I].Position] := I; + + FNeedPositionsFix := False; + UpdatePositions(True); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVirtualTreeColumns.GetColumnAndBounds(P : TPoint; var ColumnLeft, ColumnRight : Integer; + Relative : Boolean = True) : Integer; + +// Returns the column where the mouse is currently in as well as the left and right bound of +// this column (Left and Right are undetermined if no column is involved). + +var + I : Integer; + +begin + Result := InvalidColumn; + if Relative and (P.X >= Header.Columns.GetVisibleFixedWidth) then + ColumnLeft := - TreeViewControl.EffectiveOffsetX + else + ColumnLeft := 0; + + if TreeViewControl.UseRightToLeftAlignment then + Inc(ColumnLeft, TreeViewControl.ComputeRTLOffset(True)); + + for I := 0 to Count - 1 do + with Items[FPositionToIndex[I]] do + if coVisible in FOptions then + begin + ColumnRight := ColumnLeft + FWidth; + + //fix: in right to left alignment, X can be in the + //area on the left of first column which is OUT. + if (P.X < ColumnLeft) and (I = 0) then + begin + Result := InvalidColumn; + Exit; + end; + if P.X < ColumnRight then + begin + Result := FPositionToIndex[I]; + Exit; + end; + ColumnLeft := ColumnRight; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVirtualTreeColumns.GetOwner : TPersistent; + +begin + Result := FHeader; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVirtualTreeColumns.HandleClick(P : TPoint; Button : TMouseButton; Force, DblClick : Boolean) : 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). +// Returns true if the click was handled, False otherwise. + +var + HitInfo : TVTHeaderHitInfo; + NewClickIndex : Integer; + Menu : TPopupMenu; +begin + Result := False; + if (csDesigning in TreeViewControl.ComponentState) then + Exit; + // Convert vertical position to local coordinates. + Inc(P.Y, Header.Height); + NewClickIndex := ColumnFromPosition(P); + with HitInfo do + begin + X := P.X; + Y := P.Y; + Shift := Header.GetShiftState; + if DblClick then + Shift := Shift + [ssDouble]; + end; + HitInfo.Button := Button; + + if (NewClickIndex > NoColumn) and (coAllowClick in Items[NewClickIndex].Options) and + ((NewClickIndex = FDownIndex) or Force) then + begin + FClickIndex := NewClickIndex; + HitInfo.Column := NewClickIndex; + HitInfo.HitPosition := [hhiOnColumn]; + + if Items[NewClickIndex].HasImage and PtInRect(Items[NewClickIndex].ImageRect, P) then + begin + Include(HitInfo.HitPosition, hhiOnIcon); + if Items[NewClickIndex].CheckBox then + begin + if Button = mbLeft then + TreeViewControl.UpdateColumnCheckState(Items[NewClickIndex]); + Include(HitInfo.HitPosition, hhiOnCheckbox); + end; + end; + end + else + begin + FClickIndex := NoColumn; + HitInfo.Column := NoColumn; + HitInfo.HitPosition := [hhiNoWhere]; + end; + + if DblClick then + TreeViewControl.DoHeaderDblClick(HitInfo) + else + begin + if (hoHeaderClickAutoSort in Header.Options) and (HitInfo.Button = mbLeft) 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.DoSetSortColumn(HitInfo.Column, Self[HitInfo.Column].DefaultSortDirection); + end//if + else + begin + // toggle sort direction + if Header.SortDirection = sdDescending then + Header.SortDirection := sdAscending + else + Header.SortDirection := sdDescending; + end; //else + Result := True; + end; //if + + if (Button = mbRight) then + begin + Dec(P.Y, Header.Height); // popup menus at actual clicked point + FreeAndNil(FColumnPopupMenu); // Attention: Do not free the TVTHeaderPopupMenu at the end of this method, otherwise the clikc events of the menu item will not be fired. + Self.FDownIndex := NoColumn; + Self.FTrackIndex := NoColumn; + Self.FCheckBoxHit := False; + Menu := Header.DoGetPopupMenu(Self.ColumnFromPosition(Point(P.X, P.Y + Integer(TreeViewControl.Height))), P); + if Assigned(Menu) then + begin + TreeViewControl.StopTimer(ScrollTimer); + TreeViewControl.StopTimer(HeaderTimer); + Header.Columns.SetHoverIndex(NoColumn); + TreeViewControl.DoStateChange([], [tsScrollPending, tsScrolling]); + + Menu.PopupComponent := TreeView; + With TreeViewControl.ClientToScreen(P) do + Menu.Popup(X, Y); + Result := True; + end + else if (hoAutoColumnPopupMenu in Header.Options) then + begin + FColumnPopupMenu := TVTHeaderPopupMenu.Create(TreeView); + TVTHeaderPopupMenu(FColumnPopupMenu).OnAddHeaderPopupItem := HeaderPopupMenuAddHeaderPopupItem; + FColumnPopupMenu.PopupComponent := TreeView; + if (hoDblClickResize in Header.Options) and ((TreeViewControl.ChildCount[nil] > 0) or (hoAutoResizeInclCaption in Header.Options)) then + TVTHeaderPopupMenu(FColumnPopupMenu).Options := TVTHeaderPopupMenu(FColumnPopupMenu).Options + [poResizeToFitItem] + else + TVTHeaderPopupMenu(FColumnPopupMenu).Options := TVTHeaderPopupMenu(FColumnPopupMenu).Options - [poResizeToFitItem]; + With TreeViewControl.ClientToScreen(P) do + FColumnPopupMenu.Popup(X, Y); + Result := True; + end; // if hoAutoColumnPopupMenu + end; //if mbRight + TreeViewControl.DoHeaderClick(HitInfo); + end; //else (not DblClick) + + if not (hhiNoWhere in HitInfo.HitPosition) then + Header.Invalidate(Items[NewClickIndex]); + if (FClickIndex > NoColumn) and (FClickIndex <> NewClickIndex) then + Header.Invalidate(Items[FClickIndex]); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumns.HeaderPopupMenuAddHeaderPopupItem(const Sender : TObject; const Column : TColumnIndex; var Cmd : TAddPopupItemType); +begin + TBaseVirtualTreeCracker(Sender).DoHeaderAddPopupItem(Column, Cmd); +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 : System.Classes.TCollectionNotification); +var + I : Integer; + lRemovedPosition: TColumnPosition; +begin + if Action in [cnDeleting] then + begin + lRemovedPosition := TVirtualTreeColumn(Item).Position; + // Adjust all positions larger than the deleted column's position. Fixes #959, #1049 + for I := Count - 1 downto 0 do + begin + if Items[I].Position > lRemovedPosition then + Items[I].Position := Items[I].Position - 1; + end; //for I + + with TreeViewControl do + if not (csLoading in ComponentState) and (FocusedColumn = Item.Index) then + InternalSetFocusedColumn(NoColumn); //bypass side effects in SetFocusedColumn + end; // if cnDeleting +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.SetHoverIndex(Index : TColumnIndex); +begin + FHoverIndex := index; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumns.EndUpdate; +begin + InitializePositionArray(); + FixPositions(); // Accept the cuurent order. See issue #753 + inherited; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumns.Update(Item : TCollectionItem); + +begin + // This is the only place which gets notified when a new column has been added or removed + // and we need this event to adjust the column position array. + InitializePositionArray; + if csLoading in TreeViewControl.ComponentState then + FNeedPositionsFix := True + else + UpdatePositions; + + // The first column which is created is by definition also the main column. + if (Count > 0) and (Header.MainColumn < 0) then + Header.MainColumn := 0; + + if not (csLoading in TreeViewControl.ComponentState) and not (hsLoading in Header.States) then + begin + with Header do + begin + if hoAutoResize in Options then + AdjustAutoSize(InvalidColumn); + if Assigned(Item) then + Invalidate(Item as TVirtualTreeColumn) + else + if Self.TreeViewControl.HandleAllocated then + begin + Self.TreeViewControl.UpdateHorizontalScrollBar(False); + Invalidate(nil); + TreeViewControl.Invalidate; + end; + + if not (Self.TreeViewControl.IsUpdating) 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. + Self.TreeViewControl.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 (csDestroying in TreeViewControl.ComponentState) and 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; + TreeViewControl.UpdateHorizontalScrollBar(False); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVirtualTreeColumns.Add : TVirtualTreeColumn; + +begin + Assert(GetCurrentThreadId = MainThreadId, 'UI controls may only be changed in UI thread.'); + Result := TVirtualTreeColumn(inherited Add); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumns.AnimatedResize(Column : TColumnIndex; NewWidth : Integer); + +// Resizes the given column animated by scrolling the window DC. + +var + OldWidth : Integer; + DC : HDC; + I, + Steps, + DX : Integer; + HeaderScrollRect, + ScrollRect, + R : TRect; + + NewBrush, + LastBrush : HBRUSH; + +begin + if not IsValidColumn(Column) then + Exit; // Just in case. + + // Make sure the width constrains are considered. + if NewWidth < Items[Column].MinWidth then + NewWidth := Items[Column].MinWidth; + if NewWidth > Items[Column].MaxWidth then + NewWidth := Items[Column].MaxWidth; + + OldWidth := Items[Column].Width; + // Nothing to do if the width is the same. + if OldWidth <> NewWidth then + begin + if not ((hoDisableAnimatedResize in Header.Options) or + (coDisableAnimatedResize in Items[Column].Options)) then + begin + DC := GetWindowDC(TreeViewControl.Handle); + with TreeViewControl 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 := HeaderRect; + ScrollRect := HeaderScrollRect; + // Exclude the header itself from scrolling. + ScrollRect.Top := ScrollRect.Bottom; + ScrollRect.Bottom := ScrollRect.Top + ClientHeight; + ScrollRect.Right := ScrollRect.Left + ClientWidth; + with Items[Column] do + Inc(ScrollRect.Left, FLeft + FWidth); + HeaderScrollRect.Left := ScrollRect.Left; + HeaderScrollRect.Right := ScrollRect.Right; + + // When the new width is larger then avoid artefacts on the left hand side + // by deleting a small stripe + if NewWidth > OldWidth then + begin + R := ScrollRect; + NewBrush := CreateSolidBrush(ColorToRGB(Color)); + LastBrush := SelectObject(DC, NewBrush); + R.Right := R.Left + DX; + FillRect(DC, R, NewBrush); + SelectObject(DC, LastBrush); + DeleteObject(NewBrush); + end + else + begin + Inc(HeaderScrollRect.Left, DX); + Inc(ScrollRect.Left, DX); + end; + + for I := 0 to Steps - 1 do + begin + ScrollDC(DC, DX, 0, HeaderScrollRect, HeaderScrollRect, 0, nil); + Inc(HeaderScrollRect.Left, DX); + ScrollDC(DC, DX, 0, ScrollRect, ScrollRect, 0, nil); + Inc(ScrollRect.Left, DX); + Sleep(1); + end; + finally + ReleaseDC(Handle, DC); + end; + end; + Items[Column].Width := NewWidth; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumns.Assign(Source : TPersistent); + +begin + // Let the collection class assign the items. + inherited; + + if Source is TVirtualTreeColumns then + begin + // Copying the position array is the only needed task here. + FPositionToIndex := Copy(TVirtualTreeColumns(Source).FPositionToIndex, 0, MaxInt); + + // Make sure the left edges are correct after assignment. + FNeedPositionsFix := False; + UpdatePositions(True); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumns.Clear; + +begin + FClearing := True; + try + TreeViewControl.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 States) then + begin + InternalSetAutoSizeIndex(NoColumn); //bypass side effects in SetAutoSizeColumn + MainColumn := NoColumn; + InternalSetSortColumn(NoColumn); //bypass side effects in SetSortColumn + end; + + with TreeViewControl do + if not (csLoading in ComponentState) then + InternalSetFocusedColumn(NoColumn); //bypass side effects in SetFocusedColumn + + inherited Clear; + finally + FClearing := False; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVirtualTreeColumns.ColumnFromPosition(P : TPoint; Relative : Boolean = True) : TColumnIndex; + +// Determines the current column based on the position passed in P. + +var + I, Sum : Integer; + +begin + Result := InvalidColumn; + + // The position must be within the header area, but we extend the vertical bounds to the entire treeview area. + if (P.X >= 0) and (P.Y >= 0) and (P.Y <= TreeViewControl.Height) then + with FHeader, TreeViewControl do + begin + if Relative and (P.X >= GetVisibleFixedWidth) then + Sum := - EffectiveOffsetX + else + Sum := 0; + + if UseRightToLeftAlignment then + Inc(Sum, ComputeRTLOffset(True)); + + for I := 0 to Count - 1 do + if coVisible in Items[FPositionToIndex[I]].Options then + begin + Inc(Sum, Items[FPositionToIndex[I]].Width); + if P.X < Sum then + begin + Result := FPositionToIndex[I]; + Break; + end; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVirtualTreeColumns.ColumnFromPosition(PositionIndex : TColumnPosition) : TColumnIndex; + +// Returns the index of the column at the given position. + +begin + if Integer(PositionIndex) < Length(FPositionToIndex) then + Result := FPositionToIndex[PositionIndex] + else + Result := NoColumn; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVirtualTreeColumns.Equals(OtherColumnsObj : TObject) : Boolean; + +// Compares itself with the given set of columns and returns True if all published properties are the same +// (including column order), otherwise False is returned. + +var + I : Integer; + OtherColumns : TVirtualTreeColumns; + +begin + if not (OtherColumnsObj is TVirtualTreeColumns) then + begin + Result := False; + Exit; + end; + + OtherColumns := TVirtualTreeColumns(OtherColumnsObj); + + // Same number of columns? + Result := OtherColumns.Count = Count; + if Result then + begin + // Same order of columns? + Result := CompareMem(Pointer(FPositionToIndex), Pointer(OtherColumns.FPositionToIndex), + Length(FPositionToIndex) * SizeOf(TColumnIndex)); + if Result then + begin + for I := 0 to Count - 1 do + if not Items[I].Equals(OtherColumns[I]) then + begin + Result := False; + Break; + end; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumns.GetColumnBounds(Column : TColumnIndex; var Left, Right : Integer); + +// Returns the left and right bound of the given column. If Column is NoColumn then the entire client width is returned. + +begin + if Column <= NoColumn then + begin + Left := 0; + Right := TreeViewControl.ClientWidth; + end + else + begin + Left := Items[Column].Left; + Right := Left + Items[Column].Width; + if TreeViewControl.UseRightToLeftAlignment then + begin + Inc(Left, TreeViewControl.ComputeRTLOffset(True)); + Inc(Right, TreeViewControl.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 Header.Columns.Count - 1 do + begin + if ([coVisible, coFixed] * Header.Columns[I].Options = [coVisible]) then + begin + Inc(Result, Header.Columns[I].Width); + Inc(ScrollColumnCount); + end; + end; + + if ScrollColumnCount > 0 then // use average width + Result := Round(Result / ScrollColumnCount) + else // use indent + Result := Integer(TreeViewControl.Indent); + +end; + +function TVirtualTreeColumns.GetTreeView: TCustomControl; +begin + Result := TBaseVirtualTreeCracker(Header.GetOwner); +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; + if (UpdateCount > 0) or (csLoading in TreeViewControl.ComponentState) then + Exit; // See issue #760 + for I := 0 to Count - 1 do + if (coVisible in Items[FPositionToIndex[I]].Options) and + ((not ConsiderAllowFocus) or + (coAllowFocus in Items[FPositionToIndex[I]].Options) + ) 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; + if (UpdateCount > 0) or (csLoading in TreeViewControl.ComponentState) then + Exit; // See issue #760 + for I := Count - 1 downto 0 do + if (coVisible in Items[FPositionToIndex[I]].Options) and + ((not ConsiderAllowFocus) or + (coAllowFocus in Items[FPositionToIndex[I]].Options) + ) 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].Options) and + ((not ConsiderAllowFocus) or + (coAllowFocus in Items[Result].Options) + ) + ); +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].Options) and + ((not ConsiderAllowFocus) or + (coAllowFocus in Items[Result].Options) + ) + ); +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]].Options then + begin + Result[Counter] := Items[FPositionToIndex[I]]; + Inc(Counter); + end; + // Set result length to actual visible count. + SetLength(Result, Counter); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVirtualTreeColumns.GetVisibleFixedWidth : Integer; + +// Determines the horizontal space all visible and fixed columns occupy. + +var + I : Integer; + +begin + Result := 0; + for I := 0 to Count - 1 do + begin + if Items[I].Options * [coVisible, coFixed] = [coVisible, coFixed] then + Inc(Result, Items[I].Width); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVirtualTreeColumns.IsValidColumn(Column : TColumnIndex) : Boolean; + +// Determines whether the given column is valid or not, that is, whether it is one of the current columns. + +begin + Result := (Column > NoColumn) and (Column < Count); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumns.LoadFromStream(const Stream : TStream; Version : Integer); + +var + I, + ItemCount : Integer; + +begin + Clear; + Stream.ReadBuffer(ItemCount, SizeOf(ItemCount)); + // number of columns + if ItemCount > 0 then + begin + BeginUpdate; + try + for I := 0 to ItemCount - 1 do + Add.LoadFromStream(Stream, Version); + SetLength(FPositionToIndex, ItemCount); + Stream.ReadBuffer(FPositionToIndex[0], ItemCount * SizeOf(TColumnIndex)); + UpdatePositions(True); + finally + EndUpdate; + end; + end; + + // Data introduced with header stream version 5 + if Version > 4 then + Stream.ReadBuffer(FDefaultWidth, SizeOf(FDefaultWidth)); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumns.PaintHeader(DC : HDC; R : TRect; HOffset : Integer); + +// Backward compatible header paint method. This method takes care of visually moving floating columns + +var + VisibleFixedWidth : Integer; + RTLOffset : Integer; + + procedure PaintFixedArea; + + begin + if VisibleFixedWidth > 0 then + PaintHeader(FHeaderBitmap.Canvas, + Rect(0, 0, Min(R.Right, VisibleFixedWidth), R.Bottom - R.Top), + Point(R.Left, R.Top), RTLOffset); + end; + +begin + // Adjust size of the header bitmap + FHeaderBitmap.SetSize(Max(TreeViewControl.HeaderRect.Right, R.Right - R.Left), TreeViewControl.HeaderRect.Bottom); + + VisibleFixedWidth := GetVisibleFixedWidth; + + // Consider right-to-left directionality. + if TreeViewControl.UseRightToLeftAlignment then + RTLOffset := TreeViewControl.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. + BitBlt(DC, R.Left, R.Top, R.Right - R.Left, R.Bottom - R.Top, FHeaderBitmap.Canvas.Handle, R.Left, R.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. + +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 Header.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; + Theme : HTHEME; + begin + BackgroundRect := Rect(Target.X, Target.Y, Target.X + R.Right - R.Left, Target.Y + Header.Height); + + with TargetCanvas do + begin + if hpeBackground in RequestedElements then + begin + PaintInfo.PaintRectangle := BackgroundRect; + TreeViewControl.DoAdvancedHeaderDraw(PaintInfo, [hpeBackground]); + end + else + begin + if (TreeViewControl.VclStyleEnabled and (seClient in TreeViewControl.StyleElements)) then + begin + Details := StyleServices.GetElementDetails(thHeaderItemRightNormal); + StyleServices.DrawElement(Handle, Details, BackgroundRect, @BackgroundRect {$IF CompilerVersion >= 34}, TreeViewControl.FCurrentPPI{$IFEND}); + end + else + if tsUseThemes in TreeViewControl.TreeStates then + begin + Theme := OpenThemeData(TreeViewControl.Handle, 'HEADER'); + DrawThemeBackground(Theme, Handle, HP_HEADERITEM, HIS_NORMAL, BackgroundRect, nil); + CloseThemeData(Theme); + end + else + begin + Brush.Color := Header.Background; + 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 + SavedDC : Integer; + ColCaptionText : string; + ColImageInfo : TVTImageInfo; + Glyph : TThemedHeader; + Details : TThemedElementDetails; + WrapCaption : Boolean; + DrawFormat : Cardinal; + Pos : TRect; + DrawHot : Boolean; + ImageWidth : Integer; + Theme : HTHEME; + IdState : Integer; + begin + ColImageInfo.Ghosted := False; + PaintInfo.Column := Items[AColumn]; + with PaintInfo, Column do + begin + IsHoverIndex := (AColumn = FHoverIndex) and (hoHotTrack in Header.Options) and (coEnabled in Options); + 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; + + //Fix for issue 643 + //Do not show the left drop mark if the position to drop is just preceding the target which means + //the dragged column will stay where it is + if (DropMark = dmmLeft) and (Items[FDragIndex].Position = TColumnPosition(Max(Integer(Items[FDropTarget].Position) - 1, 0))) + then + DropMark := dmmNone + else + //Do not show the right drop mark if the position to drop is just following the target which means + //the dragged column will stay where it is + if (DropMark = dmmRight) and (Items[FDragIndex].Position = Items[FDropTarget].Position + 1) + then + DropMark := dmmNone; + + IsEnabled := (coEnabled in FOptions) and (TreeViewControl.Enabled); + ShowHeaderGlyph := (hoShowImages in Header.Options) and ((Assigned(Images) and (FImageIndex > - 1)) or FCheckBox); + ShowSortGlyph := (AColumn = Header.SortColumn) and (hoShowSortGlyphs in Header.Options); + 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]; + TreeViewControl.DoHeaderDrawQueryElements(PaintInfo, RequestedElements); + end; + + if ShowRightBorder or (AColumn < Count - 1) then + RightBorderFlag := BF_RIGHT + else + RightBorderFlag := 0; + + if hpeBackground in RequestedElements then + TreeViewControl.DoAdvancedHeaderDraw(PaintInfo, [hpeBackground]) + else + begin + if TreeViewControl.VclStyleEnabled and (seClient in TreeViewControl.StyleElements) 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{$IF CompilerVersion >= 34}, TreeViewControl.CurrentPPI{$IFEND}); + end + else + begin + if tsUseThemes in TreeViewControl.TreeStates then + begin + Theme := OpenThemeData(TreeViewControl.Handle, 'HEADER'); + if IsDownIndex then + IdState := HIS_PRESSED + else + if IsHoverIndex then + IdState := HIS_HOT + else + IdState := HIS_NORMAL; + DrawThemeBackground(Theme, TargetCanvas.Handle, HP_HEADERITEM, IdState, PaintRectangle, nil); + CloseThemeData(Theme); + end + else + if IsDownIndex then + DrawEdge(TargetCanvas.Handle, PaintRectangle, PressedButtonStyle, PressedButtonFlags) + else + // Plates have the special case of raising on mouse over. + if (Header.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(PaintInfo, 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, hpeOverlay]; + + // 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 TreeViewControl do + begin + ColImageInfo.Images := CheckImages; + ColImageInfo.Index := GetCheckImage(nil, FCheckType, FCheckState, IsEnabled); + ColImageInfo.XPos := GlyphPos.X; + ColImageInfo.YPos := GlyphPos.Y; + PaintCheckImage(TargetCanvas, ColImageInfo, False); + end; + end; + + FHasImage := True; + FImageRect.Left := GlyphPos.X; + FImageRect.Top := GlyphPos.Y; + FImageRect.Right := FImageRect.Left + ColImageInfo.Images.Width; + FImageRect.Bottom := FImageRect.Top + ColImageInfo.Images.Height; + end; + + // caption + if WrapCaption then + ColCaptionText := FCaptionText + else + ColCaptionText := Text; + if IsHoverIndex and TreeViewControl.VclStyleEnabled then + DrawHot := True + else + DrawHot := (IsHoverIndex and (hoHotTrack in Header.Options) and not (tsUseThemes in TreeViewControl.TreeStates)); + 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 TreeViewControl.TreeStates then + begin + Pos.TopLeft := SortGlyphPos; + Pos.Right := Pos.Left + SortGlyphSize.cx; + Pos.Bottom := Pos.Top + SortGlyphSize.cy; + if Header.SortDirection = sdAscending then + Glyph := thHeaderSortArrowSortedUp + else + Glyph := thHeaderSortArrowSortedDown; + Details := StyleServices.GetElementDetails(Glyph); + if not StyleServices.DrawElement(TargetCanvas.Handle, Details, Pos, @Pos {$IF CompilerVersion >= 34}, TreeViewControl.CurrentPPI {$IFEND}) then + PaintInfo.DrawSortArrow(Header.SortDirection); + end + else + begin + PaintInfo.DrawSortArrow(Header.SortDirection); + 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 + PaintInfo.DrawDropMark(); + end; + + if ActualElements <> [] then + begin + SavedDC := SaveDC(TargetCanvas.Handle); + TreeViewControl.DoAdvancedHeaderDraw(PaintInfo, ActualElements); + RestoreDC(TargetCanvas.Handle, SavedDC); + end; + end + else // Let application draw the header. + TreeViewControl.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 Header.Options) and Assigned(TreeViewControl.OnAdvancedHeaderDraw) and + Assigned(TreeViewControl.OnHeaderDrawQueryElements) and not (csDesigning in TreeViewControl.ComponentState); + OwnerDraw := (hoOwnerDraw in Header.Options) and Assigned(TreeViewControl.OnHeaderDraw) and + not (csDesigning in TreeViewControl.ComponentState) and not AdvancedOwnerDraw; + + ZeroMemory(@PaintInfo, SizeOf(PaintInfo)); + PaintInfo.TargetCanvas := TargetCanvas; + + with PaintInfo, TargetCanvas do + begin + // Use shortcuts for the images and the font. + Images := Header.Images; + Font := Header.Font; + + 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; + TreeViewControl.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 + //Fixes issues #544, #427 -- MaxX should also shift on BidiMode bdRightToLeft + + RTLOffset; //added for fix + + // 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 := (Header.Style = hsThickButtons) or not (hoAutoResize in Header.Options) or (TreeViewControl.BevelKind = bkNone); + + // Now go for each button. + while (Run > NoColumn) and (TargetRect.Left < MaxX) do + begin + TargetRect.Right := TargetRect.Left + Items[Run].Width; + + // 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].Options) then + LastColumn := GetPreviousVisibleColumn(LastColumn); + if LastColumn > NoColumn then + with Items[LastColumn] do + Result := FLeft + FWidth; + end; +end; + +{ THeaderPaintInfo } + +procedure THeaderPaintInfo.DrawDropMark(); +var + Y : Integer; + lArrowWidth : Integer; +begin + lArrowWidth := TBaseVirtualTreeCracker(Self.Column.TreeViewControl).ScaledPixels(5); + Y := (PaintRectangle.Top + PaintRectangle.Bottom - 3 * lArrowWidth) div 2; + if DropMark = dmmLeft then + DrawArrow(TargetCanvas, TScrollDirection.sdLeft, Point(PaintRectangle.Left, Y), lArrowWidth) + else + DrawArrow(TargetCanvas, TScrollDirection.sdRight, Point(PaintRectangle.Right - lArrowWidth - (lArrowWidth div 2) {spacing}, Y), lArrowWidth); +end; + +procedure THeaderPaintInfo.DrawSortArrow(pDirection : TSortDirection); +const + cDirection : array [TSortDirection] of TScrollDirection = (TScrollDirection.sdUp, TScrollDirection.sdDown); +var + lOldColor : TColor; +begin + lOldColor := TargetCanvas.Pen.Color; + TargetCanvas.Pen.Color := clDkGray; + DrawArrow(TargetCanvas, cDirection[pDirection], Point(SortGlyphPos.X, SortGlyphPos.Y), SortGlyphSize.cy); + TargetCanvas.Pen.Color := lOldColor; +end; + +{ TVirtualTreeColumnHelper } + +function TVirtualTreeColumnHelper.Header : TVTHeader; +begin + Result := Owner.Header; +end; + +function TVirtualTreeColumnHelper.TreeViewControl : TBaseVirtualTreeCracker; +begin + Result := TBaseVirtualTreeCracker(Owner.Header.GetOwner); +end; + +{ TVirtualTreeColumnsHelper } + +function TVirtualTreeColumnsHelper.TreeViewControl : TBaseVirtualTreeCracker; +begin + Result := TBaseVirtualTreeCracker(Header.GetOwner); +end; + + +end. diff --git a/components/virtualtreeview/Source/VirtualTrees.HeaderPopup.pas b/components/virtualtreeview/Source/VirtualTrees.HeaderPopup.pas index 6d003bca..0e589816 100644 --- a/components/virtualtreeview/Source/VirtualTrees.HeaderPopup.pas +++ b/components/virtualtreeview/Source/VirtualTrees.HeaderPopup.pas @@ -68,7 +68,8 @@ interface uses System.Classes, Vcl.Menus, - VirtualTrees; + VirtualTrees, + VirtualTrees.Types; type TVTHeaderPopupOption = ( @@ -78,7 +79,7 @@ type ); TVTHeaderPopupOptions = set of TVTHeaderPopupOption; - TColumnChangeEvent = procedure(const Sender: TBaseVirtualTree; const Column: TColumnIndex; Visible: Boolean) of object; + TColumnChangeEvent = procedure(const Sender: TObject; const Column: TColumnIndex; Visible: Boolean) of object; TVTHeaderPopupMenu = class(TPopupMenu) strict private @@ -91,7 +92,7 @@ type strict protected procedure DoAddHeaderPopupItem(const Column: TColumnIndex; out Cmd: TAddPopupItemType); virtual; procedure DoColumnChange(Column: TColumnIndex; Visible: Boolean); virtual; - procedure OnMenuItemClick(Sender: TObject); + procedure OnMenuItemClick(Sender: TObject); virtual; public constructor Create(AOwner: TComponent); override; procedure Popup(x, y: Integer); override; @@ -107,7 +108,8 @@ type implementation uses - Winapi.Windows, System.Types; + Winapi.Windows, System.Types, + VirtualTrees.Header; resourcestring sResizeColumnToFit = 'Size &Column to Fit'; diff --git a/components/virtualtreeview/Source/VirtualTrees.StyleHooks.pas b/components/virtualtreeview/Source/VirtualTrees.StyleHooks.pas index b27dae37..58d55060 100644 --- a/components/virtualtreeview/Source/VirtualTrees.StyleHooks.pas +++ b/components/virtualtreeview/Source/VirtualTrees.StyleHooks.pas @@ -118,13 +118,31 @@ var VTStyleServicesFunc: TVTStyleServicesFunc = nil; +/// Wrapper function for styles services that handles differences between RAD Studio 10.4 and older versions, +/// as well as the case if these controls are used inside the IDE. +function VTStyleServices(AControl: TControl = nil): TCustomStyleServices; + + implementation uses System.SysUtils, System.Math, System.Types, - VirtualTrees; + VirtualTrees, + VirtualTrees.Header, + VirtualTrees.DrawTree; + +function VTStyleServices(AControl: TControl = nil): TCustomStyleServices; +begin + if Assigned(VTStyleServicesFunc) then + Result := VTStyleServicesFunc(AControl) + else + Result := Vcl.Themes.StyleServices{$if CompilerVersion >= 34}(AControl){$ifend}; +end; + +//---------------------------------------------------------------------------------------------------------------------- + type TBaseVirtualTreeCracker = class(TBaseVirtualTree) @@ -498,7 +516,10 @@ end; procedure TVclStyleScrollBarsHook.WMHScroll(var Msg: TWMHScroll); begin CallDefaultProc(TMessage(Msg)); - PaintScroll; + if not (Msg.ScrollCode in [SB_THUMBTRACK, SB_THUMBPOSITION]) then + UpdateScroll + else + PaintScroll; Handled := True; end; @@ -511,7 +532,7 @@ end; procedure TVclStyleScrollBarsHook.WMKeyDown(var Msg: TMessage); begin CallDefaultProc(TMessage(Msg)); - PaintScroll; + UpdateScroll; Handled := True; end; @@ -927,7 +948,10 @@ end; procedure TVclStyleScrollBarsHook.WMVScroll(var Msg: TWMVScroll); begin CallDefaultProc(TMessage(Msg)); - PaintScroll; + if not (Msg.ScrollCode in [SB_THUMBTRACK, SB_THUMBPOSITION]) then + UpdateScroll + else + PaintScroll; Handled := True; end; diff --git a/components/virtualtreeview/Source/VirtualTrees.Types.pas b/components/virtualtreeview/Source/VirtualTrees.Types.pas index 72e9834f..d44e918b 100644 --- a/components/virtualtreeview/Source/VirtualTrees.Types.pas +++ b/components/virtualtreeview/Source/VirtualTrees.Types.pas @@ -1,8 +1,917 @@ -unit VirtualTrees.Types; -// Dummy unit to make migeration between V7 and V8 easier. +unit VirtualTrees.Types; interface +uses + WinApi.ActiveX, + System.Types, + System.Classes, + System.UITypes, + System.SysUtils, + Vcl.Controls, + Vcl.GraphUtil, + Vcl.Themes; + +{$MINENUMSIZE 1, make enumerations as small as possible} + +const + VTTreeStreamVersion = 3; + 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. + cDefaultTextMargin = 4; // The default margin of text + + // Special identifiers for columns. + NoColumn = - 1; + InvalidColumn = - 2; + + // Indices for check state images used for checking. + ckEmpty = 0; // an empty image used as place holder + // radio buttons + ckRadioUncheckedNormal = 1; + ckRadioUncheckedHot = 2; + ckRadioUncheckedPressed = 3; + ckRadioUncheckedDisabled = 4; + ckRadioCheckedNormal = 5; + ckRadioCheckedHot = 6; + ckRadioCheckedPressed = 7; + ckRadioCheckedDisabled = 8; + // check boxes + ckCheckUncheckedNormal = 9; + ckCheckUncheckedHot = 10; + ckCheckUncheckedPressed = 11; + ckCheckUncheckedDisabled = 12; + ckCheckCheckedNormal = 13; + ckCheckCheckedHot = 14; + ckCheckCheckedPressed = 15; + ckCheckCheckedDisabled = 16; + ckCheckMixedNormal = 17; + ckCheckMixedHot = 18; + ckCheckMixedPressed = 19; + ckCheckMixedDisabled = 20; + // simple button + ckButtonNormal = 21; + ckButtonHot = 22; + ckButtonPressed = 23; + ckButtonDisabled = 24; + + // Instead using a TTimer class for each of the various events I use Windows timers with messages + // as this is more economical. + ExpandTimer = 1; + EditTimer = 2; + HeaderTimer = 3; + ScrollTimer = 4; + ChangeTimer = 5; + StructureChangeTimer = 6; + SearchTimer = 7; + ThemeChangedTimer = 8; + + ThemeChangedTimerDelay = 500; + + // 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; + + // 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)); + + // 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'; + + // 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 = crHSplit deprecated 'Use vrHSplit instead'; + + // Height changing cursor. + crVertSplit = crVSplit deprecated 'Use vrVSplit instead'; + + +type +{$IFDEF VT_FMX} + TDimension = Single; +{$ELSE} + TDimension = Integer; // For Firemonkey support, see #841 +{$ENDIF} + TColumnIndex = type Integer; + TColumnPosition = type Cardinal; + PCardinal = ^Cardinal; + + // The exception used by the trees. + EVirtualTreeError = class(Exception); + + // Limits the speed interval which can be used for auto scrolling (milliseconds). + TAutoScrollInterval = 1 .. 1000; + + TVTScrollIncrement = 1 .. 10000; + + // OLE drag'n drop support + TFormatEtcArray = array of TFormatEtc; + TFormatArray = array of Word; + + 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 + + + TAddPopupItemType = (apNormal, apDisabled, apHidden); + + 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 + csUncheckedDisabled, // disabled checkbox, not checkable + csCheckedDisabled, // disabled checkbox, not uncheckable + csMixedDisabled // disabled 3-state checkbox + ); + + /// Adds some convenience methods to type TCheckState + TCheckStateHelper = record helper for TCheckState + strict private + const + // Lookup to quickly convert a specific check state into its pressed counterpart and vice versa. + cPressedState : array [TCheckState] of TCheckState = ( + csUncheckedPressed, csUncheckedPressed, csCheckedPressed, csCheckedPressed, csMixedPressed, csMixedPressed, csUncheckedDisabled, csCheckedDisabled, csMixedDisabled); + cUnpressedState : array [TCheckState] of TCheckState = ( + csUncheckedNormal, csUncheckedNormal, csCheckedNormal, csCheckedNormal, csMixedNormal, csMixedNormal, csUncheckedDisabled, csCheckedDisabled, csMixedDisabled); + cEnabledState : array [TCheckState] of TCheckState = ( + csUncheckedNormal, csUncheckedPressed, csCheckedNormal, csCheckedPressed, csMixedNormal, csMixedPressed, csUncheckedNormal, csCheckedNormal, csMixedNormal); + cToggledState : array [TCheckState] of TCheckState = ( + csCheckedNormal, csCheckedPressed, csUncheckedNormal, csUncheckedPressed, csCheckedNormal, csCheckedPressed, csUncheckedDisabled, csCheckedDisabled, csMixedDisabled); + public + function GetPressed() : TCheckState; inline; + function GetUnpressed() : TCheckState; inline; + function GetEnabled() : TCheckState; inline; + function GetToggled() : TCheckState; inline; + function IsDisabled() : Boolean; inline; + function IsChecked() : Boolean; inline; + function IsUnChecked() : Boolean; inline; + function IsMixed() : Boolean; inline; + end; + +type + // 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 + coStyleColor // Prefer background color of VCL style over TVirtualTreeColumn.Color + ); + TVTColumnOptions = set of TVTColumnOption; + + TVirtualTreeColumnStyle = ( + vsText, + vsOwnerDraw + ); + + TVTHeaderColumnLayout = ( + blGlyphLeft, + blGlyphRight, + blGlyphTop, + blGlyphBottom + ); + + TSortDirection = ( + sdAscending, + sdDescending + ); + + TSortDirectionHelper = record helper for VirtualTrees.Types.TSortDirection + strict private + const + cSortDirectionToInt : Array [TSortDirection] of Integer = (1, - 1); + public + /// Returns +1 for ascending and -1 for descending sort order. + function ToInt() : Integer; inline; + end; + + +// Used during owner draw of the header to indicate which drop mark for the column must be drawn. + TVTDropMarkMode = ( + dmmNone, + dmmLeft, + dmmRight + ); + + // auto scroll directions + TScrollDirections = set of TScrollDirection; +// sdLeft, +// sdUp, +// sdRight, +// sdDown +// ); + + + + // 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: + **Do not use toAnimatedToggle when a background image is used for the tree. + The animation does not look good as the image splits and moves with it. + } + TVTAnimationOption = (toAnimatedToggle, // Expanding and collapsing a node is animated (quick window scroll). + // **See note above. + 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. Sorting will take place also if SortColum is NoColumn (-1). + + 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 (text in MainColumn) + // You may use TVTHeader.RestoreSelectiuonColumnIndex to define an other column that should be used for indentification. + toSyncCheckboxesWithSelection // If checkboxes are shown, they follow the change in selections. When checkboxes are + // changed, the selections follow them and vice-versa. + // **Only supported for ctCheckBox type checkboxes. + ); + TVTSelectionOptions = set of TVTSelectionOption; + + TVTEditOptions = (toDefaultEdit, // Standard behaviour for end of editing (after VK_RETURN stay on edited cell). + toVerticalEdit, // After VK_RETURN switch to next column. + toHorizontalEdit // After VK_RETURN switch to next row. + ); + + // 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 + ); + + // 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 + DefaultPaintOptions = [toShowButtons, toShowDropmark, toShowTreeLines, toShowRoot, toThemeAware, toUseBlendedImages]; + DefaultAnimationOptions = []; + DefaultAutoOptions = [toAutoDropExpand, toAutoTristateTracking, toAutoScrollOnExpand, toAutoDeleteMovedNodes, toAutoChangeScale, toAutoSort, toAutoHideButtons]; + DefaultSelectionOptions = []; + DefaultMiscOptions = [toAcceptOLEDrop, toFullRepaintOnResize, toInitOnSave, toToggleOnDblClick, toWheelPanning, toEditOnClick]; + + DefaultStringOptions = [toSaveCaptions, toAutoAcceptEditChange]; + +type + TCustomVirtualTreeOptions = class(TPersistent) + private + FOwner : TCustomControl; + FPaintOptions : TVTPaintOptions; + FAnimationOptions : TVTAnimationOptions; + FAutoOptions : TVTAutoOptions; + FSelectionOptions : TVTSelectionOptions; + FMiscOptions : TVTMiscOptions; + FExportMode : TVTExportMode; + FEditOptions : TVTEditOptions; + 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 + // Mitigator function to use the correct style service for this context (either the style assigned to the control for Delphi > 10.4 or the application style) + function StyleServices(AControl : TControl = nil) : TCustomStyleServices; + public + constructor Create(AOwner : TCustomControl); virtual; + //these bypass the side effects in the regular setters. + procedure InternalSetMiscOptions(const Value : TVTMiscOptions); + + procedure AssignTo(Dest : TPersistent); override; + 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; + property EditOptions : TVTEditOptions read FEditOptions write FEditOptions default toDefaultEdit; + + property Owner: TCustomControl read FOwner; + end; + + TTreeOptionsClass = class of TCustomVirtualTreeOptions; + + TVirtualTreeOptions = class(TCustomVirtualTreeOptions) + published + property AnimationOptions; + property AutoOptions; + property ExportMode; + property MiscOptions; + property PaintOptions; + property SelectionOptions; + end; + + TCustomStringTreeOptions = class(TCustomVirtualTreeOptions) + private + FStringOptions : TVTStringOptions; + procedure SetStringOptions(const Value : TVTStringOptions); + protected + public + constructor Create(AOwner : TCustomControl); override; + procedure AssignTo(Dest : TPersistent); override; + property StringOptions : TVTStringOptions read FStringOptions write SetStringOptions default DefaultStringOptions; + end; + + TStringTreeOptions = class(TCustomStringTreeOptions) + published + property AnimationOptions; + property AutoOptions; + property ExportMode; + property MiscOptions; + property PaintOptions; + property SelectionOptions; + property StringOptions; + property EditOptions; + end; + + TScrollBarStyle = (sbmRegular, sbm3D); + + // A class to manage scroll bar aspects. + TScrollBarOptions = class(TPersistent) + private + FAlwaysVisible : Boolean; + FOwner : TCustomControl; + FScrollBars : TScrollStyle; // used to hide or show vertical and/or horizontal scrollbar + FScrollBarStyle : TScrollBarStyle; // kind of scrollbars to use + FIncrementX, FIncrementY : TVTScrollIncrement; // number of pixels to scroll in one step (when auto scrolling) + procedure SetAlwaysVisible(Value : Boolean); + procedure SetScrollBars(Value : TScrollStyle); + procedure SetScrollBarStyle(Value : TScrollBarStyle); + protected + function GetOwner : TPersistent; override; + public + constructor Create(AOwner : TCustomControl); + + 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 TScrollStyle.ssBoth; + property ScrollBarStyle : TScrollBarStyle read FScrollBarStyle write SetScrollBarStyle default sbmRegular; + property VerticalIncrement : TVTScrollIncrement read FIncrementY write FIncrementY default 20; + end; + implementation -end. \ No newline at end of file +uses + VirtualTrees, + VirtualTrees.StyleHooks, + WinApi.Windows; + +type + TVTCracker = class(TBaseVirtualTree); + + //----------------- TCustomVirtualTreeOptions -------------------------------------------------------------------------- + +constructor TCustomVirtualTreeOptions.Create(AOwner : TCustomControl); +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.InternalSetMiscOptions(const Value : TVTMiscOptions); +begin + FMiscOptions := Value; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TCustomVirtualTreeOptions.SetMiscOptions(const Value : TVTMiscOptions); +var + ToBeSet, ToBeCleared : TVTMiscOptions; +begin + if FMiscOptions <> Value then + begin + ToBeSet := Value - FMiscOptions; + ToBeCleared := FMiscOptions - Value; + FMiscOptions := Value; + + with TVTCracker(FOwner) do + if not (csLoading in ComponentState) and HandleAllocated then + begin + if toCheckSupport in ToBeSet + ToBeCleared then + Invalidate; + if toEditOnDblClick in ToBeSet then + FMiscOptions := FMiscOptions - [toToggleOnDblClick]; + // In order for toEditOnDblClick to take effect, we need to remove toToggleOnDblClick which is handled with priority. See issue #747 + + if not (csDesigning in ComponentState) then + begin + if toAcceptOLEDrop in ToBeCleared then + RevokeDragDrop(Handle); + if toFullRepaintOnResize in ToBeSet + ToBeCleared then + RecreateWnd; + if toAcceptOLEDrop in ToBeSet then + RegisterDragDrop(Handle, DragManager as IDropTarget); + if toVariableNodeHeight in ToBeSet then + begin + BeginUpdate(); + try + ReInitNode(nil, True); + finally + EndUpdate(); + end; //try..finally + end; //if toVariableNodeHeight + 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 TVTCracker(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 + IncVisibleCount + else + DecVisibleCount; + 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 TreeStates) or ((toThemeAware in ToBeSet) and StyleServices.Enabled)) and (toUseExplorerTheme in (ToBeSet + ToBeCleared)) and + not VclStyleEnabled then + begin + if (toUseExplorerTheme in ToBeSet) then + begin + SetWindowTheme('explorer'); + DoStateChange([tsUseExplorerTheme]); + end + else if toUseExplorerTheme in ToBeCleared then + begin + SetWindowTheme(''); + DoStateChange([], [tsUseExplorerTheme]); + end; + 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) 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 UpdateCount = 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 TVTCracker(FOwner) do + begin + if (toMultiSelect in (ToBeCleared + ToBeSet)) or ([toLevelSelectConstraint, toSiblingSelectConstraint] * ToBeSet <> []) then + ClearSelection; + + if (toExtendedFocus in ToBeCleared) and (FocusedColumn > 0) and HandleAllocated then + begin + FocusedColumn := Header.MainColumn; + Invalidate; + end; + + if not (toExtendedFocus in FSelectionOptions) then + FocusedColumn := Header.MainColumn; + end; + end; +end; + +function TCustomVirtualTreeOptions.StyleServices(AControl : TControl) : TCustomStyleServices; +begin + Result := VTStyleServices(FOwner); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TCustomVirtualTreeOptions.AssignTo(Dest : TPersistent); +begin + if Dest is TCustomVirtualTreeOptions then + begin + with Dest as TCustomVirtualTreeOptions do + begin + PaintOptions := Self.PaintOptions; + AnimationOptions := Self.AnimationOptions; + AutoOptions := Self.AutoOptions; + SelectionOptions := Self.SelectionOptions; + MiscOptions := Self.MiscOptions; + end; + end + else + inherited; +end; + +//----------------- TCustomStringTreeOptions --------------------------------------------------------------------------- + +constructor TCustomStringTreeOptions.Create(AOwner : TCustomControl); +begin + inherited; + FStringOptions := DefaultStringOptions; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TCustomStringTreeOptions.SetStringOptions(const Value : TVTStringOptions); +var + ChangedOptions : TVTStringOptions; +begin + if FStringOptions <> Value then + begin + // Exclusive ORing to get all entries wich are in either set but not in both. + ChangedOptions := FStringOptions + Value - (FStringOptions * Value); + FStringOptions := Value; + with FOwner do + if (toShowStaticText in ChangedOptions) and not (csLoading in ComponentState) and HandleAllocated then + Invalidate; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TCustomStringTreeOptions.AssignTo(Dest : TPersistent); +begin + if Dest is TCustomStringTreeOptions then + begin + with Dest as TCustomStringTreeOptions do + begin + StringOptions := Self.StringOptions; + EditOptions := Self.EditOptions; + end; + end; + + // Let ancestors assign their options to the destination class. + inherited; +end; + +//----------------- TScrollBarOptions ---------------------------------------------------------------------------------- + +constructor TScrollBarOptions.Create(AOwner : TCustomControl); +begin + inherited Create; + + FOwner := AOwner; + FAlwaysVisible := False; + FScrollBarStyle := sbmRegular; + FScrollBars := TScrollStyle.ssBoth; + FIncrementX := 20; + FIncrementY := 20; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TScrollBarOptions.SetAlwaysVisible(Value : Boolean); +begin + if FAlwaysVisible <> Value then + begin + FAlwaysVisible := Value; + if not (csLoading in FOwner.ComponentState) and FOwner.HandleAllocated then + TVTCracker(FOwner).RecreateWnd; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TScrollBarOptions.SetScrollBars(Value : TScrollStyle); +begin + if FScrollBars <> Value then + begin + FScrollBars := Value; + if not (csLoading in FOwner.ComponentState) and FOwner.HandleAllocated then + TVTCracker(FOwner).RecreateWnd; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TScrollBarOptions.SetScrollBarStyle(Value : TScrollBarStyle); + +begin + if FScrollBarStyle <> Value then + begin + FScrollBarStyle := Value; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TScrollBarOptions.GetOwner : TPersistent; + +begin + Result := FOwner; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TScrollBarOptions.Assign(Source : TPersistent); + +begin + if Source is TScrollBarOptions then + begin + AlwaysVisible := TScrollBarOptions(Source).AlwaysVisible; + HorizontalIncrement := TScrollBarOptions(Source).HorizontalIncrement; + ScrollBars := TScrollBarOptions(Source).ScrollBars; + ScrollBarStyle := TScrollBarOptions(Source).ScrollBarStyle; + VerticalIncrement := TScrollBarOptions(Source).VerticalIncrement; + end + else + inherited; +end; + + + +{ TCheckStateHelper } + +function TCheckStateHelper.IsDisabled : Boolean; +begin + Result := Self >= TCheckState.csUncheckedDisabled; +end; + +function TCheckStateHelper.IsChecked : Boolean; +begin + Result := Self in [csCheckedNormal, csCheckedPressed, csCheckedDisabled]; +end; + +function TCheckStateHelper.IsUnChecked : Boolean; +begin + Result := Self in [csUncheckedNormal, csUncheckedPressed, csUncheckedDisabled]; +end; + +function TCheckStateHelper.IsMixed : Boolean; +begin + Result := Self in [csMixedNormal, csMixedPressed, csMixedDisabled]; +end; + +function TCheckStateHelper.GetEnabled : TCheckState; +begin + Result := cEnabledState[Self]; +end; + +function TCheckStateHelper.GetPressed() : TCheckState; +begin + Result := cPressedState[Self]; +end; + +function TCheckStateHelper.GetUnpressed() : TCheckState; +begin + Result := cUnpressedState[Self]; +end; + +function TCheckStateHelper.GetToggled() : TCheckState; +begin + Result := cToggledState[Self]; +end; + +{ TSortDirectionHelper } + +function TSortDirectionHelper.ToInt() : Integer; +begin + Result := cSortDirectionToInt[Self]; +end; + + +end. diff --git a/components/virtualtreeview/Source/VirtualTrees.pas b/components/virtualtreeview/Source/VirtualTrees.pas index 7037607d..2b6adb27 100644 --- a/components/virtualtreeview/Source/VirtualTrees.pas +++ b/components/virtualtreeview/Source/VirtualTrees.pas @@ -30,7 +30,7 @@ // 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, Roman Kassebaum, Vincent Parret, Dietmar Roesler, Sanjay Kanade, +// Andreas Hausladen, Joachim Marder, Roman Kassebaum, Vincent Parrett, Dietmar Roesler, Sanjay Kanade, // and everyone that sent pull requests: https://github.com/Virtual-TreeView/Virtual-TreeView/pulls?q= // Beta testers: // Freddy Ertl, Hans-Juergen Schnorrenberg, Werner Lehmann, Jim Kueneman, Vadim Sedulin, Moritz Franckenstein, @@ -78,142 +78,111 @@ uses Winapi.Windows, Winapi.oleacc, Winapi.Messages, System.SysUtils, Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.ImgList, Winapi.ActiveX, Vcl.StdCtrls, System.Classes, Vcl.Menus, Vcl.Printers, System.Types, Winapi.CommCtrl, Vcl.Themes, Winapi.UxTheme, - Winapi.ShlObj, System.UITypes, System.Generics.Collections, VirtualTrees.Types; -type -{$IFDEF VT_FMX} - TDimension = Single; -{$ELSE} - TDimension = Integer; // For Firemonkey support, see #841 -{$ENDIF} + Winapi.ShlObj, System.UITypes, System.Generics.Collections, + VirtualTrees.Types, + VirtualTrees.Colors, + VirtualTrees.DragImage, + VirtualTrees.Header; const - VTVersion = '7.6.2' deprecated 'This const is going to be removed in a future version'; + //Aliases + NoColumn = VirtualTrees.Types.NoColumn; + InvalidColumn = VirtualTrees.Types.InvalidColumn; + sdAscending = VirtualTrees.Types.TSortDirection.sdAscending; + sdDescending = VirtualTrees.Types.TSortDirection.sdDescending; -const - VTTreeStreamVersion = 3; - VTHeaderStreamVersion = 6; // The header needs an own stream version to indicate changes only relevant to the header. + ctNone = VirtualTrees.Types.TCheckType.ctNone; + ctTriStateCheckBox = VirtualTrees.Types.TCheckType.ctTriStateCheckBox; + ctCheckBox = VirtualTrees.Types.TCheckType.ctCheckBox; + ctRadioButton = VirtualTrees.Types.TCheckType.ctRadioButton; + ctButton = VirtualTrees.Types.TCheckType.ctButton; - 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. - cDefaultTextMargin = 4; // The default margin of text + csUncheckedNormal = VirtualTrees.Types.TCheckState.csUncheckedNormal; + csUncheckedPressed = VirtualTrees.Types.TCheckState.csUncheckedPressed; + csCheckedNormal = VirtualTrees.Types.TCheckState.csCheckedNormal; + csCheckedPressed = VirtualTrees.Types.TCheckState.csCheckedPressed; + csMixedNormal = VirtualTrees.Types.TCheckState.csMixedNormal; + csMixedPressed = VirtualTrees.Types.TCheckState.csMixedPressed; + csUncheckedDisabled = VirtualTrees.Types.TCheckState.csUncheckedDisabled; + csCheckedDisabled = VirtualTrees.Types.TCheckState.csCheckedDisabled; + csMixedDisable = VirtualTrees.Types.TCheckState.csMixedDisabled; - // Special identifiers for columns. - NoColumn = -1; - InvalidColumn = -2; - // Indices for check state images used for checking. - ckEmpty = 0; // an empty image used as place holder - // radio buttons - ckRadioUncheckedNormal = 1; - ckRadioUncheckedHot = 2; - ckRadioUncheckedPressed = 3; - ckRadioUncheckedDisabled = 4; - ckRadioCheckedNormal = 5; - ckRadioCheckedHot = 6; - ckRadioCheckedPressed = 7; - ckRadioCheckedDisabled = 8; - // check boxes - ckCheckUncheckedNormal = 9; - ckCheckUncheckedHot = 10; - ckCheckUncheckedPressed = 11; - ckCheckUncheckedDisabled = 12; - ckCheckCheckedNormal = 13; - ckCheckCheckedHot = 14; - ckCheckCheckedPressed = 15; - ckCheckCheckedDisabled = 16; - ckCheckMixedNormal = 17; - ckCheckMixedHot = 18; - ckCheckMixedPressed = 19; - ckCheckMixedDisabled = 20; - // simple button - ckButtonNormal = 21; - ckButtonHot = 22; - ckButtonPressed = 23; - ckButtonDisabled = 24; - - // Instead using a TTimer class for each of the various events I use Windows timers with messages - // as this is more economical. - ExpandTimer = 1; - EditTimer = 2; - HeaderTimer = 3; - ScrollTimer = 4; - ChangeTimer = 5; - StructureChangeTimer = 6; - SearchTimer = 7; - ThemeChangedTimer = 8; - - ThemeChangedTimerDelay = 500; - - // 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; - - // 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)); - - // 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); - -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; +var IsWinVistaOrAbove: Boolean; {$MinEnumSize 1, make enumerations as small as possible} - - type // Alias defintions for convenience TImageIndex = System.UITypes.TImageIndex; TCanvas = Vcl.Graphics.TCanvas; + //these were moved, aliases are for backwards compatibility. + //some may be removed once we sort out excactly what is needed. + TDimension = VirtualTrees.Types.TDimension; + TColumnIndex = VirtualTrees.Types.TColumnIndex; + TColumnPosition = VirtualTrees.Types.TColumnPosition; + EVirtualTreeError = VirtualTrees.Types.EVirtualTreeError; + TAutoScrollInterval = VirtualTrees.Types.TAutoScrollInterval; + TVTScrollIncrement = VirtualTrees.Types.TVTScrollIncrement; + TFormatArray = VirtualTrees.Types.TFormatArray; + TFormatEtcArray = VirtualTrees.Types.TFormatEtcArray; - // The exception used by the trees. - EVirtualTreeError = class(Exception); + TVTPaintOption = VirtualTrees.Types.TVTPaintOption; + TVTPaintOptions = VirtualTrees.Types.TVTPaintOptions; + TVTAnimateOption = VirtualTrees.Types.TVTAnimationOption; + TVTAnimateOptions = VirtualTrees.Types.TVTAnimationOptions; + TVTAutoOption = VirtualTrees.Types.TVTAutoOption; + TVTAutoOptions = VirtualTrees.Types.TVTAutoOptions; + TVTSelectionOption = VirtualTrees.Types.TVTSelectionOption; + TVTSelectionOptions = VirtualTrees.Types.TVTSelectionOptions; + TVTEditOptions = VirtualTrees.Types.TVTEditOptions; + TVTMiscOption = VirtualTrees.Types.TVTMiscOption; + TVTMiscOptions = VirtualTrees.Types.TVTMiscOptions; + TVTExportMode = VirtualTrees.Types.TVTExportMode; + TVTStringOption = VirtualTrees.Types.TVTStringOption; + TVTStringOptions = VirtualTrees.Types.TVTStringOptions; + TCustomVirtualTreeOptions = VirtualTrees.Types.TCustomVirtualTreeOptions; + TVirtualTreeOptions = VirtualTrees.Types.TVirtualTreeOptions; + TTreeOptionsClass = VirtualTrees.Types.TTreeOptionsClass; + TCustomStringTreeOptions = VirtualTrees.Types.TCustomStringTreeOptions; + TStringTreeOptions = VirtualTrees.Types.TStringTreeOptions; - PCardinal = ^Cardinal; + TScrollBarStyle = VirtualTrees.Types.TScrollBarStyle; + TScrollBarOptions = VirtualTrees.Types.TScrollBarOptions; - // Limits the speed interval which can be used for auto scrolling (milliseconds). - TAutoScrollInterval = 1..1000; + TVTColumnOption = VirtualTrees.Types.TVTColumnOption; + TVTColumnOptions = VirtualTrees.Types.TVTColumnOptions; + TVirtualTreeColumnStyle = VirtualTrees.Types.TVirtualTreeColumnStyle; + TSortDirection = VirtualTrees.Types.TSortDirection; + TCheckType = VirtualTrees.Types.TCheckType; + TCheckState = VirtualTrees.Types.TCheckState; + TVTDropMarkMode = VirtualTrees.Types.TVTDropMarkMode; + TScrollDirections = VirtualTrees.Types.TScrollDirections; + TVirtualTreeColumn = VirtualTrees.Header.TVirtualTreeColumn; + TVirtualTreeColumns = VirtualTrees.Header.TVirtualTreeColumns; + TVirtualTreeColumnClass = VirtualTrees.Header.TVirtualTreeColumnClass; + TColumnsArray = VirtualTrees.Header.TColumnsArray; + TCardinalArray = VirtualTrees.Header.TCardinalArray; + TIndexArray = VirtualTrees.Header.TIndexArray; + + TVTHeader = VirtualTrees.Header.TVTHeader; + TVTHeaderClass = VirtualTrees.Header.TVTHeaderClass; + TVTHeaderOption = VirtualTrees.Header.TVTHeaderOption; + TVTHeaderOptions = VirtualTrees.Header.TVTHeaderOptions; + THeaderPaintInfo = VirtualTrees.Header.THeaderPaintInfo; + TVTHeaderColumnLayout = VirtualTrees.Types.TVTHeaderColumnLayout; + TVTConstraintPercent = VirtualTrees.Header.TVTConstraintPercent; + TSmartAutoFitType = VirtualTrees.Types.TSmartAutoFitType; + TVTFixedAreaConstraints = VirtualTrees.Header.TVTFixedAreaConstraints; + TVTHeaderStyle = VirtualTrees.Header.TVTHeaderStyle; + THeaderState = VirtualTrees.Header.THeaderState; + THeaderStates = VirtualTrees.Header.THeaderStates; + + TVTColors = VirtualTrees.Colors.TVTColors; + // // 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. @@ -252,33 +221,7 @@ type ); TVirtualNodeInitStates = set of TVirtualNodeInitState; - TScrollBarStyle = ( - sbmRegular, - sbm3D - ); - // Options per column. - TVTColumnOption = ( - coAllowClick, // Column can be clicked (must be enabled too). - coDraggable, // Column can be dragged. - coEnabled, // Column is enabled. - coParentBidiMode, // Column uses the parent's bidi mode. - coParentColor, // Column uses the parent's background color. - coResizable, // Column can be resized. - coShowDropMark, // Column shows the drop mark if it is currently the drop target. - coVisible, // Column is shown. - coAutoSpring, // Column takes part in the auto spring feature of the header (must be resizable too). - coFixed, // Column is fixed and can not be selected or scrolled etc. - coSmartResize, // Column is resized to its largest entry which is in view (instead of its largest - // visible entry). - coAllowFocus, // Column can be focused. - coDisableAnimatedResize, // Column resizing is not animated. - coWrapCaption, // Caption could be wrapped across several header lines to fit columns width. - coUseCaptionAlignment, // Column's caption has its own aligment. - coEditable, // Column can be edited - coStyleColor // Prefer background color of VCL style over TVirtualTreeColumn.Color - ); - TVTColumnOptions = set of TVTColumnOption; // These flags are used to indicate where a click in the header happened. TVTHeaderHitPosition = ( @@ -311,51 +254,6 @@ type ); 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 - csUncheckedDisabled,// disabled checkbox, not checkable - csCheckedDisabled, // disabled checkbox, not uncheckable - csMixedDisabled // disabled 3-state checkbox - ); - - /// Adds some convenience methods to type TCheckState - TCheckStateHelper = record helper for TCheckState - strict private - const - // Lookup to quickly convert a specific check state into its pressed counterpart and vice versa. - cPressedState: array[TCheckState] of TCheckState = ( - csUncheckedPressed, csUncheckedPressed, csCheckedPressed, csCheckedPressed, csMixedPressed, csMixedPressed, csUncheckedDisabled, csCheckedDisabled, csMixedDisabled); - cUnpressedState: array[TCheckState] of TCheckState = ( - csUncheckedNormal, csUncheckedNormal, csCheckedNormal, csCheckedNormal, csMixedNormal, csMixedNormal, csUncheckedDisabled, csCheckedDisabled, csMixedDisabled); - cEnabledState: array[TCheckState] of TCheckState = ( - csUncheckedNormal, csUncheckedPressed, csCheckedNormal, csCheckedPressed, csMixedNormal, csMixedPressed, csUncheckedNormal, csCheckedNormal, csMixedNormal); - cToggledState: array[TCheckState] of TCheckState = ( - csCheckedNormal, csCheckedPressed, csUnCheckedNormal, csUnCheckedPressed, csCheckedNormal, csCheckedPressed, csUncheckedDisabled, csCheckedDisabled, csMixedDisabled); - public - function GetPressed(): TCheckState; inline; - function GetUnpressed(): TCheckState; inline; - function GetEnabled(): TCheckState; inline; - function GetToggled(): TCheckState; inline; - function IsDisabled(): Boolean; inline; - function IsChecked(): Boolean; inline; - function IsUnChecked(): Boolean; inline; - function IsMixed(): Boolean; inline; - end; TCheckImageKind = ( ckCustom, // application defined check images @@ -429,138 +327,6 @@ type ); - // 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: - **Do not use toAnimatedToggle when a background image is used for the tree. - The animation does not look good as the image splits and moves with it. - } - TVTAnimationOption = ( - toAnimatedToggle, // Expanding and collapsing a node is animated (quick window scroll). - // **See note above. - 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. Sorting will take place also if SortColum is NoColumn (-1). - 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 (text in MainColumn) - // You may use TVTHeader.RestoreSelectiuonColumnIndex to define an other column that should be used for indentification. - toSyncCheckboxesWithSelection // If checkboxes are shown, they follow the change in selections. When checkboxes are - // changed, the selections follow them and vice-versa. - // **Only supported for ctCheckBox type checkboxes. - ); - TVTSelectionOptions = set of TVTSelectionOption; - - TVTEditOptions = ( - toDefaultEdit, // Standard behaviour for end of editing (after VK_RETURN stay on edited cell). - toVerticalEdit, // After VK_RETURN switch to next column. - toHorizontalEdit // After VK_RETURN switch to next row. - ); - - // 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, @@ -588,31 +354,12 @@ type /// An array that can be used to calculate the offsets ofthe elements in the tree. TVTOffsets = array [TVTElement] of TDimension; - TAddPopupItemType = ( - apNormal, - apDisabled, - apHidden - ); - -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, coStyleColor]; - 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 @@ -623,51 +370,6 @@ type 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; - FEditOptions: TVTEditOptions; - 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 - // Mitigator function to use the correct style service for this context (either the style assigned to the control for Delphi > 10.4 or the application style) - function StyleServices(AControl: TControl = nil): TCustomStyleServices; - //these bypass the side effects in the regular setters. - procedure InternalSetMiscOptions(const Value: TVTMiscOptions); - public - constructor Create(AOwner: TBaseVirtualTree); virtual; - procedure AssignTo(Dest: TPersistent); override; - 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; - property EditOptions: TVTEditOptions read FEditOptions write FEditOptions default toDefaultEdit; - - 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; @@ -726,38 +428,7 @@ type 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; const AFormatEtcArray: TFormatEtcArray); - - function Clone(out Enum: IEnumFormatEtc): HResult; stdcall; - function Next(celt: Integer; out elt; pceltFetched: PLongint): HResult; stdcall; - function Reset: HResult; stdcall; - function Skip(celt: Integer): HResult; stdcall; - end; // ----- OLE drag'n drop handling @@ -775,73 +446,7 @@ type 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(const 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; const DataObject: IDataObject): HRESULT; - property ForClipboard: Boolean read FForClipboard; - property FormatEtcArray: TFormatEtcArray read FFormatEtcArray write FFormatEtcArray; - property InternalStgMediumArray: TInternalStgMediumArray read FInternalStgMediumArray write FInternalStgMediumArray; - property Owner: TBaseVirtualTree read FOwner; - public - constructor Create(AOwner: TBaseVirtualTree; ForClipboard: Boolean); virtual; - destructor Destroy; override; - - function DAdvise(const FormatEtc: TFormatEtc; advf: Integer; const advSink: IAdviseSink; out dwConnection: Integer): - HResult; virtual; stdcall; - function DUnadvise(dwConnection: Integer): HResult; virtual; stdcall; - function EnumDAdvise(out enumAdvise: IEnumStatData): HResult; virtual; stdcall; - function EnumFormatEtc(Direction: Integer; out EnumFormatEtc: IEnumFormatEtc): HResult; virtual; stdcall; - function GetCanonicalFormatEtc(const FormatEtc: TFormatEtc; out FormatEtcOut: TFormatEtc): HResult; virtual; stdcall; - function GetData(const FormatEtcIn: TFormatEtc; out Medium: TStgMedium): HResult; virtual; stdcall; - function GetDataHere(const FormatEtc: TFormatEtc; out Medium: TStgMedium): HResult; virtual; stdcall; - function QueryGetData(const FormatEtc: TFormatEtc): HResult; virtual; stdcall; - function SetData(const FormatEtc: TFormatEtc; var Medium: TStgMedium; DoRelease: BOOL): HResult; virtual; stdcall; - end; - - // TVTDragManager is a class to manage drag and drop in a Virtual Treeview. - TVTDragManager = class(TInterfacedObject, IVTDragManager, IDropSource, IDropTarget) - private - FOwner, // The tree which is responsible for drag management. - FDragSource: TBaseVirtualTree; // Reference to the source tree if the source was a VT, might be different than - // the owner tree. - FIsDropTarget: Boolean; // True if the owner is currently the drop target. - FDataObject: IDataObject; // A reference to the data object passed in by DragEnter (only used when the owner - // tree is the current drop target). - FDropTargetHelper: IDropTargetHelper; // Win2k > Drag image support - FFullDragging: BOOL; // True, if full dragging is currently enabled in the system. - - function GetDataObject: IDataObject; stdcall; - function GetDragSource: TBaseVirtualTree; stdcall; - function GetDropTargetHelperSupported: Boolean; stdcall; - function GetIsDropTarget: Boolean; stdcall; - public - constructor Create(AOwner: TBaseVirtualTree); virtual; - destructor Destroy; override; - - function DragEnter(const DataObject: IDataObject; KeyState: Integer; Pt: TPoint; - var Effect: Longint): HResult; stdcall; - function DragLeave: HResult; stdcall; - function DragOver(KeyState: Integer; Pt: TPoint; var Effect: LongInt): HResult; stdcall; - function Drop(const DataObject: IDataObject; KeyState: Integer; Pt: TPoint; var Effect: Integer): HResult; stdcall; - procedure ForceDragLeave; stdcall; - function GiveFeedback(Effect: Integer): HResult; stdcall; - function QueryContinueDrag(EscapePressed: BOOL; KeyState: Integer): HResult; stdcall; - end; PVTHintData = ^TVTHintData; TVTHintData = record @@ -872,431 +477,6 @@ type function IsHintMsg(var Msg: TMsg): Boolean; override; end; - // Drag image support for the tree. - TVTTransparency = 0..255; - TVTBias = -128..127; - - // Simple move limitation for the drag image. - TVTDragMoveRestriction = ( - dmrNone, - dmrHorizontalOnly, - dmrVerticalOnly - ); - - TVTDragImageStates = set of ( - disHidden, // Internal drag image is currently hidden (always hidden if drag image helper interfaces are used). - disInDrag, // Drag image class is currently being used. - disPrepared, // Drag image class is prepared. - disSystemSupport // Running on Windows 2000 or higher. System supports drag images natively. - ); - - // Class to manage header and tree drag image during a drag'n drop operation. - TVTDragImage = class - private - FOwner: TBaseVirtualTree; - FBackImage, // backup of overwritten screen area - FAlphaImage, // target for alpha blending - FDragImage: TBitmap; // the actual drag image to blend to screen - FImagePosition, // position of image (upper left corner) in screen coordinates - FLastPosition: TPoint; // last mouse position in screen coordinates - FTransparency: TVTTransparency; // alpha value of the drag image (0 - fully transparent, 255 - fully opaque) - FPreBlendBias, // value to darken or lighten the drag image before it is blended - FPostBlendBias: TVTBias; // value to darken or lighten the alpha blend result - FFade: Boolean; // determines whether to fade the drag image from center to borders or not - FRestriction: TVTDragMoveRestriction; // determines in which directions the drag image can be moved - FColorKey: TColor; // color to make fully transparent regardless of any other setting - FStates: TVTDragImageStates; // Determines the states of the drag image class. - function GetVisible: Boolean; // True if the drag image is currently hidden (used only when dragging) - procedure InternalShowDragImage(ScreenDC: HDC); - procedure MakeAlphaChannel(Source, Target: TBitmap); - procedure RecaptureBackground(Tree: TBaseVirtualTree; R: TRect; VisibleRegion: HRGN; CaptureNCArea, - ReshowDragImage: Boolean); - function WillMove(P: TPoint): Boolean; - property Visible: Boolean read GetVisible; - property PreBlendBias: TVTBias read FPreBlendBias write FPreBlendBias default 0; - property Transparency: TVTTransparency read FTransparency write FTransparency default 128; - property ColorKey: TColor read FColorKey write FColorKey default clWindow; - property Fade: Boolean read FFade write FFade default False; - public - constructor Create(AOwner: TBaseVirtualTree); - destructor Destroy; override; - - function DragTo(P: TPoint; ForceRepaint: Boolean): Boolean; - procedure EndDrag; - function GetDragImageRect: TRect; - procedure HideDragImage; - procedure PrepareDrag(DragImage: TBitmap; ImagePosition, HotSpot: TPoint; const DataObject: IDataObject); - procedure ShowDragImage; - property ImagePosition : TPoint read FImagePosition; - property LastPosition : TPoint read FLastPosition; - property MoveRestriction: TVTDragMoveRestriction read FRestriction write FRestriction default dmrNone; - end; - - // tree columns implementation - TVirtualTreeColumns = class; - TVTHeader = class; - - TVirtualTreeColumnStyle = ( - vsText, - vsOwnerDraw - ); - - TVTHeaderColumnLayout = ( - blGlyphLeft, - blGlyphRight, - blGlyphTop, - blGlyphBottom - ); - - TSortDirection = ( - sdAscending, - sdDescending - ); - - TSortDirectionHelper = record helper for VirtualTrees.TSortDirection - strict private - const cSortDirectionToInt: Array [TSortDirection] of Integer = (1, -1); - public - /// Returns +1 for ascending and -1 for descending sort order. - function ToInt(): Integer; inline; - end; - - // Used during owner draw of the header to indicate which drop mark for the column must be drawn. - TVTDropMarkMode = ( - dmmNone, - dmmLeft, - dmmRight - ); - - TVirtualTreeColumn = class; - - // 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; - SortGlyphSize: TSize; - procedure DrawSortArrow(pDirection: TSortDirection); - procedure DrawDropMark(); - end; - - - TVirtualTreeColumn = class(TCollectionItem) - private - const cDefaultColumnSpacing = 3; - private - FText, - FHint: string; - FWidth: TDimension; - FPosition: TColumnPosition; - FMinWidth: TDimension; - FMaxWidth: TDimension; - FStyle: TVirtualTreeColumnStyle; - FImageIndex: TImageIndex; - FBiDiMode: TBiDiMode; - FLayout: TVTHeaderColumnLayout; - FMargin, - FSpacing: TDimension; - FOptions: TVTColumnOptions; - FEditOptions: TVTEditOptions; - FEditNextColumn: TDimension; - FTag: NativeInt; - FAlignment: TAlignment; - FCaptionAlignment: TAlignment; // Alignment of the caption. - FLastWidth: TDimension; - 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 GetCaptionWidth: TDimension; - function GetLeft: TDimension; - 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: TDimension); - procedure SetMaxWidth(Value: TDimension); - procedure SetMinWidth(Value: TDimension); - procedure SetOptions(Value: TVTColumnOptions); - procedure SetPosition(Value: TColumnPosition); - procedure SetSpacing(Value: TDimension); - procedure SetStyle(Value: TVirtualTreeColumnStyle); - procedure SetWidth(Value: TDimension); - protected - FLeft: TDimension; - procedure ChangeScale(M, D: TDimension; isDpiChange: Boolean); virtual; - procedure ComputeHeaderLayout(var PaintInfo: THeaderPaintInfo; DrawFormat: Cardinal; CalculateTextRect: Boolean = False); - procedure DefineProperties(Filer: TFiler); override; - procedure GetAbsoluteBounds(var Left, Right: TDimension); - function GetDisplayName: string; override; - function GetText: string; virtual; // [IPK] - procedure SetText(const Value: string); virtual; // [IPK] private to protected & virtual - function GetOwner: TVirtualTreeColumns; reintroduce; - procedure InternalSetWidth(const value : TDimension); //bypass side effects in SetWidth - procedure ReadHint(Reader: TReader); - procedure ReadText(Reader: TReader); - procedure SetCollection(Value: TCollection); override; - public - constructor Create(Collection: TCollection); override; - destructor Destroy; override; - - procedure Assign(Source: TPersistent); override; - function Equals(OtherColumnObj: TObject): Boolean; override; - function GetRect: TRect; virtual; - property HasImage: Boolean read FHasImage; - property ImageRect: TRect read FImageRect; - procedure LoadFromStream(const Stream: TStream; Version: Integer); - procedure ParentBiDiModeChanged; - procedure ParentColorChanged; - procedure RestoreLastWidth; - function GetEffectiveColor(): TColor; - procedure SaveToStream(const Stream: TStream); - function UseRightToLeftReading: Boolean; - - property BonusPixel: Boolean read FBonusPixel write FBonusPixel; - property CaptionText: string read FCaptionText; - property Left: TDimension read GetLeft; - property Owner: TVirtualTreeColumns read GetOwner; - property SpringRest: Single read FSpringRest write FSpringRest; - 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 CaptionWidth: TDimension read GetCaptionWidth; - 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: string read FHint write FHint; - property ImageIndex: TImageIndex read FImageIndex write SetImageIndex default -1; - property Layout: TVTHeaderColumnLayout read FLayout write SetLayout default blGlyphLeft; - property Margin: TDimension read FMargin write SetMargin default 4; - property MaxWidth: TDimension read FMaxWidth write SetMaxWidth default 10000; - property MinWidth: TDimension read FMinWidth write SetMinWidth default 10; - property Options: TVTColumnOptions read FOptions write SetOptions default DefaultColumnOptions; - property EditOptions: TVTEditOptions read FEditOptions write FEditOptions default toDefaultEdit; - property EditNextColumn: TDimension read FEditNextColumn write FEditNextColumn default -1; - property Position: TColumnPosition read FPosition write SetPosition; - property Spacing: TDimension read FSpacing write SetSpacing default cDefaultColumnSpacing; - property Style: TVirtualTreeColumnStyle read FStyle write SetStyle default vsText; - property Tag: NativeInt read FTag write FTag default 0; - property Text: string read GetText write SetText; - property Width: TDimension 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: TDimension; // 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. - FColumnPopupMenu: TPopupMenu; // Member for storing the TVTHeaderPopupMenu - - function GetCount: TDimension; - function GetItem(Index: TColumnIndex): TVirtualTreeColumn; - function GetNewIndex(P: TPoint; var OldIndex: TColumnIndex): Boolean; - procedure SetDefaultWidth(Value: TDimension); - procedure SetItem(Index: TColumnIndex; Value: TVirtualTreeColumn); - protected - // drag support - FDragIndex: TColumnIndex; // index of column currently being dragged - FDropTarget: TColumnIndex; // current target column (index) while dragging - FDropBefore: Boolean; // True if drop position is in the left half of a column, False for the right - // side to drop the dragged column to - - procedure AdjustAutoSize(CurrentIndex: TColumnIndex; Force: Boolean = False); - function AdjustDownColumn(P: TPoint): TColumnIndex; - function AdjustHoverColumn(P: TPoint): Boolean; - procedure AdjustPosition(Column: TVirtualTreeColumn; Position: Cardinal); - function CanSplitterResize(P: TPoint; Column: TColumnIndex): Boolean; - procedure DoCanSplitterResize(P: TPoint; Column: TColumnIndex; var Allowed: Boolean); virtual; - procedure DrawButtonText(DC: HDC; Caption: string; Bounds: TRect; Enabled, Hot: Boolean; DrawFormat: Cardinal; - WrapCaption: Boolean); - procedure FixPositions; - function GetColumnAndBounds(P: TPoint; var ColumnLeft, ColumnRight: TDimension; Relative: Boolean = True): Integer; - function GetOwner: TPersistent; override; - function HandleClick(P: TPoint; Button: TMouseButton; Force, DblClick: Boolean): Boolean; virtual; - procedure HeaderPopupMenuAddHeaderPopupItem(const Sender: TBaseVirtualTree; const Column: TColumnIndex; - var Cmd: TAddPopupItemType); - procedure HeaderPopupMenuColumnChange(const Sender: TBaseVirtualTree; const Column: TColumnIndex; Visible: Boolean); - procedure IndexChanged(OldIndex, NewIndex: Integer); - procedure InitializePositionArray; - procedure Notify(Item: TCollectionItem; Action: System.Classes.TCollectionNotification); override; - procedure ReorderColumns(RTL: Boolean); - procedure SetHoverIndex(index : TColumnIndex); - 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 write FHoverIndex; - property DownIndex: TColumnIndex read FDownIndex write FDownIndex; - property CheckBoxHit: Boolean read FCheckBoxHit write FCheckBoxHit; - // Mitigator function to use the correct style service for this context (either the style assigned to the control for Delphi > 10.4 or the application style) - function StyleServices(AControl: TControl = nil): TCustomStyleServices; - public - constructor Create(AOwner: TVTHeader); virtual; - destructor Destroy; override; - - function Add: TVirtualTreeColumn; virtual; - procedure AnimatedResize(Column: TColumnIndex; NewWidth: TDimension); - procedure Assign(Source: TPersistent); override; - procedure Clear; virtual; - function ColumnFromPosition(P: TPoint; Relative: Boolean = True): TColumnIndex; overload; virtual; - function ColumnFromPosition(PositionIndex: TColumnPosition): TColumnIndex; overload; virtual; - function Equals(OtherColumnsObj: TObject): Boolean; override; - procedure GetColumnBounds(Column: TColumnIndex; var Left, Right: TDimension); - 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: TDimension; - function GetVisibleColumns: TColumnsArray; - function GetVisibleFixedWidth: TDimension; - function IsValidColumn(Column: TColumnIndex): Boolean; - procedure LoadFromStream(const Stream: TStream; Version: Integer); - procedure PaintHeader(DC: HDC; R: TRect; HOffset: TDimension); overload; virtual; - procedure PaintHeader(TargetCanvas: TCanvas; R: TRect; const Target: TPoint; - RTLOffset: TDimension = 0); overload; virtual; - procedure SaveToStream(const Stream: TStream); - procedure EndUpdate(); override; - function TotalWidth: TDimension; - - property Count: Integer read GetCount; - property ClickIndex: TColumnIndex read FClickIndex; - property DefaultWidth: TDimension read FDefaultWidth write SetDefaultWidth; - property DragIndex : TColumnIndex read FDragIndex write FDragIndex; - property DropBefore : boolean read FDropBefore write FDropBefore; - property DropTarget : TColumnIndex read FDropTarget write FDropTarget; - property Items[Index: TColumnIndex]: TVirtualTreeColumn read GetItem write SetItem; default; - property Header: TVTHeader read FHeader; - property TrackIndex: TColumnIndex read FTrackIndex write 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 95; - 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 - hoAutoColumnPopupMenu, // Show a context menu for activating and deactivating columns on right click - hoAutoResizeInclCaption // Includes the header caption for the auto resizing - ); - 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 @@ -1307,138 +487,6 @@ type 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: TDimension; - FFont: TFont; - FParentFont: Boolean; - FOptions: TVTHeaderOptions; - FStyle: TVTHeaderStyle; // button style - FBackgroundColor: TColor; - FAutoSizeIndex: TColumnIndex; - FPopupMenu: TPopupMenu; - FMainColumn: TColumnIndex; // the column which holds the tree - FMaxHeight: TDimension; - FMinHeight: TDimension; - FDefaultHeight: TDimension; - FFixedAreaConstraints: TVTFixedAreaConstraints; // Percentages for the fixed area (header, fixed columns). - FImages: TCustomImageList; - FImageChangeLink: TChangeLink; // connections to the image list to get notified about changes - fSplitterHitTolerance: TDimension; // For property SplitterHitTolerance - FSortColumn: TColumnIndex; - FSortDirection: TSortDirection; - FDragImage: TVTDragImage; // drag image management during header drag - FLastWidth: TDimension; // Used to adjust spring columns. This is the width of all visible columns, not the header rectangle. - FRestoreSelectionColumnIndex: Integer; // The column that is used to implement the coRestoreSelection option - function GetMainColumn: TColumnIndex; - function GetUseColumns: Boolean; - function IsFontStored: Boolean; - procedure SetAutoSizeIndex(Value: TColumnIndex); - procedure SetBackground(Value: TColor); - procedure SetColumns(Value: TVirtualTreeColumns); - procedure SetDefaultHeight(Value: TDimension); - procedure SetFont(const Value: TFont); - procedure SetHeight(Value: TDimension); - procedure SetImages(const Value: TCustomImageList); - procedure SetMainColumn(Value: TColumnIndex); - procedure SetMaxHeight(Value: TDimension); - procedure SetMinHeight(Value: TDimension); - procedure SetOptions(Value: TVTHeaderOptions); - procedure SetParentFont(Value: Boolean); - procedure SetSortColumn(Value: TColumnIndex); - procedure SetSortDirection(const Value: TSortDirection); - procedure SetStyle(Value: TVTHeaderStyle); - function GetRestoreSelectionColumnIndex: Integer; - 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. - FDoingAutoFitColumns: boolean; // Flag to avoid using the stored width for Main column - - procedure FontChanged(Sender: TObject); virtual; - procedure AutoScale(); virtual; - function CanSplitterResize(P: TPoint): Boolean; - function CanWriteColumns: Boolean; virtual; - procedure ChangeScale(M, D: TDimension; isDpiChange: Boolean); virtual; - function DetermineSplitterIndex(P: TPoint): Boolean; virtual; - procedure DoAfterAutoFitColumn(Column: TColumnIndex); virtual; - procedure DoAfterColumnWidthTracking(Column: TColumnIndex); virtual; - procedure DoAfterHeightTracking; virtual; - function DoBeforeAutoFitColumn(Column: TColumnIndex; SmartAutoFitType: TSmartAutoFitType): Boolean; virtual; - procedure DoBeforeColumnWidthTracking(Column: TColumnIndex; Shift: TShiftState); virtual; - procedure DoBeforeHeightTracking(Shift: TShiftState); virtual; - procedure DoCanSplitterResize(P: TPoint; var Allowed: Boolean); virtual; - function DoColumnWidthDblClickResize(Column: TColumnIndex; P: TPoint; Shift: TShiftState): Boolean; virtual; - function DoColumnWidthTracking(Column: TColumnIndex; Shift: TShiftState; var TrackPoint: TPoint; P: TPoint): Boolean; virtual; - function DoGetPopupMenu(Column: TColumnIndex; Position: TPoint): TPopupMenu; virtual; - function DoHeightTracking(var P: TPoint; Shift: TShiftState): Boolean; virtual; - function DoHeightDblClickResize(var P: TPoint; Shift: TShiftState): Boolean; virtual; - procedure DoSetSortColumn(Value: TColumnIndex; pSortDirection: TSortDirection); virtual; - procedure DragTo(P: TPoint); virtual; - procedure FixedAreaConstraintsChanged(Sender: TObject); - function GetColumnsClass: TVirtualTreeColumnsClass; virtual; - function GetOwner: TPersistent; override; - function GetShiftState: TShiftState; - function HandleHeaderMouseMove(var Message: TWMMouseMove): Boolean; - function HandleMessage(var Message: TMessage): Boolean; virtual; - procedure ImageListChange(Sender: TObject); - procedure PrepareDrag(P, Start: TPoint); - procedure ReadColumns(Reader: TReader); - procedure RecalculateHeader; virtual; - procedure RescaleHeader; - procedure UpdateMainColumn; - procedure UpdateSpringColumns; - procedure WriteColumns(Writer: TWriter); - public - constructor Create(AOwner: TBaseVirtualTree); virtual; - destructor Destroy; override; - - function AllowFocus(ColumnIndex: TColumnIndex): Boolean; - procedure Assign(Source: TPersistent); override; - procedure AutoFitColumns(Animated: Boolean = True; SmartAutoFitType: TSmartAutoFitType = smaUseColumnOption; - RangeStartCol: Integer = NoColumn; RangeEndCol: Integer = NoColumn); virtual; - function InHeader(P: TPoint): Boolean; virtual; - function InHeaderSplitterArea(P: TPoint): Boolean; virtual; - procedure Invalidate(Column: TVirtualTreeColumn; ExpandToBorder: Boolean = False; UpdateNowFlag : Boolean = False); - procedure LoadFromStream(const Stream: TStream); virtual; - function ResizeColumns(ChangeBy: TDimension; RangeStartCol: TColumnIndex; RangeEndCol: TColumnIndex; - Options: TVTColumnOptions = [coVisible]): TDimension; - procedure RestoreColumns; - procedure SaveToStream(const Stream: TStream); virtual; - procedure StyleChanged(); virtual; - - property DragImage: TVTDragImage read FDragImage; - property RestoreSelectionColumnIndex: Integer read GetRestoreSelectionColumnIndex write fRestoreSelectionColumnIndex default NoColumn; - property States: THeaderStates read FStates; - property Treeview: TBaseVirtualTree read FOwner; - property UseColumns: Boolean read GetUseColumns; - property doingAutoFitColumns: boolean read FDoingAutoFitColumns; - published - property AutoSizeIndex: TColumnIndex read FAutoSizeIndex write SetAutoSizeIndex; - property Background: TColor read FBackgroundColor write SetBackground default clBtnFace; - property Columns: TVirtualTreeColumns read FColumns write SetColumns stored False; // Stored by the owner tree to support VFI. - property DefaultHeight: Integer read FDefaultHeight write SetDefaultHeight default 19; - property Font: TFont read FFont write SetFont stored IsFontStored; - property FixedAreaConstraints: TVTFixedAreaConstraints read FFixedAreaConstraints write FFixedAreaConstraints; - property Height: Integer read FHeight write SetHeight default 19; - property Images: TCustomImageList read FImages write SetImages; - property MainColumn: TColumnIndex read GetMainColumn write SetMainColumn default 0; - property MaxHeight: Integer read FMaxHeight write SetMaxHeight default 10000; - property MinHeight: Integer read FMinHeight write SetMinHeight default 10; - property Options: TVTHeaderOptions read FOptions write SetOptions default [hoColumnResize, hoDrag, hoShowSortGlyphs]; - property ParentFont: Boolean read FParentFont write SetParentFont default True; - 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 SplitterHitTolerance: Integer read fSplitterHitTolerance write fSplitterHitTolerance default 8; // The area in pixels around a spliter which is sensitive for resizing - 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. @@ -1595,7 +643,6 @@ type // A collection of line type IDs which is used while painting a node. TLineImage = array of TVTLineType; - TVTScrollIncrement = 1..10000; // Export type TVTExportType = ( @@ -1615,106 +662,6 @@ type TVTColumnExportEvent = procedure (Sender: TBaseVirtualTree; aExportType: TVTExportType; Column: TVirtualTreeColumn) of object; TVTTreeExportEvent = procedure(Sender: TBaseVirtualTree; aExportType: TVTExportType) of object; - // A class to manage scroll bar aspects. - TScrollBarOptions = class(TPersistent) - private - FAlwaysVisible: Boolean; - FOwner: TBaseVirtualTree; - FScrollBars: TScrollStyle; // used to hide or show vertical and/or horizontal scrollbar - FScrollBarStyle: TScrollBarStyle; // kind of scrollbars to use - FIncrementX, - FIncrementY: TVTScrollIncrement; // number of pixels to scroll in one step (when auto scrolling) - procedure SetAlwaysVisible(Value: Boolean); - procedure SetScrollBars(Value: TScrollStyle); - procedure SetScrollBarStyle(Value: TScrollBarStyle); - protected - function GetOwner: TPersistent; override; - public - constructor Create(AOwner: TBaseVirtualTree); - - procedure Assign(Source: TPersistent); override; - published - property AlwaysVisible: Boolean read FAlwaysVisible write SetAlwaysVisible default False; - property HorizontalIncrement: TVTScrollIncrement read FIncrementX write FIncrementX default 20; - property ScrollBars: TScrollStyle read FScrollBars write SetScrollBars default ssBoth; - property ScrollBarStyle: TScrollBarStyle read FScrollBarStyle write SetScrollBarStyle default sbmRegular; - property VerticalIncrement: TVTScrollIncrement read FIncrementY write FIncrementY default 20; - end; - - // class to collect all switchable colors into one place - TVTColors = class(TPersistent) - private - type - TVTColorEnum =(cDisabledColor, cDropMarkColor, cDropTargetColor, cFocusedSelectionColor, - cGridLineColor, cTreeLineColor, cUnfocusedSelectionColor, cBorderColor, cHotColor, - cFocusedSelectionBorderColor, cUnfocusedSelectionBorderColor, cDropTargetBorderColor, - cSelectionRectangleBlendColor, cSelectionRectangleBorderColor, cHeaderHotColor, - cSelectionTextColor, cUnfocusedColor); - - // Please make sure that the published Color properties at the corresponding index - // have the same color if you change anything here! - const cDefaultColors : array[TVTColorEnum] of TColor = ( - clBtnShadow, // DisabledColor - clHighlight, // DropMarkColor - clHighLight, // DropTargetColor - clHighLight, // FocusedSelectionColor - clBtnFace, // GridLineColor - clBtnShadow, // TreeLineColor - clInactiveCaption, // UnfocusedSelectionColor - clBtnFace, // BorderColor - clWindowText, // HotColor - clHighLight, // FocusedSelectionBorderColor - clInactiveCaption, // UnfocusedSelectionBorderColor - clHighlight, // DropTargetBorderColor - clHighlight, // SelectionRectangleBlendColor - clHighlight, // SelectionRectangleBorderColor - clBtnShadow, // HeaderHotColor - clHighlightText, // SelectionTextColor - clInactiveCaptionText); // UnfocusedColor [IPK] - - private - FOwner: TBaseVirtualTree; - FColors: array[TVTColorEnum] of TColor; // [IPK] 15 -> 16 - function GetColor(const Index: TVTColorEnum): TColor; - procedure SetColor(const Index: TVTColorEnum; const Value: TColor); - function GetBackgroundColor: TColor; - function GetHeaderFontColor: TColor; - function GetNodeFontColor: TColor; - function GetSelectedNodeFontColor(Focused:boolean): 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; - // Mitigator function to use the correct style service for this context (either the style assigned to the control for Delphi > 10.4 or the application style) - function StyleServices(AControl: TControl = nil): TCustomStyleServices; - published - property BorderColor: TColor index cBorderColor read GetColor write SetColor default clBtnFace; - property DisabledColor: TColor index cDisabledColor read GetColor write SetColor default clBtnShadow; - property DropMarkColor: TColor index cDropMarkColor read GetColor write SetColor default clHighlight; - property DropTargetColor: TColor index cDropTargetColor read GetColor write SetColor default clHighLight; - property DropTargetBorderColor: TColor index cDropTargetBorderColor read GetColor write SetColor default clHighLight; - /// The background color of selected nodes in case the tree has the focus, or the toPopupMode flag is set. - property FocusedSelectionColor: TColor index cFocusedSelectionColor read GetColor write SetColor default clHighLight; - /// The border color of selected nodes when the tree has the focus. - property FocusedSelectionBorderColor: TColor index cFocusedSelectionBorderColor read GetColor write SetColor default clHighLight; - property GridLineColor: TColor index cGridLineColor read GetColor write SetColor default clBtnFace; - property HeaderHotColor: TColor index cHeaderHotColor read GetColor write SetColor default clBtnShadow; - property HotColor: TColor index cHotColor read GetColor write SetColor default clWindowText; - property SelectionRectangleBlendColor: TColor index cSelectionRectangleBlendColor read GetColor write SetColor default clHighlight; - property SelectionRectangleBorderColor: TColor index cSelectionRectangleBorderColor read GetColor write SetColor default clHighlight; - /// The text color of selected nodes - property SelectionTextColor: TColor index cSelectionTextColor read GetColor write SetColor default clHighlightText; - property TreeLineColor: TColor index cTreeLineColor read GetColor write SetColor default clBtnShadow; - property UnfocusedColor: TColor index cUnfocusedColor read GetColor write SetColor default clInactiveCaptionText; // [IPK] Added - /// The background color of selected nodes in case the tree does not have the focus and the toPopupMode flag is not set. - property UnfocusedSelectionColor: TColor index cUnfocusedSelectionColor read GetColor write SetColor default clInactiveCaption; - /// The border color of selected nodes in case the tree does not have the focus and the toPopupMode flag is not set. - property UnfocusedSelectionBorderColor: TColor index cUnfocusedSelectionBorderColor read GetColor write SetColor default clInactiveCaption; - end; - // For painting a node and its columns/cells a lot of information must be passed frequently around. TVTImageInfo = record Index: TImageIndex; // Index in the associated image list. @@ -1874,8 +821,7 @@ type TVTBeforeGetCheckStateEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode) of object; // header/column events - TVTHeaderAddPopupItemEvent = procedure(const Sender: TBaseVirtualTree; const Column: TColumnIndex; - var Cmd: TAddPopupItemType) of object; + TVTHeaderAddPopupItemEvent = procedure(const Sender: TObject; const Column: TColumnIndex; var Cmd: TAddPopupItemType) of object; 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; @@ -2372,7 +1318,6 @@ type procedure CMParentDoubleBufferedChange(var Message: TMessage); message CM_PARENTDOUBLEBUFFEREDCHANGED; procedure AdjustTotalCount(Node: PVirtualNode; Value: Integer; relative: Boolean = False); - procedure AdjustTotalHeight(Node: PVirtualNode; Value: Integer; relative: Boolean = False); function CalculateCacheEntryCount: Integer; procedure CalculateVerticalAlignments(var PaintInfo: TVTPaintInfo; var VButtonAlign: Integer); function ChangeCheckState(Node: PVirtualNode; Value: TCheckState): Boolean; @@ -2478,7 +1423,6 @@ type procedure SetVisiblePath(Node: PVirtualNode; Value: Boolean); procedure PrepareBackGroundPicture(Source: TPicture; DrawBitmap: TBitmap; DrawBitmapWidth: Integer; DrawBitMapHeight: Integer; ABkgcolor: TColor); procedure StaticBackground(Source: TPicture; Target: TCanvas; OffsetPosition: TPoint; R: TRect; aBkgColor: TColor); - procedure StopTimer(ID: Integer); procedure TileBackground(Source: TPicture; Target: TCanvas; Offset: TPoint; R: TRect; aBkgColor: TColor); function ToggleCallback(Step, StepSize: Integer; Data: Pointer): Boolean; @@ -2548,6 +1492,7 @@ type procedure AddToSelection(const NewItems: TNodeArray; NewLength: Integer; ForceInsert: Boolean = False); overload; virtual; procedure AdjustPaintCellRect(var PaintInfo: TVTPaintInfo; var NextNonEmpty: TColumnIndex); virtual; procedure AdjustPanningCursor(X, Y: Integer); virtual; + procedure AdjustTotalHeight(Node: PVirtualNode; Value: Integer; relative: Boolean = False); 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; @@ -2568,6 +1513,7 @@ type function CountVisibleChildren(Node: PVirtualNode): Cardinal; virtual; procedure CreateParams(var Params: TCreateParams); override; procedure CreateWnd; override; + procedure DecVisibleCount; procedure DefineProperties(Filer: TFiler); override; procedure DeleteNode(Node: PVirtualNode; Reindex: Boolean; ParentClearing: Boolean); overload; function DetermineDropMode(const P: TPoint; var HitInfo: THitInfo; var NodeRect: TRect): TDropMode; virtual; @@ -2737,6 +1683,7 @@ type procedure HandleClickSelection(LastFocused, NewNode: PVirtualNode; Shift: TShiftState; DragPending: Boolean); function HasImage(Node: PVirtualNode; Kind: TVTImageKind; Column: TColumnIndex): Boolean; virtual; deprecated 'Use GetImageSize instead'; function HasPopupMenu(Node: PVirtualNode; Column: TColumnIndex; Pos: TPoint): Boolean; virtual; + procedure IncVisibleCount; procedure InitChildren(Node: PVirtualNode); virtual; procedure InitNode(Node: PVirtualNode); virtual; procedure InternalAddFromStream(Stream: TStream; Version: Integer; Node: PVirtualNode); virtual; @@ -2748,6 +1695,7 @@ type procedure InternalConnectNode(Node, Destination: PVirtualNode; Target: TBaseVirtualTree; Mode: TVTNodeAttachMode); virtual; function InternalData(Node: PVirtualNode): Pointer; procedure InternalDisconnectNode(Node: PVirtualNode; KeepFocus: Boolean; Reindex: Boolean = True; ParentClearing: Boolean = False); virtual; + procedure InternalSetFocusedColumn(const index : TColumnIndex); procedure InternalRemoveFromSelection(Node: PVirtualNode); virtual; procedure InterruptValidation(pWaitForValidationTermination: Boolean = True); procedure InvalidateCache; @@ -2786,6 +1734,7 @@ type procedure SkipNode(Stream: TStream); virtual; procedure StartOperation(OperationKind: TVTOperationKind); procedure StartWheelPanning(Position: TPoint); virtual; + procedure StopTimer(ID: Integer); procedure StopWheelPanning; virtual; procedure StructureChange(Node: PVirtualNode; Reason: TChangeReason); virtual; function SuggestDropEffect(Source: TObject; Shift: TShiftState; Pt: TPoint; AllowedEffects: Integer): Integer; virtual; @@ -3079,6 +2028,7 @@ type function GetLastNoInit(Node: PVirtualNode = nil; ConsiderChildrenAbove: Boolean = False): PVirtualNode; function GetLastChild(Node: PVirtualNode): PVirtualNode; function GetLastChildNoInit(Node: PVirtualNode): PVirtualNode; + function GetLastSelected(ConsiderChildrenAbove: Boolean = False): PVirtualNode; function GetLastVisible(Node: PVirtualNode = nil; ConsiderChildrenAbove: Boolean = True; IncludeFiltered: Boolean = False): PVirtualNode; function GetLastVisibleChild(Node: PVirtualNode; IncludeFiltered: Boolean = False): PVirtualNode; @@ -3261,116 +2211,8 @@ type 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; - property EditOptions; - end; - TCustomVirtualStringTree = class; - // Edit support Classes. - TStringEditLink = class; - - TVTEdit = class(TCustomEdit) - private - procedure CMAutoAdjust(var Message: TMessage); message CM_AUTOADJUST; - procedure CMExit(var Message: TMessage); message CM_EXIT; - procedure CMRelease(var Message: TMessage); message CM_RELEASE; - procedure CNCommand(var Message: TWMCommand); message CN_COMMAND; - procedure WMChar(var Message: TWMChar); message WM_CHAR; - procedure WMDestroy(var Message: TWMDestroy); message WM_DESTROY; - procedure WMGetDlgCode(var Message: TWMGetDlgCode); message WM_GETDLGCODE; - procedure WMKeyDown(var Message: TWMKeyDown); message WM_KEYDOWN; - protected - FRefLink: IVTEditLink; - FLink: TStringEditLink; - procedure AutoAdjustSize; virtual; - function CalcMinHeight: Integer; virtual; - procedure CreateParams(var Params: TCreateParams); override; - function GetTextSize: TSize; virtual; - procedure KeyPress(var Key: Char); override; - public - constructor Create(Link: TStringEditLink); reintroduce; - procedure ClearLink; - procedure ClearRefLink; - 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 Alignment : TAlignment read FAlignment; - property Node : PVirtualNode read FNode; // [IPK] Make FNode accessible - property Column: TColumnIndex read FColumn; // [IPK] Make Column(Index) accessible - - function BeginEdit: Boolean; virtual; stdcall; - function CancelEdit: Boolean; virtual; stdcall; - property Edit: TVTEdit read FEdit write SetEdit; - function EndEdit: Boolean; virtual; stdcall; - function GetBounds: TRect; virtual; stdcall; - function PrepareEdit(Tree: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex): Boolean; virtual; stdcall; - procedure ProcessMessage(var Message: TMessage); virtual; stdcall; - procedure SetBounds(R: TRect); virtual; stdcall; - property Stopping : boolean read FStopping; - property Tree : TCustomVirtualStringTree read FTree; - end; // Describes the type of text to return in the text and draw info retrival events. TVSTTextType = ( @@ -3783,254 +2625,6 @@ type 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; - - [ComponentPlatformsAttribute(pidWin32 or pidWin64)] - TVirtualDrawTree = class(TCustomVirtualDrawTree) - private - function GetOptions: TVirtualTreeOptions; - procedure SetOptions(const Value: TVirtualTreeOptions); - protected - function GetOptionsClass: TTreeOptionsClass; override; - public - property Canvas; - property LastDragEffect; - property CheckImageKind; // should no more be published to make #622 fix working - published - property Action; - property Align; - property Alignment; - property Anchors; - property AnimationDuration; - property AutoExpandDelay; - property AutoScrollDelay; - property AutoScrollInterval; - property Background; - property BackgroundOffsetX; - property BackgroundOffsetY; - property BiDiMode; - property BevelEdges; - property BevelInner; - property BevelOuter; - property BevelKind; - property BevelWidth; - property BorderStyle; - property BottomSpace; - property ButtonFillMode; - property ButtonStyle; - property BorderWidth; - property ChangeDelay; - property ClipboardFormats; - property Color; - property Colors; - property Constraints; - property Ctl3D; - property CustomCheckImages; - property DefaultNodeHeight; - property DefaultPasteMode; - property DragCursor; - property DragHeight; - property DragKind; - property DragImageKind; - property DragMode; - property DragOperations; - property DragType; - property DragWidth; - property DrawSelectionMode; - property EditDelay; - property Enabled; - property Font; - property Header; - property HintMode; - property HotCursor; - property Images; - property IncrementalSearch; - property IncrementalSearchDirection; - property IncrementalSearchStart; - property IncrementalSearchTimeout; - property Indent; - property LineMode; - property LineStyle; - property Margin; - property NodeAlignment; - property NodeDataSize; - property OperationCanceled; - property ParentBiDiMode; - property ParentColor default False; - property ParentCtl3D; - property ParentFont; - property ParentShowHint; - property PopupMenu; - property RootNodeCount; - property ScrollBarOptions; - property SelectionBlendFactor; - property SelectionCurveRadius; - property ShowHint; - property StateImages; - property TabOrder; - property TabStop default True; - property TextMargin; - property TreeOptions: TVirtualTreeOptions read GetOptions write SetOptions; - property Visible; - property WantTabs; - - property OnAddToSelection; - property OnAdvancedHeaderDraw; - property OnAfterAutoFitColumn; - property OnAfterAutoFitColumns; - property OnAfterCellPaint; - property OnAfterColumnExport; - property OnAfterColumnWidthTracking; - property OnAfterGetMaxColumnWidth; - property OnAfterHeaderExport; - property OnAfterHeaderHeightTracking; - property OnAfterItemErase; - property OnAfterItemPaint; - property OnAfterNodeExport; - property OnAfterPaint; - property OnAfterTreeExport; - property OnBeforeAutoFitColumn; - property OnBeforeAutoFitColumns; - property OnBeforeCellPaint; - property OnBeforeColumnExport; - property OnBeforeColumnWidthTracking; - property OnBeforeDrawTreeLine; - property OnBeforeGetMaxColumnWidth; - property OnBeforeHeaderExport; - property OnBeforeHeaderHeightTracking; - property OnBeforeItemErase; - property OnBeforeItemPaint; - property OnBeforeNodeExport; - property OnBeforePaint; - property OnBeforeTreeExport; - property OnCanSplitterResizeColumn; - property OnCanSplitterResizeHeader; - property OnCanSplitterResizeNode; - property OnChange; - property OnChecked; - property OnChecking; - property OnClick; - property OnCollapsed; - property OnCollapsing; - property OnColumnClick; - property OnColumnDblClick; - property OnColumnExport; - property OnColumnResize; - property OnColumnVisibilityChanged; - 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 OnHeaderAddPopupItem; - 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 OnPrepareButtonBitmaps; - 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 OnCanResize; - property OnGesture; - property Touch; - property StyleElements; - end; - - // utility routines function TreeFromNode(Node: PVirtualNode): TBaseVirtualTree; @@ -4056,11 +2650,14 @@ uses VirtualTrees.AccessibilityFactory, VirtualTrees.StyleHooks, VirtualTrees.Classes, + VirtualTrees.DataObject, VirtualTrees.WorkerThread, VirtualTrees.ClipBoard, - VirtualTrees.Utils, + VirtualTrees.Utils, VirtualTrees.Export, - VirtualTrees.HeaderPopup; + VirtualTrees.HeaderPopup, + VirtualTrees.DragnDrop, + VirtualTrees.EditLink; resourcestring // Localizable strings. @@ -4085,27 +2682,7 @@ const // in the compiled binary file. Copyright: string = 'Virtual Treeview © 1999-2021 Mike Lischke, Joachim Marder'; -var - StandardOLEFormat: TFormatEtc = ( - // Format must later be set. - cfFormat: 0; - // No specific target device to render on. - ptd: nil; - // Normal content to render. - dwAspect: DVASPECT_CONTENT; - // No specific page of multipage data (we don't use multipage data by default). - lindex: -1; - // Acceptable storage formats are IStream and global memory. The first is preferred. - tymed: TYMED_ISTREAM or TYMED_HGLOBAL; - ); -type - // protection against TRect record method that cause problems with with-statements - TWithSafeRect = record - case Integer of - 0: (Left, Top, Right, Bottom: Integer); - 1: (TopLeft, BottomRight: TPoint); - end; type // streaming support TMagicID = array[0..5] of WideChar; @@ -4153,6 +2730,12 @@ type // streaming support TCanvasEx = class(TCanvas); + //These allow us access to protected members in the classes + TVirtualTreeColumnsCracker = class(TVirtualTreeColumns); + TVTHeaderCracker = class(TVTHeader); + TVirtualTreeColumnCracker = class(TVirtualTreeColumn); + + const MagicID: TMagicID = (#$2045, 'V', 'T', WideChar(VTTreeStreamVersion), ' ', #$2046); @@ -4203,19 +2786,6 @@ end; //---------------------------------------------------------------------------------------------------------------------- -/// Wrapper function for styles services that handles differences between RAD Studio 10.4 and older versions, -/// as well as the case if these controls are used inside the IDE. -function VTStyleServices(AControl: TControl = nil): TCustomStyleServices; -begin - if Assigned(VTStyleServicesFunc) then - Result := VTStyleServicesFunc(AControl) - else - Result := Vcl.Themes.StyleServices{$if CompilerVersion >= 34}(AControl){$ifend}; -end; - -//---------------------------------------------------------------------------------------------------------------------- - - procedure QuickSort(const TheArray: TNodeArray; L, R: Integer); var @@ -4463,11 +3033,6 @@ begin // Register the tree reference clipboard format. Others will be handled in InternalClipboarFormats. CF_VTREFERENCE := RegisterClipboardFormat(CFSTR_VTREFERENCE); - // Delphi (at least version 6 and lower) does not provide a standard split cursor. - // Hence we have to load our own. - Screen.Cursors[crHeaderSplit] := LoadCursor(HInstance, 'VT_HEADERSPLIT'); - Screen.Cursors[crVertSplit] := LoadCursor(HInstance, 'VT_VERTSPLIT'); - // Clipboard format registration. // Native clipboard format. Needs a new identifier and has an average priority to allow other formats to take over. // This format is supposed to use the IStream storage format but unfortunately this does not work when @@ -4511,981 +3076,6 @@ begin gWatcher := nil; 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.InternalSetMiscOptions(const Value: TVTMiscOptions); -begin - FMiscOptions := value; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TCustomVirtualTreeOptions.SetMiscOptions(const Value: TVTMiscOptions); - -var - ToBeSet, - ToBeCleared: TVTMiscOptions; - -begin - if FMiscOptions <> Value then - begin - ToBeSet := Value - FMiscOptions; - ToBeCleared := FMiscOptions - Value; - FMiscOptions := Value; - - with FOwner do - if not (csLoading in ComponentState) and HandleAllocated then - begin - if toCheckSupport in ToBeSet + ToBeCleared then - Invalidate; - if toEditOnDblClick in ToBeSet then - FMiscOptions := FMiscOptions - [toToggleOnDblClick]; // In order for toEditOnDblClick to take effect, we need to remove toToggleOnDblClick which is handled with priority. See issue #747 - - if not (csDesigning in ComponentState) then - begin - if toAcceptOLEDrop in ToBeCleared then - RevokeDragDrop(Handle); - if toFullRepaintOnResize in ToBeSet + ToBeCleared then - RecreateWnd; - if toAcceptOLEDrop in ToBeSet then - RegisterDragDrop(Handle, DragManager as IDropTarget); - if toVariableNodeHeight in ToBeSet then begin - BeginUpdate(); - try - ReInitNode(nil, True); - finally - EndUpdate(); - end;//try..finally - end;//if toVariableNodeHeight - 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 - begin - if (toUseExplorerTheme in ToBeSet) then - begin - SetWindowTheme('explorer'); - DoStateChange([tsUseExplorerTheme]); - end - else - if toUseExplorerTheme in ToBeCleared then - begin - SetWindowTheme(''); - DoStateChange([], [tsUseExplorerTheme]); - end; - 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) 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; - -function TCustomVirtualTreeOptions.StyleServices(AControl: TControl): TCustomStyleServices; -begin - Result := VTStyleServices(FOwner); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TCustomVirtualTreeOptions.AssignTo(Dest: TPersistent); - -begin - if Dest is TCustomVirtualTreeOptions then - begin - with Dest as TCustomVirtualTreeOptions do - begin - PaintOptions := Self.PaintOptions; - AnimationOptions := Self.AnimationOptions; - AutoOptions := Self.AutoOptions; - SelectionOptions := Self.SelectionOptions; - MiscOptions := Self.MiscOptions; - end; - end - else - inherited; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -// OLE drag and drop support classes -// This is quite heavy stuff (compared with the VCL implementation) but is much better suited to fit the needs -// of DD'ing various kinds of virtual data and works also between applications. - -//----------------- TEnumFormatEtc ------------------------------------------------------------------------------------- - -constructor TEnumFormatEtc.Create(Tree: TBaseVirtualTree; const AFormatEtcArray: TFormatEtcArray); - -var - I: Integer; - -begin - inherited Create; - - FTree := Tree; - // Make a local copy of the format data. - SetLength(FFormatEtcArray, Length(AFormatEtcArray)); - for I := 0 to High(AFormatEtcArray) do - FFormatEtcArray[I] := AFormatEtcArray[I]; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TEnumFormatEtc.Clone(out Enum: IEnumFormatEtc): HResult; - -var - AClone: TEnumFormatEtc; - -begin - Result := S_OK; - try - AClone := TEnumFormatEtc.Create(nil, FFormatEtcArray); - AClone.FCurrentIndex := FCurrentIndex; - Enum := AClone as IEnumFormatEtc; - except - Result := E_FAIL; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TEnumFormatEtc.Next(celt: Integer; out elt; pceltFetched: PLongint): HResult; - -var - CopyCount: Integer; - -begin - Result := S_FALSE; - CopyCount := Length(FFormatEtcArray) - FCurrentIndex; - if celt < CopyCount then - CopyCount := celt; - if CopyCount > 0 then - begin - Move(FFormatEtcArray[FCurrentIndex], elt, CopyCount * SizeOf(TFormatEtc)); - Inc(FCurrentIndex, CopyCount); - Result := S_OK; - end; - if Assigned(pceltFetched) then - pceltFetched^ := CopyCount; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TEnumFormatEtc.Reset: HResult; - -begin - FCurrentIndex := 0; - Result := S_OK; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TEnumFormatEtc.Skip(celt: Integer): HResult; - -begin - if FCurrentIndex + celt < High(FFormatEtcArray) then - begin - Inc(FCurrentIndex, celt); - Result := S_Ok; - end - else - Result := S_FALSE; -end; - -//----------------- TVTDataObject -------------------------------------------------------------------------------------- - -constructor TVTDataObject.Create(AOwner: TBaseVirtualTree; ForClipboard: Boolean); - -begin - inherited Create; - - FOwner := AOwner; - FForClipboard := ForClipboard; - FOwner.GetNativeClipboardFormats(FFormatEtcArray); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -destructor TVTDataObject.Destroy; - -var - I: Integer; - StgMedium: PStgMedium; - -begin - // Cancel a pending clipboard operation if this data object was created for the clipboard and - // is freed because something else is placed there. - if FForClipboard and not (tsClipboardFlushing in FOwner.TreeStates) then - FOwner.CancelCutOrCopy; - - // Release any internal clipboard formats - for I := 0 to High(FormatEtcArray) do - begin - StgMedium := FindInternalStgMedium(FormatEtcArray[I].cfFormat); - if Assigned(StgMedium) then - ReleaseStgMedium(StgMedium^); - end; - - FormatEtcArray := nil; - inherited; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTDataObject.CanonicalIUnknown(const TestUnknown: IUnknown): IUnknown; - -// Uses COM object identity: An explicit call to the IUnknown::QueryInterface method, requesting the IUnknown -// interface, will always return the same pointer. - -begin - if Assigned(TestUnknown) then - begin - if TestUnknown.QueryInterface(IUnknown, Result) = 0 then - Result._Release // Don't actually need it just need the pointer value - else - Result := TestUnknown; - end - else - Result := TestUnknown; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTDataObject.EqualFormatEtc(FormatEtc1, FormatEtc2: TFormatEtc): Boolean; - -begin - Result := (FormatEtc1.cfFormat = FormatEtc2.cfFormat) and (FormatEtc1.ptd = FormatEtc2.ptd) and - (FormatEtc1.dwAspect = FormatEtc2.dwAspect) and (FormatEtc1.lindex = FormatEtc2.lindex) and - (FormatEtc1.tymed and FormatEtc2.tymed <> 0); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTDataObject.FindFormatEtc(TestFormatEtc: TFormatEtc; const FormatEtcArray: TFormatEtcArray): integer; - -var - I: integer; - -begin - Result := -1; - for I := 0 to High(FormatEtcArray) do - begin - if EqualFormatEtc(TestFormatEtc, FormatEtcArray[I]) then - begin - Result := I; - Break; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTDataObject.FindInternalStgMedium(Format: TClipFormat): PStgMedium; - -var - I: integer; -begin - Result := nil; - for I := 0 to High(InternalStgMediumArray) do - begin - if Format = InternalStgMediumArray[I].Format then - begin - Result := @InternalStgMediumArray[I].Medium; - Break; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTDataObject.HGlobalClone(HGlobal: THandle): THandle; - -// Returns a global memory block that is a copy of the passed memory block. - -var - Size: Cardinal; - Data, - NewData: PByte; - -begin - Size := GlobalSize(HGlobal); - Result := GlobalAlloc(GPTR, Size); - Data := GlobalLock(hGlobal); - try - NewData := GlobalLock(Result); - try - Move(Data^, NewData^, Size); - finally - GlobalUnLock(Result); - end; - finally - GlobalUnLock(hGlobal); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTDataObject.RenderInternalOLEData(const FormatEtcIn: TFormatEtc; var Medium: TStgMedium; - var OLEResult: HResult): Boolean; - -// Tries to render one of the formats which have been stored via the SetData method. -// Since this data is already there it is just copied or its reference count is increased (depending on storage medium). - -var - InternalMedium: PStgMedium; - -begin - Result := True; - InternalMedium := FindInternalStgMedium(FormatEtcIn.cfFormat); - if Assigned(InternalMedium) then - OLEResult := StgMediumIncRef(InternalMedium^, Medium, False, Self as IDataObject) - else - Result := False; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTDataObject.StgMediumIncRef(const InStgMedium: TStgMedium; var OutStgMedium: TStgMedium; - CopyInMedium: Boolean; const DataObject: IDataObject): HRESULT; - -// InStgMedium is the data that is requested, OutStgMedium is the data that we are to return either a copy of or -// increase the IDataObject's reference and send ourselves back as the data (unkForRelease). The InStgMedium is usually -// the result of a call to find a particular FormatEtc that has been stored locally through a call to SetData. -// If CopyInMedium is not true we already have a local copy of the data when the SetData function was called (during -// that call the CopyInMedium must be true). Then as the caller asks for the data through GetData we do not have to make -// copy of the data for the caller only to have them destroy it then need us to copy it again if necessary. -// This way we increase the reference count to ourselves and pass the STGMEDIUM structure initially stored in SetData. -// This way when the caller frees the structure it sees the unkForRelease is not nil and calls Release on the object -// instead of destroying the actual data. - -var - Len: Integer; - -begin - Result := S_OK; - - // Simply copy all fields to start with. - OutStgMedium := InStgMedium; - // The data handled here always results from a call of SetData we got. This ensures only one storage format - // is indicated and hence the case statement below is safe (IDataObject.GetData can optionally use several - // storage formats). - case InStgMedium.tymed of - TYMED_HGLOBAL: - begin - if CopyInMedium then - begin - // Generate a unique copy of the data passed - OutStgMedium.hGlobal := HGlobalClone(InStgMedium.hGlobal); - if OutStgMedium.hGlobal = 0 then - Result := E_OUTOFMEMORY; - end - else - // Don't generate a copy just use ourselves and the copy previously saved. - OutStgMedium.unkForRelease := Pointer(DataObject); // Does not increase RefCount. - end; - TYMED_FILE: - begin - Len := lstrLenW(InStgMedium.lpszFileName) + 1; // Don't forget the terminating null character. - OutStgMedium.lpszFileName := CoTaskMemAlloc(2 * Len); - Move(InStgMedium.lpszFileName^, OutStgMedium.lpszFileName^, 2 * Len); - end; - TYMED_ISTREAM: - IUnknown(OutStgMedium.stm)._AddRef; - TYMED_ISTORAGE: - IUnknown(OutStgMedium.stg)._AddRef; - TYMED_GDI: - if not CopyInMedium then - // Don't generate a copy just use ourselves and the previously saved data. - OutStgMedium.unkForRelease := Pointer(DataObject) // Does not increase RefCount. - else - Result := DV_E_TYMED; // Don't know how to copy GDI objects right now. - TYMED_MFPICT: - if not CopyInMedium then - // Don't generate a copy just use ourselves and the previously saved data. - OutStgMedium.unkForRelease := Pointer(DataObject) // Does not increase RefCount. - else - Result := DV_E_TYMED; // Don't know how to copy MetaFile objects right now. - TYMED_ENHMF: - if not CopyInMedium then - // Don't generate a copy just use ourselves and the previously saved data. - OutStgMedium.unkForRelease := Pointer(DataObject) // Does not increase RefCount. - else - Result := DV_E_TYMED; // Don't know how to copy enhanced metafiles objects right now. - else - Result := DV_E_TYMED; - end; - - if (Result = S_OK) and Assigned(OutStgMedium.unkForRelease) then - IUnknown(OutStgMedium.unkForRelease)._AddRef; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTDataObject.DAdvise(const FormatEtc: TFormatEtc; advf: Integer; const advSink: IAdviseSink; - out dwConnection: Integer): HResult; - -// Advise sink management is greatly simplified by the IDataAdviseHolder interface. -// We use this interface and forward all concerning calls to it. - -begin - Result := S_OK; - if FAdviseHolder = nil then - Result := CreateDataAdviseHolder(FAdviseHolder); - if Result = S_OK then - Result := FAdviseHolder.Advise(Self as IDataObject, FormatEtc, advf, advSink, dwConnection); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTDataObject.DUnadvise(dwConnection: Integer): HResult; - -begin - if FAdviseHolder = nil then - Result := E_NOTIMPL - else - Result := FAdviseHolder.Unadvise(dwConnection); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTDataObject.EnumDAdvise(out enumAdvise: IEnumStatData): HResult; - -begin - if FAdviseHolder = nil then - Result := OLE_E_ADVISENOTSUPPORTED - else - Result := FAdviseHolder.EnumAdvise(enumAdvise); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTDataObject.EnumFormatEtc(Direction: Integer; out EnumFormatEtc: IEnumFormatEtc): HResult; - -var - NewList: TEnumFormatEtc; - -begin - Result := E_FAIL; - if Direction = DATADIR_GET then - begin - NewList := TEnumFormatEtc.Create(FOwner, FormatEtcArray); - EnumFormatEtc := NewList as IEnumFormatEtc; - Result := S_OK; - end - else - EnumFormatEtc := nil; - if EnumFormatEtc = nil then - Result := OLE_S_USEREG; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTDataObject.GetCanonicalFormatEtc(const FormatEtc: TFormatEtc; out FormatEtcOut: TFormatEtc): HResult; - -begin - Result := DATA_S_SAMEFORMATETC; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTDataObject.GetData(const FormatEtcIn: TFormatEtc; out Medium: TStgMedium): HResult; - -// Data is requested by clipboard or drop target. This method dispatchs the call -// depending on the data being requested. - -var - I: Integer; - Data: PVTReference; - -begin - // The tree reference format is always supported and returned from here. - if FormatEtcIn.cfFormat = CF_VTREFERENCE then - begin - // Note: this format is not used while flushing the clipboard to avoid a dangling reference - // when the owner tree is destroyed before the clipboard data is replaced with something else. - if tsClipboardFlushing in FOwner.TreeStates then - Result := E_FAIL - else - begin - Medium.hGlobal := GlobalAlloc(GHND or GMEM_SHARE, SizeOf(TVTReference)); - Data := GlobalLock(Medium.hGlobal); - Data.Process := GetCurrentProcessID; - Data.Tree := FOwner; - GlobalUnlock(Medium.hGlobal); - Medium.tymed := TYMED_HGLOBAL; - Medium.unkForRelease := nil; - Result := S_OK; - end; - end - else - begin - try - // See if we accept this type and if not get the correct return value. - Result := QueryGetData(FormatEtcIn); - if Result = S_OK then - begin - for I := 0 to High(FormatEtcArray) do - begin - if EqualFormatEtc(FormatEtcIn, FormatEtcArray[I]) then - begin - if not RenderInternalOLEData(FormatEtcIn, Medium, Result) then - Result := FOwner.RenderOLEData(FormatEtcIn, Medium, FForClipboard); - Break; - end; - end; - end; - except - ZeroMemory (@Medium, SizeOf(Medium)); - Result := E_FAIL; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTDataObject.GetDataHere(const FormatEtc: TFormatEtc; out Medium: TStgMedium): HResult; - -begin - Result := E_NOTIMPL; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTDataObject.QueryGetData(const FormatEtc: TFormatEtc): HResult; - -var - I: Integer; - -begin - Result := DV_E_CLIPFORMAT; - for I := 0 to High(FFormatEtcArray) do - begin - if FormatEtc.cfFormat = FFormatEtcArray[I].cfFormat then - begin - if (FormatEtc.tymed and FFormatEtcArray[I].tymed) <> 0 then - begin - if FormatEtc.dwAspect = FFormatEtcArray[I].dwAspect then - begin - if FormatEtc.lindex = FFormatEtcArray[I].lindex then - begin - Result := S_OK; - Break; - end - else - Result := DV_E_LINDEX; - end - else - Result := DV_E_DVASPECT; - end - else - Result := DV_E_TYMED; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTDataObject.SetData(const FormatEtc: TFormatEtc; var Medium: TStgMedium; DoRelease: BOOL): HResult; - -// Allows dynamic adding to the IDataObject during its existance. Most noteably it is used to implement -// IDropSourceHelper and allows to set a special format for optimized moves during a shell transfer. - -var - Index: Integer; - LocalStgMedium: PStgMedium; - -begin - // See if we already have a format of that type available. - Index := FindFormatEtc(FormatEtc, FormatEtcArray); - if Index > - 1 then - begin - // Just use the TFormatEct in the array after releasing the data. - LocalStgMedium := FindInternalStgMedium(FormatEtcArray[Index].cfFormat); - if Assigned(LocalStgMedium) then - begin - ReleaseStgMedium(LocalStgMedium^); - ZeroMemory(LocalStgMedium, SizeOf(LocalStgMedium^)); - end; - end - else - begin - // It is a new format so create a new TFormatCollectionItem, copy the - // FormatEtc parameter into the new object and and put it in the list. - SetLength(FFormatEtcArray, Length(FormatEtcArray) + 1); - FormatEtcArray[High(FormatEtcArray)] := FormatEtc; - - // Create a new InternalStgMedium and initialize it and associate it with the format. - SetLength(FInternalStgMediumArray, Length(InternalStgMediumArray) + 1); - InternalStgMediumArray[High(InternalStgMediumArray)].Format := FormatEtc.cfFormat; - LocalStgMedium := @InternalStgMediumArray[High(InternalStgMediumArray)].Medium; - ZeroMemory(LocalStgMedium, SizeOf(LocalStgMedium^)); - end; - - if DoRelease then - begin - // We are simply being given the data and we take control of it. - LocalStgMedium^ := Medium; - Result := S_OK; - end - else - begin - // We need to reference count or copy the data and keep our own references to it. - Result := StgMediumIncRef(Medium, LocalStgMedium^, True, Self as IDataObject); - - // Can get a circular reference if the client calls GetData then calls SetData with the same StgMedium. - // Because the unkForRelease for the IDataObject can be marshalled it is necessary to get pointers that - // can be correctly compared. See the IDragSourceHelper article by Raymond Chen at MSDN. - if Assigned(LocalStgMedium.unkForRelease) then - begin - if CanonicalIUnknown(Self) = CanonicalIUnknown(IUnknown(LocalStgMedium.unkForRelease)) then - IUnknown(LocalStgMedium.unkForRelease) := nil; // release the interface - end; - end; - - // Tell all registered advice sinks about the data change. - if Assigned(FAdviseHolder) then - FAdviseHolder.SendOnDataChange(Self as IDataObject, 0, 0); -end; - -//----------------- TVTDragManager ------------------------------------------------------------------------------------- - -constructor TVTDragManager.Create(AOwner: TBaseVirtualTree); - -begin - inherited Create; - FOwner := AOwner; - - // Create an instance of the drop target helper interface. This will fail but not harm on systems which do - // not support this interface (everything below Windows 2000); - CoCreateInstance(CLSID_DragDropHelper, nil, CLSCTX_INPROC_SERVER, IID_IDropTargetHelper, FDropTargetHelper); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -destructor TVTDragManager.Destroy; - -begin - // Set the owner's reference to us to nil otherwise it will access an invalid pointer - // after our desctruction is complete. - FOwner.ClearDragManager; - inherited; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTDragManager.GetDataObject: IDataObject; - -begin - // When the owner tree starts a drag operation then it gets a data object here to pass it to the OLE subsystem. - // In this case there is no local reference to a data object and one is created (but not stored). - // If there is a local reference then the owner tree is currently the drop target and the stored interface is - // that of the drag initiator. - if Assigned(FDataObject) then - Result := FDataObject - else - begin - Result := FOwner.DoCreateDataObject; - if (Result = nil) and not Assigned(FOwner.OnCreateDataObject) then - // Do not create a TVTDataObject if the event handler explicitely decided not to supply one, issue #736. - Result := TVTDataObject.Create(FOwner, False) as IDataObject; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTDragManager.GetDragSource: TBaseVirtualTree; - -begin - Result := FDragSource; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTDragManager.GetDropTargetHelperSupported: Boolean; - -begin - Result := Assigned(FDropTargetHelper); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTDragManager.GetIsDropTarget: Boolean; - -begin - Result := FIsDropTarget; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTDragManager.DragEnter(const DataObject: IDataObject; KeyState: Integer; Pt: TPoint; - var Effect: Integer): HResult; - -begin - FDataObject := DataObject; - FIsDropTarget := True; - - SystemParametersInfo(SPI_GETDRAGFULLWINDOWS, 0, @FFullDragging, 0); - // If full dragging of window contents is disabled in the system then our tree windows will be locked - // and cannot be updated during a drag operation. With the following call painting is again enabled. - if not FFullDragging then - LockWindowUpdate(0); - if Assigned(FDropTargetHelper) and FFullDragging then begin - if toAutoScroll in Self.FOwner.TreeOptions.AutoOptions then - FDropTargetHelper.DragEnter(FOwner.Handle, DataObject, Pt, Effect) - else - FDropTargetHelper.DragEnter(0, DataObject, Pt, Effect);// Do not pass handle, otherwise the IDropTargetHelper will perform autoscroll. Issue #486 - end; - FDragSource := FOwner.GetTreeFromDataObject(DataObject); - Result := FOwner.DragEnter(KeyState, Pt, Effect); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTDragManager.DragLeave: HResult; - -begin - if Assigned(FDropTargetHelper) and FFullDragging then - FDropTargetHelper.DragLeave; - - FOwner.DragLeave; - FIsDropTarget := False; - FDragSource := nil; - FDataObject := nil; - Result := NOERROR; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTDragManager.DragOver(KeyState: Integer; Pt: TPoint; var Effect: Integer): HResult; - -begin - if Assigned(FDropTargetHelper) and FFullDragging then - FDropTargetHelper.DragOver(Pt, Effect); - - Result := FOwner.DragOver(FDragSource, KeyState, dsDragMove, Pt, Effect); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTDragManager.Drop(const DataObject: IDataObject; KeyState: Integer; Pt: TPoint; - var Effect: Integer): HResult; - -begin - if Assigned(FDropTargetHelper) and FFullDragging then - FDropTargetHelper.Drop(DataObject, Pt, Effect); - - Result := FOwner.DragDrop(DataObject, KeyState, Pt, Effect); - FIsDropTarget := False; - FDataObject := nil; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTDragManager.ForceDragLeave; - -// Some drop targets, e.g. Internet Explorer leave a drag image on screen instead removing it when they receive -// a drop action. This method calls the drop target helper's DragLeave method to ensure it removes the drag image from -// screen. Unfortunately, sometimes not even this does help (e.g. when dragging text from VT to a text field in IE). - -begin - if Assigned(FDropTargetHelper) and FFullDragging then - FDropTargetHelper.DragLeave; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTDragManager.GiveFeedback(Effect: Integer): HResult; - -begin - Result := DRAGDROP_S_USEDEFAULTCURSORS; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTDragManager.QueryContinueDrag(EscapePressed: BOOL; KeyState: Integer): HResult; - -var - RButton, - LButton: Boolean; - -begin - LButton := (KeyState and MK_LBUTTON) <> 0; - RButton := (KeyState and MK_RBUTTON) <> 0; - - // Drag'n drop canceled by pressing both mouse buttons or Esc? - if (LButton and RButton) or EscapePressed then - Result := DRAGDROP_S_CANCEL - else - // Drag'n drop finished? - if not (LButton or RButton) then - Result := DRAGDROP_S_DROP - else - Result := S_OK; -end; - - //----------------- TVirtualTreeHintWindow ----------------------------------------------------------------------------- procedure TVirtualTreeHintWindow.CMTextChanged(var Message: TMessage); @@ -5701,7 +3291,7 @@ begin begin // Determine actual line break style depending on what was returned by the methods and what's in the node. if LineBreakStyle = hlbDefault then - if vsMultiline in Node.States then + if (vsMultiline in Node.States) or HintText.Contains(#13) then LineBreakStyle := hlbForceMultiLine else LineBreakStyle := hlbForceSingleLine; @@ -5817,545 +3407,6 @@ begin Result := False; end; -//----------------- TVTDragImage --------------------------------------------------------------------------------------- - -constructor TVTDragImage.Create(AOwner: TBaseVirtualTree); - -begin - FOwner := AOwner; - FTransparency := 128; - FPreBlendBias := 0; - FPostBlendBias := 0; - FFade := False; - FRestriction := dmrNone; - FColorKey := clNone; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -destructor TVTDragImage.Destroy; - -begin - EndDrag; - - inherited; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTDragImage.GetVisible: Boolean; - -// Returns True if the internal drag image is used (i.e. the system does not natively support drag images) and -// the internal image is currently visible on screen. - -begin - Result := FStates * [disHidden, disInDrag, disPrepared, disSystemSupport] = [disInDrag, disPrepared]; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTDragImage.InternalShowDragImage(ScreenDC: HDC); - -// Frequently called helper routine to actually do the blend and put it onto the screen. -// Only used if the system does not support drag images. - -var - BlendMode: TBlendMode; - -begin - with FAlphaImage do - BitBlt(Canvas.Handle, 0, 0, Width, Height, FBackImage.Canvas.Handle, 0, 0, SRCCOPY); - if not FFade and (FColorKey = clNone) then - BlendMode := bmConstantAlpha - else - BlendMode := bmMasterAlpha; - with FDragImage do - AlphaBlend(Canvas.Handle, FAlphaImage.Canvas.Handle, Rect(0, 0, Width, Height), Point(0, 0), BlendMode, - FTransparency, FPostBlendBias); - - with FAlphaImage do - BitBlt(ScreenDC, FImagePosition.X, FImagePosition.Y, Width, Height, Canvas.Handle, 0, 0, SRCCOPY); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTDragImage.MakeAlphaChannel(Source, Target: TBitmap); - -// Helper method to create a proper alpha channel in Target (which must be in 32 bit pixel format), depending -// on the settings for the drag image and the color values in Source. -// Only used if the system does not support drag images. - -type - PBGRA = ^TBGRA; - TBGRA = packed record - case Boolean of - False: - (Color: Cardinal); - True: - (BGR: array[0..2] of Byte; - Alpha: Byte); - end; - -var - Color, - ColorKeyRef: COLORREF; - UseColorKey: Boolean; - SourceRun, - TargetRun: PBGRA; - X, Y, - MaxDimension, - HalfWidth, - HalfHeight: Integer; - T: Extended; - -begin - UseColorKey := ColorKey <> clNone; - ColorKeyRef := ColorToRGB(ColorKey) and $FFFFFF; - // Color values are in the form BGR (red on LSB) while bitmap colors are in the form ARGB (blue on LSB) - // hence we have to swap red and blue in the color key. - with TBGRA(ColorKeyRef) do - begin - X := BGR[0]; - BGR[0] := BGR[2]; - BGR[2] := X; - end; - - with Target do - begin - MaxDimension := Max(Width, Height); - - HalfWidth := Width div 2; - HalfHeight := Height div 2; - for Y := 0 to Height - 1 do - begin - TargetRun := Scanline[Y]; - SourceRun := Source.Scanline[Y]; - for X := 0 to Width - 1 do - begin - Color := SourceRun.Color and $FFFFFF; - if UseColorKey and (Color = ColorKeyRef) then - TargetRun.Alpha := 0 - else - begin - // If the color is not the given color key (or none is used) then do full calculation of a bell curve. - T := Exp(-8 * Sqrt(Sqr((X - HalfWidth) / MaxDimension) + Sqr((Y - HalfHeight) / MaxDimension))); - TargetRun.Alpha := Round(255 * T); - end; - Inc(SourceRun); - Inc(TargetRun); - end; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTDragImage.DragTo(P: TPoint; ForceRepaint: Boolean): Boolean; - -// Moves the drag image to a new position, which is determined from the passed point P and the previous -// mouse position. -// ForceRepaint is True if something on the screen changed and the back image must be refreshed. - -var - ScreenDC: HDC; - DeltaX, - DeltaY: Integer; - - // optimized drag image move support - RSamp1, - RSamp2, // newly added parts from screen which will be overwritten - RDraw1, - RDraw2, // parts to be restored to screen - RScroll, - RClip: TRect; // ScrollDC of the existent background - -begin - // Determine distances to move the drag image. Take care for restrictions. - case FRestriction of - dmrHorizontalOnly: - begin - DeltaX := FLastPosition.X - P.X; - DeltaY := 0; - end; - dmrVerticalOnly: - begin - DeltaX := 0; - DeltaY := FLastPosition.Y - P.Y; - end; - else // dmrNone - DeltaX := FLastPosition.X - P.X; - DeltaY := FLastPosition.Y - P.Y; - end; - - Result := (DeltaX <> 0) or (DeltaY <> 0) or ForceRepaint; - if Result then - begin - if Visible then - begin - // All this stuff is only called if we have to handle the drag image ourselves. If the system supports - // drag image then this is all never executed. - ScreenDC := GetDC(0); - try - if (Abs(DeltaX) >= FDragImage.Width) or (Abs(DeltaY) >= FDragImage.Height) or ForceRepaint then - begin - // If moved more than image size then just restore old screen and blit image to new position. - BitBlt(ScreenDC, FImagePosition.X, FImagePosition.Y, FBackImage.Width, FBackImage.Height, - FBackImage.Canvas.Handle, 0, 0, SRCCOPY); - - if ForceRepaint then - UpdateWindow(FOwner.Handle); - - Inc(FImagePosition.X, -DeltaX); - Inc(FImagePosition.Y, -DeltaY); - - BitBlt(FBackImage.Canvas.Handle, 0, 0, FBackImage.Width, FBackImage.Height, ScreenDC, FImagePosition.X, - FImagePosition.Y, SRCCOPY); - end - else - begin - // overlapping copy - FillDragRectangles(FDragImage.Width, FDragImage.Height, DeltaX, DeltaY, RClip, RScroll, RSamp1, RSamp2, RDraw1, - RDraw2); - - with FBackImage.Canvas do - begin - // restore uncovered areas of the screen - if DeltaX = 0 then - begin - with TWithSafeRect(RDraw2) do - BitBlt(ScreenDC, FImagePosition.X + Left, FImagePosition.Y + Top, Right, Bottom, Handle, Left, Top, - SRCCOPY); - end - else - begin - if DeltaY = 0 then - begin - with TWithSafeRect(RDraw1) do - BitBlt(ScreenDC, FImagePosition.X + Left, FImagePosition.Y + Top, Right, Bottom, Handle, Left, Top, - SRCCOPY); - end - else - begin - with TWithSafeRect(RDraw1) do - BitBlt(ScreenDC, FImagePosition.X + Left, FImagePosition.Y + Top, Right, Bottom, Handle, Left, Top, - SRCCOPY); - with TWithSafeRect(RDraw2) do - BitBlt(ScreenDC, FImagePosition.X + Left, FImagePosition.Y + Top, Right, Bottom, Handle, Left, Top, - SRCCOPY); - end; - end; - - // move existent background - ScrollDC(Handle, DeltaX, DeltaY, RScroll, RClip, 0, nil); - - Inc(FImagePosition.X, -DeltaX); - Inc(FImagePosition.Y, -DeltaY); - - // Get first and second additional rectangle from screen. - if DeltaX = 0 then - begin - with TWithSafeRect(RSamp2) do - BitBlt(Handle, Left, Top, Right, Bottom, ScreenDC, FImagePosition.X + Left, FImagePosition.Y + Top, - SRCCOPY); - end - else - if DeltaY = 0 then - begin - with TWithSafeRect(RSamp1) do - BitBlt(Handle, Left, Top, Right, Bottom, ScreenDC, FImagePosition.X + Left, FImagePosition.Y + Top, - SRCCOPY); - end - else - begin - with TWithSafeRect(RSamp1) do - BitBlt(Handle, Left, Top, Right, Bottom, ScreenDC, FImagePosition.X + Left, FImagePosition.Y + Top, - SRCCOPY); - with TWithSafeRect(RSamp2) do - BitBlt(Handle, Left, Top, Right, Bottom, ScreenDC, FImagePosition.X + Left, FImagePosition.Y + Top, - SRCCOPY); - end; - end; - end; - InternalShowDragImage(ScreenDC); - finally - ReleaseDC(0, ScreenDC); - end; - end; - FLastPosition.X := P.X; - FLastPosition.Y := P.Y; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTDragImage.EndDrag; - -begin - HideDragImage; - FStates := FStates - [disInDrag, disPrepared]; - - FBackImage.Free; - FBackImage := nil; - FDragImage.Free; - FDragImage := nil; - FAlphaImage.Free; - FAlphaImage := nil; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTDragImage.GetDragImageRect: TRect; - -// Returns the current size and position of the drag image (screen coordinates). - -begin - if Visible then - begin - with FBackImage do - Result := Rect(FImagePosition.X, FImagePosition.Y, FImagePosition.X + Width, FImagePosition.Y + Height); - end - else - Result := Rect(0, 0, 0, 0); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTDragImage.HideDragImage; - -var - ScreenDC: HDC; - -begin - if Visible then - begin - Include(FStates, disHidden); - ScreenDC := GetDC(0); - try - // restore screen - with FBackImage do - BitBlt(ScreenDC, FImagePosition.X, FImagePosition.Y, Width, Height, Canvas.Handle, 0, 0, SRCCOPY); - finally - ReleaseDC(0, ScreenDC); - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTDragImage.PrepareDrag(DragImage: TBitmap; ImagePosition, HotSpot: TPoint; const DataObject: IDataObject); - -// Creates all necessary structures to do alpha blended dragging using the given image. -// ImagePostion and HotSpot are given in screen coordinates. The first determines where to place the drag image while -// the second is the initial mouse position. -// This method also determines whether the system supports drag images natively. If so then only minimal structures -// are created. - -var - Width, - Height: Integer; - DragSourceHelper: IDragSourceHelper; - DragInfo: TSHDragImage; - lDragSourceHelper2: IDragSourceHelper2;// Needed to get Windows Vista+ style drag hints. - lNullPoint: TPoint; -begin - Width := DragImage.Width; - Height := DragImage.Height; - - // Determine whether the system supports the drag helper interfaces. - if Assigned(DataObject) and Succeeded(CoCreateInstance(CLSID_DragDropHelper, nil, CLSCTX_INPROC_SERVER, - IDragSourceHelper, DragSourceHelper)) then - begin - Include(FStates, disSystemSupport); - lNullPoint := Point(0,0); - if Supports(DragSourceHelper, IDragSourceHelper2, lDragSourceHelper2) then - lDragSourceHelper2.SetFlags(DSH_ALLOWDROPDESCRIPTIONTEXT);// Show description texts - // First let the system try to initialze the DragSourceHelper, this works fine for file system objects (CF_HDROP) - StandardOLEFormat.cfFormat := CF_HDROP; - if not Succeeded(DataObject.QueryGetData(StandardOLEFormat)) or not Succeeded(DragSourceHelper.InitializeFromWindow(0, lNullPoint, DataObject)) then - begin - // Supply the drag source helper with our drag image. - DragInfo.sizeDragImage.cx := Width; - DragInfo.sizeDragImage.cy := Height; - DragInfo.ptOffset.x := Width div 2; - DragInfo.ptOffset.y := Height div 2; - DragInfo.hbmpDragImage := CopyImage(DragImage.Handle, IMAGE_BITMAP, Width, Height, LR_COPYRETURNORG); - DragInfo.crColorKey := ColorToRGB(FColorKey); - if not Succeeded(DragSourceHelper.InitializeFromBitmap(@DragInfo, DataObject)) then - begin - DeleteObject(DragInfo.hbmpDragImage); - Exclude(FStates, disSystemSupport); - end; - end; - end - else - Exclude(FStates, disSystemSupport); - - if not (disSystemSupport in FStates) then - begin - FLastPosition := HotSpot; - - FDragImage := TBitmap.Create; - FDragImage.PixelFormat := pf32Bit; - FDragImage.SetSize(Width, Height); - - FAlphaImage := TBitmap.Create; - FAlphaImage.PixelFormat := pf32Bit; - FAlphaImage.SetSize(Width, Height); - - FBackImage := TBitmap.Create; - FBackImage.PixelFormat := pf32Bit; - FBackImage.SetSize(Width, Height); - - // Copy the given drag image and apply pre blend bias if required. - if FPreBlendBias = 0 then - with FDragImage do - BitBlt(Canvas.Handle, 0, 0, Width, Height, DragImage.Canvas.Handle, 0, 0, SRCCOPY) - else - AlphaBlend(DragImage.Canvas.Handle, FDragImage.Canvas.Handle, Rect(0, 0, Width, Height), Point(0, 0), - bmConstantAlpha, 255, FPreBlendBias); - - // Create a proper alpha channel also if no fading is required (transparent parts). - MakeAlphaChannel(DragImage, FDragImage); - - FImagePosition := ImagePosition; - - // Initially the drag image is hidden and will be shown during the immediately following DragEnter event. - FStates := FStates + [disInDrag, disHidden, disPrepared]; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTDragImage.RecaptureBackground(Tree: TBaseVirtualTree; R: TRect; VisibleRegion: HRGN; - CaptureNCArea, ReshowDragImage: Boolean); - -// Notification by the drop target tree to update the background image because something in the tree has changed. -// Note: The passed rectangle is given in client coordinates of the current drop target tree (given in Tree). -// The caller does not check if the given rectangle is actually within the drag image. Hence this method must do -// all the checks. -// This method does nothing if the system manages the drag image. - -var - DragRect, - ClipRect: TRect; - PaintTarget: TPoint; - PaintOptions: TVTInternalPaintOptions; - ScreenDC: HDC; - -begin - // Recapturing means we want the tree to paint the new part into our back bitmap instead to the screen. - if Visible then - begin - // Create the minimum rectangle to be recaptured. - MapWindowPoints(Tree.Handle, 0, R, 2); - DragRect := GetDragImageRect; - IntersectRect(R, R, DragRect); - - OffsetRgn(VisibleRegion, -DragRect.Left, -DragRect.Top); - - // The target position for painting in the drag image is relative and can be determined from screen coordinates too. - PaintTarget.X := R.Left - DragRect.Left; - PaintTarget.Y := R.Top - DragRect.Top; - - // The source rectangle is determined by the offsets in the tree. - MapWindowPoints(0, Tree.Handle, R, 2); - OffsetRect(R, -Tree.FOffsetX, -Tree.FOffsetY); - - // Finally let the tree paint the relevant part and upate the drag image on screen. - PaintOptions := [poBackground, poColumnColor, poDrawFocusRect, poDrawDropMark, poDrawSelection, poGridLines]; - with FBackImage do - begin - ClipRect.TopLeft := PaintTarget; - ClipRect.Right := ClipRect.Left + R.Right - R.Left; - ClipRect.Bottom := ClipRect.Top + R.Bottom - R.Top; - // TODO: somehow with clipping, the background image is not drawn on the - // backup image. Need to be diagnosed and fixed. For now, we have coded - // a work around in DragTo where this is used by using the condition - // IsInHeader. (found when solving issue 248) - ClipCanvas(Canvas, ClipRect, VisibleRegion); - Tree.PaintTree(Canvas, R, PaintTarget, PaintOptions); - - if CaptureNCArea then - begin - // Header is painted in this part only so when you use this routine and want - // to capture the header in backup image, this flag should be ON. - // For the non-client area we only need the visible region of the window as limit for painting. - SelectClipRgn(Canvas.Handle, VisibleRegion); - // Since WM_PRINT cannot be given a position where to draw we simply move the window origin and - // get the same effect. - GetWindowRect(Tree.Handle, ClipRect); - SetCanvasOrigin(Canvas, DragRect.Left - ClipRect.Left, DragRect.Top - ClipRect.Top); - Tree.Perform(WM_PRINT, WPARAM(Canvas.Handle), PRF_NONCLIENT); - SetCanvasOrigin(Canvas, 0, 0); - end; - SelectClipRgn(Canvas.Handle, 0); - - if ReshowDragImage then - begin - GDIFlush; - ScreenDC := GetDC(0); - try - InternalShowDragImage(ScreenDC); - finally - ReleaseDC(0, ScreenDC); - end; - end; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTDragImage.ShowDragImage; - -// Shows the drag image after it has been hidden by HideDragImage. -// Note: there might be a new background now. -// Also this method does nothing if the system manages the drag image. - -var - ScreenDC: HDC; - -begin - if FStates * [disInDrag, disHidden, disPrepared, disSystemSupport] = [disInDrag, disHidden, disPrepared] then - begin - Exclude(FStates, disHidden); - - GDIFlush; - ScreenDC := GetDC(0); - try - BitBlt(FBackImage.Canvas.Handle, 0, 0, FBackImage.Width, FBackImage.Height, ScreenDC, FImagePosition.X, - FImagePosition.Y, SRCCOPY); - - InternalShowDragImage(ScreenDC); - finally - ReleaseDC(0, ScreenDC); - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTDragImage.WillMove(P: TPoint): Boolean; - -// This method determines whether the drag image would "physically" move when DragTo would be called with the same -// target point. -// Always returns False if the system drag image support is available. - -begin - Result := Visible; - if Result then - begin - // Determine distances to move the drag image. Take care for restrictions. - case FRestriction of - dmrHorizontalOnly: - Result := FLastPosition.X <> P.X; - dmrVerticalOnly: - Result := FLastPosition.Y <> P.Y; - else // dmrNone - Result := (FLastPosition.X <> P.X) or (FLastPosition.Y <> P.Y); - end; - end; -end; //----------------- TVTVirtualNodeEnumerator --------------------------------------------------------------------------- @@ -6490,5588 +3541,8 @@ begin end; end; -//----------------- TVirtualTreeColumn --------------------------------------------------------------------------------- -constructor TVirtualTreeColumn.Create(Collection: TCollection); -begin - FMinWidth := 10; - FMaxWidth := 10000; - FImageIndex := -1; - FMargin := 4; - FSpacing := cDefaultColumnSpacing; - 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; - fEditNextColumn := -1; - - inherited Create(Collection); - - if Assigned(Owner) then begin - FWidth := Owner.FDefaultWidth; - FLastWidth := Owner.FDefaultWidth; - FPosition := Owner.Count - 1; - end; -end; - -procedure TVirtualTreeColumn.SetCollection(Value: TCollection); -begin - inherited; - // 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.GetCaptionWidth: TDimension; -var - Theme: HTHEME; - AdvancedOwnerDraw: Boolean; - PaintInfo: THeaderPaintInfo; - RequestedElements: THeaderPaintElements; - - TextSize: TSize; - HeaderGlyphSize: TPoint; - UseText: Boolean; - R: TRect; -begin - AdvancedOwnerDraw := (hoOwnerDraw in Owner.Header.Options) and Assigned(Owner.Header.Treeview.FOnAdvancedHeaderDraw) and Assigned(Owner.Header.Treeview.FOnHeaderDrawQueryElements) and - not(csDesigning in Owner.Header.Treeview.ComponentState); - - PaintInfo.Column := Self; - PaintInfo.TargetCanvas := Owner.FHeaderBitmap.Canvas; - - with PaintInfo, Column do - begin - ShowHeaderGlyph := (hoShowImages in Owner.Header.Options) and ((Assigned(Owner.Header.Images) and (FImageIndex > -1)) or FCheckBox); - ShowSortGlyph := ((Owner.Header.FSortColumn > -1) and (Self = Owner.Items[Owner.Header.SortColumn])) and (hoShowSortGlyphs in Owner.Header.Options); - - // This path for text columns or advanced owner draw. - // See if the application wants to draw part of the header itself. - RequestedElements := []; - if AdvancedOwnerDraw then - begin - PaintInfo.Column := Self; - Owner.Header.Treeview.DoHeaderDrawQueryElements(PaintInfo, RequestedElements); - end; - end; - - UseText := Length(FText) > 0; - // If nothing is to show then don't waste time with useless preparation. - if not(UseText or PaintInfo.ShowHeaderGlyph or PaintInfo.ShowSortGlyph) then - Exit(0); - - // Calculate sizes of the involved items. - with Owner, Header do - begin - if PaintInfo.ShowHeaderGlyph then - if not FCheckBox then - begin - if Assigned(FImages) then - HeaderGlyphSize := Point(FImages.Width, FImages.Height); - end - 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 PaintInfo.ShowSortGlyph then - begin - if tsUseExplorerTheme in FHeader.Treeview.FStates then - begin - R := Rect(0, 0, 100, 100); - Theme := OpenThemeData(FHeader.Treeview.Handle, 'HEADER'); - GetThemePartSize(Theme, PaintInfo.TargetCanvas.Handle, HP_HEADERSORTARROW, HSAS_SORTEDUP, @R, TS_TRUE, PaintInfo.SortGlyphSize); - CloseThemeData(Theme); - end - else - begin - PaintInfo.SortGlyphSize.cx := Header.Treeview.ScaledPixels(16); - PaintInfo.SortGlyphSize.cy := Header.Treeview.ScaledPixels(4); - end; - end - else - begin - PaintInfo.SortGlyphSize.cx := 0; - PaintInfo.SortGlyphSize.cy := 0; - end; - end; - - if UseText then - begin - GetTextExtentPoint32W(PaintInfo.TargetCanvas.Handle, PWideChar(FText), Length(FText), TextSize); - Inc(TextSize.cx, 2); - end - else - begin - TextSize.cx := 0; - TextSize.cy := 0; - end; - - // if CalculateTextRect then - Result := TextSize.cx; - if PaintInfo.ShowHeaderGlyph then - if Layout in [blGlyphLeft, blGlyphRight] then - Inc(Result, HeaderGlyphSize.X + FSpacing) - else // if Layout in [ blGlyphTop, blGlyphBottom] then - Result := Max(Result, HeaderGlyphSize.X); - if PaintInfo.ShowSortGlyph then - Inc(Result, PaintInfo.SortGlyphSize.cx + FSpacing + 2); // without this +2, there is a slight movement of the sort glyph when expanding the column - -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); - Exclude(FOptions, coStyleColor); // Issue #919 - Changed(False); - Owner.Header.TreeView.Invalidate; - end; -end; - -function TVirtualTreeColumn.GetEffectiveColor(): TColor; -// Returns the color that should effectively be used as background color for this -// column considering all flags in the TVirtualTreeColumn.Options property -begin - if (coParentColor in Options) or ((coStyleColor in Options) and Owner.Header.TreeView.VclStyleEnabled) then - Result := Owner.Header.TreeView.FColors.BackGroundColor - else - Result := Self.Color; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumn.SetCheckBox(Value: Boolean); - -begin - if Value <> FCheckBox then - begin - FCheckBox := Value; - if Value and (csDesigning in Owner.Header.Treeview.ComponentState) then - Owner.Header.Options := Owner.Header.Options + [hoShowImages]; - Changed(False); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumn.SetCheckState(Value: TCheckState); - -begin - if Value <> FCheckState then - begin - FCheckState := Value; - Changed(False); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumn.SetCheckType(Value: TCheckType); - -begin - if Value <> FCheckType then - begin - FCheckType := Value; - Changed(False); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumn.SetImageIndex(Value: TImageIndex); - -begin - if Value <> FImageIndex then - begin - FImageIndex := Value; - Changed(False); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumn.SetLayout(Value: TVTHeaderColumnLayout); - -begin - if FLayout <> Value then - begin - FLayout := Value; - Changed(False); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumn.SetMargin(Value: Integer); - -begin - // Compatibility setting for -1. - if Value < 0 then - Value := 4; - if FMargin <> Value then - begin - FMargin := Value; - Changed(False); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumn.SetMaxWidth(Value: Integer); - -begin - if Value < FMinWidth then - Value := FMinWidth; - FMaxWidth := Value; - SetWidth(FWidth); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumn.SetMinWidth(Value: Integer); - -begin - if Value < 0 then - Value := 0; - if Value > FMaxWidth then - Value := FMaxWidth; - FMinWidth := Value; - SetWidth(FWidth); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumn.SetOptions(Value: TVTColumnOptions); - -var - ToBeSet, - ToBeCleared: TVTColumnOptions; - VisibleChanged, - lParentColorSet: Boolean; - lTreeView: TBaseVirtualTree; -begin - if FOptions <> Value then - begin - ToBeCleared := FOptions - Value; - ToBeSet := Value - FOptions; - - FOptions := Value; - - VisibleChanged := coVisible in (ToBeSet + ToBeCleared); - lParentColorSet := coParentColor in ToBeSet; - - if coParentBidiMode in ToBeSet then - ParentBiDiModeChanged; - if lParentColorSet then begin - Include(FOptions, coStyleColor);// Issue #919 - ParentColorChanged(); - end; - - if coAutoSpring in ToBeSet then - FSpringRest := 0; - - if coVisible in ToBeCleared then - Owner.Header.UpdateMainColumn(); // Fixes issue #946 - - 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. - lTreeView := Owner.Header.Treeview; - if not (csLoading in lTreeview.ComponentState) and (VisibleChanged or lParentColorSet) and (Owner.UpdateCount = 0) and lTreeView.HandleAllocated then - begin - lTreeview.Invalidate(); - if VisibleChanged then begin - lTreeview.DoColumnVisibilityChanged(Self.Index, coVisible in ToBeSet); - lTreeview.UpdateHorizontalScrollBar(False); - end; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumn.SetPosition(Value: TColumnPosition); - -var - Temp: TColumnIndex; - -begin - if (csLoading in Owner.Header.Treeview.ComponentState) or (Owner.UpdateCount > 0) 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: string); - -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.Header.States) 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].Options = [coVisible, coFixed]) then - begin - Inc(TotalFixedMaxWidth, FColumns[I].MaxWidth); - Inc(TotalFixedMinWidth, FColumns[I].MinWidth); - end; - - if HandleAllocated then // Prevent premature creation of window handle, see issue #1073 - begin - // The percentage values have precedence over the pixel values. - If FMaxWidthPercent > 0 then - TotalFixedMinWidth:= Min((ClientWidth * FMaxWidthPercent) div 100, TotalFixedMinWidth); - If FMinWidthPercent > 0 then - TotalFixedMaxWidth := Max((ClientWidth * FMinWidthPercent) div 100, 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;// if HandleAllocated - 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; - if not (hoAutoResize in Owner.Header.Options) or (Index <> Owner.Header.AutoSizeIndex) then - begin - FWidth := Value; - Owner.UpdatePositions; - end; - if not (csLoading in Owner.Header.Treeview.ComponentState) and (Owner.UpdateCount = 0) then - begin - if hoAutoResize in Owner.Header.Options then - Owner.AdjustAutoSize(Index); - Owner.Header.Treeview.DoColumnResize(Index); - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumn.ChangeScale(M, D: TDimension; isDpiChange: Boolean); -begin - FMinWidth := MulDiv(FMinWidth, M, D); - FMaxWidth := MulDiv(FMaxWidth, M, D); - FSpacing := MulDiv(FSpacing, M, D); - Self.Width := MulDiv(Self.Width, M, D); -end; - -procedure TVirtualTreeColumn.ComputeHeaderLayout(var PaintInfo: THeaderPaintInfo; DrawFormat: Cardinal; CalculateTextRect: Boolean = False); - -// The layout of a column header is determined by a lot of factors. This method takes them all into account and -// determines all necessary positions and bounds: -// - for the header text -// - the header glyph -// - the sort glyph - -var - TextSize: TSize; - TextPos, - ClientSize, - HeaderGlyphSize: TPoint; - CurrentAlignment: TAlignment; - MinLeft, - MaxRight, - TextSpacing: Integer; - UseText: Boolean; - R: TRect; - Theme: HTHEME; - -begin - UseText := Length(FText) > 0; - // If nothing is to show then don't waste time with useless preparation. - if not (UseText or PaintInfo.ShowHeaderGlyph or PaintInfo.ShowSortGlyph) then - Exit; - - CurrentAlignment := CaptionAlignment; - if FBiDiMode <> bdLeftToRight then - ChangeBiDiModeAlignment(CurrentAlignment); - - // Calculate sizes of the involved items. - ClientSize := Point(PaintInfo.PaintRectangle.Right - PaintInfo.PaintRectangle.Left, PaintInfo.PaintRectangle.Bottom - PaintInfo.PaintRectangle.Top); - with Owner, Header do - begin - if PaintInfo.ShowHeaderGlyph 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 PaintInfo.ShowSortGlyph then - begin - if tsUseExplorerTheme in FHeader.Treeview.FStates then - begin - R := Rect(0, 0, 100, 100); - Theme := OpenThemeData(FHeader.Treeview.Handle, 'HEADER'); - GetThemePartSize(Theme, PaintInfo.TargetCanvas.Handle, HP_HEADERSORTARROW, HSAS_SORTEDUP, @R, TS_TRUE, PaintInfo.SortGlyphSize); - CloseThemeData(Theme); - end - else - begin - PaintInfo.SortGlyphSize.cx := Header.Treeview.ScaledPixels(16); - PaintInfo.SortGlyphSize.cy := Header.Treeview.ScaledPixels(4); - end; - - // In any case, the sort glyph is vertically centered. - PaintInfo.SortGlyphPos.Y := (ClientSize.Y - PaintInfo.SortGlyphSize.cy) div 2; - end - else - begin - PaintInfo.SortGlyphSize.cx := 0; - PaintInfo.SortGlyphSize.cy := 0; - end; - end; - - if UseText then - begin - if not (coWrapCaption in FOptions) then - begin - FCaptionText := FText; - GetTextExtentPoint32W(PaintInfo.TargetCanvas.Handle, PWideChar(FText), Length(FText), TextSize); - Inc(TextSize.cx, 2); - PaintInfo.TextRectangle := Rect(0, 0, TextSize.cx, TextSize.cy); - end - else - begin - R := PaintInfo.PaintRectangle; - if FCaptionText = '' then - FCaptionText := WrapString(PaintInfo.TargetCanvas.Handle, FText, R, DT_RTLREADING and DrawFormat <> 0, DrawFormat); - - GetStringDrawRect(PaintInfo.TargetCanvas.Handle, FCaptionText, R, DrawFormat); - TextSize.cx := PaintInfo.PaintRectangle.Right - PaintInfo.PaintRectangle.Left; - TextSize.cy := R.Bottom - R.Top; - PaintInfo.TextRectangle := 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 PaintInfo.ShowSortGlyph and not (UseText or PaintInfo.ShowHeaderGlyph) then - begin - // Center the sort glyph in the available area if nothing else is there. - PaintInfo.SortGlyphPos := Point((ClientSize.X - PaintInfo.SortGlyphSize.cx) div 2, (ClientSize.Y - PaintInfo.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 PaintInfo.ShowHeaderGlyph then - begin - PaintInfo.GlyphPos.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 - PaintInfo.GlyphPos.Y := (ClientSize.Y - HeaderGlyphSize.Y - TextSize.cy - TextSpacing) div 2; - TextPos.Y := PaintInfo.GlyphPos.Y + HeaderGlyphSize.Y + TextSpacing; - end - else - begin - TextPos.Y := (ClientSize.Y - HeaderGlyphSize.Y - TextSize.cy - TextSpacing) div 2; - PaintInfo.GlyphPos.Y := TextPos.Y + TextSize.cy + TextSpacing; - end; - end; - - // Each alignment needs special consideration. - case CurrentAlignment of - taLeftJustify: - begin - MinLeft := FMargin; - if PaintInfo.ShowSortGlyph and (FBiDiMode <> bdLeftToRight) then - begin - // In RTL context is the sort glyph placed on the left hand side. - PaintInfo.SortGlyphPos.X := MinLeft; - Inc(MinLeft, PaintInfo.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 PaintInfo.ShowHeaderGlyph then - begin - PaintInfo.GlyphPos.X := (ClientSize.X - HeaderGlyphSize.X) div 2; - if PaintInfo.GlyphPos.X < MinLeft then - PaintInfo.GlyphPos.X := MinLeft; - MinLeft := Max(TextPos.X + TextSize.cx + TextSpacing, PaintInfo.GlyphPos.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 PaintInfo.ShowHeaderGlyph and (Layout = blGlyphLeft) then - begin - PaintInfo.GlyphPos.X := MinLeft; - Inc(MinLeft, HeaderGlyphSize.X + FSpacing); - end; - TextPos.X := MinLeft; - Inc(MinLeft, TextSize.cx + TextSpacing); - if PaintInfo.ShowHeaderGlyph and (Layout = blGlyphRight) then - begin - PaintInfo.GlyphPos.X := MinLeft; - Inc(MinLeft, HeaderGlyphSize.X + FSpacing); - end; - end; - if PaintInfo.ShowSortGlyph and (FBiDiMode = bdLeftToRight) then - PaintInfo.SortGlyphPos.X := MinLeft; - end; - taCenter: - begin - if Layout in [blGlyphTop, blGlyphBottom] then - begin - PaintInfo.GlyphPos.X := (ClientSize.X - HeaderGlyphSize.X) div 2; - TextPos.X := (ClientSize.X - TextSize.cx) div 2; - if PaintInfo.ShowSortGlyph then - Dec(TextPos.X, PaintInfo.SortGlyphSize.cx div 2); - end - else - begin - MinLeft := (ClientSize.X - HeaderGlyphSize.X - TextSpacing - TextSize.cx) div 2; - if PaintInfo.ShowHeaderGlyph and (Layout = blGlyphLeft) then - begin - PaintInfo.GlyphPos.X := MinLeft; - Inc(MinLeft, HeaderGlyphSize.X + TextSpacing); - end; - TextPos.X := MinLeft; - Inc(MinLeft, TextSize.cx + TextSpacing); - if PaintInfo.ShowHeaderGlyph and (Layout = blGlyphRight) then - PaintInfo.GlyphPos.X := MinLeft; - end; - if PaintInfo.ShowHeaderGlyph then - begin - MinLeft := Min(PaintInfo.GlyphPos.X, TextPos.X); - MaxRight := Max(PaintInfo.GlyphPos.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 PaintInfo.ShowSortGlyph then - if FBiDiMode = bdLeftToRight then - begin - // Sort glyph on the right hand side. - PaintInfo.SortGlyphPos.X := MaxRight + FSpacing; - end - else - begin - // Sort glyph on the left hand side. - PaintInfo.SortGlyphPos.X := MinLeft - FSpacing - PaintInfo.SortGlyphSize.cx; - end; - end; - else - // taRightJustify - MaxRight := ClientSize.X - FMargin; - if PaintInfo.ShowSortGlyph and (FBiDiMode = bdLeftToRight) then - begin - // In LTR context is the sort glyph placed on the right hand side. - Dec(MaxRight, PaintInfo.SortGlyphSize.cx); - PaintInfo.SortGlyphPos.X := MaxRight; - Dec(MaxRight, FSpacing); - end; - if Layout in [blGlyphTop, blGlyphBottom] then - begin - TextPos.X := MaxRight - TextSize.cx; - if PaintInfo.ShowHeaderGlyph then - begin - PaintInfo.GlyphPos.X := (ClientSize.X - HeaderGlyphSize.X) div 2; - if PaintInfo.GlyphPos.X + HeaderGlyphSize.X + FSpacing > MaxRight then - PaintInfo.GlyphPos.X := MaxRight - HeaderGlyphSize.X - FSpacing; - MaxRight := Min(TextPos.X - TextSpacing, PaintInfo.GlyphPos.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 PaintInfo.ShowHeaderGlyph and (Layout = blGlyphRight) then - begin - PaintInfo.GlyphPos.X := MaxRight - HeaderGlyphSize.X; - MaxRight := PaintInfo.GlyphPos.X - FSpacing; - end; - TextPos.X := MaxRight - TextSize.cx; - MaxRight := TextPos.X - TextSpacing; - if PaintInfo.ShowHeaderGlyph and (Layout = blGlyphLeft) then - begin - PaintInfo.GlyphPos.X := MaxRight - HeaderGlyphSize.X; - MaxRight := PaintInfo.GlyphPos.X - FSpacing; - end; - end; - if PaintInfo.ShowSortGlyph and (FBiDiMode <> bdLeftToRight) then - PaintInfo.SortGlyphPos.X := MaxRight - PaintInfo.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 PaintInfo.ShowSortGlyph then - begin - if FBiDiMode = bdLeftToRight then - begin - // Sort glyph on the right hand side. - if PaintInfo.SortGlyphPos.X + PaintInfo.SortGlyphSize.cx > MaxRight then - PaintInfo.SortGlyphPos.X := MaxRight - PaintInfo.SortGlyphSize.cx; - MaxRight := PaintInfo.SortGlyphPos.X - FSpacing; - end; - - // Consider also the left side of the sort glyph regardless of the bidi mode. - if PaintInfo.SortGlyphPos.X < MinLeft then - PaintInfo.SortGlyphPos.X := MinLeft; - // Left border needs only adjustment if the sort glyph marks the left border. - if FBiDiMode <> bdLeftToRight then - MinLeft := PaintInfo.SortGlyphPos.X + PaintInfo.SortGlyphSize.cx + FSpacing; - - // Finally transform sort glyph to its actual position. - Inc(PaintInfo.SortGlyphPos.X, PaintInfo.PaintRectangle.Left); - Inc(PaintInfo.SortGlyphPos.Y, PaintInfo.PaintRectangle.Top); - end; - if PaintInfo.ShowHeaderGlyph then - begin - if PaintInfo.GlyphPos.X + HeaderGlyphSize.X > MaxRight then - PaintInfo.GlyphPos.X := MaxRight - HeaderGlyphSize.X; - if Layout = blGlyphRight then - MaxRight := PaintInfo.GlyphPos.X - FSpacing; - if PaintInfo.GlyphPos.X < MinLeft then - PaintInfo.GlyphPos.X := MinLeft; - if Layout = blGlyphLeft then - MinLeft := PaintInfo.GlyphPos.X + HeaderGlyphSize.X + FSpacing; - if FCheckBox and (Owner.Header.MainColumn = Self.Index) then - Dec(PaintInfo.GlyphPos.X, 2) - else - if Owner.Header.MainColumn <> Self.Index then - Dec(PaintInfo.GlyphPos.X, 2); - - // Finally transform header glyph to its actual position. - Inc(PaintInfo.GlyphPos.X, PaintInfo.PaintRectangle.Left); - Inc(PaintInfo.GlyphPos.Y, PaintInfo.PaintRectangle.Top); - end; - if UseText then - begin - if TextPos.X < MinLeft then - TextPos.X := MinLeft; - OffsetRect(PaintInfo.TextRectangle, TextPos.X, TextPos.Y); - if PaintInfo.TextRectangle.Right > MaxRight then - PaintInfo.TextRectangle.Right := MaxRight; - OffsetRect(PaintInfo.TextRectangle, PaintInfo.PaintRectangle.Left, PaintInfo.PaintRectangle.Top); - - if coWrapCaption in FOptions then - begin - // Wrap the column caption if necessary. - R := PaintInfo.TextRectangle; - FCaptionText := WrapString(PaintInfo.TargetCanvas.Handle, FText, R, DT_RTLREADING and DrawFormat <> 0, DrawFormat); - GetStringDrawRect(PaintInfo.TargetCanvas.Handle, FCaptionText, R, DrawFormat); - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumn.DefineProperties(Filer: TFiler); - -begin - inherited; - - // These properites are remains from non-Unicode Delphi versions, readers remain for backward compatibility. - Filer.DefineProperty('WideText', ReadText, nil, False); - Filer.DefineProperty('WideHint', ReadHint, nil, False); -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; -begin - Result := FText // Use column header caption as display name -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVirtualTreeColumn.GetOwner: TVirtualTreeColumns; - -begin - Result := Collection as TVirtualTreeColumns; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumn.InternalSetWidth(const value : TDimension); -begin - FWidth := value; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumn.ReadText(Reader: TReader); - -begin - case Reader.NextValue of - vaLString, vaString: - SetText(Reader.ReadString); - else - SetText(Reader.ReadString); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumn.ReadHint(Reader: TReader); - -begin - case Reader.NextValue of - vaLString, vaString: - FHint := Reader.ReadString; - else - FHint := Reader.ReadString; - end; -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; - EditOptions := TVirtualTreeColumn(Source).EditOptions; - EditNextColumn := TVirtualTreeColumn(Source).EditNextColumn; - - // 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(PWideChar(S)^, 2 * Dummy); - Text := S; - ReadBuffer(Dummy, SizeOf(Dummy)); - SetLength(FHint, Dummy); - ReadBuffer(PWideChar(FHint)^, 2 * Dummy); - ReadBuffer(Dummy, SizeOf(Dummy)); - Width := Dummy; - ReadBuffer(Dummy, SizeOf(Dummy)); - MinWidth := Dummy; - ReadBuffer(Dummy, SizeOf(Dummy)); - MaxWidth := Dummy; - ReadBuffer(Dummy, SizeOf(Dummy)); - Style := TVirtualTreeColumnStyle(Dummy); - ReadBuffer(Dummy, SizeOf(Dummy)); - ImageIndex := Dummy; - ReadBuffer(Dummy, SizeOf(Dummy)); - Layout := TVTHeaderColumnLayout(Dummy); - ReadBuffer(Dummy, SizeOf(Dummy)); - Margin := Dummy; - ReadBuffer(Dummy, SizeOf(Dummy)); - Spacing := Dummy; - ReadBuffer(Dummy, SizeOf(Dummy)); - BiDiMode := TBiDiMode(Dummy); - - ReadBuffer(Dummy, SizeOf(Dummy)); - if Version >= 3 then - Options := TVTColumnOptions(Dummy); - - if Version > 0 then - begin - // Parts which have been introduced/changed with header stream version 1+. - ReadBuffer(Dummy, SizeOf(Dummy)); - Tag := Dummy; - ReadBuffer(Dummy, SizeOf(Dummy)); - Alignment := TAlignment(Dummy); - - if Version > 1 then - begin - ReadBuffer(Dummy, SizeOf(Dummy)); - Color := TColor(Dummy); - end; - - if Version > 5 then - begin - if coUseCaptionAlignment in FOptions then - begin - ReadBuffer(Dummy, SizeOf(Dummy)); - CaptionAlignment := TAlignment(Dummy); - end; - end; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumn.ParentBiDiModeChanged; - -var - Columns: TVirtualTreeColumns; - -begin - if coParentBiDiMode in FOptions then - begin - Columns := GetOwner as TVirtualTreeColumns; - if Assigned(Columns) and (FBiDiMode <> Columns.FHeader.Treeview.BiDiMode) then - begin - FBiDiMode := Columns.FHeader.Treeview.BiDiMode; - Changed(False); - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumn.ParentColorChanged; - -var - Columns: TVirtualTreeColumns; - -begin - if coParentColor in FOptions then - begin - Columns := GetOwner as TVirtualTreeColumns; - if Assigned(Columns) and (FColor <> Columns.FHeader.Treeview.Color) then - begin - FColor := Columns.FHeader.Treeview.Color; - Changed(False); - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumn.RestoreLastWidth; - -begin - TVirtualTreeColumns(GetOwner).AnimatedResize(Index, FLastWidth); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumn.SaveToStream(const Stream: TStream); - -var - Dummy: Integer; - -begin - with Stream do - begin - Dummy := Length(FText); - WriteBuffer(Dummy, SizeOf(Dummy)); - WriteBuffer(PWideChar(FText)^, 2 * Dummy); - Dummy := Length(FHint); - WriteBuffer(Dummy, SizeOf(Dummy)); - WriteBuffer(PWideChar(FHint)^, 2 * Dummy); - WriteBuffer(FWidth, SizeOf(FWidth)); - WriteBuffer(FMinWidth, SizeOf(FMinWidth)); - WriteBuffer(FMaxWidth, SizeOf(FMaxWidth)); - Dummy := Ord(FStyle); - WriteBuffer(Dummy, SizeOf(Dummy)); - Dummy := FImageIndex; - WriteBuffer(Dummy, SizeOf(Dummy)); - Dummy := Ord(FLayout); - WriteBuffer(Dummy, SizeOf(Dummy)); - WriteBuffer(FMargin, SizeOf(FMargin)); - WriteBuffer(FSpacing, SizeOf(FSpacing)); - Dummy := Ord(FBiDiMode); - WriteBuffer(Dummy, SizeOf(Dummy)); - Dummy := Integer(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; - Self.FColumnPopupMenu := nil; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -destructor TVirtualTreeColumns.Destroy; - -begin - FreeAndNil(FColumnPopupMenu); - FreeAndNil(FHeaderBitmap); - inherited; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVirtualTreeColumns.GetCount: Integer; - -begin - Result := inherited Count; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVirtualTreeColumns.GetItem(Index: TColumnIndex): TVirtualTreeColumn; - -begin - Result := TVirtualTreeColumn(inherited GetItem(Index)); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVirtualTreeColumns.GetNewIndex(P: TPoint; var OldIndex: TColumnIndex): Boolean; - -var - NewIndex: Integer; - -begin - Result := False; - // convert to local coordinates - Inc(P.Y, FHeader.Height); - NewIndex := ColumnFromPosition(P); - if NewIndex <> OldIndex then - begin - if OldIndex > NoColumn then - FHeader.Invalidate(Items[OldIndex], False, True); - OldIndex := NewIndex; - if OldIndex > NoColumn then - FHeader.Invalidate(Items[OldIndex], False, True); - 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; - -function TVirtualTreeColumns.StyleServices(AControl: TControl): TCustomStyleServices; -begin - if AControl = nil then - AControl := FHeader.Treeview; - Result := VTStyleServices(AControl); -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.AutoSizeIndex; - 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].Options) 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.Height); - Result := ColumnFromPosition(P); - if (Result > NoColumn) and (Result <> FDownIndex) and (coAllowClick in Items[Result].Options) and - (coEnabled in Items[Result].Options) then - begin - if FDownIndex > NoColumn then - FHeader.Invalidate(Items[FDownIndex]); - FDownIndex := Result; - FCheckBoxHit := Items[Result].HasImage and PtInRect(Items[Result].ImageRect, P) and Items[Result].CheckBox; - FHeader.Invalidate(Items[FDownIndex]); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVirtualTreeColumns.AdjustHoverColumn(P: TPoint): Boolean; - -// Determines the new hover column index and returns True if the index actually changed else False. - -begin - Result := GetNewIndex(P, FHoverIndex); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumns.AdjustPosition(Column: TVirtualTreeColumn; Position: Cardinal); - -// Reorders the column position array so that the given column gets the given position. - -var - OldPosition: Cardinal; - -begin - OldPosition := Column.Position; - if OldPosition <> Position then - begin - if OldPosition < Position then - begin - // column will be moved up so move down other entries - Move(FPositionToIndex[OldPosition + 1], FPositionToIndex[OldPosition], (Position - OldPosition) * SizeOf(Cardinal)); - end - else - begin - // column will be moved down so move up other entries - Move(FPositionToIndex[Position], FPositionToIndex[Position + 1], (OldPosition - Position) * SizeOf(Cardinal)); - end; - FPositionToIndex[Position] := Column.Index; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVirtualTreeColumns.CanSplitterResize(P: TPoint; Column: TColumnIndex): Boolean; - -begin - Result := (Column > NoColumn) and ([coResizable, coVisible] * Items[Column].Options = [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; - Size: TSize; - -begin - if not WrapCaption then - begin - // Do we need to shorten the caption due to limited space? - GetTextExtentPoint32W(DC, PWideChar(Caption), Length(Caption), Size); - TextSpace := Bounds.Right - Bounds.Left; - if TextSpace < Size.cx then - Caption := ShortenString(DC, Caption, TextSpace); - end; - - SetBkMode(DC, TRANSPARENT); - if not Enabled then - if FHeader.Treeview.VclStyleEnabled then - begin - SetTextColor(DC, ColorToRGB(FHeader.Treeview.FColors.HeaderFontColor)); - Winapi.Windows.DrawTextW(DC, PWideChar(Caption), Length(Caption), Bounds, DrawFormat); - end - else - begin - OffsetRect(Bounds, 1, 1); - SetTextColor(DC, ColorToRGB(clBtnHighlight)); - Winapi.Windows.DrawTextW(DC, PWideChar(Caption), Length(Caption), Bounds, DrawFormat); - OffsetRect(Bounds, -1, -1); - SetTextColor(DC, ColorToRGB(clBtnShadow)); - Winapi.Windows.DrawTextW(DC, PWideChar(Caption), Length(Caption), Bounds, DrawFormat); - end - else - begin - if Hot then - SetTextColor(DC, ColorToRGB(FHeader.Treeview.FColors.HeaderHotColor)) - else - SetTextColor(DC, ColorToRGB(FHeader.Treeview.FColors.HeaderFontColor)); - Winapi.Windows.DrawTextW(DC, PWideChar(Caption), Length(Caption), Bounds, DrawFormat); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumns.FixPositions; - -// Fixes column positions after loading from DFM or Bidi mode change. - -var - I: Integer; - -begin - for I := 0 to Count - 1 do - FPositionToIndex[Items[I].Position] := I; - - FNeedPositionsFix := False; - UpdatePositions(True); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVirtualTreeColumns.GetColumnAndBounds(P: TPoint; var ColumnLeft, ColumnRight: Integer; - Relative: Boolean = True): Integer; - -// Returns the column where the mouse is currently in as well as the left and right bound of -// this column (Left and Right are undetermined if no column is involved). - -var - I: Integer; - -begin - Result := InvalidColumn; - if Relative and (P.X >= Header.Columns.GetVisibleFixedWidth) then - ColumnLeft := -FHeader.Treeview.FEffectiveOffsetX - else - ColumnLeft := 0; - - if FHeader.Treeview.UseRightToLeftAlignment then - Inc(ColumnLeft, FHeader.Treeview.ComputeRTLOffset(True)); - - for I := 0 to Count - 1 do - with Items[FPositionToIndex[I]] do - if coVisible in FOptions then - begin - ColumnRight := ColumnLeft + FWidth; - - //fix: in right to left alignment, X can be in the - //area on the left of first column which is OUT. - if (P.X < ColumnLeft) and (I = 0) then - begin - Result := InvalidColumn; - exit; - end; - if P.X < ColumnRight then - begin - Result := FPositionToIndex[I]; - Exit; - end; - ColumnLeft := ColumnRight; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVirtualTreeColumns.GetOwner: TPersistent; - -begin - Result := FHeader; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVirtualTreeColumns.HandleClick(P: TPoint; Button: TMouseButton; Force, DblClick: Boolean): 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). -// Returns true if the click was handled, False otherwise. - -var - HitInfo: TVTHeaderHitInfo; - NewClickIndex: Integer; - Menu: TPopupMenu; -begin - Result := False; - if (csDesigning in Header.Treeview.ComponentState) then - exit; - // Convert vertical position to local coordinates. - Inc(P.Y, FHeader.Height); - 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].Options) and - ((NewClickIndex = FDownIndex) or Force) then - begin - FClickIndex := NewClickIndex; - HitInfo.Column := NewClickIndex; - HitInfo.HitPosition := [hhiOnColumn]; - - if Items[NewClickIndex].HasImage and PtInRect(Items[NewClickIndex].ImageRect, 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 DblClick then - FHeader.Treeview.DoHeaderDblClick(HitInfo) - else begin - if (hoHeaderClickAutoSort in Header.Options) and (HitInfo.Button = mbLeft) 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.DoSetSortColumn(HitInfo.Column, Self[HitInfo.Column].DefaultSortDirection); - end//if - else - begin - // toggle sort direction - if Header.SortDirection = sdDescending then - Header.SortDirection := sdAscending - else - Header.SortDirection := sdDescending; - end;//else - Result := True; - end;//if - - if (Button = mbRight) then - begin - Dec(P.Y, FHeader.Height); // popup menus at actual clicked point - FreeAndNil(fColumnPopupMenu);// Attention: Do not free the TVTHeaderPopupMenu at the end of this method, otherwise the clikc events of the menu item will not be fired. - Self.FDownIndex := NoColumn; - Self.FTrackIndex := NoColumn; - Self.FCheckBoxHit := False; - Menu := Header.DoGetPopupMenu(Self.ColumnFromPosition(Point(P.X, P.Y + Integer(Header.Treeview.Height))), P); - if Assigned(Menu) then - begin - Header.Treeview.StopTimer(ScrollTimer); - Header.Treeview.StopTimer(HeaderTimer); - Header.Columns.SetHoverIndex(NoColumn); - Header.Treeview.DoStateChange([], [tsScrollPending, tsScrolling]); - - Menu.PopupComponent := Header.Treeview; - With Header.Treeview.ClientToScreen(P) do - Menu.Popup(X, Y); - Result := True; - end - else if (hoAutoColumnPopupMenu in Header.Options) then - begin - fColumnPopupMenu := TVTHeaderPopupMenu.Create(Header.TreeView); - TVTHeaderPopupMenu(fColumnPopupMenu).OnAddHeaderPopupItem := HeaderPopupMenuAddHeaderPopupItem; - TVTHeaderPopupMenu(fColumnPopupMenu).OnColumnChange := HeaderPopupMenuColumnChange; - fColumnPopupMenu.PopupComponent := Header.Treeview; - if (hoDblClickResize in Header.Options) and ((Header.Treeview.ChildCount[nil] > 0) or (hoAutoResizeInclCaption in Header.Options)) then - TVTHeaderPopupMenu(fColumnPopupMenu).Options := TVTHeaderPopupMenu(fColumnPopupMenu).Options + [poResizeToFitItem] - else - TVTHeaderPopupMenu(fColumnPopupMenu).Options := TVTHeaderPopupMenu(fColumnPopupMenu).Options - [poResizeToFitItem]; - With Header.Treeview.ClientToScreen(P) do - fColumnPopupMenu.Popup(X, Y); - Result := True; - end; // if hoAutoColumnPopupMenu - end;//if mbRight - FHeader.Treeview.DoHeaderClick(HitInfo); - end;//else (not DblClick) - - 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.HeaderPopupMenuAddHeaderPopupItem(const Sender: TBaseVirtualTree; const Column: TColumnIndex; - var Cmd: TAddPopupItemType); -begin - Sender.DoHeaderAddPopupItem(Column, Cmd); -end; - -//---------------------------------------------------------------------------------------------------------------------- - - -procedure TVirtualTreeColumns.HeaderPopupMenuColumnChange(const Sender: TBaseVirtualTree; const Column: TColumnIndex; Visible: Boolean); -begin - Sender.DoColumnVisibilityChanged(Column, Visible); -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: System.Classes.TCollectionNotification); -var - I: Integer; -begin - if Action in [cnDeleting] then - begin - // Adjust all positions larger than the deleted column's position. Fixes #959, #1049 - for I := 0 to Count - 1 do begin - if Items[I].Position > TVirtualTreeColumn(Item).Position then - Items[I].Position := Items[I].Position - 1; - end;//for I - - with Header.Treeview do - if not (csLoading in ComponentState) and (FFocusedColumn = Item.Index) then - FFocusedColumn := NoColumn; - end;// if cnDeleting -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.SetHoverIndex(index : TColumnIndex); -begin - FHoverIndex := index; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumns.EndUpdate; -begin - InitializePositionArray(); - FixPositions(); // Accept the cuurent order. See issue #753 - inherited; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumns.Update(Item: TCollectionItem); - -begin - // This is the only place which gets notified when a new column has been added or removed - // and we need this event to adjust the column position array. - InitializePositionArray; - if csLoading in Header.Treeview.ComponentState then - FNeedPositionsFix := True - else - UpdatePositions; - - // The first column which is created is by definition also the main column. - if (Count > 0) and (Header.FMainColumn < 0) then - FHeader.MainColumn := 0; - - if not (csLoading in FHeader.Treeview.ComponentState) and not (hsLoading in FHeader.States) 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 (Treeview.IsUpdating) 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 (csDestroying in FHeader.Treeview.ComponentState) and 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 - Assert(GetCurrentThreadId = MainThreadId, 'UI controls may only be changed in UI thread.'); - Result := TVirtualTreeColumn(inherited Add); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumns.AnimatedResize(Column: TColumnIndex; NewWidth: Integer); - -// Resizes the given column animated by scrolling the window DC. - -var - OldWidth: Integer; - DC: HDC; - I, - Steps, - DX: Integer; - HeaderScrollRect, - ScrollRect, - R: TRect; - - NewBrush, - LastBrush: HBRUSH; - -begin - if not IsValidColumn(Column) then - Exit; // Just in case. - - // Make sure the width constrains are considered. - if NewWidth < Items[Column].MinWidth then - NewWidth := Items[Column].MinWidth; - if NewWidth > Items[Column].MaxWidth then - NewWidth := Items[Column].MaxWidth; - - OldWidth := Items[Column].Width; - // Nothing to do if the width is the same. - if OldWidth <> NewWidth then - begin - if not ( (hoDisableAnimatedResize in FHeader.Options) or - (coDisableAnimatedResize in Items[Column].Options) ) then - begin - DC := GetWindowDC(FHeader.Treeview.Handle); - with FHeader.Treeview do - try - Steps := 32; - DX := (NewWidth - OldWidth) div Steps; - - // Determination of the scroll rectangle is a bit complicated since we neither want - // to scroll the scrollbars nor the border of the treeview window. - HeaderScrollRect := FHeaderRect; - ScrollRect := HeaderScrollRect; - // Exclude the header itself from scrolling. - ScrollRect.Top := ScrollRect.Bottom; - ScrollRect.Bottom := ScrollRect.Top + ClientHeight; - ScrollRect.Right := ScrollRect.Left + ClientWidth; - with Items[Column] do - Inc(ScrollRect.Left, FLeft + FWidth); - HeaderScrollRect.Left := ScrollRect.Left; - HeaderScrollRect.Right := ScrollRect.Right; - - // When the new width is larger then avoid artefacts on the left hand side - // by deleting a small stripe - if NewWidth > OldWidth then - begin - R := ScrollRect; - NewBrush := CreateSolidBrush(ColorToRGB(Color)); - LastBrush := SelectObject(DC, NewBrush); - R.Right := R.Left + DX; - FillRect(DC, R, NewBrush); - SelectObject(DC, LastBrush); - DeleteObject(NewBrush); - end - else - begin - Inc(HeaderScrollRect.Left, DX); - Inc(ScrollRect.Left, DX); - end; - - for I := 0 to Steps - 1 do - begin - ScrollDC(DC, DX, 0, HeaderScrollRect, HeaderScrollRect, 0, nil); - Inc(HeaderScrollRect.Left, DX); - ScrollDC(DC, DX, 0, ScrollRect, ScrollRect, 0, nil); - Inc(ScrollRect.Left, DX); - Sleep(1); - end; - finally - ReleaseDC(Handle, DC); - end; - end; - Items[Column].Width := NewWidth; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumns.Assign(Source: TPersistent); - -begin - // Let the collection class assign the items. - inherited; - - if Source is TVirtualTreeColumns then - begin - // Copying the position array is the only needed task here. - FPositionToIndex := Copy(TVirtualTreeColumns(Source).FPositionToIndex, 0, MaxInt); - - // Make sure the left edges are correct after assignment. - FNeedPositionsFix := False; - UpdatePositions(True); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumns.Clear; - -begin - FClearing := True; - try - Header.Treeview.CancelEditNode; - - // Since we're freeing all columns, the following have to be true when we're done. - FHoverIndex := NoColumn; - FDownIndex := NoColumn; - FTrackIndex := NoColumn; - FClickIndex := NoColumn; - FCheckBoxHit := False; - - with Header do - if not (hsLoading in FStates) then - begin - FAutoSizeIndex := NoColumn; - FMainColumn := NoColumn; - FSortColumn := NoColumn; - end; - - with Header.Treeview do - if not (csLoading in ComponentState) then - FFocusedColumn := NoColumn; - - inherited Clear; - finally - FClearing := False; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVirtualTreeColumns.ColumnFromPosition(P: TPoint; Relative: Boolean = True): TColumnIndex; - -// Determines the current column based on the position passed in P. - -var - I, Sum: Integer; - -begin - Result := InvalidColumn; - - // The position must be within the header area, but we extend the vertical bounds to the entire treeview area. - if (P.X >= 0) and (P.Y >= 0) and (P.Y <= FHeader.TreeView.Height) then - with FHeader, Treeview do - begin - if Relative and (P.X >= GetVisibleFixedWidth) then - Sum := -FEffectiveOffsetX - else - Sum := 0; - - if UseRightToLeftAlignment then - Inc(Sum, ComputeRTLOffset(True)); - - for I := 0 to Count - 1 do - if coVisible in Items[FPositionToIndex[I]].Options then - begin - Inc(Sum, Items[FPositionToIndex[I]].Width); - if P.X < Sum then - begin - Result := FPositionToIndex[I]; - Break; - end; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVirtualTreeColumns.ColumnFromPosition(PositionIndex: TColumnPosition): TColumnIndex; - -// Returns the index of the column at the given position. - -begin - if Integer(PositionIndex) < Length(FPositionToIndex) then - Result := FPositionToIndex[PositionIndex] - else - Result := NoColumn; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVirtualTreeColumns.Equals(OtherColumnsObj: TObject): Boolean; - -// Compares itself with the given set of columns and returns True if all published properties are the same -// (including column order), otherwise False is returned. - -var - I: Integer; - OtherColumns : TVirtualTreeColumns; - -begin - if not (OtherColumnsObj is TVirtualTreeColumns) then - begin - Result := False; - Exit; - end; - - OtherColumns := TVirtualTreeColumns (OtherColumnsObj); - - // Same number of columns? - Result := OtherColumns.Count = Count; - if Result then - begin - // Same order of columns? - Result := CompareMem(Pointer(FPositionToIndex), Pointer(OtherColumns.FPositionToIndex), - Length(FPositionToIndex) * SizeOf(TColumnIndex)); - if Result then - begin - for I := 0 to Count - 1 do - if not Items[I].Equals(OtherColumns[I]) then - begin - Result := False; - Break; - end; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumns.GetColumnBounds(Column: TColumnIndex; var Left, Right: Integer); - -// Returns the left and right bound of the given column. If Column is NoColumn then the entire client width is returned. - -begin - if Column <= NoColumn then - begin - Left := 0; - Right := FHeader.Treeview.ClientWidth; - end - else - begin - Left := Items[Column].Left; - Right := Left + Items[Column].Width; - if FHeader.Treeview.UseRightToLeftAlignment then - begin - Inc(Left, FHeader.Treeview.ComputeRTLOffset(True)); - Inc(Right, FHeader.Treeview.ComputeRTLOffset(True)); - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVirtualTreeColumns.GetScrollWidth: Integer; - -// Returns the average width of all visible, non-fixed columns. If there is no such column the indent is returned. - -var - I: Integer; - ScrollColumnCount: Integer; - -begin - - Result := 0; - - ScrollColumnCount := 0; - for I := 0 to FHeader.Columns.Count - 1 do - begin - if ([coVisible, coFixed] * FHeader.Columns[I].Options = [coVisible]) then - begin - Inc(Result, FHeader.Columns[I].Width); - Inc(ScrollColumnCount); - end; - end; - - if ScrollColumnCount > 0 then // use average width - Result := Round(Result / ScrollColumnCount) - else // use indent - Result := Integer(FHeader.Treeview.FIndent); - -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVirtualTreeColumns.GetFirstVisibleColumn(ConsiderAllowFocus: Boolean = False): TColumnIndex; - -// Returns the index of the first visible column or "InvalidColumn" if either no columns are defined or -// all columns are hidden. -// If ConsiderAllowFocus is True then the column has not only to be visible but also focus has to be allowed. - -var - I: Integer; - -begin - Result := InvalidColumn; - if (UpdateCount > 0) or (csLoading in Header.TreeView.ComponentState) then - exit; // See issue #760 - for I := 0 to Count - 1 do - if (coVisible in Items[FPositionToIndex[I]].Options) and - ( (not ConsiderAllowFocus) or - (coAllowFocus in Items[FPositionToIndex[I]].Options) - ) 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; - if (UpdateCount > 0) or (csLoading in Header.TreeView.ComponentState) then - exit; // See issue #760 - for I := Count - 1 downto 0 do - if (coVisible in Items[FPositionToIndex[I]].Options) and - ( (not ConsiderAllowFocus) or - (coAllowFocus in Items[FPositionToIndex[I]].Options) - ) 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].Options) and - ( (not ConsiderAllowFocus) or - (coAllowFocus in Items[Result].Options) - ) - ); -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].Options) and - ( (not ConsiderAllowFocus) or - (coAllowFocus in Items[Result].Options) - ) - ); -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]].Options then - begin - Result[Counter] := Items[FPositionToIndex[I]]; - Inc(Counter); - end; - // Set result length to actual visible count. - SetLength(Result, Counter); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVirtualTreeColumns.GetVisibleFixedWidth: Integer; - -// Determines the horizontal space all visible and fixed columns occupy. - -var - I: Integer; - -begin - Result := 0; - for I := 0 to Count - 1 do - begin - if Items[I].Options * [coVisible, coFixed] = [coVisible, coFixed] then - Inc(Result, Items[I].Width); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVirtualTreeColumns.IsValidColumn(Column: TColumnIndex): Boolean; - -// Determines whether the given column is valid or not, that is, whether it is one of the current columns. - -begin - Result := (Column > NoColumn) and (Column < Count); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumns.LoadFromStream(const Stream: TStream; Version: Integer); - -var - I, - ItemCount: Integer; - -begin - Clear; - Stream.ReadBuffer(ItemCount, SizeOf(ItemCount)); - // number of columns - if ItemCount > 0 then - begin - BeginUpdate; - try - for I := 0 to ItemCount - 1 do - Add.LoadFromStream(Stream, Version); - SetLength(FPositionToIndex, ItemCount); - Stream.ReadBuffer(FPositionToIndex[0], ItemCount * SizeOf(TColumnIndex)); - UpdatePositions(True); - finally - EndUpdate; - end; - end; - - // Data introduced with header stream version 5 - if Version > 4 then - Stream.ReadBuffer(FDefaultWidth, SizeOf(FDefaultWidth)); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumns.PaintHeader(DC: HDC; R: TRect; HOffset: Integer); - -// Backward compatible header paint method. This method takes care of visually moving floating columns - -var - VisibleFixedWidth: Integer; - RTLOffset: Integer; - - procedure PaintFixedArea; - - begin - if VisibleFixedWidth > 0 then - PaintHeader(FHeaderBitmap.Canvas, - Rect(0, 0, Min(R.Right, VisibleFixedWidth), R.Bottom - R.Top), - Point(R.Left, R.Top), RTLOffset); - end; - -begin - // Adjust size of the header bitmap - with TWithSafeRect(FHeader.Treeview.FHeaderRect) do - begin - FHeaderBitmap.SetSize(Max(Right, R.Right - R.Left), 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. - -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; - Theme: HTheme; - 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 (FHeader.Treeview.VclStyleEnabled and (seClient in FHeader.Treeview.StyleElements)) then - begin - Details := StyleServices.GetElementDetails(thHeaderItemRightNormal); - StyleServices.DrawElement(Handle, Details, BackgroundRect, @BackgroundRect {$IF CompilerVersion >= 34}, FHeader.Treeview.FCurrentPPI{$IFEND}); - end - else - if tsUseThemes in FHeader.Treeview.FStates then - begin - Theme := OpenThemeData(FHeader.Treeview.Handle, 'HEADER'); - DrawThemeBackground(Theme, Handle, HP_HEADERITEM, HIS_NORMAL, BackgroundRect, nil); - CloseThemeData(THeme); - end - else - begin - Brush.Color := FHeader.Background; - 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 - SavedDC: Integer; - ColCaptionText: string; - ColImageInfo: TVTImageInfo; - Glyph: TThemedHeader; - Details: TThemedElementDetails; - WrapCaption: Boolean; - DrawFormat: Cardinal; - Pos: TRect; - DrawHot: Boolean; - ImageWidth: Integer; - Theme: HTheme; - IdState: Integer; - begin - ColImageInfo.Ghosted := False; - PaintInfo.Column := Items[AColumn]; - with PaintInfo, Column do - begin - IsHoverIndex := (AColumn = FHoverIndex) and (hoHotTrack in FHeader.Options) and (coEnabled in FOptions); - IsDownIndex := (AColumn = FDownIndex) and not FCheckBoxHit; - - if (coShowDropMark in FOptions) and (AColumn = FDropTarget) and (AColumn <> FDragIndex) then - begin - if FDropBefore then - DropMark := dmmLeft - else - DropMark := dmmRight; - end - else - DropMark := dmmNone; - - //Fix for issue 643 - //Do not show the left drop mark if the position to drop is just preceding the target which means - //the dragged column will stay where it is - if (DropMark = dmmLeft) and (Items[FDragIndex].Position = TColumnPosition(Max(Integer(Items[FDropTarget].Position) - 1, 0))) - then - DropMark := dmmNone - else - //Do not show the right drop mark if the position to drop is just following the target which means - //the dragged column will stay where it is - if (DropMark = dmmRight) and (Items[FDragIndex].Position = Items[FDropTarget].Position + 1) - then - DropMark := dmmNone; - - IsEnabled := (coEnabled in FOptions) and (FHeader.Treeview.Enabled); - ShowHeaderGlyph := (hoShowImages in FHeader.Options) and ((Assigned(Images) and (FImageIndex > -1)) or FCheckBox); - ShowSortGlyph := (AColumn = FHeader.SortColumn) and (hoShowSortGlyphs in FHeader.Options); - 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 FHeader.Treeview.VclStyleEnabled and (seClient in FHeader.Treeview.StyleElements) 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{$IF CompilerVersion >= 34}, FHeader.TreeView.FCurrentPPI{$IFEND}); - end - else - begin - if tsUseThemes in FHeader.Treeview.FStates then - begin - Theme := OpenThemeData(FHeader.Treeview.Handle, 'HEADER'); - if IsDownIndex then - IdState := HIS_PRESSED - else - if IsHoverIndex then - IdState := HIS_HOT - else - IdState := HIS_NORMAL; - DrawThemeBackground(Theme, TargetCanvas.Handle, HP_HEADERITEM, IdState, PaintRectangle, nil); - CloseThemeData(Theme); - end - else - 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(PaintInfo, 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, hpeOverlay]; - - // 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 := FCheckImages; - 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.Options) 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.SortDirection = sdAscending then - Glyph := thHeaderSortArrowSortedUp - else - Glyph := thHeaderSortArrowSortedDown; - Details := StyleServices.GetElementDetails(Glyph); - if not StyleServices.DrawElement(TargetCanvas.Handle, Details, Pos, @Pos {$IF CompilerVersion >= 34}, FHeader.TreeView.FCurrentPPI {$IFEND}) then - PaintInfo.DrawSortArrow(FHeader.SortDirection); - end - else - begin - PaintInfo.DrawSortArrow(FHeader.SortDirection); - 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 - PaintInfo.DrawDropMark(); - 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.Options) and Assigned(FHeader.Treeview.OnAdvancedHeaderDraw) and - Assigned(FHeader.Treeview.FOnHeaderDrawQueryElements) and not (csDesigning in FHeader.Treeview.ComponentState); - OwnerDraw := (hoOwnerDraw in FHeader.Options) and Assigned(FHeader.Treeview.OnHeaderDraw) and - not (csDesigning in FHeader.Treeview.ComponentState) and not AdvancedOwnerDraw; - - ZeroMemory(@PaintInfo, SizeOf(PaintInfo)); - PaintInfo.TargetCanvas := TargetCanvas; - - with PaintInfo, TargetCanvas do - begin - // Use shortcuts for the images and the font. - Images := FHeader.Images; - Font := FHeader.Font; - - 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 - //Fixes issues #544, #427 -- MaxX should also shift on BidiMode bdRightToLeft - + RTLOffset; //added for fix - - // 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.Options) or - (FHeader.Treeview.BevelKind = bkNone); - - // Now go for each button. - while (Run > NoColumn) and (TargetRect.Left < MaxX) do - begin - TargetRect.Right := TargetRect.Left + Items[Run].Width; - - // 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].Options) 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; - FMaxWidthPercent := 95; - FHeader := AOwner; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTFixedAreaConstraints.SetConstraints(Index: Integer; Value: TVTConstraintPercent); - -begin - case Index of - 0: - if Value <> FMaxHeightPercent then - begin - FMaxHeightPercent := Value; - if (Value > 0) and (Value < FMinHeightPercent) then - FMinHeightPercent := Value; - Change; - end; - 1: - if Value <> FMaxWidthPercent then - begin - FMaxWidthPercent := Value; - if (Value > 0) and (Value < FMinWidthPercent) then - FMinWidthPercent := Value; - Change; - end; - 2: - if Value <> FMinHeightPercent then - begin - FMinHeightPercent := Value; - if (FMaxHeightPercent > 0) and (Value > FMaxHeightPercent) then - FMaxHeightPercent := Value; - Change; - end; - 3: - if Value <> FMinWidthPercent then - begin - FMinWidthPercent := Value; - if (FMaxWidthPercent > 0) and (Value > FMaxWidthPercent) then - FMaxWidthPercent := Value; - Change; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTFixedAreaConstraints.Change; - -begin - if Assigned(FOnChange) then - FOnChange(Self); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTFixedAreaConstraints.Assign(Source: TPersistent); - -begin - if Source is TVTFixedAreaConstraints then - begin - FMaxHeightPercent := TVTFixedAreaConstraints(Source).FMaxHeightPercent; - FMaxWidthPercent := TVTFixedAreaConstraints(Source).FMaxWidthPercent; - FMinHeightPercent := TVTFixedAreaConstraints(Source).FMinHeightPercent; - FMinWidthPercent := TVTFixedAreaConstraints(Source).FMinWidthPercent; - Change; - end - else - inherited; -end; - -//----------------- TVTHeader ----------------------------------------------------------------------------------------- - -constructor TVTHeader.Create(AOwner: TBaseVirtualTree); - -begin - inherited Create; - FOwner := AOwner; - FColumns := GetColumnsClass.Create(Self); - FHeight := 19; - FDefaultHeight := FHeight; - FMinHeight := 10; - FMaxHeight := 10000; - FFont := TFont.Create; - FFont.OnChange := FontChanged; - FParentFont := True; - FBackgroundColor := 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; - PreBlendBias := -50; - Transparency := 140; - end; - - fSplitterHitTolerance := 8; - FFixedAreaConstraints := TVTFixedAreaConstraints.Create(Self); - FFixedAreaConstraints.OnChange := FixedAreaConstraintsChanged; - - FDoingAutoFitColumns := false; -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); -begin - inherited; - {$IF CompilerVersion < 31} // See issue #1043 - AutoScale(); - {$IFEND} -end; - -procedure TVTHeader.AutoScale(); -var - I: Integer; - lMaxHeight: Integer; -begin - if toAutoChangeScale in Treeview.TreeOptions.AutoOptions then - begin - // Ensure a minimum header size based on the font, so that all text is visible. - // First 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 height based on the font, this is important as the user might just have increased the size of the system 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 and the minimum needed header height. - lMaxHeight := Max(lMaxHeight, FHeight); - // Set the calculated size - Self.SetHeight(lMaxHeight); - end; -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 FBackgroundColor <> Value then - begin - FBackgroundColor := 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; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTHeader.SetImages(const Value: TCustomImageList); - -begin - if FImages <> Value then - begin - if Assigned(FImages) then - begin - FImages.UnRegisterChanges(FImageChangeLink); - FImages.RemoveFreeNotification(FOwner); - end; - FImages := Value; - if Assigned(FImages) then - begin - FImages.RegisterChanges(FImageChangeLink); - FImages.FreeNotification(FOwner); - end; - if not (csLoading in Treeview.ComponentState) then - Invalidate(nil); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTHeader.SetMainColumn(Value: TColumnIndex); - -begin - if csLoading in Treeview.ComponentState then - FMainColumn := Value - else - begin - if Value < 0 then - Value := 0; - if Value > FColumns.Count - 1 then - Value := FColumns.Count - 1; - if Value <> FMainColumn then - begin - FMainColumn := Value; - if not (csLoading in Treeview.ComponentState) then - begin - Treeview.MainColumnChanged; - if not (toExtendedFocus in Treeview.TreeOptions.SelectionOptions) then - Treeview.FocusedColumn := FMainColumn; - Treeview.Invalidate; - end; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTHeader.SetMaxHeight(Value: Integer); - -begin - if Value < FMinHeight then - Value := FMinHeight; - FMaxHeight := Value; - SetHeight(FHeight); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTHeader.SetMinHeight(Value: Integer); - -begin - if Value < 0 then - Value := 0; - if Value > FMaxHeight then - Value := FMaxHeight; - FMinHeight := Value; - SetHeight(FHeight); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTHeader.SetOptions(Value: TVTHeaderOptions); - -var - ToBeSet, - ToBeCleared: TVTHeaderOptions; - -begin - ToBeSet := Value - FOptions; - ToBeCleared := FOptions - Value; - FOptions := Value; - - if (hoAutoResize in (ToBeSet + ToBeCleared)) and (FColumns.Count > 0) then - begin - FColumns.AdjustAutoSize(InvalidColumn); - if Treeview.HandleAllocated then - begin - Treeview.UpdateHorizontalScrollBar(False); - if hoAutoResize in ToBeSet then - Treeview.Invalidate; - end; - end; - - if not (csLoading in Treeview.ComponentState) and Treeview.HandleAllocated then - begin - if hoVisible in (ToBeSet + ToBeCleared) then - RecalculateHeader; - Invalidate(nil); - Treeview.Invalidate; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTHeader.SetParentFont(Value: Boolean); - -begin - if FParentFont <> Value then - begin - FParentFont := Value; - if FParentFont then - FFont.Assign(FOwner.Font); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTHeader.SetSortColumn(Value: TColumnIndex); - -begin - if csLoading in Treeview.ComponentState then - FSortColumn := Value - else - DoSetSortColumn(Value, FSortDirection); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTHeader.SetSortDirection(const Value: TSortDirection); - -begin - if Value <> FSortDirection then - begin - FSortDirection := Value; - Invalidate(nil); - if ((toAutoSort in Treeview.TreeOptions.AutoOptions) or (hoHeaderClickAutoSort in Options)) and (Treeview.UpdateCount = 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; - -procedure TVTHeader.StyleChanged(); -begin - {$IF CompilerVersion < 31} // See issue #1043 - AutoScale(); //Elements may have changed in size - {$IFEND} -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; isDpiChange: Boolean); -var - I: Integer; -begin - // This method is only executed if toAutoChangeScale is set - FMinHeight := MulDiv(FMinHeight, M, D); - FMaxHeight := MulDiv(FMaxHeight, M, D); - Self.Height := MulDiv(FHeight, M, D); - if not ParentFont then - Font.Height := MulDiv(Font.Height, M, D); - // Scale the columns widths too - for I := 0 to FColumns.Count - 1 do - Self.FColumns[I].ChangeScale(M, D, isDpiChange); - if not isDpiChange then - AutoScale(); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTHeader.DetermineSplitterIndex(P: TPoint): Boolean; - -// Tries to find the index of that column whose right border corresponds to P. -// Result is True if column border was hit (with -3..+5 pixels tolerance). -// For continuous resizing the current track index and the column's left/right border are set. -// Note: The hit test is checking from right to left (or left to right in RTL mode) to make enlarging of zero-sized -// columns possible. - -var - 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 ---------------------------------------- - -var - I: Integer; - LeftTolerance: Integer; // The area left of the column divider which allows column resizing -begin - Result := False; - - if FColumns.Count > 0 then - begin - FColumns.TrackIndex := NoColumn; - VisibleFixedWidth := FColumns.GetVisibleFixedWidth; - LeftTolerance := Round(SplitterHitTolerance * 0.6); - if Treeview.UseRightToLeftAlignment then - begin - SplitPoint := -Treeview.FEffectiveOffsetX; - if FColumns.TotalWidth < Treeview.ClientWidth then - Inc(SplitPoint, Treeview.ClientWidth - FColumns.TotalWidth); - - 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, LeftTolerance, SplitterHitTolerance - LeftTolerance) 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 + FColumns.TotalWidth; - - 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, SplitterHitTolerance - LeftTolerance, LeftTolerance) 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 := PopupMenu; - 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; pSortDirection: TSortDirection); - -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; - FSortDirection := pSortDirection; - if FSortColumn > NoColumn then - Invalidate(Columns[FSortColumn]); - if ((toAutoSort in Treeview.TreeOptions.AutoOptions) or (hoHeaderClickAutoSort in Options)) and (Treeview.UpdateCount = 0) then - Treeview.SortTree(FSortColumn, FSortDirection, True); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTHeader.DragTo(P: TPoint); - -// Moves the drag image to a new position, which is determined from the passed point P and the previous -// mouse position. - -var - I, - NewTarget: Integer; - // optimized drag image move support - ClientP: TPoint; - Left, - Right: Integer; - NeedRepaint: Boolean; // True if the screen needs an update (changed drop target or drop side) - -begin - // Determine new drop target and which side of it is prefered. - ClientP := Treeview.ScreenToClient(P); - // Make coordinates relative to (0, 0) of the non-client area. - Inc(ClientP.Y, FHeight); - NewTarget := FColumns.ColumnFromPosition(ClientP); - NeedRepaint := (NewTarget <> InvalidColumn) and (NewTarget <> FColumns.DropTarget); - if NewTarget >= 0 then - begin - FColumns.GetColumnBounds(NewTarget, Left, Right); - if (ClientP.X < ((Left + Right) div 2)) <> FColumns.DropBefore then - begin - NeedRepaint := True; - FColumns.DropBefore := not FColumns.DropBefore; - end; - end; - - if NeedRepaint then - begin - // Invalidate columns which need a repaint. - if FColumns.DropTarget > NoColumn then - begin - I := FColumns.DropTarget; - FColumns.DropTarget := NoColumn; - Invalidate(FColumns.Items[I]); - end; - if (NewTarget > NoColumn) and (NewTarget <> FColumns.DropTarget) then - begin - Invalidate(FColumns.Items[NewTarget]); - FColumns.DropTarget := NewTarget; - end; - end; - - // Fix for various problems mentioned in issue 248. - if NeedRepaint then - begin - UpdateWindow(FOwner.Handle); - // The new routine recaptures the backup image after the updatewindow - // Note: We could have called this unconditionally but when called - // over the tree, doesn't capture the background image. Since our - // problems are in painting of the header, we call it only when the - // drag image is over the header. - if - // determine the case when the drag image is or was on the header area - (InHeader(FOwner.ScreenToClient(FDragImage.LastPosition)) - or InHeader(FOwner.ScreenToClient(FDragImage.ImagePosition)) - ) then - begin - GDIFlush; - FOwner.UpdateWindowAndDragImage(FOwner, FOwner.HeaderRect, True, true); - end; - // since we took care of UpdateWindow above, there is no need to do an - // update window again by sending NeedRepaint. So switch off the second parameter. - NeedRepaint := false; - 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.GetRestoreSelectionColumnIndex: Integer; -begin - if fRestoreSelectionColumnIndex >= 0 then - Result := fRestoreSelectionColumnIndex - else - Result := MainColumn; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTHeader.GetShiftState: TShiftState; - -begin - Result := []; - if GetKeyState(VK_SHIFT) < 0 then - Include(Result, ssShift); - if GetKeyState(VK_CONTROL) < 0 then - Include(Result, ssCtrl); - if GetKeyState(VK_MENU) < 0 then - Include(Result, ssAlt); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTHeader.HandleHeaderMouseMove(var Message: TWMMouseMove): Boolean; - -var - P: TPoint; - NextColumn, - I: TColumnIndex; - NewWidth: Integer; - -begin - Result := False; - with Message do - begin - P := Point(XPos, YPos); - if hsColumnWidthTrackPending in FStates then - begin - Treeview.StopTimer(HeaderTimer); - FStates := FStates - [hsColumnWidthTrackPending] + [hsColumnWidthTracking]; - HandleHeaderMouseMove := True; - Result := 0; - end - else - if hsHeightTrackPending in FStates then - begin - Treeview.StopTimer(HeaderTimer); - FStates := FStates - [hsHeightTrackPending] + [hsHeightTracking]; - HandleHeaderMouseMove := True; - Result := 0; - end - else - if hsColumnWidthTracking in FStates then - begin - if DoColumnWidthTracking(FColumns.TrackIndex, GetShiftState, FTrackPoint, P) then - begin - if Treeview.UseRightToLeftAlignment then - begin - NewWidth := FTrackPoint.X - XPos; - NextColumn := FColumns.GetPreviousVisibleColumn(FColumns.TrackIndex); - end - else - begin - NewWidth := XPos - FTrackPoint.X; - NextColumn := FColumns.GetNextVisibleColumn(FColumns.TrackIndex); - 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.TrackIndex = FAutoSizeIndex) and - (NextColumn > NoColumn) and (coResizable in FColumns[NextColumn].Options) and - (FColumns[FColumns.TrackIndex].MinWidth < NewWidth) and - (FColumns[FColumns.TrackIndex].MaxWidth > NewWidth) then - FColumns[NextColumn].Width := FColumns[NextColumn].Width - NewWidth - + FColumns[FColumns.TrackIndex].Width - else - FColumns[FColumns.TrackIndex].Width := NewWidth; // 1 EListError seen here (List index out of bounds (-1)) since 10/2013 - end; - HandleHeaderMouseMove := True; - Result := 0; - end - else - if hsHeightTracking in FStates then - begin - if DoHeightTracking(P, GetShiftState) then - SetHeight(Integer(FHeight) + P.Y); - HandleHeaderMouseMove := True; - Result := 0; - end - else - begin - if hsDragPending in FStates then - begin - P := Treeview.ClientToScreen(P); - // start actual dragging if allowed - if (hoDrag in FOptions) and Treeview.DoHeaderDragging(FColumns.DownIndex) then - begin - if ((Abs(FDragStart.X - P.X) > Mouse.DragThreshold) or - (Abs(FDragStart.Y - P.Y) > Mouse.DragThreshold)) then - begin - Treeview.StopTimer(HeaderTimer); - I := FColumns.DownIndex; - FColumns.DownIndex := NoColumn; - FColumns.HoverIndex := NoColumn; - if I > NoColumn then - Invalidate(FColumns[I]); - PrepareDrag(P, FDragStart); - FStates := FStates - [hsDragPending] + [hsDragging]; - HandleHeaderMouseMove := True; - Result := 0; - end; - end; - end - else - if hsDragging in FStates then - begin - DragTo(Treeview.ClientToScreen(Point(XPos, YPos))); - HandleHeaderMouseMove := True; - Result := 0; - end; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTHeader.HandleMessage(var Message: TMessage): Boolean; - -// The header gets here the opportunity to handle certain messages before they reach the tree. This is important -// because the tree needs to handle various non-client area messages for the header as well as some dragging/tracking -// events. -// By returning True the message will not be handled further, otherwise the message is then dispatched -// to the proper message handlers. - -var - P: TPoint; - R: TRect; - I: TColumnIndex; - OldPosition: Integer; - HitIndex: TColumnIndex; - NewCursor: HCURSOR; - Button: TMouseButton; - IsInHeader, - IsHSplitterHit, - IsVSplitterHit: Boolean; - - //--------------- local function -------------------------------------------- - - function HSplitterHit: Boolean; - begin - Result := (hoColumnResize in FOptions) and DetermineSplitterIndex(P); - if Result and not InHeader(P) then - begin - // Code commented due to issue #1067. What was the orginal inention of this code? It does not make much sense unless you allow column resize outside the header. - // NextCol := FColumns.GetNextVisibleColumn(FColumns.TrackIndex); - // if not (coFixed in FColumns[FColumns.TrackIndex].Options) or (NextCol <= NoColumn) or - // (coFixed in FColumns[NextCol].Options) or (P.Y > Integer(Treeview.FRangeY)) then - Result := False; - end; - end; - - //--------------- end local function ---------------------------------------- - -begin - Result := False; - case Message.Msg of - WM_SIZE: - begin - if not (tsWindowCreating in FOwner.TreeStates) 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].Options then - FColumns[I].ParentBiDiModeChanged; - WM_NCMBUTTONDOWN: - begin - with TWMNCMButtonDown(Message) do - P := Treeview.ScreenToClient(Point(XCursor, YCursor)); - if InHeader(P) then - FOwner.DoHeaderMouseDown(mbMiddle, GetShiftState, P.X, P.Y + Integer(FHeight)); - end; - WM_NCMBUTTONUP: - begin - with TWMNCMButtonUp(Message) do - P := FOwner.ScreenToClient(Point(XCursor, YCursor)); - if InHeader(P) then - begin - FColumns.HandleClick(P, mbMiddle, True, False); - FOwner.DoHeaderMouseUp(mbMiddle, GetShiftState, P.X, P.Y + Integer(FHeight)); - FColumns.DownIndex := NoColumn; - FColumns.CheckBoxHit := False; - end; - end; - WM_LBUTTONDBLCLK, - WM_NCLBUTTONDBLCLK, - WM_NCMBUTTONDBLCLK, - WM_NCRBUTTONDBLCLK: - begin - if Message.Msg <> WM_LBUTTONDBLCLK then - with TWMNCLButtonDblClk(Message) do - P := FOwner.ScreenToClient(Point(XCursor, YCursor)) - else - with TWMLButtonDblClk(Message) do - P := Point(XPos, YPos); - - if (hoHeightDblClickResize in FOptions) and InHeaderSplitterArea(P) and (FDefaultHeight > 0) then - begin - if DoHeightDblClickResize(P, GetShiftState) and (FDefaultHeight > 0) then - SetHeight(FMinHeight); - Result := True; - end - else - if HSplitterHit and ((Message.Msg = WM_NCLBUTTONDBLCLK) or (Message.Msg = WM_LBUTTONDBLCLK)) and - (hoDblClickResize in FOptions) and (FColumns.TrackIndex > NoColumn) then - begin - // If the click was on a splitter then resize column to smallest width. - if DoColumnWidthDblClickResize(FColumns.TrackIndex, P, GetShiftState) then - AutoFitColumns(True, smaUseColumnOption, FColumns[FColumns.TrackIndex].Position, - FColumns[FColumns.TrackIndex].Position); - Message.Result := 0; - Result := True; - end - else - if InHeader(P) and (Message.Msg <> WM_LBUTTONDBLCLK) then - begin - case Message.Msg of - WM_NCMBUTTONDBLCLK: - Button := mbMiddle; - WM_NCRBUTTONDBLCLK: - Button := mbRight; - else - // WM_NCLBUTTONDBLCLK - Button := mbLeft; - end; - if Button = mbLeft then - Columns.AdjustDownColumn(P); - FColumns.HandleClick(P, Button, True, True); - end; - end; - // The "hot" area of the headers horizontal splitter is partly within the client area of the the tree, so we need - // to handle WM_LBUTTONDOWN here, too. - WM_LBUTTONDOWN, - WM_NCLBUTTONDOWN: - begin - - Application.CancelHint; - - if not (csDesigning in Treeview.ComponentState) then - begin - // make sure no auto scrolling is active... - Treeview.StopTimer(ScrollTimer); - Treeview.DoStateChange([], [tsScrollPending, tsScrolling]); - // ... pending editing is cancelled (actual editing remains active) - Treeview.StopTimer(EditTimer); - Treeview.DoStateChange([], [tsEditPending]); - end; - - if Message.Msg = WM_LBUTTONDOWN then - // Coordinates are already client area based. - with TWMLButtonDown(Message) do - begin - P := Point(XPos, YPos); - // #909 - FDragStart := Treeview.ClientToScreen(p); - end - else - with TWMNCLButtonDown(Message) do - begin - // want the drag start point in screen coordinates - FDragStart := Point(XCursor, YCursor); - P := Treeview.ScreenToClient(FDragStart); - end; - - IsInHeader := InHeader(P); - // in design-time header columns are always resizable - if (csDesigning in Treeview.ComponentState) then - IsVSplitterHit := InHeaderSplitterArea(P) - else - IsVSplitterHit := InHeaderSplitterArea(P) and CanSplitterResize(P); - IsHSplitterHit := HSplitterHit; - - if IsVSplitterHit or IsHSplitterHit then - begin - FTrackStart := P; - FColumns.HoverIndex := 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.TrackIndex, 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].Options)) then - begin - // Show potential drag operation. - // Disabled columns do not start a drag operation because they can't be clicked. - Include(FStates, hsDragPending); - SetCapture(Treeview.Handle); - Result := True; - Message.Result := 0; - end; - end; - - // This is a good opportunity to notify the application. - if not (csDesigning in Treeview.ComponentState) and IsInHeader then - FOwner.DoHeaderMouseDown(mbLeft, GetShiftState, P.X, P.Y + Integer(FHeight)); - end; - WM_NCRBUTTONDOWN: - begin - with TWMNCRButtonDown(Message) do - P := FOwner.ScreenToClient(Point(XCursor, YCursor)); - if InHeader(P) then - FOwner.DoHeaderMouseDown(mbRight, GetShiftState, P.X, P.Y + Integer(FHeight)); - end; - WM_NCRBUTTONUP: - if not (csDesigning in FOwner.ComponentState) then - with TWMNCRButtonUp(Message) do - begin - Application.CancelHint; - P := FOwner.ScreenToClient(Point(XCursor, YCursor)); - if InHeader(P) then - begin - HandleMessage := FColumns.HandleClick(P, mbRight, True, False); - FOwner.DoHeaderMouseUp(mbRight, GetShiftState, P.X, P.Y + Integer(FHeight)); - end; - end; - // When the tree window has an active mouse capture then we only get "client-area" messages. - WM_LBUTTONUP, - WM_NCLBUTTONUP: - begin - Application.CancelHint; - - if FStates <> [] then - begin - ReleaseCapture; - if hsDragging in FStates then - begin - // successfull dragging moves columns - with TWMLButtonUp(Message) do - P := Treeview.ClientToScreen(Point(XPos, YPos)); - GetWindowRect(Treeview.Handle, R); - with FColumns do - begin - FDragImage.EndDrag; - - //Problem fixed: - //Column Header does not paint correctly after a drop in certain conditions - //** The conditions are, drag is across header, mouse is not moved after - //the drop and the graphics hardware is slow in certain operations (encountered - //on Windows 10). - //Fix for the problem on certain systems where the dropped column header - //does not appear in the new position if the mouse is not moved after - //the drop. The reason is that the restore backup image operation (BitBlt) - //in the above EndDrag is slower than the header repaint in the code below - //and overlaps the new changed header with the older image. - //This happens because BitBlt seems to operate in its own thread in the - //graphics hardware and finishes later than the following code. - // - //To solve this problem, we introduce a small delay here so that the - //changed header in the following code is correctly repainted after - //the delayed BitBlt above has finished operation to restore the old - //backup image. - sleep(50); - - if (FDropTarget > -1) and (FDropTarget <> FDragIndex) and PtInRect(R, P) then - begin - OldPosition := FColumns[FDragIndex].Position; - if FColumns.DropBefore then - begin - if FColumns[FDragIndex].Position < FColumns[FDropTarget].Position then - FColumns[FDragIndex].Position := Max(0, FColumns[FDropTarget].Position - 1) - else - FColumns[FDragIndex].Position := FColumns[FDropTarget].Position; - end - else - begin - if FColumns[FDragIndex].Position < FColumns[FDropTarget].Position then - FColumns[FDragIndex].Position := FColumns[FDropTarget].Position - else - FColumns[FDragIndex].Position := FColumns[FDropTarget].Position + 1; - end; - Treeview.DoHeaderDragged(FDragIndex, OldPosition); - end - else - Treeview.DoHeaderDraggedOut(FDragIndex, P); - FDropTarget := NoColumn; - end; - Invalidate(nil); - end; - Result := True; - Message.Result := 0; - end; - - case Message.Msg of - WM_LBUTTONUP: - with TWMLButtonUp(Message) do - begin - if FColumns.DownIndex > NoColumn then - FColumns.HandleClick(Point(XPos, YPos), mbLeft, False, False); - if FStates <> [] then - FOwner.DoHeaderMouseUp(mbLeft, KeysToShiftState(Keys), XPos, YPos); - end; - WM_NCLBUTTONUP: - with TWMNCLButtonUp(Message) do - begin - P := FOwner.ScreenToClient(Point(XCursor, YCursor)); - FColumns.HandleClick(P, mbLeft, False, False); - FOwner.DoHeaderMouseUp(mbLeft, GetShiftState, P.X, P.Y + Integer(FHeight)); - end; - end; - - if FColumns.TrackIndex > NoColumn then - begin - if hsColumnWidthTracking in FStates then - DoAfterColumnWidthTracking(FColumns.TrackIndex); - Invalidate(Columns[FColumns.TrackIndex]); - FColumns.TrackIndex := NoColumn; - end; - if FColumns.DownIndex > NoColumn then - begin - Invalidate(Columns[FColumns.DownIndex]); - FColumns.DownIndex := NoColumn; - end; - if hsHeightTracking in FStates then - DoAfterHeightTracking; - - FStates := FStates - [hsDragging, hsDragPending, - hsColumnWidthTracking, hsColumnWidthTrackPending, - hsHeightTracking, hsHeightTrackPending]; - end;// WM_NCLBUTTONUP - // hovering, mouse leave detection - WM_NCMOUSEMOVE: - with TWMNCMouseMove(Message), FColumns do - begin - P := Treeview.ScreenToClient(Point(XCursor, YCursor)); - Treeview.DoHeaderMouseMove(GetShiftState, P.X, P.Y + Integer(FHeight)); - if InHeader(P) and ((AdjustHoverColumn(P)) or ((FDownIndex >= 0) and (FHoverIndex <> FDownIndex))) then - begin - // We need a mouse leave detection from here for the non client area. - // TODO: The best solution available would be the TrackMouseEvent API. - // With the drop of the support of Win95 totally and WinNT4 we should replace the timer. - Treeview.StopTimer(HeaderTimer); - SetTimer(Treeview.Handle, HeaderTimer, 50, nil); - // use Delphi's internal hint handling for header hints too - if hoShowHint in FOptions then - begin - // client coordinates! - XCursor := P.X; - YCursor := P.Y + Integer(FHeight); - Application.HintMouseMessage(Treeview, Message); - end; - end; - end; - WM_TIMER: - if TWMTimer(Message).TimerID = HeaderTimer then - begin - // determine current mouse position to check if it left the window - GetCursorPos(P); - P := Treeview.ScreenToClient(P); - with FColumns do - begin - if not InHeader(P) or ((FDownIndex > NoColumn) and (FHoverIndex <> FDownIndex)) then - begin - Treeview.StopTimer(HeaderTimer); - FHoverIndex := NoColumn; - FClickIndex := NoColumn; - FDownIndex := NoColumn; - FCheckBoxHit := False; - Result := True; - Message.Result := 0; - Invalidate(nil); - end; - end; - end; - WM_MOUSEMOVE: // mouse capture and general message redirection - Result := HandleHeaderMouseMove(TWMMouseMove(Message)); - WM_SETCURSOR: - // Feature: design-time header - if (FStates = []) then - begin - // Retrieve last cursor position (GetMessagePos does not work here, I don't know why). - GetCursorPos(P); - - // Is the mouse in the header rectangle and near the splitters? - P := Treeview.ScreenToClient(P); - IsHSplitterHit := HSplitterHit; - // in design-time header columns are always resizable - if (csDesigning in Treeview.ComponentState) then - IsVSplitterHit := InHeaderSplitterArea(P) - else - IsVSplitterHit := InHeaderSplitterArea(P) and CanSplitterResize(P); - - if IsVSplitterHit or IsHSplitterHit then - begin - NewCursor := Screen.Cursors[Treeview.Cursor]; - if IsVSplitterHit and ((hoHeightResize in FOptions) or (csDesigning in Treeview.ComponentState)) then - NewCursor := Screen.Cursors[crVertSplit] - else - if IsHSplitterHit then - NewCursor := Screen.Cursors[crHeaderSplit]; - - if not (csDesigning in Treeview.ComponentState) then - Treeview.DoGetHeaderCursor(NewCursor); - Result := NewCursor <> Screen.Cursors[crDefault]; - if Result then - begin - Winapi.Windows.SetCursor(NewCursor); - Message.Result := 1; - end; - end; - end - else - begin - Message.Result := 1; - Result := True; - end; - WM_KEYDOWN, - WM_KILLFOCUS: - if (Message.Msg = WM_KILLFOCUS) or - (TWMKeyDown(Message).CharCode = VK_ESCAPE) then - begin - if hsDragging in FStates then - begin - ReleaseCapture; - FDragImage.EndDrag; - Exclude(FStates, hsDragging); - FColumns.DropTarget := 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.TrackIndex); - 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.DropTarget := NoColumn; - Start := Treeview.ScreenToClient(Start); - Inc(Start.Y, FHeight); - FColumns.DragIndex := FColumns.ColumnFromPosition(Start); - DragColumn := FColumns[FColumns.DragIndex]; - - Image := TBitmap.Create; - with Image do - try - PixelFormat := pf32Bit; - SetSize(DragColumn.Width, FHeight); - - // Erase the entire image with the color key value, for the case not everything - // in the image is covered by the header image. - Canvas.Brush.Color := clBtnFace; - Canvas.FillRect(Rect(0, 0, Width, Height)); - - if TreeView.UseRightToLeftAlignment then - RTLOffset := Treeview.ComputeRTLOffset - else - RTLOffset := 0; - with DragColumn do - FColumns.PaintHeader(Canvas, Rect(FLeft, 0, FLeft + Width, Height), Point(-RTLOffset, 0), RTLOffset); - - if Treeview.UseRightToLeftAlignment then - ImagePos := Treeview.ClientToScreen(Point(DragColumn.Left + Treeview.ComputeRTLOffset(True), 0)) - else - ImagePos := Treeview.ClientToScreen(Point(DragColumn.Left, 0)); - // Column rectangles are given in local window coordinates not client coordinates. - Dec(ImagePos.Y, FHeight); - - if hoRestrictDrag in FOptions then - FDragImage.MoveRestriction := dmrHorizontalOnly - else - FDragImage.MoveRestriction := dmrNone; - FDragImage.PrepareDrag(Image, ImagePos, P, nil); - FDragImage.ShowDragImage; - finally - Image.Free; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTHeader.ReadColumns(Reader: TReader); - -begin - Include(FStates, hsLoading); - Columns.Clear; - Reader.ReadValue; - Reader.ReadCollection(Columns); - Exclude(FStates, hsLoading); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTHeader.RecalculateHeader; - -// Initiate a recalculation of the non-client area of the owner tree. - -begin - if Treeview.HandleAllocated then - begin - Treeview.UpdateHeaderRect; - SetWindowPos(Treeview.Handle, 0, 0, 0, 0, 0, SWP_FRAMECHANGED or SWP_NOMOVE or SWP_NOACTIVATE or SWP_NOOWNERZORDER or - SWP_NOSENDCHANGING or SWP_NOSIZE or SWP_NOZORDER); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTHeader.RescaleHeader; - -// Rescale the fixed elements (fixed columns, header itself) to FixedAreaConstraints. - -var - FixedWidth, - MaxFixedWidth, - MinFixedWidth: Integer; - - //--------------- local function -------------------------------------------- - - procedure ComputeConstraints; - - var - I: TColumnIndex; - - begin - with FColumns do - begin - I := GetFirstVisibleColumn; - while I > NoColumn do - begin - if (coFixed in FColumns[I].Options) and (FColumns[I].Width < FColumns[I].MinWidth) then - FColumns[I].InternalSetWidth(FColumns[I].MinWidth); //SetWidth has side effects and this bypasses them - 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 (FMaxWidthPercent > 0) or (FMinWidthPercent > 0) or (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 - MainColumn := 0; - if FMainColumn > FColumns.Count - 1 then - MainColumn := FColumns.Count - 1; - if (FMainColumn >= 0) and not (coVisible in Self.Columns[FMainColumn].Options) then - begin - // Issue #946: Choose new MainColumn if current one ist not visible - MainColumn := Self.Columns.GetFirstVisibleColumn(); - end -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].Options = [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].Options = [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].SpringRest + Difference; - // Set new width if at least one pixel size difference is reached. - if NewAccumulator >= 1 then - FColumns[I].SetWidth(FColumns[I].Width + (Trunc(NewAccumulator) * Sign)); - FColumns[I].SpringRest := Frac(NewAccumulator); - - // Keep track of the size count. - ChangeBy := ChangeBy - Difference; - // Exit loop if resize count drops below freezing point. - if ChangeBy < 0 then - Break; - end; - end; - end; - with TreeView do - FLastWidth := FHeaderRect.Right - FHeaderRect.Left; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -type - // --- HACK WARNING! - // This type cast is a partial rewrite of the private section of TWriter. The purpose is to have access to - // the FPropPath member, which is otherwise not accessible. The reason why this access is needed is that - // with nested components this member contains unneeded property path information. These information prevent - // successful load of the stored properties later. - // In System.Classes.pas you can see that FPropPath is reset several times to '' to prevent this case for certain properies. - // Unfortunately, there is no clean way for us here to do the same. - {$hints off} - TWriterHack = class(TFiler) - private - FRootAncestor: TComponent; - FPropPath: string; - end; - {$hints on} - -procedure TVTHeader.WriteColumns(Writer: TWriter); - -// Write out the columns but take care for the case VT is a nested component. - -var - LastPropPath: string; - -begin - // Save last property path for restoration. - LastPropPath := TWriterHack(Writer).FPropPath; - try - // If VT is a nested component then this path contains the name of the parent component at this time - // (otherwise it is already empty). This path is then combined with the property name under which the tree - // is defined in the parent component. Unfortunately, the load code in System.Classes.pas does not consider this case - // is then unable to load this property. - TWriterHack(Writer).FPropPath := ''; - Writer.WriteCollection(Columns); - finally - TWriterHack(Writer).FPropPath := LastPropPath; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTHeader.AllowFocus(ColumnIndex: TColumnIndex): Boolean; -begin - Result := False; - if not FColumns.IsValidColumn(ColumnIndex) then - Exit; // Just in case. - - Result := (coAllowFocus in FColumns[ColumnIndex].Options); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTHeader.Assign(Source: TPersistent); - -begin - if Source is TVTHeader then - begin - AutoSizeIndex := TVTHeader(Source).AutoSizeIndex; - Background := TVTHeader(Source).Background; - Columns := TVTHeader(Source).Columns; - Font := TVTHeader(Source).Font; - FixedAreaConstraints.Assign(TVTHeader(Source).FixedAreaConstraints); - Height := TVTHeader(Source).Height; - Images := TVTHeader(Source).Images; - MainColumn := TVTHeader(Source).MainColumn; - Options := TVTHeader(Source).Options; - ParentFont := TVTHeader(Source).ParentFont; - PopupMenu := TVTHeader(Source).PopupMenu; - SortColumn := TVTHeader(Source).SortColumn; - SortDirection := TVTHeader(Source).SortDirection; - Style := TVTHeader(Source).Style; - - RescaleHeader; - end - else - inherited; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTHeader.AutoFitColumns(Animated: Boolean = True; SmartAutoFitType: TSmartAutoFitType = smaUseColumnOption; - RangeStartCol: Integer = NoColumn; RangeEndCol: Integer = NoColumn); - - //--------------- local functions ------------------------------------------- - - function GetUseSmartColumnWidth(ColumnIndex: TColumnIndex): Boolean; - - begin - case SmartAutoFitType of - smaAllColumns: - Result := True; - smaUseColumnOption: - Result := coSmartResize in FColumns.Items[ColumnIndex].Options; - else - Result := False; - end; - end; - - //---------------------------------------------------------------------------- - - procedure DoAutoFitColumn(Column: TColumnIndex); - - begin - with FColumns do - if ([coResizable, coVisible] * Items[FPositionToIndex[Column]].Options = [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); - FDoingAutoFitColumns := true; - 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); - TreeView.Invalidate(); - FDoingAutoFitColumns := false; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTHeader.InHeader(P: TPoint): Boolean; - -// Determines whether the given point (client coordinates!) is within the header rectangle (non-client coordinates). - -var - R, RW: TRect; - -begin - R := Treeview.FHeaderRect; - - // Current position of the owner in screen coordinates. - GetWindowRect(Treeview.Handle, RW); - - // Convert to client coordinates. - MapWindowPoints(0, Treeview.Handle, RW, 2); - - // Consider the header within this rectangle. - OffsetRect(R, RW.Left, RW.Top); - Result := PtInRect(R, P); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTHeader.InHeaderSplitterArea(P: TPoint): Boolean; - -// Determines whether the given point (client coordinates!) hits the horizontal splitter area of the header. - -var - R, RW: TRect; - -begin - if (P.Y > 2) or (P.Y < -2) or not (hoVisible in FOptions) then - Result := False - else - begin - R := Treeview.FHeaderRect; - Inc(R.Bottom, 2); - - // Current position of the owner in screen coordinates. - GetWindowRect(Treeview.Handle, RW); - - // Convert to client coordinates. - MapWindowPoints(0, Treeview.Handle, RW, 2); - - // Consider the header within this rectangle. - OffsetRect(R, RW.Left, RW.Top); - Result := PtInRect(R, P); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTHeader.Invalidate(Column: TVirtualTreeColumn; ExpandToBorder: Boolean = False; UpdateNowFlag : Boolean = False); - -// Because the header is in the non-client area of the tree it needs some special handling in order to initiate its -// repainting. -// If ExpandToBorder is True then not only the given column but everything or (depending on hoFullRepaintOnResize) just -// everything to its right (or left, in RTL mode) will be invalidated (useful for resizing). This makes only sense when -// a column is given. - -var - R, RW: TRect; - Flags: Cardinal; - -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.Options) 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; - R.Bottom := Treeview.ClientHeight; // We want to repaint the entire column to bottom, not just the header - - // 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); - Flags := RDW_FRAME or RDW_INVALIDATE or RDW_VALIDATE or RDW_NOINTERNALPAINT or RDW_NOERASE or RDW_NOCHILDREN; - if UpdateNowFlag then - Flags := Flags or RDW_UPDATENOW; - RedrawWindow(Handle, @R, 0, Flags); - 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 := UTF8ToString(S); - ReadBuffer(Dummy, SizeOf(Dummy)); - Pitch := TFontPitch(Dummy); - ReadBuffer(Dummy, SizeOf(Dummy)); - Style := TFontStyles(Byte(Dummy)); - end; - - // Read data introduced by stream version 1+. - if Version > 0 then - begin - ReadBuffer(Dummy, SizeOf(Dummy)); - MainColumn := Dummy; - ReadBuffer(Dummy, SizeOf(Dummy)); - SortColumn := Dummy; - ReadBuffer(Dummy, SizeOf(Dummy)); - SortDirection := TSortDirection(Byte(Dummy)); - end; - - // Read data introduced by stream version 5+. - if Version > 4 then - begin - ReadBuffer(Dummy, SizeOf(Dummy)); - ParentFont := Boolean(Dummy); - ReadBuffer(Dummy, SizeOf(Dummy)); - FMaxHeight := Integer(Dummy); - ReadBuffer(Dummy, SizeOf(Dummy)); - FMinHeight := Integer(Dummy); - ReadBuffer(Dummy, SizeOf(Dummy)); - FDefaultHeight := Integer(Dummy); - with FFixedAreaConstraints do - begin - ReadBuffer(Dummy, SizeOf(Dummy)); - FMaxHeightPercent := TVTConstraintPercent(Dummy); - ReadBuffer(Dummy, SizeOf(Dummy)); - FMaxWidthPercent := TVTConstraintPercent(Dummy); - ReadBuffer(Dummy, SizeOf(Dummy)); - FMinHeightPercent := TVTConstraintPercent(Dummy); - ReadBuffer(Dummy, SizeOf(Dummy)); - FMinWidthPercent := TVTConstraintPercent(Dummy); - end; - end; - finally - Exclude(FStates, hsLoading); - RecalculateHeader(); - 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].Options = Options) and - (FColumns[Column].Width > 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) and (RangeEndCol >= 0) then // RangeEndCol == -1 means no columns, so nothing to do - 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].Width; - 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].Options = 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].Options = Options) and IsResizable(I) then - ChangeWidth(I, Difference * Sign); - - // Now distribute Rest. - I := Start; - while Rest > 0 do - begin - if (Options * FColumns[I].Options = Options) and IsResizable(I) then - if FColumns[I].BonusPixel <> BonusPixel then - begin - Dec(Rest, ChangeWidth(I, Sign)); - FColumns[I].BonusPixel := 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].Options = Options then - FColumns[I].BonusPixel := not FColumns[I].BonusPixel; - 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].Options = Options) then - begin - Inc(Result, Widths[I - RangeStartCol] - FColumns[I].Width); - 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]].Options = [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 := FBackgroundColor; - WriteBuffer(Dummy, SizeOf(Dummy)); - Dummy := FHeight; - WriteBuffer(Dummy, SizeOf(Dummy)); - Dummy := Integer(FOptions); - WriteBuffer(Dummy, SizeOf(Dummy)); - // PopupMenu is neither saved nor restored - Dummy := Ord(FStyle); - WriteBuffer(Dummy, SizeOf(Dummy)); - // TFont has no own save routine so we do it manually - with Font do - begin - Dummy := Color; - WriteBuffer(Dummy, SizeOf(Dummy)); - - // Need only to write one: size or height, I decided to write height. - Dummy := Height; - WriteBuffer(Dummy, SizeOf(Dummy)); - Tmp := UTF8Encode(Name); - Dummy := Length(Tmp); - WriteBuffer(Dummy, SizeOf(Dummy)); - WriteBuffer(PAnsiChar(Tmp)^, Dummy); - Dummy := Ord(Pitch); - WriteBuffer(Dummy, SizeOf(Dummy)); - Dummy := Byte(Style); - WriteBuffer(Dummy, SizeOf(Dummy)); - end; - - // Data introduced by stream version 1. - Dummy := FMainColumn; - WriteBuffer(Dummy, SizeOf(Dummy)); - Dummy := FSortColumn; - WriteBuffer(Dummy, SizeOf(Dummy)); - Dummy := Byte(FSortDirection); - WriteBuffer(Dummy, SizeOf(Dummy)); - - // Data introduced by stream version 5. - Dummy := Integer(ParentFont); - WriteBuffer(Dummy, SizeOf(Dummy)); - Dummy := Integer(FMaxHeight); - WriteBuffer(Dummy, SizeOf(Dummy)); - Dummy := Integer(FMinHeight); - WriteBuffer(Dummy, SizeOf(Dummy)); - Dummy := Integer(FDefaultHeight); - WriteBuffer(Dummy, SizeOf(Dummy)); - with FFixedAreaConstraints do - begin - Dummy := Integer(FMaxHeightPercent); - WriteBuffer(Dummy, SizeOf(Dummy)); - Dummy := Integer(FMaxWidthPercent); - WriteBuffer(Dummy, SizeOf(Dummy)); - Dummy := Integer(FMinHeightPercent); - WriteBuffer(Dummy, SizeOf(Dummy)); - Dummy := Integer(FMinWidthPercent); - WriteBuffer(Dummy, SizeOf(Dummy)); - end; - end; -end; - -//----------------- TScrollBarOptions ---------------------------------------------------------------------------------- - -constructor TScrollBarOptions.Create(AOwner: TBaseVirtualTree); - -begin - inherited Create; - - FOwner := AOwner; - FAlwaysVisible := False; - FScrollBarStyle := sbmRegular; - FScrollBars := ssBoth; - FIncrementX := 20; - FIncrementY := 20; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TScrollBarOptions.SetAlwaysVisible(Value: Boolean); - -begin - if FAlwaysVisible <> Value then - begin - FAlwaysVisible := Value; - if not (csLoading in FOwner.ComponentState) and FOwner.HandleAllocated then - FOwner.RecreateWnd; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TScrollBarOptions.SetScrollBars(Value: TScrollStyle); - -begin - if FScrollBars <> Value then - begin - FScrollBars := Value; - if not (csLoading in FOwner.ComponentState) and FOwner.HandleAllocated then - FOwner.RecreateWnd; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TScrollBarOptions.SetScrollBarStyle(Value: TScrollBarStyle); - -begin - if FScrollBarStyle <> Value then - begin - FScrollBarStyle := Value; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TScrollBarOptions.GetOwner: TPersistent; - -begin - Result := FOwner; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TScrollBarOptions.Assign(Source: TPersistent); - -begin - if Source is TScrollBarOptions then - begin - AlwaysVisible := TScrollBarOptions(Source).AlwaysVisible; - HorizontalIncrement := TScrollBarOptions(Source).HorizontalIncrement; - ScrollBars := TScrollBarOptions(Source).ScrollBars; - ScrollBarStyle := TScrollBarOptions(Source).ScrollBarStyle; - VerticalIncrement := TScrollBarOptions(Source).VerticalIncrement; - end - else - inherited; -end; - -//----------------- TVTColors ------------------------------------------------------------------------------------------ - -constructor TVTColors.Create(AOwner: TBaseVirtualTree); -var - CE : TVTColorEnum; -begin - FOwner := AOwner; - for CE := Low(TVTColorEnum) to High(TVTColorEnum) do - FColors[CE] := cDefaultColors[CE]; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTColors.GetBackgroundColor: TColor; -begin -// XE2 VCL Style - if FOwner.VclStyleEnabled and (seClient in FOwner.StyleElements) then - Result := StyleServices.GetStyleColor(scTreeView) - else - Result := FOwner.Color; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTColors.GetColor(const Index: TVTColorEnum): TColor; -begin - // Only try to fetch the color via StyleServices if theses are enabled - // Return default/user defined color otherwise - if FOwner.VclStyleEnabled then - begin - // If the ElementDetails are not defined, fall back to the SystemColor - case Index of - cDisabledColor: - if not StyleServices.GetElementColor(StyleServices.GetElementDetails(ttItemDisabled), ecTextColor, Result) then - Result := StyleServices.GetSystemColor(FColors[Index]); - cTreeLineColor: - if not StyleServices.GetElementColor(StyleServices.GetElementDetails(ttBranch), ecBorderColor, Result) then - Result := StyleServices.GetSystemColor(FColors[Index]); - cBorderColor: - if (seBorder in FOwner.StyleElements) then - Result := StyleServices.GetSystemColor(FColors[Index]) - else - Result := FColors[Index]; - cHotColor: - if not StyleServices.GetElementColor(StyleServices.GetElementDetails(ttItemHot), ecTextColor, Result) then - Result := StyleServices.GetSystemColor(FColors[Index]); - cHeaderHotColor: - if not StyleServices.GetElementColor(StyleServices.GetElementDetails(thHeaderItemHot), ecTextColor, Result) then - Result := StyleServices.GetSystemColor(FColors[Index]); - cSelectionTextColor: - if not StyleServices.GetElementColor(StyleServices.GetElementDetails(ttItemSelected), ecTextColor, Result) then - Result := StyleServices.GetSystemColor(clHighlightText); - cUnfocusedColor: - if not StyleServices.GetElementColor(StyleServices.GetElementDetails(ttItemSelectedNotFocus), ecTextColor, Result) then - Result := StyleServices.GetSystemColor(FColors[Index]); - else - Result := StyleServices.GetSystemColor(FColors[Index]); - end; - end - else - Result := FColors[Index]; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTColors.GetHeaderFontColor: TColor; -begin -// XE2+ VCL Style - if FOwner.VclStyleEnabled and (seFont in FOwner.StyleElements) then - StyleServices.GetElementColor(StyleServices.GetElementDetails(thHeaderItemNormal), ecTextColor, Result) - else - Result := FOwner.Header.Font.Color; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTColors.GetNodeFontColor: TColor; -begin - if FOwner.VclStyleEnabled and (seFont in FOwner.StyleElements) then - StyleServices.GetElementColor(StyleServices.GetElementDetails(ttItemNormal), ecTextColor, Result) - else - Result := FOwner.Font.Color; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTColors.GetSelectedNodeFontColor(Focused: boolean): TColor; -begin - if Focused then begin - if (tsUseExplorerTheme in FOwner.TreeStates) and not IsHighContrastEnabled then begin - Result := NodeFontColor - end - else - Result := SelectionTextColor - end// if Focused - else - Result := UnfocusedColor; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTColors.SetColor(const Index: TVTColorEnum; 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 - cTreeLineColor: - begin - FOwner.PrepareBitmaps(True, False); - FOwner.Invalidate; - end; - cBorderColor: - RedrawWindow(FOwner.Handle, nil, 0, RDW_FRAME or RDW_INVALIDATE or RDW_NOERASE or RDW_NOCHILDREN) - else - FOwner.Invalidate; - end; - end; - end; -end; - -function TVTColors.StyleServices(AControl: TControl): TCustomStyleServices; -begin - if AControl = nil then - AControl := fOwner; - Result := VTStyleServices(AControl); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTColors.Assign(Source: TPersistent); - -begin - if Source is TVTColors then - begin - FColors := TVTColors(Source).FColors; - if FOwner.UpdateCount = 0 then - FOwner.Invalidate; - end - else - inherited; -end; //----------------- TClipboardFormats ---------------------------------------------------------------------------------- @@ -12968,8 +4439,7 @@ begin Pen.Color := FColors.UnfocusedSelectionBorderColor; end; - with TWithSafeRect(R) do - RoundRect(Left, Top, Right, Bottom, FSelectionCurveRadius, FSelectionCurveRadius); + RoundRect(R.Left, R.Top, R.Right, R.Bottom, FSelectionCurveRadius, FSelectionCurveRadius); end else begin @@ -13341,7 +4811,7 @@ begin begin FDragManager := DoCreateDragManager; if FDragManager = nil then - FDragManager := TVTDragManager.Create(Self); + FDragManager := TVTDragManager.Create(Self) as IVTDragManager; end; Result := FDragManager; @@ -15800,7 +7270,7 @@ begin FEffectiveOffsetX := 0; if toAutoBidiColumnOrdering in FOptions.AutoOptions then - FHeader.Columns.ReorderColumns(UseRightToLeftAlignment); + TVirtualTreeColumnsCracker(FHeader.Columns).ReorderColumns(UseRightToLeftAlignment); FHeader.Invalidate(nil); end; @@ -15966,7 +7436,7 @@ begin HeaderMessage.WParam := 0; HeaderMessage.LParam := 0; HeaderMessage.Result := 0; - FHeader.HandleMessage(HeaderMessage); + TVTHeaderCracker(FHeader).HandleMessage(HeaderMessage); end; //---------------------------------------------------------------------------------------------------------------------- @@ -16030,7 +7500,7 @@ begin CursorRect := FHeaderRect; // Convert the cursor rectangle into real client coordinates. OffsetRect(CursorRect, 0, -Integer(FHeader.Height)); - HitInfo.HitColumn := FHeader.Columns.GetColumnAndBounds(CursorPos, CursorRect.Left, CursorRect.Right); + HitInfo.HitColumn := TVirtualTreeColumnsCracker(FHeader.Columns).GetColumnAndBounds(CursorPos, CursorRect.Left, CursorRect.Right); if (HitInfo.HitColumn > NoColumn) and not (csLButtonDown in ControlState) and (FHeader.Columns[HitInfo.HitColumn].Hint <> '') then HintStr := FHeader.Columns[HitInfo.HitColumn].Hint; @@ -16053,7 +7523,7 @@ begin CursorRect := FHeaderRect; // Convert the cursor rectangle into real client coordinates. OffsetRect(CursorRect, 0, -Integer(FHeader.Height)); - HitInfo.HitColumn := FHeader.Columns.GetColumnAndBounds(CursorPos, CursorRect.Left, CursorRect.Right); + HitInfo.HitColumn := TVirtualTreeColumnsCracker(FHeader.Columns).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); @@ -16067,7 +7537,7 @@ begin with FHeader.Columns[HitInfo.HitColumn] do begin if (2 * FMargin + CaptionWidth + 1) >= Width then - HintStr := FCaptionText; + HintStr := CaptionText; end; if HintStr <> '' then ShowOwnHint := True @@ -16279,9 +7749,12 @@ begin if Assigned(Header) then begin - Header.FColumns.DownIndex := NoColumn; - Header.FColumns.HoverIndex := NoColumn; - Header.FColumns.CheckBoxHit := False; + with TVirtualTreeColumnsCracker(Header.Columns) do + begin + DownIndex := NoColumn; + HoverIndex := NoColumn; + CheckBoxHit := False; + end; end; DoMouseLeave(); inherited; @@ -16336,7 +7809,10 @@ begin else begin SystemParametersInfo(SPI_GETWHEELSCROLLLINES, 0, @ScrollLines, 0); - ScrollAmount := Trunc(WheelFactor * ScrollLines * FHeader.Columns.GetScrollWidth); + if ScrollLines = WHEEL_PAGESCROLL then + ScrollAmount := Trunc(WheelFactor * (ClientWidth - FHeader.Columns.GetVisibleFixedWidth)) + else + ScrollAmount := Integer(Trunc(WheelFactor * ScrollLines * FHeader.Columns.GetScrollWidth)); end; SetOffsetX(FOffsetX + RTLFactor * ScrollAmount); end; @@ -16413,8 +7889,8 @@ begin if vsExpanded in Node.States then Item.state := Item.state or TVIS_EXPANDED; - // Construct state image and overlay image indices. They are zero based, btw. - // and -1 means there is no image. + // 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)); @@ -17628,7 +9104,7 @@ begin with FHeader do if hoVisible in FHeader.Options then with Message.CalcSize_Params^ do - Inc(rgrc[0].Top, FHeight); + Inc(rgrc[0].Top, Height); end; //---------------------------------------------------------------------------------------------------------------------- @@ -17915,7 +9391,7 @@ begin if (CursorWnd = Handle) and ([tsWheelPanning, tsWheelScrolling] * FStates = []) then begin - if not FHeader.HandleMessage(TMessage(Message)) then + if not TVTHeaderCracker(FHeader).HandleMessage(TMessage(Message)) then begin // Apply own cursors only if there is no global cursor set. if Screen.Cursor = crDefault then @@ -17938,7 +9414,7 @@ begin Node := HitInfo.HitNode; if CanSplitterResizeNode(P, Node, HitInfo.HitColumn) then - NewCursor := crVertSplit; + NewCursor := crVSplit; end; end; @@ -17989,8 +9465,8 @@ begin try DoStateChange([tsSizing]); // This call will invalidate the entire non-client area which needs recalculation on resize. - FHeader.RescaleHeader; - FHeader.UpdateSpringColumns; + TVTHeaderCracker(FHeader).RescaleHeader; + TVTHeaderCracker(FHeader).UpdateSpringColumns; UpdateScrollBars(True); if (tsEditing in FStates) and not FHeader.UseColumns then @@ -18549,7 +10025,7 @@ begin else Flags := DefaultScalingFlags; // Important for #677 if (sfHeight in Flags) then begin - FHeader.ChangeScale(M, D, {$if CompilerVersion >= 31}isDpiChange{$ELSE} M <> D{$ifend}); + TVTHeaderCracker(FHeader).ChangeScale(M, D, {$if CompilerVersion >= 31}isDpiChange{$ELSE} M <> D{$ifend}); SetDefaultNodeHeight(MulDiv(FDefaultNodeHeight, M, D)); Indent := MulDiv(Indent, M, D); FTextMargin := MulDiv(FTextMargin, M, D); @@ -18592,7 +10068,8 @@ begin Run.NodeHeight := MulDiv(Run.NodeHeight, M, D); // The next three lines fix issue #1000 lNewNodeTotalHeight := MulDiv(Run.TotalHeight, M, D); - FRoot.TotalHeight := Cardinal(Int64(FRoot.TotalHeight) + Int64(lNewNodeTotalHeight) - Int64(Run.TotalHeight)); // Avoiding EIntOverflow exception. + FRoot.TotalHeight := FRoot.TotalHeight + lNewNodeTotalHeight - Run.TotalHeight; // 1 EIntOverflow exception seen here in debug build in 01/2021 + Run.TotalHeight := lNewNodeTotalHeight; end; Run := GetNextNoInit(Run); end; // while @@ -18803,7 +10280,7 @@ begin with Params do begin - Style := Style or WS_CLIPCHILDREN or WS_CLIPSIBLINGS or ScrollBar[ScrollBarOptions.FScrollBars]; + Style := Style or WS_CLIPCHILDREN or WS_CLIPSIBLINGS or ScrollBar[ScrollBarOptions.ScrollBars]; if toFullRepaintOnResize in FOptions.MiscOptions then WindowClass.style := WindowClass.style or CS_HREDRAW or CS_VREDRAW else @@ -18857,9 +10334,9 @@ begin // 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.States then - FHeader.RescaleHeader; + TVTHeaderCracker(FHeader).RescaleHeader; if hoAutoResize in FHeader.Options then - FHeader.Columns.AdjustAutoSize(InvalidColumn); + TVirtualTreeColumnsCracker(FHeader.Columns).AdjustAutoSize(InvalidColumn); PrepareBitmaps(True, True); @@ -18881,6 +10358,11 @@ begin end; +procedure TBaseVirtualTree.DecVisibleCount; +begin + Dec(FVisibleCount); +end; + procedure TBaseVirtualTree.DefineProperties(Filer: TFiler); // There were heavy changes in some properties during development of VT. This method helps to make migration easier @@ -18896,7 +10378,7 @@ begin inherited; // The header can prevent writing columns altogether. - if FHeader.CanWriteColumns then + if TVTHeaderCracker(FHeader).CanWriteColumns then begin // Check if we inherit from an ancestor form (Visual Form Inheritance). StoreIt := Filer.Ancestor = nil; @@ -18907,7 +10389,7 @@ begin else StoreIt := False; - Filer.DefineProperty('Columns', FHeader.ReadColumns, FHeader.WriteColumns, StoreIt); + Filer.DefineProperty('Columns', TVTHeaderCracker(FHeader).ReadColumns, TVTHeaderCracker(FHeader).WriteColumns, StoreIt); // #622 made old DFMs incompatible with new VTW - so the program is compiled successfully // and then suddenly crashes at user site in runtime. @@ -18930,8 +10412,11 @@ var begin ImageHit := HitInfo.HitPositions * [hiOnNormalIcon, hiOnStateIcon] <> []; LabelHit := hiOnItemLabel in HitInfo.HitPositions; - ItemHit := (hiOnItem in HitInfo.HitPositions) and ((toFullRowDrag in FOptions.MiscOptions) or - (toFullRowSelect in FOptions.SelectionOptions)); + //VSOFT ======================================== + //VSOFT 5.0 chang broke our drag/drop line info. + //VSOFT CHANGE - changed back to 4.8.5 behaviour + ItemHit := (hiOnItem in HitInfo.HitPositions);{ and ((toFullRowDrag in FOptions.MiscOptions) or + (toFullRowSelect in FOptions.SelectionOptions));} // In report mode only direct hits of the node captions/images in the main column are accepted as hits. if (toReportMode in FOptions.MiscOptions) and not (ItemHit or ((LabelHit or ImageHit) and @@ -21368,8 +12853,9 @@ begin begin FDropTargetNode := HitInfo.HitNode; R := GetDisplayRect(HitInfo.HitNode, FHeader.MainColumn, False); + //VSOFT CHANGE - changed back to 4.8.5 behaviour if (hiOnItemLabel in HitInfo.HitPositions) or ((hiOnItem in HitInfo.HitPositions) and - ((toFullRowDrag in FOptions.MiscOptions) or (toFullRowSelect in FOptions.SelectionOptions)))then + ((toFullRowDrag in FOptions.MiscOptions){ or (toFullRowSelect in FOptions.SelectionOptions)}))then FLastDropMode := dmOnNode else if ((R.Top + R.Bottom) div 2) > Pt.Y then @@ -21534,7 +13020,7 @@ begin NewDropMode := DetermineDropMode(Pt, HitInfo, R); if Assigned(Tree) then - DragImageWillMove := Tree.FDragImage.WillMove(DragPos) + DragImageWillMove := Tree.DragImage.WillMove(DragPos) else DragImageWillMove := False; @@ -22432,7 +13918,7 @@ begin FSearchBuffer := NewSearchText; FLastSearchNode := Run; FocusedNode := Run; - Selected[Run] := True; + AddToSelection(Run, False); FLastSearchNode := Run; end else @@ -22466,7 +13952,7 @@ begin if not (tsEditing in FStates) or DoEndEdit then begin - if HitInfo.HitColumn = FHeader.Columns.FClickIndex then + if HitInfo.HitColumn = FHeader.Columns.ClickIndex then DoColumnDblClick(HitInfo.HitColumn, KeysToShiftState(Message.Keys)); if HitInfo.HitNode <> nil then @@ -22638,10 +14124,10 @@ begin end; if IsEmpty then - exit; + Exit; // Nothing to do // Keep clicked column in case the application needs it. - FHeader.Columns.FClickIndex := HitInfo.HitColumn; + FHeader.Columns.ClickIndex := HitInfo.HitColumn; // Change column only if we have hit the node label. if (hiOnItemLabel in HitInfo.HitPositions) or @@ -22940,7 +14426,7 @@ begin tsScrollPending, tsScrolling]); StopTimer(ScrollTimer); - if (FHeader.Columns.FClickIndex > NoColumn) and (FHeader.Columns.FClickIndex = HitInfo.HitColumn) then + if (FHeader.Columns.ClickIndex > NoColumn) and (FHeader.Columns.ClickIndex = HitInfo.HitColumn) then DoColumnClick(HitInfo.HitColumn, KeysToShiftState(Message.Keys)); if FLastHitInfo.HitNode <> nil then begin // Use THitInfo of mouse down here, see issue #692 @@ -23003,6 +14489,13 @@ end; //---------------------------------------------------------------------------------------------------------------------- +procedure TBaseVirtualTree.IncVisibleCount; +begin + Inc(FVisibleCount); +end; + +//---------------------------------------------------------------------------------------------------------------------- + procedure TBaseVirtualTree.InitChildren(Node: PVirtualNode); // Initiates the initialization of the child number of the given node. @@ -23629,6 +15122,11 @@ begin end; end; +procedure TBaseVirtualTree.InternalSetFocusedColumn(const index: TColumnIndex); +begin + FFocusedColumn := index; +end; + //---------------------------------------------------------------------------------------------------------------------- procedure TBaseVirtualTree.InvalidateCache; @@ -23701,18 +15199,18 @@ begin // when auto resize is enabled. Updating; try - FHeader.UpdateMainColumn; - FHeader.Columns.FixPositions; + TVTHeaderCracker(FHeader).UpdateMainColumn; + TVirtualTreeColumnsCracker(FHeader.Columns).FixPositions; if toAutoBidiColumnOrdering in FOptions.AutoOptions then - FHeader.Columns.ReorderColumns(UseRightToLeftAlignment); + TVirtualTreeColumnsCracker(FHeader.Columns).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.States then - FHeader.RescaleHeader + TVTHeaderCracker(FHeader).RescaleHeader else - FHeader.RecalculateHeader; + TVTHeaderCracker(FHeader).RecalculateHeader; if hoAutoResize in FHeader.Options then - FHeader.Columns.AdjustAutoSize(InvalidColumn, True); + TVirtualTreeColumnsCracker(FHeader.Columns).AdjustAutoSize(InvalidColumn, True); finally Updated; end; @@ -23790,8 +15288,7 @@ begin if tsNodeHeightTracking in FStates then begin // Handle height tracking. - if DoNodeHeightTracking(FHeightTrackNode, FHeightTrackColumn, FHeader.GetShiftState, - FHeightTrackPoint, Point(X, Y)) then + if DoNodeHeightTracking(FHeightTrackNode, FHeightTrackColumn, TVTHeaderCracker(FHeader).GetShiftState, FHeightTrackPoint, Point(X, Y)) then begin // Avoid negative (or zero) node heights. if FHeightTrackPoint.Y >= Y then @@ -23935,17 +15432,14 @@ begin 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; + if beLeft in BevelEdges then + Inc(RC.Left, EdgeSize); + if beTop in BevelEdges then + Inc(RC.Top, EdgeSize); + if beRight in BevelEdges then + Dec(RC.Right, EdgeSize); + if beBottom in BevelEdges then + Dec(RC.Bottom, EdgeSize); end; // Repaint only the part in the original clipping region and not yet drawn parts. @@ -24517,20 +16011,17 @@ begin begin case Alignment of taLeftJustify: - with TWithSafeRect(InnerRect) do - if Left + NodeWidth < Right then - Right := Left + NodeWidth; + if InnerRect.Left + NodeWidth < InnerRect.Right then + InnerRect.Right := InnerRect.Left + NodeWidth; taCenter: - with TWithSafeRect(InnerRect) do - if (Right - Left) > NodeWidth then - begin - Left := (Left + Right - NodeWidth) div 2; - Right := Left + NodeWidth; - end; + if (InnerRect.Right - InnerRect.Left) > NodeWidth then + begin + InnerRect.Left := (InnerRect.Left + InnerRect.Right - NodeWidth) div 2; + InnerRect.Right := InnerRect.Left + NodeWidth; + end; taRightJustify: - with TWithSafeRect(InnerRect) do - if (Right - Left) > NodeWidth then - Left := Right - NodeWidth; + if (InnerRect.Right - InnerRect.Left) > NodeWidth then + InnerRect.Left := InnerRect.Right - NodeWidth; end; end; @@ -24556,8 +16047,7 @@ begin if (toUseBlendedSelection in FOptions.PaintOptions) then AlphaBlendSelection(Brush.Color) else - with TWithSafeRect(InnerRect) do - RoundRect(Left, Top, Right, Bottom, FSelectionCurveRadius, FSelectionCurveRadius); + RoundRect(InnerRect.Left, InnerRect.Top, InnerRect.Right, InnerRect.Bottom, FSelectionCurveRadius, FSelectionCurveRadius); end else begin @@ -24591,8 +16081,7 @@ begin if (toUseBlendedSelection in FOptions.PaintOptions) then AlphaBlendSelection(Brush.Color) else - with TWithSafeRect(InnerRect) do - RoundRect(Left, Top, Right, Bottom, FSelectionCurveRadius, FSelectionCurveRadius); + RoundRect(InnerRect.Left, InnerRect.Top, InnerRect.Right, InnerRect.Bottom, FSelectionCurveRadius, FSelectionCurveRadius); end; end; end; @@ -25825,7 +17314,7 @@ begin // Try the header whether it needs to take this message. if Assigned(FHeader) and (FHeader.States <> []) then - Handled := FHeader.HandleMessage(Message); + Handled := TVTHeaderCracker(FHeader).HandleMessage(Message); if not Handled then begin // For auto drag mode, let tree handle itself, instead of TControl. @@ -25846,7 +17335,7 @@ begin end; if not Handled and Assigned(FHeader) then - Handled := FHeader.HandleMessage(Message); + Handled := TVTHeaderCracker(FHeader).HandleMessage(Message); if not Handled then begin @@ -26579,11 +18068,14 @@ end; //---------------------------------------------------------------------------------------------------------------------- -procedure TBaseVirtualTree.CutToClipboard; +procedure TBaseVirtualTree.CutToClipboard(); +var + lDataObject: IDataObject; begin if (FSelectionCount > 0) and not (toReadOnly in FOptions.MiscOptions) then begin - if OleSetClipboard(TVTDataObject.Create(Self, True)) = S_OK then + lDataObject := TVTDataObject.Create(Self, True); + if OleSetClipboard(lDataObject) = S_OK then begin MarkCutCopyNodes; DoStateChange([tsCutPending], [tsCopyPending]); @@ -26757,7 +18249,10 @@ begin if not ParentClearing then begin - DetermineHiddenChildrenFlag(LastParent); + if FUpdateCount = 0 then + DetermineHiddenChildrenFlag(LastParent) + else + Include(FStates, tsUpdateHiddenChildrenNeeded); InvalidateCache; if FUpdateCount = 0 then begin @@ -27789,7 +19284,7 @@ begin if FHeader.UseColumns then begin - HitInfo.HitColumn := FHeader.Columns.GetColumnAndBounds(Point(X, Y), ColLeft, ColRight, False); + HitInfo.HitColumn := TVirtualTreeColumnsCracker(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.AutoOptions then begin @@ -27967,6 +19462,16 @@ end; //---------------------------------------------------------------------------------------------------------------------- +function TBaseVirtualTree.GetLastSelected(ConsiderChildrenAbove: Boolean = False): PVirtualNode; + +// Returns the last node in the current selection while optionally considering toChildrenAbove. + +begin + Result := GetPreviousSelected(nil, ConsiderChildrenAbove); +end; + +//---------------------------------------------------------------------------------------------------------------------- + function TBaseVirtualTree.GetLastVisible(Node: PVirtualNode = nil; ConsiderChildrenAbove: Boolean = True; IncludeFiltered: Boolean = False): PVirtualNode; @@ -29185,7 +20690,7 @@ begin if FSelectionCount > 0 then begin if (Node = nil) or (Node = FRoot) then - Result := FRoot.LastChild + Result := GetLastNoInit(nil, ConsiderChildrenAbove) else Result := GetPreviousNoInit(Node, ConsiderChildrenAbove); while Assigned(Result) and not (vsSelected in Result.States) do @@ -30725,14 +22230,14 @@ begin InitializeFirstColumnValues(PaintInfo); // Now go through all visible columns (there's still one run if columns aren't used). - with FHeader.Columns do + with TVirtualTreeColumnsCracker(FHeader.Columns) 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]; + PaintInfo.Column := PositionToIndex[PaintInfo.Position]; if FirstColumn = InvalidColumn then FirstColumn := PaintInfo.Column; PaintInfo.BidiMode := Items[PaintInfo.Column].BiDiMode; @@ -30816,7 +22321,7 @@ begin begin if BidiMode = bdLeftToRight then begin - DrawDottedHLine(PaintInfo, CellRect.Left + PaintInfo.Offsets[ofsCheckBox] - fImagesMargin, CellRect.Right - 1, CellRect.Bottom - 1); + DrawDottedHLine(PaintInfo, CellRect.Left + PaintInfo.Offsets[ofsCheckBox] - fImagesMargin, CellRect.Right - 1, CellRect.Bottom - 1); end else begin @@ -30927,7 +22432,7 @@ begin if coVisible in Items[NextColumn].Options then with PaintInfo do begin - Items[NextColumn].GetAbsoluteBounds(CellRect.Left, CellRect.Right); + TVirtualTreeColumnCracker(Items[NextColumn]).GetAbsoluteBounds(CellRect.Left, CellRect.Right); CellRect.Bottom := Node.NodeHeight; ContentRect.Bottom := Node.NodeHeight; end; @@ -30957,8 +22462,8 @@ begin // Put the constructed node image onto the target canvas. if not (poUnbuffered in PaintOptions) then - with TWithSafeRect(TargetRect), NodeBitmap do - BitBlt(TargetCanvas.Handle, Left, Top, Width, Height, Canvas.Handle, Window.Left, 0, SRCCOPY); + with NodeBitmap do + BitBlt(TargetCanvas.Handle, TargetRect.Left, TargetRect.Top, TargetRect.Width, TargetRect.Height, Canvas.Handle, Window.Left, 0, SRCCOPY); end; end; @@ -31200,23 +22705,20 @@ begin // Check that we have a valid rectangle. PaintRect := TreeRect; - with TWithSafeRect(TreeRect) do + if TreeRect.Left < 0 then begin - if Left < 0 then - begin - PaintTarget.X := -Left; - PaintRect.Left := 0; - end - else - PaintTarget.X := 0; - if Top < 0 then - begin - PaintTarget.Y := -Top; - PaintRect.Top := 0; - end - else - PaintTarget.Y := 0; - end; + PaintTarget.X := -TreeRect.Left; + PaintRect.Left := 0; + end + else + PaintTarget.X := 0; + if TreeRect.Top < 0 then + begin + PaintTarget.Y := -TreeRect.Top; + PaintRect.Top := 0; + end + else + PaintTarget.Y := 0; Image := TBitmap.Create; with Image do @@ -31693,7 +23195,7 @@ begin InitNode(Node); end; - if Recursive and (Node.ChildCount > 0) then // Prevent previoulsy uninitilaized children from being initialized. Issue #1145 + if Recursive then ReinitChildren(Node, True); end; @@ -31810,6 +23312,7 @@ var Run: PVirtualNode; UseColumns, HScrollBarVisible: Boolean; + OldOffsetY: Integer; ScrolledVertically, ScrolledHorizontally: Boolean; @@ -31835,13 +23338,13 @@ begin // The returned rectangle can never be empty after the expand code above. // 1) scroll vertically + OldOffsetY := FOffsetY; 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 @@ -31857,8 +23360,8 @@ begin // 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; + ScrolledVertically := OldOffsetY <> FOffsetY; if Horizontally then // 2) scroll horizontally @@ -31886,7 +23389,8 @@ function TBaseVirtualTree.ScrollIntoView(Column: TColumnIndex; Center: Boolean; var ColumnLeft, ColumnRight: Integer; - NewOffset: Integer; + NewOffset, + OldOffset: Integer; R: TRect; begin @@ -31903,6 +23407,7 @@ begin end else Exit; + OldOffset := FOffsetX; NewOffset := FEffectiveOffsetX; if not (FHeader.UseColumns and (coFixed in Header.Columns[Column].Options)) and (not Center) then begin @@ -31918,7 +23423,6 @@ begin else SetOffsetX(-NewOffset); end; - Result := True; end else if Center then begin @@ -31930,8 +23434,8 @@ begin else SetOffsetX(-NewOffset); end; - Result := True; - end + end; + Result := OldOffset <> FOffsetX; end; //---------------------------------------------------------------------------------------------------------------------- @@ -32934,654 +24438,6 @@ begin end; end; -//----------------- TCustomStringTreeOptions --------------------------------------------------------------------------- - -constructor TCustomStringTreeOptions.Create(AOwner: TBaseVirtualTree); - -begin - inherited; - - FStringOptions := DefaultStringOptions; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TCustomStringTreeOptions.SetStringOptions(const Value: TVTStringOptions); - -var - ChangedOptions: TVTStringOptions; - -begin - if FStringOptions <> Value then - begin - // Exclusive ORing to get all entries wich are in either set but not in both. - ChangedOptions := FStringOptions + Value - (FStringOptions * Value); - FStringOptions := Value; - with FOwner do - if (toShowStaticText in ChangedOptions) and not (csLoading in ComponentState) and HandleAllocated then - Invalidate; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TCustomStringTreeOptions.AssignTo(Dest: TPersistent); - -begin - if Dest is TCustomStringTreeOptions then - begin - with Dest as TCustomStringTreeOptions do - begin - StringOptions := Self.StringOptions; - EditOptions := Self.EditOptions; - end; - 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); - if not Assigned(Link) then - raise EArgumentException.Create('Paramter Link must not be 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.ClearLink; -begin - FLink := nil -end; - -//---------------------------------------------------------------------------------------------------------------------- -procedure TVTEdit.ClearRefLink; -begin - FRefLink := nil -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTEdit.CalcMinHeight: Integer; -var - textHeight : Integer; -begin - // Get the actual text height. - textHeight := GetTextSize.cy; - // The minimal height is the actual text height in pixels plus the the non client area. - Result := textHeight + (Height - ClientHeight); - // Also, proportionally to the text size, additional pixel(s) needs to be added for the caret. - Result := Result + Trunc(textHeight * 0.05); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTEdit.CMAutoAdjust(var Message: TMessage); - -begin - AutoAdjustSize; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTEdit.CMExit(var Message: TMessage); - -begin - if Assigned(FLink) and not FLink.Stopping then - with FLink, FTree do - begin - if (toAutoAcceptEditChange in TreeOptions.StringOptions) then - DoEndEdit - else - DoCancelEdit; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTEdit.CMRelease(var Message: TMessage); - -begin - Free; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTEdit.CNCommand(var Message: TWMCommand); - -begin - if Assigned(FLink) and Assigned(FLink.Tree) and (Message.NotifyCode = EN_UPDATE) and - not (vsMultiline in FLink.Node.States) then - // Instead directly calling AutoAdjustSize it is necessary on Win9x/Me to decouple this notification message - // and eventual resizing. Hence we use a message to accomplish that. - AutoAdjustSize() - else - inherited; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTEdit.WMChar(var Message: TWMChar); - -begin - if not (Message.CharCode in [VK_ESCAPE, VK_TAB]) then - inherited; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTEdit.WMDestroy(var Message: TWMDestroy); - -begin - // If editing stopped by other means than accept or cancel then we have to do default processing for - // pending changes. - if Assigned(FLink) and not FLink.Stopping and not (csRecreating in Self.ControlState) then - begin - with FLink, FTree do - begin - if (toAutoAcceptEditChange in TreeOptions.StringOptions) and Modified then - Text[FNode, FColumn] := FEdit.Text; - end; - FLink := nil; - FRefLink := nil; - end; - - inherited; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTEdit.WMGetDlgCode(var Message: TWMGetDlgCode); - -begin - inherited; - - Message.Result := Message.Result or DLGC_WANTALLKEYS or DLGC_WANTTAB or DLGC_WANTARROWS; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTEdit.WMKeyDown(var Message: TWMKeyDown); - -// Handles some control keys. - -var - Shift: TShiftState; - EndEdit: Boolean; - Tree: TBaseVirtualTree; - NextNode: PVirtualNode; - ColumnCandidate: Integer; - EditOptions: TVTEditOptions; - Column: TVirtualTreeColumn; -begin - Tree := FLink.Tree; - case Message.CharCode of - VK_ESCAPE: - begin - Tree.DoCancelEdit; - end; - VK_RETURN: - begin - EndEdit := not (vsMultiline in FLink.Node.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.Tree; - FLink.Tree.InvalidateNode(FLink.Node); - NextNode := Tree.GetNextVisible(FLink.Node, True); - FLink.Tree.DoEndEdit; - - // get edit options for column as priority. If column has toDefaultEdit - // use global edit options for tree - EditOptions := Tree.TreeOptions.EditOptions; // default - ColumnCandidate := -1; - if Tree.Header.Columns.Count > 0 then // are there any columns? - begin - Column := Tree.Header.Columns[Tree.FocusedColumn]; - if Column.EditOptions <> toDefaultEdit then - EditOptions := Column.EditOptions; - - // next column candidate for toVerticalEdit and toHorizontalEdit - if Column.EditNextColumn <> -1 then - ColumnCandidate := Column.EditNextColumn; - end; - - case EditOptions of - toDefaultEdit: Tree.TrySetFocus; - toVerticalEdit: - if NextNode <> nil then - begin - Tree.FocusedNode := NextNode; - - // for toVerticalEdit ColumnCandidate is also proper, - // select ColumnCandidate column in row below - if ColumnCandidate <> -1 then - begin - Tree.FocusedColumn := ColumnCandidate; - Tree.EditColumn := ColumnCandidate; - end; - - if Tree.CanEdit(Tree.FocusedNode, Tree.FocusedColumn) then - Tree.DoEdit; - end; - toHorizontalEdit: - begin - if ColumnCandidate = -1 then - begin - // for toHorizontalEdit if property EditNextColumn is not used - // try to use just next column - ColumnCandidate := Tree.FocusedColumn+1; - while (ColumnCandidate < Tree.Header.Columns.Count) - and not Tree.CanEdit(Tree.FocusedNode, ColumnCandidate) - do - Inc(ColumnCandidate); - end - else - if not Tree.CanEdit(Tree.FocusedNode, ColumnCandidate) then - ColumnCandidate := Tree.Header.Columns.Count; // omit "focus/edit column" (see below) - - if ColumnCandidate < Tree.Header.Columns.Count then - begin - Tree.FocusedColumn := ColumnCandidate; - Tree.EditColumn := ColumnCandidate; - Tree.DoEdit; - end; - end; - end; - end; - end; - VK_UP: - begin - if not (vsMultiline in FLink.Node.States) then - Message.CharCode := VK_LEFT; - inherited; - end; - VK_DOWN: - begin - if not (vsMultiline in FLink.Node.States) then - Message.CharCode := VK_RIGHT; - inherited; - end; - VK_TAB: - begin - if Tree.IsEditing then - begin - Tree.InvalidateNode(FLink.Node); - if ssShift in KeyDataToShiftState(Message.KeyData) then - NextNode := Tree.GetPreviousVisible(FLink.Node, True) // Shift+Tab goes to previous mode - else - NextNode := Tree.GetNextVisible(FLink.Node, True); - Tree.EndEditNode; - // check NextNode, otherwise we got AV - if NextNode <> nil then - begin - // Continue editing next node - Tree.ClearSelection(); - Tree.Selected[NextNode] := True; - if Tree.CanEdit(Tree.FocusedNode, Tree.FocusedColumn) then - Tree.DoEdit; - end; - end; - end; - Ord('A'): - begin - if Tree.IsEditing and ([ssCtrl] = KeyboardStateToShiftState) then - begin - Self.SelectAll(); - Message.CharCode := 0; - end; - end; - else - inherited; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTEdit.AutoAdjustSize; - -// Changes the size of the edit to accomodate as much as possible of its text within its container window. -// NewChar describes the next character which will be added to the edit's text. - -var - Size: TSize; -begin - if not (vsMultiline in FLink.Node.States) and not (toGridExtensions in FLink.Tree.TreeOptions.MiscOptions{see issue #252}) then - begin - // avoid flicker - SendMessage(Handle, WM_SETREDRAW, 0, 0); - try - Size := GetTextSize; - Inc(Size.cx, 2 * FLink.Tree.FTextMargin); - // Repaint associated node if the edit becomes smaller. - if Size.cx < Width then - FLink.Tree.Invalidate(); - - if FLink.Alignment = taRightJustify then - FLink.SetBounds(Rect(Left + Width - Size.cx, Top, Left + Width, Top + Max(Size.cy, Height))) - else - FLink.SetBounds(Rect(Left, Top, Left + Size.cx, Top + Max(Size.cy, Height))); - finally - SendMessage(Handle, WM_SETREDRAW, 1, 0); - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTEdit.CreateParams(var Params: TCreateParams); - -begin - inherited; - if not Assigned(FLink.Node) then - exit; // Prevent AV exceptions occasionally seen in code below - - // Only with multiline style we can use the text formatting rectangle. - // This does not harm formatting as single line control, if we don't use word wrapping. - with Params do - begin - Style := Style or ES_MULTILINE; - if vsMultiline in FLink.Node.States then - Style := Style and not (ES_AUTOHSCROLL or WS_HSCROLL) or WS_VSCROLL or ES_AUTOVSCROLL; - if tsUseThemes in FLink.Tree.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; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTEdit.GetTextSize: TSize; -var - DC: HDC; - LastFont: THandle; -begin - DC := GetDC(Handle); - LastFont := SelectObject(DC, Font.Handle); - try - // Read needed space for the current text. - GetTextExtentPoint32(DC, PChar(Text+'yG'), Length(Text)+2, Result); - finally - SelectObject(DC, LastFont); - ReleaseDC(Handle, DC); - end; -end; - -procedure TVTEdit.KeyPress(var Key: Char); -begin - if (Key = #13) and Assigned(FLink) and not (vsMultiline in FLink.Node.States) then - Key := #0; // Filter out return keys as they will be added to the text, avoids #895 - inherited; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTEdit.Release; - -begin - if HandleAllocated then - PostMessage(Handle, CM_RELEASE, 0, 0); -end; - -//----------------- TStringEditLink ------------------------------------------------------------------------------------ - -constructor TStringEditLink.Create; - -begin - inherited; - FEdit := TVTEdit.Create(Self); - with FEdit do - begin - Visible := False; - BorderStyle := bsSingle; - AutoSize := False; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -destructor TStringEditLink.Destroy; - -begin - if Assigned(FEdit) then - FEdit.Release; - inherited; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TStringEditLink.BeginEdit: Boolean; - -// Notifies the edit link that editing can start now. descendants may cancel node edit -// by returning False. - -begin - Result := not FStopping; - if Result then - begin - FEdit.Show; - FEdit.SelectAll; - FEdit.SetFocus; - FEdit.AutoAdjustSize; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TStringEditLink.SetEdit(const Value: TVTEdit); - -begin - if Assigned(FEdit) then - FEdit.Free; - FEdit := Value; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TStringEditLink.CancelEdit: Boolean; - -begin - Result := not FStopping; - if Result then - begin - FStopping := True; - FEdit.Hide; - FTree.CancelEditNode; - FEdit.ClearLink; - FEdit.ClearRefLink; - 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.ClearLink; - FEdit.ClearRefLink; - 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; - end; - FEdit.AutoSize := True; - FTree := Tree as TCustomVirtualStringTree; - FNode := Node; - FColumn := Column; - FEdit.Parent := Tree; - // Initial size, font and text of the node. - FTree.GetTextInfo(Node, Column, FEdit.Font, FTextBounds, Text); - FEdit.Font.Color := clWindowText; - FEdit.RecreateWnd; - FEdit.AutoSize := False; - FEdit.Text := Text; - - if Column <= NoColumn then - begin - FEdit.BidiMode := FTree.BidiMode; - FAlignment := FTree.Alignment; - end - else - begin - FEdit.BidiMode := FTree.Header.Columns[Column].BidiMode; - FAlignment := FTree.Header.Columns[Column].Alignment; - end; - - if FEdit.BidiMode <> bdLeftToRight then - ChangeBidiModeAlignment(FAlignment); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TStringEditLink.ProcessMessage(var Message: TMessage); - -begin - FEdit.WindowProc(Message); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TStringEditLink.SetBounds(R: TRect); - -// Sets the outer bounds of the edit control and the actual edit area in the control. - -var - lOffset, tOffset, height: Integer; - offsets : TVTOffsets; -begin - if not FStopping then - begin - // Check if the provided rect height is smaller than the edit control height. - height := R.Bottom - R.Top; - if height < FEdit.ClientHeight then - begin - // If the height is smaller than the minimal height we must correct it, otherwise the caret will be invisible. - tOffset := FEdit.CalcMinHeight - height; - if tOffset > 0 then - Inc(R.Bottom, tOffset); - end; - - // 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; - - // If toGridExtensions are turned on, we can fine tune the left margin (or the right margin if RTL is on) - // of the text to exactly match the text in the tree cell. - if (toGridExtensions in FTree.TreeOptions.MiscOptions) and - ((FAlignment = taLeftJustify) and (FEdit.BidiMode = bdLeftToRight) or - (FAlignment = taRightJustify) and (FEdit.BidiMode <> bdLeftToRight)) then - begin - // Calculate needed text area offset. - FTree.GetOffsets(FNode, offsets, ofsText, FColumn); - if FColumn = FTree.Header.MainColumn then - begin - if offsets[ofsToggleButton] < 0 then - lOffset := -(offsets[ofsToggleButton] + 2) - else - lOffset := 0; - end - else - lOffset := offsets[ofsText] - offsets[ofsMargin] + 1; - // Apply the offset. - if FEdit.BidiMode = bdLeftToRight then - Inc(R.Left, lOffset) - else - Dec(R.Right, lOffset); - end; - - lOffset := IfThen(vsMultiline in FNode.States, 0, 2); - if tsUseThemes in FTree.TreeStates then - Inc(lOffset); - InflateRect(R, -FTree.TextMargin + lOffset, lOffset); - if not (vsMultiline in FNode.States) then - begin - tOffset := FTextBounds.Top - FEdit.Top; - // Do not apply a negative offset, the cursor will disappear. - if tOffset > 0 then - OffsetRect(R, 0, tOffset); - end; - 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 ------------------------------------------------------------------------------- @@ -33769,7 +24625,7 @@ begin else if vsSelected in Node.States then begin - Canvas.Font.Color := FColors.GetSelectedNodeFontColor(Focused); + Canvas.Font.Color := FColors.GetSelectedNodeFontColor(Focused or (toPopupMode in FOptions.PaintOptions)); end; end; end; @@ -33884,7 +24740,7 @@ begin if Node = FDropTargetNode then begin if (FLastDropMode = dmOnNode) or (vsSelected in Node.States) then - Canvas.Font.Color := FColors.GetSelectedNodeFontColor(Focused) + Canvas.Font.Color := FColors.GetSelectedNodeFontColor(Focused or (toPopupMode in FOptions.PaintOptions)) else Canvas.Font.Color := FColors.NodeFontColor; end @@ -33892,7 +24748,7 @@ begin if vsSelected in Node.States then begin if Focused or (toPopupMode in FOptions.PaintOptions) then - Canvas.Font.Color := FColors.GetSelectedNodeFontColor(Focused) + Canvas.Font.Color := FColors.GetSelectedNodeFontColor(Focused or (toPopupMode in FOptions.PaintOptions)) else Canvas.Font.Color := FColors.NodeFontColor; end; @@ -34947,72 +25803,6 @@ begin Result := TStringTreeOptions; end; -//---------------------------------------------------------------------------------------------------------------------- - -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; - //---------------------------------------------------------------------------------------------------------------------- @@ -35097,56 +25887,6 @@ begin Self.ExportType := pExportType; end; -{ TCheckStateHelper } - -function TCheckStateHelper.IsDisabled: Boolean; -begin - Result := Self >= TCheckState.csUncheckedDisabled; -end; - -function TCheckStateHelper.IsChecked: Boolean; -begin - Result := Self in [csCheckedNormal, csCheckedPressed, csCheckedDisabled]; -end; - -function TCheckStateHelper.IsUnChecked: Boolean; -begin - Result := Self in [csUnCheckedNormal, csUnCheckedPressed, csUnCheckedDisabled]; -end; - -function TCheckStateHelper.IsMixed: Boolean; -begin - Result := Self in [csMixedNormal, csMixedPressed, csMixedDisabled]; -end; - -function TCheckStateHelper.GetEnabled: TCheckState; -begin - Result := cEnabledState[Self]; -end; - -function TCheckStateHelper.GetPressed(): TCheckState; -begin - Result := cPressedState[Self]; -end; - -function TCheckStateHelper.GetUnpressed(): TCheckState; -begin - Result := cUnpressedState[Self]; -end; - -function TCheckStateHelper.GetToggled(): TCheckState; -begin - Result := cToggledState[Self]; -end; - -{ TSortDirectionHelper } - -function TSortDirectionHelper.ToInt(): Integer; -begin - Result := cSortDirectionToInt[Self]; -end; - - { TVTPaintInfo } procedure TVTPaintInfo.AdjustImageCoordinates(); @@ -35176,36 +25916,10 @@ begin ImageInfo[iiCheck].YPos := CellRect.Top + VAlign - ImageInfo[iiCheck].Images.Height div 2; end; -{ THeaderPaintInfo } - -procedure THeaderPaintInfo.DrawDropMark(); -var - Y: Integer; - lArrowWidth: Integer; -begin - lArrowWidth := Self.Column.Owner.Header.Treeview.ScaledPixels(5); - Y := (PaintRectangle.Top + PaintRectangle.Bottom - 3 * lArrowWidth) div 2; - if DropMark = dmmLeft then - DrawArrow(TargetCanvas, TScrollDirection.sdLeft, Point(PaintRectangle.Left, Y), lArrowWidth) - else - DrawArrow(TargetCanvas, TScrollDirection.sdRight, Point(PaintRectangle.Right - lArrowWidth - (lArrowWidth div 2) {spacing}, Y), lArrowWidth); -end; - -procedure THeaderPaintInfo.DrawSortArrow(pDirection: TSortDirection); -const - cDirection: array[TSortDirection] of TScrollDirection = (TScrollDirection.sdUp, TScrollDirection.sdDown); -var - lOldColor: TColor; -begin - lOldColor := TargetCanvas.Pen.Color; - TargetCanvas.Pen.Color := clDkGray; - DrawArrow(TargetCanvas, cDirection[pDirection], Point(SortGlyphPos.X, SortGlyphPos.Y), SortGlyphSize.cy); - TargetCanvas.Pen.Color := lOldColor; -end; - initialization finalization FinalizeGlobalStructures(); end. + diff --git a/components/virtualtreeview/Source/VirtualTrees.res b/components/virtualtreeview/Source/VirtualTrees.res index deb671eb..558fd1ef 100644 Binary files a/components/virtualtreeview/Source/VirtualTrees.res and b/components/virtualtreeview/Source/VirtualTrees.res differ diff --git a/components/virtualtreeview/packages/Delphi11.2/VirtualTreesR.dpk b/components/virtualtreeview/packages/Delphi11.2/VirtualTreesR.dpk index ec3458cb..bae6130d 100644 --- a/components/virtualtreeview/packages/Delphi11.2/VirtualTreesR.dpk +++ b/components/virtualtreeview/packages/Delphi11.2/VirtualTreesR.dpk @@ -33,16 +33,24 @@ requires vclx; contains - VirtualTrees in '..\..\Source\VirtualTrees.pas', - VirtualTrees.HeaderPopup in '..\..\Source\VirtualTrees.HeaderPopup.pas', - VirtualTrees.AccessibilityFactory in '..\..\Source\VirtualTrees.AccessibilityFactory.pas', VirtualTrees.Accessibility in '..\..\Source\VirtualTrees.Accessibility.pas', - VirtualTrees.StyleHooks in '..\..\Source\VirtualTrees.StyleHooks.pas', - VirtualTrees.Classes in '..\..\Source\VirtualTrees.Classes.pas', - VirtualTrees.WorkerThread in '..\..\Source\VirtualTrees.WorkerThread.pas', - VirtualTrees.ClipBoard in '..\..\Source\VirtualTrees.ClipBoard.pas', + VirtualTrees.AccessibilityFactory in '..\..\Source\VirtualTrees.AccessibilityFactory.pas', VirtualTrees.Actions in '..\..\Source\VirtualTrees.Actions.pas', + VirtualTrees.Classes in '..\..\Source\VirtualTrees.Classes.pas', + VirtualTrees.ClipBoard in '..\..\Source\VirtualTrees.ClipBoard.pas', + VirtualTrees.Colors in '..\..\Source\VirtualTrees.Colors.pas', + VirtualTrees.DataObject in '..\..\Source\VirtualTrees.DataObject.pas', + VirtualTrees.DragImage in '..\..\Source\VirtualTrees.DragImage.pas', + VirtualTrees.DragnDrop in '..\..\Source\VirtualTrees.DragnDrop.pas', + VirtualTrees.DrawTree in '..\..\Source\VirtualTrees.DrawTree.pas', + VirtualTrees.EditLink in '..\..\Source\VirtualTrees.EditLink.pas', VirtualTrees.Export in '..\..\Source\VirtualTrees.Export.pas', - VirtualTrees.Utils in '..\..\Source\VirtualTrees.Utils.pas'; + VirtualTrees.Header in '..\..\Source\VirtualTrees.Header.pas', + VirtualTrees.HeaderPopup in '..\..\Source\VirtualTrees.HeaderPopup.pas', + VirtualTrees in '..\..\source\VirtualTrees.pas', + VirtualTrees.StyleHooks in '..\..\Source\VirtualTrees.StyleHooks.pas', + VirtualTrees.Types in '..\..\Source\VirtualTrees.Types.pas', + VirtualTrees.Utils in '..\..\Source\VirtualTrees.Utils.pas', + VirtualTrees.WorkerThread in '..\..\Source\VirtualTrees.WorkerThread.pas'; end. diff --git a/components/virtualtreeview/packages/Delphi11.2/VirtualTreesR.dproj b/components/virtualtreeview/packages/Delphi11.2/VirtualTreesR.dproj index 3664bb4b..f6ab2d8a 100644 --- a/components/virtualtreeview/packages/Delphi11.2/VirtualTreesR.dproj +++ b/components/virtualtreeview/packages/Delphi11.2/VirtualTreesR.dproj @@ -6,7 +6,7 @@ DCC32 VCL VirtualTreesR.dpk - Win32 + Win64 {B62F3689-96E1-47D5-9FB2-2A2718281FDB} 19.5 3 @@ -64,17 +64,25 @@ - - - - - - - + + + + + + + + + + + + + + + Base @@ -133,4 +141,5 @@ + diff --git a/source/main.pas b/source/main.pas index cd100868..1c30de05 100644 --- a/source/main.pas +++ b/source/main.pas @@ -17,7 +17,7 @@ uses routine_editor, trigger_editor, event_editor, preferences, EditVar, apphelpers, createdatabase, table_editor, TableTools, View, Usermanager, SelectDBObject, connections, sqlhelp, dbconnection, insertfiles, searchreplace, loaddata, copytable, csv_detector, Cromis.DirectoryWatch, SyncDB, gnugettext, - VirtualTrees, VirtualTrees.HeaderPopup, VirtualTrees.Utils, VirtualTrees.Types, + VirtualTrees, VirtualTrees.Header, VirtualTrees.HeaderPopup, VirtualTrees.Utils, VirtualTrees.Types, JumpList, System.Actions, System.UITypes, Vcl.Imaging.pngimage, System.ImageList, Vcl.Styles.UxTheme, Vcl.Styles.Utils.Menus, Vcl.Styles.Utils.Forms, Vcl.VirtualImageList, Vcl.BaseImageCollection, Vcl.ImageCollection, System.IniFiles, extra_controls, diff --git a/source/routine_editor.pas b/source/routine_editor.pas index e9ce7485..ef895538 100644 --- a/source/routine_editor.pas +++ b/source/routine_editor.pas @@ -4,7 +4,7 @@ interface uses Winapi.Windows, System.SysUtils, System.Classes, Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs, SynEdit, SynMemo, Vcl.StdCtrls, - Vcl.ComCtrls, Vcl.ToolWin, VirtualTrees, SynRegExpr, extra_controls, + Vcl.ComCtrls, Vcl.ToolWin, VirtualTrees, VirtualTrees.EditLink, SynRegExpr, extra_controls, dbconnection, apphelpers, gnugettext, Vcl.Menus, Vcl.ExtCtrls; type diff --git a/source/tabletools.pas b/source/tabletools.pas index bf777b29..c62e8df4 100644 --- a/source/tabletools.pas +++ b/source/tabletools.pas @@ -10,7 +10,7 @@ interface uses Winapi.Windows, System.SysUtils, System.Classes, Vcl.Controls, Vcl.Forms, Vcl.StdCtrls, Vcl.ComCtrls, Vcl.Buttons, Vcl.Dialogs, Vcl.StdActns, - VirtualTrees, Vcl.ExtCtrls, Vcl.Graphics, SynRegExpr, System.Math, System.Generics.Collections, extra_controls, + VirtualTrees, VirtualTrees.Header, Vcl.ExtCtrls, Vcl.Graphics, SynRegExpr, System.Math, System.Generics.Collections, extra_controls, dbconnection, apphelpers, Vcl.Menus, gnugettext, System.DateUtils, System.Zip, System.UITypes, System.StrUtils, Winapi.Messages, SynEdit, SynMemo, Vcl.ClipBrd, generic_types;