opensource/HeidiSQL
1
0
Fork 0
mirror of https://github.com/HeidiSQL/HeidiSQL.git synced 2025-08-26 11:17:57 +08:00
Code Issues Packages Projects Releases Wiki Activity

Update VirtualTreeview component to current master from https://github.com/Virtual-TreeView/Virtual-TreeView

Browse Source
This commit is contained in:
Ansgar Becker
2018-12-11 21:26:53 +01:00
parent ac63d5f613
commit 7ad1a5bee4
27 changed files with 45851 additions and 38857 deletions
Download Patch File Download Diff File Expand all files Collapse all files

BIN
components/virtualtreeview/Design/StrEditD4.dfm
View File

Binary file not shown.

70
components/virtualtreeview/Design/StrEditD4.pas
View File

@ -1,70 +0,0 @@
unit StrEditD4;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, ExtCtrls, ComCtrls, dsgnintf;
type
TStrEditDlg = class(TForm)
Bevel1: TBevel;
btnOk: TButton;
btnCancel: TButton;
Editor: TRichEdit;
StatusBar: TStatusBar;
procedure EditorChange(Sender: TObject);
procedure EditorKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
private
FModified: Boolean;
public
{ Public declarations }
end;
TStringListProperty = class(TClassProperty)
public
function GetAttributes: TPropertyAttributes; override;
procedure Edit; override;
end;
implementation
{$R *.DFM}
procedure TStrEditDlg.EditorChange(Sender: TObject);
begin
if Sender = Editor then
FModified := True;
StatusBar.SimpleText := Format ('%d lines.', [Editor.Lines.Count]);
end;
procedure TStrEditDlg.EditorKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
if Key = VK_ESCAPE then
ModalResult := mrCancel;
end;
{ TStringListProperty }
procedure TStringListProperty.Edit;
begin
with TStrEditDlg.Create(Application) do
try
Editor.Lines := TStrings(GetOrdValue);
EditorChange (nil);
FModified := False;
ActiveControl := Editor;
if ShowModal = mrOk then
SetOrdValue(LongInt(Editor.Lines));
finally
Free;
end;
end;
function TStringListProperty.GetAttributes: TPropertyAttributes;
begin
Result := inherited GetAttributes + [paDialog] - [paSubProperties];
end;
end.

0
components/virtualtreeview/Resources/VirtualTreesD.dcr → components/virtualtreeview/Design/VirtualTrees.dcr
View File

90
components/virtualtreeview/Design/VirtualTreesReg.pas
View File

@ -12,7 +12,7 @@ interface
uses uses
Windows, Classes, DesignIntf, DesignEditors, VCLEditors, PropertyCategories, Windows, Classes, DesignIntf, DesignEditors, VCLEditors, PropertyCategories,
ColnEdit, VirtualTrees, VTHeaderPopup; ColnEdit, VirtualTrees, VirtualTrees.HeaderPopup;
type type
TVirtualTreeEditor = class (TDefaultEditor) TVirtualTreeEditor = class (TDefaultEditor)
@ -65,15 +65,6 @@ type
procedure PropDrawValue(ACanvas: TCanvas; const ARect: TRect; ASelected: Boolean); procedure PropDrawValue(ACanvas: TCanvas; const ARect: TRect; ASelected: Boolean);
end; end;
TCheckImageKindProperty = class(TEnumProperty, ICustomPropertyDrawing, ICustomPropertyListDrawing)
public
procedure ListMeasureHeight(const Value: string; Canvas: TCanvas; var AHeight: Integer);
procedure ListMeasureWidth(const Value: string; ACanvas: TCanvas; var AWidth: Integer);
procedure ListDrawValue(const Value: string; ACanvas: TCanvas; const ARect: TRect; ASelected: Boolean);
procedure PropDrawName(ACanvas: TCanvas; const ARect: TRect; ASelected: Boolean);
procedure PropDrawValue(ACanvas: TCanvas; const ARect: TRect; ASelected: Boolean);
end;
resourcestring resourcestring
sVTHeaderCategoryName = 'Header'; sVTHeaderCategoryName = 'Header';
sVTPaintingCategoryName = 'Custom painting'; sVTPaintingCategoryName = 'Custom painting';
@ -296,84 +287,6 @@ begin
// Nothing to do here. // Nothing to do here.
end; end;
//----------------- TCheckImageKindProperty ----------------------------------------------------------------------------
const
cCheckImageKindComboItemBorder = 0;
cCheckImageKindComboItemSpacing = 2;
cCheckImageKindComboBitmapHeight = 16;
cCheckImageKindComboBitmapWidth = 16;
//----------------------------------------------------------------------------------------------------------------------
procedure TCheckImageKindProperty.PropDrawName(ACanvas: TCanvas; const ARect: TRect; ASelected: Boolean);
begin
DefaultPropertyDrawName(Self, ACanvas, ARect);
end;
//----------------------------------------------------------------------------------------------------------------------
procedure TCheckImageKindProperty.PropDrawValue(ACanvas: TCanvas; const ARect: TRect; ASelected: Boolean);
begin
if GetVisualValue <> '' then
ListDrawValue(GetVisualValue, ACanvas, ARect, ASelected)
else
DefaultPropertyDrawValue(Self, ACanvas, ARect);
end;
//----------------------------------------------------------------------------------------------------------------------
procedure TCheckImageKindProperty.ListDrawValue(const Value: string; ACanvas: TCanvas; const ARect: TRect; ASelected: Boolean);
var
RighPosition: Integer;
OldPenColor: TColor;
CheckKind: TCheckImageKind;
ImageList: TCustomImageList;
RemainingRect: TRect;
begin
RighPosition := ARect.Left + cCheckImageKindComboBitmapWidth;
with ACanvas do
try
OldPenColor := Pen.Color;
Pen.Color := Brush.Color;
Rectangle(ARect.Left, ARect.Top, RighPosition, ARect.Bottom);
CheckKind := TCheckImageKind(GetEnumValue(GetPropInfo^.PropType^, Value));
ImageList := TVirtualTreeCast.GetCheckImageListFor(CheckKind);
if ImageList <> nil then
begin
ImageList_DrawEx(ImageList.Handle, ckCheckCheckedNormal, ACanvas.Handle, ARect.Left + cCheckImageKindComboItemBorder,
ARect.Top + cCheckImageKindComboItemBorder, 0, 0, CLR_NONE, CLR_NONE, ILD_TRANSPARENT);
end;
Pen.Color := OldPenColor;
finally
RemainingRect := Rect(RighPosition, ARect.Top, ARect.Right, ARect.Bottom);
DefaultPropertyListDrawValue(Value, ACanvas, RemainingRect, ASelected);
end;
end;
//----------------------------------------------------------------------------------------------------------------------
procedure TCheckImageKindProperty.ListMeasureHeight(const Value: string; Canvas: TCanvas; var AHeight: Integer);
begin
AHeight := cCheckImageKindComboBitmapHeight;
end;
//----------------------------------------------------------------------------------------------------------------------
procedure TCheckImageKindProperty.ListMeasureWidth(const Value: string; ACanvas: TCanvas; var AWidth: Integer);
begin
AWidth := AWidth + cCheckImageKindComboBitmapWidth;
end;
//---------------------------------------------------------------------------------------------------------------------- //----------------------------------------------------------------------------------------------------------------------
procedure Register; procedure Register;
@ -383,7 +296,6 @@ begin
RegisterComponentEditor(TVirtualStringTree, TVirtualTreeEditor); RegisterComponentEditor(TVirtualStringTree, TVirtualTreeEditor);
RegisterComponentEditor(TVirtualDrawTree, TVirtualTreeEditor); RegisterComponentEditor(TVirtualDrawTree, TVirtualTreeEditor);
RegisterPropertyEditor(TypeInfo(TClipboardFormats), nil, '', TClipboardFormatsProperty); RegisterPropertyEditor(TypeInfo(TClipboardFormats), nil, '', TClipboardFormatsProperty);
RegisterPropertyEditor(TypeInfo(TCheckImageKind), nil, '', TCheckImageKindProperty);
// Categories: // Categories:
RegisterPropertiesInCategory(sActionCategoryName, TBaseVirtualTree, ['ChangeDelay', 'EditDelay']); RegisterPropertiesInCategory(sActionCategoryName, TBaseVirtualTree, ['ChangeDelay', 'EditDelay']);

BIN
components/virtualtreeview/Resources/VirtualTrees.res
View File

Binary file not shown.

BIN
components/virtualtreeview/Resources/VirtualTreeview-Icon.ico Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 57 KiB

BIN
components/virtualtreeview/Resources/VirtualTreeview-Icon.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 14 KiB

1556
components/virtualtreeview/Source/VTAccessibility.pas → components/virtualtreeview/Source/VirtualTrees.Accessibility.pas
View File

File diff suppressed because it is too large Load Diff

356
components/virtualtreeview/Source/VTAccessibilityFactory.pas → components/virtualtreeview/Source/VirtualTrees.AccessibilityFactory.pas
View File

@ -1,178 +1,178 @@
unit VTAccessibilityFactory; unit VirtualTrees.AccessibilityFactory;
// The contents of this file are subject to the Mozilla Public License // The contents of this file are subject to the Mozilla Public License
// Version 1.1 (the "License"); you may not use this file except in compliance // Version 1.1 (the "License"); you may not use this file except in compliance
// with the License. You may obtain a copy of the License at http://www.mozilla.org/MPL/ // with the License. You may obtain a copy of the License at http://www.mozilla.org/MPL/
// //
// Alternatively, you may redistribute this library, use and/or modify it under the terms of the // Alternatively, you may redistribute this library, use and/or modify it under the terms of the
// GNU Lesser General Public License as published by the Free Software Foundation; // GNU Lesser General Public License as published by the Free Software Foundation;
// either version 2.1 of the License, or (at your option) any later version. // either version 2.1 of the License, or (at your option) any later version.
// You may obtain a copy of the LGPL at http://www.gnu.org/copyleft/. // You may obtain a copy of the LGPL at http://www.gnu.org/copyleft/.
// //
// Software distributed under the License is distributed on an "AS IS" basis, // Software distributed under the License is distributed on an "AS IS" basis,
// WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for the // WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for the
// specific language governing rights and limitations under the License. // specific language governing rights and limitations under the License.
// //
// The original code is VirtualTrees.pas, released September 30, 2000. // The original code is VirtualTrees.pas, released September 30, 2000.
// //
// The initial developer of the original code is digital publishing AG (Munich, Germany, www.digitalpublishing.de), // The initial developer of the original code is digital publishing AG (Munich, Germany, www.digitalpublishing.de),
// written by Mike Lischke (public@soft-gems.net, www.soft-gems.net). // written by Mike Lischke (public@soft-gems.net, www.soft-gems.net).
// //
// Portions created by digital publishing AG are Copyright // Portions created by digital publishing AG are Copyright
// (C) 1999-2001 digital publishing AG. All Rights Reserved. // (C) 1999-2001 digital publishing AG. All Rights Reserved.
//---------------------------------------------------------------------------------------------------------------------- //----------------------------------------------------------------------------------------------------------------------
// class to create IAccessibles for the tree passed into it. // class to create IAccessibles for the tree passed into it.
// If not already assigned, creates IAccessibles for the tree itself // If not already assigned, creates IAccessibles for the tree itself
// and the focused item // and the focused item
// the tree accessible is returned when the tree receives an WM_GETOBJECT message // the tree accessible is returned when the tree receives an WM_GETOBJECT message
// the AccessibleItem is returned when the Accessible is being asked for the first child // the AccessibleItem is returned when the Accessible is being asked for the first child
// To create your own IAccessibles, use the VTStandardAccessible unit as a reference, // To create your own IAccessibles, use the VTStandardAccessible unit as a reference,
// and assign your Accessibles to the variables in the unit's initialization. // and assign your Accessibles to the variables in the unit's initialization.
// You only need to add the unit to your project, and voilá, you have an accessible string tree! // You only need to add the unit to your project, and voilá, you have an accessible string tree!
// //
// Written by Marco Zehe. (c) 2007 // Written by Marco Zehe. (c) 2007
interface interface
uses uses
System.Classes, Winapi.oleacc, VirtualTrees; System.Classes, Winapi.oleacc, VirtualTrees;
type type
IVTAccessibleProvider = interface IVTAccessibleProvider = interface
function CreateIAccessible(ATree: TBaseVirtualTree): IAccessible; function CreateIAccessible(ATree: TBaseVirtualTree): IAccessible;
end; end;
TVTAccessibilityFactory = class(TObject) TVTAccessibilityFactory = class(TObject)
strict private class var strict private class var
FAccessibilityAvailable: Boolean; FAccessibilityAvailable: Boolean;
FVTAccessibleFactory: TVTAccessibilityFactory; FVTAccessibleFactory: TVTAccessibilityFactory;
strict private strict private
FAccessibleProviders: TInterfaceList; FAccessibleProviders: TInterfaceList;
private private
class procedure FreeFactory; class procedure FreeFactory;
public public
constructor Create; constructor Create;
destructor Destroy; override; destructor Destroy; override;
function CreateIAccessible(ATree: TBaseVirtualTree): IAccessible; function CreateIAccessible(ATree: TBaseVirtualTree): IAccessible;
class function GetAccessibilityFactory: TVTAccessibilityFactory; static; class function GetAccessibilityFactory: TVTAccessibilityFactory; static;
procedure RegisterAccessibleProvider(const AProvider: IVTAccessibleProvider); procedure RegisterAccessibleProvider(const AProvider: IVTAccessibleProvider);
procedure UnRegisterAccessibleProvider(const AProvider: IVTAccessibleProvider); procedure UnRegisterAccessibleProvider(const AProvider: IVTAccessibleProvider);
end; end;
implementation implementation
{ TVTAccessibilityFactory } { TVTAccessibilityFactory }
constructor TVTAccessibilityFactory.Create; constructor TVTAccessibilityFactory.Create;
begin begin
inherited Create; inherited Create;
FAccessibleProviders := TInterfaceList.Create; FAccessibleProviders := TInterfaceList.Create;
FAccessibleProviders.Clear; FAccessibleProviders.Clear;
end; end;
function TVTAccessibilityFactory.CreateIAccessible( function TVTAccessibilityFactory.CreateIAccessible(
ATree: TBaseVirtualTree): IAccessible; ATree: TBaseVirtualTree): IAccessible;
var var
I: Integer; I: Integer;
TmpIAccessible: IAccessible; TmpIAccessible: IAccessible;
// returns an IAccessible. // returns an IAccessible.
// 1. If the Accessible property of the passed-in tree is nil, // 1. If the Accessible property of the passed-in tree is nil,
// the first registered element will be returned. // the first registered element will be returned.
// Usually, this is the IAccessible that provides information about the tree itself. // Usually, this is the IAccessible that provides information about the tree itself.
// If it is not nil, we'll check whether the AccessibleItem is nil. // If it is not nil, we'll check whether the AccessibleItem is nil.
// If it is, we'll look in the registered IAccessibles for the appropriate one. // If it is, we'll look in the registered IAccessibles for the appropriate one.
// Each IAccessibleProvider will check the tree for properties to determine whether it is responsible. // Each IAccessibleProvider will check the tree for properties to determine whether it is responsible.
// We'll work top to bottom, from the most complicated to the most simple. // We'll work top to bottom, from the most complicated to the most simple.
// The index for these should all be greater than 0, e g the IAccessible for the tree itself should always be registered first, then any IAccessible items. // The index for these should all be greater than 0, e g the IAccessible for the tree itself should always be registered first, then any IAccessible items.
begin begin
Result := nil; Result := nil;
if ATree <> nil then if ATree <> nil then
begin begin
if ATree.Accessible = nil then if ATree.Accessible = nil then
begin begin
if FAccessibleProviders.Count > 0 then if FAccessibleProviders.Count > 0 then
begin begin
Result := IVTAccessibleProvider(FAccessibleProviders.Items[0]).CreateIAccessible(ATree); Result := IVTAccessibleProvider(FAccessibleProviders.Items[0]).CreateIAccessible(ATree);
Exit; Exit;
end; end;
end; end;
if ATree.AccessibleItem = nil then if ATree.AccessibleItem = nil then
begin begin
if FAccessibleProviders.Count > 0 then if FAccessibleProviders.Count > 0 then
begin begin
for I := FAccessibleProviders.Count - 1 downto 1 do for I := FAccessibleProviders.Count - 1 downto 1 do
begin begin
TmpIAccessible := IVTAccessibleProvider(FAccessibleProviders.Items[I]).CreateIAccessible(ATree); TmpIAccessible := IVTAccessibleProvider(FAccessibleProviders.Items[I]).CreateIAccessible(ATree);
if TmpIAccessible <> nil then if TmpIAccessible <> nil then
begin begin
Result := TmpIAccessible; Result := TmpIAccessible;
Break; Break;
end; end;
end; end;
if TmpIAccessible = nil then if TmpIAccessible = nil then
begin begin
Result := IVTAccessibleProvider(FAccessibleProviders.Items[0]).CreateIAccessible(ATree); Result := IVTAccessibleProvider(FAccessibleProviders.Items[0]).CreateIAccessible(ATree);
end; end;
end; end;
end end
else else
Result := ATree.AccessibleItem; Result := ATree.AccessibleItem;
end; end;
end; end;
destructor TVTAccessibilityFactory.Destroy; destructor TVTAccessibilityFactory.Destroy;
begin begin
FAccessibleProviders.Free; FAccessibleProviders.Free;
FAccessibleProviders := nil; FAccessibleProviders := nil;
inherited Destroy; inherited Destroy;
end; end;
class procedure TVTAccessibilityFactory.FreeFactory; class procedure TVTAccessibilityFactory.FreeFactory;
begin begin
FVTAccessibleFactory.Free; FVTAccessibleFactory.Free;
end; end;
procedure TVTAccessibilityFactory.RegisterAccessibleProvider(const AProvider: IVTAccessibleProvider); procedure TVTAccessibilityFactory.RegisterAccessibleProvider(const AProvider: IVTAccessibleProvider);
// Ads a provider if it is not already registered // Ads a provider if it is not already registered
begin begin
if FAccessibleProviders.IndexOf(AProvider) < 0 then if FAccessibleProviders.IndexOf(AProvider) < 0 then
FAccessibleProviders.Add(AProvider) FAccessibleProviders.Add(AProvider)
end; end;
procedure TVTAccessibilityFactory.UnRegisterAccessibleProvider(const AProvider: IVTAccessibleProvider); procedure TVTAccessibilityFactory.UnRegisterAccessibleProvider(const AProvider: IVTAccessibleProvider);
// Unregisters/removes an IAccessible provider if it is present // Unregisters/removes an IAccessible provider if it is present
begin begin
if FAccessibleProviders.IndexOf(AProvider) >= 0 then if FAccessibleProviders.IndexOf(AProvider) >= 0 then
FAccessibleProviders.Remove(AProvider); FAccessibleProviders.Remove(AProvider);
end; end;
class function TVTAccessibilityFactory.GetAccessibilityFactory: TVTAccessibilityFactory; class function TVTAccessibilityFactory.GetAccessibilityFactory: TVTAccessibilityFactory;
// Accessibility helper function to create a singleton class that will create or return // Accessibility helper function to create a singleton class that will create or return
// the IAccessible interface for the tree and the focused node. // the IAccessible interface for the tree and the focused node.
begin begin
// first, check if we've loaded the library already // first, check if we've loaded the library already
if not FAccessibilityAvailable then if not FAccessibilityAvailable then
FAccessibilityAvailable := True; FAccessibilityAvailable := True;
if FAccessibilityAvailable then if FAccessibilityAvailable then
begin begin
// Check to see if the class has already been created. // Check to see if the class has already been created.
if FVTAccessibleFactory = nil then if FVTAccessibleFactory = nil then
FVTAccessibleFactory := TVTAccessibilityFactory.Create; FVTAccessibleFactory := TVTAccessibilityFactory.Create;
Result := FVTAccessibleFactory; Result := FVTAccessibleFactory;
end end
else else
Result := nil; Result := nil;
end; end;
initialization initialization
finalization finalization
TVTAccessibilityFactory.FreeFactory; TVTAccessibilityFactory.FreeFactory;
end. end.

175
components/virtualtreeview/Source/VirtualTrees.Actions.pas
View File

@ -5,6 +5,7 @@ interface
uses uses
System.Classes, System.Classes,
System.Actions, System.Actions,
Vcl.Controls,
Vcl.ActnList, Vcl.ActnList,
VirtualTrees; VirtualTrees;
@ -20,7 +21,7 @@ type
fFilter: TVirtualNodeStates; // Apply only of nodes which match these states fFilter: TVirtualNodeStates; // Apply only of nodes which match these states
procedure SetControl(Value: TBaseVirtualTree); // Setter for the property "Control" procedure SetControl(Value: TBaseVirtualTree); // Setter for the property "Control"
procedure Notification(AComponent: TComponent; Operation: TOperation); override; procedure Notification(AComponent: TComponent; Operation: TOperation); override;
procedure DoAfterExecute; // Fires the event "OnAfterExecute" procedure DoAfterExecute; virtual;// Fires the event "OnAfterExecute"
property SelectedOnly: Boolean read GetSelectedOnly write SetSelectedOnly default False; property SelectedOnly: Boolean read GetSelectedOnly write SetSelectedOnly default False;
public public
function HandlesTarget(Target: TObject): Boolean; override; function HandlesTarget(Target: TObject): Boolean; override;
@ -28,6 +29,7 @@ type
procedure ExecuteTarget(Target: TObject); override; procedure ExecuteTarget(Target: TObject); override;
published published
constructor Create(AOwner: TComponent); override; constructor Create(AOwner: TComponent); override;
function Update: Boolean; override;
property Control: TBaseVirtualTree read fTree write SetControl; property Control: TBaseVirtualTree read fTree write SetControl;
property OnAfterExecute: TNotifyEvent read fOnAfterExecute write fOnAfterExecute; // Executed after the action was performed property OnAfterExecute: TNotifyEvent read fOnAfterExecute write fOnAfterExecute; // Executed after the action was performed
property Caption; property Caption;
@ -45,9 +47,11 @@ type
TVirtualTreePerItemAction = class(TVirtualTreeAction) TVirtualTreePerItemAction = class(TVirtualTreeAction)
strict private strict private
fOnBeforeExecute: TNotifyEvent; fOnBeforeExecute: TNotifyEvent;
fOldCursor: TCursor;
strict protected strict protected
fToExecute: TVTGetNodeProc; // method which is executed per item to perform this action fToExecute: TVTGetNodeProc; // method which is executed per item to perform this action
procedure DoBeforeExecute; procedure DoBeforeExecute();
procedure DoAfterExecute(); override;// Fires the event "OnAfterExecute"
public public
constructor Create(AOwner: TComponent); override; constructor Create(AOwner: TComponent); override;
procedure ExecuteTarget(Target: TObject); override; procedure ExecuteTarget(Target: TObject); override;
@ -63,6 +67,7 @@ type
constructor Create(AOwner: TComponent); override; constructor Create(AOwner: TComponent); override;
published published
property SelectedOnly; property SelectedOnly;
property OnUpdate;
end; end;
// A standard action which unchecks nodes in a virtual treeview // A standard action which unchecks nodes in a virtual treeview
@ -79,10 +84,10 @@ type
// Base class for actions that are applied to selected nodes only // Base class for actions that are applied to selected nodes only
TVirtualTreeForSelectedAction = class(TVirtualTreeAction) TVirtualTreeForSelectedAction = class(TVirtualTreeAction)
public public
constructor Create(AOwner: TComponent); override; constructor Create(AOwner: TComponent); override;
end; end;
TVirtualTreeCopy = class(TVirtualTreeForSelectedAction) TVirtualTreeCopy = class(TVirtualTreeForSelectedAction)
public public
procedure ExecuteTarget(Target: TObject); override; procedure ExecuteTarget(Target: TObject); override;
@ -109,7 +114,8 @@ procedure Register;
implementation implementation
uses uses
Controls, Forms; WinApi.Windows,
Vcl.Forms;
procedure Register; procedure Register;
begin begin
@ -128,18 +134,18 @@ begin
end; end;
function TVirtualTreeAction.GetSelectedOnly: Boolean; function TVirtualTreeAction.GetSelectedOnly: Boolean;
begin begin
exit(TVirtualNodeState.vsSelected in fFilter); exit(TVirtualNodeState.vsSelected in fFilter);
end; end;
procedure TVirtualTreeAction.SetSelectedOnly(const Value: Boolean); procedure TVirtualTreeAction.SetSelectedOnly(const Value: Boolean);
begin begin
if Value then if Value then
Include(fFilter, TVirtualNodeState.vsSelected) Include(fFilter, TVirtualNodeState.vsSelected)
else else
Exclude(fFilter, TVirtualNodeState.vsSelected); Exclude(fFilter, TVirtualNodeState.vsSelected);
end; end;
procedure TVirtualTreeAction.DoAfterExecute; procedure TVirtualTreeAction.DoAfterExecute;
begin begin
if Assigned(fOnAfterExecute) then if Assigned(fOnAfterExecute) then
@ -151,6 +157,15 @@ begin
Result := (Target is TBaseVirtualTree); Result := (Target is TBaseVirtualTree);
end; end;
function TVirtualTreeAction.Update(): Boolean;
begin
Result := inherited;
// If an OnUpdate event handler is assigned, TBasicAction.Update() will return True and so TBasicAction.UpdateTarget() will not be called.
// We would then end up with Control == nil. So trigger update of action manually.
if Result and Assigned(OnUpdate) then
SendAppMessage(CM_ACTIONUPDATE, 0, LPARAM(Self))
end;
procedure TVirtualTreeAction.UpdateTarget(Target: TObject); procedure TVirtualTreeAction.UpdateTarget(Target: TObject);
begin begin
if fTreeAutoDetect and (Target is TBaseVirtualTree) then if fTreeAutoDetect and (Target is TBaseVirtualTree) then
@ -160,7 +175,7 @@ end;
procedure TVirtualTreeAction.ExecuteTarget(Target: TObject); procedure TVirtualTreeAction.ExecuteTarget(Target: TObject);
begin begin
DoAfterExecute(); DoAfterExecute();
end; end;
procedure TVirtualTreeAction.Notification(AComponent: TComponent; Operation: TOperation); procedure TVirtualTreeAction.Notification(AComponent: TComponent; Operation: TOperation);
@ -186,35 +201,40 @@ end;
{ TVirtualTreePerItemAction } { TVirtualTreePerItemAction }
constructor TVirtualTreePerItemAction.Create(AOwner: TComponent); constructor TVirtualTreePerItemAction.Create(AOwner: TComponent);
begin begin
inherited; inherited;
fToExecute := nil; fToExecute := nil;
fOnBeforeExecute := nil; fOnBeforeExecute := nil;
end; fOldCursor := crNone;
end;
procedure TVirtualTreePerItemAction.DoAfterExecute;
begin
inherited;
if fOldCursor <> crNone then
Screen.Cursor := fOldCursor;
end;
procedure TVirtualTreePerItemAction.DoBeforeExecute; procedure TVirtualTreePerItemAction.DoBeforeExecute;
begin begin
if Screen.Cursor <> crHourGlass then begin
fOldCursor := Screen.Cursor;
Screen.Cursor := crHourGlass;
end;//if
if Assigned(fOnBeforeExecute) then if Assigned(fOnBeforeExecute) then
fOnBeforeExecute(Self); fOnBeforeExecute(Self);
end; end;
procedure TVirtualTreePerItemAction.ExecuteTarget(Target: TObject); procedure TVirtualTreePerItemAction.ExecuteTarget(Target: TObject);
var
lOldCursor: TCursor;
begin begin
if Assigned(Self.Control) then
Target := Self.Control;
DoBeforeExecute(); DoBeforeExecute();
lOldCursor := Screen.Cursor;
Screen.Cursor := crHourGlass;
Control.BeginUpdate(); Control.BeginUpdate();
try try
Control.IterateSubtree(nil, Self.fToExecute, nil, fFilter); Control.IterateSubtree(nil, Self.fToExecute, nil, fFilter, true);
finally finally
Control.EndUpdate; Control.EndUpdate();
Screen.Cursor := lOldCursor; DoAfterExecute();
end; end;
Inherited ExecuteTarget(Target);
end; end;
{ TVirtualTreeCheckAll } { TVirtualTreeCheckAll }
@ -227,7 +247,8 @@ begin
fDesiredCheckState := csCheckedNormal; fDesiredCheckState := csCheckedNormal;
fToExecute := procedure(Sender: TBaseVirtualTree; Node: PVirtualNode; Data: Pointer; var Abort: Boolean) fToExecute := procedure(Sender: TBaseVirtualTree; Node: PVirtualNode; Data: Pointer; var Abort: Boolean)
begin begin
Control.CheckState[Node] := fDesiredCheckState; if not Control.CheckState[Node].IsDisabled then
Control.CheckState[Node] := fDesiredCheckState;
end; end;
end; end;
@ -244,62 +265,62 @@ end;
{ TVirtualStringSelectAll } { TVirtualStringSelectAll }
procedure TVirtualTreeSelectAll.UpdateTarget(Target: TObject); procedure TVirtualTreeSelectAll.UpdateTarget(Target: TObject);
begin begin
Inherited; Inherited;
//Enabled := Enabled and (toMultiSelect in Control.TreeOptions.SelectionOptions) // TreeOptions is protected :-( //Enabled := Enabled and (toMultiSelect in Control.TreeOptions.SelectionOptions) // TreeOptions is protected :-(
end; end;
procedure TVirtualTreeSelectAll.ExecuteTarget(Target: TObject); procedure TVirtualTreeSelectAll.ExecuteTarget(Target: TObject);
begin begin
Control.SelectAll(False); Control.SelectAll(False);
inherited; inherited;
end; end;
{ TVirtualTreeForSelectedAction } { TVirtualTreeForSelectedAction }
constructor TVirtualTreeForSelectedAction.Create(AOwner: TComponent); constructor TVirtualTreeForSelectedAction.Create(AOwner: TComponent);
begin begin
inherited; inherited;
SelectedOnly := True; SelectedOnly := True;
end; end;
{ TVirtualTreeCopy } { TVirtualTreeCopy }
procedure TVirtualTreeCopy.ExecuteTarget(Target: TObject); procedure TVirtualTreeCopy.ExecuteTarget(Target: TObject);
begin begin
Control.CopyToClipboard(); Control.CopyToClipboard();
Inherited; Inherited;
end; end;
{ TVirtualTreeCut } { TVirtualTreeCut }
procedure TVirtualTreeCut.ExecuteTarget(Target: TObject); procedure TVirtualTreeCut.ExecuteTarget(Target: TObject);
begin begin
Control.CutToClipboard(); Control.CutToClipboard();
Inherited; Inherited;
end; end;
{ TVirtualTreePaste } { TVirtualTreePaste }
procedure TVirtualTreePaste.ExecuteTarget(Target: TObject); procedure TVirtualTreePaste.ExecuteTarget(Target: TObject);
begin begin
Control.PasteFromClipboard(); Control.PasteFromClipboard();
Inherited; Inherited;
end; end;
{ TVirtualTreeDelete } { TVirtualTreeDelete }
procedure TVirtualTreeDelete.ExecuteTarget(Target: TObject); procedure TVirtualTreeDelete.ExecuteTarget(Target: TObject);
begin begin
Control.DeleteSelectedNodes(); Control.DeleteSelectedNodes();
Inherited; Inherited;
end; end;

47
components/virtualtreeview/Source/VirtualTrees.Classes.pas
View File

@ -63,18 +63,6 @@ type
property AsString: string read GetAsString; property AsString: string read GetAsString;
end; end;
TCriticalSection = class(TObject)
protected
FSection: TRTLCriticalSection;
public
constructor Create;
destructor Destroy; override;
procedure Enter;
procedure Leave;
end;
implementation implementation
@ -221,40 +209,5 @@ begin
Inc(FPosition); Inc(FPosition);
end; end;
//----------------- TCriticalSection -----------------------------------------------------------------------------------
constructor TCriticalSection.Create;
begin
inherited Create;
InitializeCriticalSection(FSection);
end;
//----------------------------------------------------------------------------------------------------------------------
destructor TCriticalSection.Destroy;
begin
DeleteCriticalSection(FSection);
inherited Destroy;
end;
//----------------------------------------------------------------------------------------------------------------------
procedure TCriticalSection.Enter;
begin
EnterCriticalSection(FSection);
end;
//----------------------------------------------------------------------------------------------------------------------
procedure TCriticalSection.Leave;
begin
LeaveCriticalSection(FSection);
end;
end. end.

799
components/virtualtreeview/Source/VirtualTrees.ClipBoard.pas
View File

@ -1,392 +1,407 @@
unit VirtualTrees.ClipBoard; unit VirtualTrees.ClipBoard;
// The contents of this file are subject to the Mozilla Public License // The contents of this file are subject to the Mozilla Public License
// Version 1.1 (the "License"); you may not use this file except in compliance // Version 1.1 (the "License"); you may not use this file except in compliance
// with the License. You may obtain a copy of the License at http://www.mozilla.org/MPL/ // with the License. You may obtain a copy of the License at http://www.mozilla.org/MPL/
// //
// Alternatively, you may redistribute this library, use and/or modify it under the terms of the // Alternatively, you may redistribute this library, use and/or modify it under the terms of the
// GNU Lesser General Public License as published by the Free Software Foundation; // GNU Lesser General Public License as published by the Free Software Foundation;
// either version 2.1 of the License, or (at your option) any later version. // either version 2.1 of the License, or (at your option) any later version.
// You may obtain a copy of the LGPL at http://www.gnu.org/copyleft/. // You may obtain a copy of the LGPL at http://www.gnu.org/copyleft/.
// //
// Software distributed under the License is distributed on an "AS IS" basis, // Software distributed under the License is distributed on an "AS IS" basis,
// WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for the // WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for the
// specific language governing rights and limitations under the License. // specific language governing rights and limitations under the License.
// //
// The original code is VirtualTrees.pas, released September 30, 2000. // The original code is VirtualTrees.pas, released September 30, 2000.
// //
// The initial developer of the original code is digital publishing AG (Munich, Germany, www.digitalpublishing.de), // The initial developer of the original code is digital publishing AG (Munich, Germany, www.digitalpublishing.de),
// written by Mike Lischke (public@soft-gems.net, www.soft-gems.net). // written by Mike Lischke (public@soft-gems.net, www.soft-gems.net).
// //
// Portions created by digital publishing AG are Copyright // Portions created by digital publishing AG are Copyright
// (C) 1999-2001 digital publishing AG. All Rights Reserved. // (C) 1999-2001 digital publishing AG. All Rights Reserved.
//---------------------------------------------------------------------------------------------------------------------- //----------------------------------------------------------------------------------------------------------------------
interface interface
uses {$WARN UNSAFE_TYPE OFF}
Winapi.Windows, {$WARN UNSAFE_CAST OFF}
Winapi.ActiveX,
System.Classes, uses
VirtualTrees; Winapi.Windows,
Winapi.ActiveX,
type System.Classes,
TClipboardFormatEntry = record VirtualTrees;
ID: Word;
Description: string; type
end; TClipboardFormatEntry = record
ID: Word;
var Description: string;
ClipboardDescriptions: array [1..CF_MAX - 1] of TClipboardFormatEntry = ( end;
(ID: CF_TEXT; Description: 'Plain text'), // Do not localize
(ID: CF_BITMAP; Description: 'Windows bitmap'), // Do not localize var
(ID: CF_METAFILEPICT; Description: 'Windows metafile'), // Do not localize ClipboardDescriptions: array [1..CF_MAX - 1] of TClipboardFormatEntry = (
(ID: CF_SYLK; Description: 'Symbolic link'), // Do not localize (ID: CF_TEXT; Description: 'Plain text'), // Do not localize
(ID: CF_DIF; Description: 'Data interchange format'), // Do not localize (ID: CF_BITMAP; Description: 'Windows bitmap'), // Do not localize
(ID: CF_TIFF; Description: 'Tiff image'), // Do not localize (ID: CF_METAFILEPICT; Description: 'Windows metafile'), // Do not localize
(ID: CF_OEMTEXT; Description: 'OEM text'), // Do not localize (ID: CF_SYLK; Description: 'Symbolic link'), // Do not localize
(ID: CF_DIB; Description: 'DIB image'), // Do not localize (ID: CF_DIF; Description: 'Data interchange format'), // Do not localize
(ID: CF_PALETTE; Description: 'Palette data'), // Do not localize (ID: CF_TIFF; Description: 'Tiff image'), // Do not localize
(ID: CF_PENDATA; Description: 'Pen data'), // Do not localize (ID: CF_OEMTEXT; Description: 'OEM text'), // Do not localize
(ID: CF_RIFF; Description: 'Riff audio data'), // Do not localize (ID: CF_DIB; Description: 'DIB image'), // Do not localize
(ID: CF_WAVE; Description: 'Wav audio data'), // Do not localize (ID: CF_PALETTE; Description: 'Palette data'), // Do not localize
(ID: CF_UNICODETEXT; Description: 'Unicode text'), // Do not localize (ID: CF_PENDATA; Description: 'Pen data'), // Do not localize
(ID: CF_ENHMETAFILE; Description: 'Enhanced metafile image'), // Do not localize (ID: CF_RIFF; Description: 'Riff audio data'), // Do not localize
(ID: CF_HDROP; Description: 'File name(s)'), // Do not localize (ID: CF_WAVE; Description: 'Wav audio data'), // Do not localize
(ID: CF_LOCALE; Description: 'Locale descriptor'), // Do not localize (ID: CF_UNICODETEXT; Description: 'Unicode text'), // Do not localize
(ID: CF_DIBV5; Description: 'DIB image V5') // Do not localize (ID: CF_ENHMETAFILE; Description: 'Enhanced metafile image'), // Do not localize
); (ID: CF_HDROP; Description: 'File name(s)'), // Do not localize
(ID: CF_LOCALE; Description: 'Locale descriptor'), // Do not localize
(ID: CF_DIBV5; Description: 'DIB image V5') // Do not localize
// OLE Clipboard and drag'n drop helper );
procedure EnumerateVTClipboardFormats(TreeClass: TVirtualTreeClass; const List: TStrings); overload;
procedure EnumerateVTClipboardFormats(TreeClass: TVirtualTreeClass; var Formats: TFormatEtcArray); overload;
function GetVTClipboardFormatDescription(AFormat: Word): string; // OLE Clipboard and drag'n drop helper
procedure RegisterVTClipboardFormat(AFormat: Word; TreeClass: TVirtualTreeClass; Priority: Cardinal); overload; procedure EnumerateVTClipboardFormats(TreeClass: TVirtualTreeClass; const List: TStrings); overload;
function RegisterVTClipboardFormat(const Description: string; TreeClass: TVirtualTreeClass; Priority: Cardinal; procedure EnumerateVTClipboardFormats(TreeClass: TVirtualTreeClass; var Formats: TFormatEtcArray); overload;
tymed: Integer = TYMED_HGLOBAL; ptd: PDVTargetDevice = nil; function GetVTClipboardFormatDescription(AFormat: Word): string;
dwAspect: Integer = DVASPECT_CONTENT; lindex: Integer = -1): Word; overload; procedure RegisterVTClipboardFormat(AFormat: Word; TreeClass: TVirtualTreeClass; Priority: Cardinal); overload;
function RegisterVTClipboardFormat(const Description: string; TreeClass: TVirtualTreeClass; Priority: Cardinal;
//----------------- TClipboardFormats ---------------------------------------------------------------------------------- tymed: Integer = TYMED_HGLOBAL; ptd: PDVTargetDevice = nil;
dwAspect: Integer = DVASPECT_CONTENT; lindex: Integer = -1): Word; overload;
type
PClipboardFormatListEntry = ^TClipboardFormatListEntry; //----------------- TClipboardFormats ----------------------------------------------------------------------------------
TClipboardFormatListEntry = record
Description: string; // The string used to register the format with Winapi.Windows. type
TreeClass: TVirtualTreeClass; // The tree class which supports rendering this format. TClipboardFormatListEntry = class
Priority: Cardinal; // Number which determines the order of formats used in IDataObject. public
FormatEtc: TFormatEtc; // The definition of the format in the IDataObject. Description: string; // The string used to register the format with Winapi.Windows.
end; TreeClass: TVirtualTreeClass; // The tree class which supports rendering this format.
Priority: Cardinal; // Number which determines the order of formats used in IDataObject.
TClipboardFormatList = class FormatEtc: TFormatEtc; // The definition of the format in the IDataObject.
private end;
class var
FList : TList; TClipboardFormatList = class
protected strict private
class procedure Sort; class function GetList(): TList; static;
public class property List: TList read GetList;
class procedure Add(const FormatString: string; AClass: TVirtualTreeClass; Priority: Cardinal; AFormatEtc: TFormatEtc); protected
class procedure Clear; class procedure Sort;
class procedure EnumerateFormats(TreeClass: TVirtualTreeClass; var Formats: TFormatEtcArray; const AllowedFormats: TClipboardFormats = nil); overload; public
class procedure EnumerateFormats(TreeClass: TVirtualTreeClass; const Formats: TStrings); overload; class procedure Add(const FormatString: string; AClass: TVirtualTreeClass; Priority: Cardinal; AFormatEtc: TFormatEtc);
class function FindFormat(const FormatString: string): PClipboardFormatListEntry; overload; class procedure Clear;
class function FindFormat(const FormatString: string; var Fmt: Word): TVirtualTreeClass; overload; class procedure EnumerateFormats(TreeClass: TVirtualTreeClass; var Formats: TFormatEtcArray; const AllowedFormats: TClipboardFormats = nil); overload;
class function FindFormat(Fmt: Word; var Description: string): TVirtualTreeClass; overload; class procedure EnumerateFormats(TreeClass: TVirtualTreeClass; const Formats: TStrings); overload;
end; class function FindFormat(const FormatString: string): TClipboardFormatListEntry; overload;
class function FindFormat(const FormatString: string; var Fmt: Word): TVirtualTreeClass; overload;
class function FindFormat(Fmt: Word; var Description: string): TVirtualTreeClass; overload;
implementation end;
uses
System.SysUtils; implementation
uses
procedure EnumerateVTClipboardFormats(TreeClass: TVirtualTreeClass; const List: TStrings); System.SysUtils;
begin var
TClipboardFormatList.EnumerateFormats(TreeClass, List); _List: TList = nil; //Note - not using class constructors as they are not supported on C++ Builder. See also issue #
end;
procedure EnumerateVTClipboardFormats(TreeClass: TVirtualTreeClass; const List: TStrings);
//----------------------------------------------------------------------------------------------------------------------
begin
procedure EnumerateVTClipboardFormats(TreeClass: TVirtualTreeClass; var Formats: TFormatEtcArray); TClipboardFormatList.EnumerateFormats(TreeClass, List);
end;
begin
TClipboardFormatList.EnumerateFormats(TreeClass, Formats); //----------------------------------------------------------------------------------------------------------------------
end;
procedure EnumerateVTClipboardFormats(TreeClass: TVirtualTreeClass; var Formats: TFormatEtcArray);
//----------------------------------------------------------------------------------------------------------------------
begin
function GetVTClipboardFormatDescription(AFormat: Word): string; TClipboardFormatList.EnumerateFormats(TreeClass, Formats);
end;
begin
if TClipboardFormatList.FindFormat(AFormat, Result) = nil then //----------------------------------------------------------------------------------------------------------------------
Result := '';
end; function GetVTClipboardFormatDescription(AFormat: Word): string;
//---------------------------------------------------------------------------------------------------------------------- begin
if TClipboardFormatList.FindFormat(AFormat, Result) = nil then
procedure RegisterVTClipboardFormat(AFormat: Word; TreeClass: TVirtualTreeClass; Priority: Cardinal); Result := '';
end;
// Registers the given clipboard format for the given TreeClass.
//----------------------------------------------------------------------------------------------------------------------
var
I: Integer; procedure RegisterVTClipboardFormat(AFormat: Word; TreeClass: TVirtualTreeClass; Priority: Cardinal);
Buffer: array[0..2048] of Char;
FormatEtc: TFormatEtc; // Registers the given clipboard format for the given TreeClass.
begin var
I: Integer;
// Assumes a HGlobal format. Buffer: array[0..2048] of Char;
FormatEtc.cfFormat := AFormat; FormatEtc: TFormatEtc;
FormatEtc.ptd := nil;
FormatEtc.dwAspect := DVASPECT_CONTENT; begin
FormatEtc.lindex := -1;
FormatEtc.tymed := TYMED_HGLOBAL; // Assumes a HGlobal format.
FormatEtc.cfFormat := AFormat;
// Determine description string of the given format. For predefined formats we need the lookup table because they FormatEtc.ptd := nil;
// don't have a description string. For registered formats the description string is the string which was used FormatEtc.dwAspect := DVASPECT_CONTENT;
// to register them. FormatEtc.lindex := -1;
if AFormat < CF_MAX then FormatEtc.tymed := TYMED_HGLOBAL;
begin
for I := 1 to High(ClipboardDescriptions) do // Determine description string of the given format. For predefined formats we need the lookup table because they
if ClipboardDescriptions[I].ID = AFormat then // don't have a description string. For registered formats the description string is the string which was used
begin // to register them.
TClipboardFormatList.Add(ClipboardDescriptions[I].Description, TreeClass, Priority, FormatEtc); if AFormat < CF_MAX then
Break; begin
end; for I := 1 to High(ClipboardDescriptions) do
end if ClipboardDescriptions[I].ID = AFormat then
else begin
begin TClipboardFormatList.Add(ClipboardDescriptions[I].Description, TreeClass, Priority, FormatEtc);
GetClipboardFormatName(AFormat, Buffer, Length(Buffer)); Break;
TClipboardFormatList.Add(Buffer, TreeClass, Priority, FormatEtc); end;
end; end
end; else
begin
//---------------------------------------------------------------------------------------------------------------------- GetClipboardFormatName(AFormat, Buffer, Length(Buffer));
TClipboardFormatList.Add(Buffer, TreeClass, Priority, FormatEtc);
function RegisterVTClipboardFormat(const Description: string; TreeClass: TVirtualTreeClass; Priority: Cardinal; end;
tymed: Integer = TYMED_HGLOBAL; ptd: PDVTargetDevice = nil; dwAspect: Integer = DVASPECT_CONTENT; end;
lindex: Integer = -1): Word;
//----------------------------------------------------------------------------------------------------------------------
// Alternative method to register a certain clipboard format for a given tree class. Registration with the
// clipboard is done here too and the assigned ID returned by the function. function RegisterVTClipboardFormat(const Description: string; TreeClass: TVirtualTreeClass; Priority: Cardinal;
// tymed may contain or'ed TYMED constants which allows to register several storage formats for one clipboard format. tymed: Integer = TYMED_HGLOBAL; ptd: PDVTargetDevice = nil; dwAspect: Integer = DVASPECT_CONTENT;
lindex: Integer = -1): Word;
var
FormatEtc: TFormatEtc; // Alternative method to register a certain clipboard format for a given tree class. Registration with the
// clipboard is done here too and the assigned ID returned by the function.
begin // tymed may contain or'ed TYMED constants which allows to register several storage formats for one clipboard format.
Result := RegisterClipboardFormat(PChar(Description));
FormatEtc.cfFormat := Result; var
FormatEtc.ptd := ptd; FormatEtc: TFormatEtc;
FormatEtc.dwAspect := dwAspect;
FormatEtc.lindex := lindex; begin
FormatEtc.tymed := tymed; Result := RegisterClipboardFormat(PChar(Description));
TClipboardFormatList.Add(Description, TreeClass, Priority, FormatEtc); FormatEtc.cfFormat := Result;
end; FormatEtc.ptd := ptd;
FormatEtc.dwAspect := dwAspect;
//---------------------------------------------------------------------------------------------------------------------- FormatEtc.lindex := lindex;
FormatEtc.tymed := tymed;
class procedure TClipboardFormatList.Sort; TClipboardFormatList.Add(Description, TreeClass, Priority, FormatEtc);
end;
// Sorts all entry for priority (increasing priority value).
//----------------------------------------------------------------------------------------------------------------------
//--------------- local function --------------------------------------------
procedure QuickSort(L, R: Integer); class procedure TClipboardFormatList.Sort;
var // Sorts all entry for priority (increasing priority value).
I, J: Integer;
P, T: PClipboardFormatListEntry; //--------------- local function --------------------------------------------
procedure QuickSort(L, R: Integer);
begin
repeat var
I := L; I, J: Integer;
J := R; P, T: TClipboardFormatListEntry;
P := FList[(L + R) shr 1];
repeat begin
while PClipboardFormatListEntry(FList[I]).Priority < P.Priority do repeat
Inc(I); I := L;
while PClipboardFormatListEntry(FList[J]).Priority > P.Priority do J := R;
Dec(J); P := _List[(L + R) shr 1];
if I <= J then repeat
begin while TClipboardFormatListEntry(_List[I]).Priority < P.Priority do
T := FList[I]; Inc(I);
FList[I] := FList[J]; while TClipboardFormatListEntry(_List[J]).Priority > P.Priority do
FList[J] := T; Dec(J);
Inc(I); if I <= J then
Dec(J); begin
end; T := List[I];
until I > J; _List[I] := _List[J];
if L < J then _List[J] := T;
QuickSort(L, J); Inc(I);
L := I; Dec(J);
until I >= R; end;
end; until I > J;
//--------------- end local function ---------------------------------------- if L < J then
QuickSort(L, J);
begin L := I;
if FList.Count > 1 then until I >= R;
QuickSort(0, FList.Count - 1); end;
end; //--------------- end local function ----------------------------------------
//---------------------------------------------------------------------------------------------------------------------- begin
if List.Count > 1 then
class procedure TClipboardFormatList.Add(const FormatString: string; AClass: TVirtualTreeClass; Priority: Cardinal; AFormatEtc: TFormatEtc); QuickSort(0, List.Count - 1);
end;
// Adds the given data to the internal list. The priority value is used to sort formats for importance. Larger priority
// values mean less priority. //----------------------------------------------------------------------------------------------------------------------
var class procedure TClipboardFormatList.Add(const FormatString: string; AClass: TVirtualTreeClass; Priority: Cardinal; AFormatEtc: TFormatEtc);
Entry: PClipboardFormatListEntry;
// Adds the given data to the internal list. The priority value is used to sort formats for importance. Larger priority
begin // values mean less priority.
New(Entry);
Entry.Description := FormatString; var
Entry.TreeClass := AClass; Entry: TClipboardFormatListEntry;
Entry.Priority := Priority;
Entry.FormatEtc := AFormatEtc; begin
FList.Add(Entry); Entry := TClipboardFormatListEntry.Create;
Entry.Description := FormatString;
Sort; Entry.TreeClass := AClass;
end; Entry.Priority := Priority;
Entry.FormatEtc := AFormatEtc;
//---------------------------------------------------------------------------------------------------------------------- List.Add(Entry);
class procedure TClipboardFormatList.Clear; Sort;
end;
var
I: Integer; //----------------------------------------------------------------------------------------------------------------------
begin class procedure TClipboardFormatList.Clear;
for I := 0 to FList.Count - 1 do
Dispose(PClipboardFormatListEntry(FList[I])); var
FList.Clear; I: Integer;
end;
begin
//---------------------------------------------------------------------------------------------------------------------- if Assigned(_List) then begin
for I := 0 to _List.Count - 1 do
class procedure TClipboardFormatList.EnumerateFormats(TreeClass: TVirtualTreeClass; var Formats: TFormatEtcArray; const AllowedFormats: TClipboardFormats = nil); TClipboardFormatListEntry(List[I]).Free;
_List.Clear;
// Returns a list of format records for the given class. If assigned the AllowedFormats is used to limit the end;
// enumerated formats to those described in the list. end;
var //----------------------------------------------------------------------------------------------------------------------
I, Count: Integer;
Entry: PClipboardFormatListEntry; class procedure TClipboardFormatList.EnumerateFormats(TreeClass: TVirtualTreeClass; var Formats: TFormatEtcArray; const AllowedFormats: TClipboardFormats = nil);
begin // Returns a list of format records for the given class. If assigned the AllowedFormats is used to limit the
SetLength(Formats, FList.Count); // enumerated formats to those described in the list.
Count := 0;
for I := 0 to FList.Count - 1 do var
begin I, Count: Integer;
Entry := FList[I]; Entry: TClipboardFormatListEntry;
// Does the tree class support this clipboard format?
if TreeClass.InheritsFrom(Entry.TreeClass) then begin
begin SetLength(Formats, List.Count);
// Is this format allowed to be included? Count := 0;
if (AllowedFormats = nil) or (AllowedFormats.IndexOf(Entry.Description) > -1) then for I := 0 to List.Count - 1 do
begin begin
// The list could change before we use the FormatEtc so it is best not to pass a pointer to the true FormatEtc Entry := List[I];
// structure. Instead make a copy and send that. // Does the tree class support this clipboard format?
Formats[Count] := Entry.FormatEtc; if TreeClass.InheritsFrom(Entry.TreeClass) then
Inc(Count); begin
end; // Is this format allowed to be included?
end; if (AllowedFormats = nil) or (AllowedFormats.IndexOf(Entry.Description) > -1) then
end; begin
SetLength(Formats, Count); // The list could change before we use the FormatEtc so it is best not to pass a pointer to the true FormatEtc
end; // structure. Instead make a copy and send that.
Formats[Count] := Entry.FormatEtc;
//---------------------------------------------------------------------------------------------------------------------- Inc(Count);
end;
class procedure TClipboardFormatList.EnumerateFormats(TreeClass: TVirtualTreeClass; const Formats: TStrings); end;
end;
// Returns a list of format descriptions for the given class. SetLength(Formats, Count);
end;
var
I: Integer; //----------------------------------------------------------------------------------------------------------------------
Entry: PClipboardFormatListEntry;
class procedure TClipboardFormatList.EnumerateFormats(TreeClass: TVirtualTreeClass; const Formats: TStrings);
begin
for I := 0 to FList.Count - 1 do // Returns a list of format descriptions for the given class.
begin
Entry := FList[I]; var
if TreeClass.InheritsFrom(Entry.TreeClass) then I: Integer;
Formats.Add(Entry.Description); Entry: TClipboardFormatListEntry;
end;
end; begin
for I := 0 to List.Count - 1 do
//---------------------------------------------------------------------------------------------------------------------- begin
Entry := List[I];
class function TClipboardFormatList.FindFormat(const FormatString: string): PClipboardFormatListEntry; if TreeClass.InheritsFrom(Entry.TreeClass) then
Formats.Add(Entry.Description);
var end;
I: Integer; end;
Entry: PClipboardFormatListEntry;
//----------------------------------------------------------------------------------------------------------------------
begin
Result := nil; class function TClipboardFormatList.FindFormat(const FormatString: string): TClipboardFormatListEntry;
for I := FList.Count - 1 downto 0 do
begin var
Entry := FList[I]; I: Integer;
if CompareText(Entry.Description, FormatString) = 0 then Entry: TClipboardFormatListEntry;
begin
Result := Entry; begin
Break; Result := nil;
end; for I := List.Count - 1 downto 0 do
end; begin
end; Entry := List[I];
if CompareText(Entry.Description, FormatString) = 0 then
//---------------------------------------------------------------------------------------------------------------------- begin
Result := Entry;
class function TClipboardFormatList.FindFormat(const FormatString: string; var Fmt: Word): TVirtualTreeClass; Break;
end;
var end;
I: Integer; end;
Entry: PClipboardFormatListEntry;
//----------------------------------------------------------------------------------------------------------------------
begin
Result := nil; class function TClipboardFormatList.FindFormat(const FormatString: string; var Fmt: Word): TVirtualTreeClass;
for I := FList.Count - 1 downto 0 do
begin var
Entry := FList[I]; I: Integer;
if CompareText(Entry.Description, FormatString) = 0 then Entry: TClipboardFormatListEntry;
begin
Result := Entry.TreeClass; begin
Fmt := Entry.FormatEtc.cfFormat; Result := nil;
Break; for I := List.Count - 1 downto 0 do
end; begin
end; Entry := List[I];
end; if CompareText(Entry.Description, FormatString) = 0 then
begin
//---------------------------------------------------------------------------------------------------------------------- Result := Entry.TreeClass;
Fmt := Entry.FormatEtc.cfFormat;
class function TClipboardFormatList.FindFormat(Fmt: Word; var Description: string): TVirtualTreeClass; Break;
end;
var end;
I: Integer; end;
Entry: PClipboardFormatListEntry;
//----------------------------------------------------------------------------------------------------------------------
begin
Result := nil; class function TClipboardFormatList.FindFormat(Fmt: Word; var Description: string): TVirtualTreeClass;
for I := FList.Count - 1 downto 0 do
begin var
Entry := FList[I]; I: Integer;
if Entry.FormatEtc.cfFormat = Fmt then Entry: TClipboardFormatListEntry;
begin
Result := Entry.TreeClass; begin
Description := Entry.Description; Result := nil;
Break; for I := List.Count - 1 downto 0 do
end; begin
end; Entry := List[I];
end; if Entry.FormatEtc.cfFormat = Fmt then
begin
Result := Entry.TreeClass;
//Note - not using class constructors as they are not supported on C++ Builder. Description := Entry.Description;
initialization Break;
TClipboardFormatList.FList := TList.Create; end;
finalization end;
TClipboardFormatList.Clear; end;
TClipboardFormatList.FList.Free;
end.
class function TClipboardFormatList.GetList: TList;
begin
if not Assigned(_List) then
_List := TList.Create;
Exit(_List);
end;
initialization
finalization
TClipboardFormatList.Clear;
FreeAndNil(_List);
end.

2174
components/virtualtreeview/Source/VirtualTrees.Export.pas
View File

File diff suppressed because it is too large Load Diff

54
components/virtualtreeview/Source/VirtualTrees.HeaderPopup.dtx Normal file
View File

@ -0,0 +1,54 @@
@@TVirtualTreeCast
Necessary to make the header accessible.
@@TVTHeaderPopupOption.poAllowHideAll
Allows to hide all columns, including the last one.
@@TVTHeaderPopupOption.poOriginalOrder
Show menu items in original column order as they were added to the tree.
@@VTHeaderPopup.pas
The contents of this file are subject to the Mozilla Public License
Version 1.1 (the "License"); you may not use this file except in
compliance with the License. You may obtain a copy of the License at
http://www.mozilla.org/MPL/
Alternatively, you may redistribute this library, use and/or modify it under the terms of the
GNU Lesser General Public License as published by the Free Software Foundation;
either version 2.1 of the License, or (at your option) any later version.
You may obtain a copy of the LGPL at http://www.gnu.org/copyleft/.
Software distributed under the License is distributed on an "AS IS"
basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
License for the specific language governing rights and limitations
under the License.
The Original Code is VTHeaderPopup.pas.
The Initial Developer of the Original Code is Ralf Junker <delphi@zeitungsjunge.de>. All Rights Reserved.
Modified 14 Sep 2003 by Mike Lischke <public@delphi-gems.com>.
- Renamed event type name to be consistent with other event types (e.g. used in VT).
- Added event for hiding/showing columns.
- DoXXX method are now virtual.
- Conditional code rearrangement to get back Ctrl+Shift+Up/Down navigation back.
Modified 31 Mar 2003 by Mike Lischke <public@delphi-gems.com>.
Added a check for the PopupComponent property before casting it hardly to a Virtual Treeview. People might
(accidentally) misuse the header popup.
Modified 20 Oct 2002 by Borut Maricic <borut.maricic@pobox.com>.
Added the possibility to use Troy Wolbrink's Unicode aware popup menu. Define the compiler symbol TNT to enable it.
You can get Troy's Unicode controls collection from http://home.ccci.org/wolbrink/tnt/delphi_unicode_controls.htm).
Modified 24 Feb 2002 by Ralf Junker <delphi@zeitungsjunge.de>.
Fixed a bug where the OnAddHeaderPopupItem would interfere with poAllowHideAll options.
All column indexes now consistently use TColumnIndex (instead of Integer).
Modified 23 Feb 2002 by Ralf Junker <delphi@zeitungsjunge.de>.
Added option to show menu items in the same order as the columns or in original order.
Added option to prevent the user to hide all columns.
Modified 17 Feb 2002 by Jim Kueneman <jimdk@mindspring.com>.
Added the event to filter the items as they are added to the menu.

516
components/virtualtreeview/Source/VTHeaderPopup.pas → components/virtualtreeview/Source/VirtualTrees.HeaderPopup.pas
View File

@ -1,244 +1,272 @@
unit VTHeaderPopup; unit VirtualTrees.HeaderPopup;
//---------------------------------------------------------------------------------------------------------------------- //----------------------------------------------------------------------------------------------------------------------
// //
// Version 4.7.0 // Version 4.7.0
// //
// The contents of this file are subject to the Mozilla Public License // The contents of this file are subject to the Mozilla Public License
// Version 1.1 (the "License"); you may not use this file except in // Version 1.1 (the "License"); you may not use this file except in
// compliance with the License. You may obtain a copy of the License at // compliance with the License. You may obtain a copy of the License at
// http://www.mozilla.org/MPL/ // http://www.mozilla.org/MPL/
// //
// Alternatively, you may redistribute this library, use and/or modify it under the terms of the // Alternatively, you may redistribute this library, use and/or modify it under the terms of the
// GNU Lesser General Public License as published by the Free Software Foundation; // GNU Lesser General Public License as published by the Free Software Foundation;
// either version 2.1 of the License, or (at your option) any later version. // either version 2.1 of the License, or (at your option) any later version.
// You may obtain a copy of the LGPL at http://www.gnu.org/copyleft/. // You may obtain a copy of the LGPL at http://www.gnu.org/copyleft/.
// //
// Software distributed under the License is distributed on an "AS IS" // Software distributed under the License is distributed on an "AS IS"
// basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the // basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
// License for the specific language governing rights and limitations // License for the specific language governing rights and limitations
// under the License. // under the License.
// //
// The Original Code is VTHeaderPopup.pas. // The Original Code is VTHeaderPopup.pas.
// //
// The Initial Developer of the Original Code is Ralf Junker <delphi@zeitungsjunge.de>. All Rights Reserved. // The Initial Developer of the Original Code is Ralf Junker <delphi@zeitungsjunge.de>. All Rights Reserved.
// //
// September 2004: // September 2004:
// - Bug fix: TVTHeaderPopupMenu.OnMenuItemClick used the wrong Tag member for the event. // - Bug fix: TVTHeaderPopupMenu.OnMenuItemClick used the wrong Tag member for the event.
// //
// Modified 12 Dec 2003 by Ralf Junker <delphi@zeitungsjunge.de>. // Modified 12 Dec 2003 by Ralf Junker <delphi@zeitungsjunge.de>.
// - Added missing default storage specifier for Options property. // - Added missing default storage specifier for Options property.
// - To avoid mixing up image lists of different trees sharing the same header // - To avoid mixing up image lists of different trees sharing the same header
// popup, set the popup's image list to nil if hoShowImages is not in the // popup, set the popup's image list to nil if hoShowImages is not in the
// tree's header options. // tree's header options.
// - Added an additional check for the PopupComponent property before casting // - Added an additional check for the PopupComponent property before casting
// it hardly to a Virtual Treeview in OnMenuItemClick. See entry 31 Mar 2003. // it hardly to a Virtual Treeview in OnMenuItemClick. See entry 31 Mar 2003.
// //
// Modified 14 Sep 2003 by Mike Lischke <public@delphi-gems.com>. // Modified 14 Sep 2003 by Mike Lischke <public@delphi-gems.com>.
// - Renamed event type name to be consistent with other event types (e.g. used in VT). // - Renamed event type name to be consistent with other event types (e.g. used in VT).
// - Added event for hiding/showing columns. // - Added event for hiding/showing columns.
// - DoXXX method are now virtual. // - DoXXX method are now virtual.
// - Conditional code rearrangement to get back Ctrl+Shift+Up/Down navigation. // - Conditional code rearrangement to get back Ctrl+Shift+Up/Down navigation.
// //
// Modified 31 Mar 2003 by Mike Lischke <public@soft-gems.net>. // Modified 31 Mar 2003 by Mike Lischke <public@soft-gems.net>.
// - Added a check for the PopupComponent property before casting it hardly to // - Added a check for the PopupComponent property before casting it hardly to
// a Virtual Treeview. People might (accidentally) misuse the header popup. // a Virtual Treeview. People might (accidentally) misuse the header popup.
// //
// Modified 20 Oct 2002 by Borut Maricic <borut.maricic@pobox.com>. // Modified 20 Oct 2002 by Borut Maricic <borut.maricic@pobox.com>.
// - Added the possibility to use Troy Wolbrink's Unicode aware popup menu. // - Added the possibility to use Troy Wolbrink's Unicode aware popup menu.
// Define the compiler symbol TNT to enable it. You can get Troy's Unicode // Define the compiler symbol TNT to enable it. You can get Troy's Unicode
// controls collection from http://home.ccci.org/wolbrink/tnt/delphi_unicode_controls.htm. // controls collection from http://home.ccci.org/wolbrink/tnt/delphi_unicode_controls.htm.
// //
// Modified 24 Feb 2002 by Ralf Junker <delphi@zeitungsjunge.de>. // Modified 24 Feb 2002 by Ralf Junker <delphi@zeitungsjunge.de>.
// - Fixed a bug where the OnAddHeaderPopupItem would interfere with // - Fixed a bug where the OnAddHeaderPopupItem would interfere with
// poAllowHideAll options. // poAllowHideAll options.
// - All column indexes now consistently use TColumnIndex (instead of Integer). // - All column indexes now consistently use TColumnIndex (instead of Integer).
// //
// Modified 23 Feb 2002 by Ralf Junker <delphi@zeitungsjunge.de>. // Modified 23 Feb 2002 by Ralf Junker <delphi@zeitungsjunge.de>.
// - Added option to show menu items in the same order as the columns or in // - Added option to show menu items in the same order as the columns or in
// original order. // original order.
// - Added option to prevent the user to hide all columns. // - Added option to prevent the user to hide all columns.
// //
// Modified 17 Feb 2002 by Jim Kueneman <jimdk@mindspring.com>. // Modified 17 Feb 2002 by Jim Kueneman <jimdk@mindspring.com>.
// - Added the event to filter the items as they are added to the menu. // - Added the event to filter the items as they are added to the menu.
//---------------------------------------------------------------------------------------------------------------------- //----------------------------------------------------------------------------------------------------------------------
interface interface
uses uses
Vcl.Menus, VirtualTrees; System.Classes,
Vcl.Menus,
type VirtualTrees;
TVTHeaderPopupOption = (
poOriginalOrder, // Show menu items in original column order as they were added to the tree. type
poAllowHideAll, // Allows to hide all columns, including the last one. TVTHeaderPopupOption = (
poResizeToFitItem // Adds an item which, if clicks, resizes all columns to fit by callung TVTHeader.AutoFitColumns poOriginalOrder, // Show menu items in original column order as they were added to the tree.
); poAllowHideAll, // Allows to hide all columns, including the last one.
TVTHeaderPopupOptions = set of TVTHeaderPopupOption; poResizeToFitItem // Adds an item which, if clicks, resizes all columns to fit by callung TVTHeader.AutoFitColumns
);
TAddPopupItemType = ( TVTHeaderPopupOptions = set of TVTHeaderPopupOption;
apNormal,
apDisabled, TColumnChangeEvent = procedure(const Sender: TBaseVirtualTree; const Column: TColumnIndex; Visible: Boolean) of object;
apHidden
); TVTHeaderPopupMenu = class(TPopupMenu)
strict private
TAddHeaderPopupItemEvent = procedure(const Sender: TBaseVirtualTree; const Column: TColumnIndex; FOptions: TVTHeaderPopupOptions;
var Cmd: TAddPopupItemType) of object;
TColumnChangeEvent = procedure(const Sender: TBaseVirtualTree; const Column: TColumnIndex; Visible: Boolean) of object; FOnHeaderAddPopupItem: TVTHeaderAddPopupItemEvent;
FOnColumnChange: TColumnChangeEvent;
TVTMenuItem = TMenuItem; procedure ResizeColumnToFit(Sender: TObject);
procedure ResizeToFit(Sender: TObject);
TVTHeaderPopupMenu = class(TPopupMenu) strict protected
strict private procedure DoAddHeaderPopupItem(const Column: TColumnIndex; out Cmd: TAddPopupItemType); virtual;
FOptions: TVTHeaderPopupOptions; procedure DoColumnChange(Column: TColumnIndex; Visible: Boolean); virtual;
procedure OnMenuItemClick(Sender: TObject);
FOnAddHeaderPopupItem: TAddHeaderPopupItemEvent; public
FOnColumnChange: TColumnChangeEvent; constructor Create(AOwner: TComponent); override;
strict protected procedure Popup(x, y: Integer); override;
procedure DoAddHeaderPopupItem(const Column: TColumnIndex; out Cmd: TAddPopupItemType); virtual; published
procedure DoColumnChange(Column: TColumnIndex; Visible: Boolean); virtual; property Options: TVTHeaderPopupOptions read FOptions write FOptions default [poResizeToFitItem];
procedure OnMenuItemClick(Sender: TObject);
public property OnAddHeaderPopupItem: TVTHeaderAddPopupItemEvent read FOnHeaderAddPopupItem write FOnHeaderAddPopupItem;
procedure Popup(x, y: Integer); override; property OnColumnChange: TColumnChangeEvent read FOnColumnChange write FOnColumnChange;
published end;
property Options: TVTHeaderPopupOptions read FOptions write FOptions default [];
//----------------------------------------------------------------------------------------------------------------------
property OnAddHeaderPopupItem: TAddHeaderPopupItemEvent read FOnAddHeaderPopupItem write FOnAddHeaderPopupItem;
property OnColumnChange: TColumnChangeEvent read FOnColumnChange write FOnColumnChange; implementation
end;
uses
//---------------------------------------------------------------------------------------------------------------------- Winapi.Windows, System.Types;
implementation resourcestring
sResizeColumnToFit = 'Size &Column to Fit';
uses sResizeToFit = 'Size &All Columns to Fit';
Winapi.Windows, System.Classes;
type
const TVTMenuItem = class(TMenuItem)
cResizeToFitMenuItemName = 'VT_ResizeToFitMenuItem'; public
constructor Create(AOwner: TComponent; const ACaption: string; AClickHandler: TNotifyEvent = nil); reintroduce;
//----------------- TVTHeaderPopupMenu --------------------------------------------------------------------------------- end;
procedure TVTHeaderPopupMenu.DoAddHeaderPopupItem(const Column: TColumnIndex; out Cmd: TAddPopupItemType); //----------------- TVTHeaderPopupMenu ---------------------------------------------------------------------------------
begin constructor TVTHeaderPopupMenu.Create(AOwner: TComponent);
Cmd := apNormal; begin
if Assigned(FOnAddHeaderPopupItem) then inherited;
FOnAddHeaderPopupItem((PopupComponent as TBaseVirtualTree), Column, Cmd); FOptions := [poResizeToFitItem];
end; end;
//---------------------------------------------------------------------------------------------------------------------- procedure TVTHeaderPopupMenu.DoAddHeaderPopupItem(const Column: TColumnIndex; out Cmd: TAddPopupItemType);
procedure TVTHeaderPopupMenu.DoColumnChange(Column: TColumnIndex; Visible: Boolean); begin
Cmd := apNormal;
begin if Assigned(FOnHeaderAddPopupItem) then
if Assigned(FOnColumnChange) then FOnHeaderAddPopupItem((PopupComponent as TBaseVirtualTree), Column, Cmd);
FOnColumnChange((PopupComponent as TBaseVirtualTree), Column, Visible); end;
end;
//----------------------------------------------------------------------------------------------------------------------
//----------------------------------------------------------------------------------------------------------------------
procedure TVTHeaderPopupMenu.DoColumnChange(Column: TColumnIndex; Visible: Boolean);
procedure TVTHeaderPopupMenu.OnMenuItemClick(Sender: TObject);
begin
begin if Assigned(FOnColumnChange) then
if Assigned(PopupComponent) and (PopupComponent is TBaseVirtualTree) then begin FOnColumnChange((PopupComponent as TBaseVirtualTree), Column, Visible);
if TVTMenuItem(Sender).Name = cResizeToFitMenuItemName then begin end;
TBaseVirtualTree(PopupComponent).Header.AutoFitColumns();
end //----------------------------------------------------------------------------------------------------------------------
else begin
with TVTMenuItem(Sender), procedure TVTHeaderPopupMenu.OnMenuItemClick(Sender: TObject);
TBaseVirtualTree(PopupComponent).Header.Columns.Items[Tag] do
begin begin
if Checked then if Assigned(PopupComponent) and (PopupComponent is TBaseVirtualTree) then begin
Options := Options - [coVisible] with TBaseVirtualTree(PopupComponent).Header.Columns.Items[TVTMenuItem(Sender).Tag] do
else begin
Options := Options + [coVisible]; if TVTMenuItem(Sender).Checked then
Options := Options - [coVisible]
DoColumnChange(TVTMenuItem(Sender).Tag, not Checked); else
end; Options := Options + [coVisible];
end;//else end;
end; end;
end; end;
//---------------------------------------------------------------------------------------------------------------------- //----------------------------------------------------------------------------------------------------------------------
procedure TVTHeaderPopupMenu.Popup(x, y: Integer); procedure TVTHeaderPopupMenu.Popup(x, y: Integer);
resourcestring var
sResizeToFit = '&Resize All Columns To Fit'; ColPos: TColumnPosition;
var ColIdx: TColumnIndex;
ColPos: TColumnPosition;
ColIdx: TColumnIndex; NewMenuItem: TVTMenuItem;
Cmd: TAddPopupItemType;
NewMenuItem: TVTMenuItem;
Cmd: TAddPopupItemType; VisibleCounter: Cardinal;
VisibleItem: TVTMenuItem;
VisibleCounter: Cardinal;
VisibleItem: TVTMenuItem; i: Integer;
begin begin
if Assigned(PopupComponent) and (PopupComponent is TBaseVirtualTree) then if Assigned(PopupComponent) and (PopupComponent is TBaseVirtualTree) then
begin begin
// Delete existing menu items. // Delete existing menu items.
while Items.Count > 0 do for i := Items.Count -1 downto 0 do begin
Items[0].Free; if Items[i] is TVTMenuItem then
Items[i].Free;
if poResizeToFitItem in Self.Options then begin end;//for i
NewMenuItem := NewItem(sResizeToFit, 0, False, True, OnMenuItemClick, 0, cResizeToFitMenuItemName);
Items.Add(NewMenuItem); if poResizeToFitItem in Self.Options then
Items.Add(NewLine()); begin
end;//poResizeToFitItem Items.Add(TVTMenuItem.Create(Self, sResizeColumnToFit, ResizeColumnToFit));
Items.Add(TVTMenuItem.Create(Self, sResizeToFit, ResizeToFit));
// Add column menu items. Items.Add(TVTMenuItem.Create(Self, cLineCaption));
with (PopupComponent as TBaseVirtualTree).Header do end;//poResizeToFitItem
begin
if hoShowImages in Options then // Add column menu items.
Self.Images := Images with (PopupComponent as TBaseVirtualTree).Header do
else begin
// Remove a possible reference to image list of another tree previously assigned. if hoShowImages in Options then
Self.Images := nil; Self.Images := Images
VisibleItem := nil; else
VisibleCounter := 0; // Remove a possible reference to image list of another tree previously assigned.
for ColPos := 0 to Columns.Count - 1 do Self.Images := nil;
begin VisibleItem := nil;
if poOriginalOrder in FOptions then VisibleCounter := 0;
ColIdx := ColPos for ColPos := 0 to Columns.Count - 1 do
else begin
ColIdx := Columns.ColumnFromPosition(ColPos); if poOriginalOrder in FOptions then
ColIdx := ColPos
with Columns[ColIdx] do else
begin ColIdx := Columns.ColumnFromPosition(ColPos);
if coVisible in Options then
Inc(VisibleCounter); with Columns[ColIdx] do
DoAddHeaderPopupItem(ColIdx, Cmd); begin
if Cmd <> apHidden then if coVisible in Options then
begin Inc(VisibleCounter);
NewMenuItem := TVTMenuItem.Create(Self); DoAddHeaderPopupItem(ColIdx, Cmd);
NewMenuItem.Tag := ColIdx; if Cmd <> apHidden then
NewMenuItem.Caption := Text; begin
NewMenuItem.Hint := Hint; NewMenuItem := TVTMenuItem.Create(Self, Text, OnMenuItemClick);
NewMenuItem.ImageIndex := ImageIndex; NewMenuItem.Tag := ColIdx;
NewMenuItem.Checked := coVisible in Options; NewMenuItem.Caption := Text;
NewMenuItem.OnClick := OnMenuItemClick; NewMenuItem.Hint := Hint;
if Cmd = apDisabled then NewMenuItem.ImageIndex := ImageIndex;
NewMenuItem.Enabled := False NewMenuItem.Checked := coVisible in Options;
else if Cmd = apDisabled then
if coVisible in Options then NewMenuItem.Enabled := False
VisibleItem := NewMenuItem; else
Items.Add(NewMenuItem); if coVisible in Options then
end; VisibleItem := NewMenuItem;
end; Items.Add(NewMenuItem);
end; end;
end;
// Conditionally disable menu item of last enabled column. end;
if (VisibleCounter = 1) and (VisibleItem <> nil) and not (poAllowHideAll in FOptions) then
VisibleItem.Enabled := False; // Conditionally disable menu item of last enabled column.
end; if (VisibleCounter = 1) and (VisibleItem <> nil) and not (poAllowHideAll in FOptions) then
end; VisibleItem.Enabled := False;
end;
inherited; end;
end;
inherited;
//---------------------------------------------------------------------------------------------------------------------- end;
end. procedure TVTHeaderPopupMenu.ResizeColumnToFit(Sender: TObject);
var
P: TPoint;
Column: TColumnIndex;
begin
P := Point(PopupPoint.X, PopupPoint.Y + TBaseVirtualTree(PopupComponent).Header.Height);
P := TBaseVirtualTree(PopupComponent).ScreenToClient(P);
Column := TBaseVirtualTree(PopupComponent).Header.Columns.ColumnFromPosition(P);
if Column <> InvalidColumn then
TBaseVirtualTree(PopupComponent).Header.AutoFitColumns(True, smaUseColumnOption, Column, Column);
end;
procedure TVTHeaderPopupMenu.ResizeToFit(Sender: TObject);
begin
TBaseVirtualTree(PopupComponent).Header.AutoFitColumns();
end;
//----------------------------------------------------------------------------------------------------------------------
{ TVTMenuItem }
constructor TVTMenuItem.Create(AOwner: TComponent; const ACaption: string; AClickHandler: TNotifyEvent);
begin
Inherited Create(AOwner);
Caption := ACaption;
OnClick := AClickHandler;
end;
end.

23
components/virtualtreeview/Source/VirtualTrees.StyleHooks.pas
View File

@ -447,10 +447,16 @@ begin
PaintScrollBars; PaintScrollBars;
end; end;
procedure TVclStyleScrollBarsHook.PaintScrollBars; procedure TVclStyleScrollBarsHook.PaintScrollBars();
begin begin
FVertScrollBarWindow.Repaint; if FVertScrollBarWindow.HandleAllocated then begin
FHorzScrollBarWindow.Repaint; FVertScrollBarWindow.Repaint;
RedrawWindow(FVertScrollBarWindow.Handle, nil, 0, RDW_FRAME or RDW_INVALIDATE); // Fixes issue #698
end;
if FHorzScrollBarWindow.HandleAllocated then begin
FHorzScrollBarWindow.Repaint;
RedrawWindow(FHorzScrollBarWindow.Handle, nil, 0, RDW_FRAME or RDW_INVALIDATE); // Fixes issue #698
end;
end; end;
function TVclStyleScrollBarsHook.PointInTreeHeader(const P: TPoint): Boolean; function TVclStyleScrollBarsHook.PointInTreeHeader(const P: TPoint): Boolean;
@ -573,7 +579,8 @@ end;
procedure TVclStyleScrollBarsHook.WMKeyDown(var Msg: TMessage); procedure TVclStyleScrollBarsHook.WMKeyDown(var Msg: TMessage);
begin begin
CallDefaultProc(TMessage(Msg)); CallDefaultProc(TMessage(Msg));
PaintScrollBars; CalcScrollBarsRect;
UpdateScrollBarWindow;
Handled := True; Handled := True;
end; end;
@ -587,7 +594,8 @@ end;
procedure TVclStyleScrollBarsHook.WMLButtonDown(var Msg: TWMMouse); procedure TVclStyleScrollBarsHook.WMLButtonDown(var Msg: TWMMouse);
begin begin
CallDefaultProc(TMessage(Msg)); CallDefaultProc(TMessage(Msg));
PaintScrollBars; CalcScrollBarsRect;
UpdateScrollBarWindow;
Handled := True; Handled := True;
end; end;
@ -1140,9 +1148,12 @@ begin
end; end;
initialization initialization
TCustomStyleEngine.RegisterStyleHook(TVirtualStringTree, TVclStyleScrollBarsHook); TCustomStyleEngine.RegisterStyleHook(TVirtualStringTree, TVclStyleScrollBarsHook);
TCustomStyleEngine.RegisterStyleHook(TVirtualDrawTree, TVclStyleScrollBarsHook); TCustomStyleEngine.RegisterStyleHook(TVirtualDrawTree, TVclStyleScrollBarsHook);
finalization
TCustomStyleEngine.UnRegisterStyleHook(TVirtualStringTree, TVclStyleScrollBarsHook);
TCustomStyleEngine.UnRegisterStyleHook(TVirtualDrawTree, TVclStyleScrollBarsHook);
end. end.

2618
components/virtualtreeview/Source/VirtualTrees.Utils.pas
View File

File diff suppressed because it is too large Load Diff

436
components/virtualtreeview/Source/VirtualTrees.WorkerThread.pas
View File

@ -1,227 +1,225 @@
unit VirtualTrees.WorkerThread; unit VirtualTrees.WorkerThread;
interface interface
uses uses
System.Classes, System.Classes,
VirtualTrees; VirtualTrees;
type type
// internal worker thread // internal worker thread
TWorkerThread = class(TThread) TWorkerThread = class(TThread)
private private
FCurrentTree: TBaseVirtualTree; FCurrentTree: TBaseVirtualTree;
FWaiterList: TThreadList; FWaiterList: TThreadList;
FRefCount: Cardinal; FRefCount: Integer;
protected class procedure EnsureCreated();
procedure CancelValidation(Tree: TBaseVirtualTree); class procedure Dispose();
procedure Execute; override; procedure WaitForValidationTermination(Tree: TBaseVirtualTree);
public protected
constructor Create(CreateSuspended: Boolean); procedure Execute; override;
destructor Destroy; override; public
constructor Create();
procedure AddTree(Tree: TBaseVirtualTree); destructor Destroy; override;
procedure RemoveTree(Tree: TBaseVirtualTree);
/// For lifeteime management of the TWorkerThread
property CurrentTree: TBaseVirtualTree read FCurrentTree; class procedure AddThreadReference;
end; class procedure ReleaseThreadReference();
class procedure AddTree(Tree: TBaseVirtualTree);
procedure AddThreadReference; class procedure RemoveTree(Tree: TBaseVirtualTree);
procedure ReleaseThreadReference(Tree: TBaseVirtualTree);
property CurrentTree: TBaseVirtualTree read FCurrentTree;
end;
var
WorkerThread: TWorkerThread;
WorkEvent: THandle;
implementation implementation
uses uses
Winapi.Windows, Winapi.Windows,
System.Types, System.Types,
System.SysUtils; System.SysUtils;
type type
TBaseVirtualTreeCracker = class(TBaseVirtualTree) TBaseVirtualTreeCracker = class(TBaseVirtualTree)
end; end;
//----------------- TWorkerThread -------------------------------------------------------------------------------------- var
WorkerThread: TWorkerThread = nil;
procedure AddThreadReference; WorkEvent: THandle;
//----------------- TWorkerThread --------------------------------------------------------------------------------------
class procedure TWorkerThread.EnsureCreated();
begin begin
if not Assigned(WorkerThread) then if not Assigned(WorkerThread) then
begin begin
// Create an event used to trigger our worker thread when something is to do. // Create an event used to trigger our worker thread when something is to do.
WorkEvent := CreateEvent(nil, False, False, nil); WorkEvent := CreateEvent(nil, False, False, nil);
if WorkEvent = 0 then if WorkEvent = 0 then
RaiseLastOSError; RaiseLastOSError;
// Create worker thread, initialize it and send it to its wait loop. // Create worker thread, initialize it and send it to its wait loop.
WorkerThread := TWorkerThread.Create(False); WorkerThread := TWorkerThread.Create();
end; end;
Inc(WorkerThread.FRefCount);
end; end;
//---------------------------------------------------------------------------------------------------------------------- class procedure TWorkerThread.Dispose();
procedure ReleaseThreadReference(Tree: TBaseVirtualTree);
begin begin
if Assigned(WorkerThread) then WorkerThread.Terminate();
begin SetEvent(WorkEvent);
Dec(WorkerThread.FRefCount); WorkerThread := nil; //Will be freed usinf TThreaf.FreeOnTerminate
CloseHandle(WorkEvent);
// Make sure there is no reference remaining to the releasing tree.
TBaseVirtualTreeCracker(Tree).InterruptValidation;
if WorkerThread.FRefCount = 0 then
begin
with WorkerThread do
begin
Terminate;
SetEvent(WorkEvent);
end;
FreeAndNil(WorkerThread);
CloseHandle(WorkEvent);
end;
end;
end;
//----------------------------------------------------------------------------------------------------------------------
constructor TWorkerThread.Create(CreateSuspended: Boolean);
begin
inherited Create(CreateSuspended);
FWaiterList := TThreadList.Create;
end;
//----------------------------------------------------------------------------------------------------------------------
destructor TWorkerThread.Destroy;
begin
// First let the ancestor stop the thread before freeing our resources.
inherited;
FWaiterList.Free;
end;
//----------------------------------------------------------------------------------------------------------------------
procedure TWorkerThread.CancelValidation(Tree: TBaseVirtualTree);
var
Msg: TMsg;
begin
// Wait for any references to this tree to be released.
// Pump WM_CHANGESTATE messages so the thread doesn't block on SendMessage calls.
while FCurrentTree = Tree do
begin
if Tree.HandleAllocated and PeekMessage(Msg, Tree.Handle, WM_CHANGESTATE, WM_CHANGESTATE, PM_REMOVE) then
begin
TranslateMessage(Msg);
DispatchMessage(Msg);
Continue;
end;
if (toVariableNodeHeight in TBaseVirtualTreeCracker(Tree).TreeOptions.MiscOptions) then
CheckSynchronize(); // We need to call CheckSynchronize here because we are using TThread.Synchronize in TBaseVirtualTree.MeasureItemHeight()
end;
end;
//----------------------------------------------------------------------------------------------------------------------
procedure TWorkerThread.Execute;
// Does some background tasks, like validating tree caches.
var
EnterStates,
LeaveStates: TChangeStates;
lCurrentTree: TBaseVirtualTree;
begin
TThread.NameThreadForDebugging('VirtualTrees.TWorkerThread');
while not Terminated do
begin
WaitForSingleObject(WorkEvent, INFINITE);
if not Terminated then
begin
// Get the next waiting tree.
with FWaiterList.LockList do
try
if Count > 0 then
begin
FCurrentTree := Items[0];
// Remove this tree from waiter list.
Delete(0);
// If there is yet another tree to work on then set the work event to keep looping.
if Count > 0 then
SetEvent(WorkEvent);
end
else
FCurrentTree := nil;
finally
FWaiterList.UnlockList;
end;
// Something to do?
if Assigned(FCurrentTree) then
begin
try
TBaseVirtualTreeCracker(FCurrentTree).ChangeTreeStatesAsync([csValidating], [csUseCache, csValidationNeeded]);
EnterStates := [];
if not (tsStopValidation in FCurrentTree.TreeStates) and TBaseVirtualTreeCracker(FCurrentTree).DoValidateCache then
EnterStates := [csUseCache];
finally
LeaveStates := [csValidating, csStopValidation];
TBaseVirtualTreeCracker(FCurrentTree).ChangeTreeStatesAsync(EnterStates, LeaveStates);
lCurrentTree := FCurrentTree; // Save reference in a local variable for later use
FCurrentTree := nil; //Clear variable to prevent deadlock in CancelValidation. See #434
Queue(TBaseVirtualTreeCracker(lCurrentTree).UpdateEditBounds);
end;
end;
end;
end;
end;
//----------------------------------------------------------------------------------------------------------------------
procedure TWorkerThread.AddTree(Tree: TBaseVirtualTree);
begin
Assert(Assigned(Tree), 'Tree must not be nil.');
// Remove validation stop flag, just in case it is still set.
TBaseVirtualTreeCracker(Tree).DoStateChange([], [tsStopValidation]);
with FWaiterList.LockList do
try
if IndexOf(Tree) = -1 then
Add(Tree);
finally
FWaiterList.UnlockList;
end;
end;
//----------------------------------------------------------------------------------------------------------------------
procedure TWorkerThread.RemoveTree(Tree: TBaseVirtualTree);
begin
Assert(Assigned(Tree), 'Tree must not be nil.');
with FWaiterList.LockList do
try
Remove(Tree);
finally
FWaiterList.UnlockList; // Seen several AVs in this line, was called from TWorkerThrea.Destroy. Joachim Marder.
end;
CancelValidation(Tree);
end; end;
end. class procedure TWorkerThread.AddThreadReference;
begin
TWorkerThread.EnsureCreated();
InterlockedIncrement(WorkerThread.FRefCount);
end;
//----------------------------------------------------------------------------------------------------------------------
class procedure TWorkerThread.ReleaseThreadReference();
begin
if Assigned(WorkerThread) then
begin
InterlockedDecrement(WorkerThread.FRefCount);
if WorkerThread.FRefCount = 0 then
WorkerThread.Dispose();
end;
end;
//----------------------------------------------------------------------------------------------------------------------
constructor TWorkerThread.Create();
begin
inherited Create(False);
FreeOnTerminate := True;
FWaiterList := TThreadList.Create;
end;
//----------------------------------------------------------------------------------------------------------------------
destructor TWorkerThread.Destroy;
begin
// First let the ancestor stop the thread before freeing our resources.
inherited;
FWaiterList.Free;
end;
//----------------------------------------------------------------------------------------------------------------------
procedure TWorkerThread.WaitForValidationTermination(Tree: TBaseVirtualTree);
begin
// Wait for any references to this tree to be released.
while FCurrentTree = Tree do
begin
Sleep(1);
if (toVariableNodeHeight in TBaseVirtualTreeCracker(Tree).TreeOptions.MiscOptions) then
CheckSynchronize(); // We need to call CheckSynchronize here because we are using TThread.Synchronize in TBaseVirtualTree.MeasureItemHeight()
end;
end;
//----------------------------------------------------------------------------------------------------------------------
procedure TWorkerThread.Execute();
// Does some background tasks, like validating tree caches.
var
EnterStates: TVirtualTreeStates;
lCurrentTree: TBaseVirtualTree;
begin
TThread.NameThreadForDebugging('VirtualTrees.TWorkerThread');
while not Terminated do
begin
WaitForSingleObject(WorkEvent, INFINITE);
if Terminated then
exit;
// Get the next waiting tree.
with FWaiterList.LockList do
try
if Count > 0 then
begin
lCurrentTree := Items[0];
// Remove this tree from waiter list.
Delete(0);
// If there is yet another tree to work on then set the work event to keep looping.
if Count > 0 then
SetEvent(WorkEvent);
end
else
lCurrentTree := nil;
finally
FWaiterList.UnlockList;
end;
// Something to do?
if Assigned(lCurrentTree) then
begin
try
TBaseVirtualTreeCracker(lCurrentTree).ChangeTreeStatesAsync([tsValidating], [tsUseCache, tsValidationNeeded]);
FCurrentTree := lCurrentTree;
EnterStates := [];
if not (tsStopValidation in FCurrentTree.TreeStates) and TBaseVirtualTreeCracker(FCurrentTree).DoValidateCache then
EnterStates := [tsUseCache];
finally
FCurrentTree := nil; //Clear variable to prevent deadlock in CancelValidation. See #434
TBaseVirtualTreeCracker(lCurrentTree).ChangeTreeStatesAsync(EnterStates, [tsValidating, tsStopValidation]);
Queue(TBaseVirtualTreeCracker(lCurrentTree).UpdateEditBounds);
end;
end;
end;//while
end;
//----------------------------------------------------------------------------------------------------------------------
class procedure TWorkerThread.AddTree(Tree: TBaseVirtualTree);
begin
Assert(Assigned(Tree), 'Tree must not be nil.');
TWorkerThread.EnsureCreated();
// Remove validation stop flag, just in case it is still set.
TBaseVirtualTreeCracker(Tree).DoStateChange([], [tsStopValidation]);
with WorkerThread.FWaiterList.LockList do
try
if IndexOf(Tree) = -1 then
Add(Tree);
finally
WorkerThread.FWaiterList.UnlockList;
end;
SetEvent(WorkEvent);
end;
//----------------------------------------------------------------------------------------------------------------------
class procedure TWorkerThread.RemoveTree(Tree: TBaseVirtualTree);
begin
if not Assigned(WorkerThread) then
exit;
Assert(Assigned(Tree), 'Tree must not be nil.');
with WorkerThread.FWaiterList.LockList do
try
Remove(Tree);
finally
WorkerThread.FWaiterList.UnlockList; // Seen several AVs in this line, was called from TWorkerThrea.Destroy. Joachim Marder.
end;
WorkerThread.WaitForValidationTermination(Tree);
end;
end.

6469
components/virtualtreeview/Source/VirtualTrees.dtx Normal file
View File

File diff suppressed because it is too large Load Diff

69216
components/virtualtreeview/Source/VirtualTrees.pas
View File

File diff suppressed because it is too large Load Diff

BIN
components/virtualtreeview/Source/VirtualTrees.res
View File

Binary file not shown.

10
components/virtualtreeview/packages/Delphi10.3/VirtualTreesD.dpk vendored
View File

@ -1,30 +1,30 @@
package VirtualTreesD; package VirtualTreesD;
{$R *.res} {$R *.res}
{$R '..\..\Resources\VirtualTreesD.dcr'} {$R '..\..\Design\VirtualTrees.dcr'}
{$IFDEF IMPLICITBUILDING This IFDEF should not be used by users} {$IFDEF IMPLICITBUILDING This IFDEF should not be used by users}
{$ALIGN 8} {$ALIGN 8}
{$ASSERTIONS ON} {$ASSERTIONS ON}
{$BOOLEVAL OFF} {$BOOLEVAL OFF}
{$DEBUGINFO ON} {$DEBUGINFO OFF}
{$EXTENDEDSYNTAX ON} {$EXTENDEDSYNTAX ON}
{$IMPORTEDDATA ON} {$IMPORTEDDATA ON}
{$IOCHECKS ON} {$IOCHECKS ON}
{$LOCALSYMBOLS ON} {$LOCALSYMBOLS ON}
{$LONGSTRINGS ON} {$LONGSTRINGS ON}
{$OPENSTRINGS ON} {$OPENSTRINGS ON}
{$OPTIMIZATION OFF} {$OPTIMIZATION ON}
{$OVERFLOWCHECKS OFF} {$OVERFLOWCHECKS OFF}
{$RANGECHECKS OFF} {$RANGECHECKS OFF}
{$REFERENCEINFO ON} {$REFERENCEINFO ON}
{$SAFEDIVIDE OFF} {$SAFEDIVIDE OFF}
{$STACKFRAMES ON} {$STACKFRAMES OFF}
{$TYPEDADDRESS OFF} {$TYPEDADDRESS OFF}
{$VARSTRINGCHECKS ON} {$VARSTRINGCHECKS ON}
{$WRITEABLECONST OFF} {$WRITEABLECONST OFF}
{$MINENUMSIZE 1} {$MINENUMSIZE 1}
{$IMAGEBASE $400000} {$IMAGEBASE $400000}
{$DEFINE DEBUG} {$DEFINE RELEASE}
{$ENDIF IMPLICITBUILDING} {$ENDIF IMPLICITBUILDING}
{$DESCRIPTION 'VirtualTreeView Controls'} {$DESCRIPTION 'VirtualTreeView Controls'}
{$DESIGNONLY} {$DESIGNONLY}

28
components/virtualtreeview/packages/Delphi10.3/VirtualTreesD.dproj vendored
View File

@ -3,7 +3,7 @@
<ProjectGuid>{A34BA07B-19B6-4C21-9DEE-65FCA52D00AB}</ProjectGuid> <ProjectGuid>{A34BA07B-19B6-4C21-9DEE-65FCA52D00AB}</ProjectGuid>
<MainSource>VirtualTreesD.dpk</MainSource> <MainSource>VirtualTreesD.dpk</MainSource>
<Base>True</Base> <Base>True</Base>
<Config Condition="'$(Config)'==''">Debug</Config> <Config Condition="'$(Config)'==''">Release</Config>
<AppType>Package</AppType> <AppType>Package</AppType>
<FrameworkType>VCL</FrameworkType> <FrameworkType>VCL</FrameworkType>
<DCC_DCCCompiler>DCC32</DCC_DCCCompiler> <DCC_DCCCompiler>DCC32</DCC_DCCCompiler>
@ -19,11 +19,6 @@
<CfgParent>Base</CfgParent> <CfgParent>Base</CfgParent>
<Base>true</Base> <Base>true</Base>
</PropertyGroup> </PropertyGroup>
<PropertyGroup Condition="('$(Platform)'=='Win64' and '$(Base)'=='true') or '$(Base_Win64)'!=''">
<Base_Win64>true</Base_Win64>
<CfgParent>Base</CfgParent>
<Base>true</Base>
</PropertyGroup>
<PropertyGroup Condition="'$(Config)'=='Release' or '$(Cfg_1)'!=''"> <PropertyGroup Condition="'$(Config)'=='Release' or '$(Cfg_1)'!=''">
<Cfg_1>true</Cfg_1> <Cfg_1>true</Cfg_1>
<CfgParent>Base</CfgParent> <CfgParent>Base</CfgParent>
@ -35,6 +30,8 @@
<Base>true</Base> <Base>true</Base>
</PropertyGroup> </PropertyGroup>
<PropertyGroup Condition="'$(Base)'!=''"> <PropertyGroup Condition="'$(Base)'!=''">
<SanitizedProjectName>VirtualTreesD</SanitizedProjectName>
<DCC_HppOutput>..\..\Source</DCC_HppOutput>
<DCC_DcuOutput>..\..\build\$(Platform)</DCC_DcuOutput> <DCC_DcuOutput>..\..\build\$(Platform)</DCC_DcuOutput>
<DCC_OutputNeverBuildDcps>true</DCC_OutputNeverBuildDcps> <DCC_OutputNeverBuildDcps>true</DCC_OutputNeverBuildDcps>
<DCC_Description>VirtualTreeView Controls</DCC_Description> <DCC_Description>VirtualTreeView Controls</DCC_Description>
@ -52,20 +49,14 @@
<DCC_N>false</DCC_N> <DCC_N>false</DCC_N>
<DCC_F>false</DCC_F> <DCC_F>false</DCC_F>
<DCC_K>false</DCC_K> <DCC_K>false</DCC_K>
<SanitizedProjectName>VirtualTreesD</SanitizedProjectName>
</PropertyGroup> </PropertyGroup>
<PropertyGroup Condition="'$(Base_Win32)'!=''"> <PropertyGroup Condition="'$(Base_Win32)'!=''">
<Debugger_HostApplication>$(BDS)\BIN\Bds.exe</Debugger_HostApplication>
<DCC_Namespace>Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace)</DCC_Namespace> <DCC_Namespace>Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace)</DCC_Namespace>
<DCC_UsePackage>vcl;VirtualTreesD;VirtualTreesR;$(DCC_UsePackage)</DCC_UsePackage> <DCC_UsePackage>vcl;VirtualTreesR;$(DCC_UsePackage)</DCC_UsePackage>
</PropertyGroup>
<PropertyGroup Condition="'$(Base_Win64)'!=''">
<DCC_UsePackage>vcl;$(DCC_UsePackage)</DCC_UsePackage>
</PropertyGroup> </PropertyGroup>
<PropertyGroup Condition="'$(Cfg_1)'!=''"> <PropertyGroup Condition="'$(Cfg_1)'!=''">
<DCC_LocalDebugSymbols>false</DCC_LocalDebugSymbols>
<DCC_Define>RELEASE;$(DCC_Define)</DCC_Define> <DCC_Define>RELEASE;$(DCC_Define)</DCC_Define>
<DCC_SymbolReferenceInfo>0</DCC_SymbolReferenceInfo>
<DCC_DebugInformation>0</DCC_DebugInformation>
</PropertyGroup> </PropertyGroup>
<PropertyGroup Condition="'$(Cfg_2)'!=''"> <PropertyGroup Condition="'$(Cfg_2)'!=''">
<DCC_Define>DEBUG;$(DCC_Define)</DCC_Define> <DCC_Define>DEBUG;$(DCC_Define)</DCC_Define>
@ -76,7 +67,7 @@
<DelphiCompile Include="$(MainSource)"> <DelphiCompile Include="$(MainSource)">
<MainSource>MainSource</MainSource> <MainSource>MainSource</MainSource>
</DelphiCompile> </DelphiCompile>
<DCCReference Include="..\..\Resources\VirtualTreesD.dcr"/> <DCCReference Include="..\..\Design\VirtualTrees.dcr"/>
<DCCReference Include="DesignIDE.dcp"/> <DCCReference Include="DesignIDE.dcp"/>
<DCCReference Include="VirtualTreesR.dcp"/> <DCCReference Include="VirtualTreesR.dcp"/>
<DCCReference Include="..\..\Design\VirtualTreesReg.pas"/> <DCCReference Include="..\..\Design\VirtualTreesReg.pas"/>
@ -127,14 +118,11 @@
<VersionInfoKeys Name="ProductVersion">1.0.0.0</VersionInfoKeys> <VersionInfoKeys Name="ProductVersion">1.0.0.0</VersionInfoKeys>
<VersionInfoKeys Name="Comments"/> <VersionInfoKeys Name="Comments"/>
</VersionInfoKeys> </VersionInfoKeys>
<Excluded_Packages> <Excluded_Packages />
<Excluded_Packages Name="$(BDSBIN)\dcloffice2k190.bpl">Microsoft Office 2000 Sample Automation Server Wrapper Components</Excluded_Packages>
<Excluded_Packages Name="$(BDSBIN)\dclofficexp190.bpl">Microsoft Office XP Sample Automation Server Wrapper Components</Excluded_Packages>
</Excluded_Packages>
</Delphi.Personality> </Delphi.Personality>
<Platforms> <Platforms>
<Platform value="Win32">True</Platform> <Platform value="Win32">True</Platform>
<Platform value="Win64">False</Platform>
</Platforms> </Platforms>
</BorlandProject> </BorlandProject>
<ProjectFileVersion>12</ProjectFileVersion> <ProjectFileVersion>12</ProjectFileVersion>

22
components/virtualtreeview/packages/Delphi10.3/VirtualTreesR.dpk vendored
View File

@ -1,28 +1,29 @@
package VirtualTreesR; package VirtualTreesR;
{$R *.res}
{$IFDEF IMPLICITBUILDING This IFDEF should not be used by users} {$IFDEF IMPLICITBUILDING This IFDEF should not be used by users}
{$ALIGN 8} {$ALIGN 8}
{$ASSERTIONS ON} {$ASSERTIONS ON}
{$BOOLEVAL OFF} {$BOOLEVAL OFF}
{$DEBUGINFO ON} {$DEBUGINFO OFF}
{$EXTENDEDSYNTAX ON} {$EXTENDEDSYNTAX ON}
{$IMPORTEDDATA ON} {$IMPORTEDDATA ON}
{$IOCHECKS ON} {$IOCHECKS ON}
{$LOCALSYMBOLS ON} {$LOCALSYMBOLS ON}
{$LONGSTRINGS ON} {$LONGSTRINGS ON}
{$OPENSTRINGS ON} {$OPENSTRINGS ON}
{$OPTIMIZATION OFF} {$OPTIMIZATION ON}
{$OVERFLOWCHECKS OFF} {$OVERFLOWCHECKS OFF}
{$RANGECHECKS OFF} {$RANGECHECKS OFF}
{$REFERENCEINFO ON} {$REFERENCEINFO OFF}
{$SAFEDIVIDE OFF} {$SAFEDIVIDE OFF}
{$STACKFRAMES ON} {$STACKFRAMES OFF}
{$TYPEDADDRESS OFF} {$TYPEDADDRESS OFF}
{$VARSTRINGCHECKS ON} {$VARSTRINGCHECKS ON}
{$WRITEABLECONST OFF} {$WRITEABLECONST OFF}
{$MINENUMSIZE 1} {$MINENUMSIZE 1}
{$IMAGEBASE $400000} {$IMAGEBASE $400000}
{$DEFINE DEBUG} {$DEFINE RELEASE}
{$ENDIF IMPLICITBUILDING} {$ENDIF IMPLICITBUILDING}
{$RUNONLY} {$RUNONLY}
{$IMPLICITBUILD OFF} {$IMPLICITBUILD OFF}
@ -33,16 +34,17 @@ requires
contains contains
VirtualTrees in '..\..\Source\VirtualTrees.pas', VirtualTrees in '..\..\Source\VirtualTrees.pas',
VTHeaderPopup in '..\..\Source\VTHeaderPopup.pas', VirtualTrees.HeaderPopup in '..\..\Source\VirtualTrees.HeaderPopup.pas',
VTAccessibilityFactory in '..\..\Source\VTAccessibilityFactory.pas', VirtualTrees.AccessibilityFactory in '..\..\Source\VirtualTrees.AccessibilityFactory.pas',
VTAccessibility in '..\..\Source\VTAccessibility.pas', VirtualTrees.Accessibility in '..\..\Source\VirtualTrees.Accessibility.pas',
VirtualTrees.StyleHooks in '..\..\Source\VirtualTrees.StyleHooks.pas', VirtualTrees.StyleHooks in '..\..\Source\VirtualTrees.StyleHooks.pas',
VirtualTrees.Classes in '..\..\Source\VirtualTrees.Classes.pas', VirtualTrees.Classes in '..\..\Source\VirtualTrees.Classes.pas',
VirtualTrees.WorkerThread in '..\..\Source\VirtualTrees.WorkerThread.pas', VirtualTrees.WorkerThread in '..\..\Source\VirtualTrees.WorkerThread.pas',
VirtualTrees.ClipBoard in '..\..\Source\VirtualTrees.ClipBoard.pas', VirtualTrees.ClipBoard in '..\..\Source\VirtualTrees.ClipBoard.pas',
VirtualTrees.Utils in '..\..\Source\VirtualTrees.Utils.pas', VirtualTrees.Actions in '..\..\Source\VirtualTrees.Actions.pas',
VirtualTrees.Export in '..\..\Source\VirtualTrees.Export.pas', VirtualTrees.Export in '..\..\Source\VirtualTrees.Export.pas',
VirtualTrees.Actions in '..\..\Source\VirtualTrees.Actions.pas'; VirtualTrees.Utils in '..\..\Source\VirtualTrees.Utils.pas';
end. end.

41
components/virtualtreeview/packages/Delphi10.3/VirtualTreesR.dproj vendored
View File

@ -3,7 +3,7 @@
<ProjectGuid>{B62F3689-96E1-47D5-9FB2-2A2718281FDB}</ProjectGuid> <ProjectGuid>{B62F3689-96E1-47D5-9FB2-2A2718281FDB}</ProjectGuid>
<MainSource>VirtualTreesR.dpk</MainSource> <MainSource>VirtualTreesR.dpk</MainSource>
<Base>True</Base> <Base>True</Base>
<Config Condition="'$(Config)'==''">Debug</Config> <Config Condition="'$(Config)'==''">Release</Config>
<AppType>Package</AppType> <AppType>Package</AppType>
<FrameworkType>VCL</FrameworkType> <FrameworkType>VCL</FrameworkType>
<DCC_DCCCompiler>DCC32</DCC_DCCCompiler> <DCC_DCCCompiler>DCC32</DCC_DCCCompiler>
@ -19,11 +19,6 @@
<CfgParent>Base</CfgParent> <CfgParent>Base</CfgParent>
<Base>true</Base> <Base>true</Base>
</PropertyGroup> </PropertyGroup>
<PropertyGroup Condition="('$(Platform)'=='Win64' and '$(Base)'=='true') or '$(Base_Win64)'!=''">
<Base_Win64>true</Base_Win64>
<CfgParent>Base</CfgParent>
<Base>true</Base>
</PropertyGroup>
<PropertyGroup Condition="'$(Config)'=='Release' or '$(Cfg_1)'!=''"> <PropertyGroup Condition="'$(Config)'=='Release' or '$(Cfg_1)'!=''">
<Cfg_1>true</Cfg_1> <Cfg_1>true</Cfg_1>
<CfgParent>Base</CfgParent> <CfgParent>Base</CfgParent>
@ -40,14 +35,11 @@
<Cfg_2>true</Cfg_2> <Cfg_2>true</Cfg_2>
<Base>true</Base> <Base>true</Base>
</PropertyGroup> </PropertyGroup>
<PropertyGroup Condition="('$(Platform)'=='Win64' and '$(Cfg_2)'=='true') or '$(Cfg_2_Win64)'!=''">
<Cfg_2_Win64>true</Cfg_2_Win64>
<CfgParent>Cfg_2</CfgParent>
<Cfg_2>true</Cfg_2>
<Base>true</Base>
</PropertyGroup>
<PropertyGroup Condition="'$(Base)'!=''"> <PropertyGroup Condition="'$(Base)'!=''">
<DCC_CBuilderOutput>All</DCC_CBuilderOutput>
<SanitizedProjectName>VirtualTreesR</SanitizedProjectName>
<DCC_DcuOutput>..\..\build\$(Platform)</DCC_DcuOutput> <DCC_DcuOutput>..\..\build\$(Platform)</DCC_DcuOutput>
<DCC_HppOutput>..\..\Source</DCC_HppOutput>
<DCC_OutputNeverBuildDcps>true</DCC_OutputNeverBuildDcps> <DCC_OutputNeverBuildDcps>true</DCC_OutputNeverBuildDcps>
<RuntimeOnlyPackage>true</RuntimeOnlyPackage> <RuntimeOnlyPackage>true</RuntimeOnlyPackage>
<DCC_UnitSearchPath>..\..\source;$(DCC_UnitSearchPath)</DCC_UnitSearchPath> <DCC_UnitSearchPath>..\..\source;$(DCC_UnitSearchPath)</DCC_UnitSearchPath>
@ -62,17 +54,10 @@
<DCC_N>false</DCC_N> <DCC_N>false</DCC_N>
<DCC_F>false</DCC_F> <DCC_F>false</DCC_F>
<DCC_K>false</DCC_K> <DCC_K>false</DCC_K>
<SanitizedProjectName>VirtualTreesR</SanitizedProjectName>
</PropertyGroup> </PropertyGroup>
<PropertyGroup Condition="'$(Base_Win32)'!=''"> <PropertyGroup Condition="'$(Base_Win32)'!=''">
<DCC_Namespace>Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace)</DCC_Namespace> <DCC_Namespace>Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace)</DCC_Namespace>
</PropertyGroup> </PropertyGroup>
<PropertyGroup Condition="'$(Base_Win64)'!=''">
<DCC_DcuOutput>$(BDSCOMMONDIR)\DCP\$(Platform)</DCC_DcuOutput>
<DCC_Namespace>Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;$(DCC_Namespace)</DCC_Namespace>
<VerInfo_IncludeVerInfo>true</VerInfo_IncludeVerInfo>
<VerInfo_Locale>1033</VerInfo_Locale>
</PropertyGroup>
<PropertyGroup Condition="'$(Cfg_1)'!=''"> <PropertyGroup Condition="'$(Cfg_1)'!=''">
<DCC_LocalDebugSymbols>false</DCC_LocalDebugSymbols> <DCC_LocalDebugSymbols>false</DCC_LocalDebugSymbols>
<DCC_Define>RELEASE;$(DCC_Define)</DCC_Define> <DCC_Define>RELEASE;$(DCC_Define)</DCC_Define>
@ -87,9 +72,6 @@
<PropertyGroup Condition="'$(Cfg_2_Win32)'!=''"> <PropertyGroup Condition="'$(Cfg_2_Win32)'!=''">
<DCC_OutputNeverBuildDcps>true</DCC_OutputNeverBuildDcps> <DCC_OutputNeverBuildDcps>true</DCC_OutputNeverBuildDcps>
</PropertyGroup> </PropertyGroup>
<PropertyGroup Condition="'$(Cfg_2_Win64)'!=''">
<DCC_RemoteDebug>true</DCC_RemoteDebug>
</PropertyGroup>
<ItemGroup> <ItemGroup>
<DelphiCompile Include="$(MainSource)"> <DelphiCompile Include="$(MainSource)">
<MainSource>MainSource</MainSource> <MainSource>MainSource</MainSource>
@ -97,16 +79,16 @@
<DCCReference Include="vcl.dcp"/> <DCCReference Include="vcl.dcp"/>
<DCCReference Include="vclx.dcp"/> <DCCReference Include="vclx.dcp"/>
<DCCReference Include="..\..\Source\VirtualTrees.pas"/> <DCCReference Include="..\..\Source\VirtualTrees.pas"/>
<DCCReference Include="..\..\Source\VTHeaderPopup.pas"/> <DCCReference Include="..\..\Source\VirtualTrees.HeaderPopup.pas"/>
<DCCReference Include="..\..\Source\VTAccessibilityFactory.pas"/> <DCCReference Include="..\..\Source\VirtualTrees.AccessibilityFactory.pas"/>
<DCCReference Include="..\..\Source\VTAccessibility.pas"/> <DCCReference Include="..\..\Source\VirtualTrees.Accessibility.pas"/>
<DCCReference Include="..\..\Source\VirtualTrees.StyleHooks.pas"/> <DCCReference Include="..\..\Source\VirtualTrees.StyleHooks.pas"/>
<DCCReference Include="..\..\Source\VirtualTrees.Classes.pas"/> <DCCReference Include="..\..\Source\VirtualTrees.Classes.pas"/>
<DCCReference Include="..\..\Source\VirtualTrees.WorkerThread.pas"/> <DCCReference Include="..\..\Source\VirtualTrees.WorkerThread.pas"/>
<DCCReference Include="..\..\Source\VirtualTrees.ClipBoard.pas"/> <DCCReference Include="..\..\Source\VirtualTrees.ClipBoard.pas"/>
<DCCReference Include="..\..\Source\VirtualTrees.Utils.pas"/>
<DCCReference Include="..\..\Source\VirtualTrees.Export.pas"/>
<DCCReference Include="..\..\Source\VirtualTrees.Actions.pas"/> <DCCReference Include="..\..\Source\VirtualTrees.Actions.pas"/>
<DCCReference Include="..\..\Source\VirtualTrees.Export.pas"/>
<DCCReference Include="..\..\Source\VirtualTrees.Utils.pas"/>
<BuildConfiguration Include="Debug"> <BuildConfiguration Include="Debug">
<Key>Cfg_2</Key> <Key>Cfg_2</Key>
<CfgParent>Base</CfgParent> <CfgParent>Base</CfgParent>
@ -154,10 +136,7 @@
<VersionInfoKeys Name="ProductVersion">1.0.0.0</VersionInfoKeys> <VersionInfoKeys Name="ProductVersion">1.0.0.0</VersionInfoKeys>
<VersionInfoKeys Name="Comments"/> <VersionInfoKeys Name="Comments"/>
</VersionInfoKeys> </VersionInfoKeys>
<Excluded_Packages> <Excluded_Packages />
<Excluded_Packages Name="$(BDSBIN)\dcloffice2k190.bpl">Microsoft Office 2000 Sample Automation Server Wrapper Components</Excluded_Packages>
<Excluded_Packages Name="$(BDSBIN)\dclofficexp190.bpl">Microsoft Office XP Sample Automation Server Wrapper Components</Excluded_Packages>
</Excluded_Packages>
</Delphi.Personality> </Delphi.Personality>
<Platforms> <Platforms>
<Platform value="Win32">True</Platform> <Platform value="Win32">True</Platform>

3
components/virtualtreeview/packages/delphiXE5/VirtualTreesD.dproj
View File

@ -7,7 +7,7 @@
<AppType>Package</AppType> <AppType>Package</AppType>
<FrameworkType>VCL</FrameworkType> <FrameworkType>VCL</FrameworkType>
<DCC_DCCCompiler>DCC32</DCC_DCCCompiler> <DCC_DCCCompiler>DCC32</DCC_DCCCompiler>
<ProjectVersion>15.1</ProjectVersion> <ProjectVersion>18.4</ProjectVersion>
<Platform Condition="'$(Platform)'==''">Win32</Platform> <Platform Condition="'$(Platform)'==''">Win32</Platform>
<TargetedPlatforms>1</TargetedPlatforms> <TargetedPlatforms>1</TargetedPlatforms>
</PropertyGroup> </PropertyGroup>
@ -52,6 +52,7 @@
<DCC_N>false</DCC_N> <DCC_N>false</DCC_N>
<DCC_F>false</DCC_F> <DCC_F>false</DCC_F>
<DCC_K>false</DCC_K> <DCC_K>false</DCC_K>
<SanitizedProjectName>VirtualTreesD</SanitizedProjectName>
</PropertyGroup> </PropertyGroup>
<PropertyGroup Condition="'$(Base_Win32)'!=''"> <PropertyGroup Condition="'$(Base_Win32)'!=''">
<DCC_Namespace>Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace)</DCC_Namespace> <DCC_Namespace>Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace)</DCC_Namespace>

5
components/virtualtreeview/packages/delphiXE5/VirtualTreesR.dproj
View File

@ -7,7 +7,7 @@
<AppType>Package</AppType> <AppType>Package</AppType>
<FrameworkType>VCL</FrameworkType> <FrameworkType>VCL</FrameworkType>
<DCC_DCCCompiler>DCC32</DCC_DCCCompiler> <DCC_DCCCompiler>DCC32</DCC_DCCCompiler>
<ProjectVersion>15.1</ProjectVersion> <ProjectVersion>18.4</ProjectVersion>
<Platform Condition="'$(Platform)'==''">Win32</Platform> <Platform Condition="'$(Platform)'==''">Win32</Platform>
<TargetedPlatforms>3</TargetedPlatforms> <TargetedPlatforms>3</TargetedPlatforms>
</PropertyGroup> </PropertyGroup>
@ -62,6 +62,7 @@
<DCC_N>false</DCC_N> <DCC_N>false</DCC_N>
<DCC_F>false</DCC_F> <DCC_F>false</DCC_F>
<DCC_K>false</DCC_K> <DCC_K>false</DCC_K>
<SanitizedProjectName>VirtualTreesR</SanitizedProjectName>
</PropertyGroup> </PropertyGroup>
<PropertyGroup Condition="'$(Base_Win32)'!=''"> <PropertyGroup Condition="'$(Base_Win32)'!=''">
<DCC_Namespace>Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace)</DCC_Namespace> <DCC_Namespace>Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace)</DCC_Namespace>
@ -104,8 +105,8 @@
<DCCReference Include="..\..\Source\VirtualTrees.WorkerThread.pas"/> <DCCReference Include="..\..\Source\VirtualTrees.WorkerThread.pas"/>
<DCCReference Include="..\..\Source\VirtualTrees.ClipBoard.pas"/> <DCCReference Include="..\..\Source\VirtualTrees.ClipBoard.pas"/>
<DCCReference Include="..\..\Source\VirtualTrees.Utils.pas"/> <DCCReference Include="..\..\Source\VirtualTrees.Utils.pas"/>
<DCCReference Include="..\..\Source\VirtualTrees.Actions.pas"/>
<DCCReference Include="..\..\Source\VirtualTrees.Export.pas"/> <DCCReference Include="..\..\Source\VirtualTrees.Export.pas"/>
<DCCReference Include="..\..\Source\VirtualTrees.Actions.pas"/>
<BuildConfiguration Include="Debug"> <BuildConfiguration Include="Debug">
<Key>Cfg_2</Key> <Key>Cfg_2</Key>
<CfgParent>Base</CfgParent> <CfgParent>Base</CfgParent>