From bdbb669f677db2382086082acff13b4226671c71 Mon Sep 17 00:00:00 2001
From: chuacw <1757930+chuacw@users.noreply.github.com>
Date: Sat, 7 Feb 2026 14:19:40 +0800
Subject: [PATCH] Updated tests for missing OnChange event
Updated tests for missing OnChange event
Fixed code to properly handle combination of toMultiSelect, toExtendedFocus and toFullRowSelect
---
Source/VirtualTrees.BaseTree.pas | 204 ++++++++++--------
Tests/Tests.dpr | 3 +-
Tests/Tests.dproj | 4 +
...CellSelectionTests.VTSelectionTestForm.dfm | 73 +++++++
...CellSelectionTests.VTSelectionTestForm.pas | 181 ++++++++++++++++
Tests/VTCellSelectionTests.pas | 159 +++++++++++---
Tests/VirtualTrees.MouseUtils.pas | 7 +-
Tests/VisibilityTest.dpr | 5 +-
Tests/VisibilityTest.dproj | 5 +
9 files changed, 515 insertions(+), 126 deletions(-)
create mode 100644 Tests/VTCellSelectionTests.VTSelectionTestForm.dfm
create mode 100644 Tests/VTCellSelectionTests.VTSelectionTestForm.pas
diff --git a/Source/VirtualTrees.BaseTree.pas b/Source/VirtualTrees.BaseTree.pas
index 742734b5..e7669939 100644
--- a/Source/VirtualTrees.BaseTree.pas
+++ b/Source/VirtualTrees.BaseTree.pas
@@ -978,9 +978,15 @@ TBaseVirtualTree = class abstract(TVTBaseAncestor)
procedure DoCanSplitterResizeNode(P: TPoint; Node: PVirtualNode; Column: TColumnIndex;
var Allowed: Boolean); virtual;
procedure DoChange(Node: PVirtualNode); virtual;
+
///
- /// Notifies that the selected cells have changed. Nodes can be empty
+ /// Notifies that the selected cells have changed. Cells can be empty
///
+ ///
+ /// Multiple events might be fired for the same selection
+ /// Do not assume that only 1 cell change event will be fired for the same
+ /// cell change
+ ///
///
///
procedure DoChangeCell(const Cells: TVTCellArray); virtual;
@@ -1143,19 +1149,46 @@ TBaseVirtualTree = class abstract(TVTBaseAncestor)
ForceInsert: Boolean): Boolean; overload;
///
- ///
- /// Multiple cell select support / multicell
- /// Multi-selection requires [toExtendedFocus, toMultiSelect] - [toFullRowSelect]
- ///
+ /// Adds a cell to the existing selection
///
+ ///
+ /// Cell to add to existing selection
+ ///
+ ///
+ ///
+ ///
+ /// True if added successfully, false if Cell already exists, or not added
+ ///
function InternalAddToCellSelection(const Cell: TVTCell; ForceInsert: Boolean): Boolean;
+
+ ///
+ /// Removes a cell from the existing selection
+ ///
+ ///
+ /// Cell to remove from existing selection
+ ///
procedure InternalRemoveFromCellSelection(const Cell: TVTCell); virtual;
procedure InternalClearCellSelection; virtual;
+
+ ///
+ ///
+ ///
+ /// With the current design, cell multi-selection hinges on the existing
+ /// toMultiSelect in addition to toExtendedFocus being present and
+ /// toFullRowSelect being absent. When overriding this function,
+ /// be sure to check that the logic is compatible with existing code
+ ///
+ ///
+ /// True if cell selection has been enabled, false otherwise
+ ///
function IsCellSelectionEnabled: Boolean; virtual;
procedure AddToCellSelection(const Cell: TVTCell; ForceInsert: Boolean);
procedure RemoveFromCellSelection(const Cell: TVTCell);
- function InternalIsCellSelected(Node: PVirtualNode; Column: TColumnIndex): Boolean;
+ // Internal functions do not check if cell selection is enabled, since they
+ // should already be performed by their wrapper functions
+ function InternalIsCellSelected(Node: PVirtualNode; Column: TColumnIndex): Boolean; overload;
+ function InternalIsCellSelected(const Cell: TVTCell): Boolean; overload;
procedure InternalSelectCells(StartCell, EndCell: TVTCell; AddOnly: Boolean); virtual;
procedure InternalUnselectCells(StartCell, EndCell: TVTCell); virtual;
@@ -1338,9 +1371,15 @@ TBaseVirtualTree = class abstract(TVTBaseAncestor)
property OnCanSplitterResizeHeader: TVTCanSplitterResizeHeaderEvent read FOnCanSplitterResizeHeader write FOnCanSplitterResizeHeader;
property OnCanSplitterResizeNode: TVTCanSplitterResizeNodeEvent read FOnCanSplitterResizeNode write FOnCanSplitterResizeNode;
property OnChange: TVTChangeEvent read FOnChange write FOnChange;
+
///
- /// Called when cell selection changes
+ /// Notifies that the selected cells have changed. Cells can be empty
///
+ ///
+ /// Multiple events might be fired for the same selection
+ /// Do not assume that only 1 cell change event will be fired for the same
+ /// cell change
+ ///
property OnChangeCell: TVTChangeCellEvent read FOnChangeCell write FOnChangeCell;
property OnChecked: TVTChangeEvent read FOnChecked write FOnChecked;
property OnChecking: TVTCheckChangingEvent read FOnChecking write FOnChecking;
@@ -1664,7 +1703,9 @@ TBaseVirtualTree = class abstract(TVTBaseAncestor)
/// If True, adds the range to the existing selection without clearing it.
///
procedure SelectCells(StartNode: PVirtualNode; StartColumn:
- TColumnIndex; EndNode: PVirtualNode; EndColumn: TColumnIndex; AddOnly: Boolean);
+ TColumnIndex; EndNode: PVirtualNode; EndColumn: TColumnIndex; AddOnly: Boolean); overload;
+
+ procedure SelectCells(const StartCell, EndCell: TVTCell; AddOnly: Boolean); overload;
///
/// Unselects the rectangular range of cells specified by the rest of the
@@ -1886,7 +1927,12 @@ procedure TBaseVirtualTree.SelectCells(StartNode: PVirtualNode; StartColumn: TCo
begin
S := TVTCell.Create(StartNode, StartColumn);
E := TVTCell.Create(EndNode, EndColumn);
- InternalSelectCells(S, E, AddOnly);
+ SelectCells(S, E, AddOnly);
+end;
+
+procedure TBaseVirtualTree.SelectCells(const StartCell, EndCell: TVTCell; AddOnly: Boolean);
+begin
+ InternalSelectCells(StartCell, EndCell, AddOnly);
ChangeCell(FSelectedCells);
end;
@@ -1913,7 +1959,6 @@ procedure TBaseVirtualTree.ClearCellSelection;
//----------------------------------------------------------------------------------------------------------------------
function TBaseVirtualTree.IsCellSelected(Node: PVirtualNode; Column: TColumnIndex): Boolean;
-
begin
Result := InternalIsCellSelected(Node, Column);
end;
@@ -3707,10 +3752,11 @@ procedure TBaseVirtualTree.HandleClickSelection(LastFocused, NewNode: PVirtualNo
ClickedCell: TVTCell;
// Handles multi-selection with mouse click.
-
+ LCellSelectionEnabled: LongBool;
begin
+ LCellSelectionEnabled := IsCellSelectionEnabled;
// Support cell selection when clicking a specific column (and full-row-select is off)
- if (FLastHitInfo.HitColumn > NoColumn) and not (toFullRowSelect in FOptions.SelectionOptions) then
+ if (FLastHitInfo.HitColumn > NoColumn) and LCellSelectionEnabled then
begin
// build the clicked cell (use ClickIndex as it reflects the saved hit column)
ClickedCell.Node := NewNode;
@@ -3731,20 +3777,21 @@ procedure TBaseVirtualTree.HandleClickSelection(LastFocused, NewNode: PVirtualNo
else
FCellRangeAnchor := ClickedCell;
end;
- InternalSelectCells(FCellRangeAnchor, ClickedCell, True);
+ SelectCells(FCellRangeAnchor, ClickedCell, True);
+ Invalidate;
end
- else
- begin
- if not (toSiblingSelectConstraint in FOptions.SelectionOptions) then
- FCellRangeAnchor := ClickedCell;
- if DragPending then
- DoStateChange([tsToggleFocusedSelection])
else
- if InternalIsCellSelected(ClickedCell.Node, ClickedCell.Column) then
- RemoveFromCellSelection(ClickedCell)
+ begin
+ if not (toSiblingSelectConstraint in FOptions.SelectionOptions) then
+ FCellRangeAnchor := ClickedCell;
+ if DragPending then
+ DoStateChange([tsToggleFocusedSelection])
else
- AddToCellSelection(ClickedCell, True);
- end;
+ if InternalIsCellSelected(ClickedCell.Node, ClickedCell.Column) then
+ RemoveFromCellSelection(ClickedCell)
+ else
+ AddToCellSelection(ClickedCell, True);
+ end;
end
else
// Shift key down
@@ -3760,15 +3807,15 @@ procedure TBaseVirtualTree.HandleClickSelection(LastFocused, NewNode: PVirtualNo
else
FCellRangeAnchor := ClickedCell;
end;
- InternalSelectCells(FCellRangeAnchor, ClickedCell, True);
+ SelectCells(FCellRangeAnchor, ClickedCell, True);
Invalidate;
end
else
begin
- // Clear any existing cell selection and select the clicked cell.
- InternalClearCellSelection;
- AddToCellSelection(ClickedCell, True);
- FCellRangeAnchor := ClickedCell;
+ // Clear any existing cell selection and select the clicked cell.
+ InternalClearCellSelection;
+ AddToCellSelection(ClickedCell, True);
+ FCellRangeAnchor := ClickedCell;
end;
Exit;
end;
@@ -7393,7 +7440,7 @@ procedure TBaseVirtualTree.WMKeyDown(var Message: TWMKeyDown);
// multicell support / select multiple cells
SelectedCell := TVTCell.Create(FFocusedNode, FFocusedColumn);
OldCell := FCellRangeAnchor;
- InternalSelectCells(OldCell, SelectedCell, True);
+ SelectCells(OldCell, SelectedCell, True);
end;
if Assigned(FFocusedNode) then
@@ -12797,6 +12844,8 @@ procedure TBaseVirtualTree.HandleMouseDown(var Message: TWMMouse; var HitInfo: T
else
AltPressed := False;
+ // Cell multi-selection hinges on the existing toMultiSelect in addition
+ // to toExtendedFocus being present and toFullRowSelect being absent
LCellSelectionEnabled := IsCellSelectionEnabled;
// Various combinations determine what states the tree enters now.
@@ -12942,7 +12991,7 @@ procedure TBaseVirtualTree.HandleMouseDown(var Message: TWMMouse; var HitInfo: T
end
else
ClearSelection(False);
- end;
+ end;
// pending node edit
if Focused and
@@ -13003,7 +13052,8 @@ procedure TBaseVirtualTree.HandleMouseDown(var Message: TWMMouse; var HitInfo: T
FRangeAnchor := HitInfo.HitNode;
// If a column was hit on a plain click, clear existing cell selection and select the clicked cell.
- if ShiftEmpty and MultiSelect and Assigned(HitInfo.HitNode) and (Column > NoColumn) then
+ // !!! MultiSelect <> LCellSelectionEnabled, not interchangeable !!!
+ if ShiftEmpty and LCellSelectionEnabled and Assigned(HitInfo.HitNode) and (Column > NoColumn) then
begin
InternalClearCellSelection;
ClickedCell.Node := HitInfo.HitNode;
@@ -15599,7 +15649,7 @@ procedure TBaseVirtualTree.AddToCellSelection(const Cell: TVTCell; ForceInsert:
InvalidateNode(Cell.Node)
else
InvalidateColumn(Cell.Column);
- DoChangeCell(FSelectedCells);
+ ChangeCell(FSelectedCells);
end;
end;
@@ -15614,7 +15664,7 @@ procedure TBaseVirtualTree.RemoveFromCellSelection(const Cell: TVTCell);
InvalidateNode(Cell.Node)
else
InvalidateColumn(Cell.Column);
- DoChangeCell(FSelectedCells);
+ ChangeCell(FSelectedCells);
end;
//----------------------------------------------------------------------------------------------------------------------
@@ -15631,12 +15681,22 @@ function TBaseVirtualTree.InternalIsCellSelected(Node: PVirtualNode; Column: TCo
//----------------------------------------------------------------------------------------------------------------------
+function TBaseVirtualTree.InternalIsCellSelected(const Cell: TVTCell): Boolean;
+begin
+ Result := InternalIsCellSelected(Cell.Node, Cell.Column);
+end;
+
+//----------------------------------------------------------------------------------------------------------------------
+
procedure TBaseVirtualTree.InternalSelectCells(StartCell, EndCell: TVTCell; AddOnly: Boolean);
+type
+ TNextColFunc = function (Column: TColumnIndex; ConsiderAllowFocus: Boolean = False): TColumnIndex of object;
var
NodeFrom, NodeTo, NodeIter: PVirtualNode;
ColFrom, ColTo, ColIter: TColumnIndex;
ColNext: TColumnIndex;
TempCell: TVTCell;
+ NextColFunc: TNextColFunc;
begin
// Normalize start cell
if StartCell.Node = nil then
@@ -15666,71 +15726,37 @@ procedure TBaseVirtualTree.InternalSelectCells(StartCell, EndCell: TVTCell; AddO
if not AddOnly then
InternalClearCellSelection;
+ if ColFrom <= ColTo then
+ NextColFunc := FHeader.Columns.GetNextVisibleColumn else
+ NextColFunc := FHeader.Columns.GetPreviousVisibleColumn;
+
NodeIter := NodeFrom;
while NodeIter <> NodeTo do
begin
// iterate columns between ColFrom and ColTo (inclusive)
- if ColFrom <= ColTo then
- begin
- ColIter := ColFrom;
- repeat
- begin
- TempCell.Node := NodeIter; TempCell.Column := ColIter;
- AddToCellSelection(TempCell, True);
- end;
- ColNext := FHeader.Columns.GetNextVisibleColumn(ColIter);
- if ColIter = ColTo then
- Break;
- ColIter := ColNext;
- until ColIter = InvalidColumn;
- end
- else
- begin
- ColIter := ColFrom;
- repeat
- begin
- TempCell.Node := NodeIter; TempCell.Column := ColIter;
- AddToCellSelection(TempCell, True);
- end;
- ColNext := FHeader.Columns.GetPreviousVisibleColumn(ColIter);
- if ColIter = ColTo then
- Break;
- ColIter := ColNext;
- until ColIter = InvalidColumn;
- end;
+ ColIter := ColFrom;
+ repeat
+ TempCell.Node := NodeIter; TempCell.Column := ColIter;
+ AddToCellSelection(TempCell, True);
+ ColNext := NextColFunc(ColIter);
+ if ColIter = ColTo then
+ Break;
+ ColIter := ColNext;
+ until ColIter = InvalidColumn;
NodeIter := GetNextVisible(NodeIter, True);
end;
// include last node
if Assigned(NodeTo) then
begin
- if ColFrom <= ColTo then
- begin
- ColIter := ColFrom;
- repeat
- begin
- TempCell.Node := NodeTo; TempCell.Column := ColIter;
- AddToCellSelection(TempCell, True);
- end;
- ColNext := FHeader.Columns.GetNextVisibleColumn(ColIter);
- if ColIter = ColTo then
- Break;
- ColIter := ColNext;
- until ColIter = InvalidColumn;
- end
- else
- begin
- ColIter := ColFrom;
- repeat
- begin
- TempCell.Node := NodeTo; TempCell.Column := ColIter;
- AddToCellSelection(TempCell, True);
- end;
- ColNext := FHeader.Columns.GetPreviousVisibleColumn(ColIter);
- if ColIter = ColTo then
- Break;
- ColIter := ColNext;
- until ColIter = InvalidColumn;
- end;
+ ColIter := ColFrom;
+ repeat
+ TempCell.Node := NodeTo; TempCell.Column := ColIter;
+ AddToCellSelection(TempCell, True);
+ ColNext := NextColFunc(ColIter);
+ if ColIter = ColTo then
+ Break;
+ ColIter := ColNext;
+ until ColIter = InvalidColumn;
end;
end;
diff --git a/Tests/Tests.dpr b/Tests/Tests.dpr
index 8c90faea..46c91cd0 100644
--- a/Tests/Tests.dpr
+++ b/Tests/Tests.dpr
@@ -18,7 +18,8 @@ uses
VTOnDrawTextTests in 'VTOnDrawTextTests.pas',
VTCellSelectionTests in 'VTCellSelectionTests.pas',
VirtualTrees.MouseUtils in 'VirtualTrees.MouseUtils.pas',
- VTCellSelectionTests.VisibilityForm in 'VTCellSelectionTests.VisibilityForm.pas' {VisibilityForm};
+ VTCellSelectionTests.VisibilityForm in 'VTCellSelectionTests.VisibilityForm.pas' {VisibilityForm},
+ VTCellSelectionTests.VTSelectionTestForm in 'VTCellSelectionTests.VTSelectionTestForm.pas' {SelectionTestForm};
var
runner : ITestRunner;
diff --git a/Tests/Tests.dproj b/Tests/Tests.dproj
index e2a3adbe..8d1ccaf8 100644
--- a/Tests/Tests.dproj
+++ b/Tests/Tests.dproj
@@ -111,6 +111,10 @@
dfm
+
+
+ dfm
+
Base
diff --git a/Tests/VTCellSelectionTests.VTSelectionTestForm.dfm b/Tests/VTCellSelectionTests.VTSelectionTestForm.dfm
new file mode 100644
index 00000000..64621d64
--- /dev/null
+++ b/Tests/VTCellSelectionTests.VTSelectionTestForm.dfm
@@ -0,0 +1,73 @@
+object SelectionTestForm: TSelectionTestForm
+ Left = 0
+ Top = 0
+ Caption = 'SelectionTestForm'
+ ClientHeight = 843
+ ClientWidth = 1424
+ Color = clBtnFace
+ Font.Charset = DEFAULT_CHARSET
+ Font.Color = clWindowText
+ Font.Height = -27
+ Font.Name = 'Segoe UI'
+ Font.Style = []
+ OnShow = FormShow
+ PixelsPerInch = 216
+ TextHeight = 37
+ object VSTA: TVirtualStringTree
+ Left = 0
+ Top = 0
+ Width = 1424
+ Height = 843
+ Margins.Left = 7
+ Margins.Top = 7
+ Margins.Right = 7
+ Margins.Bottom = 7
+ Align = alClient
+ ClipboardFormats.Strings = (
+ 'Plain text'
+ 'Virtual Tree Data')
+ DefaultNodeHeight = 46
+ Header.AutoSizeIndex = 0
+ Header.Height = 41
+ Header.MaxHeight = 22500
+ Header.MinHeight = 23
+ Header.Options = [hoColumnResize, hoDrag, hoShowSortGlyphs, hoVisible]
+ Indent = 41
+ Margin = 9
+ TabOrder = 0
+ TextMargin = 9
+ TreeOptions.SelectionOptions = [toMultiSelect, toSelectNextNodeOnRemoval]
+ OnChange = VSTAChange
+ OnClick = VSTAClick
+ OnDragAllowed = VSTADragAllowed
+ OnDragOver = VSTADragOver
+ OnDragDrop = VSTADragDrop
+ OnFreeNode = VSTAFreeNode
+ OnGetText = VSTAGetText
+ Touch.InteractiveGestures = [igPan, igPressAndTap]
+ Touch.InteractiveGestureOptions = [igoPanSingleFingerHorizontal, igoPanSingleFingerVertical, igoPanInertia, igoPanGutter, igoParentPassthrough]
+ Columns = <
+ item
+ MaxWidth = 11250
+ MinWidth = 72
+ Position = 0
+ Text = 'Name'
+ Width = 563
+ end
+ item
+ MaxWidth = 11250
+ MinWidth = 72
+ Position = 1
+ Text = 'Desp'
+ Width = 150
+ end
+ item
+ MaxWidth = 11250
+ MinWidth = 72
+ Position = 2
+ Text = 'Location'
+ Width = 135
+ end>
+ DefaultText = ''
+ end
+end
diff --git a/Tests/VTCellSelectionTests.VTSelectionTestForm.pas b/Tests/VTCellSelectionTests.VTSelectionTestForm.pas
new file mode 100644
index 00000000..8607e636
--- /dev/null
+++ b/Tests/VTCellSelectionTests.VTSelectionTestForm.pas
@@ -0,0 +1,181 @@
+unit VTCellSelectionTests.VTSelectionTestForm;
+
+interface
+
+uses
+ Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
+ Vcl.Controls, Vcl.Forms, Vcl.Dialogs, VirtualTrees.BaseAncestorVCL,
+ VirtualTrees.BaseTree, VirtualTrees.AncestorVCL, VirtualTrees,
+ VirtualTrees.Types, VirtualTrees.ClipBoard, ActiveX, Vcl.ExtCtrls;
+
+type
+
+ TDataRec = record
+ Name: String;
+ Desp: String;
+ Loc: String;
+ end;
+ PDataRec = ^TDataRec;
+
+ TSelectionTestForm = class(TForm)
+ VSTA: TVirtualStringTree;
+ procedure VSTAGetText(Sender: TBaseVirtualTree; Node: PVirtualNode;
+ Column: TColumnIndex; TextType: TVSTTextType; var CellText: string);
+ procedure VSTADragAllowed(Sender: TBaseVirtualTree; Node: PVirtualNode;
+ Column: TColumnIndex; var Allowed: Boolean);
+ procedure VSTADragDrop(Sender: TBaseVirtualTree; Source: TObject;
+ DataObject: IDataObject; Formats: TFormatArray; Shift: TShiftState;
+ Pt: TPoint; var Effect: Integer; Mode: TDropMode);
+ procedure VSTADragOver(Sender: TBaseVirtualTree; Source: TObject;
+ Shift: TShiftState; State: TDragState; Pt: TPoint; Mode: TDropMode;
+ var Effect: Integer; var Accept: Boolean);
+ procedure VSTAFreeNode(Sender: TBaseVirtualTree; Node: PVirtualNode);
+ procedure FormShow(Sender: TObject);
+ procedure VSTAChange(Sender: TBaseVirtualTree; Node: PVirtualNode);
+ procedure VSTAClick(Sender: TObject);
+ private
+ { Private declarations }
+ public
+ { Public declarations }
+ end;
+
+var
+ SelectionTestForm: TSelectionTestForm;
+
+implementation
+
+{$R *.dfm}
+
+procedure TSelectionTestForm.FormShow(Sender: TObject);
+var
+ Data: PDataRec;
+ PNode: PVirtualNode;
+begin
+ VSTA.BeginUpdate;
+ New(Data);
+ FillChar(Data^, SizeOf(TDataRec), 0);
+ Data.Name := 'Name-0';
+ Data.Desp := 'Desp-0';
+ Data.Loc := 'Loc-0';
+ PNode := VSTA.AddChild(nil, Data);
+
+ New(Data);
+ FillChar(Data^, SizeOf(TDataRec), 0);
+ Data.Name := 'Name-1';
+ Data.Desp := 'Desp-1';
+ Data.Loc := 'Loc-1';
+ VSTA.AddChild(PNode, Data);
+
+ New(Data);
+ FillChar(Data^, SizeOf(TDataRec), 0);
+ Data.Name := 'Name-2';
+ Data.Desp := 'Desp-2';
+ Data.Loc := 'Loc-2';
+ VSTA.AddChild(PNode, Data);
+ VSTA.Expanded[PNode] := True;
+
+ New(Data);
+ FillChar(Data^, SizeOf(TDataRec), 0);
+ Data.Name := 'Name-3';
+ Data.Desp := 'Desp-3';
+ Data.Loc := 'Loc-3';
+ VSTA.AddChild(nil, Data);
+ VSTA.EndUpdate;
+end;
+
+procedure TSelectionTestForm.VSTAChange(Sender: TBaseVirtualTree; Node: PVirtualNode);
+begin
+ Beep;
+end;
+
+procedure TSelectionTestForm.VSTAClick(Sender: TObject);
+begin
+// Beep;
+end;
+
+procedure TSelectionTestForm.VSTADragAllowed(Sender: TBaseVirtualTree;
+ Node: PVirtualNode; Column: TColumnIndex; var Allowed: Boolean);
+begin
+ Allowed := true;
+end;
+
+procedure TSelectionTestForm.VSTADragDrop(Sender: TBaseVirtualTree; Source: TObject;
+ DataObject: IDataObject; Formats: TFormatArray; Shift: TShiftState;
+ Pt: TPoint; var Effect: Integer; Mode: TDropMode);
+var
+ I: Integer;
+ AttachMode: TVTNodeAttachMode;
+
+begin
+ if Length(Formats) > 0 then
+ begin
+ // OLE drag'n drop
+ // If the native tree format is listed then use this and accept the drop, otherwise recject (ignore) it.
+ // It is recommend by Microsoft to order available clipboard formats in decreasing detail richness so
+ // the first best format which we can accept is usually the best format we can get at all.
+ for I := 0 to High(Formats) do
+ if Formats[I] = CF_VIRTUALTREE then
+ begin
+ case Mode of
+ dmAbove:
+ AttachMode := amInsertBefore;
+ dmOnNode:
+ AttachMode := amAddChildLast;
+ dmBelow:
+ AttachMode := amInsertAfter;
+ else
+ if Assigned(Source) and (Source is TBaseVirtualTree) and (Sender <> Source) then
+ AttachMode := amInsertBefore
+ else
+ AttachMode := amNowhere;
+ end;
+ // in the case the drop target does an optimized move Effect is set to DROPEFFECT_NONE
+ // to indicate this also to the drag source (so the source doesn't need to take any further action)
+ Sender.ProcessDrop(DataObject, Sender.DropTargetNode, Effect, AttachMode);
+ Sender.Expanded[Sender.DropTargetNode] := True;
+ Break;
+ end;
+ end
+ else
+ begin
+ // VCL drag'n drop, Effects contains by default both move and copy effect suggestion,
+ // as usual the application has to find out what operation is finally to do
+ Beep;
+ end;
+end;
+
+procedure TSelectionTestForm.VSTADragOver(Sender: TBaseVirtualTree; Source: TObject;
+ Shift: TShiftState; State: TDragState; Pt: TPoint; Mode: TDropMode;
+ var Effect: Integer; var Accept: Boolean);
+begin
+ Accept := true;
+// Accept := (Source = Sender);
+end;
+
+procedure TSelectionTestForm.VSTAFreeNode(Sender: TBaseVirtualTree; Node: PVirtualNode);
+var
+ Data: PDataRec;
+begin
+ Data := PPointer(Sender.GetNodeData(Node))^;
+ Dispose(Data);
+end;
+
+procedure TSelectionTestForm.VSTAGetText(Sender: TBaseVirtualTree; Node: PVirtualNode;
+ Column: TColumnIndex; TextType: TVSTTextType; var CellText: string);
+var
+ Data: PDataRec;
+begin
+ Data := PPointer(Sender.GetNodeData(Node))^;
+ if TextType = ttNormal then begin
+ case Column of
+ -1,
+ 0: CellText := Data.Name;
+ 1: CellText := Data.Desp;
+ 2: CellText := Data.Loc;
+ else
+ CellText := '';
+ end;
+ end;
+end;
+
+end.
diff --git a/Tests/VTCellSelectionTests.pas b/Tests/VTCellSelectionTests.pas
index fa62ae66..27ccaa13 100644
--- a/Tests/VTCellSelectionTests.pas
+++ b/Tests/VTCellSelectionTests.pas
@@ -7,7 +7,7 @@ interface
uses
DUnitX.TestFramework, Vcl.Forms, VirtualTrees, System.Types,
- Winapi.Messages, Winapi.Windows, Vcl.ComCtrls;
+ Winapi.Messages, Winapi.Windows, Vcl.ComCtrls, VirtualTrees.Types;
type
@@ -136,15 +136,16 @@ TCellSelectionTests = class(TObject)
///
[Test]
procedure TestRemovingSetsClearCellSelection;
+
end;
implementation
uses
- System.SysUtils, Vcl.Controls, VirtualTrees.Types,
+ System.SysUtils, Vcl.Controls,
Vcl.Clipbrd, VirtualTrees.ClipBoard,
System.Classes, Winapi.ActiveX, Vcl.ClipboardHelper, VirtualTrees.MouseUtils,
- VTCellSelectionTests.VisibilityForm;
+ VTCellSelectionTests.VisibilityForm, VTCellSelectionTests.VTSelectionTestForm;
type
TRowData = record
@@ -392,7 +393,7 @@ procedure TCellSelectionTests.TestChangeCellEvent;
LTree := FTree;
LTree.TreeOptions.SelectionOptions := LTree.TreeOptions.SelectionOptions +
- [toExtendedFocus, toMultiSelect];
+ [toExtendedFocus, toMultiSelect] - [toFullRowSelect];
LChangeCellFiredWhenAdding := False;
AssignChange(procedure (Sender: TBaseVirtualTree; const Cells: TVTCellArray)
@@ -1109,14 +1110,23 @@ procedure TCellSelectionTests.TestSelectSingleCell;
LNodes: TArray;
LNode: PVirtualNode;
LColumn: Integer;
+ LCellChangeFired: LongBool;
begin
LTree := FTree;
LTree.TreeOptions.SelectionOptions := LTree.TreeOptions.SelectionOptions +
[toExtendedFocus, toMultiSelect];
+ LCellChangeFired := False;
+ AssignChange(procedure(Sender: TBaseVirtualTree; const Cells: TVTCellArray)
+ begin
+ LCellChangeFired := True;
+ end);
n3 := FNode3;
+ Assert.IsFalse(LCellChangeFired, 'LCellChangedFired is True!');
LTree.SelectCells(n3, 1, n3, 1, False);
+ Assert.IsTrue(LCellChangeFired, 'LCellChangedFired is False!');
+
Assert.IsTrue(LTree.IsCellSelected(n3, 1), 'n3, col1 should be selected');
LSelectedCells := LTree.SelectedCells;
@@ -1166,19 +1176,20 @@ procedure TCellSelectionTests.TestShiftClickMultipleCells;
procedure TCellSelectionTests.TestLeftClickSelectsNode;
var
LTree: TVirtualStringTree;
- n3: PVirtualNode;
+ LNode: PVirtualNode;
LSelectedCells: TVTCellArray;
- n3Selected: LongBool;
+ LSelected: LongBool;
+ LForm: TSelectionTestForm;
begin
LTree := FTree;
- n3 := FNode3;
+ LNode := FNode3;
LTree.TreeOptions.SelectionOptions := LTree.TreeOptions.SelectionOptions +
[toExtendedFocus, toMultiSelect] - [toFullRowSelect];
LSelectedCells := LTree.SelectedCells;
Assert.IsTrue(Length(LSelectedCells) = 0, 'Length of selected cell is unexpected!');
- LTree.MouseClick(n3, 0);
+ LTree.MouseClick(LNode, 0);
LSelectedCells := LTree.SelectedCells;
Assert.IsTrue(Length(LSelectedCells) = 1, 'Length of selected cell is unexpected!');
@@ -1187,16 +1198,41 @@ procedure TCellSelectionTests.TestLeftClickSelectsNode;
LSelectedCells := LTree.SelectedCells;
Assert.IsTrue(Length(LSelectedCells) = 0, 'Length of selected cell is unexpected!');
- // Remove multiselect
+ // Remove multiselect, which is part of multicell select
LTree.TreeOptions.SelectionOptions := LTree.TreeOptions.SelectionOptions -
[toMultiSelect];
- LTree.MouseClick(n3);
+ // SelectionOptions should now be [toExtendedFocus,toSelectNextNodeOnRemoval]
+ LTree.MouseClick(LNode);
LSelectedCells := LTree.SelectedCells;
Assert.IsTrue(Length(LSelectedCells) = 0, 'Length of selected cell is unexpected!');
- n3Selected := LTree.Selected[n3];
- Assert.IsTrue(n3Selected, 'n3 is not selected!');
+ LSelected := LTree.Selected[LNode];
+ Assert.IsTrue(LSelected, 'Node is not selected!');
+
+ // This test is the same as the one below with TSelectionTestForm
+ LTree.TreeOptions.SelectionOptions := [toMultiSelect,toSelectNextNodeOnRemoval];
+ LSelected := LTree.Selected[LNode];
+ Assert.IsFalse(LSelected, 'Node should not be selected!');
+ LTree.MouseClick(LNode);
+ LSelected := LTree.Selected[LNode];
+ Assert.IsTrue(LSelected, 'Node should be selected!');
+
+ // This test ensures that left click is working correctly
+ LForm := TSelectionTestForm.Create(nil);
+ try
+ LForm.Show; // Needed to initialize VST
+ LTree := LForm.VSTA;
+ LNode := LTree.GetFirstVisible;
+ Assert.IsTrue(LNode <> nil, 'Node is nil!');
+ LSelected := LTree.Selected[LNode];
+ Assert.IsFalse(LSelected, 'Node is selected');
+ LTree.MouseClick(LNode);
+ LSelected := LTree.Selected[LNode];
+ Assert.IsTrue(LSelected, 'Node is selected');
+ finally
+ LForm.Free;
+ end;
end;
procedure TCellSelectionTests.TestLeftClickWithoutMultiSelectDoesNotSelectCell;
@@ -1225,12 +1261,42 @@ procedure TCellSelectionTests.TestRemovingSetsClearCellSelection;
LTree: TVirtualStringTree;
n3: PVirtualNode;
LSelectedCells: TVTCellArray;
+ LNodeSelected: LongBool;
+
+ procedure DisableMulticellSelection;
+ begin
+ LTree.TreeOptions.SelectionOptions := LTree.TreeOptions.SelectionOptions -
+ [toExtendedFocus, toMultiSelect];
+ end;
+
+ procedure EnableMulticellSelection;
+ begin
+ LTree.TreeOptions.SelectionOptions := LTree.TreeOptions.SelectionOptions +
+ [toExtendedFocus, toMultiSelect] - [toFullRowSelect];
+ end;
procedure SelectCell;
begin
LTree.MouseClick(n3, 0);
end;
+ procedure SelectNode;
+ begin
+ LTree.MouseClick(n3);
+ end;
+
+ procedure EnsureNodeSelected;
+ begin
+ LNodeSelected := LTree.Selected[n3];
+ Assert.IsTrue(LNodeSelected, 'Node is not selected!');
+ end;
+
+ procedure EnsureNodeNotSelected;
+ begin
+ LNodeSelected := LTree.Selected[n3];
+ Assert.IsFalse(LNodeSelected, 'Node is selected!');
+ end;
+
procedure EnsureCellNotSelected;
begin
LSelectedCells := LTree.SelectedCells;
@@ -1245,40 +1311,65 @@ procedure TCellSelectionTests.TestRemovingSetsClearCellSelection;
procedure EnsureSelectCell;
begin
- LTree.TreeOptions.SelectionOptions := LTree.TreeOptions.SelectionOptions +
- [toExtendedFocus, toMultiSelect] - [toFullRowSelect];
+ EnableMulticellSelection;
EnsureCellNotSelected;
SelectCell;
EnsureCellSelected;
end;
-begin
- LTree := FTree;
- n3 := FNode3;
+ procedure CheckTree;
+ begin
+ EnsureSelectCell;
+ DisableMulticellSelection;
+ EnsureCellNotSelected;
- EnsureSelectCell;
- LTree.TreeOptions.SelectionOptions := LTree.TreeOptions.SelectionOptions + [toFullRowSelect];
- EnsureCellNotSelected;
+ EnableMulticellSelection;
+ SelectCell;
+ EnsureCellSelected;
- LTree.TreeOptions.SelectionOptions := LTree.TreeOptions.SelectionOptions - [toFullRowSelect];
- SelectCell;
- EnsureCellSelected;
+ LTree.ClearCellSelection;
+ EnsureCellNotSelected;
- LTree.ClearCellSelection;
- EnsureCellNotSelected;
+ DisableMulticellSelection;
+ LTree.ClearSelection;
+ EnsureNodeNotSelected;
+ SelectNode;
+ EnsureNodeSelected;
- EnsureSelectCell;
- LTree.TreeOptions.SelectionOptions := LTree.TreeOptions.SelectionOptions - [toExtendedFocus];
- EnsureCellNotSelected;
+ EnsureSelectCell;
+ LTree.TreeOptions.SelectionOptions := LTree.TreeOptions.SelectionOptions - [toExtendedFocus];
+ EnsureCellNotSelected;
- EnsureSelectCell;
- LTree.TreeOptions.SelectionOptions := LTree.TreeOptions.SelectionOptions - [toMultiSelect];
- EnsureCellNotSelected;
+ EnsureSelectCell;
+ LTree.TreeOptions.SelectionOptions := LTree.TreeOptions.SelectionOptions - [toMultiSelect];
+ EnsureCellNotSelected;
+
+ EnsureSelectCell;
+ LTree.TreeOptions.SelectionOptions := LTree.TreeOptions.SelectionOptions - [toExtendedFocus, toMultiSelect];
+ EnsureCellNotSelected;
+ end;
+
+var
+ LForm: TSelectionTestForm;
+begin
+ LTree := FTree;
+ n3 := FNode3;
- EnsureSelectCell;
- LTree.TreeOptions.SelectionOptions := LTree.TreeOptions.SelectionOptions - [toExtendedFocus, toMultiSelect];
- EnsureCellNotSelected;
+ // Run against the default tree
+ CheckTree;
+
+ LForm := TSelectionTestForm.Create(nil);
+ try
+ LForm.Show;
+ LTree := LForm.VSTA;
+ n3 := LTree.GetFirstVisibleChild(LTree.RootNode);
+
+ // Run against the form's tree
+ CheckTree;
+ finally
+ LForm.Free;
+ end;
end;
initialization
diff --git a/Tests/VirtualTrees.MouseUtils.pas b/Tests/VirtualTrees.MouseUtils.pas
index a610af16..09d9882f 100644
--- a/Tests/VirtualTrees.MouseUtils.pas
+++ b/Tests/VirtualTrees.MouseUtils.pas
@@ -16,12 +16,16 @@ TCustomVirtualStringTreeMouseHelper = class helper for TCustomVirtualStringTre
KEYDOWN = Byte(1 shl 7);
public
function GetDisplayRectEx(ANode: PVirtualNode; AColumn: TColumnIndex): TPoint;
+
procedure KeyedMouseClick(Key: Byte; ACursorPos: TPoint); overload;
procedure KeyedMouseClick(Key: Byte; ANode: PVirtualNode; AColumn: TColumnIndex = 0); overload;
+
procedure MouseClick(ACursorPos: TPoint); overload;
procedure MouseClick(ANode: PVirtualNode; AColumn: TColumnIndex = 0); overload;
+
procedure CtrlMouseClick(ACursorPos: TPoint); overload;
procedure CtrlMouseClick(ANode: PVirtualNode; AColumn: TColumnIndex = 0); overload;
+
procedure ShiftMouseClick(ANode: PVirtualNode; AColumn: TColumnIndex = 0); overload;
end;
@@ -33,7 +37,8 @@ implementation
{ TCustomVirtualStringTreeMouseHelper }
-function TCustomVirtualStringTreeMouseHelper.GetDisplayRectEx(ANode: PVirtualNode; AColumn: TColumnIndex): TPoint;
+function TCustomVirtualStringTreeMouseHelper.GetDisplayRectEx(
+ ANode: PVirtualNode; AColumn: TColumnIndex): TPoint;
var
R: TRect;
LRight: TDimension;
diff --git a/Tests/VisibilityTest.dpr b/Tests/VisibilityTest.dpr
index 677c703c..2a5abd4a 100644
--- a/Tests/VisibilityTest.dpr
+++ b/Tests/VisibilityTest.dpr
@@ -2,13 +2,16 @@
uses
Vcl.Forms,
- VTCellSelectionTests.VisibilityForm in 'VTCellSelectionTests.VisibilityForm.pas' {VisibilityForm};
+ VTCellSelectionTests.VisibilityForm in 'VTCellSelectionTests.VisibilityForm.pas' {VisibilityForm},
+ VirtualTrees.MouseUtils in 'VirtualTrees.MouseUtils.pas',
+ VTCellSelectionTests.VTSelectionTestForm in 'VTCellSelectionTests.VTSelectionTestForm.pas' {SelectionTestForm};
{$R *.res}
begin
Application.Initialize;
Application.MainFormOnTaskbar := True;
+ Application.CreateForm(TSelectionTestForm, SelectionTestForm);
Application.CreateForm(TVisibilityForm, VisibilityForm);
Application.Run;
end.
diff --git a/Tests/VisibilityTest.dproj b/Tests/VisibilityTest.dproj
index ba232184..775b2e38 100644
--- a/Tests/VisibilityTest.dproj
+++ b/Tests/VisibilityTest.dproj
@@ -125,6 +125,11 @@
dfm
+
+
+
+ dfm
+
Base