diff --git a/.gitignore b/.gitignore index b38a0e1d6..b1ef1e6cc 100644 --- a/.gitignore +++ b/.gitignore @@ -53,4 +53,6 @@ Packages/RAD Studio XE3/VirtualTreesR.lib # Folder with repro projects # ############################## -/#* \ No newline at end of file +/#* +Tests/dunitx-results.xml +Tests/TestInsightSettings.ini diff --git a/Demos/Advanced/Advanced.dproj b/Demos/Advanced/Advanced.dproj index aafc38101..2f5fc9969 100644 --- a/Demos/Advanced/Advanced.dproj +++ b/Demos/Advanced/Advanced.dproj @@ -7,7 +7,7 @@ Advanced.dpr Win32 {E5FD8257-AE07-4A8D-AB79-44170493F9A2} - 20.2 + 20.3 3 Advanced @@ -155,7 +155,6 @@
StateForm
 - Base diff --git a/Demos/Advanced/AlignDemo.pas b/Demos/Advanced/AlignDemo.pas index 0db29619c..d5bd0c6d4 100644 --- a/Demos/Advanced/AlignDemo.pas +++ b/Demos/Advanced/AlignDemo.pas @@ -15,8 +15,11 @@ interface {$warn UNSAFE_CODE off} uses - Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, - StdCtrls, Buttons, VirtualTrees, ComCtrls, ExtCtrls, ImgList, Menus, UITypes, VirtualTrees.Types, System.ImageList; + Winapi.Windows, Winapi.Messages, System.SysUtils, System.Classes, Vcl.Graphics, + Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, Vcl.Buttons, + VirtualTrees, Vcl.ComCtrls, Vcl.ExtCtrls, Vcl.ImgList, Vcl.Menus, System.UITypes, + VirtualTrees.Types, System.ImageList, VirtualTrees.BaseAncestorVCL, + VirtualTrees.BaseTree, VirtualTrees.AncestorVCL; type TAlignForm = class(TForm) diff --git a/Demos/Advanced/DrawTreeDemo.pas b/Demos/Advanced/DrawTreeDemo.pas index 87fd86139..dd1ad9643 100644 --- a/Demos/Advanced/DrawTreeDemo.pas +++ b/Demos/Advanced/DrawTreeDemo.pas @@ -24,9 +24,13 @@ interface uses - Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, - VirtualTrees, StdCtrls, {$ifdef GraphicEx} GraphicEx, {$else} JPEG, {$endif} - ImgList, ComCtrls, UITypes, VirtualTrees.DrawTree, System.ImageList, VirtualTrees.Types; + Winapi.Windows, Winapi.Messages, System.SysUtils, System.Classes, + Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs, + VirtualTrees, Vcl.StdCtrls, + {$ifdef GraphicEx} GraphicEx, {$else} Vcl.Imaging.JPEG, {$endif} + Vcl.ImgList, Vcl.ComCtrls, System.UITypes, VirtualTrees.DrawTree, + System.ImageList, VirtualTrees.Types, VirtualTrees.BaseAncestorVCL, + VirtualTrees.BaseTree, VirtualTrees.AncestorVCL; type TDrawTreeForm = class(TForm) @@ -46,7 +50,7 @@ TDrawTreeForm = class(TForm) procedure VDT1GetImageIndex(Sender: TBaseVirtualTree; Node: PVirtualNode; Kind: TVTImageKind; Column: TColumnIndex; var Ghosted: Boolean; var Index: TImageIndex); procedure VDT1GetNodeWidth(Sender: TBaseVirtualTree; Canvas: TCanvas; Node: PVirtualNode; Column: TColumnIndex; - var NodeWidth: Integer); + var NodeWidth: TDimension); procedure VDT1HeaderClick(Sender: TVTHeader; HitInfo: TVTHeaderHitInfo); procedure VDT1InitChildren(Sender: TBaseVirtualTree; Node: PVirtualNode; var ChildCount: Cardinal); procedure VDT1InitNode(Sender: TBaseVirtualTree; ParentNode, Node: PVirtualNode; @@ -484,7 +488,7 @@ procedure TDrawTreeForm.VDT1DrawNode(Sender: TBaseVirtualTree; const PaintInfo: //---------------------------------------------------------------------------------------------------------------------- procedure TDrawTreeForm.VDT1GetNodeWidth(Sender: TBaseVirtualTree; Canvas: TCanvas; Node: PVirtualNode; Column: TColumnIndex; - var NodeWidth: Integer); + var NodeWidth: TDimension); // Since the draw tree does not know what is in a cell, we have to return the width of the content (not the entire // cell width, this could be determined by the column width). diff --git a/Demos/Advanced/Editors.pas b/Demos/Advanced/Editors.pas index 72014c127..1b06f2c8b 100644 --- a/Demos/Advanced/Editors.pas +++ b/Demos/Advanced/Editors.pas @@ -6,9 +6,10 @@ interface uses - Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, - StdCtrls, ExtDlgs, ImgList, Buttons, ExtCtrls, ComCtrls, Mask, - VirtualTrees, VirtualTrees.EditLink, VirtualTrees.Types; + Winapi.Windows, Winapi.Messages, System.SysUtils, System.Classes, Vcl.Graphics, + Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, Vcl.ExtDlgs, Vcl.ImgList, + Vcl.Buttons, Vcl.ExtCtrls, Vcl.ComCtrls, Vcl.Mask, VirtualTrees, + VirtualTrees.EditLink, VirtualTrees.Types; type // Describes the type of value a property tree node stores in its data property. diff --git a/Demos/Advanced/GeneralAbilitiesDemo.pas b/Demos/Advanced/GeneralAbilitiesDemo.pas index 83da0778f..a3e7ef0f8 100644 --- a/Demos/Advanced/GeneralAbilitiesDemo.pas +++ b/Demos/Advanced/GeneralAbilitiesDemo.pas @@ -1,4 +1,4 @@ -unit GeneralAbilitiesDemo; +unit GeneralAbilitiesDemo; // Virtual Treeview sample form demonstrating following features: // - General use and feel of TVirtualStringTree. @@ -25,10 +25,12 @@ interface {$ifend} uses - Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, - StdCtrls, Buttons, VirtualTrees, ComCtrls, ExtCtrls, ImgList, Menus, - StdActns, ActnList, VirtualTrees.HeaderPopup, UITypes, System.ImageList, VirtualTrees.BaseTree, - VirtualTrees.Types; + Winapi.Windows, Winapi.Messages, System.SysUtils, System.Classes, Vcl.Graphics, + Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, Vcl.Buttons, VirtualTrees, + Vcl.ComCtrls, Vcl.ExtCtrls, Vcl.ImgList, Vcl.Menus, Vcl.StdActns, Vcl.ActnList, + VirtualTrees.HeaderPopup, System.UITypes, System.ImageList, + VirtualTrees.BaseTree, VirtualTrees.Types, VirtualTrees.BaseAncestorVCL, + VirtualTrees.AncestorVCL; type TGeneralForm = class(TForm) @@ -259,7 +261,7 @@ procedure TGeneralForm.VST2InitNode(Sender: TBaseVirtualTree; ParentNode, Node: 4: begin ForeignText := WideChar($20AC); - ForeignText := 'nichts ist unmöglich ' + ForeignText; + ForeignText := 'nichts ist unmöglich ' + ForeignText; end; 5: begin @@ -368,15 +370,11 @@ procedure TGeneralForm.VST2GetPopupMenu(Sender: TBaseVirtualTree; Node: PVirtual const P: TPoint; var AskParent: Boolean; var PopupMenu: TPopupMenu); begin - case Column of - 0: - PopupMenu := PopupMenu1 - else - PopupMenu := nil; - end; + if Column <= 0 then + PopupMenu := PopupMenu1; end; -//---------------------------------------------------------------------------------------------------------------------- +//----------------------------------------------------------------------------------------------------------------------; procedure TGeneralForm.VST2KeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); diff --git a/Demos/Advanced/GridDemo.pas b/Demos/Advanced/GridDemo.pas index 30c81556b..2768d744f 100644 --- a/Demos/Advanced/GridDemo.pas +++ b/Demos/Advanced/GridDemo.pas @@ -10,8 +10,9 @@ interface uses - Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, - StdCtrls, VirtualTrees, ImgList, Menus, System.ImageList, VirtualTrees.BaseTree, VirtualTrees.Types, + Winapi.Windows, Winapi.Messages, System.SysUtils, System.Classes, Vcl.Graphics, + Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, VirtualTrees, + Vcl.ImgList, Vcl.Menus, System.ImageList, VirtualTrees.BaseTree, VirtualTrees.Types, VirtualTrees.BaseAncestorVCL, VirtualTrees.AncestorVCL; type @@ -48,7 +49,7 @@ TGridForm = class(TForm) procedure AutoSpanCheckBoxClick(Sender: TObject); procedure DisplayFullNameCheckBoxClick(Sender: TObject); procedure VST5ColumnHeaderSpanning(Sender: TVTHeader; Column: TColumnIndex; - var Count: Cardinal); + var Count: Integer); end; var @@ -190,7 +191,7 @@ procedure TGridForm.VST5BeforeCellPaint(Sender: TBaseVirtualTree; TargetCanvas: //---------------------------------------------------------------------------------------------------------------------- -procedure TGridForm.VST5ColumnHeaderSpanning(Sender: TVTHeader; Column: TColumnIndex; var Count: Cardinal); +procedure TGridForm.VST5ColumnHeaderSpanning(Sender: TVTHeader; Column: TColumnIndex; var Count: Integer); begin case Column of 2: diff --git a/Demos/Advanced/HeaderCustomDrawDemo.pas b/Demos/Advanced/HeaderCustomDrawDemo.pas index c3072b355..9bb283f9d 100644 --- a/Demos/Advanced/HeaderCustomDrawDemo.pas +++ b/Demos/Advanced/HeaderCustomDrawDemo.pas @@ -1,317 +1,319 @@ -unit HeaderCustomDrawDemo; - -// Virtual Treeview sample form demonstrating following features: -// - Advanced header custom draw. -// Written by Mike Lischke. - -interface - -uses - Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, - Dialogs, ImgList, VirtualTrees, StdCtrls, ExtCtrls, VirtualTrees.BaseTree, System.ImageList, - VirtualTrees.Types, VirtualTrees.BaseAncestorVCL, VirtualTrees.AncestorVCL; - -type - THeaderOwnerDrawForm = class(TForm) - Label8: TLabel; - HeaderCustomDrawTree: TVirtualStringTree; - HeaderImages: TImageList; - AnimationTimer: TTimer; - procedure HeaderCustomDrawTreeHeaderDrawQueryElements(Sender: TVTHeader; var PaintInfo: THeaderPaintInfo; - var Elements: THeaderPaintElements); - procedure HeaderCustomDrawTreeAdvancedHeaderDraw(Sender: TVTHeader; var PaintInfo: THeaderPaintInfo; - const Elements: THeaderPaintElements); - procedure FormCreate(Sender: TObject); - procedure FormDestroy(Sender: TObject); - procedure AnimationTimerTimer(Sender: TObject); - procedure HeaderCustomDrawTreeHeaderMouseUp(Sender: TVTHeader; Button: TMouseButton; Shift: TShiftState; X, - Y: Integer); - procedure HeaderCustomDrawTreeHeaderMouseDown(Sender: TVTHeader; Button: TMouseButton; Shift: TShiftState; X, - Y: Integer); - procedure HeaderCustomDrawTreeStateChange(Sender: TBaseVirtualTree; Enter, Leave: TVirtualTreeStates); - procedure HeaderCustomDrawTreeGetText(Sender: TBaseVirtualTree; - Node: PVirtualNode; Column: TColumnIndex; TextType: TVSTTextType; - var CellText: string); - private - FBackBitmap1, - FBackBitmap2, - FCheckerBackground: TBitmap; - FHeaderBitmap: TBitmap; - FLeftPos: Integer; - procedure CreateCheckerBackground; - procedure PaintSelection(Bitmap: TBitmap); - procedure FillBackground(R: TRect; Target: TCanvas); - end; - -var - HeaderOwnerDrawForm: THeaderOwnerDrawForm; - -//---------------------------------------------------------------------------------------------------------------------- - -implementation - -uses - States, Types,VirtualTrees.Utils; - -{$R *.dfm} - -//---------------------------------------------------------------------------------------------------------------------- - -procedure THeaderOwnerDrawForm.HeaderCustomDrawTreeHeaderDrawQueryElements(Sender: TVTHeader; - var PaintInfo: THeaderPaintInfo; var Elements: THeaderPaintElements); - -// This event tells the tree which part we want to draw ourselves. Don't forget to enable custom drawing in the header -// options and switch the Style property of every column, which we handle here to vsOwnerDraw. - -begin - with PaintInfo do - begin - // First check the column member. If it is NoColumn then it's about the header background. - if Column = nil then - Elements := [hpeBackground] // No other flag is recognized for the header background. - else - begin - // Using the index here ensures a column, regardless of its position, always has the same draw style. - // By using the Position member, we could make a certain column place stand out, regardless of the column order. - // Don't forget to change the AdvancedHeaderDraw event body accordingly after you changed the indicator here. - case Column.Index of - 0: // Default drawing. - ; - 1: // Background only customization. - Include(Elements, hpeBackground); - 2: // Full customization (well, quite). - Elements := [hpeBackground, hpeText{, hpeDropMark, hpeHeaderGlyph, hpeSortGlyph}]; - end; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure THeaderOwnerDrawForm.HeaderCustomDrawTreeAdvancedHeaderDraw(Sender: TVTHeader; var PaintInfo: THeaderPaintInfo; - const Elements: THeaderPaintElements); - -var - S: string; - Size: TSize; - SourceRect, - TargetRect: TRect; - OldFont: TFont; -begin - with PaintInfo do - begin - // First check the column member. If it is NoColumn then it's about the header background. - if Column = nil then - begin - if hpeBackground in Elements then - begin - TargetCanvas.Brush.Color := clBackground; - TargetCanvas.FillRect(PaintRectangle); - end; - end - else - begin - case Column.Index of - 0: // Will never come here. - ; - 1: // Background only customization. - begin - FBackBitmap1.Width := PaintRectangle.Right - PaintRectangle.Left; - FBackBitmap1.Height := PaintRectangle.Bottom - PaintRectangle.Top; - FillBackground(PaintRectangle, FBackbitmap1.Canvas); - if IsHoverIndex then - PaintSelection(FBackBitmap1); - TargetCanvas.Draw(PaintRectangle.Left, Paintrectangle.Top, FBackbitmap1); - end; - 2: // Full customization. Check elements to learn what must be drawn in the various stages. - begin - if hpeBackground in Elements then - with FBackBitmap2 do - begin - Width := PaintRectangle.Right - PaintRectangle.Left; - Height := PaintRectangle.Bottom - PaintRectangle.Top; - TargetRect := Rect(0, 0, Width, Height); - Canvas.Brush.Color := clInfoBk; - Canvas.FillRect(TargetRect); - InflateRect(TargetRect, - 10, -10); - SourceRect := TargetRect; - OffsetRect(SourceRect, -SourceRect.Left + FLeftPos, -SourceRect.Top); - Canvas.CopyRect(TargetRect, FHeaderBitmap.Canvas, SourceRect); - - TargetCanvas.Draw(PaintRectangle.Left, Paintrectangle.Top, FBackbitmap2); - end; - if hpeText in Elements then - begin - // store current font - OldFont := TFont.Create(); - try - OldFont.Assign(TargetCanvas.Font); - // draw world map - TargetCanvas.Font.Name := 'Webdings'; - TargetCanvas.Font.Charset := SYMBOL_CHARSET; - TargetCanvas.Font.Size := 60; - if IsHoverIndex then - TargetCanvas.Font.Color := $80FF; - S := 'û'; - Size := TargetCanvas.TextExtent(S); - SetBkMode(TargetCanvas.Handle, TRANSPARENT); - TargetCanvas.TextOut(PaintRectangle.Left + 10, Paintrectangle.Bottom - Size.cy, S); - // restore previous font - TargetCanvas.Font.Assign(OldFont); +unit HeaderCustomDrawDemo; + +// Virtual Treeview sample form demonstrating following features: +// - Advanced header custom draw. +// Written by Mike Lischke. + +interface + +uses + Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, + System.Classes, Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs, + Vcl.ImgList, VirtualTrees, Vcl.StdCtrls, Vcl.ExtCtrls, VirtualTrees.BaseTree, + System.ImageList, VirtualTrees.Types, VirtualTrees.BaseAncestorVCL, + VirtualTrees.AncestorVCL; + +type + THeaderOwnerDrawForm = class(TForm) + Label8: TLabel; + HeaderCustomDrawTree: TVirtualStringTree; + HeaderImages: TImageList; + AnimationTimer: TTimer; + procedure HeaderCustomDrawTreeHeaderDrawQueryElements(Sender: TVTHeader; var PaintInfo: THeaderPaintInfo; + var Elements: THeaderPaintElements); + procedure HeaderCustomDrawTreeAdvancedHeaderDraw(Sender: TVTHeader; var PaintInfo: THeaderPaintInfo; + const Elements: THeaderPaintElements); + procedure FormCreate(Sender: TObject); + procedure FormDestroy(Sender: TObject); + procedure AnimationTimerTimer(Sender: TObject); + procedure HeaderCustomDrawTreeHeaderMouseUp(Sender: TVTHeader; Button: TMouseButton; Shift: TShiftState; X, + Y: TDimension); + procedure HeaderCustomDrawTreeHeaderMouseDown(Sender: TVTHeader; Button: TMouseButton; Shift: TShiftState; X, + Y: TDimension); + procedure HeaderCustomDrawTreeStateChange(Sender: TBaseVirtualTree; Enter, Leave: TVirtualTreeStates); + procedure HeaderCustomDrawTreeGetText(Sender: TBaseVirtualTree; + Node: PVirtualNode; Column: TColumnIndex; TextType: TVSTTextType; + var CellText: string); + private + FBackBitmap1, + FBackBitmap2, + FCheckerBackground: TBitmap; + FHeaderBitmap: TBitmap; + FLeftPos: Integer; + procedure CreateCheckerBackground; + procedure PaintSelection(Bitmap: TBitmap); + procedure FillBackground(R: TRect; Target: TCanvas); + end; + +var + HeaderOwnerDrawForm: THeaderOwnerDrawForm; + +//---------------------------------------------------------------------------------------------------------------------- + +implementation + +uses + States, Types,VirtualTrees.Utils; + +{$R *.dfm} + +//---------------------------------------------------------------------------------------------------------------------- + +procedure THeaderOwnerDrawForm.HeaderCustomDrawTreeHeaderDrawQueryElements(Sender: TVTHeader; + var PaintInfo: THeaderPaintInfo; var Elements: THeaderPaintElements); + +// This event tells the tree which part we want to draw ourselves. Don't forget to enable custom drawing in the header +// options and switch the Style property of every column, which we handle here to vsOwnerDraw. + +begin + with PaintInfo do + begin + // First check the column member. If it is NoColumn then it's about the header background. + if Column = nil then + Elements := [hpeBackground] // No other flag is recognized for the header background. + else + begin + // Using the index here ensures a column, regardless of its position, always has the same draw style. + // By using the Position member, we could make a certain column place stand out, regardless of the column order. + // Don't forget to change the AdvancedHeaderDraw event body accordingly after you changed the indicator here. + case Column.Index of + 0: // Default drawing. + ; + 1: // Background only customization. + Include(Elements, hpeBackground); + 2: // Full customization (well, quite). + Elements := [hpeBackground, hpeText{, hpeDropMark, hpeHeaderGlyph, hpeSortGlyph}]; + end; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure THeaderOwnerDrawForm.HeaderCustomDrawTreeAdvancedHeaderDraw(Sender: TVTHeader; var PaintInfo: THeaderPaintInfo; + const Elements: THeaderPaintElements); + +var + S: string; + Size: TSize; + SourceRect, + TargetRect: TRect; + OldFont: TFont; +begin + with PaintInfo do + begin + // First check the column member. If it is NoColumn then it's about the header background. + if Column = nil then + begin + if hpeBackground in Elements then + begin + TargetCanvas.Brush.Color := clBackground; + TargetCanvas.FillRect(PaintRectangle); + end; + end + else + begin + case Column.Index of + 0: // Will never come here. + ; + 1: // Background only customization. + begin + FBackBitmap1.Width := PaintRectangle.Right - PaintRectangle.Left; + FBackBitmap1.Height := PaintRectangle.Bottom - PaintRectangle.Top; + FillBackground(PaintRectangle, FBackbitmap1.Canvas); + if IsHoverIndex then + PaintSelection(FBackBitmap1); + TargetCanvas.Draw(PaintRectangle.Left, Paintrectangle.Top, FBackbitmap1); + end; + 2: // Full customization. Check elements to learn what must be drawn in the various stages. + begin + if hpeBackground in Elements then + with FBackBitmap2 do + begin + Width := PaintRectangle.Right - PaintRectangle.Left; + Height := PaintRectangle.Bottom - PaintRectangle.Top; + TargetRect := Rect(0, 0, Width, Height); + Canvas.Brush.Color := clInfoBk; + Canvas.FillRect(TargetRect); + InflateRect(TargetRect, - 10, -10); + SourceRect := TargetRect; + OffsetRect(SourceRect, -SourceRect.Left + FLeftPos, -SourceRect.Top); + Canvas.CopyRect(TargetRect, FHeaderBitmap.Canvas, SourceRect); + + TargetCanvas.Draw(PaintRectangle.Left, Paintrectangle.Top, FBackbitmap2); + end; + if hpeText in Elements then + begin + // store current font + OldFont := TFont.Create(); + try + OldFont.Assign(TargetCanvas.Font); + // draw world map + TargetCanvas.Font.Name := 'Webdings'; + TargetCanvas.Font.Charset := SYMBOL_CHARSET; + TargetCanvas.Font.Size := 60; + if IsHoverIndex then + TargetCanvas.Font.Color := $80FF; + S := 'û'; + Size := TargetCanvas.TextExtent(S); + SetBkMode(TargetCanvas.Handle, TRANSPARENT); + TargetCanvas.TextOut(PaintRectangle.Left + 10, Paintrectangle.Bottom - Size.cy, S); + // restore previous font + TargetCanvas.Font.Assign(OldFont); finally OldFont.Free(); - end; - end; - // Other elements go here. - end; - end; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure THeaderOwnerDrawForm.CreateCheckerBackground; - -begin - FCheckerBackground := TBitmap.Create; - with FCheckerBackground do - begin - Width := 16; - Height := 16; - Canvas.Brush.Color := clBtnShadow; - Canvas.FillRect(Rect(0, 0, Width, Height)); - Canvas.Brush.Color := clBtnHighlight; - Canvas.FillRect(Rect(0, 0, 8, 8)); - Canvas.FillRect(Rect(8, 8, 16, 16)); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure THeaderOwnerDrawForm.PaintSelection(Bitmap: TBitmap); - -const - Alpha = 75; - -var - R: TRect; - -begin - R := Rect(0, 0, Bitmap.Width, Bitmap.Height); - VirtualTrees.Utils.AlphaBlend(0, Bitmap.Canvas.Handle, R, Point(0, 0), bmConstantAlphaAndColor, Alpha, - ColorToRGB(clHighlight)); - with Bitmap do - begin - Canvas.Pen.Color := clHighlight; - Canvas.Brush.Style := bsClear; - Canvas.Rectangle(0, 0, Width, Height); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure THeaderOwnerDrawForm.FillBackground(R: TRect; Target: TCanvas); - -// Tiles the background image over the given target bitmap. - -var - X, Y: Integer; - dX, dY: Integer; - -begin - with Target do - begin - dX := FCheckerBackground.Width; - dY := FCheckerBackground.Height; - - Y := 0; - while Y < R.Bottom - R.Top do - begin - X := 0; - while X < R.Right - R.Left do - begin - Draw(X, Y, FCheckerBackground); - Inc(X, dX); - end; - Inc(Y, dY); - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure THeaderOwnerDrawForm.FormCreate(Sender: TObject); - -begin - FBackBitmap1 := TBitmap.Create; - FBackBitmap1.PixelFormat := pf32Bit; - FBackBitmap2 := TBitmap.Create; - FBackBitmap2.PixelFormat := pf32Bit; - CreateCheckerBackground; - FHeaderBitmap := TBitmap.Create; - FHeaderBitmap.Handle := LoadImage(HInstance, 'Transcriptions', IMAGE_BITMAP, 0, 0, LR_DEFAULTCOLOR); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure THeaderOwnerDrawForm.FormDestroy(Sender: TObject); - -begin - FCheckerBackground.Free; - FBackBitmap1.Free; - FBackBitmap2.Free; - FHeaderBitmap.Free; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure THeaderOwnerDrawForm.AnimationTimerTimer(Sender: TObject); - -begin - FLeftPos := (FLeftPos + FHeaderBitmap.Width div 2000) mod FHeaderBitmap.Width; - with HeaderCustomDrawTree.Header do - Invalidate(Columns[2]); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure THeaderOwnerDrawForm.HeaderCustomDrawTreeHeaderMouseUp(Sender: TVTHeader; Button: TMouseButton; - Shift: TShiftState; X, Y: Integer); - -begin - // Reenable animation after a drag operation. - AnimationTimer.Enabled := True; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure THeaderOwnerDrawForm.HeaderCustomDrawTreeHeaderMouseDown(Sender: TVTHeader; Button: TMouseButton; - Shift: TShiftState; X, Y: Integer); - -begin - // Stop animation when mouse button is down. - AnimationTimer.Enabled := False; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure THeaderOwnerDrawForm.HeaderCustomDrawTreeStateChange(Sender: TBaseVirtualTree; Enter, Leave: TVirtualTreeStates); - -begin - if not (csDestroying in ComponentState) then - UpdateStateDisplay(Sender.TreeStates, Enter, Leave); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure THeaderOwnerDrawForm.HeaderCustomDrawTreeGetText(Sender: TBaseVirtualTree; Node: PVirtualNode; - Column: TColumnIndex; TextType: TVSTTextType; var CellText: string); - -begin - CellText := 'Some simple text.'; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -end. + end; + end; + // Other elements go here. + end; + end; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure THeaderOwnerDrawForm.CreateCheckerBackground; + +begin + FCheckerBackground := TBitmap.Create; + with FCheckerBackground do + begin + Width := 16; + Height := 16; + Canvas.Brush.Color := clBtnShadow; + Canvas.FillRect(Rect(0, 0, Width, Height)); + Canvas.Brush.Color := clBtnHighlight; + Canvas.FillRect(Rect(0, 0, 8, 8)); + Canvas.FillRect(Rect(8, 8, 16, 16)); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure THeaderOwnerDrawForm.PaintSelection(Bitmap: TBitmap); + +const + Alpha = 75; + +var + R: TRect; + +begin + R := Rect(0, 0, Bitmap.Width, Bitmap.Height); + VirtualTrees.Utils.AlphaBlend(0, Bitmap.Canvas.Handle, R, Point(0, 0), bmConstantAlphaAndColor, Alpha, + ColorToRGB(clHighlight)); + with Bitmap do + begin + Canvas.Pen.Color := clHighlight; + Canvas.Brush.Style := bsClear; + Canvas.Rectangle(0, 0, Width, Height); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure THeaderOwnerDrawForm.FillBackground(R: TRect; Target: TCanvas); + +// Tiles the background image over the given target bitmap. + +var + X, Y: Integer; + dX, dY: Integer; + +begin + with Target do + begin + dX := FCheckerBackground.Width; + dY := FCheckerBackground.Height; + + Y := 0; + while Y < R.Bottom - R.Top do + begin + X := 0; + while X < R.Right - R.Left do + begin + Draw(X, Y, FCheckerBackground); + Inc(X, dX); + end; + Inc(Y, dY); + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure THeaderOwnerDrawForm.FormCreate(Sender: TObject); + +begin + FBackBitmap1 := TBitmap.Create; + FBackBitmap1.PixelFormat := pf32Bit; + FBackBitmap2 := TBitmap.Create; + FBackBitmap2.PixelFormat := pf32Bit; + CreateCheckerBackground; + FHeaderBitmap := TBitmap.Create; + FHeaderBitmap.Handle := LoadImage(HInstance, 'Transcriptions', IMAGE_BITMAP, 0, 0, LR_DEFAULTCOLOR); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure THeaderOwnerDrawForm.FormDestroy(Sender: TObject); + +begin + FCheckerBackground.Free; + FBackBitmap1.Free; + FBackBitmap2.Free; + FHeaderBitmap.Free; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure THeaderOwnerDrawForm.AnimationTimerTimer(Sender: TObject); + +begin + FLeftPos := (FLeftPos + FHeaderBitmap.Width div 2000) mod FHeaderBitmap.Width; + with HeaderCustomDrawTree.Header do + Invalidate(Columns[2]); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure THeaderOwnerDrawForm.HeaderCustomDrawTreeHeaderMouseUp(Sender: TVTHeader; Button: TMouseButton; + Shift: TShiftState; X, Y: TDimension); + +begin + // Reenable animation after a drag operation. + AnimationTimer.Enabled := True; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure THeaderOwnerDrawForm.HeaderCustomDrawTreeHeaderMouseDown(Sender: TVTHeader; Button: TMouseButton; + Shift: TShiftState; X, Y: TDimension); + +begin + // Stop animation when mouse button is down. + AnimationTimer.Enabled := False; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure THeaderOwnerDrawForm.HeaderCustomDrawTreeStateChange(Sender: TBaseVirtualTree; Enter, Leave: TVirtualTreeStates); + +begin + if not (csDestroying in ComponentState) then + UpdateStateDisplay(Sender.TreeStates, Enter, Leave); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure THeaderOwnerDrawForm.HeaderCustomDrawTreeGetText(Sender: TBaseVirtualTree; Node: PVirtualNode; + Column: TColumnIndex; TextType: TVSTTextType; var CellText: string); + +begin + CellText := 'Some simple text.'; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +end. diff --git a/Demos/Advanced/Main.dfm b/Demos/Advanced/Main.dfm index ade5f4d5a..e56f1e1ed 100644 --- a/Demos/Advanced/Main.dfm +++ b/Demos/Advanced/Main.dfm @@ -10,10 +10,8 @@ object MainForm: TMainForm Font.Height = -13 Font.Name = 'Tahoma' Font.Style = [] - OldCreateOrder = False OnCreate = FormCreate OnShow = FormShow - PixelsPerInch = 96 TextHeight = 16 object Bevel1: TBevel Left = 0 diff --git a/Demos/Advanced/Main.pas b/Demos/Advanced/Main.pas index 4b7019381..0e25c824c 100644 --- a/Demos/Advanced/Main.pas +++ b/Demos/Advanced/Main.pas @@ -12,9 +12,10 @@ interface {$warn UNSAFE_CODE off} uses - Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, - ComCtrls, ToolWin, Buttons, ExtCtrls, StdCtrls, ImgList, ActnList, - StdActns, VirtualTrees; + Winapi.Windows, Winapi.Messages, System.SysUtils, System.Classes, Vcl.Graphics, + Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.ComCtrls, Vcl.ToolWin, Vcl.Buttons, + Vcl.ExtCtrls, Vcl.StdCtrls, Vcl.ImgList, Vcl.ActnList, + Vcl.StdActns, VirtualTrees; type TMainForm = class(TForm) diff --git a/Demos/Advanced/MultilineDemo.pas b/Demos/Advanced/MultilineDemo.pas index 0d833fc90..d20ecdf64 100644 --- a/Demos/Advanced/MultilineDemo.pas +++ b/Demos/Advanced/MultilineDemo.pas @@ -8,7 +8,8 @@ interface uses Windows, SysUtils, Classes, Forms, Controls, Graphics, VirtualTrees, - ExtCtrls, StdCtrls, ImgList, VirtualTrees.Types; + ExtCtrls, StdCtrls, ImgList, VirtualTrees.Types, VirtualTrees.BaseAncestorVCL, + VirtualTrees.BaseTree, VirtualTrees.AncestorVCL; type TNodeForm = class(TForm) @@ -26,7 +27,7 @@ TNodeForm = class(TForm) procedure MLTreeEditing(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; var Allowed: Boolean); procedure MLTreeStateChange(Sender: TBaseVirtualTree; Enter, Leave: TVirtualTreeStates); procedure MLTreeMeasureItem(Sender: TBaseVirtualTree; TargetCanvas: TCanvas; Node: PVirtualNode; - var NodeHeight: Integer); + var NodeHeight: TDimension); procedure AutoAdjustCheckBoxClick(Sender: TObject); end; @@ -128,8 +129,8 @@ procedure TNodeForm.MLTreeStateChange(Sender: TBaseVirtualTree; Enter, Leave: TV //---------------------------------------------------------------------------------------------------------------------- -procedure TNodeForm.MLTreeMeasureItem(Sender: TBaseVirtualTree; TargetCanvas: TCanvas; Node: PVirtualNode; - var NodeHeight: Integer); +procedure TNodeForm.MLTreeMeasureItem(Sender: TBaseVirtualTree; TargetCanvas: + TCanvas; Node: PVirtualNode; var NodeHeight: TDimension); begin if Sender.MultiLine[Node] then diff --git a/Demos/Advanced/PropertiesDemo.pas b/Demos/Advanced/PropertiesDemo.pas index 5561d638f..a71c7185f 100644 --- a/Demos/Advanced/PropertiesDemo.pas +++ b/Demos/Advanced/PropertiesDemo.pas @@ -9,9 +9,11 @@ interface uses - Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, - StdCtrls, VirtualTrees, ImgList, ExtCtrls, UITypes, VirtualTrees.BaseTree, System.ImageList, - VirtualTrees.Types; + Winapi.Windows, Winapi.Messages, System.SysUtils, System.Classes, Vcl.Graphics, + Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, VirtualTrees, + Vcl.ImgList, Vcl.ExtCtrls, System.UITypes, VirtualTrees.BaseTree, + System.ImageList, VirtualTrees.Types, VirtualTrees.BaseAncestorVCL, + VirtualTrees.AncestorVCL; const // Helper message to decouple node change handling from edit handling. diff --git a/Demos/Advanced/SpeedDemo.pas b/Demos/Advanced/SpeedDemo.pas index e34182fb1..d150230ae 100644 --- a/Demos/Advanced/SpeedDemo.pas +++ b/Demos/Advanced/SpeedDemo.pas @@ -8,8 +8,10 @@ interface uses - Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, - StdCtrls, VirtualTrees, VirtualTrees.Types, ExtDlgs, ComCtrls, jpeg, Menus; + Winapi.Windows, Winapi.Messages, System.SysUtils, System.Classes, Vcl.Graphics, + Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, VirtualTrees, + VirtualTrees.Types, Vcl.ExtDlgs, Vcl.ComCtrls, Vcl.Imaging.jpeg, Vcl.Menus, + VirtualTrees.BaseAncestorVCL, VirtualTrees.BaseTree, VirtualTrees.AncestorVCL; type TSpeedForm = class(TForm) diff --git a/Demos/Advanced/States.pas b/Demos/Advanced/States.pas index 9c3608221..480d71a08 100644 --- a/Demos/Advanced/States.pas +++ b/Demos/Advanced/States.pas @@ -3,8 +3,9 @@ interface uses - Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, - Dialogs, StdCtrls, VirtualTrees, VirtualTrees.BaseTree; + Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, + Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, + VirtualTrees, VirtualTrees.BaseTree; type TStateForm = class(TForm) diff --git a/Demos/Advanced/VisibilityDemo.dfm b/Demos/Advanced/VisibilityDemo.dfm index 96a9f9f9c..5e831b8b7 100644 --- a/Demos/Advanced/VisibilityDemo.dfm +++ b/Demos/Advanced/VisibilityDemo.dfm @@ -8202,7 +8202,7 @@ object VisibilityForm: TVisibilityForm TreeOptions.MiscOptions = [toAcceptOLEDrop, toCheckSupport, toInitOnSave, toToggleOnDblClick, toWheelPanning] TreeOptions.PaintOptions = [toHideFocusRect, toShowBackground, toShowButtons, toShowDropmark, toShowRoot, toShowTreeLines, toThemeAware, toUseBlendedImages, toUseBlendedSelection] TreeOptions.SelectionOptions = [toExtendedFocus, toFullRowSelect] - OnChange = VST2Change + OnChange = VST3Change OnCollapsed = VSTCollapsedExpanded OnExpanded = VSTCollapsedExpanded OnFreeNode = VST3FreeNode @@ -8260,6 +8260,7 @@ object VisibilityForm: TVisibilityForm TabOrder = 0 TreeOptions.AutoOptions = [toAutoDropExpand, toAutoScroll, toAutoScrollOnExpand, toAutoTristateTracking, toAutoHideButtons, toAutoChangeScale] TreeOptions.SelectionOptions = [toMultiSelect] + OnChange = VST1Change OnFreeNode = VST1FreeNode OnGetText = VST1GetText OnInitChildren = VST1InitChildren diff --git a/Demos/Advanced/VisibilityDemo.pas b/Demos/Advanced/VisibilityDemo.pas index 22599763c..e67f770a6 100644 --- a/Demos/Advanced/VisibilityDemo.pas +++ b/Demos/Advanced/VisibilityDemo.pas @@ -10,8 +10,10 @@ interface uses - Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, - StdCtrls, VirtualTrees, ComCtrls, ExtCtrls, ImgList, VirtualTrees.Types; + Winapi.Windows, Winapi.Messages, System.SysUtils, System.Classes, Vcl.Graphics, + Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, VirtualTrees, Vcl.ComCtrls, + Vcl.ExtCtrls, Vcl.ImgList, VirtualTrees.Types, VirtualTrees.BaseAncestorVCL, + VirtualTrees.BaseTree, VirtualTrees.AncestorVCL; type TVisibilityForm = class(TForm) @@ -33,11 +35,12 @@ TVisibilityForm = class(TForm) procedure RadioGroup1Click(Sender: TObject); procedure VST2GetText(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; TextType: TVSTTextType; var CellText: string); - procedure VST3Scroll(Sender: TBaseVirtualTree; DeltaX, DeltaY: Integer); + procedure VST3Scroll(Sender: TBaseVirtualTree; DeltaX, DeltaY: TDimension); procedure VST2InitChildren(Sender: TBaseVirtualTree; Node: PVirtualNode; var ChildCount: Cardinal); - procedure VST2Scroll(Sender: TBaseVirtualTree; DeltaX, DeltaY: Integer); + procedure VST2Scroll(Sender: TBaseVirtualTree; DeltaX, DeltaY: TDimension); procedure VSTCollapsedExpanded(Sender: TBaseVirtualTree; Node: PVirtualNode); procedure VST2Change(Sender: TBaseVirtualTree; Node: PVirtualNode); + procedure VST3Change(Sender: TBaseVirtualTree; Node: PVirtualNode); procedure Splitter2CanResize(Sender: TObject; var NewSize: Integer; var Accept: Boolean); procedure Splitter2Paint(Sender: TObject); @@ -45,11 +48,15 @@ TVisibilityForm = class(TForm) var CellText: string); procedure FormShow(Sender: TObject); procedure FormHide(Sender: TObject); + procedure VST1Change(Sender: TBaseVirtualTree; Node: PVirtualNode); procedure VST3FreeNode(Sender: TBaseVirtualTree; Node: PVirtualNode); procedure VST2FreeNode(Sender: TBaseVirtualTree; Node: PVirtualNode); procedure VST1FreeNode(Sender: TBaseVirtualTree; Node: PVirtualNode); + procedure VSTChange(Sender: TBaseVirtualTree; Node: PVirtualNode); + private FChanging: Boolean; + procedure ShowNode(const Source: string; Node: PVirtualNode); procedure HideNodes(Sender: TBaseVirtualTree; Node: PVirtualNode; Data: Pointer; var Abort: Boolean); end; @@ -184,7 +191,7 @@ procedure TVisibilityForm.VST2GetText(Sender: TBaseVirtualTree; Node: PVirtualNo //---------------------------------------------------------------------------------------------------------------------- -procedure TVisibilityForm.VST3Scroll(Sender: TBaseVirtualTree; DeltaX, DeltaY: Integer); +procedure TVisibilityForm.VST3Scroll(Sender: TBaseVirtualTree; DeltaX, DeltaY: TDimension); // Synchronizes scroll offsets of VST2 and VST3. @@ -204,7 +211,7 @@ procedure TVisibilityForm.VST3Scroll(Sender: TBaseVirtualTree; DeltaX, DeltaY: I //---------------------------------------------------------------------------------------------------------------------- -procedure TVisibilityForm.VST2Scroll(Sender: TBaseVirtualTree; DeltaX, DeltaY: Integer); +procedure TVisibilityForm.VST2Scroll(Sender: TBaseVirtualTree; DeltaX, DeltaY: TDimension); // Synchronizes scroll offsets of VST2 and VST3. @@ -261,7 +268,14 @@ procedure TVisibilityForm.VSTCollapsedExpanded(Sender: TBaseVirtualTree; Node: P //---------------------------------------------------------------------------------------------------------------------- -procedure TVisibilityForm.VST2Change(Sender: TBaseVirtualTree; Node: PVirtualNode); +procedure TVisibilityForm.ShowNode(const Source: string; Node: PVirtualNode); +begin + OutputDebugString(PChar(Format('%s %s Node: %p', [FormatDateTime('hh:nn:ss', Now), Source, Pointer(Node)]))); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVisibilityForm.VSTChange(Sender: TBaseVirtualTree; Node: PVirtualNode); // Keep selected nodes in sync. @@ -290,6 +304,22 @@ procedure TVisibilityForm.VST2Change(Sender: TBaseVirtualTree; Node: PVirtualNod //---------------------------------------------------------------------------------------------------------------------- +procedure TVisibilityForm.VST2Change(Sender: TBaseVirtualTree; Node: PVirtualNode); +begin + ShowNode('VST2', Node); + VSTChange(Sender, Node); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVisibilityForm.VST3Change(Sender: TBaseVirtualTree; Node: PVirtualNode); +begin + ShowNode('VST3', Node); + VSTChange(Sender, Node); +end; + +//---------------------------------------------------------------------------------------------------------------------- + procedure TVisibilityForm.Splitter2CanResize(Sender: TObject; var NewSize: Integer; var Accept: Boolean); // This method is called just before resizing is done. This is a good opportunity to adjust the background image @@ -338,6 +368,12 @@ procedure TVisibilityForm.FormHide(Sender: TObject); StateForm.Show; end; +procedure TVisibilityForm.VST1Change(Sender: TBaseVirtualTree; Node: + PVirtualNode); +begin + ShowNode('VST1', Node); +end; + //---------------------------------------------------------------------------------------------------------------------- procedure TVisibilityForm.VST1FreeNode(Sender: TBaseVirtualTree; diff --git a/Demos/Advanced/WindowsXPStyleDemo.pas b/Demos/Advanced/WindowsXPStyleDemo.pas index 73ad96205..96f0c611e 100644 --- a/Demos/Advanced/WindowsXPStyleDemo.pas +++ b/Demos/Advanced/WindowsXPStyleDemo.pas @@ -11,10 +11,11 @@ interface {$warn UNSAFE_CODE off} uses - Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, - Dialogs, VirtualTrees, ImgList, ComCtrls, ToolWin, Menus, StdCtrls, UITypes, - System.ImageList, VirtualTrees.Types, Vcl.ExtCtrls, - VirtualTrees.BaseAncestorVCL, VirtualTrees.BaseTree, VirtualTrees.AncestorVCL; + Winapi.Windows, Winapi.Messages, System.SysUtils, System.Classes, Vcl.Graphics, + Vcl.Controls, Vcl.Forms, Vcl.Dialogs, VirtualTrees, Vcl.ImgList, Vcl.ComCtrls, + Vcl.ToolWin, Vcl.Menus, Vcl.StdCtrls, System.UITypes, System.ImageList, + VirtualTrees.Types, Vcl.ExtCtrls, VirtualTrees.BaseAncestorVCL, + VirtualTrees.BaseTree, VirtualTrees.AncestorVCL; type TWindowsXPForm = class(TForm) diff --git a/Demos/Interfaces/charityevents.dpr b/Demos/Interfaces/charityevents.dpr index cd2df8533..4e2a9eb7e 100644 --- a/Demos/Interfaces/charityevents.dpr +++ b/Demos/Interfaces/charityevents.dpr @@ -1,4 +1,4 @@ -program charityevents; +program charityevents; uses Vcl.Forms, @@ -15,4 +15,4 @@ begin Application.CreateForm(TFormModelView, FormModelView); Application.Run; -end. +end. diff --git a/Demos/Interfaces/charityevents.dproj b/Demos/Interfaces/charityevents.dproj index 12c050aa9..7db55c19e 100644 --- a/Demos/Interfaces/charityevents.dproj +++ b/Demos/Interfaces/charityevents.dproj @@ -1,7 +1,7 @@  {527B0DE7-5A48-4EA5-9810-F0952ADD7A9C} - 20.2 + 20.3 VCL charityevents.dpr True diff --git a/Demos/Minimal/Main.pas b/Demos/Minimal/Main.pas index 2c3e41cca..57a3e87f7 100644 --- a/Demos/Minimal/Main.pas +++ b/Demos/Minimal/Main.pas @@ -6,8 +6,9 @@ interface uses - Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, - VirtualTrees, StdCtrls, ExtCtrls; + Winapi.Windows, Winapi.Messages, System.SysUtils, System.Classes, Vcl.Graphics, + Vcl.Controls, Vcl.Forms, Vcl.Dialogs, VirtualTrees, Vcl.StdCtrls, Vcl.ExtCtrls, + VirtualTrees.BaseAncestorVCL, VirtualTrees.BaseTree, VirtualTrees.AncestorVCL; type TMainForm = class(TForm) diff --git a/Demos/Minimal/Minimal.dproj b/Demos/Minimal/Minimal.dproj index c6ac5a90a..48564c718 100644 --- a/Demos/Minimal/Minimal.dproj +++ b/Demos/Minimal/Minimal.dproj @@ -7,7 +7,7 @@ Minimal.dpr Win32 {9ED56071-1730-40BE-A992-27309A7C55CB} - 20.2 + 20.3 1 Minimal diff --git a/Demos/Multiselect/Multiselect.Main.dfm b/Demos/Multiselect/Multiselect.Main.dfm new file mode 100644 index 000000000..d4a3f89c6 --- /dev/null +++ b/Demos/Multiselect/Multiselect.Main.dfm @@ -0,0 +1,188 @@ +object Form1: TForm1 + Left = 0 + Top = 0 + Margins.Left = 7 + Margins.Top = 7 + Margins.Right = 7 + Margins.Bottom = 7 + Caption = 'Multiselect Demo' + ClientHeight = 776 + ClientWidth = 1104 + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -27 + Font.Name = 'Segoe UI' + Font.Style = [] + OldCreateOrder = True + Position = poMainFormCenter + OnCreate = FormCreate + PixelsPerInch = 216 + TextHeight = 37 + object VirtualStringTree1: TVirtualStringTree + Left = 0 + Top = 0 + Width = 828 + Height = 776 + Margins.Left = 7 + Margins.Top = 7 + Margins.Right = 7 + Margins.Bottom = 7 + Align = alClient + DefaultNodeHeight = 46 + Header.AutoSizeIndex = 0 + Header.Height = 40 + Header.MaxHeight = 22500 + Header.MinHeight = 23 + Header.Options = [hoColumnResize, hoDrag, hoShowSortGlyphs, hoVisible] + Indent = 41 + Margin = 9 + TabOrder = 0 + TextMargin = 9 + TreeOptions.SelectionOptions = [toExtendedFocus, toMultiSelect, toSelectNextNodeOnRemoval] + OnFreeNode = VirtualStringTree1FreeNode + OnGetText = VirtualStringTree1GetText + OnKeyPress = VirtualStringTree1KeyPress + Touch.InteractiveGestures = [igPan, igPressAndTap] + Touch.InteractiveGestureOptions = [igoPanSingleFingerHorizontal, igoPanSingleFingerVertical, igoPanInertia, igoPanGutter, igoParentPassthrough] + Columns = < + item + MaxWidth = 9999 + MinWidth = 9 + Position = 0 + Spacing = 2 + Text = 'table_schema' + Width = 212 + end + item + MaxWidth = 9999 + MinWidth = 9 + Position = 1 + Spacing = 2 + Text = 'table_name' + Width = 191 + end + item + MaxWidth = 9999 + MinWidth = 9 + Position = 2 + Spacing = 2 + Text = 'table_type' + Width = 204 + end + item + MaxWidth = 9999 + MinWidth = 9 + Position = 3 + Spacing = 2 + Text = 'table_version' + Width = 183 + end> + end + object Panel1: TPanel + Left = 828 + Top = 0 + Width = 276 + Height = 776 + Margins.Left = 7 + Margins.Top = 7 + Margins.Right = 7 + Margins.Bottom = 7 + Align = alRight + Anchors = [] + BevelOuter = bvNone + Caption = 'Panel1' + TabOrder = 1 + DesignSize = ( + 276 + 776) + object btnSelect4CellsLeftToRight: TButton + Left = 44 + Top = 6 + Width = 216 + Height = 90 + Margins.Left = 7 + Margins.Top = 7 + Margins.Right = 7 + Margins.Bottom = 7 + Anchors = [akRight] + Caption = 'Select 4 cells'#13#10'left to right' + TabOrder = 0 + WordWrap = True + OnClick = btnSelect4CellsLeftToRightClick + end + object btnSelect4CellsRightToLeft: TButton + Left = 44 + Top = 110 + Width = 216 + Height = 90 + Margins.Left = 7 + Margins.Top = 7 + Margins.Right = 7 + Margins.Bottom = 7 + Anchors = [akRight] + Caption = 'Select 4 cells'#13#10'right to left' + TabOrder = 1 + WordWrap = True + OnClick = btnSelect4CellsRightToLeftClick + end + object btnClickRow2Col1: TButton + Left = 14 + Top = 293 + Width = 252 + Height = 56 + Margins.Left = 7 + Margins.Top = 7 + Margins.Right = 7 + Margins.Bottom = 7 + Anchors = [akRight] + Caption = 'Select row 2, cell 1' + TabOrder = 2 + OnClick = btnClickRow2Col1Click + end + object btnClickRow1Col1: TButton + Left = 14 + Top = 222 + Width = 252 + Height = 57 + Margins.Left = 7 + Margins.Top = 7 + Margins.Right = 7 + Margins.Bottom = 7 + Anchors = [akRight] + Caption = 'Select row 1, cell 1' + TabOrder = 3 + OnClick = btnClickRow1Col1Click + end + object btnSelectRow3Col1Row4Col2: TButton + Left = 14 + Top = 363 + Width = 252 + Height = 118 + Margins.Left = 7 + Margins.Top = 7 + Margins.Right = 7 + Margins.Bottom = 7 + Anchors = [akRight] + Caption = 'Select row 3, col 2, row 4, col 3'#13#10'Copy' + TabOrder = 4 + WordWrap = True + OnClick = btnSelectRow3Col1Row4Col2Click + end + object btnSelectRow2_3_Copy: TButton + Left = 14 + Top = 495 + Width = 252 + Height = 72 + Margins.Left = 7 + Margins.Top = 7 + Margins.Right = 7 + Margins.Bottom = 7 + Anchors = [akRight] + Caption = 'Select row 2-3, copy' + TabOrder = 5 + WordWrap = True + OnClick = btnSelectRow2_3_CopyClick + end + end +end diff --git a/Demos/Multiselect/Multiselect.Main.pas b/Demos/Multiselect/Multiselect.Main.pas new file mode 100644 index 000000000..e9c662cb0 --- /dev/null +++ b/Demos/Multiselect/Multiselect.Main.pas @@ -0,0 +1,333 @@ +unit Multiselect.Main; + +// Virtual Treeview sample form demonstrating following feature: +// - Multiple cell selection. +// Written by CheeWee Chua. + +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, Vcl.StdCtrls, Vcl.ExtCtrls; + +type + TForm1 = class(TForm) + VirtualStringTree1: TVirtualStringTree; + Panel1: TPanel; + btnSelect4CellsLeftToRight: TButton; + btnSelect4CellsRightToLeft: TButton; + btnClickRow2Col1: TButton; + btnClickRow1Col1: TButton; + btnSelectRow3Col1Row4Col2: TButton; + btnSelectRow2_3_Copy: TButton; + procedure FormCreate(Sender: TObject); + procedure VirtualStringTree1FreeNode(Sender: TBaseVirtualTree; + Node: PVirtualNode); + procedure VirtualStringTree1GetText(Sender: TBaseVirtualTree; + Node: PVirtualNode; Column: TColumnIndex; TextType: TVSTTextType; + var CellText: string); + procedure btnSelect4CellsLeftToRightClick(Sender: TObject); + procedure btnSelect4CellsRightToLeftClick(Sender: TObject); + procedure btnClickRow1Col1Click(Sender: TObject); + procedure btnClickRow2Col1Click(Sender: TObject); + procedure btnSelectRow3Col1Row4Col2Click(Sender: TObject); + procedure btnSelectRow2_3_CopyClick(Sender: TObject); + procedure VirtualStringTree1KeyPress(Sender: TObject; var Key: Char); + private + { Private declarations } + + procedure EnableMulticellSelection; + procedure EnableFullRowSelection; + + // These functions mimic human interaction with the user interface + procedure MouseClick(const ACursorPos: TPoint); overload; + procedure MouseClick(ANode: PVirtualNode; AColumn: TColumnIndex = 0); overload; + procedure ShiftMouseClick(ANode: PVirtualNode; AColumn: TColumnIndex = 0); overload; + procedure ShiftMouseClick(const ACell: TVTCell); overload; + public + { Public declarations } + end; + +var + Form1: TForm1; + +implementation + +uses + VirtualTrees.Types, VirtualTrees.Clipboard; + +{$R *.dfm} + +type + TRowData = record + table_schema: string; + table_name: string; + table_type: string; + public + constructor Create(const ASchema, AName, AType: string); + procedure Clear; + class operator Finalize(var Self: TRowData); + end; + +{ TRowData } + +procedure TRowData.Clear; +begin + table_schema := ''; + table_name := ''; + table_type := ''; +end; + +constructor TRowData.Create(const ASchema, AName, AType: string); +begin + table_schema := ASchema; + table_name := AName; + table_type := AType; +end; + +class operator TRowData.Finalize(var Self: TRowData); +begin + Self.Clear; +end; + +const + colSchema = 0; + colName = 1; + colType = 2; + +procedure TForm1.btnClickRow1Col1Click(Sender: TObject); +begin + EnableMulticellSelection; + var LTree := VirtualStringTree1; + var LNode := LTree.GetFirstChild(LTree.RootNode); + MouseClick(LNode); +end; + +procedure TForm1.btnClickRow2Col1Click(Sender: TObject); +begin + EnableMulticellSelection; + var LTree := VirtualStringTree1; + var LNode := LTree.GetFirstChild(LTree.RootNode); + LNode := LTree.GetNext(LNode); + MouseClick(LNode); +end; + +procedure TForm1.btnSelect4CellsLeftToRightClick(Sender: TObject); +begin + EnableMulticellSelection; + var LTree := VirtualStringTree1; + LTree.ClearCellSelection; + + var LNode := LTree.GetFirstChild(LTree.RootNode); + for var I := 1 to 2 do + LNode := LTree.GetNext(LNode); + // We're on 3rd row now... + var L3rdRow := LNode; // 3rd row + var L4thRow := LTree.GetNext(L3rdRow); // 4th row + + // Select cells from left to right + LTree.SelectCells( + L3rdRow, 1, // Left aka Start + L4thRow, 2, // Right aka End + True); +end; + +procedure TForm1.btnSelect4CellsRightToLeftClick(Sender: TObject); +begin + EnableMulticellSelection; + var LTree := VirtualStringTree1; + + LTree.ClearCellSelection; + + var LNode := LTree.GetFirstChild(LTree.RootNode); + for var I := 1 to 2 do + LNode := LTree.GetNext(LNode); + // We're on 3rd row now... + var L3rdRow := LNode; + var L4thRow := LTree.GetNext(L3rdRow); // 4th row + LTree.SelectCells( + L4thRow, 2, // Right aka Start + L3rdRow, 1, // Left aka End + True); +end; + +procedure TForm1.btnSelectRow2_3_CopyClick(Sender: TObject); +begin + // RegisterVTClipboardFormat(CF_TEXT, TVirtualStringTree); + EnableFullRowSelection; + var LTree := VirtualStringTree1; + + var LNode1 := LTree.GetFirstVisible(); + var LNode2 := LTree.GetNextVisible(LNode1); + var LNode3 := LTree.GetNextVisible(LNode2); + LTree.Selected[LNode2] := True; + LTree.Selected[LNode3] := True; + + LTree.CopyToClipboard; +end; + +procedure TForm1.btnSelectRow3Col1Row4Col2Click(Sender: TObject); +begin + EnableMulticellSelection; + var LTree := VirtualStringTree1; + + var LNode := LTree.GetFirstChild(LTree.RootNode); + for var I := 1 to 2 do + LNode := LTree.GetNext(LNode); + // We're on 3rd row now... + var L3rdRow := LNode; // 3rd row + var L4thRow := LTree.GetNext(L3rdRow); // 4th row + + // column 1 in code is column 2 in human eyes... + MouseClick(L3rdRow, 1); + + // column 2 in code is column 3 in human eyes... + ShiftMouseClick(TVTCell.Create(L4thRow, 2)); + + LTree.CopyToClipboard; +end; + +procedure TForm1.EnableFullRowSelection; +begin + var LTree := VirtualStringTree1; + LTree.TreeOptions.SelectionOptions := LTree.TreeOptions.SelectionOptions + + [toFullRowSelect]; +end; + +procedure TForm1.EnableMulticellSelection; +begin + var LTree := VirtualStringTree1; + LTree.TreeOptions.SelectionOptions := LTree.TreeOptions.SelectionOptions + + [toMultiSelect, toExtendedFocus] - [toFullRowSelect]; +end; + +procedure TForm1.FormCreate(Sender: TObject); +begin + var LTree := VirtualStringTree1; + + LTree.NodeDataSize := SizeOf(TRowData); + + var LNode1 := LTree.AddChild(LTree.RootNode); + var LNode2 := LTree.AddChild(LTree.RootNode); + var LNode3 := LTree.AddChild(LTree.RootNode); + var LNode4 := LTree.AddChild(LTree.RootNode); + var LNode5 := LTree.AddChild(LTree.RootNode); + var LNode6 := LTree.AddChild(LTree.RootNode); + var LNode7 := LTree.AddChild(LTree.RootNode); + var LNode8 := LTree.AddChild(LTree.RootNode); + + LNode1.SetData(TRowData.Create('pg_catalog', 'pg_user_info', 'VIEW')); + LNode2.SetData(TRowData.Create('pg_catalog', 'pg_stastic', 'BASE TABLE')); + LNode3.SetData(TRowData.Create('pg_catalog', 'pg_settings', 'VIEW1')); + LNode4.SetData(TRowData.Create('pg_catalog', 'pg_type', 'VIEW2')); + LNode5.SetData(TRowData.Create('pg_catalog', 'pg_attribute', 'BASE TABLE')); + LNode6.SetData(TRowData.Create('pg_catalog', 'pg_class', 'BASE TABLE')); + LNode7.SetData(TRowData.Create('pg_catalog', 'pg_tablespace', 'BASE TABLE')); + LNode8.SetData(TRowData.Create('pg_catalog', 'pg_inherits', 'BASE TABLE')); + + LTree.ClipboardFormats.Add(GetVTClipboardFormatDescription(CF_TEXT)); + LTree.ClipboardFormats.Add(GetVTClipboardFormatDescription(CF_UNICODETEXT)); + LTree.ClipboardFormats.Add(GetVTClipboardFormatDescription(CF_VRTF)); + LTree.ClipboardFormats.Add(GetVTClipboardFormatDescription(CF_HTML)); +end; + +procedure TForm1.VirtualStringTree1FreeNode(Sender: TBaseVirtualTree; + Node: PVirtualNode); +begin + var LData := Node.GetData; + LData.Clear; +end; + +procedure TForm1.VirtualStringTree1GetText(Sender: TBaseVirtualTree; + Node: PVirtualNode; Column: TColumnIndex; TextType: TVSTTextType; + var CellText: string); +begin + if not Assigned(Node) then + Exit; + var LData := Node.GetData; + case Column of + colSchema: begin + CellText := LData.table_schema; + end; + colName: begin + CellText := LData.table_name; + end; + colType: begin + CellText := LData.table_type; + end; + // column 4 is deliberately left empty + end; +end; + +procedure TForm1.MouseClick(const ACursorPos: TPoint); +const + KEYDOWN = Byte(1 shl 7); +var + LKeyboardState: TKeyboardState; +begin + // Click a new cell on the tree... + var LTree := VirtualStringTree1; + var LCursorPos := Mouse.CursorPos; + try + Mouse.CursorPos := ACursorPos; + var LWPARAM: WPARAM := MK_LBUTTON; + if GetKeyboardState(LKeyboardState) then + begin + if (LKeyboardState[VK_SHIFT] and KEYDOWN <> 0) or + (LKeyboardState[VK_LSHIFT] and KEYDOWN <> 0) or + (LKeyboardState[VK_RSHIFT] and KEYDOWN <> 0) then + LWPARAM := LWPARAM or MK_SHIFT; + if (LKeyboardState[VK_CONTROL] and KEYDOWN <> 0) or + (LKeyboardState[VK_LCONTROL] and KEYDOWN <> 0) or + (LKeyboardState[VK_RCONTROL] and KEYDOWN <> 0) then + LWPARAM := LWPARAM or MK_CONTROL; + end; + var LPos := MakeLParam(ACursorPos.X, ACursorPos.Y); + LTree.Perform(WM_LBUTTONDOWN, LWPARAM, LPos); + LTree.Perform(WM_LBUTTONUP, LWPARAM, LPos); + finally + Mouse.CursorPos := LCursorPos; + end; +end; + +procedure TForm1.MouseClick(ANode: PVirtualNode; AColumn: TColumnIndex); +begin + var LTree := VirtualStringTree1; + var LClientRect := LTree.GetDisplayRect(ANode, AColumn, True); + MouseClick(LClientRect.TopLeft); +end; + +procedure TForm1.ShiftMouseClick(const ACell: TVTCell); +begin + ShiftMouseClick(ACell.Node, ACell.Column); +end; + +procedure TForm1.ShiftMouseClick(ANode: PVirtualNode; AColumn: TColumnIndex = 0); +const + KEYDOWN = Byte(1 shl 7); +var + LOrigKBState, LNewKBState: TKeyboardState; +begin + GetKeyboardState(LOrigKBState); + LNewKBState := LOrigKBState; + LNewKBState[VK_SHIFT] := LOrigKBState[VK_SHIFT] or KEYDOWN; + SetKeyboardState(LNewKBState); + try + MouseClick(ANode, AColumn); + finally + SetKeyboardState(LOrigKBState); + end; +end; + +procedure TForm1.VirtualStringTree1KeyPress(Sender: TObject; var Key: Char); +begin + // Press Ctrl+C to copy to clipboard + if Key = ^C then + begin + VirtualStringTree1.CopyToClipboard; + end; +end; + +end. diff --git a/Demos/Multiselect/Multiselect.dpr b/Demos/Multiselect/Multiselect.dpr new file mode 100644 index 000000000..3efa63ebd --- /dev/null +++ b/Demos/Multiselect/Multiselect.dpr @@ -0,0 +1,14 @@ +program Multiselect; + +uses + Vcl.Forms, + Multiselect.Main in 'Multiselect.Main.pas' {Form1}; + +{$R *.res} + +begin + Application.Initialize; + Application.MainFormOnTaskbar := True; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. diff --git a/Demos/Multiselect/Multiselect.dproj b/Demos/Multiselect/Multiselect.dproj new file mode 100644 index 000000000..dae5eb97b --- /dev/null +++ b/Demos/Multiselect/Multiselect.dproj @@ -0,0 +1,166 @@ + + + {B90F6CEF-381E-4531-ACD8-5F0D652EC358} + 19.2 + VCL + True + Debug + Win32 + Multiselect + 3 + Application + Multiselect.dpr + + + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Cfg_1 + true + true + + + true + Cfg_1 + true + true + + + true + Base + true + + + true + Cfg_2 + true + true + + + true + Cfg_2 + true + true + + + .\$(Platform)\$(Config) + .\$(Platform)\$(Config) + false + false + false + false + false + System;Xml;Data;Datasnap;Web;Soap;Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;$(DCC_Namespace) + $(BDS)\bin\delphi_PROJECTICON.ico + Multiselect + ..\..\Source;$(DCC_UnitSearchPath) + 1031 + CompanyName=;FileDescription=$(MSBuildProjectName);FileVersion=1.0.0.0;InternalName=Multiselect;LegalCopyright=© 2026, CheeWee Chua;LegalTrademarks=;OriginalFilename=Multiselect;ProgramID=cx.ath.journeyman.$(MSBuildProjectName);ProductName=$(MSBuildProjectName);ProductVersion=1.0.0.0;Comments=Multiselect demo by CheeWee Chua, https://github.com/chuacw + + + vclwinx;DataSnapServer;fmx;emshosting;vclie;DbxCommonDriver;bindengine;IndyIPCommon;VCLRESTComponents;DBXMSSQLDriver;FireDACCommonODBC;emsclient;FireDACCommonDriver;IndyProtocols;vclx;Skia.Package.RTL;IndyIPClient;dbxcds;vcledge;bindcompvclwinx;emsedge;bindcompfmx;DBXFirebirdDriver;inetdb;FireDACSqliteDriver;DbxClientDriver;FireDACASADriver;soapmidas;vclactnband;fmxFireDAC;dbexpress;FireDACInfxDriver;DBXMySQLDriver;VclSmp;inet;DataSnapCommon;fmxase;vcltouch;DBXOdbcDriver;dbrtl;FireDACDBXDriver;Skia.Package.FMX;FireDACOracleDriver;fmxdae;FireDACMSAccDriver;CustomIPTransport;FireDACMSSQLDriver;DataSnapIndy10ServerTransport;DataSnapConnectors;vcldsnap;DBXInterBaseDriver;FireDACMongoDBDriver;IndySystem;FireDACTDataDriver;Skia.Package.VCL;vcldb;VirtualTreesR;vclFireDAC;bindcomp;FireDACCommon;DataSnapServerMidas;FireDACODBCDriver;emsserverresource;inetstn;IndyCore;RESTBackendComponents;bindcompdbx;rtl;FireDACMySQLDriver;FireDACADSDriver;RESTComponents;DBXSqliteDriver;vcl;IndyIPServer;dsnapxml;dsnapcon;DataSnapClient;DataSnapProviderClient;adortl;DBXSybaseASEDriver;DBXDb2Driver;vclimg;DataSnapFireDAC;emsclientfiredac;FireDACPgDriver;FireDAC;FireDACDSDriver;inetdbxpress;xmlrtl;tethering;bindcompvcl;dsnap;CloudService;DBXSybaseASADriver;DBXOracleDriver;FireDACDb2Driver;DBXInformixDriver;fmxobj;bindcompvclsmp;DataSnapNativeClient;DatasnapConnectorsFreePascal;soaprtl;soapserver;FireDACIBDriver;$(DCC_UsePackage) + Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace) + Debug + true + CompanyName=;FileDescription=$(MSBuildProjectName);FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProgramID=com.embarcadero.$(MSBuildProjectName);ProductName=$(MSBuildProjectName);ProductVersion=1.0.0.0;Comments= + 1033 + $(BDS)\bin\default_app.manifest + + + vclwinx;DataSnapServer;fmx;emshosting;vclie;DbxCommonDriver;bindengine;IndyIPCommon;VCLRESTComponents;DBXMSSQLDriver;FireDACCommonODBC;emsclient;FireDACCommonDriver;IndyProtocols;vclx;IndyIPClient;dbxcds;vcledge;bindcompvclwinx;emsedge;bindcompfmx;DBXFirebirdDriver;inetdb;FireDACSqliteDriver;DbxClientDriver;FireDACASADriver;soapmidas;vclactnband;fmxFireDAC;dbexpress;FireDACInfxDriver;DBXMySQLDriver;VclSmp;inet;DataSnapCommon;fmxase;vcltouch;DBXOdbcDriver;dbrtl;FireDACDBXDriver;FireDACOracleDriver;fmxdae;FireDACMSAccDriver;CustomIPTransport;FireDACMSSQLDriver;DataSnapIndy10ServerTransport;DataSnapConnectors;vcldsnap;DBXInterBaseDriver;FireDACMongoDBDriver;IndySystem;FireDACTDataDriver;Skia.Package.VCL;vcldb;VirtualTreesR;vclFireDAC;bindcomp;FireDACCommon;DataSnapServerMidas;FireDACODBCDriver;emsserverresource;inetstn;IndyCore;RESTBackendComponents;bindcompdbx;rtl;FireDACMySQLDriver;FireDACADSDriver;RESTComponents;DBXSqliteDriver;vcl;IndyIPServer;dsnapxml;dsnapcon;DataSnapClient;DataSnapProviderClient;adortl;DBXSybaseASEDriver;DBXDb2Driver;vclimg;DataSnapFireDAC;emsclientfiredac;FireDACPgDriver;FireDAC;FireDACDSDriver;inetdbxpress;xmlrtl;tethering;bindcompvcl;dsnap;CloudService;DBXSybaseASADriver;DBXOracleDriver;FireDACDb2Driver;DBXInformixDriver;fmxobj;bindcompvclsmp;DataSnapNativeClient;DatasnapConnectorsFreePascal;soaprtl;soapserver;FireDACIBDriver;$(DCC_UsePackage) + Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;$(DCC_Namespace) + Debug + true + CompanyName=;FileDescription=$(MSBuildProjectName);FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProgramID=com.embarcadero.$(MSBuildProjectName);ProductName=$(MSBuildProjectName);ProductVersion=1.0.0.0;Comments= + 1033 + $(BDS)\bin\default_app.manifest + + + DEBUG;$(DCC_Define) + true + false + true + true + true + true + true + + + false + PerMonitorV2 + true + 1033 + CompanyName=;FileDescription=$(MSBuildProjectName);FileVersion=1.0.0.0;InternalName=Multiselect;LegalCopyright=© 2026, CheeWee Chua;LegalTrademarks=;OriginalFilename=Multiselect;ProgramID=cx.ath.journeyman.$(MSBuildProjectName);ProductName=$(MSBuildProjectName);ProductVersion=1.0.0.0;Comments=Multiselect demo by CheeWee Chua, https://github.com/chuacw + + + PerMonitorV2 + + + false + RELEASE;$(DCC_Define) + 0 + 0 + + + PerMonitorV2 + + + PerMonitorV2 + + + + MainSource + + +
Form1
+ dfm + + + Base + + + Cfg_1 + Base + + + Cfg_2 + Base + + + + Delphi.Personality.12 + Application + + + + Multiselect.dpr + + + + + True + True + + + 12 + + + + + diff --git a/Demos/OLE/Main.dfm b/Demos/OLE/Main.dfm index 0aa63f0da..c6c751f12 100644 --- a/Demos/OLE/Main.dfm +++ b/Demos/OLE/Main.dfm @@ -139,6 +139,7 @@ object MainForm: TMainForm OnDragAllowed = Tree2DragAllowed OnDragOver = TreeDragOver OnDragDrop = TreeDragDrop + OnFreeNode = TreeFreeNode OnGetText = Tree1GetText OnInitNode = TreeInitNode OnNewText = Tree1NewText @@ -184,6 +185,7 @@ object MainForm: TMainForm TreeOptions.SelectionOptions = [toMultiSelect] OnDragOver = TreeDragOver OnDragDrop = TreeDragDrop + OnFreeNode = TreeFreeNode OnGetText = Tree1GetText OnInitNode = TreeInitNode OnNewText = Tree1NewText diff --git a/Demos/OLE/Main.pas b/Demos/OLE/Main.pas index 31a564ca0..5db4b7a08 100644 --- a/Demos/OLE/Main.pas +++ b/Demos/OLE/Main.pas @@ -1,674 +1,687 @@ -unit Main; - -// Virtual Treeview sample application demonstrating clipboard and drag'n drop operations. -// The treeview uses OLE for these operations but can also issue and accept VCL drag'n drop. -// Written by Mike Lischke. - -interface - -uses - Windows, Messages, ActiveX, SysUtils, Forms, Dialogs, Graphics, - VirtualTrees, ActnList, ComCtrls, ExtCtrls, StdCtrls, Controls, Classes, - ImgList, System.Actions, System.ImageList, VirtualTrees.BaseAncestorVCL, - VirtualTrees.BaseTree, VirtualTrees.AncestorVCL, VirtualTrees.Types; - -type - TMainForm = class(TForm) - ActionList1: TActionList; - CutAction: TAction; - CopyAction: TAction; - PasteAction: TAction; - FontDialog: TFontDialog; - Panel3: TPanel; - Label6: TLabel; - Button1: TButton; - Button3: TButton; - Tree2: TVirtualStringTree; - Label1: TLabel; - Tree1: TVirtualStringTree; - Label2: TLabel; - PageControl1: TPageControl; - LogTabSheet: TTabSheet; - RichTextTabSheet: TTabSheet; - LogListBox: TListBox; - RichEdit1: TRichEdit; - Label3: TLabel; - Label7: TLabel; - Button2: TButton; - TabSheet1: TTabSheet; - Label8: TLabel; - TabSheet2: TTabSheet; - Label4: TLabel; - Label5: TLabel; - Label9: TLabel; - Label10: TLabel; - TreeImages: TImageList; - procedure Button1Click(Sender: TObject); - procedure CutActionExecute(Sender: TObject); - procedure CopyActionExecute(Sender: TObject); - procedure PasteActionExecute(Sender: TObject); - procedure Tree1GetText(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; TextType: TVSTTextType; - var CellText: string); - procedure FormCreate(Sender: TObject); - procedure TreeDragDrop(Sender: TBaseVirtualTree; Source: TObject; DataObject: IDataObject; - Formats: TFormatArray; Shift: TShiftState; Pt: TPoint; var Effect: Integer; Mode: TDropMode); - procedure Button2Click(Sender: TObject); - procedure TreeInitNode(Sender: TBaseVirtualTree; ParentNode, Node: PVirtualNode; - var InitialStates: TVirtualNodeInitStates); - procedure Tree1NewText(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; NewText: string); - procedure Button3Click(Sender: TObject); - procedure Tree2DragAllowed(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; var Allowed: Boolean); - procedure TreeDragOver(Sender: TBaseVirtualTree; Source: TObject; Shift: TShiftState; State: TDragState; - Pt: TPoint; Mode: TDropMode; var Effect: Integer; var Accept: Boolean); - procedure Tree2BeforeItemErase(Sender: TBaseVirtualTree; Canvas: TCanvas; Node: PVirtualNode; ItemRect: TRect; - var ItemColor: TColor; var EraseAction: TItemEraseAction); - private - procedure AddUnicodeText(DataObject: IDataObject; Target: TVirtualStringTree; Mode: TVTNodeAttachMode); - procedure AddVCLText(Target: TVirtualStringTree; const Text: UnicodeString; Mode: TVTNodeAttachMode); - function FindCPFormatDescription(CPFormat: Word): string; - procedure InsertData(Sender: TVirtualStringTree; DataObject: IDataObject; Formats: TFormatArray; Effect: Integer; - Mode: TVTNodeAttachMode); - end; - -var - MainForm: TMainForm; - -//---------------------------------------------------------------------------------------------------------------------- - -implementation - -uses - TypInfo, ShlObj, UrlMon, VirtualTrees.ClipBoard; - -{$R *.DFM} -{$R Res\Extra.res} // Contains a little rich text for the rich edit control and a XP manifest. - -type - PNodeData = ^TNodeData; - TNodeData = record - Caption: UnicodeString; - end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TMainForm.Button1Click(Sender: TObject); - -begin - Close; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TMainForm.CutActionExecute(Sender: TObject); - -begin - if ActiveControl = Tree1 then - Tree1.CutToClipboard - else - if ActiveControl = Tree2 then - Tree2.CutToClipboard - else - if ActiveControl = RichEdit1 then - RichEdit1.CutToClipboard; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TMainForm.CopyActionExecute(Sender: TObject); - -begin - if ActiveControl = Tree1 then - Tree1.CopyToClipboard - else - if ActiveControl = Tree2 then - Tree2.CopyToClipboard - else - if ActiveControl = RichEdit1 then - RichEdit1.CopyToClipboard; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TMainForm.PasteActionExecute(Sender: TObject); - -var - DataObject: IDataObject; - EnumFormat: IEnumFormatEtc; - Format: TFormatEtc; - Formats: TFormatArray; - Fetched: Integer; - Tree: TVirtualStringTree; - -begin - if ActiveControl is TVirtualStringTree then - begin - Tree := ActiveControl as TVirtualStringTree; - - if LogListBox.Items.Count > 0 then - LogListBox.Items.Add(''); - if ActiveControl = Tree1 then - LogListBox.Items.Add('----- Tree 1') - else - LogListBox.Items.Add('----- Tree 2'); - - if Tree.PasteFromClipboard then - LogListBox.Items.Add('Native tree data pasted.') - else - begin - LogListBox.Items.Add('Other data pasted.'); - // Some other data was pasted. Enumerate the available formats and try to add the data. - // 1) Get a data object for the data. - OLEGetClipboard(DataObject); - // 2) Enumerate all offered formats and create a format array from it which can be used in InsertData. - if Succeeded(DataObject.EnumFormatEtc(DATADIR_GET, EnumFormat)) then - begin - EnumFormat.Reset; - while EnumFormat.Next(1, Format, @Fetched) = S_OK do - begin - SetLength(Formats, Length(Formats) + 1); - Formats[High(Formats)] := Format.cfFormat; - end; - - InsertData(Tree, DataObject, Formats, DROPEFFECT_COPY, Tree.DefaultPasteMode); - end; - end; - end - else - if ActiveControl = RichEdit1 then - RichEdit1.PasteFromClipboard; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TMainForm.Tree1GetText(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; TextType: TVSTTextType; - var CellText: string); - -var - Data: PNodeData; - -begin - if TextType = ttNormal then - begin - Data := Sender.GetNodeData(Node); - CellText := Data.Caption; - end - else - Text := ''; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TMainForm.FormCreate(Sender: TObject); - -var - Stream: TResourceStream; - -begin - Tree1.NodeDataSize := SizeOf(TNodeData); - Tree1.RootNodeCount := 30; - Tree2.NodeDataSize := SizeOf(TNodeData); - Tree2.RootNodeCount := 30; - - ReportMemoryLeaksOnShutdown := True; - // There is a small RTF text stored in the resource to have something to display in the rich edit control. - Stream := TResourceStream.Create(HInstance, 'RTF', 'RCDATA'); - try - RichEdit1.Lines.LoadFromStream(Stream); - finally - Stream.Free; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TMainForm.AddUnicodeText(DataObject: IDataObject; Target: TVirtualStringTree; Mode: TVTNodeAttachMode); - -// This method is called when the drop handler gets called with Unicode text as only -// understandable clipboard format. This text is retrieved and splitted in lines. -// Every line is then added as new node. - -var - FormatEtc: TFormatEtc; - Medium: TStgMedium; - OLEData, - Head, Tail: PWideChar; - TargetNode, - Node: PVirtualNode; - Data: PNodeData; - -begin - if Mode <> amNowhere then - begin - // fill the structure used to get the Unicode string - with FormatEtc do - begin - cfFormat := CF_UNICODETEXT; - // no specific target device - ptd := nil; - // normal content to render - dwAspect := DVASPECT_CONTENT; - // no specific page of multipage data - lindex := -1; - // pass the data via memory - tymed := TYMED_HGLOBAL; - end; - - // Check if we can get the Unicode text data. - if DataObject.QueryGetData(FormatEtc) = S_OK then - begin - // Data is accessible so finally get a pointer to it - if DataObject.GetData(FormatEtc, Medium) = S_OK then - begin - OLEData := GlobalLock(Medium.hGlobal); - if Assigned(OLEData) then - begin - Target.BeginUpdate; - TargetNode := Target.DropTargetNode; - if TargetNode = nil then - TargetNode := Target.FocusedNode; - - Head := OLEData; - try - while Head^ <> #0 do - begin - Tail := Head; - while not CharInSet(Tail^, [WideChar(#0), WideChar(#13), WideChar(#10), WideChar(#9)]) do - Inc(Tail); - if Head <> Tail then - begin - // add a new node if we got a non-empty caption - Node := Target.InsertNode(TargetNode, Mode); - Data := Target.GetNodeData(Node); - SetString(Data.Caption, Head, Tail - Head); - end; - // Skip any tab. - if Tail^ = #9 then - Inc(Tail); - // skip line separators - if Tail^ = #13 then - Inc(Tail); - if Tail^ = #10 then - Inc(Tail); - Head := Tail; - end; - finally - GlobalUnlock(Medium.hGlobal); - Target.EndUpdate; - end; - end; - // never forget to free the storage medium - ReleaseStgMedium(Medium); - end; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TMainForm.AddVCLText(Target: TVirtualStringTree; const Text: UnicodeString; Mode: TVTNodeAttachMode); - -// This method is called when the drop handler gets called with a VCL drag source. -// The given text is retrieved and splitted in lines. - -var - Head, Tail: PWideChar; - TargetNode, - Node: PVirtualNode; - Data: PNodeData; - -begin - if Mode <> amNowhere then - begin - Target.BeginUpdate; - try - TargetNode := Target.DropTargetNode; - if TargetNode = nil then - TargetNode := Target.FocusedNode; - - Head := PWideChar(Text); - while Head^ <> #0 do - begin - Tail := Head; - while not CharInSet(Tail^, [WideChar(#0), WideChar(#13), WideChar(#10)]) do - Inc(Tail); - if Head <> Tail then - begin - // add a new node if we got a non-empty caption - Node := Target.InsertNode(TargetNode, Mode); - Data := Target.GetNodeData(Node); - SetString(Data.Caption, Head, Tail - Head); - end; - // skip line separators - if Tail^ = #13 then - Inc(Tail); - if Tail^ = #10 then - Inc(Tail); - Head := Tail; - end; - finally - Target.EndUpdate; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TMainForm.FindCPFormatDescription(CPFormat: Word): string; - -var - Buffer: array[0..2048] of Char; - -begin - // Try the formats support the by Virtual Treeview first. - Result := GetVTClipboardFormatDescription(CPFormat); - - // Retrieve additional formats from system. - if Length(Result) = 0 then - begin - if GetClipboardFormatName(CPFormat, @Buffer, 2048) > 0 then - Result := ' - ' + Buffer - else - Result := Format(' - unknown format (%d)', [CPFormat]); - end - else - Result := ' - ' + Result; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TMainForm.TreeDragDrop(Sender: TBaseVirtualTree; Source: TObject; DataObject: IDataObject; - Formats: TFormatArray; Shift: TShiftState; Pt: TPoint; var Effect: Integer; Mode: TDropMode); - - //--------------- local function -------------------------------------------- - - procedure DetermineEffect; - - // Determine the drop effect to use if the source is a Virtual Treeview. - - begin - // In the case the source is a Virtual Treeview we know 'move' is the default if dragging within - // the same tree and copy if dragging to another tree. Set Effect accordingly. - if Shift = [] then - begin - // No modifier key, so use standard action. - if Source = Sender then - Effect := DROPEFFECT_MOVE - else - Effect := DROPEFFECT_COPY; - end - else - begin - // A modifier key is pressed, hence use this to determine action. - if (Shift = [ssAlt]) or (Shift = [ssCtrl, ssAlt]) then - Effect := DROPEFFECT_LINK - else - if Shift = [ssCtrl] then - Effect := DROPEFFECT_COPY - else - Effect := DROPEFFECT_MOVE; - end; - end; - - //--------------- end local function ---------------------------------------- - -var - S: string; - Attachmode: TVTNodeAttachMode; - Nodes: TNodeArray; - I: Integer; - -begin - Nodes := nil; - - if LogListBox.Items.Count > 0 then - LogListBox.Items.Add(''); - if Sender = Tree1 then - LogListBox.Items.Add('----- Tree 1') - else - LogListBox.Items.Add('----- Tree 2'); - - if DataObject = nil then - LogListBox.Items.Add('VCL drop arrived') - else - LogListBox.Items.Add('OLE drop arrived'); - - S := 'Drop actions allowed:'; - if Boolean(DROPEFFECT_COPY and Effect) then - S := S + ' copy'; - if Boolean(DROPEFFECT_MOVE and Effect) then - S := S + ' move'; - if Boolean(DROPEFFECT_LINK and Effect) then - S := S + ' link'; - LogListBox.Items.Add(S); - - S := 'Drop mode: ' + GetEnumName(TypeInfo(TDropMode), Ord(Mode)); - LogListBox.Items.Add(S); - - // Translate the drop position into an node attach mode. - case Mode of - dmAbove: - AttachMode := amInsertBefore; - dmOnNode: - AttachMode := amAddChildLast; - dmBelow: - AttachMode := amInsertAfter; - else - AttachMode := amNowhere; - end; - - if DataObject = nil then - begin - // VCL drag'n drop. Handling this requires detailed knowledge about the sender and its data. This is one reason - // why it was a bad decision by Borland to implement something own instead using the system's way. - // In this demo we have two known sources of VCL dd data: Tree2 and LogListBox. - if Source = Tree2 then - begin - // Since we know this is a Virtual Treeview we can ignore the drop event entirely and use VT mechanisms. - DetermineEffect; - Nodes := Tree2.GetSortedSelection(True); - if Effect = DROPEFFECT_COPY then - begin - for I := 0 to High(Nodes) do - Tree2.CopyTo(Nodes[I], Sender.DropTargetNode, AttachMode, False); - end - else - for I := 0 to High(Nodes) do - Tree2.MoveTo(Nodes[I], Sender.DropTargetNode, AttachMode, False); - end - else - begin - // One long string (one node) is added, containing all text currently in the list box. - AddVCLText(Sender as TVirtualStringTree, LogListBox.Items.CommaText, AttachMode); - LogListBox.Items.Add('List box data accepted as string.'); - end; - end - else - begin - // OLE drag'n drop. Perform full processing. - - LogListBox.Items.Add('There are ' + IntToStr(Length(Formats)) + ' formats available:'); - - // Determine action in advance even if we don't use the dropped data. - // Note: The Effect parameter is a variable which must be set to the action we - // will actually take, to notify the sender of the drag operation about remaining actions. - // This value determines what the caller will do after the method returns, - // e.g. if DROPEFFECT_MOVE is returned then the source data will be deleted. - if Source is TBaseVirtualTree then - begin - DetermineEffect; - end - else - // Prefer copy if allowed for every other drag source. Alone from Effect you cannot determine the standard action - // of the sender, but we assume if copy is allowed then it is also the standard action - // (e.g. as in TRichEdit). - if Boolean(Effect and DROPEFFECT_COPY) then - Effect := DROPEFFECT_COPY - else - Effect := DROPEFFECT_MOVE; - - InsertData(Sender as TVirtualStringTree, DataObject, Formats, Effect, AttachMode); - end; - - // scroll last added entry into view - LogListBox.ItemIndex := LogListBox.Items.Count - 1; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TMainForm.Button2Click(Sender: TObject); - -begin - LogListBox.Clear; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TMainForm.TreeInitNode(Sender: TBaseVirtualTree; ParentNode, Node: PVirtualNode; - var InitialStates: TVirtualNodeInitStates); - -var - Data: PNodeData; - -begin - Data := Sender.GetNodeData(Node); - // set a generic caption only if there is not already one (e.g. from drag operations) - if Length(Data.Caption) = 0 then - Data.Caption := Format('Node Index %d', [Node.Index]); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TMainForm.Tree1NewText(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; NewText: string); - -var - Data: PNodeData; - -// Tree1 as well as Tree2 use the soSaveCaptions StringOption which enables automatic caption store action -// when tree data is serialized into memory (e.g. for drag'n drop). Restoring the caption is done by triggering -// this event for each loaded node. -// This mechanism frees us from implementing a SaveNode and LoadNode event since we have only the caption to store. - -begin - Data := Sender.GetNodeData(Node); - Data.Caption := NewText; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TMainForm.Button3Click(Sender: TObject); - -begin - with FontDialog do - begin - Font := Tree1.Font; - if Execute then - begin - Tree1.Font := Font; - Tree2.Font := Font; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TMainForm.Tree2DragAllowed(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; var Allowed: Boolean); - -// Tree 2 uses manual drag start to tell which node might be dragged. - -begin - Allowed := Odd(Node.Index); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TMainForm.TreeDragOver(Sender: TBaseVirtualTree; Source: TObject; Shift: TShiftState; State: TDragState; - Pt: TPoint; Mode: TDropMode; var Effect: Integer; var Accept: Boolean); - -begin - Accept := True; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TMainForm.Tree2BeforeItemErase(Sender: TBaseVirtualTree; Canvas: TCanvas; Node: PVirtualNode; ItemRect: TRect; - var ItemColor: TColor; var EraseAction: TItemEraseAction); - -// The second tree uses manual drag and we want to show the lines which are allowed to start a drag operation by -// a colored background. - -begin - if Odd(Node.Index) then - begin - ItemColor := $FFEEEE; - EraseAction := eaColor; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TMainForm.InsertData(Sender: TVirtualStringTree; DataObject: IDataObject; Formats: TFormatArray; - Effect: Integer; Mode: TVTNodeAttachMode); - -var - FormatAccepted: Boolean; - I: Integer; - -begin - // Go through each available format and see if we can make sense of it. - FormatAccepted := False; - for I := 0 to High(Formats) do - begin - case Formats[I] of - // standard clipboard formats - CF_UNICODETEXT: - begin - LogListBox.Items.Add(' - Unicode text'); - - // As demonstration for non-tree data here an implementation for Unicode text. - // Formats are placed in preferred order in the formats parameter. Hence if - // there is native tree data involved in this drop operation then it has been - // caught earlier in the loop and FormatAccepted is already True. - if not FormatAccepted then - begin - // Unicode text data was dropped (e.g. from RichEdit1) add this line by line - // as new nodes. - AddUnicodeText(DataObject, Sender as TVirtualStringTree, Mode); - LogListBox.Items.Add('+ Unicode accepted'); - FormatAccepted := True; - end; - end; - else - if Formats[I] = CF_VIRTUALTREE then - begin - // this is our native tree format - LogListBox.Items.Add(' - native Virtual Treeview data'); - - if not FormatAccepted then - begin - Sender.ProcessDrop(DataObject, Sender.DropTargetNode, Effect, Mode); - LogListBox.Items.Add('+ native Virtual Treeview data accepted'); - // Indicate that we found a format we accepted so the data is not used twice. - FormatAccepted := True; - end; - end - else - if Formats[I] = CF_VTREFERENCE then - LogListBox.Items.Add(' - Virtual Treeview reference') - else - begin - // Predefined, shell specific, MIME specific or application specific clipboard data. - LogListBox.Items.Add(FindCPFormatDescription(Formats[I])); - end; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -end. - - - - - - +unit Main; + +// Virtual Treeview sample application demonstrating clipboard and drag'n drop operations. +// The treeview uses OLE for these operations but can also issue and accept VCL drag'n drop. +// Written by Mike Lischke. + +interface + +uses + Winapi.Windows, Winapi.Messages, Winapi.ActiveX, System.SysUtils, Vcl.Forms, + Vcl.Dialogs, Vcl.Graphics, VirtualTrees, Vcl.ActnList, Vcl.ComCtrls, + Vcl.ExtCtrls, Vcl.StdCtrls, Vcl.Controls, System.Classes, Vcl.ImgList, + System.Actions, System.ImageList, VirtualTrees.BaseAncestorVCL, + VirtualTrees.BaseTree, VirtualTrees.AncestorVCL, VirtualTrees.Types; + +type + TMainForm = class(TForm) + ActionList1: TActionList; + CutAction: TAction; + CopyAction: TAction; + PasteAction: TAction; + FontDialog: TFontDialog; + Panel3: TPanel; + Label6: TLabel; + Button1: TButton; + Button3: TButton; + Tree2: TVirtualStringTree; + Label1: TLabel; + Tree1: TVirtualStringTree; + Label2: TLabel; + PageControl1: TPageControl; + LogTabSheet: TTabSheet; + RichTextTabSheet: TTabSheet; + LogListBox: TListBox; + RichEdit1: TRichEdit; + Label3: TLabel; + Label7: TLabel; + Button2: TButton; + TabSheet1: TTabSheet; + Label8: TLabel; + TabSheet2: TTabSheet; + Label4: TLabel; + Label5: TLabel; + Label9: TLabel; + Label10: TLabel; + TreeImages: TImageList; + procedure Button1Click(Sender: TObject); + procedure CutActionExecute(Sender: TObject); + procedure CopyActionExecute(Sender: TObject); + procedure PasteActionExecute(Sender: TObject); + procedure Tree1GetText(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; TextType: TVSTTextType; + var CellText: string); + procedure FormCreate(Sender: TObject); + procedure TreeDragDrop(Sender: TBaseVirtualTree; Source: TObject; DataObject: TVTDragDataObject; + Formats: TFormatArray; Shift: TShiftState; Pt: TPoint; var Effect: Integer; Mode: TDropMode); + procedure Button2Click(Sender: TObject); + procedure TreeInitNode(Sender: TBaseVirtualTree; ParentNode, Node: PVirtualNode; + var InitialStates: TVirtualNodeInitStates); + procedure TreeFreeNode(Sender: TBaseVirtualTree; Node: PVirtualNode); + procedure Tree1NewText(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; NewText: string); + procedure Button3Click(Sender: TObject); + procedure Tree2DragAllowed(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; var Allowed: Boolean); + procedure TreeDragOver(Sender: TBaseVirtualTree; Source: TObject; Shift: TShiftState; State: TDragState; + Pt: TPoint; Mode: TDropMode; var Effect: Integer; var Accept: Boolean); + procedure Tree2BeforeItemErase(Sender: TBaseVirtualTree; Canvas: TCanvas; Node: PVirtualNode; ItemRect: TRect; + var ItemColor: TColor; var EraseAction: TItemEraseAction); + private + procedure AddUnicodeText(DataObject: IDataObject; Target: TVirtualStringTree; Mode: TVTNodeAttachMode); + procedure AddVCLText(Target: TVirtualStringTree; const Text: UnicodeString; Mode: TVTNodeAttachMode); + function FindCPFormatDescription(CPFormat: Word): string; + procedure InsertData(Sender: TVirtualStringTree; DataObject: IDataObject; Formats: TFormatArray; Effect: Integer; + Mode: TVTNodeAttachMode); + end; + +var + MainForm: TMainForm; + +//---------------------------------------------------------------------------------------------------------------------- + +implementation + +uses + TypInfo, ShlObj, UrlMon, VirtualTrees.ClipBoard; + +{$R *.DFM} +{$R Res\Extra.res} // Contains a little rich text for the rich edit control and a XP manifest. + +type + PNodeData = ^TNodeData; + TNodeData = record + Caption: UnicodeString; + end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TMainForm.Button1Click(Sender: TObject); + +begin + Close; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TMainForm.CutActionExecute(Sender: TObject); + +begin + if ActiveControl = Tree1 then + Tree1.CutToClipboard + else + if ActiveControl = Tree2 then + Tree2.CutToClipboard + else + if ActiveControl = RichEdit1 then + RichEdit1.CutToClipboard; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TMainForm.CopyActionExecute(Sender: TObject); + +begin + if ActiveControl = Tree1 then + Tree1.CopyToClipboard + else + if ActiveControl = Tree2 then + Tree2.CopyToClipboard + else + if ActiveControl = RichEdit1 then + RichEdit1.CopyToClipboard; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TMainForm.PasteActionExecute(Sender: TObject); + +var + DataObject: IDataObject; + EnumFormat: IEnumFormatEtc; + Format: TFormatEtc; + Formats: TFormatArray; + Fetched: Integer; + Tree: TVirtualStringTree; + +begin + if ActiveControl is TVirtualStringTree then + begin + Tree := ActiveControl as TVirtualStringTree; + + if LogListBox.Items.Count > 0 then + LogListBox.Items.Add(''); + if ActiveControl = Tree1 then + LogListBox.Items.Add('----- Tree 1') + else + LogListBox.Items.Add('----- Tree 2'); + + if Tree.PasteFromClipboard then + LogListBox.Items.Add('Native tree data pasted.') + else + begin + LogListBox.Items.Add('Other data pasted.'); + // Some other data was pasted. Enumerate the available formats and try to add the data. + // 1) Get a data object for the data. + OLEGetClipboard(DataObject); + // 2) Enumerate all offered formats and create a format array from it which can be used in InsertData. + if Succeeded(DataObject.EnumFormatEtc(DATADIR_GET, EnumFormat)) then + begin + EnumFormat.Reset; + while EnumFormat.Next(1, Format, @Fetched) = S_OK do + begin + SetLength(Formats, Length(Formats) + 1); + Formats[High(Formats)] := Format.cfFormat; + end; + + InsertData(Tree, DataObject, Formats, DROPEFFECT_COPY, Tree.DefaultPasteMode); + end; + end; + end + else + if ActiveControl = RichEdit1 then + RichEdit1.PasteFromClipboard; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TMainForm.Tree1GetText(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; TextType: TVSTTextType; + var CellText: string); + +var + Data: PNodeData; + +begin + if TextType = ttNormal then + begin + Data := Sender.GetNodeData(Node); + CellText := Data.Caption; + end + else + Text := ''; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TMainForm.FormCreate(Sender: TObject); + +var + Stream: TResourceStream; + +begin + Tree1.NodeDataSize := SizeOf(TNodeData); + Tree1.RootNodeCount := 30; + Tree2.NodeDataSize := SizeOf(TNodeData); + Tree2.RootNodeCount := 30; + + ReportMemoryLeaksOnShutdown := True; + // There is a small RTF text stored in the resource to have something to display in the rich edit control. + Stream := TResourceStream.Create(HInstance, 'RTF', 'RCDATA'); + try + RichEdit1.Lines.LoadFromStream(Stream); + finally + Stream.Free; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TMainForm.AddUnicodeText(DataObject: IDataObject; Target: TVirtualStringTree; Mode: TVTNodeAttachMode); + +// This method is called when the drop handler gets called with Unicode text as only +// understandable clipboard format. This text is retrieved and splitted in lines. +// Every line is then added as new node. + +var + FormatEtc: TFormatEtc; + Medium: TStgMedium; + OLEData, + Head, Tail: PWideChar; + TargetNode, + Node: PVirtualNode; + Data: PNodeData; + +begin + if Mode <> amNowhere then + begin + // fill the structure used to get the Unicode string + with FormatEtc do + begin + cfFormat := CF_UNICODETEXT; + // no specific target device + ptd := nil; + // normal content to render + dwAspect := DVASPECT_CONTENT; + // no specific page of multipage data + lindex := -1; + // pass the data via memory + tymed := TYMED_HGLOBAL; + end; + + // Check if we can get the Unicode text data. + if DataObject.QueryGetData(FormatEtc) = S_OK then + begin + // Data is accessible so finally get a pointer to it + if DataObject.GetData(FormatEtc, Medium) = S_OK then + begin + OLEData := GlobalLock(Medium.hGlobal); + if Assigned(OLEData) then + begin + Target.BeginUpdate; + TargetNode := Target.DropTargetNode; + if TargetNode = nil then + TargetNode := Target.FocusedNode; + + Head := OLEData; + try + while Head^ <> #0 do + begin + Tail := Head; + while not CharInSet(Tail^, [WideChar(#0), WideChar(#13), WideChar(#10), WideChar(#9)]) do + Inc(Tail); + if Head <> Tail then + begin + // add a new node if we got a non-empty caption + Node := Target.InsertNode(TargetNode, Mode); + Data := Target.GetNodeData(Node); + SetString(Data.Caption, Head, Tail - Head); + end; + // Skip any tab. + if Tail^ = #9 then + Inc(Tail); + // skip line separators + if Tail^ = #13 then + Inc(Tail); + if Tail^ = #10 then + Inc(Tail); + Head := Tail; + end; + finally + GlobalUnlock(Medium.hGlobal); + Target.EndUpdate; + end; + end; + // never forget to free the storage medium + ReleaseStgMedium(Medium); + end; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TMainForm.AddVCLText(Target: TVirtualStringTree; const Text: UnicodeString; Mode: TVTNodeAttachMode); + +// This method is called when the drop handler gets called with a VCL drag source. +// The given text is retrieved and splitted in lines. + +var + Head, Tail: PWideChar; + TargetNode, + Node: PVirtualNode; + Data: PNodeData; + +begin + if Mode <> amNowhere then + begin + Target.BeginUpdate; + try + TargetNode := Target.DropTargetNode; + if TargetNode = nil then + TargetNode := Target.FocusedNode; + + Head := PWideChar(Text); + while Head^ <> #0 do + begin + Tail := Head; + while not CharInSet(Tail^, [WideChar(#0), WideChar(#13), WideChar(#10)]) do + Inc(Tail); + if Head <> Tail then + begin + // add a new node if we got a non-empty caption + Node := Target.InsertNode(TargetNode, Mode); + Data := Target.GetNodeData(Node); + SetString(Data.Caption, Head, Tail - Head); + end; + // skip line separators + if Tail^ = #13 then + Inc(Tail); + if Tail^ = #10 then + Inc(Tail); + Head := Tail; + end; + finally + Target.EndUpdate; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TMainForm.FindCPFormatDescription(CPFormat: Word): string; + +var + Buffer: array[0..2048] of Char; + +begin + // Try the formats support the by Virtual Treeview first. + Result := GetVTClipboardFormatDescription(CPFormat); + + // Retrieve additional formats from system. + if Length(Result) = 0 then + begin + if GetClipboardFormatName(CPFormat, @Buffer, 2048) > 0 then + Result := ' - ' + Buffer + else + Result := Format(' - unknown format (%d)', [CPFormat]); + end + else + Result := ' - ' + Result; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TMainForm.TreeDragDrop(Sender: TBaseVirtualTree; Source: TObject; DataObject: TVTDragDataObject; + Formats: TFormatArray; Shift: TShiftState; Pt: TPoint; var Effect: Integer; Mode: TDropMode); + + //--------------- local function -------------------------------------------- + + procedure DetermineEffect; + + // Determine the drop effect to use if the source is a Virtual Treeview. + + begin + // In the case the source is a Virtual Treeview we know 'move' is the default if dragging within + // the same tree and copy if dragging to another tree. Set Effect accordingly. + if Shift = [] then + begin + // No modifier key, so use standard action. + if Source = Sender then + Effect := DROPEFFECT_MOVE + else + Effect := DROPEFFECT_COPY; + end + else + begin + // A modifier key is pressed, hence use this to determine action. + if (Shift = [ssAlt]) or (Shift = [ssCtrl, ssAlt]) then + Effect := DROPEFFECT_LINK + else + if Shift = [ssCtrl] then + Effect := DROPEFFECT_COPY + else + Effect := DROPEFFECT_MOVE; + end; + end; + + //--------------- end local function ---------------------------------------- + +var + S: string; + Attachmode: TVTNodeAttachMode; + Nodes: TNodeArray; + I: Integer; + +begin + Nodes := nil; + + if LogListBox.Items.Count > 0 then + LogListBox.Items.Add(''); + if Sender = Tree1 then + LogListBox.Items.Add('----- Tree 1') + else + LogListBox.Items.Add('----- Tree 2'); + + if DataObject = nil then + LogListBox.Items.Add('VCL drop arrived') + else + LogListBox.Items.Add('OLE drop arrived'); + + S := 'Drop actions allowed:'; + if Boolean(DROPEFFECT_COPY and Effect) then + S := S + ' copy'; + if Boolean(DROPEFFECT_MOVE and Effect) then + S := S + ' move'; + if Boolean(DROPEFFECT_LINK and Effect) then + S := S + ' link'; + LogListBox.Items.Add(S); + + S := 'Drop mode: ' + GetEnumName(TypeInfo(TDropMode), Ord(Mode)); + LogListBox.Items.Add(S); + + // Translate the drop position into an node attach mode. + case Mode of + dmAbove: + AttachMode := amInsertBefore; + dmOnNode: + AttachMode := amAddChildLast; + dmBelow: + AttachMode := amInsertAfter; + else + AttachMode := amNowhere; + end; + + if DataObject = nil then + begin + // VCL drag'n drop. Handling this requires detailed knowledge about the sender and its data. This is one reason + // why it was a bad decision by Borland to implement something own instead using the system's way. + // In this demo we have two known sources of VCL dd data: Tree2 and LogListBox. + if Source = Tree2 then + begin + // Since we know this is a Virtual Treeview we can ignore the drop event entirely and use VT mechanisms. + DetermineEffect; + Nodes := Tree2.GetSortedSelection(True); + if Effect = DROPEFFECT_COPY then + begin + for I := 0 to High(Nodes) do + Tree2.CopyTo(Nodes[I], Sender.DropTargetNode, AttachMode, False); + end + else + for I := 0 to High(Nodes) do + Tree2.MoveTo(Nodes[I], Sender.DropTargetNode, AttachMode, False); + end + else + begin + // One long string (one node) is added, containing all text currently in the list box. + AddVCLText(Sender as TVirtualStringTree, LogListBox.Items.CommaText, AttachMode); + LogListBox.Items.Add('List box data accepted as string.'); + end; + end + else + begin + // OLE drag'n drop. Perform full processing. + + LogListBox.Items.Add('There are ' + IntToStr(Length(Formats)) + ' formats available:'); + + // Determine action in advance even if we don't use the dropped data. + // Note: The Effect parameter is a variable which must be set to the action we + // will actually take, to notify the sender of the drag operation about remaining actions. + // This value determines what the caller will do after the method returns, + // e.g. if DROPEFFECT_MOVE is returned then the source data will be deleted. + if Source is TBaseVirtualTree then + begin + DetermineEffect; + end + else + // Prefer copy if allowed for every other drag source. Alone from Effect you cannot determine the standard action + // of the sender, but we assume if copy is allowed then it is also the standard action + // (e.g. as in TRichEdit). + if Boolean(Effect and DROPEFFECT_COPY) then + Effect := DROPEFFECT_COPY + else + Effect := DROPEFFECT_MOVE; + + InsertData(Sender as TVirtualStringTree, DataObject, Formats, Effect, AttachMode); + end; + + // scroll last added entry into view + LogListBox.ItemIndex := LogListBox.Items.Count - 1; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TMainForm.Button2Click(Sender: TObject); + +begin + LogListBox.Clear; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TMainForm.TreeInitNode(Sender: TBaseVirtualTree; ParentNode, Node: PVirtualNode; + var InitialStates: TVirtualNodeInitStates); + +var + Data: PNodeData; + +begin + Data := Sender.GetNodeData(Node); + // set a generic caption only if there is not already one (e.g. from drag operations) + if Length(Data.Caption) = 0 then + Data.Caption := Format('Node Index %d', [Node.Index]); +end; + +//---------------------------------------------------------------------------------------------------------------------- +procedure TMainForm.TreeFreeNode(Sender: TBaseVirtualTree; Node: PVirtualNode); + +var + Data: PNodeData; + +begin + Data := Sender.GetNodeData(Node); + Data.Caption := ''; // Removes the caption, otherwise, memory leak. +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TMainForm.Tree1NewText(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; NewText: string); + +var + Data: PNodeData; + +// Tree1 as well as Tree2 use the soSaveCaptions StringOption which enables automatic caption store action +// when tree data is serialized into memory (e.g. for drag'n drop). Restoring the caption is done by triggering +// this event for each loaded node. +// This mechanism frees us from implementing a SaveNode and LoadNode event since we have only the caption to store. + +begin + Data := Sender.GetNodeData(Node); + Data.Caption := NewText; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TMainForm.Button3Click(Sender: TObject); + +begin + with FontDialog do + begin + Font := Tree1.Font; + if Execute then + begin + Tree1.Font := Font; + Tree2.Font := Font; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TMainForm.Tree2DragAllowed(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; var Allowed: Boolean); + +// Tree 2 uses manual drag start to tell which node might be dragged. + +begin + Allowed := Odd(Node.Index); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TMainForm.TreeDragOver(Sender: TBaseVirtualTree; Source: TObject; Shift: TShiftState; State: TDragState; + Pt: TPoint; Mode: TDropMode; var Effect: Integer; var Accept: Boolean); + +begin + Accept := True; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TMainForm.Tree2BeforeItemErase(Sender: TBaseVirtualTree; Canvas: TCanvas; Node: PVirtualNode; ItemRect: TRect; + var ItemColor: TColor; var EraseAction: TItemEraseAction); + +// The second tree uses manual drag and we want to show the lines which are allowed to start a drag operation by +// a colored background. + +begin + if Odd(Node.Index) then + begin + ItemColor := $FFEEEE; + EraseAction := eaColor; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TMainForm.InsertData(Sender: TVirtualStringTree; DataObject: IDataObject; Formats: TFormatArray; + Effect: Integer; Mode: TVTNodeAttachMode); + +var + FormatAccepted: Boolean; + I: Integer; + +begin + // Go through each available format and see if we can make sense of it. + FormatAccepted := False; + for I := 0 to High(Formats) do + begin + case Formats[I] of + // standard clipboard formats + CF_UNICODETEXT: + begin + LogListBox.Items.Add(' - Unicode text'); + + // As demonstration for non-tree data here an implementation for Unicode text. + // Formats are placed in preferred order in the formats parameter. Hence if + // there is native tree data involved in this drop operation then it has been + // caught earlier in the loop and FormatAccepted is already True. + if not FormatAccepted then + begin + // Unicode text data was dropped (e.g. from RichEdit1) add this line by line + // as new nodes. + AddUnicodeText(DataObject, Sender as TVirtualStringTree, Mode); + LogListBox.Items.Add('+ Unicode accepted'); + FormatAccepted := True; + end; + end; + else + if Formats[I] = CF_VIRTUALTREE then + begin + // this is our native tree format + LogListBox.Items.Add(' - native Virtual Treeview data'); + + if not FormatAccepted then + begin + Sender.ProcessDrop(DataObject, Sender.DropTargetNode, Effect, Mode); + LogListBox.Items.Add('+ native Virtual Treeview data accepted'); + // Indicate that we found a format we accepted so the data is not used twice. + FormatAccepted := True; + end; + end + else + if Formats[I] = CF_VTREFERENCE then + LogListBox.Items.Add(' - Virtual Treeview reference') + else + begin + // Predefined, shell specific, MIME specific or application specific clipboard data. + LogListBox.Items.Add(FindCPFormatDescription(Formats[I])); + end; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +end. + + + + + + diff --git a/Demos/OLE/OLE.dproj b/Demos/OLE/OLE.dproj index 772b60813..4c19b5e52 100644 --- a/Demos/OLE/OLE.dproj +++ b/Demos/OLE/OLE.dproj @@ -7,7 +7,7 @@ OLE.dpr Win32 {3C00F0E3-8F50-46FC-A49D-A7B9DC7DF0A7} - 20.2 + 20.3 1 OLE diff --git a/Demos/Objects/MVCDemo.dproj b/Demos/Objects/MVCDemo.dproj index 67c3b91a3..2bfa17f9e 100644 --- a/Demos/Objects/MVCDemo.dproj +++ b/Demos/Objects/MVCDemo.dproj @@ -4,10 +4,10 @@ MVCDemo.dpr True Debug - 1 + 3 Application VCL - 20.2 + 20.3 Win32 MVCDemo @@ -40,6 +40,12 @@ true true + + true + Cfg_2 + true + true + 1 false @@ -83,6 +89,12 @@ Debug + + Debug + $(BDS)\bin\delphi_PROJECTICON.ico + $(BDS)\bin\default_app.manifest + PerMonitorV2 + MainSource @@ -138,10 +150,14 @@ 1.0.0.0 + + Microsoft Office 2000 Sample Automation Server Wrapper Components + Microsoft Office XP Sample Automation Server Wrapper Components + True - False + True 12 diff --git a/Design/VirtualTreesReg.pas b/Design/VirtualTreesReg.pas index 1eca78714..af421246d 100644 --- a/Design/VirtualTreesReg.pas +++ b/Design/VirtualTreesReg.pas @@ -1,403 +1,523 @@ -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 - DesignEditors; - -type - TVirtualTreeEditor = class (TDefaultEditor) - public - procedure Edit; override; - end; - -procedure Register; - -//---------------------------------------------------------------------------------------------------------------------- - -implementation - -uses - WinApi.Windows, WinApi.CommCtrl, - System.TypInfo, System.SysUtils, System.Classes, - StrEdit,DesignIntf, VCLEditors, PropertyCategories, ColnEdit, - Vcl.Dialogs, Vcl.Graphics, Vcl.ImgList, Vcl.Controls, - VirtualTrees.ClipBoard, VirtualTrees.Actions, VirtualTrees, VirtualTrees.DrawTree, - VirtualTrees.HeaderPopup, VirtualTrees.BaseTree; - -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 + DesignEditors; + +type + TVirtualTreeEditor = class (TDefaultEditor) + public + procedure Edit; override; + end; + +procedure Register; + +//---------------------------------------------------------------------------------------------------------------------- + +implementation + +uses + WinApi.Windows, WinApi.CommCtrl, + System.TypInfo, System.SysUtils, System.Classes, + StrEdit,DesignIntf, VCLEditors, PropertyCategories, ColnEdit, + Vcl.Dialogs, Vcl.Graphics, Vcl.ImgList, Vcl.Controls, + VirtualTrees.ClipBoard, VirtualTrees.Actions, VirtualTrees, VirtualTrees.DrawTree, + VirtualTrees.HeaderPopup, VirtualTrees.BaseTree; + +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; + + TColumnOptionsProperty = class(VCLEditors.TSetProperty) + public + procedure GetProperties(Proc: TGetPropProc); override; + function GetValue: string; override; + end; + + TVTColumnOptionsElementsProperty = class(VCLEditors.TSetElementProperty, + ICustomPropertyMessage + ) + private + FBit: TBit; + FPropList: TArray; + protected + constructor Create(Parent: TPropertyEditor; AElement: Integer); reintroduce; + procedure UpdateOrdValue; + public + // ICustomPropertyMessage + procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer; + InNameRect: Boolean; const ItemRect: TRect; var Handled: 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 TColumnOptionsProperty.GetProperties(Proc: TGetPropProc); +var + I: integer; + E: IProperty; +begin + with GetTypeData(GetTypeData(GetPropType)^.CompType^)^ do + begin + for I := MinValue to MaxValue do + begin + E := TVTColumnOptionsElementsProperty.Create(Self, I); + Proc(E); + E := nil; + end; + end; +end; + +function TColumnOptionsProperty.GetValue: string; +var + I : integer; + S: TIntegerSet; +begin + Integer(S) := GetOrdValue; + Result := ''; + for I := 0 to SizeOf(Integer) * 8 - 1 do + if I in S then + Result := Result + GetEnumName(TypeInfo(TVTColumnOption), I) + ','; + if Result.EndsWith(',') then + Delete(Result, Length(Result), 1); + Result := '[' + Result + ']'; +end; + +type + TPropertyEditorHack = class(TBasePropertyEditor) + protected + FDesigner: IDesigner; + FPropList: PInstPropList; + FPropCount: Integer; + end; + +constructor TVTColumnOptionsElementsProperty.Create(Parent: TPropertyEditor; AElement: Integer); +var + MinValue: integer; + I: Integer; +begin + inherited Create(Parent, AElement); + MinValue := GetTypeData(GetTypeData(GetPropType).CompType^).MinValue; + FBit := AElement - MinValue; + SetLength(FPropList, Parent.PropCount); + for I := 0 to High(FPropList) do + FPropList[I] := TPropertyEditorHack(Parent).FPropList^[I]; +end; + +procedure TVTColumnOptionsElementsProperty.UpdateOrdValue; +var + S: TIntegerSet; + I: Integer; +begin + // Changes only the specific bit in the set + for I := 0 to TPropertyEditorHack(Self).FPropCount - 1 do + begin + Integer(S) := GetOrdProp(FPropList[I].Instance, FPropList[I].PropInfo); + if FBit in S then + Exclude(S, FBit) + else + Include(S, FBit); + SetOrdProp(FPropList[I].Instance, FPropList[I].PropInfo, NativeInt(Integer(S))); + end; + Modified; +end; + +procedure TVTColumnOptionsElementsProperty.MouseUp(Button: TMouseButton; + Shift: TShiftState; X, Y: Integer; InNameRect: Boolean; const ItemRect: TRect; + var Handled: Boolean); +begin + Handled := False; + if paReadOnly in GetAttributes then + Exit; + if PtInRect(CBRect(ItemRect), Point(x,y)) then + begin + UpdateOrdValue; + Handled := True; + end; +end; + +// for sets, the VCLDesigner code always makes the property editor back to the +// standard set property editor: VclEditors.TSetProperty, so we need to make +// OUR set property's map to our editor implementation and not the standard +// set property editor. +function SetColumnOptionsPropertyMapper(Obj: TPersistent; PropInfo: PPropInfo): TPropertyEditorClass; +begin + Result := nil; + if Assigned(Obj) and (Obj.ClassType <> TVirtualTreeColumn) then + Exit; + if (PropInfo.PropType^.Kind = tkSet) and (PropInfo.PropType^ = TypeInfo(TVTColumnOptions)) then + Result := TColumnOptionsProperty; +end; + +//---------------------------------------------------------------------------------------------------------------------- +procedure Register; + +begin + RegisterComponents('Virtual Controls', [TVirtualStringTree, TVirtualDrawTree, TVTHeaderPopupMenu]); + RegisterPropertyMapper(SetColumnOptionsPropertyMapper); + 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/INSTALL.txt b/INSTALL.txt index 21ad1fe69..162fac3d9 100644 --- a/INSTALL.txt +++ b/INSTALL.txt @@ -6,7 +6,7 @@ Extract the entire(!) ZIP file and follow the instructions below. Delphi / RAD Studio 10.4 and higher Installation ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 1. Open the project group "Packages\RAD Studio 10.4+\VirtualTreeView.groupproj" -2. Right click on root elelment "VirtualTreeView" and click "Build All" +2. Right click on root element "VirtualTreeView" and click "Build All" 3. Right click on "VirtualTreesD*.bpl" and click "Install" 4. Go to "Tools > Options > Language > Delphi Options > Library 5. Choose platform "Win32", click on "Library Path > [...]" @@ -30,7 +30,7 @@ Delphi / RAD Studio 10.3 2. Right click on "VirtualTreesD270.bpl" and click "Install" 3. Go to "Tools > Options > Language > Delphi Options > Library > Library Path > [...]" Browse to the "Source" folder of VirtualTreeView, press "OK", "Add", "OK" - Do this for both Win32 and Win64 platform, which you can choose in the dropdown box. + Do this for both Win32 and Win64 platforms, which you can choose in the dropdown box. 4. C++ Builder users only: In the Options dialog go to "Environment Options > C++ Options > Paths and Directories" a) Click "Library Path > [...]" @@ -46,7 +46,7 @@ Delphi / RAD Studio 10.0 - 10.2 Installation 2. Right click on "VirtualTreesD*.bpl" and click "Install" 3. Go to "Tools > Options > Environment Options > Delphi Options > Library > Library Path > [...]" Browse to the "Source" folder of VirtualTreeView, press "OK", "Add", "OK" - Do this for both Win32 and Win64 platform, which you can choose in the dropdown box. + Do this for both Win32 and Win64 platforms, which you can choose in the dropdown box. 4. C++ Builder users only: In the Options dialog go to "Environment Options > C++ Options > Paths and Directories" a) Click "Library Path > [...]" diff --git a/Packages/CBuilder XE7/VirtualTreeView.groupproj b/Packages/CBuilder 12/VirtualTrees.groupproj similarity index 93% rename from Packages/CBuilder XE7/VirtualTreeView.groupproj rename to Packages/CBuilder 12/VirtualTrees.groupproj index d45ca9e06..6c0680676 100644 --- a/Packages/CBuilder XE7/VirtualTreeView.groupproj +++ b/Packages/CBuilder 12/VirtualTrees.groupproj @@ -1,6 +1,6 @@  - {90943296-FDFA-4C80-A99D-237F570C4F54} + {BF155D09-6AED-4790-9020-744D12876B35} diff --git a/Packages/CBuilder XE6/VirtualTreesCD.cbproj b/Packages/CBuilder 12/VirtualTreesCD.cbproj similarity index 52% rename from Packages/CBuilder XE6/VirtualTreesCD.cbproj rename to Packages/CBuilder 12/VirtualTreesCD.cbproj index e7a876bc4..35a254c21 100644 --- a/Packages/CBuilder XE6/VirtualTreesCD.cbproj +++ b/Packages/CBuilder 12/VirtualTreesCD.cbproj @@ -1,14 +1,16 @@  - {DE1FB54C-6852-4F59-B4A5-7718E6069FE8} - VirtualTreesCD.cpp - 15.4 - Release + {B6350E5E-13A2-44EC-8515-C119E896CB47} + 20.3 VCL + VirtualTreesCD.cpp True + Release Win32 - 1 + VirtualTreesCD + 1048579 Package + c true @@ -23,6 +25,11 @@ Base true + + true + Base + true + true Base @@ -34,6 +41,18 @@ true true + + true + Cfg_1 + true + true + + + true + Cfg_1 + true + true + true Base @@ -46,47 +65,53 @@ true - 200 - VirtualTree CBuilder designtime package - $(BDSCOMMONDIR)\hpp\$(Platform)\ - VirtualTreesCD - true - ..\..\Source;$(DCC_UnitSearchPath) - 4108 - System;Xml;Data;Datasnap;Web;Soap;Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;$(DCC_Namespace) - true - CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments= - 6 + true + true -LUDesignIDE true - bpl + .\Design\$(Platform)\$(Config) + false + true + true + $(BDSLIB)\$(PLATFORM)\release\$(LANGDIR);$(ILINK_TranslatedLibraryPath) CppPackage + System;Xml;Data;Datasnap;Web;Soap;Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;$(DCC_Namespace) true true + <_TCHARMapping>wchar_t true + VirtualTreesCD + 1033 + CompanyName=;FileDescription=$(MSBuildProjectName);FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProgramID=com.embarcadero.$(MSBuildProjectName);ProductName=$(MSBuildProjectName);ProductVersion=1.0.0.0;Comments= + VirtualTrees Designtime + ..\..\Source;$(DCC_UnitSearchPath) All - true - ..\..\Source\;..\..\Design\;$(BDS)\include;$(BDS)\include\windows;$(BDS)\include\windows\rtl;$(BDS)\include\windows\vcl;$(BDS)\include\windows\crtl;$(BDS)\include\windows\sdk;$(IncludePath) - ..\..\Design\;$(BDS)\lib;$(BDS)\lib\$(Platform)\$(Config);$(BDS)\lib\$(Platform)\release\psdk;..\..\Source;$(ILINK_LibraryPath) - false - true - true + true - true - $(BDS)\bin\default_app.manifest - 1033 Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace) + Debug + true + $(BDSINCLUDE)\windows\vcl;$(IncludePath) - 1033 Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;$(DCC_Namespace) + Debug + true + $(BDSINCLUDE)\windows\vcl;$(IncludePath) + + + Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;$(DCC_Namespace) + Debug + true + true false true false true + _DEBUG;$(Defines) false None DEBUG @@ -96,43 +121,56 @@ true Full true + true + true + true + true + $(BDSLIB)\$(PLATFORM)\debug;$(ILINK_LibraryPath) + $(BDSLIB)\$(PLATFORM)\debug\$(LANGDIR);$(ILINK_TranslatedLibraryPath) - _DEBUG;$(Defines) + false + $(BDSLIB)\$(PLATFORM)$(CC_SUFFIX)\debug;$(ILINK_LibraryPath) + true + VirtualTrees Designtime + + + true + + + true + NDEBUG;$(Defines) None - 1033 - NDEBUG;$(Defines) + false + true - 9 + {4AB7ABC9-E87D-4D9D-99AF-39363FDE2732} + 2 - - 10 - + 4 + + 5 1 - 4 + 3 0 - 9 + 12 - - Cfg_2 - Base - Base @@ -140,100 +178,38 @@ Cfg_1 Base + + Cfg_2 + Base + - CPlusPlusBuilder.Personality.12 CppPackage - - VirtualTreesCD.cpp - - - False - False - 1 - 0 - 0 - 0 - False - False - False - False - False - 4108 - 1252 - - - - - 1.0.0.0 - - - - - - 1.0.0.0 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - False - - - - - - - False - - False - - True - False - - False - True + False True - False + True + + VirtualTreesCD.cpp + + + + True - False + True + True 12 + + diff --git a/Packages/CBuilder XE7/VirtualTreesCD.cpp b/Packages/CBuilder 12/VirtualTreesCD.cpp similarity index 62% rename from Packages/CBuilder XE7/VirtualTreesCD.cpp rename to Packages/CBuilder 12/VirtualTreesCD.cpp index 37aacb559..4927fbe10 100644 --- a/Packages/CBuilder XE7/VirtualTreesCD.cpp +++ b/Packages/CBuilder 12/VirtualTreesCD.cpp @@ -1,6 +1,6 @@ //--------------------------------------------------------------------------- -#include +#include #pragma hdrstop #pragma package(smart_init) //--------------------------------------------------------------------------- @@ -8,10 +8,14 @@ // Package source. //--------------------------------------------------------------------------- +#pragma comment(lib, "shcore") +#pragma comment(lib, "uxtheme") +#pragma comment(lib, "windowscodecs") +//#pragma comment(lib, "VirtualTrees_R") #pragma argsused -int WINAPI DllEntryPoint(HINSTANCE hinst, unsigned long reason, void*) +extern "C" int _libmain(unsigned long reason) { - return 1; + return 1; } //--------------------------------------------------------------------------- diff --git a/Packages/CBuilder XE6/VirtualTreesCR.cbproj b/Packages/CBuilder 12/VirtualTreesCR.cbproj similarity index 60% rename from Packages/CBuilder XE6/VirtualTreesCR.cbproj rename to Packages/CBuilder 12/VirtualTreesCR.cbproj index d50a1e525..43b617463 100644 --- a/Packages/CBuilder XE6/VirtualTreesCR.cbproj +++ b/Packages/CBuilder 12/VirtualTreesCR.cbproj @@ -1,13 +1,14 @@  - {FE6B0D67-74B6-4E30-8AED-CB2B3E77A51F} - VirtualTreesCR.cpp - 15.4 - Release + {2381F390-47E4-4CAA-BAF9-857BF136C307} + 20.3 VCL + VirtualTreesCR.cpp True + Release Win32 - 3 + VirtualTreesCR + 1048579 Package @@ -23,6 +24,11 @@ Base true + + true + Base + true + true Base @@ -51,52 +57,63 @@ true true + + true + Cfg_2 + true + true + - 200 - true - VirtualTree CBuilder runtime package - $(BDSCOMMONDIR)\hpp\$(Platform) - VirtualTreesCR - Shell32.dll;$(ILINK_DelayLoadDll) - $(BDS)\lib;$(BDS)\lib\$(Platform);$(BDS)\lib\$(Platform)\$(Config);$(DCC_UnitSearchPath) - true - 4108 - System;Xml;Data;Datasnap;Web;Soap;Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;$(DCC_Namespace) - true - CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments= - 6 - bpl - CppPackage - true - true - true All + true true - ..\..\Source\;$(BDS)\include;$(BDS)\include\windows;$(BDS)\include\windows\rtl;$(BDS)\include\windows\vcl;$(BDS)\include\windows\crtl;$(BDS)\include\windows\sdk;$(IncludePath) - ..\..\Source\;$(BDS)\lib;$(BDS)\lib\$(Platform)\$(Config);$(BDS)\lib\$(Platform)\release\psdk;$(ILINK_LibraryPath) + .\Runtime\$(Platform)\$(Config) false true true - .\$(Platform)\$(Config) - .\$(Platform)\$(Config) + $(BDSLIB)\$(PLATFORM)\release\$(LANGDIR);$(ILINK_TranslatedLibraryPath) + CppPackage + System;Xml;Data;Datasnap;Web;Soap;Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;$(DCC_Namespace) + bpl + true + true + <_TCHARMapping>wchar_t + true + VirtualTreesCR + ..\..\Source;$(DCC_UnitSearchPath) + 1033 + CompanyName=;FileDescription=$(MSBuildProjectName);FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProgramID=com.embarcadero.$(MSBuildProjectName);ProductName=$(MSBuildProjectName);ProductVersion=1.0.0.0;Comments= + 6 + true + $(BDSCOMMONDIR)\hpp\$(Platform) + true + VirtualTrees Runtime + true - $(BDSINCLUDE)\windows\vcl;$(IncludePath) - true - $(BDS)\bin\default_app.manifest - 1033 Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace) + Debug + true + $(BDSINCLUDE)\windows\vcl;$(IncludePath) + Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;$(DCC_Namespace) + Debug + true $(BDSINCLUDE)\windows\vcl;$(IncludePath) - 1033 + + Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;$(DCC_Namespace) + Debug + true + true false true false true + _DEBUG;$(Defines) false None DEBUG @@ -106,104 +123,129 @@ true Full true + true + true + true + true + $(BDSLIB)\$(PLATFORM)\debug;$(ILINK_LibraryPath) + $(BDSLIB)\$(PLATFORM)\debug\$(LANGDIR);$(ILINK_TranslatedLibraryPath) - _DEBUG;$(Defines) + false + $(BDSLIB)\$(PLATFORM)$(CC_SUFFIX)\debug;$(ILINK_LibraryPath) + NDEBUG;$(Defines) None - 1033 - NDEBUG;$(Defines) + true + VirtualTrees Runtime - 1033 + true + + + true - - 17 - true - 1 - 4 + 32 0 - 0 + {FF0836F4-FE45-4852-8226-19028E202F2D} + 3 - 1 + {FF0836F4-FE45-4852-8226-19028E202F2D} + 4 - 2 + {FF0836F4-FE45-4852-8226-19028E202F2D} + 5 - 3 + {FF0836F4-FE45-4852-8226-19028E202F2D} + 6 - 4 + {FF0836F4-FE45-4852-8226-19028E202F2D} + 7 - 5 + {FF0836F4-FE45-4852-8226-19028E202F2D} + 8 - 6 + {FF0836F4-FE45-4852-8226-19028E202F2D} + 9 - 7 + {FF0836F4-FE45-4852-8226-19028E202F2D} + 10 - 8 + {FF0836F4-FE45-4852-8226-19028E202F2D} + 11 - 9 + {FF0836F4-FE45-4852-8226-19028E202F2D} + 12 - 10 + {FF0836F4-FE45-4852-8226-19028E202F2D} + 13 - 11 + {FF0836F4-FE45-4852-8226-19028E202F2D} + 14 - 12 + {FF0836F4-FE45-4852-8226-19028E202F2D} + 15 - 13 + {FF0836F4-FE45-4852-8226-19028E202F2D} + 16 - 14 + {FF0836F4-FE45-4852-8226-19028E202F2D} + 17 - 15 + {FF0836F4-FE45-4852-8226-19028E202F2D} + 18 - 16 + {FF0836F4-FE45-4852-8226-19028E202F2D} + 19 - 17 + {FF0836F4-FE45-4852-8226-19028E202F2D} + 20 - 18 + {FF0836F4-FE45-4852-8226-19028E202F2D} + 21 - 19 + {FF0836F4-FE45-4852-8226-19028E202F2D} + 22 - 20 + {FF0836F4-FE45-4852-8226-19028E202F2D} + 23 - 21 + {FF0836F4-FE45-4852-8226-19028E202F2D} + 24 - - Cfg_2 - Base - Base @@ -211,100 +253,38 @@ Cfg_1 Base + + Cfg_2 + Base + - CPlusPlusBuilder.Personality.12 CppPackage - - VirtualTreesCR.cpp - - - False - False - 1 - 0 - 0 - 0 - False - False - False - False - False - 4108 - 1252 - - - - - 1.0.0.0 - - - - - - 1.0.0.0 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - False - - - - - - - False - - False - - True - False - - False - True + False True - False + True + + VirtualTreesCR.cpp + + + + True True + True 12 + + diff --git a/Packages/CBuilder XE5/VirtualTreesCR.cpp b/Packages/CBuilder 12/VirtualTreesCR.cpp similarity index 66% rename from Packages/CBuilder XE5/VirtualTreesCR.cpp rename to Packages/CBuilder 12/VirtualTreesCR.cpp index 37aacb559..80bc9ffc8 100644 --- a/Packages/CBuilder XE5/VirtualTreesCR.cpp +++ b/Packages/CBuilder 12/VirtualTreesCR.cpp @@ -1,17 +1,21 @@ //--------------------------------------------------------------------------- -#include +#include #pragma hdrstop #pragma package(smart_init) + //--------------------------------------------------------------------------- // Package source. //--------------------------------------------------------------------------- +#pragma comment(lib, "shcore") +#pragma comment(lib, "uxtheme") +#pragma comment(lib, "windowscodecs") #pragma argsused -int WINAPI DllEntryPoint(HINSTANCE hinst, unsigned long reason, void*) +extern "C" int _libmain(unsigned long reason) { - return 1; + return 1; } //--------------------------------------------------------------------------- diff --git a/Packages/CBuilder XE5/VirtualTreeView.groupproj b/Packages/CBuilder XE5/VirtualTreeView.groupproj deleted file mode 100644 index c44a4d884..000000000 --- a/Packages/CBuilder XE5/VirtualTreeView.groupproj +++ /dev/null @@ -1,48 +0,0 @@ - - - {90943296-FDFA-4C80-A99D-237F570C4F54} - - - - - - - VirtualTreesCR.cbproj - - - - Default.Personality.12 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - diff --git a/Packages/CBuilder XE5/VirtualTreesCD.cbproj b/Packages/CBuilder XE5/VirtualTreesCD.cbproj deleted file mode 100644 index abe0aaf46..000000000 --- a/Packages/CBuilder XE5/VirtualTreesCD.cbproj +++ /dev/null @@ -1,239 +0,0 @@ - - - {DE1FB54C-6852-4F59-B4A5-7718E6069FE8} - VirtualTreesCD.cpp - 16.1 - Release - VCL - True - Win32 - 1 - Package - - - true - - - true - Base - true - - - true - Base - true - - - true - Base - true - - - true - Cfg_1 - true - true - - - true - Base - true - - - true - Cfg_2 - true - true - - - 190 - VirtualTree CBuilder designtime package - $(BDSCOMMONDIR)\hpp\$(Platform)\ - VirtualTreesCD - true - ..\..\Source;$(DCC_UnitSearchPath) - 4108 - System;Xml;Data;Datasnap;Web;Soap;Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;$(DCC_Namespace) - true - CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments= - 6 - -LUDesignIDE - true - bpl - CppPackage - true - true - true - All - true - ..\..\Source\;..\..\Design\;$(BDS)\include;$(BDS)\include\windows;$(BDS)\include\windows\rtl;$(BDS)\include\windows\vcl;$(BDS)\include\windows\crtl;$(BDS)\include\windows\sdk;$(IncludePath) - ..\..\Design\;$(BDS)\lib;$(BDS)\lib\$(Platform)\$(Config);$(BDS)\lib\$(Platform)\release\psdk;..\..\Source;$(ILINK_LibraryPath) - false - true - true - - - true - $(BDS)\bin\default_app.manifest - 1033 - Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace) - - - 1033 - Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;$(DCC_Namespace) - - - false - true - false - true - false - None - DEBUG - true - true - true - true - Full - true - - - _DEBUG;$(Defines) - - - None - - - 1033 - NDEBUG;$(Defines) - - - - 9 - - - 10 - - - 5 - - - 1 - - - 4 - - - 0 - - - 9 - - - Cfg_2 - Base - - - Base - - - Cfg_1 - Base - - - - - CPlusPlusBuilder.Personality.12 - CppPackage - - - - VirtualTreesCD.cpp - - - False - False - 1 - 0 - 0 - 0 - False - False - False - False - False - 4108 - 1252 - - - - - 1.0.0.0 - - - - - - 1.0.0.0 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - False - - - - - - - False - - False - - True - False - - - - False - True - True - False - - - - True - False - - - 12 - - - diff --git a/Packages/CBuilder XE5/VirtualTreesCD.cpp b/Packages/CBuilder XE5/VirtualTreesCD.cpp deleted file mode 100644 index 37aacb559..000000000 --- a/Packages/CBuilder XE5/VirtualTreesCD.cpp +++ /dev/null @@ -1,17 +0,0 @@ -//--------------------------------------------------------------------------- - -#include -#pragma hdrstop -#pragma package(smart_init) -//--------------------------------------------------------------------------- - -// Package source. -//--------------------------------------------------------------------------- - - -#pragma argsused -int WINAPI DllEntryPoint(HINSTANCE hinst, unsigned long reason, void*) -{ - return 1; -} -//--------------------------------------------------------------------------- diff --git a/Packages/CBuilder XE5/VirtualTreesCR.cbproj b/Packages/CBuilder XE5/VirtualTreesCR.cbproj deleted file mode 100644 index ab073a74d..000000000 --- a/Packages/CBuilder XE5/VirtualTreesCR.cbproj +++ /dev/null @@ -1,310 +0,0 @@ - - - {FE6B0D67-74B6-4E30-8AED-CB2B3E77A51F} - VirtualTreesCR.cpp - 16.1 - Release - VCL - True - Win32 - 3 - Package - - - true - - - true - Base - true - - - true - Base - true - - - true - Base - true - - - true - Cfg_1 - true - true - - - true - Base - true - - - true - Cfg_2 - true - true - - - true - Cfg_2 - true - true - - - 190 - true - VirtualTree CBuilder runtime package - $(BDSCOMMONDIR)\hpp\$(Platform) - VirtualTreesCR - Shell32.dll;$(ILINK_DelayLoadDll) - $(BDS)\lib;$(BDS)\lib\$(Platform);$(BDS)\lib\$(Platform)\$(Config);$(DCC_UnitSearchPath) - true - 4108 - System;Xml;Data;Datasnap;Web;Soap;Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;$(DCC_Namespace) - true - CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments= - 6 - bpl - CppPackage - true - true - true - All - true - ..\..\Source\;$(BDS)\include;$(BDS)\include\windows;$(BDS)\include\windows\rtl;$(BDS)\include\windows\vcl;$(BDS)\include\windows\crtl;$(BDS)\include\windows\sdk;$(IncludePath) - ..\..\Source\;$(BDS)\lib;$(BDS)\lib\$(Platform)\$(Config);$(BDS)\lib\$(Platform)\release\psdk;$(ILINK_LibraryPath) - false - true - true - .\$(Platform)\$(Config) - .\$(Platform)\$(Config) - - - $(BDSINCLUDE)\windows\vcl;$(IncludePath) - true - $(BDS)\bin\default_app.manifest - 1033 - Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace) - - - $(BDSINCLUDE)\windows\vcl;$(IncludePath) - 1033 - Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;$(DCC_Namespace) - - - false - true - false - true - false - None - DEBUG - true - true - true - true - Full - true - - - _DEBUG;$(Defines) - - - None - - - 1033 - NDEBUG;$(Defines) - - - 1033 - - - - 17 - true - - - 1 - - - 4 - - - 0 - - - 0 - - - 1 - - - 2 - - - 3 - - - 4 - - - 5 - - - 6 - - - 7 - - - 8 - - - 9 - - - 10 - - - 11 - - - 12 - - - 13 - - - 14 - - - 15 - - - 16 - - - 17 - - - 18 - - - 19 - - - 20 - - - 21 - - - Cfg_2 - Base - - - Base - - - Cfg_1 - Base - - - - - CPlusPlusBuilder.Personality.12 - CppPackage - - - - VirtualTreesCR.cpp - - - False - False - 1 - 0 - 0 - 0 - False - False - False - False - False - 4108 - 1252 - - - - - 1.0.0.0 - - - - - - 1.0.0.0 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - False - - - - - - - False - - False - - True - False - - - - False - True - True - False - - - - True - True - - - 12 - - - diff --git a/Packages/CBuilder XE6/VirtualTreeView.groupproj b/Packages/CBuilder XE6/VirtualTreeView.groupproj deleted file mode 100644 index c44a4d884..000000000 --- a/Packages/CBuilder XE6/VirtualTreeView.groupproj +++ /dev/null @@ -1,48 +0,0 @@ - - - {90943296-FDFA-4C80-A99D-237F570C4F54} - - - - - - - VirtualTreesCR.cbproj - - - - Default.Personality.12 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - diff --git a/Packages/CBuilder XE6/VirtualTreesCD.cpp b/Packages/CBuilder XE6/VirtualTreesCD.cpp deleted file mode 100644 index 37aacb559..000000000 --- a/Packages/CBuilder XE6/VirtualTreesCD.cpp +++ /dev/null @@ -1,17 +0,0 @@ -//--------------------------------------------------------------------------- - -#include -#pragma hdrstop -#pragma package(smart_init) -//--------------------------------------------------------------------------- - -// Package source. -//--------------------------------------------------------------------------- - - -#pragma argsused -int WINAPI DllEntryPoint(HINSTANCE hinst, unsigned long reason, void*) -{ - return 1; -} -//--------------------------------------------------------------------------- diff --git a/Packages/CBuilder XE6/VirtualTreesCR.cpp b/Packages/CBuilder XE6/VirtualTreesCR.cpp deleted file mode 100644 index 37aacb559..000000000 --- a/Packages/CBuilder XE6/VirtualTreesCR.cpp +++ /dev/null @@ -1,17 +0,0 @@ -//--------------------------------------------------------------------------- - -#include -#pragma hdrstop -#pragma package(smart_init) -//--------------------------------------------------------------------------- - -// Package source. -//--------------------------------------------------------------------------- - - -#pragma argsused -int WINAPI DllEntryPoint(HINSTANCE hinst, unsigned long reason, void*) -{ - return 1; -} -//--------------------------------------------------------------------------- diff --git a/Packages/CBuilder XE7/VirtualTreesCD.cbproj b/Packages/CBuilder XE7/VirtualTreesCD.cbproj deleted file mode 100644 index 2499563f1..000000000 --- a/Packages/CBuilder XE7/VirtualTreesCD.cbproj +++ /dev/null @@ -1,253 +0,0 @@ - - - {DE1FB54C-6852-4F59-B4A5-7718E6069FE8} - VirtualTreesCD.cpp - 18.0 - Release - VCL - True - Win32 - 1 - Package - - - true - - - true - Base - true - - - true - Base - true - - - true - Base - true - - - true - Cfg_1 - true - true - - - true - Base - true - - - true - Cfg_2 - true - true - - - 210 - VirtualTree CBuilder designtime package - $(BDSCOMMONDIR)\hpp\$(Platform)\ - VirtualTreesCD - true - ..\..\Source;$(DCC_UnitSearchPath) - 4108 - System;Xml;Data;Datasnap;Web;Soap;Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;$(DCC_Namespace) - true - CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments= - 6 - -LUDesignIDE - true - bpl - CppPackage - true - true - true - All - true - ..\..\Source\;..\..\Design\;$(BDS)\include;$(BDS)\include\windows;$(BDS)\include\windows\rtl;$(BDS)\include\windows\vcl;$(BDS)\include\windows\crtl;$(BDS)\include\windows\sdk;$(IncludePath) - ..\..\Design\;$(BDS)\lib;$(BDS)\lib\$(Platform)\$(Config);$(BDS)\lib\$(Platform)\release\psdk;..\..\Source;$(ILINK_LibraryPath) - false - true - true - - - true - true - $(BDS)\bin\default_app.manifest - 1033 - Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace) - - - 1033 - Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;$(DCC_Namespace) - - - true - true - true - true - off - false - true - false - true - false - None - DEBUG - true - true - true - true - Full - true - - - $(BDS)\Bin\BDS.EXE - true - true - true - off - 1033 - true - _DEBUG;$(Defines) - - - None - - - 1033 - NDEBUG;$(Defines) - - - - 16 - true - - - 3 - - - 5 - - - 1 - - - 4 - - - 0 - - - 9 - - - Cfg_2 - Base - - - Base - - - Cfg_1 - Base - - - - - CPlusPlusBuilder.Personality.12 - CppPackage - - - - VirtualTreesCD.cpp - - - False - False - 1 - 0 - 0 - 0 - False - False - False - False - False - 4108 - 1252 - - - - - 1.0.0.0 - - - - - - 1.0.0.0 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - False - - - - - - - False - - False - - True - False - - - - False - True - True - False - - - - True - False - - - 12 - - - diff --git a/Packages/CBuilder XE7/VirtualTreesCR.cbproj b/Packages/CBuilder XE7/VirtualTreesCR.cbproj deleted file mode 100644 index ea1bb070d..000000000 --- a/Packages/CBuilder XE7/VirtualTreesCR.cbproj +++ /dev/null @@ -1,332 +0,0 @@ - - - {FE6B0D67-74B6-4E30-8AED-CB2B3E77A51F} - VirtualTreesCR.cpp - 18.0 - Release - VCL - True - Win32 - 3 - Package - - - true - - - true - Base - true - - - true - Base - true - - - true - Base - true - - - true - Cfg_1 - true - true - - - true - Cfg_1 - true - true - - - true - Base - true - - - true - Cfg_2 - true - true - - - true - Cfg_2 - true - true - - - 210 - true - VirtualTree CBuilder runtime package - $(BDSCOMMONDIR)\hpp\$(Platform) - VirtualTreesCR - Shell32.dll;$(ILINK_DelayLoadDll) - $(BDS)\lib;$(BDS)\lib\$(Platform);$(BDS)\lib\$(Platform)\$(Config);$(DCC_UnitSearchPath) - true - 4108 - System;Xml;Data;Datasnap;Web;Soap;Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;$(DCC_Namespace) - true - CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments= - 6 - bpl - CppPackage - true - true - true - All - true - ..\..\Source\;$(BDS)\include;$(BDS)\include\windows;$(BDS)\include\windows\rtl;$(BDS)\include\windows\vcl;$(BDS)\include\windows\crtl;$(BDS)\include\windows\sdk;$(IncludePath) - ..\..\Source\;$(BDS)\lib;$(BDS)\lib\$(Platform)\$(Config);$(BDS)\lib\$(Platform)\release\psdk;$(ILINK_LibraryPath) - false - true - true - .\$(Platform)\$(Config) - .\$(Platform)\$(Config) - - - $(BDS)\Bin\BDS.EXE - true - $(BDSINCLUDE)\windows\vcl;$(IncludePath) - true - $(BDS)\bin\default_app.manifest - 1033 - Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace) - - - $(BDSINCLUDE)\windows\vcl;$(IncludePath) - 1033 - Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;$(DCC_Namespace) - - - true - true - true - true - off - false - true - false - true - false - None - DEBUG - true - true - true - true - Full - true - - - true - true - true - off - 1033 - true - _DEBUG;$(Defines) - - - 1033 - - - None - - - 1033 - NDEBUG;$(Defines) - - - 1033 - - - - 9 - true - - - 1 - - - 4 - - - 0 - - - 0 - - - 1 - - - 2 - - - 3 - - - 4 - - - 5 - - - 6 - - - 7 - - - 8 - - - 9 - - - 10 - - - 11 - - - 12 - - - 13 - - - 14 - - - 15 - - - 16 - - - 17 - - - 18 - - - 19 - - - 20 - - - 21 - - - Cfg_2 - Base - - - Base - - - Cfg_1 - Base - - - - - CPlusPlusBuilder.Personality.12 - CppPackage - - - - VirtualTreesCR.cpp - - - False - False - 1 - 0 - 0 - 0 - False - False - False - False - False - 4108 - 1252 - - - - - 1.0.0.0 - - - - - - 1.0.0.0 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - False - - - - - - - False - - False - - True - False - - - - False - True - True - False - - - - True - True - - - 12 - - - diff --git a/Packages/CBuilder XE7/VirtualTreesCR.cpp b/Packages/CBuilder XE7/VirtualTreesCR.cpp deleted file mode 100644 index 37aacb559..000000000 --- a/Packages/CBuilder XE7/VirtualTreesCR.cpp +++ /dev/null @@ -1,17 +0,0 @@ -//--------------------------------------------------------------------------- - -#include -#pragma hdrstop -#pragma package(smart_init) -//--------------------------------------------------------------------------- - -// Package source. -//--------------------------------------------------------------------------- - - -#pragma argsused -int WINAPI DllEntryPoint(HINSTANCE hinst, unsigned long reason, void*) -{ - return 1; -} -//--------------------------------------------------------------------------- diff --git a/Packages/CBuilder XE8/VirtualTreeView.groupproj b/Packages/CBuilder XE8/VirtualTreeView.groupproj deleted file mode 100644 index d45ca9e06..000000000 --- a/Packages/CBuilder XE8/VirtualTreeView.groupproj +++ /dev/null @@ -1,48 +0,0 @@ - - - {90943296-FDFA-4C80-A99D-237F570C4F54} - - - - - - - - - - - Default.Personality.12 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - diff --git a/Packages/CBuilder XE8/VirtualTreesCD.cbproj b/Packages/CBuilder XE8/VirtualTreesCD.cbproj deleted file mode 100644 index b79a3427d..000000000 --- a/Packages/CBuilder XE8/VirtualTreesCD.cbproj +++ /dev/null @@ -1,253 +0,0 @@ - - - {DE1FB54C-6852-4F59-B4A5-7718E6069FE8} - VirtualTreesCD.cpp - 18.0 - Release - VCL - True - Win32 - 1 - Package - - - true - - - true - Base - true - - - true - Base - true - - - true - Base - true - - - true - Cfg_1 - true - true - - - true - Base - true - - - true - Cfg_2 - true - true - - - 220 - VirtualTree CBuilder designtime package - $(BDSCOMMONDIR)\hpp\$(Platform)\ - VirtualTreesCD - true - ..\..\Source;$(DCC_UnitSearchPath) - 4108 - System;Xml;Data;Datasnap;Web;Soap;Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;$(DCC_Namespace) - true - CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments= - 6 - -LUDesignIDE - true - bpl - CppPackage - true - true - true - All - true - ..\..\Source\;..\..\Design\;$(BDS)\include;$(BDS)\include\windows;$(BDS)\include\windows\rtl;$(BDS)\include\windows\vcl;$(BDS)\include\windows\crtl;$(BDS)\include\windows\sdk;$(IncludePath) - ..\..\Design\;$(BDS)\lib;$(BDS)\lib\$(Platform)\$(Config);$(BDS)\lib\$(Platform)\release\psdk;..\..\Source;$(ILINK_LibraryPath) - false - true - true - - - true - true - $(BDS)\bin\default_app.manifest - 1033 - Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace) - - - 1033 - Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;$(DCC_Namespace) - - - true - true - true - true - off - false - true - false - true - false - None - DEBUG - true - true - true - true - Full - true - - - $(BDS)\Bin\BDS.EXE - true - true - true - off - 1033 - true - _DEBUG;$(Defines) - - - None - - - 1033 - NDEBUG;$(Defines) - - - - 16 - true - - - 3 - - - 5 - - - 1 - - - 4 - - - 0 - - - 9 - - - Cfg_2 - Base - - - Base - - - Cfg_1 - Base - - - - - CPlusPlusBuilder.Personality.12 - CppPackage - - - - VirtualTreesCD.cpp - - - False - False - 1 - 0 - 0 - 0 - False - False - False - False - False - 4108 - 1252 - - - - - 1.0.0.0 - - - - - - 1.0.0.0 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - False - - - - - - - False - - False - - True - False - - - - False - True - True - False - - - - True - False - - - 12 - - - diff --git a/Packages/CBuilder XE8/VirtualTreesCD.cpp b/Packages/CBuilder XE8/VirtualTreesCD.cpp deleted file mode 100644 index 37aacb559..000000000 --- a/Packages/CBuilder XE8/VirtualTreesCD.cpp +++ /dev/null @@ -1,17 +0,0 @@ -//--------------------------------------------------------------------------- - -#include -#pragma hdrstop -#pragma package(smart_init) -//--------------------------------------------------------------------------- - -// Package source. -//--------------------------------------------------------------------------- - - -#pragma argsused -int WINAPI DllEntryPoint(HINSTANCE hinst, unsigned long reason, void*) -{ - return 1; -} -//--------------------------------------------------------------------------- diff --git a/Packages/CBuilder XE8/VirtualTreesCR.cbproj b/Packages/CBuilder XE8/VirtualTreesCR.cbproj deleted file mode 100644 index d37348b87..000000000 --- a/Packages/CBuilder XE8/VirtualTreesCR.cbproj +++ /dev/null @@ -1,332 +0,0 @@ - - - {FE6B0D67-74B6-4E30-8AED-CB2B3E77A51F} - VirtualTreesCR.cpp - 18.0 - Release - VCL - True - Win32 - 3 - Package - - - true - - - true - Base - true - - - true - Base - true - - - true - Base - true - - - true - Cfg_1 - true - true - - - true - Cfg_1 - true - true - - - true - Base - true - - - true - Cfg_2 - true - true - - - true - Cfg_2 - true - true - - - 220 - true - VirtualTree CBuilder runtime package - $(BDSCOMMONDIR)\hpp\$(Platform) - VirtualTreesCR - Shell32.dll;$(ILINK_DelayLoadDll) - $(BDS)\lib;$(BDS)\lib\$(Platform);$(BDS)\lib\$(Platform)\$(Config);$(DCC_UnitSearchPath) - true - 4108 - System;Xml;Data;Datasnap;Web;Soap;Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;$(DCC_Namespace) - true - CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments= - 6 - bpl - CppPackage - true - true - true - All - true - ..\..\Source\;$(BDS)\include;$(BDS)\include\windows;$(BDS)\include\windows\rtl;$(BDS)\include\windows\vcl;$(BDS)\include\windows\crtl;$(BDS)\include\windows\sdk;$(IncludePath) - ..\..\Source\;$(BDS)\lib;$(BDS)\lib\$(Platform)\$(Config);$(BDS)\lib\$(Platform)\release\psdk;$(ILINK_LibraryPath) - false - true - true - .\$(Platform)\$(Config) - .\$(Platform)\$(Config) - - - $(BDS)\Bin\BDS.EXE - true - $(BDSINCLUDE)\windows\vcl;$(IncludePath) - true - $(BDS)\bin\default_app.manifest - 1033 - Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace) - - - $(BDSINCLUDE)\windows\vcl;$(IncludePath) - 1033 - Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;$(DCC_Namespace) - - - true - true - true - true - off - false - true - false - true - false - None - DEBUG - true - true - true - true - Full - true - - - true - true - true - off - 1033 - true - _DEBUG;$(Defines) - - - 1033 - - - None - - - 1033 - NDEBUG;$(Defines) - - - 1033 - - - - 9 - true - - - 1 - - - 4 - - - 0 - - - 0 - - - 1 - - - 2 - - - 3 - - - 4 - - - 5 - - - 6 - - - 7 - - - 8 - - - 9 - - - 10 - - - 11 - - - 12 - - - 13 - - - 14 - - - 15 - - - 16 - - - 17 - - - 18 - - - 19 - - - 20 - - - 21 - - - Cfg_2 - Base - - - Base - - - Cfg_1 - Base - - - - - CPlusPlusBuilder.Personality.12 - CppPackage - - - - VirtualTreesCR.cpp - - - False - False - 1 - 0 - 0 - 0 - False - False - False - False - False - 4108 - 1252 - - - - - 1.0.0.0 - - - - - - 1.0.0.0 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - False - - - - - - - False - - False - - True - False - - - - False - True - True - False - - - - True - True - - - 12 - - - diff --git a/Packages/CBuilder XE8/VirtualTreesCR.cpp b/Packages/CBuilder XE8/VirtualTreesCR.cpp deleted file mode 100644 index 37aacb559..000000000 --- a/Packages/CBuilder XE8/VirtualTreesCR.cpp +++ /dev/null @@ -1,17 +0,0 @@ -//--------------------------------------------------------------------------- - -#include -#pragma hdrstop -#pragma package(smart_init) -//--------------------------------------------------------------------------- - -// Package source. -//--------------------------------------------------------------------------- - - -#pragma argsused -int WINAPI DllEntryPoint(HINSTANCE hinst, unsigned long reason, void*) -{ - return 1; -} -//--------------------------------------------------------------------------- diff --git a/Packages/RAD Studio 10.1/VirtualTreesR.dpk b/Packages/RAD Studio 10.1/VirtualTreesR.dpk index 04582e6c6..6f2d721d6 100644 --- a/Packages/RAD Studio 10.1/VirtualTreesR.dpk +++ b/Packages/RAD Studio 10.1/VirtualTreesR.dpk @@ -34,24 +34,27 @@ 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.AccessibilityFactory in '..\..\Source\VirtualTrees.AccessibilityFactory.pas', + VirtualTrees.Actions in '..\..\Source\VirtualTrees.Actions.pas', VirtualTrees.Classes in '..\..\Source\VirtualTrees.Classes.pas', - VirtualTrees.WorkerThread in '..\..\Source\VirtualTrees.WorkerThread.pas', VirtualTrees.ClipBoard in '..\..\Source\VirtualTrees.ClipBoard.pas', - VirtualTrees.Actions in '..\..\Source\VirtualTrees.Actions.pas', - VirtualTrees.Export in '..\..\Source\VirtualTrees.Export.pas', - VirtualTrees.Utils in '..\..\Source\VirtualTrees.Utils.pas', - VirtualTrees.Types in '..\..\Source\VirtualTrees.Types.pas', - VirtualTrees.Header in '..\..\Source\VirtualTrees.Header.pas', + VirtualTrees.Colors in '..\..\Source\VirtualTrees.Colors.pas', VirtualTrees.DataObject in '..\..\Source\VirtualTrees.DataObject.pas', - VirtualTrees.DragnDrop in '..\..\Source\VirtualTrees.DragnDrop.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.Colors in '..\..\Source\VirtualTrees.Colors.pas', - VirtualTrees.DrawTree in '..\..\Source\VirtualTrees.DrawTree.pas'; + VirtualTrees.Export in '..\..\Source\VirtualTrees.Export.pas', + VirtualTrees.Header in '..\..\Source\VirtualTrees.Header.pas', + VirtualTrees.HeaderPopup in '..\..\Source\VirtualTrees.HeaderPopup.pas', + VirtualTrees in '..\..\source\VirtualTrees.pas', + VirtualTrees.BaseTree in '..\..\source\VirtualTrees.BaseTree.pas', + VirtualTrees.AncestorVCL in '..\..\source\VirtualTrees.AncestorVCL.pas', + VirtualTrees.BaseAncestorVCL in '..\..\source\VirtualTrees.BaseAncestorVCL.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/Packages/RAD Studio 10.1/VirtualTreesR.dproj b/Packages/RAD Studio 10.1/VirtualTreesR.dproj index 9842ffdc6..8baa133a8 100644 --- a/Packages/RAD Studio 10.1/VirtualTreesR.dproj +++ b/Packages/RAD Studio 10.1/VirtualTreesR.dproj @@ -79,25 +79,28 @@ - - - - + + - - - - - - + - - - + + + + + + + + + + + + + Cfg_2 Base diff --git a/Packages/RAD Studio 10.2/VirtualTreesR.dpk b/Packages/RAD Studio 10.2/VirtualTreesR.dpk index f4a36a1a8..c58d9234f 100644 --- a/Packages/RAD Studio 10.2/VirtualTreesR.dpk +++ b/Packages/RAD Studio 10.2/VirtualTreesR.dpk @@ -34,24 +34,27 @@ 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.AccessibilityFactory in '..\..\Source\VirtualTrees.AccessibilityFactory.pas', + VirtualTrees.Actions in '..\..\Source\VirtualTrees.Actions.pas', VirtualTrees.Classes in '..\..\Source\VirtualTrees.Classes.pas', - VirtualTrees.WorkerThread in '..\..\Source\VirtualTrees.WorkerThread.pas', VirtualTrees.ClipBoard in '..\..\Source\VirtualTrees.ClipBoard.pas', - VirtualTrees.Actions in '..\..\Source\VirtualTrees.Actions.pas', - VirtualTrees.Export in '..\..\Source\VirtualTrees.Export.pas', - VirtualTrees.Utils in '..\..\Source\VirtualTrees.Utils.pas', - VirtualTrees.Types in '..\..\Source\VirtualTrees.Types.pas', - VirtualTrees.Header in '..\..\Source\VirtualTrees.Header.pas', + VirtualTrees.Colors in '..\..\Source\VirtualTrees.Colors.pas', VirtualTrees.DataObject in '..\..\Source\VirtualTrees.DataObject.pas', - VirtualTrees.DragnDrop in '..\..\Source\VirtualTrees.DragnDrop.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.Colors in '..\..\Source\VirtualTrees.Colors.pas', - VirtualTrees.DrawTree in '..\..\Source\VirtualTrees.DrawTree.pas'; + VirtualTrees.Export in '..\..\Source\VirtualTrees.Export.pas', + VirtualTrees.Header in '..\..\Source\VirtualTrees.Header.pas', + VirtualTrees.HeaderPopup in '..\..\Source\VirtualTrees.HeaderPopup.pas', + VirtualTrees in '..\..\source\VirtualTrees.pas', + VirtualTrees.BaseTree in '..\..\source\VirtualTrees.BaseTree.pas', + VirtualTrees.AncestorVCL in '..\..\source\VirtualTrees.AncestorVCL.pas', + VirtualTrees.BaseAncestorVCL in '..\..\source\VirtualTrees.BaseAncestorVCL.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/Packages/RAD Studio 10.2/VirtualTreesR.dproj b/Packages/RAD Studio 10.2/VirtualTreesR.dproj index 4b8608bbf..ded52d8f1 100644 --- a/Packages/RAD Studio 10.2/VirtualTreesR.dproj +++ b/Packages/RAD Studio 10.2/VirtualTreesR.dproj @@ -79,25 +79,28 @@ - - - - + + - - - - - - + - - - + + + + + + + + + + + + + Cfg_2 Base diff --git a/Packages/RAD Studio 10.4+/VirtualTreesD.dpk b/Packages/RAD Studio 10.4+/VirtualTreesD.dpk index ebb9a9ec3..601b5477a 100644 --- a/Packages/RAD Studio 10.4+/VirtualTreesD.dpk +++ b/Packages/RAD Studio 10.4+/VirtualTreesD.dpk @@ -29,7 +29,7 @@ {$DESCRIPTION 'VirtualTreeView Controls'} {$LIBSUFFIX AUTO} {$DESIGNONLY} -{$IMPLICITBUILD ON} +{$IMPLICITBUILD OFF} requires DesignIDE, diff --git a/Packages/RAD Studio 10.4+/VirtualTreesD.dproj b/Packages/RAD Studio 10.4+/VirtualTreesD.dproj index b0cc108a4..337db6336 100644 --- a/Packages/RAD Studio 10.4+/VirtualTreesD.dproj +++ b/Packages/RAD Studio 10.4+/VirtualTreesD.dproj @@ -8,7 +8,7 @@ VirtualTreesD.dpk Win32 {A34BA07B-19B6-4C21-9DEE-65FCA52D00AB} - 20.2 + 20.3 1048577 VirtualTreesD diff --git a/Packages/RAD Studio 10.4+/VirtualTreesR.dpk b/Packages/RAD Studio 10.4+/VirtualTreesR.dpk index 46f90d69d..f65fc3b6e 100644 --- a/Packages/RAD Studio 10.4+/VirtualTreesR.dpk +++ b/Packages/RAD Studio 10.4+/VirtualTreesR.dpk @@ -27,7 +27,7 @@ package VirtualTreesR; {$ENDIF IMPLICITBUILDING} {$LIBSUFFIX AUTO} {$RUNONLY} -{$IMPLICITBUILD ON} +{$IMPLICITBUILD OFF} requires vcl, diff --git a/Packages/RAD Studio 10.4+/VirtualTreesR.dproj b/Packages/RAD Studio 10.4+/VirtualTreesR.dproj index 10230a053..c0abab669 100644 --- a/Packages/RAD Studio 10.4+/VirtualTreesR.dproj +++ b/Packages/RAD Studio 10.4+/VirtualTreesR.dproj @@ -8,7 +8,7 @@ VirtualTreesR.dpk Win64 {B62F3689-96E1-47D5-9FB2-2A2718281FDB} - 20.2 + 20.3 1048579 VirtualTreesR diff --git a/Packages/RAD Studio 10/VirtualTreesR.dpk b/Packages/RAD Studio 10/VirtualTreesR.dpk index bc517ca96..4b2f7d9f6 100644 --- a/Packages/RAD Studio 10/VirtualTreesR.dpk +++ b/Packages/RAD Studio 10/VirtualTreesR.dpk @@ -34,24 +34,27 @@ 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.AccessibilityFactory in '..\..\Source\VirtualTrees.AccessibilityFactory.pas', + VirtualTrees.Actions in '..\..\Source\VirtualTrees.Actions.pas', VirtualTrees.Classes in '..\..\Source\VirtualTrees.Classes.pas', - VirtualTrees.WorkerThread in '..\..\Source\VirtualTrees.WorkerThread.pas', VirtualTrees.ClipBoard in '..\..\Source\VirtualTrees.ClipBoard.pas', - VirtualTrees.Actions in '..\..\Source\VirtualTrees.Actions.pas', - VirtualTrees.Export in '..\..\Source\VirtualTrees.Export.pas', - VirtualTrees.Utils in '..\..\Source\VirtualTrees.Utils.pas', - VirtualTrees.Types in '..\..\Source\VirtualTrees.Types.pas', - VirtualTrees.Header in '..\..\Source\VirtualTrees.Header.pas', + VirtualTrees.Colors in '..\..\Source\VirtualTrees.Colors.pas', VirtualTrees.DataObject in '..\..\Source\VirtualTrees.DataObject.pas', - VirtualTrees.DragnDrop in '..\..\Source\VirtualTrees.DragnDrop.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.Colors in '..\..\Source\VirtualTrees.Colors.pas', - VirtualTrees.DrawTree in '..\..\Source\VirtualTrees.DrawTree.pas'; + VirtualTrees.Export in '..\..\Source\VirtualTrees.Export.pas', + VirtualTrees.Header in '..\..\Source\VirtualTrees.Header.pas', + VirtualTrees.HeaderPopup in '..\..\Source\VirtualTrees.HeaderPopup.pas', + VirtualTrees in '..\..\source\VirtualTrees.pas', + VirtualTrees.BaseTree in '..\..\source\VirtualTrees.BaseTree.pas', + VirtualTrees.AncestorVCL in '..\..\source\VirtualTrees.AncestorVCL.pas', + VirtualTrees.BaseAncestorVCL in '..\..\source\VirtualTrees.BaseAncestorVCL.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/Packages/RAD Studio 10/VirtualTreesR.dproj b/Packages/RAD Studio 10/VirtualTreesR.dproj index 8b72f1d81..61567ef51 100644 --- a/Packages/RAD Studio 10/VirtualTreesR.dproj +++ b/Packages/RAD Studio 10/VirtualTreesR.dproj @@ -79,25 +79,28 @@ - - - - + + - - - - - - + - - - + + + + + + + + + + + + + Cfg_2 Base diff --git a/Resources/VirtualTreeview-Catalog-Image.png b/Resources/VirtualTreeview-Catalog-Image.png new file mode 100644 index 000000000..c4116cc15 Binary files /dev/null and b/Resources/VirtualTreeview-Catalog-Image.png differ diff --git a/Source/VirtualTrees.BaseAncestorVcl.pas b/Source/VirtualTrees.BaseAncestorVcl.pas index ce624b59e..8eba812f9 100644 --- a/Source/VirtualTrees.BaseAncestorVcl.pas +++ b/Source/VirtualTrees.BaseAncestorVcl.pas @@ -41,6 +41,13 @@ TVTBaseAncestorVcl = class abstract(TCustomControl) procedure SetWindowTheme(const Theme: string); virtual; //// Abtract method that are implemented in TBaseVirtualTree, keep in sync with TVTBaseAncestorFMX function GetSelectedCount(): Integer; virtual; abstract; + + /// + /// multicell support. How many cells are selected? + /// + function GetSelectedCellCount(): Integer; virtual; abstract; + procedure MarkCutCopyCells; virtual; abstract; + procedure MarkCutCopyNodes; virtual; abstract; procedure DoStateChange(Enter: TVirtualTreeStates; Leave: TVirtualTreeStates = []); virtual; abstract; function GetSortedCutCopySet(Resolve: Boolean): TNodeArray; virtual; abstract; @@ -283,6 +290,20 @@ procedure TVTBaseAncestorVcl.CopyToClipboard; lDataObject: IDataObject; begin + // multicell support copy + if GetSelectedCellCount > 0 then + begin + lDataObject := TVTDataObject.Create(Self, True); + if OleSetClipboard(lDataObject) = S_OK then + begin + MarkCutCopyCells; + DoStateChange([tsCopyPending]); + Invalidate; + end; + Exit; + end; + + // regular fullrow copy if GetSelectedCount > 0 then begin lDataObject := TVTDataObject.Create(Self, True); diff --git a/Source/VirtualTrees.BaseTree.pas b/Source/VirtualTrees.BaseTree.pas index 9bf24825a..6246b1574 100644 --- a/Source/VirtualTrees.BaseTree.pas +++ b/Source/VirtualTrees.BaseTree.pas @@ -201,6 +201,10 @@ TClipboardFormats = class(TStringList) TVTCheckChangingEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode; var NewState: TCheckState; var Allowed: Boolean) of object; TVTChangeEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode) of object; + /// + /// Cells can be empty + /// + TVTChangeCellEvent = procedure(Sender: TBaseVirtualTree; const Cells: TVTCellArray) of object; TVTStructureChangeEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode; Reason: TChangeReason) of object; TVTEditCancelEvent = procedure(Sender: TBaseVirtualTree; Column: TColumnIndex) of object; TVTEditChangingEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; @@ -451,6 +455,9 @@ TBaseVirtualTree = class abstract(TVTBaseAncestor) FStartIndex: Cardinal; // index to start validating cache from FSelection: TNodeArray; // list of currently selected nodes FSelectionLocked: Boolean; // prevents the tree from changing the selection + FSelectedCells: TVTCellArray; // list of currently selected cells (node+column) / multicell + FSelectedCellCount: Integer; // number of selected cells in the array / multicell + FCellRangeAnchor: TVTCell; // anchor cell for cell range selection / multicell FRangeAnchor: PVirtualNode; // anchor node for selection with the keyboard, determines start of a // selection range FCheckPropagationCount: Cardinal; // nesting level of check propagation (WL, 05.02.2004) @@ -571,6 +578,11 @@ TBaseVirtualTree = class abstract(TVTBaseAncestor) // common events FOnChange: TVTChangeEvent; // selection change + /// + /// Used for notifying that cell selection have changed + /// + FOnChangeCell: TVTChangeCellEvent; + // cells selection change FOnStructureChange: TVTStructureChangeEvent; // structural change like adding nodes etc. FOnInitChildren: TVTInitChildrenEvent; // called when a node's children are needed (expanding etc.) FOnInitNode: TVTInitNodeEvent; // called when a node needs to be initialized (child count etc.) @@ -908,6 +920,7 @@ TBaseVirtualTree = class abstract(TVTBaseAncestor) procedure AdjustPanningCursor(X, Y: TDimension); virtual; procedure AdjustTotalHeight(Node: PVirtualNode; Value: TNodeHeight; relative: Boolean = False); procedure AdviseChangeEvent(StructureChange: Boolean; Node: PVirtualNode; Reason: TChangeReason); virtual; + procedure AdviseChangeCellEvent(const Cells: TVTCellArray); virtual; function AllocateInternalDataArea(Size: Cardinal): Cardinal; virtual; procedure Animate(Steps, Duration: Cardinal; Callback: TVTAnimationCallback; Data: Pointer); virtual; function CalculateSelectionRect(X, Y: TDimension): Boolean; virtual; @@ -915,6 +928,14 @@ TBaseVirtualTree = class abstract(TVTBaseAncestor) function CanShowDragImage: Boolean; virtual; function CanSplitterResizeNode(P: TPoint; Node: PVirtualNode; Column: TColumnIndex): Boolean; procedure Change(Node: PVirtualNode); virtual; + + /// + /// Called to notify that cell selection have changed + /// + /// + /// The updated cells + /// + procedure ChangeCell(const Cells: TVTCellArray); virtual; procedure ChangeTreeStatesAsync(EnterStates, LeaveStates: TVirtualTreeStates); procedure ChangeScale(M, D: Integer{$if CompilerVersion >= 31}; isDpiChange: Boolean{$ifend}); override; function CheckParentCheckState(Node: PVirtualNode; NewCheckState: TCheckState): Boolean; virtual; @@ -957,6 +978,18 @@ 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. 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; procedure DoCheckClick(Node: PVirtualNode; NewCheckState: TCheckState); virtual; procedure DoChecked(Node: PVirtualNode); virtual; function DoChecking(Node: PVirtualNode; var NewCheckState: TCheckState): Boolean; virtual; @@ -1095,6 +1128,10 @@ TBaseVirtualTree = class abstract(TVTBaseAncestor) function GetOperationCanceled: Boolean; function GetOptionsClass: TTreeOptionsClass; virtual; function GetSelectedCount(): Integer; override; + + // multicell support + function GetSelectedCellCount(): Integer; override; + procedure HandleHotTrack(X, Y: TDimension); virtual; procedure HandleIncrementalSearch(CharCode: Word); virtual; procedure HandleMouseDblClick(var Message: TWMMouse; const HitInfo: THitInfo); virtual; @@ -1110,6 +1147,53 @@ TBaseVirtualTree = class abstract(TVTBaseAncestor) function InternalAddToSelection(Node: PVirtualNode; ForceInsert: Boolean): Boolean; overload; function InternalAddToSelection(const NewItems: TNodeArray; NewLength: Integer; ForceInsert: Boolean): Boolean; overload; + + /// + /// 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); + + // 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; + + procedure ToggleCellSelection(StartCell, EndCell: TVTCell); virtual; + procedure InternalCacheNode(Node: PVirtualNode); virtual; procedure InternalClearSelection; virtual; procedure InternalConnectNode(Node, Destination: PVirtualNode; Target: TBaseVirtualTree; Mode: TVTNodeAttachMode); virtual; @@ -1122,7 +1206,12 @@ TBaseVirtualTree = class abstract(TVTBaseAncestor) function LineWidth(): TDimension; procedure Loaded; override; procedure MainColumnChanged; virtual; + + // multicell support + procedure MarkCutCopyCells; override; + procedure MarkCutCopyNodes; override; + procedure MouseMove(Shift: TShiftState; X, Y: TDimension); override; procedure Notification(AComponent: TComponent; Operation: TOperation); override; procedure OriginalWMNCPaint(DC: HDC); virtual; @@ -1282,6 +1371,16 @@ 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; + + /// + /// 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; property OnCollapsed: TVTChangeEvent read FOnCollapsed write FOnCollapsed; @@ -1565,6 +1664,68 @@ TBaseVirtualTree = class abstract(TVTBaseAncestor) procedure ValidateChildren(Node: PVirtualNode; Recursive: Boolean); procedure ValidateNode(Node: PVirtualNode; Recursive: Boolean); + { Multiple cell selection / multicell } + /// + /// Clears the currently selected cells. + /// + procedure ClearCellSelection; + + /// + /// Determines whether the specified cell is selected. + /// + /// + /// The node containing the cell to test. + /// + /// + /// The column index of the cell to test. + /// + /// + /// True if the specified cell is selected; otherwise, False. + /// + function IsCellSelected(Node: PVirtualNode; Column: TColumnIndex): Boolean; + + /// + /// Selects a rectangular range of cells. + /// + /// + /// The node where the selection starts. + /// + /// + /// The column index where the selection starts. + /// + /// + /// The node where the selection ends. + /// + /// + /// The column index where the selection ends. + /// + /// + /// If True, adds the range to the existing selection without clearing it. + /// + procedure SelectCells(StartNode: PVirtualNode; StartColumn: + 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 + /// parameters + /// + /// + /// The node where the selection starts. + /// + /// + /// The column index where the selection starts. + /// + /// + /// The node where the selection ends. + /// + /// + /// The column index where the selection ends. + /// + procedure UnselectCells(StartNode: PVirtualNode; StartColumn: TColumnIndex; + EndNode: PVirtualNode; EndColumn: TColumnIndex); + { Enumerations } function Nodes(ConsiderChildrenAbove: Boolean = False): TVTVirtualNodeEnumeration; function CheckedNodes(State: TCheckState = csCheckedNormal; ConsiderChildrenAbove: Boolean = False): TVTVirtualNodeEnumeration; @@ -1574,6 +1735,7 @@ TBaseVirtualTree = class abstract(TVTBaseAncestor) function LeafNodes: TVTVirtualNodeEnumeration; function LevelNodes(NodeLevel: Cardinal): TVTVirtualNodeEnumeration; function NoInitNodes(ConsiderChildrenAbove: Boolean = False): TVTVirtualNodeEnumeration; + function SelectedCells: TVTCellArray; // multicell support function SelectedNodes(ConsiderChildrenAbove: Boolean = False): TVTVirtualNodeEnumeration; function VisibleNodes(Node: PVirtualNode = nil; ConsiderChildrenAbove: Boolean = True; IncludeFiltered: Boolean = False): TVTVirtualNodeEnumeration; @@ -1649,7 +1811,7 @@ implementation System.Math, System.SyncObjs, System.StrUtils, - Clipbrd, + Vcl.Clipbrd, Vcl.Consts, Vcl.ExtCtrls, Vcl.AxCtrls, // TOLEStream @@ -1759,6 +1921,50 @@ function TreeFromNode(Node: PVirtualNode): TBaseVirtualTree; //---------------------------------------------------------------------------------------------------------------------- +procedure TBaseVirtualTree.SelectCells(StartNode: PVirtualNode; StartColumn: TColumnIndex; EndNode: PVirtualNode; EndColumn: TColumnIndex; AddOnly: Boolean); +var + S, E: TVTCell; +begin + S := TVTCell.Create(StartNode, StartColumn); + E := TVTCell.Create(EndNode, EndColumn); + SelectCells(S, E, AddOnly); +end; + +procedure TBaseVirtualTree.SelectCells(const StartCell, EndCell: TVTCell; AddOnly: Boolean); +begin + InternalSelectCells(StartCell, EndCell, AddOnly); + ChangeCell(FSelectedCells); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.UnselectCells(StartNode: PVirtualNode; StartColumn: TColumnIndex; EndNode: PVirtualNode; EndColumn: TColumnIndex); +var + S, E: TVTCell; +begin + S := TVTCell.Create(StartNode, StartColumn); + E := TVTCell.Create(EndNode, EndColumn); + InternalUnselectCells(S, E); + ChangeCell(FSelectedCells); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.ClearCellSelection; +begin + InternalClearCellSelection; + ChangeCell([]); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.IsCellSelected(Node: PVirtualNode; Column: TColumnIndex): Boolean; +begin + Result := InternalIsCellSelected(Node, Column); +end; + +//---------------------------------------------------------------------------------------------------------------------- + procedure QuickSort(const TheArray: TNodeArray; L, R: Integer); var @@ -3439,6 +3645,13 @@ function TBaseVirtualTree.GetSelectedCount: Integer; //---------------------------------------------------------------------------------------------------------------------- +function TBaseVirtualTree.GetSelectedCellCount: Integer; +begin + Exit(FSelectedCellCount); +end; + +//---------------------------------------------------------------------------------------------------------------------- + function TBaseVirtualTree.GetSelectedData: TArray; var lItem: PVirtualNode; @@ -3535,10 +3748,77 @@ function TBaseVirtualTree.GetVisiblePath(Node: PVirtualNode): Boolean; procedure TBaseVirtualTree.HandleClickSelection(LastFocused, NewNode: PVirtualNode; Shift: TShiftState; DragPending: Boolean); +var + 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 LCellSelectionEnabled then + begin + // build the clicked cell (use ClickIndex as it reflects the saved hit column) + ClickedCell.Node := NewNode; + ClickedCell.Column := FHeader.Columns.ClickIndex; + + // Ctrl key down + if ssCtrl in Shift then + begin + if ssShift in Shift then + begin + if FCellRangeAnchor.Node = nil then + begin + if Assigned(FRoot.FirstChild) then + begin + FCellRangeAnchor.Node := FRoot.FirstChild; + FCellRangeAnchor.Column := 0; + end + else + FCellRangeAnchor := ClickedCell; + end; + 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) + else + AddToCellSelection(ClickedCell, True); + end; + end + else + // Shift key down + if ssShift in Shift then + begin + if FCellRangeAnchor.Node = nil then + begin + if Assigned(FRoot.FirstChild) then + begin + FCellRangeAnchor.Node := FRoot.FirstChild; + FCellRangeAnchor.Column := 0; + end + else + FCellRangeAnchor := ClickedCell; + end; + SelectCells(FCellRangeAnchor, ClickedCell, True); + Invalidate; + end + else + begin + // Clear any existing cell selection and select the clicked cell. + InternalClearCellSelection; + AddToCellSelection(ClickedCell, True); + FCellRangeAnchor := ClickedCell; + end; + Exit; + end; // Ctrl key down if ssCtrl in Shift then begin @@ -3903,7 +4183,7 @@ function TBaseVirtualTree.PackArray({*}const TheArray: TNodeArray; Count: Intege // The returned value is the number of remaining entries in the array, so the caller can reallocate (shorten) // the selection array if needed or -1 if nothing needs to be changed. -{$IF Defined(CPUX64) or Defined(VT_FMX)} +{$IF Defined(CPUX64) or not Defined(ASSEMBLER)} var Source, Dest: ^PVirtualNode; ConstOne: NativeInt; @@ -5276,7 +5556,10 @@ procedure TBaseVirtualTree.SetTextMargin(Value: TDimension); begin FTextMargin := Value; if not (csLoading in ComponentState) then + begin + AutoScale(); Invalidate; + end; end; end; @@ -5786,9 +6069,9 @@ procedure TBaseVirtualTree.CMDrag(var Message: TCMDrag); inherited else begin - // We need an extra check for the control drag object as there might be other objects not derived from - // this class (e.g. TActionDragObject). - if not (tsUserDragObject in FStates) and (S is TBaseDragControlObject) then + // We need an extra check for the control drag object as there might be other objects not derived from this class (e.g. TActionDragObject). + // Original line of code (see issue #1295): if not (tsUserDragObject in FStates) and (S is TBaseDragControlObject) then + if (S.ClassName = TDragControlObject.ClassName) or (S.ClassName = TDragControlObjectEx.ClassName) then // see issue #1295 S := (S as TBaseDragControlObject).Control; case DragMessage of dmDragEnter, dmDragLeave, dmDragMove: @@ -6472,8 +6755,18 @@ procedure TBaseVirtualTree.WMContextMenu(var Message: TWMContextMenu); // This method is called when a popup menu is about to be displayed. // We have to cancel some pending states here to avoid interferences. +var + HitInfo: THitInfo; + pt: TPoint; begin - DoStateChange([], [tsClearPending, tsEditPending, tsOLEDragPending, tsVCLDragPending]); + DoStateChange([], [tsClearPending, tsEditPending, tsOLEDragPending, tsVCLDragPending, tsPopupMenuShown]); + + if not Assigned(PopupMenu) then begin + // convert screen coordinates to client + pt := ScreenToClient(Point(Message.XPos, Message.YPos)); + GetHitTestInfoAt(pt.x, pt.y, True, HitInfo); // ShiftState is not used anyway here + DoPopupMenu(HitInfo.HitNode, HitInfo.HitColumn, pt); + end; if not (tsPopupMenuShown in FStates) then inherited; @@ -6597,7 +6890,7 @@ procedure TBaseVirtualTree.WMKeyDown(var Message: TWMKeyDown); var Shift: TShiftState; Node, Temp, - LastFocused: PVirtualNode; + LastFocusedNode: PVirtualNode; Offset: Integer; ClearPending, NeedInvalidate, @@ -6622,6 +6915,7 @@ procedure TBaseVirtualTree.WMKeyDown(var Message: TWMKeyDown); KeyState: TKeyboardState; Buffer: array[0..1] of AnsiChar; + LCellSelectionEnabled: Boolean; //--------------- local functions ------------------------------------------- function getPreviousVisibleAutoSpanColumn(acolumn: TColumnIndex; anode: PVirtualNode): TColumnIndex; @@ -6711,10 +7005,14 @@ procedure TBaseVirtualTree.WMKeyDown(var Message: TWMKeyDown); //--------------- end local functions --------------------------------------- +var + SelectedCell, OldCell: TVTCell; begin // Make form key preview work and let application modify the key if it wants this. inherited; + LCellSelectionEnabled := IsCellSelectionEnabled; + with Message do begin Shift := KeyDataToShiftState(KeyData); @@ -6725,8 +7023,16 @@ procedure TBaseVirtualTree.WMKeyDown(var Message: TWMKeyDown); begin PerformMultiSelect := (ssShift in Shift) and (toMultiSelect in FOptions.SelectionOptions) and not IsEditing; + // Clear range selection + if (Shift = []) and LCellSelectionEnabled then + begin + ClearCellSelection; + end; + // Flag to avoid range selection in case of single node advance. - DoRangeSelect := (CharCode in [VK_HOME, VK_END, VK_PRIOR, VK_NEXT]) and PerformMultiSelect and not IsEditing; + DoRangeSelect := (CharCode in [ + VK_HOME, VK_END, VK_PRIOR, VK_NEXT, VK_UP, VK_DOWN, VK_LEFT, VK_RIGHT + ]) and PerformMultiSelect and not IsEditing; NeedInvalidate := DoRangeSelect or (FSelectionCount > 1); ActAsGrid := toGridExtensions in FOptions.MiscOptions; @@ -6734,9 +7040,9 @@ procedure TBaseVirtualTree.WMKeyDown(var Message: TWMKeyDown); not (toMultiSelect in FOptions.SelectionOptions) or (CharCode in [VK_TAB, VK_BACK]); // Keep old focused node for range selection. Use a default node if none was focused until now. - LastFocused := FFocusedNode; - if (LastFocused = nil) and (Shift <> []) then - LastFocused := GetFirstVisible(nil, True); + LastFocusedNode := FFocusedNode; + if (LastFocusedNode = nil) and (Shift <> []) then + LastFocusedNode := GetFirstVisible(nil, True); // Set an initial range anchor if there is not yet one. if FRangeAnchor = nil then @@ -6927,7 +7233,7 @@ procedure TBaseVirtualTree.WMKeyDown(var Message: TWMKeyDown); begin if not EndEditNode then exit; - if (not PerformMultiSelect or (CompareNodePositions(LastFocused, Node) < -1)) and Assigned(FFocusedNode) then + if (not PerformMultiSelect or (CompareNodePositions(LastFocusedNode, Node) < -1)) and Assigned(FFocusedNode) then ClearSelection(False); // Clear selection only if more than one node was skipped. See issue #926 if FFocusedColumn <= NoColumn then FFocusedColumn := FHeader.MainColumn; @@ -6954,7 +7260,7 @@ procedure TBaseVirtualTree.WMKeyDown(var Message: TWMKeyDown); begin if not EndEditNode then exit; - if (not PerformMultiSelect or (CompareNodePositions(LastFocused, Node) > 1)) and Assigned(FFocusedNode) then + if (not PerformMultiSelect or (CompareNodePositions(LastFocusedNode, Node) > 1)) and Assigned(FFocusedNode) then ClearSelection(False); // Clear selection only if more than one node was skipped. See issue #926 if FFocusedColumn <= NoColumn then FFocusedColumn := FHeader.MainColumn; @@ -6974,7 +7280,8 @@ procedure TBaseVirtualTree.WMKeyDown(var Message: TWMKeyDown); begin // other special cases Context := NoColumn; - if (toExtendedFocus in FOptions.SelectionOptions) and (toGridExtensions in FOptions.MiscOptions) then + if ((toExtendedFocus in FOptions.SelectionOptions) and (toGridExtensions in FOptions.MiscOptions)) or + LCellSelectionEnabled then begin Context := getPreviousVisibleAutoSpanColumn(FFocusedColumn, FFocusedNode); if Context > NoColumn then @@ -7024,7 +7331,8 @@ procedure TBaseVirtualTree.WMKeyDown(var Message: TWMKeyDown); begin // other special cases Context := NoColumn; - if (toExtendedFocus in FOptions.SelectionOptions) and (toGridExtensions in FOptions.MiscOptions) then + if ((toExtendedFocus in FOptions.SelectionOptions) and (toGridExtensions in FOptions.MiscOptions)) or + LCellSelectionEnabled then begin Context := getNextVisibleAutoSpanColumn(FFocusedColumn, FFocusedNode); if Context > NoColumn then @@ -7111,7 +7419,7 @@ procedure TBaseVirtualTree.WMKeyDown(var Message: TWMKeyDown); // Clear old selection if required but take care to select the new focused node if it was not selected before. ForceSelection := False; - if ClearPending and ((LastFocused <> FFocusedNode) or (FSelectionCount <> 1)) then + if ClearPending and ((LastFocusedNode <> FFocusedNode) or (FSelectionCount <> 1)) then begin ClearSelection(not Assigned(FFocusedNode)); ForceSelection := True; @@ -7120,22 +7428,33 @@ procedure TBaseVirtualTree.WMKeyDown(var Message: TWMKeyDown); // Determine new selection anchor. if Shift = [] then begin + // Node-level anchor FRangeAnchor := FFocusedNode; FLastSelectionLevel := GetNodeLevelForSelectConstraint(FFocusedNode); + // Cell-level anchor + FCellRangeAnchor.Node := FFocusedNode; + FCellRangeAnchor.Column := FFocusedColumn; + end else + if (ssShift in Shift) and LCellSelectionEnabled then + begin + // multicell support / select multiple cells + SelectedCell := TVTCell.Create(FFocusedNode, FFocusedColumn); + OldCell := FCellRangeAnchor; + SelectCells(OldCell, SelectedCell, True); end; if Assigned(FFocusedNode) then begin - // Finally change the selection for a specific range of nodes. - if DoRangeSelect then - ToggleSelection(LastFocused, FFocusedNode) - // Make sure the new focused node is also selected. - else if (LastFocused <> FFocusedNode) then begin - if ForceSelection then - AddToSelection(FFocusedNode, False) - else - ToggleSelection(LastFocused, FFocusedNode); // See issue #926 - end; + // Finally change the selection for a specific range of nodes. + if DoRangeSelect then + ToggleSelection(LastFocusedNode, FFocusedNode) + // Make sure the new focused node is also selected. + else if (LastFocusedNode <> FFocusedNode) then begin + if ForceSelection then + AddToSelection(FFocusedNode, False) + else + ToggleSelection(LastFocusedNode, FFocusedNode); // See issue #926 + end; end; // If a repaint is needed then paint the entire tree because of the ClearSelection call, @@ -7735,7 +8054,7 @@ procedure TBaseVirtualTree.WMRButtonUp(var Message: TWMRButtonUp); HitInfo: THitInfo; begin - DoStateChange([], [tsPopupMenuShown, tsRightButtonDown]); + DoStateChange([], [tsRightButtonDown]); if FHeader.States = [] then begin @@ -7756,8 +8075,6 @@ procedure TBaseVirtualTree.WMRButtonUp(var Message: TWMRButtonUp); if toRightClickSelect in FOptions.SelectionOptions then HandleMouseUp(Message, HitInfo); - if not Assigned(PopupMenu) then - DoPopupMenu(HitInfo.HitNode, HitInfo.HitColumn, Point(Message.XPos, Message.YPos)); end; end; @@ -7912,6 +8229,9 @@ procedure TBaseVirtualTree.WMTimer(var Message: TWMTimer); ChangeTimer: if tsChangePending in FStates then // see issue #602 DoChange(FLastChangedNode); + ChangeCellTimer: + if tsChangeCellPending in FStates then + DoChangeCell(FSelectedCells); StructureChangeTimer: DoStructureChange(FLastStructureChangeNode, FLastStructureChangeReason); SearchTimer: @@ -8200,6 +8520,16 @@ procedure TBaseVirtualTree.AdviseChangeEvent(StructureChange: Boolean; Node: PVi //---------------------------------------------------------------------------------------------------------------------- +procedure TBaseVirtualTree.AdviseChangeCellEvent(const Cells: TVTCellArray); +begin + if tsChangeCellPending in FStates then + StopTimer(ChangeCellTimer) + else + DoStateChange([tsChangeCellPending]); +end; + +//---------------------------------------------------------------------------------------------------------------------- + function TBaseVirtualTree.AllocateInternalDataArea(Size: Cardinal): Cardinal; // Simple registration method to be called by each descendant to claim their internal data area. @@ -8397,6 +8727,21 @@ procedure TBaseVirtualTree.Change(Node: PVirtualNode); //---------------------------------------------------------------------------------------------------------------------- +procedure TBaseVirtualTree.ChangeCell(const Cells: TVTCellArray); +begin + AdviseChangeCellEvent(Cells); + + if FUpdateCount = 0 then + begin + if (FChangeDelay > 0) and HandleAllocated and not (tsSynchMode in FStates) then + SetTimer(Handle, ChangeCellTimer, FChangeDelay, nil) + else + DoChangeCell(Cells); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + procedure TBaseVirtualTree.ChangeScale(M, D: Integer{$if CompilerVersion >= 31}; isDpiChange: Boolean{$ifend}); begin if (M <> D) then @@ -9320,9 +9665,7 @@ function TBaseVirtualTree.DetermineScrollDirections(X, Y: TDimension): TScrollDi // yet elapsed. if ((Int64(timeGetTime) - FDragScrollStart) < FAutoScrollDelay) then Result := []; - end - else - OutputDebugString('Ooops'); + end; end; end; end; @@ -9499,17 +9842,20 @@ function TBaseVirtualTree.DoEndEdit(pCancel: Boolean = False): Boolean; DoStateChange([], [tsEditPending]); if not (tsEditing in FStates) then Exit(True); + DoStateChange([], [tsEditing]); if pCancel then - Result := FEditLink.CancelEdit + begin + Result := FEditLink.CancelEdit(); + if Result and Assigned(FOnEditCancelled) then + FOnEditCancelled(Self, FEditColumn); + end else - Result := FEditLink.EndEdit; - if Result then begin - DoStateChange([], [tsEditing]); - FEditLink := nil; - if Assigned(FOnEdited) then + Result := FEditLink.EndEdit; + if Result and Assigned(FOnEdited) then FOnEdited(Self, FFocusedNode, FEditColumn); end; + FEditLink := nil; TrySetFocus(); end; @@ -9549,6 +9895,18 @@ procedure TBaseVirtualTree.DoChange(Node: PVirtualNode); //---------------------------------------------------------------------------------------------------------------------- +procedure TBaseVirtualTree.DoChangeCell(const Cells: TVTCellArray); +begin + StopTimer(ChangeCellTimer); + if Assigned(FOnChangeCell) then + begin + FOnChangeCell(Self, Cells); + end; + DoStateChange([], [tsChangeCellPending]); +end; + +//---------------------------------------------------------------------------------------------------------------------- + procedure TBaseVirtualTree.DoCheckClick(Node: PVirtualNode; NewCheckState: TCheckState); begin @@ -9926,6 +10284,7 @@ procedure TBaseVirtualTree.DoEdit; if Assigned(FFocusedNode) and not (vsDisabled in FFocusedNode.States) and not (toReadOnly in FOptions.MiscOptions) and (FEditLink = nil) then begin + InternalSetFocusedColumn(FEditColumn); ScrollIntoView(FFocusedNode, toCenterScrollIntoView in FOptions.SelectionOptions, not (toDisableAutoscrollOnEdit in FOptions.AutoOptions)); FEditLink := DoCreateEditor(FFocusedNode, FEditColumn); if Assigned(FEditLink) then @@ -11827,7 +12186,7 @@ function TBaseVirtualTree.GetImageSize(Node: PVirtualNode; Kind: TVTImageKind = Index := -1; Ghosted := False; lImageList := DoGetImageIndex(Node, Kind, Column, Ghosted, Index); - if Index >= 0 then begin + if (Index > NoImage) or (Index = EmptyImage) then begin if IncludePadding then Result.cx := lImageList.Width + ScaledPixels(2) else @@ -12373,6 +12732,7 @@ procedure TBaseVirtualTree.HandleMouseDown(var Message: TWMMouse; var HitInfo: T AltPressed: Boolean; // Pressing the Alt key enables special processing for selection. FullRowDrag: Boolean; // Start dragging anywhere within a node's bound. NodeRect: TRect; + LCellSelectionEnabled: Boolean; //--------------- local functions ------------------------------------------- @@ -12409,6 +12769,9 @@ procedure TBaseVirtualTree.HandleMouseDown(var Message: TWMMouse; var HitInfo: T //--------------- end local functions --------------------------------------- +var + CellClickHandled: Boolean; + ClickedCell: TVTCell; begin if tsPanning in FStates then begin @@ -12481,6 +12844,10 @@ 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. // We initialize shorthand variables to avoid the following expressions getting too large // and to avoid repeative expensive checks. @@ -12490,11 +12857,22 @@ procedure TBaseVirtualTree.HandleMouseDown(var Message: TWMMouse; var HitInfo: T IsCellHit := not IsLabelHit and Assigned(HitInfo.HitNode) and ([hiOnItemButton, hiOnItemCheckBox, hiNoWhere] * HitInfo.HitPositions = []) and ((toFullRowSelect in FOptions.SelectionOptions) or - ((toGridExtensions in FOptions.MiscOptions) and (HitInfo.HitColumn > NoColumn))); + ((toGridExtensions in FOptions.MiscOptions) and (HitInfo.HitColumn > NoColumn))) or + (LCellSelectionEnabled and (HitInfo.HitColumn > NoColumn)); IsAnyHit := IsLabelHit or IsCellHit; MultiSelect := toMultiSelect in FOptions.SelectionOptions; ShiftEmpty := ShiftState = []; + + // Early anchor set for plain clicks helps avoid race where + // later handlers see the anchor as nil and fall back to the first cell. + if ShiftEmpty and + (LCellSelectionEnabled and Assigned(HitInfo.HitNode) and (Column > NoColumn)) then + begin + InternalClearCellSelection; + FCellRangeAnchor.Node := HitInfo.HitNode; + FCellRangeAnchor.Column := Column; + end; NodeSelected := IsAnyHit and (vsSelected in HitInfo.HitNode.States); // Determine the Drag behavior. @@ -12600,7 +12978,7 @@ procedure TBaseVirtualTree.HandleMouseDown(var Message: TWMMouse; var HitInfo: T if NeedChangeEvent then begin Invalidate; - Change(nil); + Change(HitInfo.HitNode); end; end else if (toAlwaysSelectNode in Self.TreeOptions.SelectionOptions) then @@ -12613,7 +12991,7 @@ procedure TBaseVirtualTree.HandleMouseDown(var Message: TWMMouse; var HitInfo: T end else ClearSelection(False); - end; + end; // pending node edit if Focused and @@ -12669,11 +13047,24 @@ procedure TBaseVirtualTree.HandleMouseDown(var Message: TWMMouse; var HitInfo: T HandleClickSelection(LastFocused, HitInfo.HitNode, ShiftState, AutoDrag) else begin + CellClickHandled := False; if ShiftEmpty then FRangeAnchor := HitInfo.HitNode; - // If the hit node is not yet selected then do it now. - if not NodeSelected then + // If a column was hit on a plain click, clear existing cell selection and select the clicked cell. + // !!! MultiSelect <> LCellSelectionEnabled, not interchangeable !!! + if ShiftEmpty and LCellSelectionEnabled and Assigned(HitInfo.HitNode) and (Column > NoColumn) then + begin + InternalClearCellSelection; + ClickedCell.Node := HitInfo.HitNode; + ClickedCell.Column := Column; + AddToCellSelection(ClickedCell, True); + FCellRangeAnchor := ClickedCell; + CellClickHandled := True; + end; + + // If the hit node is not yet selected then do it now (unless we already handled the cell click) + if (not CellClickHandled) and (not NodeSelected) then AddToSelection(HitInfo.HitNode, True); end; @@ -13455,6 +13846,21 @@ procedure TBaseVirtualTree.InvalidateCache; //---------------------------------------------------------------------------------------------------------------------- +procedure TBaseVirtualTree.MarkCutCopyCells; +var + I: Integer; + LCell: TVTCell; +begin + // Mark that the node is included in cut/copy for multicell + for I := 0 to FSelectedCellCount - 1 do + begin + LCell := FSelectedCells[I]; + Include(LCell.Node.States, vsCutOrCopy); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + procedure TBaseVirtualTree.MarkCutCopyNodes; // Sets the vsCutOrCopy style in every currently selected but not disabled node to indicate it is @@ -14281,7 +14687,10 @@ procedure TBaseVirtualTree.PrepareCell(var PaintInfo: TVTPaintInfo; WindowOrgX, begin Brush.Color := Items[Column].GetEffectiveColor; FillRect(CellRect); - end; + end + else + Brush.Color := FColors.BackGroundColor; + // Let the application customize the cell background and the content rectangle. DoBeforeCellPaint(Canvas, Node, Column, cpmPaint, CellRect, ContentRect); @@ -14307,14 +14716,20 @@ procedure TBaseVirtualTree.PrepareCell(var PaintInfo: TVTPaintInfo; WindowOrgX, end; end; - if (Column = FFocusedColumn) or (toFullRowSelect in FOptions.SelectionOptions) then + // If this specific cell is selected, highlight the whole cell area + // (including empty space up to the next column) even when grid + // extensions are not enabled. + if InternalIsCellSelected(Node, Column) then + InnerRect := CellRect; + + if (Column = FFocusedColumn) or (toFullRowSelect in FOptions.SelectionOptions) or InternalIsCellSelected(Node, Column) then begin // Fill the selection rectangle. if poDrawSelection in PaintOptions then begin if Node = FDropTargetNode then begin - if (FLastDropMode = dmOnNode) or (vsSelected in Node.States) then + if (FLastDropMode = dmOnNode) or (vsSelected in Node.States) or InternalIsCellSelected(Node, Column) then begin Brush.Color := FColors.DropTargetColor; Pen.Color := FColors.DropTargetBorderColor; @@ -14337,7 +14752,7 @@ procedure TBaseVirtualTree.PrepareCell(var PaintInfo: TVTPaintInfo; WindowOrgX, end; end else - if vsSelected in Node.States then + if (vsSelected in Node.States) or InternalIsCellSelected(Node, Column) then begin if Focused or (toPopupMode in FOptions.PaintOptions) then begin @@ -14368,10 +14783,10 @@ procedure TBaseVirtualTree.PrepareCell(var PaintInfo: TVTPaintInfo; WindowOrgX, end; end; - if (tsUseExplorerTheme in FStates) and (toHotTrack in FOptions.PaintOptions) and (Node = FCurrentHotNode) and + if (tsUseExplorerTheme in FStates) and (toHotTrack in FOptions.PaintOptions) and (Node = FCurrentHotNode) and ((Column = FCurrentHotColumn) or (toFullRowSelect in FOptions.SelectionOptions)) then - DrawBackground(IfThen((vsSelected in Node.States) and not (toAlwaysHideSelection in FOptions.PaintOptions), - TREIS_HOTSELECTED, TREIS_HOT)); + DrawBackground(IfThen(((vsSelected in Node.States) or InternalIsCellSelected(Node, Column)) and not (toAlwaysHideSelection in FOptions.PaintOptions), + TREIS_HOTSELECTED, TREIS_HOT)); if (Column = FFocusedColumn) or (toFullRowSelect in FOptions.SelectionOptions) then begin @@ -14403,7 +14818,7 @@ procedure TBaseVirtualTree.PrepareCell(var PaintInfo: TVTPaintInfo; WindowOrgX, if (tsUseExplorerTheme in FStates) then begin //Draw focused unselected style like Windows 7 Explorer - if not (vsSelected in Node.States) then + if not ((vsSelected in Node.States) or InternalIsCellSelected(Node, Column)) then DrawThemedFocusRect(LIS_NORMAL) else DrawBackground(TREIS_HOTSELECTED); @@ -15147,6 +15562,434 @@ procedure TBaseVirtualTree.UnselectNodes(StartNode, EndNode: PVirtualNode); //---------------------------------------------------------------------------------------------------------------------- +function TBaseVirtualTree.InternalAddToCellSelection(const Cell: TVTCell; ForceInsert: Boolean): Boolean; +var + i: Integer; +begin + Result := False; + + // prevent duplicates + for i := 0 to FSelectedCellCount - 1 do + if (FSelectedCells[i].Node = Cell.Node) and (FSelectedCells[i].Column = Cell.Column) then + Exit; + + if FSelectedCellCount = Length(FSelectedCells) then + SetLength(FSelectedCells, FSelectedCellCount + 16); + + Header.Columns[Cell.Column].Options := Header.Columns[Cell.Column].Options + + [coMulticellSelected]; + + FSelectedCells[FSelectedCellCount] := Cell; + Inc(FSelectedCellCount); + Result := True; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.InternalRemoveFromCellSelection(const Cell: TVTCell); +var + i, j: Integer; +begin + for i := 0 to FSelectedCellCount - 1 do + if (FSelectedCells[i].Node = Cell.Node) and (FSelectedCells[i].Column = Cell.Column) then + begin + Header.Columns[Cell.Column].Options := + Header.Columns[Cell.Column].Options - [coMulticellSelected]; + // shift remaining + for j := i to FSelectedCellCount - 2 do + FSelectedCells[j] := FSelectedCells[j + 1]; + Dec(FSelectedCellCount); + Exit; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.InternalClearCellSelection; +var + i: Integer; + LColumnIndex: TColumnIndex; +begin + // Invalidate all previously selected cells so their selection highlight is erased + for i := 0 to FSelectedCellCount - 1 do + begin + LColumnIndex := FSelectedCells[i].Column; + FHeader.Columns[LColumnIndex].Options := + FHeader.Columns[LColumnIndex].Options - [coMulticellSelected]; + + if Assigned(FSelectedCells[i].Node) then + InvalidateNode(FSelectedCells[i].Node) + else + InvalidateColumn(FSelectedCells[i].Column); + end; + SetLength(FSelectedCells, 0); + FSelectedCellCount := 0; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.IsCellSelectionEnabled: Boolean; +begin + Result := (toMultiSelect in FOptions.SelectionOptions) and + (toMultiCellSelect in FOptions.SelectionOptions) and + (toExtendedFocus in FOptions.SelectionOptions) and + not (toFullRowSelect in FOptions.SelectionOptions); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.AddToCellSelection(const Cell: TVTCell; ForceInsert: Boolean); +begin + if FSelectionLocked or not IsCellSelectionEnabled then + Exit; + if InternalAddToCellSelection(Cell, ForceInsert) then + begin + if Assigned(Cell.Node) then + InvalidateNode(Cell.Node) + else + InvalidateColumn(Cell.Column); + ChangeCell(FSelectedCells); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.RemoveFromCellSelection(const Cell: TVTCell); +begin + if FSelectionLocked or not IsCellSelectionEnabled then + Exit; + InternalRemoveFromCellSelection(Cell); + if Assigned(Cell.Node) then + InvalidateNode(Cell.Node) + else + InvalidateColumn(Cell.Column); + ChangeCell(FSelectedCells); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.InternalIsCellSelected(Node: PVirtualNode; Column: TColumnIndex): Boolean; +var + i: Integer; +begin + for i := 0 to FSelectedCellCount - 1 do + if (FSelectedCells[i].Node = Node) and (FSelectedCells[i].Column = Column) then + Exit(True); + Result := False; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +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 + StartCell.Node := FRoot.FirstChild; + + // Normalize end cell + Assert(Assigned(EndCell.Node), 'EndCell.Node must not be nil!'); + + // Determine node order + if CompareNodePositions(StartCell.Node, EndCell.Node) < 0 then + begin + NodeFrom := StartCell.Node; + NodeTo := EndCell.Node; + end + else + begin + NodeFrom := EndCell.Node; + NodeTo := StartCell.Node; + end; + + // Determine column order + ColFrom := StartCell.Column; + ColTo := EndCell.Column; + if ColFrom = NoColumn then ColFrom := FHeader.MainColumn; + if ColTo = NoColumn then ColTo := FHeader.MainColumn; + + 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) + 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 + 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; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.InternalUnselectCells(StartCell, EndCell: TVTCell); +var + NodeFrom, NodeTo, NodeIter: PVirtualNode; + ColFrom, ColTo, ColIter: TColumnIndex; + ColNext: TColumnIndex; + TempCell: TVTCell; +begin + if StartCell.Node = nil then + StartCell.Node := FRoot.FirstChild; + + Assert(Assigned(EndCell.Node), 'EndCell.Node must not be nil!'); + + if CompareNodePositions(StartCell.Node, EndCell.Node) < 0 then + begin + NodeFrom := StartCell.Node; + NodeTo := EndCell.Node; + end + else + begin + NodeFrom := EndCell.Node; + NodeTo := StartCell.Node; + end; + + ColFrom := StartCell.Column; + ColTo := EndCell.Column; + if ColFrom = NoColumn then ColFrom := FHeader.MainColumn; + if ColTo = NoColumn then ColTo := FHeader.MainColumn; + + NodeIter := NodeFrom; + while NodeIter <> NodeTo do + begin + if ColFrom <= ColTo then + begin + ColIter := ColFrom; + repeat + begin + TempCell.Node := NodeIter; TempCell.Column := ColIter; + InternalRemoveFromCellSelection(TempCell); + 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; + InternalRemoveFromCellSelection(TempCell); + end; + ColNext := FHeader.Columns.GetPreviousVisibleColumn(ColIter); + if ColIter = ColTo then + Break; + ColIter := ColNext; + until ColIter = InvalidColumn; + end; + NodeIter := GetNextVisible(NodeIter, True); + end; + // last node + if Assigned(NodeTo) then + begin + if ColFrom <= ColTo then + begin + ColIter := ColFrom; + repeat + begin + TempCell.Node := NodeTo; TempCell.Column := ColIter; + InternalRemoveFromCellSelection(TempCell); + 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; + InternalRemoveFromCellSelection(TempCell); + end; + ColNext := FHeader.Columns.GetPreviousVisibleColumn(ColIter); + if ColIter = ColTo then + Break; + ColIter := ColNext; + until ColIter = InvalidColumn; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.ToggleCellSelection(StartCell, EndCell: TVTCell); +var + NodeFrom, NodeTo, NodeIter: PVirtualNode; + ColFrom, ColTo, ColIter: TColumnIndex; + ColNext: TColumnIndex; + TempCell: TVTCell; + Found: Boolean; + i: Integer; +begin + if FSelectionLocked or not IsCellSelectionEnabled then + Exit; + + if StartCell.Node = nil then + StartCell.Node := FRoot.FirstChild; + + Assert(Assigned(EndCell.Node), 'EndCell.Node must not be nil!'); + + if CompareNodePositions(StartCell.Node, EndCell.Node) < 0 then + begin + NodeFrom := StartCell.Node; + NodeTo := EndCell.Node; + end + else + begin + NodeFrom := EndCell.Node; + NodeTo := StartCell.Node; + end; + + ColFrom := StartCell.Column; + ColTo := EndCell.Column; + if ColFrom = NoColumn then ColFrom := FHeader.MainColumn; + if ColTo = NoColumn then ColTo := FHeader.MainColumn; + + NodeIter := NodeFrom; + while NodeIter <> NodeTo do + begin + if ColFrom <= ColTo then + begin + ColIter := ColFrom; + repeat + TempCell.Node := NodeIter; TempCell.Column := ColIter; + Found := False; + for i := 0 to FSelectedCellCount - 1 do + if (FSelectedCells[i].Node = TempCell.Node) and (FSelectedCells[i].Column = TempCell.Column) then + begin + InternalRemoveFromCellSelection(TempCell); + Found := True; + Break; + end; + if not Found then + InternalAddToCellSelection(TempCell, True); + ColNext := FHeader.Columns.GetNextVisibleColumn(ColIter); + if ColIter = ColTo then + Break; + ColIter := ColNext; + until ColIter = InvalidColumn; + end + else + begin + ColIter := ColFrom; + repeat + TempCell.Node := NodeIter; TempCell.Column := ColIter; + Found := False; + for i := 0 to FSelectedCellCount - 1 do + if (FSelectedCells[i].Node = TempCell.Node) and (FSelectedCells[i].Column = TempCell.Column) then + begin + InternalRemoveFromCellSelection(TempCell); + Found := True; + Break; + end; + if not Found then + InternalAddToCellSelection(TempCell, True); + ColNext := FHeader.Columns.GetPreviousVisibleColumn(ColIter); + if ColIter = ColTo then + Break; + ColIter := ColNext; + until ColIter = InvalidColumn; + end; + NodeIter := GetNextVisible(NodeIter, True); + end; + // last node + if Assigned(NodeTo) then + begin + if ColFrom <= ColTo then + begin + ColIter := ColFrom; + repeat + TempCell.Node := NodeTo; TempCell.Column := ColIter; + Found := False; + for i := 0 to FSelectedCellCount - 1 do + if (FSelectedCells[i].Node = TempCell.Node) and (FSelectedCells[i].Column = TempCell.Column) then + begin + InternalRemoveFromCellSelection(TempCell); + Found := True; + Break; + end; + if not Found then + InternalAddToCellSelection(TempCell, True); + ColNext := FHeader.Columns.GetNextVisibleColumn(ColIter); + if ColIter = ColTo then + Break; + ColIter := ColNext; + until ColIter = InvalidColumn; + end + else + begin + ColIter := ColFrom; + repeat + TempCell.Node := NodeTo; TempCell.Column := ColIter; + Found := False; + for i := 0 to FSelectedCellCount - 1 do + if (FSelectedCells[i].Node = TempCell.Node) and (FSelectedCells[i].Column = TempCell.Column) then + begin + InternalRemoveFromCellSelection(TempCell); + Found := True; + Break; + end; + if not Found then + InternalAddToCellSelection(TempCell, True); + ColNext := FHeader.Columns.GetPreviousVisibleColumn(ColIter); + if ColIter = ColTo then + Break; + ColIter := ColNext; + until ColIter = InvalidColumn; + end; + end; + + DoChangeCell(FSelectedCells); +end; + +//---------------------------------------------------------------------------------------------------------------------- + procedure TBaseVirtualTree.UpdateColumnCheckState(Col: TVirtualTreeColumn); var NewCheckState: TCheckState; @@ -15898,6 +16741,7 @@ procedure TBaseVirtualTree.Clear; DoStateChange([], ClipboardStates); end; ClearSelection; + ClearCellSelection; FFocusedNode := nil; FLastSelected := nil; FCurrentHotNode := nil; @@ -19196,6 +20040,20 @@ function TBaseVirtualTree.NoInitNodes(ConsiderChildrenAbove: Boolean): TVTVirtua //---------------------------------------------------------------------------------------------------------------------- +function TBaseVirtualTree.SelectedCells: TVTCellArray; +begin + if FSelectedCellCount = 0 then + Result := [] else + begin + // Makes a copy of the selected cells, so the actual selected array + // cannot be changed + Result := Copy(FSelectedCells); + SetLength(Result, FSelectedCellCount); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + function TBaseVirtualTree.SelectedNodes(ConsiderChildrenAbove: Boolean): TVTVirtualNodeEnumeration; // Enumeration for selected nodes @@ -19841,7 +20699,11 @@ function TBaseVirtualTree.IterateSubtree(StartNode: PVirtualNode; Callback: TVTG Abort := False; Result := StartNode; if Result = nil then - Stop := nil + begin + Stop := nil; + // Use first node if we start with the root. + Result := GetFirstNoInit; + end else begin if not (vsInitialized in Result.States) and DoInit then @@ -19862,21 +20724,17 @@ function TBaseVirtualTree.IterateSubtree(StartNode: PVirtualNode; Callback: TVTG end; end; - // Use first node if we start with the root. - if Result = nil then - Result := GetFirstNoInit; - if Assigned(Result) then begin if not (vsInitialized in Result.States) and DoInit then InitNode(Result); // Skip given node if only the child nodes are requested. - if ChildNodesOnly then + if ChildNodesOnly and (StartNode <> nil ) then begin if Result.ChildCount = 0 then Result := nil - else if StartNode <> nil then + else Result := GetNextNode(Result); end; @@ -20622,7 +21480,6 @@ procedure TBaseVirtualTree.PaintTree(TargetCanvas: TCanvas; Window: TRect; Targe ((Column = FEditColumn) or not UseColumns)) then DoPaintNode(PaintInfo); - Canvas.Brush.Color := FColors.BackGroundColor; // Set useful background color, see issue #1264 DoAfterCellPaint(Canvas, Node, Column, CellRect); end; end; diff --git a/Source/VirtualTrees.DrawTree.pas b/Source/VirtualTrees.DrawTree.pas index 284cbf212..0fb1e38d4 100644 --- a/Source/VirtualTrees.DrawTree.pas +++ b/Source/VirtualTrees.DrawTree.pas @@ -40,7 +40,9 @@ TCustomVirtualDrawTree = class(TVTAncestor) property OnGetNodeWidth: TVTGetNodeWidthEvent read FOnGetNodeWidth write FOnGetNodeWidth; end; + {$if CompilerVersion >= 33} [ComponentPlatformsAttribute(pfidWindows)] + {$ifend} TVirtualDrawTree = class(TCustomVirtualDrawTree) private function GetOptions: TVirtualTreeOptions; diff --git a/Source/VirtualTrees.Export.pas b/Source/VirtualTrees.Export.pas index 2bfb985c8..1a68df64a 100644 --- a/Source/VirtualTrees.Export.pas +++ b/Source/VirtualTrees.Export.pas @@ -46,7 +46,7 @@ function ContentToHTML(Tree: TCustomVirtualStringTree; Source: TVSTTextSourceTyp // Renders the current tree content (depending on Source) as HTML text encoded in UTF-8. // If Caption is not empty then it is used to create and fill the header for the table built here. -// Based on ideas and code from Frank van den Bergh and Andreas H�rstemeier. +// Based on ideas and code from Frank van den Bergh and Andreas Hörstemeier. var Buffer: TBufferedString; @@ -142,6 +142,7 @@ function ContentToHTML(Tree: TCustomVirtualStringTree; Source: TVSTTextSourceTyp CellPadding: String; CrackTree: TCustomVirtualStringTreeCracker; lGetCellTextEventArgs: TVSTGetCellTextEventArgs; + MulticellSelected: Boolean; // multicell support begin CrackTree := TCustomVirtualStringTreeCracker(Tree); @@ -221,11 +222,16 @@ function ContentToHTML(Tree: TCustomVirtualStringTree; Source: TVSTTextSourceTyp Columns := nil; ColumnColors := nil; RenderColumns := CrackTree.Header.UseColumns; - if RenderColumns then + // begin multicell + MulticellSelected := CrackTree.Header.Columns.HasMulticellSelection; + if RenderColumns or MulticellSelected then begin Columns := CrackTree.Header.Columns.GetVisibleColumns; + if CrackTree.GetSelectedCellCount > 0 then + Columns := CrackTree.Header.Columns.GetSelectedCellColumns; SetLength(ColumnColors, Length(Columns)); end; + // end multicell support CrackTree.GetRenderStartValues(Source, Run, GetNextNode); Save := Run; @@ -599,6 +605,7 @@ function ContentToRTF(Tree: TCustomVirtualStringTree; Source: TVSTTextSourceType LocaleBuffer: array [0..1] of Char; CrackTree: TCustomVirtualStringTreeCracker; lGetCellTextEventArgs: TVSTGetCellTextEventArgs; + MulticellSelected: Boolean; // multicell support begin CrackTree := TCustomVirtualStringTreeCracker(Tree); @@ -620,8 +627,15 @@ function ContentToRTF(Tree: TCustomVirtualStringTree; Source: TVSTTextSourceType LastLevel := 0; RenderColumns := CrackTree.Header.UseColumns; - if RenderColumns then + // begin multicell + MulticellSelected := CrackTree.Header.Columns.HasMulticellSelection; + if RenderColumns or MulticellSelected then + begin Columns := CrackTree.Header.Columns.GetVisibleColumns; + if CrackTree.GetSelectedCellCount > 0 then + Columns := CrackTree.Header.Columns.GetSelectedCellColumns; + end; + // end multicell support CrackTree.GetRenderStartValues(Source, Run, GetNextNode); Save := Run; @@ -839,6 +853,7 @@ function ContentToUnicodeString(Tree: TCustomVirtualStringTree; Source: TVSTText I: Integer; CrackTree: TCustomVirtualStringTreeCracker; lGetCellTextEventArgs: TVSTGetCellTextEventArgs; + MulticellSelected: Boolean; begin CrackTree := TCustomVirtualStringTreeCracker(Tree); @@ -848,8 +863,19 @@ function ContentToUnicodeString(Tree: TCustomVirtualStringTree; Source: TVSTText try Columns := nil; RenderColumns := CrackTree.Header.UseColumns; - if RenderColumns then + MulticellSelected := CrackTree.Header.Columns.HasMulticellSelection; + + // begin multicell + if RenderColumns or MulticellSelected then + begin Columns := CrackTree.Header.Columns.GetVisibleColumns; + // multicell support + if CrackTree.GetSelectedCellCount > 0 then + begin + Columns := CrackTree.Header.Columns.GetSelectedCellColumns; + end; + end; + // end multicell support CrackTree.GetRenderStartValues(Source, Run, GetNextNode); Save := Run; diff --git a/Source/VirtualTrees.Header.pas b/Source/VirtualTrees.Header.pas index 440de4a39..9d74abd59 100644 --- a/Source/VirtualTrees.Header.pas +++ b/Source/VirtualTrees.Header.pas @@ -259,6 +259,11 @@ TVirtualTreeColumns = class(TCollection) function GetPreviousVisibleColumn(Column : TColumnIndex; ConsiderAllowFocus : Boolean = False) : TColumnIndex; function GetScrollWidth : TDimension; function GetVisibleColumns : TColumnsArray; + + // multicell support + function GetSelectedCellColumns: TColumnsArray; + function HasMulticellSelection: Boolean; + function GetVisibleFixedWidth : TDimension; function IsValidColumn(Column : TColumnIndex) : Boolean; procedure LoadFromStream(const Stream : TStream; Version : Integer); @@ -334,6 +339,8 @@ TVTHeader = class(TPersistent) FRestoreSelectionColumnIndex : Integer; //The column that is used to implement the coRestoreSelection option FWasDoubleClick : Boolean; // The previous mouse message was for a double click, that allows us to process mouse-up-messages differently function GetMainColumn : TColumnIndex; + function GetSortColumn: TColumnIndex; // Getter for the property SortColumn + function GetSortDirection: TSortDirection; // Getter for the property SortDirection function GetUseColumns : Boolean; function IsFontStored : Boolean; procedure SetAutoSizeIndex(Value : TColumnIndex); @@ -437,8 +444,8 @@ TVTHeader = class(TPersistent) 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 SortColumn : TColumnIndex read GetSortColumn write SetSortColumn default NoColumn; + property SortDirection : TSortDirection read GetSortDirection write SetSortDirection default sdAscending; property SplitterHitTolerance : TDimension 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; @@ -461,6 +468,9 @@ implementation VirtualTrees.BaseAncestorVcl, // to eliminate H2443 about inline expanding VirtualTrees.DataObject; +resourcestring + SConstraintsNotAllowed = 'Cannot set mininum constraints when there are no columns!'; + type TVirtualTreeColumnsCracker = class(TVirtualTreeColumns); TVirtualTreeColumnCracker = class(TVirtualTreeColumn); @@ -1260,11 +1270,28 @@ procedure TVTHeader.FixedAreaConstraintsChanged(Sender : TObject); //This method gets called when FFixedAreaConstraints is changed. + function HasFixedColumns: LongBool; + var + I: Integer; + begin + Result := False; + for I := 0 to Columns.Count-1 do + begin + if coFixed in Columns[I].Options then + Exit(True); + end; + end; + begin if Tree.HandleAllocated then RescaleHeader else Include(FStates, hsNeedScaling); + if (FixedAreaConstraints.MinWidthPercent > 0) and not HasFixedColumns then + begin + FixedAreaConstraints.FMinWidthPercent := 0; + raise EVirtualTreeError.CreateRes(PResStringRec(@SConstraintsNotAllowed)); + end; end; //---------------------------------------------------------------------------------------------------------------------- @@ -1310,6 +1337,16 @@ function TVTHeader.GetShiftState : TShiftState; Include(Result, ssAlt); end; +function TVTHeader.GetSortColumn: TColumnIndex; +begin + Exit(FSortColumn); // See issue #1319 +end; + +function TVTHeader.GetSortDirection: TSortDirection; +begin + Exit(FSortdirection); +end; + //---------------------------------------------------------------------------------------------------------------------- function TVTHeader.HandleHeaderMouseMove(var Message : TWMMouseMove) : Boolean; @@ -2046,16 +2083,38 @@ procedure TVTHeader.UpdateMainColumn(); //Called once the load process of the owner tree is done. +var + lOldMainColumn: TColumnIndex; + lNewMainColumn: TColumnIndex; 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 + + lOldMainColumn := FMainColumn; + + // Issue #1358: Prefer MainColumn to be on position 0 (where checkboxes/icons are) If position 0 is visible, use it; otherwise use first visible column + if (FColumns.Count > 0) and (coVisible in FColumns[0].Options) then + lNewMainColumn := 0 + else if (FMainColumn >= 0) and not (coVisible in Self.Columns[FMainColumn].Options) then //Issue #946: Choose new MainColumn if current one ist not visible - MainColumn := Self.Columns.GetFirstVisibleColumn(); - end + lNewMainColumn := Self.Columns.GetFirstVisibleColumn() + else + lNewMainColumn := FMainColumn; + + if (lNewMainColumn <> lOldMainColumn) and (lOldMainColumn >= 0) and (lOldMainColumn < FColumns.Count) and + (lNewMainColumn >= 0) and (lNewMainColumn < FColumns.Count) then + begin + if FColumns[lOldMainColumn].CheckBox then + begin + FColumns[lNewMainColumn].CheckBox := True; + FColumns[lOldMainColumn].CheckBox := False; + end; + end; + + if lNewMainColumn <> FMainColumn then + MainColumn := lNewMainColumn; end; //---------------------------------------------------------------------------------------------------------------------- @@ -2630,6 +2689,8 @@ function TVTHeader.ResizeColumns(ChangeBy : TDimension; RangeStartCol : TColumnI if MaxDelta < Abs(ChangeBy) then if not ReduceConstraints then Break; + if ColCount = 0 then // Fixes #1236: infinite loop + Break; until (MaxDelta >= Abs(ChangeBy)) or not (hsScaling in FStates); if ColCount = 0 then @@ -2712,7 +2773,7 @@ procedure TVTHeader.SaveToStream(const Stream : TStream); var Dummy : Integer; - DummyDimension: TDimension; + DummyDimension: TDimension; Tmp : AnsiString; begin @@ -3232,10 +3293,10 @@ procedure TVirtualTreeColumn.SetMinWidth(Value : TDimension); procedure TVirtualTreeColumn.SetOptions(Value : TVTColumnOptions); var - ToBeSet, - ToBeCleared : TVTColumnOptions; - VisibleChanged, - lParentColorSet : Boolean; + ToBeSet: TVTColumnOptions; + ToBeCleared: TVTColumnOptions; + lAppearanceChanged: Boolean; + lParentColorSet : Boolean; begin if FOptions <> Value then begin @@ -3243,8 +3304,10 @@ procedure TVirtualTreeColumn.SetOptions(Value : TVTColumnOptions); ToBeSet := Value - FOptions; FOptions := Value; + if coFixed in ToBeSet then + FOptions := FOptions - [coDraggable]; // issue #1314 - VisibleChanged := coVisible in (ToBeSet + ToBeCleared); + lAppearanceChanged := ([coVisible, coFixed, coStyleColor, coParentBidiMode, coWrapCaption] * (ToBeSet + ToBeCleared)) <> []; lParentColorSet := coParentColor in ToBeSet; if coParentBidiMode in ToBeSet then @@ -3258,18 +3321,19 @@ procedure TVirtualTreeColumn.SetOptions(Value : TVTColumnOptions); if coAutoSpring in ToBeSet then FSpringRest := 0; - if coVisible in ToBeCleared then - Header.UpdateMainColumn(); // Fixes issue #946 + // Update MainColumn when visibility changes + if (coVisible in ToBeCleared) or (coVisible in ToBeSet) then + Header.UpdateMainColumn(); // Fixes issue #946 and #1358 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 + if not (csLoading in TreeViewControl.ComponentState) and (lAppearanceChanged or lParentColorSet) and (Owner.UpdateCount = 0) and TreeViewControl.HandleAllocated then begin TreeViewControl.Invalidate(); - if VisibleChanged then + if lAppearanceChanged then begin TreeViewControl.DoColumnVisibilityChanged(Self.Index, coVisible in ToBeSet); TreeViewControl.UpdateHorizontalScrollBar(False); @@ -4535,7 +4599,12 @@ function TVirtualTreeColumns.HandleClick(P : TPoint; Button : TMouseButton; Forc end; if DblClick then - TreeViewControl.DoHeaderDblClick(HitInfo) + begin + TreeViewControl.DoHeaderDblClick(HitInfo); + // Fix for 1359: Fire DoHeaderClick so that checkbox state propagates to child nodes occurs. + if hhiOnCheckbox in HitInfo.HitPosition then + TreeViewControl.DoHeaderClick(HitInfo); + end else begin if (hoHeaderClickAutoSort in Header.Options) and (HitInfo.Button = TMouseButton.mbLeft) and not (hhiOnCheckbox in HitInfo.HitPosition) and (HitInfo.Column >= 0) then begin @@ -5279,6 +5348,42 @@ function TVirtualTreeColumns.GetPreviousVisibleColumn(Column : TColumnIndex; Con //---------------------------------------------------------------------------------------------------------------------- +function TVirtualTreeColumns.GetSelectedCellColumns : TColumnsArray; +var + LColumnIndex: TColumnIndex; +begin + Result := []; + LColumnIndex := GetFirstColumn; + if LColumnIndex = InvalidColumn then + Exit; + while LColumnIndex <> InvalidColumn do + begin + if coMulticellSelected in FHeader.Columns[LColumnIndex].Options then + Result := Result + [FHeader.Columns[LColumnIndex]]; + LColumnIndex := GetNextColumn(LColumnIndex); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVirtualTreeColumns.HasMulticellSelection: Boolean; +var + LColumnIndex: TColumnIndex; +begin + LColumnIndex := GetFirstColumn; + if LColumnIndex = InvalidColumn then + Exit(False); + while LColumnIndex <> InvalidColumn do + begin + if coMulticellSelected in FHeader.Columns[LColumnIndex].Options then + Exit(True); + LColumnIndex := GetNextColumn(LColumnIndex); + end; + Result := False; +end; + +//---------------------------------------------------------------------------------------------------------------------- + function TVirtualTreeColumns.GetVisibleColumns : TColumnsArray; // Returns a list of all currently visible columns in actual order. diff --git a/Source/VirtualTrees.Types.pas b/Source/VirtualTrees.Types.pas index 444563d10..ddf5c6a66 100644 --- a/Source/VirtualTrees.Types.pas +++ b/Source/VirtualTrees.Types.pas @@ -34,7 +34,11 @@ interface NoColumn = - 1; InvalidColumn = - 2; - // Indices for check state images used for checking. + // General constants for imagelists + NoImage = -1; // No image is avalable + EmptyImage = -2; // an empty image used as place holder + + // Indices for check state images in the imagelist used for displaying check-marks. ckEmpty = 0; // an empty image used as place holder // radio buttons ckRadioUncheckedNormal = 1; @@ -74,6 +78,7 @@ interface StructureChangeTimer = 6; SearchTimer = 7; ThemeChangedTimer = 8; + ChangeCellTimer = 9; ThemeChangedTimerDelay = 500; @@ -139,8 +144,7 @@ interface PDimension = ^Integer; TNodeHeight = NativeInt; TVTCursor = HCURSOR; - IDataObject= WinApi.ActiveX.IDataObject; - TVTDragDataObject = IDataObject; + TVTDragDataObject = WinApi.ActiveX.IDataObject; TVTBackground = TPicture; TVTPaintContext = HDC; TVTBrush = HBRUSH; @@ -256,7 +260,8 @@ TCheckStateHelper = record helper for TCheckState 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 + coStyleColor, // Prefer background color of VCL style over TVirtualTreeColumn.Color + coMulticellSelected // Indicates this column is selected as part of multicell ); TVTColumnOptions = set of TVTColumnOption; @@ -355,6 +360,7 @@ TSortDirectionHelper = record helper for VirtualTrees.Types.TSortDirection 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 and header height automatically according to the height of the used font. + // The property DefaultNodeHeight then has no effect. Use the property TextMargin to increase the row height. 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 @@ -370,7 +376,7 @@ TSortDirectionHelper = record helper for VirtualTrees.Types.TSortDirection 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. + toMultiSelect, // Allow more than one node/cell 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. @@ -384,7 +390,12 @@ TSortDirectionHelper = record helper for VirtualTrees.Types.TSortDirection 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. - toSelectNextNodeOnRemoval // If the selected node gets deleted, automatically select the next node. + toSelectNextNodeOnRemoval, // If the selected node gets deleted, automatically select the next node. + + /// + /// Enable multi-cell selection feature + /// + toMultiCellSelect ); TVTSelectionOptions = set of TVTSelectionOption; @@ -539,7 +550,8 @@ TSortDirectionHelper = record helper for VirtualTrees.Types.TSortDirection tsVCLDragFinished, // Flag to avoid triggering the OnColumnClick event twice tsPanning, // Mouse panning is active. tsWindowCreating, // Set during window handle creation to avoid frequent unnecessary updates. - tsUseExplorerTheme // The tree runs under WinVista+ and is using the explorer theme + tsUseExplorerTheme, // The tree runs under WinVista+ and is using the explorer theme + tsChangeCellPending // A cell selection change is pending. ); @@ -1014,6 +1026,16 @@ THitInfo = record ShiftState: TShiftState; end; + // A representation of a single cell (node + column) + PVTCell = ^TVTCell; + TVTCell = record + Node: PVirtualNode; + Column: TColumnIndex; + constructor Create(ANode: PVirtualNode; AColumn: TColumnIndex); + end; + + TVTCellArray = array of TVTCell; + TVTHeaderStyle = ( hsThickButtons, //TButton look and feel hsFlatButtons, //flatter look than hsThickButton, like an always raised flat TToolButton @@ -1494,10 +1516,17 @@ procedure TCustomVirtualTreeOptions.SetSelectionOptions(const Value : TVTSelecti if (toMultiSelect in (ToBeCleared + ToBeSet)) or ([toLevelSelectConstraint, toSiblingSelectConstraint] * ToBeSet <> []) then ClearSelection; + // Clear multicell selection when toFullRowSelect is going to be set or + // when a combination of toExtendedFocus, toMultiSelect, toMultiCellSelect is cleared + if (toFullRowSelect in ToBeSet) or ([toExtendedFocus, toMultiSelect, toMultiCellSelect] * ToBeCleared <> []) then + ClearCellSelection; + if (toExtendedFocus in ToBeCleared) and (FocusedColumn > 0) and HandleAllocated then begin FocusedColumn := Header.MainColumn; Invalidate; + // Also clear multicell selection when toExtendedFocus is removed + ClearCellSelection; end; if not (toExtendedFocus in FSelectionOptions) then @@ -1715,5 +1744,14 @@ function TSortDirectionHelper.ToInt() : Integer; Result := cSortDirectionToInt[Self]; end; +//---------------------------------------------------------------------------------------------------------------------- + +{ TVTCell } + +constructor TVTCell.Create(ANode: PVirtualNode; AColumn: TColumnIndex); +begin + Node := ANode; + Column := AColumn; +end; end. diff --git a/Source/VirtualTrees.Utils.pas b/Source/VirtualTrees.Utils.pas index f93f2fe03..cd276078c 100644 --- a/Source/VirtualTrees.Utils.pas +++ b/Source/VirtualTrees.Utils.pas @@ -37,7 +37,6 @@ interface Vcl.Controls, VirtualTrees.Types; - type /// /// Describes the mode how to blend pixels. @@ -594,7 +593,6 @@ function GetBitmapBitsFromDeviceContext(DC: HDC; var Width, Height: Integer): Po Assert(Result <> nil, 'Alpha blending DC error: no bitmap available.'); end; -//---------------------------------------------------------------------------------------------------------------------- procedure AlphaBlendLineConstant(Source, Destination: Pointer; Count: Integer; ConstantAlpha, Bias: Integer); @@ -604,7 +602,70 @@ procedure AlphaBlendLineConstant(Source, Destination: Pointer; Count: Integer; C // and 255 totally opaque (source pixel only). // Bias is an additional value which gets added to every component and must be in the range -128..127 // -{$ifdef CPUX64} + +{$IFNDEF ASSEMBLER} //new +var + Src, Dst: PCardinal; + i: Integer; + + S, D: Cardinal; + sB, sG, sR: Integer; + dB, dG, dR: Integer; + rB, rG, rR: Integer; +begin + Src := PCardinal(Source); + Dst := PCardinal(Destination); + + for i := 0 to Count - 1 do + begin + S := Src^; + D := Dst^; + + // Extract source components (BGRA) + sB := S and $FF; + sG := (S shr 8) and $FF; + sR := (S shr 16) and $FF; + + // Extract destination components (BGRA) + dB := D and $FF; + dG := (D shr 8) and $FF; + dR := (D shr 16) and $FF; + + // Blend: (alpha * (source - target) + 256 * target) / 256 + rB := (ConstantAlpha * (sB - dB) + (dB shl 8)) shr 8; + rG := (ConstantAlpha * (sG - dG) + (dG shl 8)) shr 8; + rR := (ConstantAlpha * (sR - dR) + (dR shl 8)) shr 8; + + // Bias handling: 0..255 -> -128..127 -> bias (saturated) -> 0..255 + rB := rB - 128 + Bias; + if rB < -128 then rB := -128 else + if rB > 127 then rB := 127; + rB := rB + 128; + + rG := rG - 128 + Bias; + if rG < -128 then rG := -128 else + if rG > 127 then rG := 127; + rG := rG + 128; + + rR := rR - 128 + Bias; + if rR < -128 then rR := -128 else + if rR > 127 then rR := 127; + rR := rR + 128; + + // Store result (preserve destination alpha) + Dst^ := + (D and $FF000000) or + (Cardinal(rR) shl 16) or + (Cardinal(rG) shl 8) or + Cardinal(rB); + + Inc(Src); + Inc(Dst); + end; +end; + {$ELSE} + {$IF defined(CPUX64)} + // RCX contains Source // RDX contains Destination // R8D contains Count @@ -727,7 +788,9 @@ procedure AlphaBlendLineConstant(Source, Destination: Pointer; Count: Integer; C POP EDI POP ESI end; -{$endif CPUX64} + {$ENDIF} +{$ENDIF !ASSEMBLER} + //---------------------------------------------------------------------------------------------------------------------- @@ -737,7 +800,72 @@ procedure AlphaBlendLinePerPixel(Source, Destination: Pointer; Count, Bias: Inte // The layout of a pixel must be BGRA. // Bias is an additional value which gets added to every component and must be in the range -128..127 // -{$ifdef CPUX64} +{$IFNDEF ASSMEBLER} //new +var + Src, Dst: PCardinal; + i: Integer; + + S, D: Cardinal; + sB, sG, sR, sA: Integer; + dB, dG, dR: Integer; + a: Integer; + + rB, rG, rR: Integer; +begin + Src := PCardinal(Source); + Dst := PCardinal(Destination); + + for i := 0 to Count - 1 do + begin + S := Src^; + D := Dst^; + + // Extract source BGRA + sB := S and $FF; + sG := (S shr 8) and $FF; + sR := (S shr 16) and $FF; + sA := (S shr 24) and $FF; + + // Extract destination BGR (alpha preserved) + dB := D and $FF; + dG := (D shr 8) and $FF; + dR := (D shr 16) and $FF; + + // Use source alpha per pixel + a := sA; // 0..255 + + // Blend formula: target = (alpha * (source - target) + 256 * target) / 256 + rB := (a * (sB - dB) + (dB shl 8)) shr 8; + rG := (a * (sG - dG) + (dG shl 8)) shr 8; + rR := (a * (sR - dR) + (dR shl 8)) shr 8; + + // Bias + clamp (branching) + rB := rB - 128 + Bias; + if rB < -128 then rB := -128 else if rB > 127 then rB := 127; + rB := rB + 128; + + rG := rG - 128 + Bias; + if rG < -128 then rG := -128 else if rG > 127 then rG := 127; + rG := rG + 128; + + rR := rR - 128 + Bias; + if rR < -128 then rR := -128 else if rR > 127 then rR := 127; + rR := rR + 128; + + // Store result (preserve destination alpha) + Dst^ := + (D and $FF000000) or + (Cardinal(rR) shl 16) or + (Cardinal(rG) shl 8) or + Cardinal(rB); + + Inc(Src); + Inc(Dst); + end; +end; + + {$ELSE} + {$IF defined(CPUX64)} // RCX contains Source // RDX contains Destination // R8D contains Count @@ -858,23 +986,24 @@ procedure AlphaBlendLinePerPixel(Source, Destination: Pointer; Count, Bias: Inte POP EDI POP ESI end; -{$endif CPUX64} - + {$ENDIF} + {$ENDIF !ASSEMBLER} //---------------------------------------------------------------------------------------------------------------------- procedure EMMS; // Reset MMX state to use the FPU for other tasks again. -{$ifdef CPUX64} - inline; -begin -end; -{$else} +{$ifdef CPUX86} asm DB $0F, $77 /// EMMS end; -{$endif CPUX64} +{$else} +inline; +begin + +end; +{$endif} //---------------------------------------------------------------------------------------------------------------------- @@ -884,8 +1013,75 @@ procedure AlphaBlendLineMaster(Source, Destination: Pointer; Count: Integer; Con // The layout of a pixel must be BGRA. // ConstantAlpha must be in the range 0..255. // Bias is an additional value which gets added to every component and must be in the range -128..127 -// -{$ifdef CPUX64} + +{$IFNDEF ASSEMBLER} +var + Src, Dst: PCardinal; + i: Integer; + + S, D: Cardinal; + sB, sG, sR, sA: Integer; + dB, dG, dR: Integer; + a: Integer; + + rB, rG, rR: Integer; +begin + Src := PCardinal(Source); + Dst := PCardinal(Destination); + + for i := 0 to Count - 1 do + begin + S := Src^; + D := Dst^; + + // Extract source BGRA + sB := S and $FF; + sG := (S shr 8) and $FF; + sR := (S shr 16) and $FF; + sA := (S shr 24) and $FF; + + // Extract destination BGR (alpha preserved) + dB := D and $FF; + dG := (D shr 8) and $FF; + dR := (D shr 16) and $FF; + + // Effective alpha = source alpha * master alpha / 256 + a := (sA * ConstantAlpha) shr 8; + + // Blend + rB := (a * (sB - dB) + (dB shl 8)) shr 8; + rG := (a * (sG - dG) + (dG shl 8)) shr 8; + rR := (a * (sR - dR) + (dR shl 8)) shr 8; + + // Bias + clamp (branching, fastest on Win32) + rB := rB - 128 + Bias; + if rB < -128 then rB := -128 else + if rB > 127 then rB := 127; + rB := rB + 128; + + rG := rG - 128 + Bias; + if rG < -128 then rG := -128 else + if rG > 127 then rG := 127; + rG := rG + 128; + + rR := rR - 128 + Bias; + if rR < -128 then rR := -128 else + if rR > 127 then rR := 127; + rR := rR + 128; + + // Store result, preserve destination alpha + Dst^ := + (D and $FF000000) or + (Cardinal(rR) shl 16) or + (Cardinal(rG) shl 8) or + Cardinal(rB); + + Inc(Src); + Inc(Dst); + end; +end; + {$ELSE} + {$IF defined(CPUX64)} // RCX contains Source // RDX contains Destination // R8D contains Count @@ -1025,7 +1221,8 @@ procedure AlphaBlendLineMaster(Source, Destination: Pointer; Count: Integer; Con POP EDI POP ESI end; -{$endif CPUX64} + {$ENDIF} + {$ENDIF !ASSEMBLER} //---------------------------------------------------------------------------------------------------------------------- @@ -1034,8 +1231,62 @@ procedure AlphaBlendLineMasterAndColor(Destination: Pointer; Count: Integer; Con // Blends a line of Count pixels in Destination against the given color using a constant alpha value. // The layout of a pixel must be BGRA and Color must be rrggbb00 (as stored by a COLORREF). // ConstantAlpha must be in the range 0..255. -// -{$ifdef CPUX64} + +{$IFNDEF ASSEMBLER} +var + Dst: PCardinal; + i: Integer; + + dB, dG, dR: Integer; + rB, rG, rR: Integer; + + alpha: Integer; + F1B, F1G, F1R: Integer; // color * alpha + F2: Integer; // 256 - alpha + cR, cG, cB: Integer; +begin + Dst := PCardinal(Destination); + + // Extract color components (BGRA layout, Color in rrggbb00 format) + cR := (Color shr 16) and $FF; + cG := (Color shr 8) and $FF; + cB := Color and $FF; + + // Precompute alpha factors + alpha := ConstantAlpha; // 0..255 + F2 := 256 - alpha; // factor for destination + F1R := cR * alpha; // factor for color + F1G := cG * alpha; + F1B := cB * alpha; + + for i := 0 to Count - 1 do + begin + // Load destination + dB := Dst^ and $FF; + dG := (Dst^ shr 8) and $FF; + dR := (Dst^ shr 16) and $FF; + + // Blend formula: target = (F1 + F2 * target) / 256 + rB := (F1B + F2 * dB) shr 8; + rG := (F1G + F2 * dG) shr 8; + rR := (F1R + F2 * dR) shr 8; + + // Branching clamp (safe) + if rB < 0 then rB := 0 else if rB > 255 then rB := 255; + if rG < 0 then rG := 0 else if rG > 255 then rG := 255; + if rR < 0 then rR := 0 else if rR > 255 then rR := 255; + + // Store back, preserve alpha (destination alpha unchanged) + Dst^ := (Dst^ and $FF000000) or + (Cardinal(rR) shl 16) or + (Cardinal(rG) shl 8) or + Cardinal(rB); + + Inc(Dst); + end; +end; + {$ELSE} + {$IF defined(CPUX64)} // RCX contains Destination // EDX contains Count // R8D contains ConstantAlpha @@ -1132,7 +1383,8 @@ procedure AlphaBlendLineMasterAndColor(Destination: Pointer; Count: Integer; Con DEC EDX JNZ @1 end; -{$endif CPUX64} + {$ENDIF} + {$ENDIF !ASSEMBLER} //---------------------------------------------------------------------------------------------------------------------- diff --git a/Source/VirtualTrees.pas b/Source/VirtualTrees.pas index 00e5c7ff7..b6be12751 100644 --- a/Source/VirtualTrees.pas +++ b/Source/VirtualTrees.pas @@ -105,6 +105,8 @@ interface TVTOperationKind = VirtualTrees.Types.TVTOperationKind; TVTUpdateState = VirtualTrees.Types.TVTUpdateState; TVTCellPaintMode = VirtualTrees.Types.TVTCellPaintMode; + TVTCell = VirtualTrees.Types.TVTCell; + TVTCellArray = VirtualTrees.Types.TVTCellArray; TVirtualNodeState = VirtualTrees.Types.TVirtualNodeState; TVirtualNodeInitState = VirtualTrees.Types.TVirtualNodeInitState; TVirtualNodeInitStates = VirtualTrees.Types.TVirtualNodeInitStates; @@ -212,6 +214,9 @@ TCustomVirtualStringTree = class; Column: TColumnIndex; const Text: string; var Extent: TDimension) of object; TVTDrawTextEvent = procedure(Sender: TBaseVirtualTree; TargetCanvas: TCanvas; Node: PVirtualNode; Column: TColumnIndex; const Text: string; const CellRect: TRect; var DefaultDraw: Boolean) of object; + TVTDrawTextExEvent = procedure(Sender: TBaseVirtualTree; TargetCanvas: TCanvas; Node: PVirtualNode; + Column: TColumnIndex; const Text: string; const CellRect: TRect; + var DefaultDraw: Boolean; var DrawFormat: Cardinal) of object; /// Event arguments of the OnGetCellText event TVSTGetCellTextEventArgs = record @@ -242,6 +247,7 @@ TCustomVirtualStringTree = class(TVTAncestor) FOnMeasureTextWidth: TVTMeasureTextEvent; // used to adjust the width of the cells FOnMeasureTextHeight: TVTMeasureTextEvent; FOnDrawText: TVTDrawTextEvent; // used to custom draw the node text + FOnDrawTextEx: TVTDrawTextExEvent; // a more advanced version, with all parameters /// Returns True if the property DefaultText has a value that differs from the default value, False otherwise. function IsDefaultTextStored(): Boolean; function GetImageText(Node: PVirtualNode; Kind: TVTImageKind; @@ -308,6 +314,7 @@ TCustomVirtualStringTree = class(TVTAncestor) property OnMeasureTextWidth: TVTMeasureTextEvent read FOnMeasureTextWidth write FOnMeasureTextWidth; property OnMeasureTextHeight: TVTMeasureTextEvent read FOnMeasureTextHeight write FOnMeasureTextHeight; property OnDrawText: TVTDrawTextEvent read FOnDrawText write FOnDrawText; + property OnDrawTextEx: TVTDrawTextExEvent read FOnDrawTextEx write FOnDrawTextEx; public constructor Create(AOwner: TComponent); override; destructor Destroy(); override; @@ -334,7 +341,9 @@ TCustomVirtualStringTree = class(TVTAncestor) property Text[Node: PVirtualNode; Column: TColumnIndex]: string read GetText write SetText; end; + {$if CompilerVersion >= 33} [ComponentPlatformsAttribute(pfidWindows)] + {$ifend} TVirtualStringTree = class(TCustomVirtualStringTree) private function GetOptions: TStringTreeOptions; @@ -463,6 +472,7 @@ TVirtualStringTree = class(TCustomVirtualStringTree) property OnCanSplitterResizeHeader; property OnCanSplitterResizeNode; property OnChange; + property OnChangeCell; property OnChecked; property OnChecking; property OnClick; @@ -488,6 +498,7 @@ TVirtualStringTree = class(TCustomVirtualStringTree) property OnDragDrop; property OnDrawHint; property OnDrawText; + property OnDrawTextEx; property OnEditCancelled; property OnEdited; property OnEditing; @@ -805,11 +816,11 @@ procedure TCustomVirtualStringTree.InitializeTextProperties(var PaintInfo: TVTPa begin if Node = DropTargetNode then begin - if ((LastDropMode = dmOnNode) or (vsSelected in Node.States)) then + if (LastDropMode = dmOnNode) or (vsSelected in Node.States) or InternalIsCellSelected(Node, Column) then Canvas.Font.Color := Colors.GetSelectedNodeFontColor(True); // See #1083, since drop highlight color is chosen independent of the focus state, we need to choose Font color also independent of it. end else - if vsSelected in Node.States then + if (vsSelected in Node.States) or InternalIsCellSelected(Node, Column) then begin Canvas.Font.Color := Colors.GetSelectedNodeFontColor(Focused or (toPopupMode in TreeOptions.PaintOptions)); end; @@ -925,13 +936,13 @@ procedure TCustomVirtualStringTree.PaintStaticText(const PaintInfo: TVTPaintInfo begin if Node = DropTargetNode then begin - if (LastDropMode = dmOnNode) or (vsSelected in Node.States) then + if (LastDropMode = dmOnNode) or (vsSelected in Node.States) or InternalIsCellSelected(Node, Column) then Canvas.Font.Color := Colors.GetSelectedNodeFontColor(Focused or (toPopupMode in TreeOptions.PaintOptions)) else Canvas.Font.Color := Colors.NodeFontColor; end else - if vsSelected in Node.States then + if (vsSelected in Node.States) or InternalIsCellSelected(Node, Column) then begin if Focused or (toPopupMode in TreeOptions.PaintOptions) then Canvas.Font.Color := Colors.GetSelectedNodeFontColor(Focused or (toPopupMode in TreeOptions.PaintOptions)) @@ -1418,12 +1429,14 @@ procedure TCustomVirtualStringTree.DoTextDrawing(var PaintInfo: TVTPaintInfo; co lText: string; begin DefaultDraw := True; - if Assigned(FOnDrawText) then + if not Assigned(FOnDrawTextEx) and Assigned(FOnDrawText) then FOnDrawText(Self, PaintInfo.Canvas, PaintInfo.Node, PaintInfo.Column, Text, CellRect, DefaultDraw); if ((DrawFormat and DT_RIGHT) > 0) and (TFontStyle.fsItalic in PaintInfo.Canvas.Font.Style) then lText := Text + ' ' else lText := Text; + if Assigned(FOnDrawTextEx) then + FOnDrawTextEx(Self, PaintInfo.Canvas, PaintInfo.Node, PaintInfo.Column, lText, CellRect, DefaultDraw, DrawFormat); if DefaultDraw then Winapi.Windows.DrawTextW(PaintInfo.Canvas.Handle, PWideChar(lText), Length(lText), CellRect, DrawFormat); end; diff --git a/Tests/Tests.dpr b/Tests/Tests.dpr index a396ed931..46c91cd06 100644 --- a/Tests/Tests.dpr +++ b/Tests/Tests.dpr @@ -4,7 +4,7 @@ program Tests; {$APPTYPE CONSOLE} {$ENDIF}{$STRONGLINKTYPES ON} uses - SysUtils, + System.SysUtils, {$IFDEF TESTINSIGHT} TestInsight.DUnitX, {$ENDIF } @@ -13,7 +13,13 @@ uses DUnitX.TestFramework, VirtualTreeTests in 'VirtualTreeTests.pas', VirtualStringTreeTests in 'VirtualStringTreeTests.pas', - VTWorkerThreadIssue1001Tests in 'VTWorkerThreadIssue1001Tests.pas'; + VTWorkerThreadIssue1001Tests in 'VTWorkerThreadIssue1001Tests.pas', + VTOnEditCancelledTests in 'VTOnEditCancelledTests.pas', + VTOnDrawTextTests in 'VTOnDrawTextTests.pas', + VTCellSelectionTests in 'VTCellSelectionTests.pas', + VirtualTrees.MouseUtils in 'VirtualTrees.MouseUtils.pas', + 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 3ca201348..8d1ccaf83 100644 --- a/Tests/Tests.dproj +++ b/Tests/Tests.dproj @@ -7,7 +7,7 @@ Tests.dpr Win32 {D37CFA56-3B13-4C93-91F7-DDC227C20116} - 20.2 + 20.3 3 Tests @@ -84,6 +84,8 @@ madExcept;$(DCC_Define) 3 false + 1033 + none 3 @@ -101,6 +103,18 @@ + + + + + +
VisibilityForm
+ dfm + + +
SelectionTestForm
+ dfm + Base @@ -121,7 +135,11 @@ Tests.dpr - + + (untitled) + Microsoft Office 2000 Sample Automation Server Wrapper Components + Microsoft Office XP Sample Automation Server Wrapper Components + True diff --git a/Tests/VTCellSelectionTests.VTSelectionTestForm.dfm b/Tests/VTCellSelectionTests.VTSelectionTestForm.dfm new file mode 100644 index 000000000..64621d640 --- /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 000000000..8607e636c --- /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.VisibilityForm.dfm b/Tests/VTCellSelectionTests.VisibilityForm.dfm new file mode 100644 index 000000000..1ba50d1f3 --- /dev/null +++ b/Tests/VTCellSelectionTests.VisibilityForm.dfm @@ -0,0 +1,76 @@ +object VisibilityForm: TVisibilityForm + Left = 5 + Top = 5 + Margins.Left = 7 + Margins.Top = 7 + Margins.Right = 7 + Margins.Bottom = 7 + Anchors = [akLeft, akTop, akRight, akBottom] + Caption = 'VisibilityForm' + ClientHeight = 641 + ClientWidth = 1046 + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -27 + Font.Name = 'Segoe UI' + Font.Style = [] + OnCreate = FormCreate + PixelsPerInch = 216 + DesignSize = ( + 1046 + 641) + TextHeight = 37 + object VST1: TVirtualStringTree + Left = 4 + Top = 12 + Width = 951 + Height = 538 + Margins.Left = 7 + Margins.Top = 7 + Margins.Right = 7 + Margins.Bottom = 7 + Anchors = [akLeft, akTop, akRight, akBottom] + Colors.BorderColor = clWindowText + Colors.HotColor = clBlack + DefaultNodeHeight = 46 + Header.AutoSizeIndex = 0 + Header.Height = 37 + Header.MainColumn = -1 + Header.MaxHeight = 22500 + Header.MinHeight = 23 + Header.Options = [hoColumnResize, hoDrag] + HintMode = hmTooltip + IncrementalSearch = isAll + Indent = 41 + Margin = 9 + ParentShowHint = False + ShowHint = True + TabOrder = 0 + TextMargin = 9 + TreeOptions.AutoOptions = [toAutoDropExpand, toAutoScroll, toAutoScrollOnExpand, toAutoTristateTracking, toAutoHideButtons, toAutoChangeScale] + TreeOptions.SelectionOptions = [toMultiSelect] + OnChange = VST1Change + OnFreeNode = VST1FreeNode + OnGetText = VST1GetText + OnInitChildren = VST1InitChildren + OnInitNode = VST1InitNode + Touch.InteractiveGestures = [igPan, igPressAndTap] + Touch.InteractiveGestureOptions = [igoPanSingleFingerHorizontal, igoPanSingleFingerVertical, igoPanInertia, igoPanGutter, igoParentPassthrough] + Columns = <> + DefaultText = '' + end + object btnCheck: TButton + Left = 786 + Top = 573 + Width = 169 + Height = 56 + Margins.Left = 7 + Margins.Top = 7 + Margins.Right = 7 + Margins.Bottom = 7 + Caption = 'btnCheck' + TabOrder = 1 + OnClick = btnCheckClick + end +end diff --git a/Tests/VTCellSelectionTests.VisibilityForm.pas b/Tests/VTCellSelectionTests.VisibilityForm.pas new file mode 100644 index 000000000..e24b44bae --- /dev/null +++ b/Tests/VTCellSelectionTests.VisibilityForm.pas @@ -0,0 +1,224 @@ +unit VTCellSelectionTests.VisibilityForm; + +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, Vcl.StdCtrls; + +type + TVisibilityForm = class(TForm) + VST1: TVirtualStringTree; + btnCheck: TButton; + procedure btnCheckClick(Sender: TObject); + procedure FormCreate(Sender: TObject); + procedure VST1Change(Sender: TBaseVirtualTree; Node: PVirtualNode); + procedure VST1FreeNode(Sender: TBaseVirtualTree; Node: PVirtualNode); + procedure VST1GetText(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: + TColumnIndex; TextType: TVSTTextType; var CellText: string); + procedure VST1InitChildren(Sender: TBaseVirtualTree; Node: PVirtualNode; var + ChildCount: Cardinal); + procedure VST1InitNode(Sender: TBaseVirtualTree; ParentNode, Node: + PVirtualNode; var InitialStates: TVirtualNodeInitStates); + private + type + TVTChangeEventProc = reference to procedure(Sender: TBaseVirtualTree; Node: PVirtualNode); + var + FChangeEventProc: TVTChangeEventProc; + { Private declarations } + procedure AssignChange( + const AChangeEventProc: TVTChangeEventProc; + const ATree: TBaseVirtualTree = nil); + procedure DoChangeEvent(Sender: TBaseVirtualTree; Node: PVirtualNode); + public + { Public declarations } + procedure HideNodes(Sender: TBaseVirtualTree; Node: PVirtualNode; Data: Pointer; var Abort: Boolean); + procedure TestEmptyAreaOnChange2; + end; + +var + VisibilityForm: TVisibilityForm; + +implementation + +uses + VirtualTrees.Types, VirtualTrees.MouseUtils; + +{$R *.dfm} + +type + PLinkData = ^TLinkData; + TLinkData = record + Caption: string; + OtherNode: PVirtualNode; + end; + + Assert = class + class procedure IsTrue(ACondition: Boolean; const AMsg: string = ''); static; + end; + +class procedure Assert.IsTrue(ACondition: Boolean; const AMsg: string = ''); +begin + System.Assert(ACondition, AMsg); +end; + +procedure TVisibilityForm.AssignChange( + const AChangeEventProc: TVTChangeEventProc; + const ATree: TBaseVirtualTree = nil); +var + FTree: TVirtualStringTree; +begin + FTree := VST1; + FChangeEventProc := AChangeEventProc; + if not Assigned(ATree) then + FTree.OnChange := DoChangeEvent else + TVirtualStringTree(ATree).OnChange := DoChangeEvent; +end; + +procedure TVisibilityForm.btnCheckClick(Sender: TObject); +begin + TestEmptyAreaOnChange2; +end; + +procedure TVisibilityForm.DoChangeEvent(Sender: TBaseVirtualTree; Node: PVirtualNode); +begin + if Assigned(FChangeEventProc) then + FChangeEventProc(Sender, Node); +end; + +procedure TVisibilityForm.FormCreate(Sender: TObject); +begin + VST1.RootNodeCount := 5; +end; + +procedure TVisibilityForm.HideNodes(Sender: TBaseVirtualTree; + Node: PVirtualNode; Data: Pointer; var Abort: Boolean); +begin + case Integer(Data) of + 0: // show all nodes + Sender.IsVisible[Node] := True; + 1: // hide every second + Sender.IsVisible[Node] := not Odd(Node.Index); + 2: // hide nodes with child nodes only + Sender.IsVisible[Node] := not Sender.HasChildren[Node]; + 3: // hide all + Sender.IsVisible[Node] := False; + end; +end; + +procedure TVisibilityForm.VST1FreeNode(Sender: TBaseVirtualTree; Node: + PVirtualNode); +var + Data: PLinkData; +begin + Data := Sender.GetNodeData(Node); + Finalize(Data^); +end; + +procedure TVisibilityForm.VST1GetText(Sender: TBaseVirtualTree; Node: + PVirtualNode; Column: TColumnIndex; TextType: TVSTTextType; var CellText: + string); +begin + CellText := Format('Node Level %d, Index %d', [Sender.GetNodeLevel(Node), Node.Index]); +end; + +procedure TVisibilityForm.VST1InitChildren(Sender: TBaseVirtualTree; Node: + PVirtualNode; var ChildCount: Cardinal); +begin + ChildCount := Random(5) + 1; +end; + +procedure TVisibilityForm.VST1InitNode(Sender: TBaseVirtualTree; ParentNode, + Node: PVirtualNode; var InitialStates: TVirtualNodeInitStates); +var + Level: Integer; +begin + Level := Sender.GetNodeLevel(Node); + if Level < 4 then + Include(InitialStates, ivsHasChildren); + if Level > 0 then + Node.CheckType := TCheckType(Level) + else + Node.CheckType := ctTriStateCheckBox; +end; + +procedure TVisibilityForm.TestEmptyAreaOnChange2; +var + LTree: TVirtualStringTree; + n1: PVirtualNode; + LOnChangeFired: LongBool; + I, LColumnCount, LMaxWidth: Integer; + Rects: TArray; + LargestRect: TRect; + LTextOnly, LUnclipped, LApplyCellContentMargin: Boolean; + LastNode, LHitNode: PVirtualNode; + LEmptyArea: TPoint; + LHitInfo: THitInfo; + LTestForm: TVisibilityForm; +begin + LTestForm := Self; + + LTree := LTestForm.VST1; + + n1 := LTree.GetLastVisible; + + // Calculate the largest client area for the VirtualTree and set it + LColumnCount := LTree.Header.Columns.Count; + LMaxWidth := 0; + for I := 0 to LColumnCount-1 do + begin + if LTree.Header.Columns[I].Width > LMaxWidth then + LMaxWidth := LTree.Header.Columns[I].Width; + end; + if LMaxWidth = 0 then + LMaxWidth := 300; + I := 0; + LargestRect := TRect.Empty; + for LTextOnly := False to True do + for LUnclipped := False to True do + for LApplyCellContentMargin := False to True do + begin + SetLength(Rects, I+1); + Rects[I] := LTree.GetDisplayRect(n1, LColumnCount-1, LTextOnly, LUnclipped, LApplyCellContentMargin); + LargestRect := TRect.Union(LargestRect, Rects[I]); + Inc(I); + end; + + LastNode := LTree.GetLastVisibleChild(LTree.RootNode); + + LTree.ClientHeight := LargestRect.BottomRight.Y + (LastNode.NodeHeight * 2); + LTree.ClientWidth := LargestRect.BottomRight.X + LMaxWidth; + + // This should be an empty area, beyond any visible nodes + LEmptyArea := Point(LargestRect.BottomRight.X + LMaxWidth, LargestRect.BottomRight.Y + LastNode.NodeHeight); + + // At this point, there should be no nodes selected + Assert.IsTrue(LTree.SelectedCount = 0); + LTree.MouseClick(n1, NoColumn); + // At this point, a node should be selected + Assert.IsTrue(LTree.SelectedCount = 1); + + LOnChangeFired := False; + LHitNode := Pointer($FFFFFFFF); + AssignChange(procedure (Sender: TBaseVirtualTree; ANode: PVirtualNode) + begin + LOnChangeFired := True; + LHitNode := ANode; + end, LTree); + + LTree.GetHitTestInfoAt(LEmptyArea.X, LEmptyArea.Y, True, LHitInfo); + LTree.MouseClick(LEmptyArea); + + Assert.IsTrue(hiNowhere in LHitInfo.HitPositions, 'Mouse click is not in an unpopulated/empty area!'); + Assert.IsTrue(LOnChangeFired, 'OnChange event not fired!'); + Assert.IsTrue(LHitNode = nil, 'Node is not nil!'); +end; + +procedure TVisibilityForm.VST1Change(Sender: TBaseVirtualTree; Node: + PVirtualNode); +begin + OutputDebugString(PChar(Format('Node: %p', [Pointer(Node)]))); +end; + +end. diff --git a/Tests/VTCellSelectionTests.pas b/Tests/VTCellSelectionTests.pas new file mode 100644 index 000000000..9bad74d01 --- /dev/null +++ b/Tests/VTCellSelectionTests.pas @@ -0,0 +1,1389 @@ +unit VTCellSelectionTests; + +// Virtual Treeview cell selection tests +// Written by CheeWee Chua. + +interface + +uses + DUnitX.TestFramework, Vcl.Forms, VirtualTrees, System.Types, + Winapi.Messages, Winapi.Windows, Vcl.ComCtrls, VirtualTrees.Types; + +type + + [TestFixture] + TCellSelectionTests = class(TObject) + strict private + const MaxTries = 10; + type + TVTChangeEventProc = reference to procedure(Sender: TBaseVirtualTree; Node: PVirtualNode); + TVTChangeCellEventProc = reference to procedure(Sender: TBaseVirtualTree; const Cells: TVTCellArray); + var + FTree: TVirtualStringTree; + FForm: TForm; + FNode1, + FNode2, + FNode3, + FNode4, + FNode5, + FNode6, + FNode7, + FNode8: PVirtualNode; + FRichEdit: TRichEdit; + + FChangeEventProc: TVTChangeEventProc; + FChangeCellEventProc: TVTChangeCellEventProc; + + procedure AssignChange(const AChangeEventProc: TVTChangeEventProc; const ATree: TBaseVirtualTree = nil); overload; + procedure AssignChange(const AChangeCellEventProc: TVTChangeCellEventProc); overload; + procedure DoChangeEvent(Sender: TBaseVirtualTree; Node: PVirtualNode); + procedure DoChangeCellEvent(Sender: TBaseVirtualTree; const Cells: TVTCellArray); + procedure FreeNodeEvent(Sender: TBaseVirtualTree; Node: PVirtualNode); + private + FClipboardAllocated: LongBool; + FClipboardWindow: HWND; + procedure CompleteClipboardCopy; + procedure OpenClipboard; + procedure CloseClipboard; + procedure MainWndProc(var Message: TMessage); + procedure WndProc(var Message: TMessage); + procedure VirtualStringTree1GetText(Sender: TBaseVirtualTree; + Node: PVirtualNode; Column: TColumnIndex; TextType: TVSTTextType; + var CellText: string); + procedure EnableMultiCellSelection(const ATree: TBaseVirtualTree = nil); + public + [Setup] + procedure Setup; + [TearDown] + procedure TearDown; + + [Test] + procedure TestChangeCellEvent; + + [Test] + procedure TestSelectSingleCell; + + [Test] + procedure TestShiftClickMultipleCells; + + [Test] + procedure TestClear; + + [Test] + procedure TestClearCellSelection; + + [Test] + procedure TestSelectMultipleCellsFailWithoutMultiSelect; + + [Test] + procedure TestSelectMultipleCellsFailWithoutExtendedFocus; + + [Test] + procedure TestSelectCellsRectangular; + + [Test] + procedure TestClickUnselectsSelectedCells; + + [Test] + procedure TestCopyHTML1; + + [Test] + procedure TestCopyHTML2; + + [Test] + procedure TestCopyPlainText1; + + [Test] + procedure TestCopyPlainText2; + + [Test] + procedure TestCopyRTF1; + + [Test] + procedure TestCopyRTF2; + + /// + /// This tests that OnChange is fired when a node is selected + /// + [Test] + procedure TestOnChange; + + /// + /// This tests that OnChange is fired when an empty area is clicked + /// + [Test] + procedure TestEmptyAreaOnChange1; + + /// + /// This tests that OnChange is fired when an empty area is clicked + /// + [Test] + procedure TestEmptyAreaOnChange2; + + /// + /// This tests that when left click is performed, node is selected + /// + [Test] + procedure TestLeftClickSelectsNode; + + /// + /// This tests that when left click is performed without multiselect, cell doesn't get selected + /// + [Test] + procedure TestLeftClickWithoutMultiSelectDoesNotSelectCell; + + /// + /// This tests that setting and removing various states clears cell selection + /// + [Test] + procedure TestRemovingSetsClearCellSelection; + + end; + +implementation + +uses + System.SysUtils, Vcl.Controls, + Vcl.Clipbrd, VirtualTrees.ClipBoard, + System.Classes, Winapi.ActiveX, Vcl.ClipboardHelper, VirtualTrees.MouseUtils, + VTCellSelectionTests.VisibilityForm, VTCellSelectionTests.VTSelectionTestForm; + +type + TRowData = record + col1: string; + col2: string; + col3: string; + col4: string; + col5: string; + public + constructor Create(const ACol1, ACol2, ACol3, ACol4, ACol5: string); + procedure Clear; + end; + +{ TRowData } + +procedure TRowData.Clear; +begin + System.Finalize(Self); +end; + +constructor TRowData.Create(const ACol1, ACol2, ACol3, ACol4, ACol5: string); +begin + col1 := ACol1; + col2 := ACol2; + col3 := ACol3; + col4 := ACol4; + col5 := ACol5; +end; + +const + col0 = 0; + col1 = 1; + col2 = 2; + col3 = 3; + col4 = 4; + col5 = 5; + // skip the 4th column + +{ TCellSelectionTests } + +procedure TCellSelectionTests.CloseClipboard; +begin + if FClipboardAllocated then + begin + DeallocateHWnd(FClipboardWindow); + FClipboardWindow := 0; + Application.Handle := 0; + FClipboardAllocated := False; + end; +end; + +// Hacks to make OLE clipboard and VCL clipboard compatible +// within DUnit test framework +procedure TCellSelectionTests.CompleteClipboardCopy; +var + LResult: HRESULT; + LErrorMsg: string; +begin + Application.ProcessMessages; + FTree.FlushClipboard; + LResult := Winapi.ActiveX.OleFlushClipboard; + if Failed(LResult) then + begin + LErrorMsg := SysErrorMessage(GetLastError); + end; + Application.ProcessMessages; +end; + +procedure TCellSelectionTests.OpenClipboard; +begin + if FClipboardWindow = 0 then + begin + FClipboardWindow := AllocateHWnd(MainWndProc); + Application.Handle := FClipboardWindow; + FClipboardAllocated := True; + end; +end; + +procedure TCellSelectionTests.MainWndProc(var Message: TMessage); +begin + try + WndProc(Message); + except + if Assigned(ApplicationHandleException) then + ApplicationHandleException(Self) + else + raise; + end; +end; + +procedure TCellSelectionTests.WndProc(var Message: TMessage); +begin + with Message do + Result := DefWindowProc(FClipboardWindow, Msg, wParam, lParam); +end; + +procedure TCellSelectionTests.VirtualStringTree1GetText(Sender: TBaseVirtualTree; + Node: PVirtualNode; Column: TColumnIndex; TextType: TVSTTextType; + var CellText: string); +var + LData: TRowData; +begin + if not Assigned(Node) then + Exit; + LData := Node.GetData; + case Column of + col0: begin + CellText := LData.col1; + end; + col1: begin + CellText := LData.col2; + end; + col2: begin + CellText := LData.col3; + end; + col3: begin + CellText := LData.col4; + end; + col4: begin + CellText := LData.col5; + end; + end; +end; + +procedure TCellSelectionTests.AssignChange( + const AChangeEventProc: TVTChangeEventProc; + const ATree: TBaseVirtualTree = nil); +begin + FChangeEventProc := AChangeEventProc; + if not Assigned(ATree) then + FTree.OnChange := DoChangeEvent else + TVirtualStringTree(ATree).OnChange := DoChangeEvent; +end; + +procedure TCellSelectionTests.AssignChange(const AChangeCellEventProc: TVTChangeCellEventProc); +begin + FChangeCellEventProc := AChangeCellEventProc; + FTree.OnChangeCell := DoChangeCellEvent; +end; + +procedure TCellSelectionTests.DoChangeEvent(Sender: TBaseVirtualTree; Node: PVirtualNode); +begin + if Assigned(FChangeEventProc) then + FChangeEventProc(Sender, Node); +end; + +procedure TCellSelectionTests.EnableMultiCellSelection(const ATree: TBaseVirtualTree); +var + LTree: TVirtualStringTree; +begin + if not Assigned(ATree) then + LTree := FTree else + LTree := TVirtualStringTree(ATree); + LTree.TreeOptions.SelectionOptions := LTree.TreeOptions.SelectionOptions + + [toExtendedFocus, toMultiSelect, toMultiCellSelect] - [toFullRowSelect]; +end; + +procedure TCellSelectionTests.DoChangeCellEvent(Sender: TBaseVirtualTree; const Cells: TVTCellArray); +begin + if Assigned(FChangeCellEventProc) then + FChangeCellEventProc(Sender, Cells); +end; + +procedure TCellSelectionTests.FreeNodeEvent(Sender: TBaseVirtualTree; + Node: PVirtualNode); +var + LRowData: TRowData; +begin + LRowData := Node.GetData; + LRowData.Clear; +end; + +// End hacks + +procedure TCellSelectionTests.Setup; +var + LTree: TVirtualStringTree; + LCol1, LCol2, LCol3, LCol4, LCol5: TVirtualTreeColumn; +begin + + OpenClipboard; + + FForm := TForm.Create(nil); + FRichEdit := TRichEdit.Create(FForm); + FForm.InsertControl(FRichEdit); + FTree := TVirtualStringTree.Create(FForm); + LTree := FTree; + LTree.Parent := FForm; + LTree.Align := alClient; + LTree.OnFreeNode := FreeNodeEvent; + LTree.OnGetText := VirtualStringTree1GetText; + LTree.TreeStates := LTree.TreeStates + [tsUseCache]; + + try + OleSetClipboard(nil); + Clipboard.AsText := ''; + except + end; + + LTree.ClipboardFormats.Add(GetVTClipboardFormatDescription(CF_TEXT)); + LTree.ClipboardFormats.Add(GetVTClipboardFormatDescription(CF_OEMTEXT)); + LTree.ClipboardFormats.Add(GetVTClipboardFormatDescription(CF_UNICODETEXT)); + LTree.ClipboardFormats.Add(GetVTClipboardFormatDescription(CF_VRTF)); + LTree.ClipboardFormats.Add(GetVTClipboardFormatDescription(CF_HTML)); + + // Add three columns + LCol1 := LTree.Header.Columns.Add; + LCol2 := LTree.Header.Columns.Add; + LCol3 := LTree.Header.Columns.Add; + LCol4 := LTree.Header.Columns.Add; + LCol5 := LTree.Header.Columns.Add; + LCol1.Text := 'col1'; + LCol2.Text := 'col2'; + LCol3.Text := 'col3'; + LCol4.Text := 'col4'; + LCol5.Text := 'col5'; + + LTree.NodeDataSize := SizeOf(TRowData); + + FNode1 := LTree.AddChild(LTree.RootNode); + FNode2 := LTree.AddChild(LTree.RootNode); + FNode3 := LTree.AddChild(LTree.RootNode); + FNode4 := LTree.AddChild(LTree.RootNode); + FNode5 := LTree.AddChild(LTree.RootNode); + + FNode1.SetData( + TRowData.Create('1a', '1b', '1c', '1d', '1e') + ); + FNode2.SetData( + TRowData.Create('2a', '2b', '2c', '2d', '2e') + ); + FNode3.SetData( + TRowData.Create('3a', '3b', '3c', '3d', '3e') + ); + FNode4.SetData( + TRowData.Create('4a', '4b', '4c', '4d', '4e') + ); + FNode5.SetData( + TRowData.Create('5a', '5b', '5c', '5d', '5e') + ); +end; + +procedure TCellSelectionTests.TearDown; +begin + CloseClipboard; + OleSetClipboard(nil); + FreeAndNil(FForm); +end; + +procedure TCellSelectionTests.TestChangeCellEvent; +var + LTree: TVirtualStringTree; + n3: PVirtualNode; + LChangeFired, + LChangeCellFiredWhenAdding, LChangeCellFiredWhenRemoving: LongBool; +begin + LTree := FTree; + + EnableMultiCellSelection(LTree); + + LChangeCellFiredWhenAdding := False; + AssignChange(procedure (Sender: TBaseVirtualTree; const Cells: TVTCellArray) + begin + LChangeCellFiredWhenAdding := True; + end); + + n3 := FNode3; + LTree.SelectCells(n3, 1, n3, 1, False); + + Assert.IsTrue(LChangeCellFiredWhenAdding, 'OnChangeCell event not fired when adding!'); + + LChangeCellFiredWhenRemoving := False; + AssignChange(procedure (Sender: TBaseVirtualTree; const Cells: TVTCellArray) + begin + LChangeCellFiredWhenRemoving := True; + end); + LChangeFired := False; + AssignChange(procedure (Sender: TBaseVirtualTree; Node: PVirtualNode) + begin + LChangeFired := True; + end); + LTree.ClearCellSelection; + + Assert.IsTrue(LChangeCellFiredWhenRemoving, 'OnChangeCell event not fired when removing!'); + + LTree.TreeOptions.SelectionOptions := LTree.TreeOptions.SelectionOptions + + [toExtendedFocus, toMultiSelect] - [toFullRowSelect, toMultiCellSelect]; + + LChangeFired := False; + LTree.MouseClick(n3); + + Assert.IsTrue(LChangeFired, 'Change event not fired'); +end; + +procedure TCellSelectionTests.TestClear; +var + LTree: TVirtualStringTree; + n3, n4: PVirtualNode; + LSelectedCells: TVTCellArray; +begin + LTree := FTree; + + EnableMultiCellSelection(LTree); + + n3 := FNode3; + n4 := FNode4; + + // Select rectangle from n3, col2 to n2, col3 + LTree.SelectCells(n3, 1, n4, 2, False); + LSelectedCells := LTree.SelectedCells; + + // How long is not important here, other tests in this suite checks it. + Assert.IsTrue(Length(LSelectedCells) > 0); + + LTree.Clear; + + LSelectedCells := LTree.SelectedCells; + Assert.IsTrue(Length(LSelectedCells) = 0, 'Selected cells are not cleared!'); +end; + +procedure TCellSelectionTests.TestClearCellSelection; +var + LTree: TVirtualStringTree; + n3, n4: PVirtualNode; + LSelectedCells: TVTCellArray; +begin + LTree := FTree; + + EnableMultiCellSelection(LTree); + + n3 := FNode3; + n4 := FNode4; + + // Select rectangle from n3, col2 to n2, col3 + LTree.SelectCells(n3, 1, n4, 2, False); + + Assert.IsTrue(toExtendedFocus in LTree.TreeOptions.SelectionOptions); + Assert.IsTrue(toMultiSelect in LTree.TreeOptions.SelectionOptions); + + // Ensure the selected cells above are selected + Assert.IsTrue(LTree.IsCellSelected(n3, 1), 'n3, col1 should be selected'); + Assert.IsTrue(LTree.IsCellSelected(n3, 2), 'n3, col2 should be selected'); + Assert.IsTrue(LTree.IsCellSelected(n4, 1), 'n4, col1 should be selected'); + Assert.IsTrue(LTree.IsCellSelected(n4, 2), 'n4, col2 should be selected'); + + LSelectedCells := LTree.SelectedCells; + Assert.IsTrue(Length(LSelectedCells) = 4, 'Length of selected cells is not 4!'); + + LTree.ClearCellSelection; + LSelectedCells := LTree.SelectedCells; + Assert.IsTrue(Length(LSelectedCells) = 0, 'Length of selected cells is not 0!'); +end; + +procedure TCellSelectionTests.TestClickUnselectsSelectedCells; +var + LTree: TVirtualStringTree; + n1, n3, n4: PVirtualNode; + LSelCel1, LSelCel2: TVTCellArray; +begin + LTree := FTree; + + EnableMultiCellSelection(LTree); + + n3 := FNode3; + n4 := FNode4; + + // Select rectangle from n3, col2 to n2, col3 + LTree.SelectCells(n3, 1, n4, 2, False); + + Assert.IsTrue(toExtendedFocus in LTree.TreeOptions.SelectionOptions); + Assert.IsTrue(toMultiSelect in LTree.TreeOptions.SelectionOptions); + + // Ensure the selected cells above are selected + Assert.IsTrue(LTree.IsCellSelected(n3, 1), 'n3, col1 should be selected'); + Assert.IsTrue(LTree.IsCellSelected(n3, 2), 'n3, col2 should be selected'); + Assert.IsTrue(LTree.IsCellSelected(n4, 1), 'n4, col1 should be selected'); + Assert.IsTrue(LTree.IsCellSelected(n4, 2), 'n4, col2 should be selected'); + + LSelCel1 := LTree.SelectedCells; + n1 := FNode1; + LTree.MouseClick(n1); + LSelCel2 := LTree.SelectedCells; + + // Ensures the above cells are no longer selected + Assert.IsFalse(LTree.IsCellSelected(n3, 1), 'n3, col1 should not be selected'); + Assert.IsFalse(LTree.IsCellSelected(n3, 2), 'n3, col2 should not be selected'); + Assert.IsFalse(LTree.IsCellSelected(n4, 1), 'n4, col1 should not be selected'); + Assert.IsFalse(LTree.IsCellSelected(n4, 2), 'n4, col2 should not be selected'); + + Assert.IsTrue(LTree.IsCellSelected(n1, 0), 'n1, col0 should be selected'); +end; + +procedure TCellSelectionTests.TestCopyHTML1; +var + LTree: TVirtualStringTree; + n3, n4: PVirtualNode; + LText, LExpected: string; + LTries: Integer; + LCompareSuccessful: LongBool; +begin + LTree := FTree; + LTree.Font.Name := 'Tahoma'; + LTree.Font.Size := 8; + + EnableMultiCellSelection(LTree); + + n3 := FNode3; + n4 := FNode4; + +// Occasional failure caused by clipboard copy issues, but this +// is due to interaction of complex interaction of Windows, console and +// DUnit testing, the failure is not seen in actual interacting applications + + // Select rectangle from n3, col2 to n4, col4 + LText := ''; LTries := 0; + repeat + LTree.SelectCells(n3, 1, n4, 3, False); + LTree.CopyToClipboard; + + // The following are not necessary in an actual application + Sleep(0); + + CompleteClipboardCopy; + Inc(LTries); + try + LText := Clipboard.AsHTML; + except + // Clipboard exception is ok, anything else is not + on EClipboardException do + begin + Clipboard.Close; + end; + else + raise; + end; + // End unnecessary stuff + until (LText <> '') or (LTries > MaxTries); + LExpected := 'Version:1.0'#$D#$A'StartHTML:00000097'#$D#$A'EndHTML:00001737'#$D#$A'StartFragment:00000269'#$D#$A'EndFragment:00001705'#$D#$A + + ''+ + ''#$D#$A + + ''#$D#$A''#$D#$A + + ''#$D#$A+ + ' '#$D#$A' '#$D#$A+ + ' '#$D#$A' '#$D#$A'
col2col3col4
3b 3c 3d
4b 4c 4d
'; + LCompareSuccessful := LText = LExpected; + Assert.IsTrue(LCompareSuccessful, 'Clipboard text is unexpected!'); +end; + +procedure TCellSelectionTests.TestCopyHTML2; +var + LTree: TVirtualStringTree; + n3, n5: PVirtualNode; + LText, LExpected: string; + LTries: Integer; + LCompareSuccessful: LongBool; +begin + LTree := FTree; + LTree.Font.Name := 'Tahoma'; + LTree.Font.Size := 10; + + EnableMultiCellSelection(LTree); + + n3 := FNode3; + n5 := FNode5; + +// Occasional failure caused by clipboard copy issues, but this +// is due to interaction of complex interaction of Windows, console and +// DUnit testing, the failure is not seen in actual interacting applications + + // Select rectangle from n3, col2 to n5, col4 + LText := ''; LTries := 0; + repeat + LTree.SelectCells(n3, 1, n5, 3, False); + LTree.CopyToClipboard; + + // The following are not necessary in an actual application + Sleep(0); + + CompleteClipboardCopy; + Inc(LTries); + try + LText := Clipboard.AsHTML; + except + // Clipboard exception is ok, anything else is not + on EClipboardException do + begin + Clipboard.Close; + end; + else + raise; + end; + // End unnecessary stuff + until (LText <> '') or (LTries > MaxTries); + LExpected := 'Version:1.0'#$D#$A'StartHTML:00000097'#$D#$A'EndHTML:00001947'#$D#$A'StartFragment:00000269'#$D#$A'EndFragment:00001915'#$D#$A''+ + ''#$D#$A + + ''#$D#$A''#$D#$A+ + ''#$D#$A+ + ' '#$D#$A' '#$D#$A+ + ' '#$D#$A' '#$D#$A' '#$D#$A + + ' '#$D#$A'
col2col3col4
3b 3c 3d
4b 4c 4d
5b 5c 5d
'; + LCompareSuccessful := LText = LExpected; + Assert.IsTrue(LCompareSuccessful, 'Clipboard text is unexpected!'); +end; + +procedure TCellSelectionTests.TestCopyPlainText1; +var + LTree: TVirtualStringTree; + n3, n4: PVirtualNode; + LText: string; + LTries: Integer; + LCompareSuccessful: LongBool; +begin + LTree := FTree; + LTree.Font.Name := 'Tahoma'; + LTree.Font.Size := 10; + + EnableMultiCellSelection(LTree); + + n3 := FNode3; + n4 := FNode4; + +// Occasional failure caused by clipboard copy issues, but this +// is due to interaction of complex interaction of Windows, console and +// DUnit testing, the failure is not seen in actual interacting applications + + // Select rectangle from n3, col2 to n4, col4 + LText := ''; LTries := 0; + repeat + LTree.SelectCells(n3, 1, n4, 3, False); + LTree.CopyToClipboard; + + // The following are not necessary in an actual application + Sleep(0); + + CompleteClipboardCopy; + Inc(LTries); + try + LText := Clipboard.AsText; + except + // Clipboard exception is ok, anything else is not + on EClipboardException do + begin + Clipboard.Close; + end; + else + raise; + end; + // End unnecessary stuff + until (LText <> '') or (LTries > MaxTries); + LCompareSuccessful := LText = 'col2'#9'col3'#9'col4'#$D#$A'3b'#9'3c'#9'3d'#$D#$A'4b'#9'4c'#9'4d'#$D#$A; + Assert.IsTrue(LCompareSuccessful, 'Clipboard text is unexpected!'); +end; + +procedure TCellSelectionTests.TestCopyPlainText2; +var + LTree: TVirtualStringTree; + n3, n5: PVirtualNode; + LText, LExpected: string; + LTries: Integer; + LCompareSuccessful: LongBool; +begin + LTree := FTree; + LTree.Font.Name := 'Tahoma'; + LTree.Font.Size := 10; + + EnableMultiCellSelection(LTree); + + n3 := FNode3; + n5 := FNode5; + +// Occasional failure caused by clipboard copy issues, but this +// is due to interaction of complex interaction of Windows, console and +// DUnit testing, the failure is not seen in actual interacting applications + + // Select rectangle from n3, col2 to n5, col4 + LText := ''; LTries := 0; + repeat + LTree.SelectCells(n3, 1, n5, 3, False); + LTree.CopyToClipboard; + + // The following are not necessary in an actual application + Sleep(0); + + CompleteClipboardCopy; + Inc(LTries); + try + LText := Clipboard.AsText; + except + // Clipboard exception is ok, anything else is not + on EClipboardException do + begin + Clipboard.Close; + end; + else + raise; + end; + // End unnecessary stuff + until (LText <> '') or (LTries > MaxTries); + LExpected := 'col2'#9'col3'#9'col4'#$D#$A'3b'#9'3c'#9'3d'#$D#$A'4b'#9'4c'#9'4d'#$D#$A'5b'#9'5c'#9'5d'#$D#$A; + LCompareSuccessful := LText = LExpected; + Assert.IsTrue(LCompareSuccessful, 'Clipboard text is unexpected!'); +end; + +procedure TCellSelectionTests.TestCopyRTF1; +var + LTree: TVirtualStringTree; + n3, n4: PVirtualNode; + LText, LPlainText, LExpected: string; + LTries: Integer; + LCompareSuccessful: LongBool; +begin + LTree := FTree; + LTree.Font.Name := 'Tahoma'; + LTree.Font.Size := 8; + + EnableMultiCellSelection(LTree); + + n3 := FNode3; + n4 := FNode4; + +// Occasional failure caused by clipboard copy issues, but this +// is due to interaction of complex interaction of Windows, console and +// DUnit testing, the failure is not seen in actual interacting applications + + // Select rectangle from n3, col2 to n4, col4 + LText := ''; LTries := 0; + repeat + LTree.SelectCells(n3, 1, n4, 3, False); + LTree.CopyToClipboard; + + // The following are not necessary in an actual application + Sleep(0); + + CompleteClipboardCopy; + Inc(LTries); + try + LText := Clipboard.AsRTF; + except + // Clipboard exception is ok, anything else is not + on EClipboardException do + begin + Clipboard.Close; + end; + else + raise; + end; + // End unnecessary stuff + until (LText <> '') or (LTries > MaxTries); + LExpected := '{\rtf1\ansi\ansicpg1252\deff0\deflang1043{\fonttbl{\f0 Tahoma;}}{\colortbl;\red0\green0\blue0;}\paperw16840\paperh11907\margl720\margr720\margt720\margb720\uc1\trowd\trgaph70\cellx750\cellx1500\cellx2250\pard\intbl\ql\f0\cf1'+ + '\fs16 \u99\''3f\u111\''3f\u108\''3f\u50\''3f\cell\ql \u99\''3f\u111\''3f\u108\''3f\u51\''3f\cell\ql \u99\''3f\u111\''3f\u108\''3f\u52\''3f\cell\row\pard\intbl \u51\''3f\u98\''3f\cell\pard\intbl \u51\''3f\u99\''3f\cell\pard\intbl \u51\''3f'+ + '\u100\''3f\cell\row'#$D#$A'\pard\intbl \u52\''3f\u98\''3f\cell\pard\intbl \u52\''3f\u99\''3f\cell\pard\intbl \u52\''3f\u100\''3f\cell\row'#$D#$A'\pard\par}'; + FRichEdit.SelText := LText; + LPlainText := FRichEdit.Text; + LCompareSuccessful := LText = LExpected; + Assert.IsTrue(LCompareSuccessful, 'Clipboard text is unexpected!'); +end; + +procedure TCellSelectionTests.TestCopyRTF2; +var + LTree: TVirtualStringTree; + n3, n5: PVirtualNode; + LText, LPlainText, LExpected: string; + LTries: Integer; + LCompareSuccessful: LongBool; +begin + LTree := FTree; + LTree.Font.Name := 'Tahoma'; + LTree.Font.Size := 8; + + EnableMultiCellSelection(LTree); + + n3 := FNode3; + n5 := FNode5; + +// Occasional failure caused by clipboard copy issues, but this +// is due to interaction of complex interaction of Windows, console and +// DUnit testing, the failure is not seen in actual interacting applications + + // Select rectangle from n3, col2 to n5, col4 + LText := ''; LTries := 0; + repeat + LTree.SelectCells(n3, 1, n5, 3, False); + LTree.CopyToClipboard; + + // The following are not necessary in an actual application + Sleep(0); + + CompleteClipboardCopy; + Inc(LTries); + try + LText := Clipboard.AsRTF; + except + // Clipboard exception is ok, anything else is not + on EClipboardException do + begin + Clipboard.Close; + end; + else + raise; + end; + // End unnecessary stuff + until (LText <> '') or (LTries > MaxTries); + LExpected := '{\rtf1\ansi\ansicpg1252\deff0\deflang1043{\fonttbl{\f0 Tahoma;}}{\colortbl;\red0\green0\blue0;}\paperw16840\paperh11907\margl720\margr720\margt720\margb720\uc1\trowd\trgaph70\cellx750\cellx1500\cellx2250\pard\intbl\ql\f0\cf1\fs16 \u99\''3f\u111\''3f\u108\''3' + + 'f\u50\''3f\cell\ql \u99\''3f\u111\''3f\u108\''3f\u51\''3f\cell\ql \u99\''3f\u111\''3f\u108\''3f\u52\''3f\cell\row\pard\intbl \u51\''3f\u98\''3f\cell\pard\intbl \u51\''3f\u99\''3f\cell\pard\intbl \u51\''3f\u100\''3f\cell\row' + sLineBreak + + '\pard\intbl \u52\''3f\u98\''3f\cell\pard\intbl \u52\''3f\u99\''3f\cell\pard\intbl \u52\''3f\u100\''3f\cell\row' + sLineBreak + + '\pard\intbl \u53\''3f\u98\''3f\cell\pard\intbl \u53\''3f\u99\''3f\cell\pard\intbl \u53\''3f\u100\''3f\cell\row' + sLineBreak + + '\pard\par}'; + FRichEdit.SelText := LText; + LPlainText := FRichEdit.Text; + LCompareSuccessful := LText = LExpected; + Assert.IsTrue(LCompareSuccessful, 'Clipboard text is unexpected!'); +end; + +procedure TCellSelectionTests.TestEmptyAreaOnChange1; +var + LTree: TVirtualStringTree; + n3: PVirtualNode; + LOnChangeFired: LongBool; + I, LColumnCount, LMaxWidth: Integer; + Rects: TArray; + LargestRect: TRect; + LTextOnly, LUnclipped, LApplyCellContentMargin: Boolean; + LastNode, LHitNode: PVirtualNode; + LEmptyArea: TPoint; + LHitInfo: THitInfo; +begin + LTree := FTree; + n3 := FNode3; + + // Calculate the largest client area for the VirtualTree and set it + LColumnCount := LTree.Header.Columns.Count; + LMaxWidth := 0; + for I := 0 to LColumnCount-1 do + begin + if LTree.Header.Columns[I].Width > LMaxWidth then + LMaxWidth := LTree.Header.Columns[I].Width; + end; + I := 0; + for LTextOnly := False to True do + for LUnclipped := False to True do + for LApplyCellContentMargin := False to True do + begin + SetLength(Rects, I+1); + Rects[I] := LTree.GetDisplayRect(n3, LColumnCount-1, LTextOnly, LUnclipped, LApplyCellContentMargin); + Inc(I); + end; + LargestRect := Rects[0]; + for I := 1 to High(Rects) do + begin + LargestRect := TRect.Union(LargestRect, Rects[I]); + end; + + LastNode := LTree.GetLastVisible; + + LTree.ClientHeight := LargestRect.BottomRight.Y + (LastNode.NodeHeight * 2); + LTree.ClientWidth := LargestRect.BottomRight.X + LMaxWidth; + + // This should be an empty area, beyond any visible nodes + LEmptyArea := Point(LargestRect.BottomRight.X + LMaxWidth, LargestRect.BottomRight.Y + LastNode.NodeHeight); + + // At this point, there should be no nodes selected + Assert.IsTrue(LTree.SelectedCount = 0); + LTree.MouseClick(n3); + // At this point, a node should be selected + Assert.IsTrue(LTree.SelectedCount = 1); + + LOnChangeFired := False; + LHitNode := Pointer($FFFFFFFF); + AssignChange(procedure (Sender: TBaseVirtualTree; ANode: PVirtualNode) + begin + LOnChangeFired := True; + LHitNode := ANode; + end); + + LTree.GetHitTestInfoAt(LEmptyArea.X, LEmptyArea.Y, True, LHitInfo); + LTree.MouseClick(LEmptyArea); + + Assert.IsTrue(hiNowhere in LHitInfo.HitPositions, 'Mouse click is not in an unpopulated/empty area!'); + Assert.IsTrue(LOnChangeFired, 'OnChange event not fired!'); + Assert.IsTrue(LHitNode = nil, 'Node is not nil!'); +end; + +procedure TCellSelectionTests.TestEmptyAreaOnChange2; +var + LTree: TVirtualStringTree; + n1: PVirtualNode; + LOnChangeFired: LongBool; + I, LColumnCount, LMaxWidth: Integer; + Rects: TArray; + LargestRect: TRect; + LTextOnly, LUnclipped, LApplyCellContentMargin: Boolean; + LastNode, LHitNode: PVirtualNode; + LEmptyArea: TPoint; + LHitInfo: THitInfo; + LTestForm: TVisibilityForm; +begin + LTestForm := TVisibilityForm.Create(nil); + try + LTestForm.Show; + LTree := LTestForm.VST1; + + n1 := LTree.GetLastVisible; + + // Calculate the largest client area for the VirtualTree and set it + LColumnCount := LTree.Header.Columns.Count; + LMaxWidth := 0; + for I := 0 to LColumnCount-1 do + begin + if LTree.Header.Columns[I].Width > LMaxWidth then + LMaxWidth := LTree.Header.Columns[I].Width; + end; + if LMaxWidth = 0 then + LMaxWidth := 300; + I := 0; + LargestRect := TRect.Empty; + for LTextOnly := False to True do + for LUnclipped := False to True do + for LApplyCellContentMargin := False to True do + begin + SetLength(Rects, I+1); + Rects[I] := LTree.GetDisplayRect(n1, LColumnCount-1, LTextOnly, LUnclipped, LApplyCellContentMargin); + LargestRect := TRect.Union(LargestRect, Rects[I]); + Inc(I); + end; + + LastNode := LTree.GetLastVisibleChild(LTree.RootNode); + + LTree.ClientHeight := LargestRect.BottomRight.Y + (LastNode.NodeHeight * 2); + LTree.ClientWidth := LargestRect.BottomRight.X + LMaxWidth; + + // This should be an empty area, beyond any visible nodes + LEmptyArea := Point(LargestRect.BottomRight.X + LMaxWidth, LargestRect.BottomRight.Y + LastNode.NodeHeight); + + // At this point, there should be no nodes selected + Assert.IsTrue(LTree.SelectedCount = 0); + LTree.MouseClick(n1, NoColumn); + // At this point, a node should be selected + Assert.IsTrue(LTree.SelectedCount = 1); + + LOnChangeFired := False; + LHitNode := Pointer($FFFFFFFF); + AssignChange(procedure (Sender: TBaseVirtualTree; ANode: PVirtualNode) + begin + LOnChangeFired := True; + LHitNode := ANode; + end, LTree); + + LTree.GetHitTestInfoAt(LEmptyArea.X, LEmptyArea.Y, True, LHitInfo); + LTree.MouseClick(LEmptyArea); + + // Clicking on an empty area clears the selection + + Assert.IsTrue(hiNowhere in LHitInfo.HitPositions, 'Mouse click is not in an unpopulated/empty area!'); + Assert.IsTrue(LOnChangeFired, 'OnChange event not fired!'); + Assert.IsTrue(LHitNode = nil, 'Node is not nil!'); + finally + LTestForm.Free; + end; +end; + +procedure TCellSelectionTests.TestOnChange; +var + LTree: TVirtualStringTree; + n3: PVirtualNode; + LOnChangeFired: LongBool; +begin + LTree := FTree; + n3 := FNode3; + + LOnChangeFired := False; + AssignChange(procedure (Sender: TBaseVirtualTree; ANode: PVirtualNode) + begin + LOnChangeFired := True; + end); + + LTree.MouseClick(n3); + Assert.IsTrue(LOnChangeFired, 'OnChange event not fired!'); +end; + +procedure TCellSelectionTests.TestSelectCellsRectangular; +var + LTree: TVirtualStringTree; + n3, n4: PVirtualNode; + LNodes: TArray; + LNode: PVirtualNode; + LColumn: Integer; +begin + + LTree := FTree; + + EnableMultiCellSelection; + + n3 := FNode3; + n4 := FNode4; + + // Select rectangle from n3, col2 to n2, col3 + LTree.SelectCells(n3, 1, n4, 2, False); + + Assert.IsTrue(toExtendedFocus in LTree.TreeOptions.SelectionOptions); + Assert.IsTrue(toMultiSelect in LTree.TreeOptions.SelectionOptions); + + // Ensure the selected cells above are selected + Assert.IsTrue(LTree.IsCellSelected(n3, 1), 'n3, col1 should be selected'); + Assert.IsTrue(LTree.IsCellSelected(n3, 2), 'n3, col2 should be selected'); + Assert.IsTrue(LTree.IsCellSelected(n4, 1), 'n4, col1 should be selected'); + Assert.IsTrue(LTree.IsCellSelected(n4, 2), 'n4, col2 should be selected'); + + // Ensure the non-selected cells are not selected + Assert.IsFalse(LTree.IsCellSelected(n3, 0), 'n3, col0 should not be selected'); + Assert.IsFalse(LTree.IsCellSelected(n3, 3), 'n3, col3 should not be selected'); + Assert.IsFalse(LTree.IsCellSelected(n4, 0), 'n4, col0 should not be selected'); + Assert.IsFalse(LTree.IsCellSelected(n4, 3), 'n4, col3 should not be selected'); + + LNodes := [FNode1, FNode2, FNode5, FNode6, FNode7, FNode8]; + for LNode in LNodes do + for LColumn := 0 to 3 do + Assert.IsFalse(LTree.IsCellSelected(LNode, LColumn), + Format('Row: $%p Column: %d should not be selected', [Pointer(LNode), LColumn])); +end; + +procedure TCellSelectionTests.TestSelectMultipleCellsFailWithoutExtendedFocus; +var + LTree: TVirtualStringTree; + n3, n4: PVirtualNode; +begin + LTree := FTree; + LTree.TreeOptions.SelectionOptions := LTree.TreeOptions.SelectionOptions - + [toExtendedFocus]; + + n3 := FNode3; + n4 := FNode4; + + // Select rectangle from n3, col2 to n2, col3 + LTree.SelectCells(n3, 1, n4, 2, False); + + // Ensure the selected cells above are not selected + Assert.IsFalse(LTree.IsCellSelected(n3, 1), 'n3, col1 should not be selected'); + Assert.IsFalse(LTree.IsCellSelected(n3, 2), 'n3, col2 should not be selected'); + Assert.IsFalse(LTree.IsCellSelected(n4, 1), 'n4, col1 should not be selected'); + Assert.IsFalse(LTree.IsCellSelected(n4, 2), 'n4, col2 should not be selected'); +end; + +procedure TCellSelectionTests.TestSelectMultipleCellsFailWithoutMultiSelect; +var + LTree: TVirtualStringTree; + n3, n4: PVirtualNode; +begin + LTree := FTree; + LTree.TreeOptions.SelectionOptions := LTree.TreeOptions.SelectionOptions - + [toMultiSelect]; + + n3 := FNode3; + n4 := FNode4; + + // Select rectangle from n3, col2 to n2, col3 + LTree.SelectCells(n3, 1, n4, 2, False); + + // Ensure the selected cells above are not selected + Assert.IsFalse(LTree.IsCellSelected(n3, 1), 'n3, col1 should not be selected'); + Assert.IsFalse(LTree.IsCellSelected(n3, 2), 'n3, col2 should not be selected'); + Assert.IsFalse(LTree.IsCellSelected(n4, 1), 'n4, col1 should not be selected'); + Assert.IsFalse(LTree.IsCellSelected(n4, 2), 'n4, col2 should not be selected'); +end; + +procedure TCellSelectionTests.TestSelectSingleCell; +var + LTree: TVirtualStringTree; + n3: PVirtualNode; + LSelectedCells: TVTCellArray; + LNodes: TArray; + LNode: PVirtualNode; + LColumn: Integer; + LCellChangeFired: LongBool; +begin + LTree := FTree; + + EnableMultiCellSelection; + + 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; + Assert.IsTrue(Length(LSelectedCells) = 1, 'Should only have 1 cell selected'); + Assert.IsTrue((LSelectedCells[0].Node = n3) and (LSelectedCells[0].Column = 1)); + + LNodes := [FNode1, FNode2, n3, FNode4, FNode5, FNode6, FNode7, FNode8]; + for LNode in LNodes do + for LColumn := 0 to 3 do + begin + if (LNode = n3) and (LColumn = 1) then + Continue; + Assert.IsFalse(LTree.IsCellSelected(LNode, LColumn), + Format('Row: $%p Column: %d should not be selected', [Pointer(LNode), LColumn])); + end; +end; + +procedure TCellSelectionTests.TestShiftClickMultipleCells; +var + LTree: TVirtualStringTree; + n3, n4: PVirtualNode; + LSelectedCells, LNewSelectedCells: TVTCellArray; +begin + LTree := FTree; + + EnableMultiCellSelection; + + n3 := FNode3; + n4 := FNode4; + + LTree.MouseClick(n3, 1); + LSelectedCells := LTree.SelectedCells; + LTree.ShiftMouseClick(n4, 2); + LNewSelectedCells := LTree.SelectedCells; + + Assert.IsTrue(Length(LSelectedCells) = 1, 'Length of selected cell is unexpected!'); + Assert.IsTrue((LSelectedCells[0].Node = n3) and (LSelectedCells[0].Column = 1), 'Unexpected cell selection 1'); + + Assert.IsTrue(Length(LNewSelectedCells) = 4, 'Length of selected cells is unexpected!'); + Assert.IsTrue((LNewSelectedCells[0].Node = n3) and (LNewSelectedCells[0].Column = 1), 'Unexpected cell selection 0!'); + Assert.IsTrue((LNewSelectedCells[1].Node = n3) and (LNewSelectedCells[1].Column = 2), 'Unexpected cell selection 1!'); + Assert.IsTrue((LNewSelectedCells[2].Node = n4) and (LNewSelectedCells[2].Column = 1), 'Unexpected cell selection 2!'); + Assert.IsTrue((LNewSelectedCells[3].Node = n4) and (LNewSelectedCells[3].Column = 2), 'Unexpected cell selection 3!'); +end; + +procedure TCellSelectionTests.TestLeftClickSelectsNode; +var + LTree: TVirtualStringTree; + LNode: PVirtualNode; + LSelectedCells: TVTCellArray; + LSelected: LongBool; + LForm: TSelectionTestForm; +begin + LTree := FTree; + + LNode := FNode3; + EnableMultiCellSelection; + + LSelectedCells := LTree.SelectedCells; + Assert.IsTrue(Length(LSelectedCells) = 0, 'Length of selected cell is unexpected!'); + LTree.MouseClick(LNode, 0); + + LSelectedCells := LTree.SelectedCells; + Assert.IsTrue(Length(LSelectedCells) = 1, 'Length of selected cell is unexpected!'); + + LTree.ClearCellSelection; + LSelectedCells := LTree.SelectedCells; + Assert.IsTrue(Length(LSelectedCells) = 0, 'Length of selected cell is unexpected!'); + + // Remove multiselect, which is part of multicell select + LTree.TreeOptions.SelectionOptions := LTree.TreeOptions.SelectionOptions - + [toMultiSelect]; + // SelectionOptions should now be [toExtendedFocus,toSelectNextNodeOnRemoval] + LTree.MouseClick(LNode); + + LSelectedCells := LTree.SelectedCells; + Assert.IsTrue(Length(LSelectedCells) = 0, 'Length of selected cell is unexpected!'); + + 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; +var + LTree: TVirtualStringTree; + n3: PVirtualNode; + LSelectedCells: TVTCellArray; +begin + LTree := FTree; + + n3 := FNode3; + LTree.TreeOptions.SelectionOptions := LTree.TreeOptions.SelectionOptions - + [toMultiSelect]; + + LSelectedCells := LTree.SelectedCells; + Assert.IsTrue(Length(LSelectedCells) = 0, 'Length of selected cell is unexpected!'); + + LTree.MouseClick(n3, 1); + + LSelectedCells := LTree.SelectedCells; + Assert.IsTrue(Length(LSelectedCells) = 0, 'Length of selected cell is unexpected!'); +end; + +procedure TCellSelectionTests.TestRemovingSetsClearCellSelection; +var + LTree: TVirtualStringTree; + n3: PVirtualNode; + LSelectedCells: TVTCellArray; + LNodeSelected: LongBool; + + procedure DisableMulticellSelection; + begin + LTree.TreeOptions.SelectionOptions := LTree.TreeOptions.SelectionOptions - + [toMultiCellSelect]; + end; + + procedure SelectCell; + begin + EnableMultiCellSelection(LTree); + 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; + Assert.IsTrue(Length(LSelectedCells) = 0, 'Length of selected cell is unexpected!'); + end; + + procedure EnsureCellSelected; + begin + LSelectedCells := LTree.SelectedCells; + Assert.IsTrue(Length(LSelectedCells) = 1, 'Length of selected cell is unexpected!'); + end; + + procedure EnsureSelectCell; + begin + EnsureCellNotSelected; + SelectCell; + EnsureCellSelected; + end; + + procedure CheckTree; + begin + EnsureSelectCell; + DisableMulticellSelection; + EnsureCellNotSelected; + + EnableMulticellSelection; + SelectCell; + EnsureCellSelected; + + LTree.ClearCellSelection; + EnsureCellNotSelected; + + DisableMulticellSelection; + LTree.ClearSelection; + EnsureNodeNotSelected; + SelectNode; + EnsureNodeSelected; + + EnsureSelectCell; + LTree.TreeOptions.SelectionOptions := LTree.TreeOptions.SelectionOptions - [toMultiCellSelect]; + 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 - [toExtendedFocus, toMultiSelect]; + EnsureCellNotSelected; + + EnsureSelectCell; + LTree.TreeOptions.SelectionOptions := LTree.TreeOptions.SelectionOptions + [toFullRowSelect]; + EnsureCellNotSelected; + end; + +var + LForm: TSelectionTestForm; +begin + LTree := FTree; + n3 := FNode3; + + // 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 + TDUnitX.RegisterTestFixture(TCellSelectionTests); +end. diff --git a/Tests/VTOnDrawTextTests.pas b/Tests/VTOnDrawTextTests.pas new file mode 100644 index 000000000..3d4dcb7fa --- /dev/null +++ b/Tests/VTOnDrawTextTests.pas @@ -0,0 +1,181 @@ +unit VTOnDrawTextTests; + +interface + +uses + DUnitX.TestFramework, + Vcl.Forms, + VirtualTrees, System.Types; + +type + + [TestFixture] + TVTOnDrawTextTests = class + strict private + fTree: TVirtualStringTree; + fForm: TForm; + + FDrawText1Called: Boolean; + FDrawTextEx1Called: Boolean; + + FDrawText2Called: Boolean; + FDrawTextEx2Called: Boolean; + + FDrawText3Called: Boolean; + FDrawTextEx3Called: Boolean; + + procedure DrawText1Event(Sender: TBaseVirtualTree; TargetCanvas: TCanvas; + Node: PVirtualNode; Column: TColumnIndex; const Text: string; + const CellRect: TRect; var DefaultDraw: Boolean); + + procedure DrawTextEx2Event(Sender: TBaseVirtualTree; TargetCanvas: TCanvas; + Node: PVirtualNode; Column: TColumnIndex; const Text: string; + const CellRect: TRect; var DefaultDraw: Boolean; var DrawFormat: Cardinal); + + procedure DrawText3Event(Sender: TBaseVirtualTree; TargetCanvas: TCanvas; + Node: PVirtualNode; Column: TColumnIndex; const Text: string; + const CellRect: TRect; var DefaultDraw: Boolean); + procedure DrawTextEx3Event(Sender: TBaseVirtualTree; TargetCanvas: TCanvas; + Node: PVirtualNode; Column: TColumnIndex; const Text: string; + const CellRect: TRect; var DefaultDraw: Boolean; var DrawFormat: Cardinal); + + procedure GetTextEvent(Sender: TBaseVirtualTree; Node: PVirtualNode; + Column: TColumnIndex; TextType: TVSTTextType; var CellText: string); + public + [Setup] + procedure Setup; + [TearDown] + procedure TearDown; + + [Test] + procedure TestOnDrawText; + + [Test] + procedure TestOnDrawTextOnDrawTextEx; + + [Test] + procedure TestOnDrawTextEx; + end; + +implementation + +uses + System.SysUtils, VirtualTrees.Types; + +const + colCaption = 0; + colData = 1; + +procedure TVTOnDrawTextTests.DrawText1Event(Sender: TBaseVirtualTree; + TargetCanvas: TCanvas; Node: PVirtualNode; Column: TColumnIndex; + const Text: string; const CellRect: TRect; var DefaultDraw: Boolean); +begin + FDrawText1Called := True; +end; + +procedure TVTOnDrawTextTests.DrawText3Event(Sender: TBaseVirtualTree; + TargetCanvas: TCanvas; Node: PVirtualNode; Column: TColumnIndex; + const Text: string; const CellRect: TRect; var DefaultDraw: Boolean); +begin + FDrawText3Called := True; +end; + +procedure TVTOnDrawTextTests.DrawTextEx2Event(Sender: TBaseVirtualTree; + TargetCanvas: TCanvas; Node: PVirtualNode; Column: TColumnIndex; + const Text: string; const CellRect: TRect; var DefaultDraw: Boolean; + var DrawFormat: Cardinal); +begin + FDrawTextEx2Called := True; +end; + +procedure TVTOnDrawTextTests.DrawTextEx3Event(Sender: TBaseVirtualTree; + TargetCanvas: TCanvas; Node: PVirtualNode; Column: TColumnIndex; + const Text: string; const CellRect: TRect; var DefaultDraw: Boolean; + var DrawFormat: Cardinal); +begin + FDrawTextEx3Called := True; +end; + +procedure TVTOnDrawTextTests.GetTextEvent(Sender: TBaseVirtualTree; + Node: PVirtualNode; Column: TColumnIndex; TextType: TVSTTextType; + var CellText: string); +begin + case Column of + colCaption: begin + CellText := 'Caption'; + end; + colData: begin + CellText := 'Data'; + end; + end; +end; + +procedure TVTOnDrawTextTests.Setup; +var + LCol1, LCol2: TVirtualTreeColumn; +begin + FDrawText1Called := False; + FDrawTextEx1Called := False; + + FDrawText2Called := False; + FDrawTextEx2Called := False; + + FDrawText3Called := False; + FDrawTextEx3Called := False; + + fForm := TForm.Create(nil); + fTree := TVirtualStringTree.Create(fForm); + fForm.InsertControl(fTree); + + fTree.OnGetText := GetTextEvent; + + LCol1 := fTree.Header.Columns.Add; + LCol2 := fTree.Header.Columns.Add; + LCol1.Text := 'Caption'; + LCol2.Text := 'Data'; + + fTree.AddChild(fTree.RootNode); + fTree.AddChild(fTree.RootNode); + fForm.Show; +end; + +procedure TVTOnDrawTextTests.TearDown; +begin + FreeAndNil(fForm); +end; + +procedure TVTOnDrawTextTests.TestOnDrawText; +begin + // This test ensures that OnDrawText event is called when OnDrawText is assigned + fTree.OnDrawText := DrawText1Event; + fTree.OnDrawTextEx := nil; + fTree.Update; + + Assert.IsTrue(FDrawText1Called and not FDrawTextEx1Called); +end; + +procedure TVTOnDrawTextTests.TestOnDrawTextEx; +begin + // This test ensures that OnDrawTextEx event is called when OnDrawTextEx is assigned + // and that OnDrawText is not called + fTree.OnDrawText := nil; + fTree.OnDrawTextEx := DrawTextEx2Event; + fTree.Update; + + Assert.IsTrue(not FDrawText2Called and FDrawTextEx2Called); +end; + +procedure TVTOnDrawTextTests.TestOnDrawTextOnDrawTextEx; +begin + // This test ensures that only the OnDrawTextEx event is called when both + // OnDrawText and OnDrawTextEx are assigned and that OnDrawText is not called + fTree.OnDrawText := DrawText3Event; + fTree.OnDrawTextEx := DrawTextEx3Event; + fTree.Update; + + Assert.IsTrue(not FDrawText3Called and FDrawTextEx3Called); +end; + +initialization + TDUnitX.RegisterTestFixture(TVTOnDrawTextTests); +end. diff --git a/Tests/VTOnEditCancelledTests.pas b/Tests/VTOnEditCancelledTests.pas new file mode 100644 index 000000000..36e7aec53 --- /dev/null +++ b/Tests/VTOnEditCancelledTests.pas @@ -0,0 +1,136 @@ +unit VTOnEditCancelledTests; + +interface + +uses + DUnitX.TestFramework, + Vcl.Forms, + VirtualTrees; + +type + + [TestFixture] + TVTOnEditCancelledTests = class + strict private + fTree: TVirtualStringTree; + fForm: TForm; + FEditCancelled: Boolean; + procedure TreeEditCancelled(Sender: TBaseVirtualTree; Column: TColumnIndex); + public + [Setup] + procedure Setup; + [TearDown] + procedure TearDown; + + [Test] + procedure TestAddColumn; + + [Test] + procedure TestEditNodeFail; + + [Test] + procedure TestEditNode; + + [Test] + procedure TestEditNodeReadOnly; + + [Test] + procedure TestOnEditCancelled; + end; + +implementation + +uses + System.SysUtils, VirtualTrees.Types; + +procedure TVTOnEditCancelledTests.Setup; +begin + fForm := TForm.Create(nil); + fTree := TVirtualStringTree.Create(fForm); +end; + +procedure TVTOnEditCancelledTests.TearDown; +begin + FreeAndNil(fForm); +end; + +procedure TVTOnEditCancelledTests.TestAddColumn; +var + LBeforeColumnCount, LAfterColumnCount: Integer; +begin + LBeforeColumnCount := fTree.Header.Columns.Count; + fTree.Header.Columns.Add; + LAfterColumnCount := fTree.Header.Columns.Count; + Assert.AreEqual(LAfterColumnCount - LBeforeColumnCount, 1); +end; + +procedure TVTOnEditCancelledTests.TestEditNode; +var + LNode: PVirtualNode; + LEditNodeResult: Boolean; + LAfterStates: TVirtualTreeStates; +begin + fForm.Show; + fTree.TreeOptions.MiscOptions := fTree.TreeOptions.MiscOptions + [toEditable]; + fTree.Parent := fForm; + fTree.Header.Columns.Add; + LNode := fTree.AddChild(fTree.RootNode); + LEditNodeResult := fTree.EditNode(LNode, 0); + LAfterStates := fTree.TreeStates; + Assert.AreEqual(LAfterStates * [tsEditing], [tsEditing]); + Assert.IsTrue(LEditNodeResult); +end; + +procedure TVTOnEditCancelledTests.TestEditNodeFail; +var + LNode: PVirtualNode; + LEditNodeResult: Boolean; +begin + fForm.Show; + fTree.TreeOptions.MiscOptions := fTree.TreeOptions.MiscOptions - [toEditable]; + fTree.Parent := fForm; + fTree.Header.Columns.Add; + LNode := fTree.AddChild(fTree.RootNode); + LEditNodeResult := fTree.EditNode(LNode, 0); + Assert.IsFalse(LEditNodeResult); +end; + +procedure TVTOnEditCancelledTests.TestEditNodeReadOnly; +var + LNode: PVirtualNode; + LEditNodeResult: Boolean; +begin + fForm.Show; + fTree.Parent := fForm; + fTree.Header.Columns.Add; + LNode := fTree.AddChild(fTree.RootNode); + fTree.TreeOptions.MiscOptions := fTree.TreeOptions.MiscOptions + [toReadOnly]; + LEditNodeResult := fTree.EditNode(LNode, 0); + Assert.IsFalse(LEditNodeResult); +end; + +procedure TVTOnEditCancelledTests.TestOnEditCancelled; +var + LNode: PVirtualNode; +begin + fForm.Show; + FEditCancelled := False; + fTree.OnEditCancelled := TreeEditCancelled; + fTree.TreeOptions.MiscOptions := fTree.TreeOptions.MiscOptions + [toEditable]; + LNode := fTree.AddChild(fTree.RootNode); + fTree.Parent := fForm; + fTree.Header.Columns.Add; + fTree.EditNode(LNode, 0); + fTree.CancelEditNode; + Assert.IsTrue(FEditCancelled); +end; + +procedure TVTOnEditCancelledTests.TreeEditCancelled(Sender: TBaseVirtualTree; + Column: TColumnIndex); +begin + FEditCancelled := True; +end; + +initialization + TDUnitX.RegisterTestFixture(TVTOnEditCancelledTests); +end. diff --git a/Tests/Vcl.ClipboardHelper.pas b/Tests/Vcl.ClipboardHelper.pas new file mode 100644 index 000000000..eaf7ea737 --- /dev/null +++ b/Tests/Vcl.ClipboardHelper.pas @@ -0,0 +1,54 @@ +unit Vcl.ClipboardHelper; + +interface + +uses + Vcl.Clipbrd, Winapi.Windows; + +type + TClipboardHelper = class helper for TClipboard + protected + function GetAsFormat(uFormat: UINT): string; + function GetAsHTML: string; + function GetAsRTF: string; + public + property AsHTML: string read GetAsHTML; + property AsRTF: string read GetAsRTF; + end; + +implementation + +uses + VirtualTrees.ClipBoard; + +{ TClipboardHelper } + +function TClipboardHelper.GetAsFormat(uFormat: UINT): string; +var + Data: THandle; +begin + Open; + Data := GetClipboardData(uFormat); + try + if Data <> 0 then + Result := string(AnsiString(PAnsiChar(GlobalLock(Data)))) + else + Result := ''; + finally + if Data <> 0 then + GlobalUnlock(Data); + Close; + end; +end; + +function TClipboardHelper.GetAsHTML: string; +begin + Result := GetAsFormat(CF_HTML); +end; + +function TClipboardHelper.GetAsRTF: string; +begin + Result := GetAsFormat(CF_VRTF); +end; + +end. diff --git a/Tests/VirtualTrees.MouseUtils.pas b/Tests/VirtualTrees.MouseUtils.pas new file mode 100644 index 000000000..09d9882fa --- /dev/null +++ b/Tests/VirtualTrees.MouseUtils.pas @@ -0,0 +1,186 @@ +unit VirtualTrees.MouseUtils; + +interface + +uses + VirtualTrees, System.Types; + +type + + /// + /// Created to be used only for testing + /// + TCustomVirtualStringTreeMouseHelper = class helper for TCustomVirtualStringTree + protected + const + 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; + +implementation + +uses + Winapi.Windows, Vcl.Controls, Winapi.Messages, VirtualTrees.Types, System.Math, + System.SysUtils; + +{ TCustomVirtualStringTreeMouseHelper } + +function TCustomVirtualStringTreeMouseHelper.GetDisplayRectEx( + ANode: PVirtualNode; AColumn: TColumnIndex): TPoint; +var + R: TRect; + LRight: TDimension; +begin + if not Assigned(ANode) then + begin + Result := Point(0, 0); + Exit; + end; + + // Use the full-row rect to get a reliable Y coordinate for hit testing. + R := GetDisplayRect(ANode, NoColumn, False, False, False); + + if R.IsEmpty then + begin + Exit(Point(0, 0)); + end; + + Result.Y := R.Top + (R.Bottom - R.Top) div 2; + Header.Columns.GetColumnBounds(AColumn, Result.X, LRight); + + // If header is visible the client coordinates for hit testing are below the header. + if hoVisible in Header.Options then + Inc(Result.Y, Header.Height); +end; + +procedure TCustomVirtualStringTreeMouseHelper.MouseClick(ACursorPos: TPoint); +var + LKeyboardState: TKeyboardState; + LTree: TCustomVirtualStringTree; + LSavedCursorPos: TPoint; + LWPARAM: WPARAM; + LPos: LPARAM; +begin + // Click a new cell on the tree... + LTree := Self; + LSavedCursorPos := Mouse.CursorPos; + try + Mouse.CursorPos := ACursorPos; + LWPARAM := MK_LBUTTON; + if GetKeyboardState(LKeyboardState) then + begin + if (LKeyboardState[VK_SHIFT] and KEYDOWN <> 0) or + (LKeyboardState[VK_LSHIFT] and KEYDOWN <> 0) or + (LKeyboardState[VK_RSHIFT] and KEYDOWN <> 0) then + LWPARAM := LWPARAM or MK_SHIFT; + if (LKeyboardState[VK_CONTROL] and KEYDOWN <> 0) or + (LKeyboardState[VK_LCONTROL] and KEYDOWN <> 0) or + (LKeyboardState[VK_RCONTROL] and KEYDOWN <> 0) then + LWPARAM := LWPARAM or MK_CONTROL; + end; + LPos := MakeLParam(ACursorPos.X, ACursorPos.Y); + LTree.Perform(WM_LBUTTONDOWN, LWPARAM, LPos); + LTree.Perform(WM_LBUTTONUP, LWPARAM, LPos); + finally + Mouse.CursorPos := LSavedCursorPos; + end; +end; + +procedure TCustomVirtualStringTreeMouseHelper.KeyedMouseClick( + Key: Byte; ACursorPos: TPoint); +var + LOrigKBState, LNewKBState: TKeyboardState; +begin + GetKeyboardState(LOrigKBState); + LNewKBState := LOrigKBState; + LNewKBState[Key] := LOrigKBState[Key] or KEYDOWN; + SetKeyboardState(LNewKBState); + try + MouseClick(ACursorPos); + finally + SetKeyboardState(LOrigKBState); + end; +end; + +procedure TCustomVirtualStringTreeMouseHelper.KeyedMouseClick( + Key: Byte; ANode: PVirtualNode; AColumn: TColumnIndex = 0); +var + LOrigKBState, LNewKBState: TKeyboardState; +begin + GetKeyboardState(LOrigKBState); + LNewKBState := LOrigKBState; + LNewKBState[Key] := LOrigKBState[Key] or KEYDOWN; + SetKeyboardState(LNewKBState); + try + MouseClick(ANode, AColumn); + finally + SetKeyboardState(LOrigKBState); + end; +end; + +procedure TCustomVirtualStringTreeMouseHelper.MouseClick(ANode: PVirtualNode; + AColumn: TColumnIndex = 0 +); +var + LTree: TCustomVirtualStringTree; + LClientRect, LClientRect2: TRect; + LHitInfo: THitInfo; + LTopLeft: TPoint; + LPasses, LCount: Integer; +begin + LTree := Self; + if not Assigned(ANode) then + Exit; + + LClientRect := LTree.GetDisplayRect(ANode, AColumn, True, True, True); + LTopLeft := LClientRect.TopLeft; + if hoVisible in LTree.Header.Options then + begin + Inc(LTopLeft.Y, LTree.Header.Height); + end; + + LPasses := 0; + LCount := LTree.VisibleCount; + repeat + LTree.GetHitTestInfoAt(LTopLeft.X, LTopLeft.Y, True, LHitInfo, []); + LClientRect2 := LTree.GetDisplayRect(LHitInfo.HitNode, AColumn, True); + if LHitInfo.HitNode <> ANode then + Inc(LTopLeft.Y, LHitInfo.HitNode.NodeHeight); + Inc(LPasses); // Prevent forever loop + until (LHitInfo.HitNode = ANode) or (LPasses > LCount); + Assert((LHitInfo.HitNode = ANode) and (LHitInfo.HitColumn = AColumn)); + + MouseClick(LTopLeft); +end; + +procedure TCustomVirtualStringTreeMouseHelper.CtrlMouseClick( + ANode: PVirtualNode; AColumn: TColumnIndex); +begin + KeyedMouseClick(VK_CONTROL, ANode, AColumn); +end; + +procedure TCustomVirtualStringTreeMouseHelper.CtrlMouseClick( + ACursorPos: TPoint); +begin + KeyedMouseClick(VK_CONTROL, ACursorPos); +end; + +procedure TCustomVirtualStringTreeMouseHelper.ShiftMouseClick( + ANode: PVirtualNode; AColumn: TColumnIndex = 0); +begin + KeyedMouseClick(VK_SHIFT, ANode, AColumn); +end; + +end. diff --git a/Tests/VisibilityTest.dpr b/Tests/VisibilityTest.dpr new file mode 100644 index 000000000..2a5abd4a6 --- /dev/null +++ b/Tests/VisibilityTest.dpr @@ -0,0 +1,17 @@ +program VisibilityTest; + +uses + Vcl.Forms, + 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 new file mode 100644 index 000000000..775b2e382 --- /dev/null +++ b/Tests/VisibilityTest.dproj @@ -0,0 +1,164 @@ + + + {A378499F-32AF-4362-9ED1-0859B1AED44A} + 20.3 + VCL + True + Debug + Win32 + VisibilityTest + 3 + Application + VisibilityTest.dpr + + + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Cfg_1 + true + true + + + true + Cfg_1 + true + true + + + true + Base + true + + + true + Cfg_2 + true + true + + + true + Cfg_2 + true + true + + + .\$(Platform)\$(Config) + .\$(Platform)\$(Config) + false + false + false + false + false + System;Xml;Data;Datasnap;Web;Soap;Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;$(DCC_Namespace) + $(BDS)\bin\delphi_PROJECTICON.ico + VisibilityTest + + + ExecutableExplorer;vclwinx;DataSnapServer;ProgressBarComponent;PluginCommonRTL;fmx;emshosting;vclie;DbxCommonDriver;bindengine;IndyIPCommon;VCLRESTComponents;DBXMSSQLDriver;FireDACCommonODBC;emsclient;FireDACCommonDriver;SupportedServices;appanalytics;IndyProtocols;vclx;Skia.Package.RTL;TestPackage;IndyIPClient;dbxcds;vcledge;bindcompvclwinx;JSONRPC.Registrar;emsedge;bindcompfmx;XMLSummaryExpert;DBXFirebirdDriver;TerminalConsolePackage_CommandPromptHere_TConsole;BuildGroupsColumnFixer;inetdb;FireDACSqliteDriver;DbxClientDriver;FireDACASADriver;soapmidas;vclactnband;fmxFireDAC;dbexpress;FireDACInfxDriver;DBXMySQLDriver;VclSmp;inet;DataSnapCommon;TerminalFrame;AsyncProDR;vcltouch;fmxase;DBXOdbcDriver;dbrtl;FireDACDBXDriver;Skia.Package.FMX;FireDACOracleDriver;fmxdae;ProgressBarDesignTime;EnableDebugVariables;FireDACMSAccDriver;EnableScrollableMenus;CustomIPTransport;FireDACMSSQLDriver;DataSnapIndy10ServerTransport;DataSnapConnectors;vcldsnap;DBXInterBaseDriver;GeminiAIPlugin;FireDACMongoDBDriver;IndySystem;FireDACTDataDriver;Skia.Package.VCL;vcldb;InlineErrors;SynEditDR;VirtualTreesR;vclFireDAC;bindcomp;FireDACCommon;DataSnapServerMidas;FireDACODBCDriver;emsserverresource;inetstn;TerminalEmulatorDsgn;IndyCore;RESTBackendComponents;bindcompdbx;rtl;FireDACMySQLDriver;FireDACADSDriver;RESTComponents;DBXSqliteDriver;vcl;IndyIPServer;dsnapxml;dsnapcon;DataSnapClient;DataSnapProviderClient;adortl;TerminalEmulatorPkg;DBXSybaseASEDriver;DBXDb2Driver;vclimg;DataSnapFireDAC;emsclientfiredac;FireDACPgDriver;FireDAC;FireDACDSDriver;inetdbxpress;xmlrtl;tethering;HexViewerDesigner;bindcompvcl;dsnap;CloudService;DBXSybaseASADriver;DBXOracleDriver;FireDACDb2Driver;DBXInformixDriver;EmulVT_Overbyte;BigNumbers;fmxobj;bindcompvclsmp;DataSnapNativeClient;DatasnapConnectorsFreePascal;soaprtl;soapserver;FireDACIBDriver;$(DCC_UsePackage) + Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace) + Debug + true + CompanyName=;FileDescription=$(MSBuildProjectName);FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProgramID=com.embarcadero.$(MSBuildProjectName);ProductName=$(MSBuildProjectName);ProductVersion=1.0.0.0;Comments= + 1033 + $(BDS)\bin\default_app.manifest + + + ExecutableExplorer;vclwinx;DataSnapServer;fmx;emshosting;vclie;DbxCommonDriver;bindengine;IndyIPCommon;VCLRESTComponents;DBXMSSQLDriver;FireDACCommonODBC;emsclient;FireDACCommonDriver;appanalytics;IndyProtocols;vclx;IndyIPClient;dbxcds;vcledge;bindcompvclwinx;JSONRPC.Registrar;emsedge;bindcompfmx;XMLSummaryExpert;DBXFirebirdDriver;BuildGroupsColumnFixer;inetdb;FireDACSqliteDriver;DbxClientDriver;FireDACASADriver;soapmidas;vclactnband;fmxFireDAC;dbexpress;FireDACInfxDriver;DBXMySQLDriver;VclSmp;inet;DataSnapCommon;AsyncProDR;vcltouch;fmxase;DBXOdbcDriver;dbrtl;FireDACDBXDriver;FireDACOracleDriver;fmxdae;EnableDebugVariables;FireDACMSAccDriver;CustomIPTransport;FireDACMSSQLDriver;DataSnapIndy10ServerTransport;DataSnapConnectors;vcldsnap;DBXInterBaseDriver;GeminiAIPlugin;FireDACMongoDBDriver;IndySystem;FireDACTDataDriver;Skia.Package.VCL;vcldb;SynEditDR;VirtualTreesR;vclFireDAC;bindcomp;FireDACCommon;DataSnapServerMidas;FireDACODBCDriver;emsserverresource;inetstn;IndyCore;RESTBackendComponents;bindcompdbx;rtl;FireDACMySQLDriver;FireDACADSDriver;RESTComponents;DBXSqliteDriver;vcl;IndyIPServer;dsnapxml;dsnapcon;DataSnapClient;DataSnapProviderClient;adortl;DBXSybaseASEDriver;DBXDb2Driver;vclimg;DataSnapFireDAC;emsclientfiredac;FireDACPgDriver;FireDAC;FireDACDSDriver;inetdbxpress;xmlrtl;tethering;bindcompvcl;dsnap;CloudService;DBXSybaseASADriver;DBXOracleDriver;FireDACDb2Driver;DBXInformixDriver;BigNumbers;fmxobj;bindcompvclsmp;DataSnapNativeClient;DatasnapConnectorsFreePascal;soaprtl;soapserver;FireDACIBDriver;$(DCC_UsePackage) + Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;$(DCC_Namespace) + Debug + true + CompanyName=;FileDescription=$(MSBuildProjectName);FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProgramID=com.embarcadero.$(MSBuildProjectName);ProductName=$(MSBuildProjectName);ProductVersion=1.0.0.0;Comments= + 1033 + $(BDS)\bin\default_app.manifest + + + DEBUG;$(DCC_Define) + true + false + true + true + true + true + true + + + false + PerMonitorV2 + + + PerMonitorV2 + + + false + RELEASE;$(DCC_Define) + 0 + 0 + + + PerMonitorV2 + + + PerMonitorV2 + + + + MainSource + + +
VisibilityForm
+ dfm + + + +
SelectionTestForm
+ dfm + + + Base + + + Cfg_1 + Base + + + Cfg_2 + Base + + + + Delphi.Personality.12 + Application + + + + VisibilityTest.dpr + + + + True + True + + + 12 + + + + + diff --git a/Virtual-TreeView.dspec b/Virtual-TreeView.dspec index 0a25c04ad..2927f96c8 100644 --- a/Virtual-TreeView.dspec +++ b/Virtual-TreeView.dspec @@ -1,7 +1,7 @@ { "metadata": { "id": "JAM.VirtualTreeView", - "version": "8.0.0-alpha1", + "version": "8.1.2", "description": "Virtual TreeView VCL Component", "authors": "Joachim Marder", "projectUrl": "https://github.com/JAM-Software/Virtual-TreeView", @@ -10,54 +10,6 @@ "tags": "VCL, TreeView" }, "targetPlatforms": [ - { - "compiler": "XE3", - "platforms": "Win32, Win64", - "template": "default", - "variables" : { - "libsuffix" : "170" - } - }, - { - "compiler": "XE4", - "platforms": "Win32, Win64", - "template": "default", - "variables" : { - "libsuffix" : "180" - } - }, - { - "compiler": "XE5", - "platforms": "Win32, Win64", - "template": "default", - "variables" : { - "libsuffix" : "190" - } - }, - { - "compiler": "XE6", - "platforms": "Win32, Win64", - "template": "default", - "variables" : { - "libsuffix" : "200" - } - }, - { - "compiler": "XE7", - "platforms": "Win32, Win64", - "template": "default", - "variables" : { - "libsuffix" : "210" - } - }, - { - "compiler": "XE8", - "platforms": "Win32, Win64", - "template": "default", - "variables" : { - "libsuffix" : "220" - } - }, { "compiler": "10.0", "platforms": "Win32, Win64", @@ -107,6 +59,14 @@ "libsuffix" : "280" } } + { + "compiler": "12.0", + "platforms": "Win32, Win64", + "template": "10.4+", + "variables" : { + "libsuffix" : "290" + } + } ], "templates": [ { diff --git a/VirtualTreesDevelopment.groupproj b/VirtualTreesDevelopment.groupproj index dffa2f549..59756a938 100644 --- a/VirtualTreesDevelopment.groupproj +++ b/VirtualTreesDevelopment.groupproj @@ -4,7 +4,7 @@ - + Packages\RAD Studio 10.4+\VirtualTreesR.dproj;Packages\RAD Studio 10.4+\VirtualTreesD.dproj @@ -13,18 +13,21 @@ Packages\RAD Studio 10.4+\VirtualTreesR.dproj - + Packages\RAD Studio 10.4+\VirtualTreesR.dproj;Packages\RAD Studio 10.4+\VirtualTreesD.dproj - + Packages\RAD Studio 10.4+\VirtualTreesR.dproj;Packages\RAD Studio 10.4+\VirtualTreesD.dproj - + Packages\RAD Studio 10.4+\VirtualTreesR.dproj;Packages\RAD Studio 10.4+\VirtualTreesD.dproj - + Packages\RAD Studio 10.4+\VirtualTreesR.dproj;Packages\RAD Studio 10.4+\VirtualTreesD.dproj + Packages\RAD Studio 10.4+\VirtualTreesR.dproj;Packages\RAD Studio 10.4+\VirtualTreesD.dproj + + @@ -35,13 +38,13 @@ - + - + - + @@ -62,59 +65,68 @@ - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + + + + + + + + + + - + - + - +