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

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

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

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

@ -63,18 +63,6 @@ type
property AsString: string read GetAsString;
end;
TCriticalSection = class(TObject)
protected
FSection: TRTLCriticalSection;
public
constructor Create;
destructor Destroy; override;
procedure Enter;
procedure Leave;
end;
implementation
@ -221,40 +209,5 @@ begin
Inc(FPosition);
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.

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

@ -1,392 +1,407 @@
unit VirtualTrees.ClipBoard;
// The contents of this file are subject to the Mozilla Public License
// Version 1.1 (the "License"); you may not use this file except in compliance
// with the License. You may obtain a copy of the License at http://www.mozilla.org/MPL/
//
// Alternatively, you may redistribute this library, use and/or modify it under the terms of the
// GNU Lesser General Public License as published by the Free Software Foundation;
// either version 2.1 of the License, or (at your option) any later version.
// You may obtain a copy of the LGPL at http://www.gnu.org/copyleft/.
//
// Software distributed under the License is distributed on an "AS IS" basis,
// WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for the
// specific language governing rights and limitations under the License.
//
// The original code is VirtualTrees.pas, released September 30, 2000.
//
// The initial developer of the original code is digital publishing AG (Munich, Germany, www.digitalpublishing.de),
// written by Mike Lischke (public@soft-gems.net, www.soft-gems.net).
//
// Portions created by digital publishing AG are Copyright
// (C) 1999-2001 digital publishing AG. All Rights Reserved.
//----------------------------------------------------------------------------------------------------------------------
interface
uses
Winapi.Windows,
Winapi.ActiveX,
System.Classes,
VirtualTrees;
type
TClipboardFormatEntry = record
ID: Word;
Description: string;
end;
var
ClipboardDescriptions: array [1..CF_MAX - 1] of TClipboardFormatEntry = (
(ID: CF_TEXT; Description: 'Plain text'), // Do not localize
(ID: CF_BITMAP; Description: 'Windows bitmap'), // Do not localize
(ID: CF_METAFILEPICT; Description: 'Windows metafile'), // Do not localize
(ID: CF_SYLK; Description: 'Symbolic link'), // Do not localize
(ID: CF_DIF; Description: 'Data interchange format'), // Do not localize
(ID: CF_TIFF; Description: 'Tiff image'), // Do not localize
(ID: CF_OEMTEXT; Description: 'OEM text'), // Do not localize
(ID: CF_DIB; Description: 'DIB image'), // Do not localize
(ID: CF_PALETTE; Description: 'Palette data'), // Do not localize
(ID: CF_PENDATA; Description: 'Pen data'), // Do not localize
(ID: CF_RIFF; Description: 'Riff audio data'), // Do not localize
(ID: CF_WAVE; Description: 'Wav audio data'), // Do not localize
(ID: CF_UNICODETEXT; Description: 'Unicode text'), // Do not localize
(ID: CF_ENHMETAFILE; Description: 'Enhanced metafile image'), // Do not localize
(ID: CF_HDROP; Description: 'File name(s)'), // Do not localize
(ID: CF_LOCALE; Description: 'Locale descriptor'), // Do not localize
(ID: CF_DIBV5; Description: 'DIB image V5') // Do not localize
);
// OLE Clipboard and drag'n drop helper
procedure EnumerateVTClipboardFormats(TreeClass: TVirtualTreeClass; const List: TStrings); overload;
procedure EnumerateVTClipboardFormats(TreeClass: TVirtualTreeClass; var Formats: TFormatEtcArray); overload;
function GetVTClipboardFormatDescription(AFormat: Word): string;
procedure RegisterVTClipboardFormat(AFormat: Word; TreeClass: TVirtualTreeClass; Priority: Cardinal); overload;
function RegisterVTClipboardFormat(const Description: string; TreeClass: TVirtualTreeClass; Priority: Cardinal;
tymed: Integer = TYMED_HGLOBAL; ptd: PDVTargetDevice = nil;
dwAspect: Integer = DVASPECT_CONTENT; lindex: Integer = -1): Word; overload;
//----------------- TClipboardFormats ----------------------------------------------------------------------------------
type
PClipboardFormatListEntry = ^TClipboardFormatListEntry;
TClipboardFormatListEntry = record
Description: string; // The string used to register the format with Winapi.Windows.
TreeClass: TVirtualTreeClass; // The tree class which supports rendering this format.
Priority: Cardinal; // Number which determines the order of formats used in IDataObject.
FormatEtc: TFormatEtc; // The definition of the format in the IDataObject.
end;
TClipboardFormatList = class
private
class var
FList : TList;
protected
class procedure Sort;
public
class procedure Add(const FormatString: string; AClass: TVirtualTreeClass; Priority: Cardinal; AFormatEtc: TFormatEtc);
class procedure Clear;
class procedure EnumerateFormats(TreeClass: TVirtualTreeClass; var Formats: TFormatEtcArray; const AllowedFormats: TClipboardFormats = nil); overload;
class procedure EnumerateFormats(TreeClass: TVirtualTreeClass; const Formats: TStrings); overload;
class function FindFormat(const FormatString: string): PClipboardFormatListEntry; overload;
class function FindFormat(const FormatString: string; var Fmt: Word): TVirtualTreeClass; overload;
class function FindFormat(Fmt: Word; var Description: string): TVirtualTreeClass; overload;
end;
implementation
uses
System.SysUtils;
procedure EnumerateVTClipboardFormats(TreeClass: TVirtualTreeClass; const List: TStrings);
begin
TClipboardFormatList.EnumerateFormats(TreeClass, List);
end;
//----------------------------------------------------------------------------------------------------------------------
procedure EnumerateVTClipboardFormats(TreeClass: TVirtualTreeClass; var Formats: TFormatEtcArray);
begin
TClipboardFormatList.EnumerateFormats(TreeClass, Formats);
end;
//----------------------------------------------------------------------------------------------------------------------
function GetVTClipboardFormatDescription(AFormat: Word): string;
begin
if TClipboardFormatList.FindFormat(AFormat, Result) = nil then
Result := '';
end;
//----------------------------------------------------------------------------------------------------------------------
procedure RegisterVTClipboardFormat(AFormat: Word; TreeClass: TVirtualTreeClass; Priority: Cardinal);
// Registers the given clipboard format for the given TreeClass.
var
I: Integer;
Buffer: array[0..2048] of Char;
FormatEtc: TFormatEtc;
begin
// Assumes a HGlobal format.
FormatEtc.cfFormat := AFormat;
FormatEtc.ptd := nil;
FormatEtc.dwAspect := DVASPECT_CONTENT;
FormatEtc.lindex := -1;
FormatEtc.tymed := TYMED_HGLOBAL;
// Determine description string of the given format. For predefined formats we need the lookup table because they
// don't have a description string. For registered formats the description string is the string which was used
// to register them.
if AFormat < CF_MAX then
begin
for I := 1 to High(ClipboardDescriptions) do
if ClipboardDescriptions[I].ID = AFormat then
begin
TClipboardFormatList.Add(ClipboardDescriptions[I].Description, TreeClass, Priority, FormatEtc);
Break;
end;
end
else
begin
GetClipboardFormatName(AFormat, Buffer, Length(Buffer));
TClipboardFormatList.Add(Buffer, TreeClass, Priority, FormatEtc);
end;
end;
//----------------------------------------------------------------------------------------------------------------------
function RegisterVTClipboardFormat(const Description: string; TreeClass: TVirtualTreeClass; Priority: Cardinal;
tymed: Integer = TYMED_HGLOBAL; ptd: PDVTargetDevice = nil; dwAspect: Integer = DVASPECT_CONTENT;
lindex: Integer = -1): Word;
// Alternative method to register a certain clipboard format for a given tree class. Registration with the
// clipboard is done here too and the assigned ID returned by the function.
// tymed may contain or'ed TYMED constants which allows to register several storage formats for one clipboard format.
var
FormatEtc: TFormatEtc;
begin
Result := RegisterClipboardFormat(PChar(Description));
FormatEtc.cfFormat := Result;
FormatEtc.ptd := ptd;
FormatEtc.dwAspect := dwAspect;
FormatEtc.lindex := lindex;
FormatEtc.tymed := tymed;
TClipboardFormatList.Add(Description, TreeClass, Priority, FormatEtc);
end;
//----------------------------------------------------------------------------------------------------------------------
class procedure TClipboardFormatList.Sort;
// Sorts all entry for priority (increasing priority value).
//--------------- local function --------------------------------------------
procedure QuickSort(L, R: Integer);
var
I, J: Integer;
P, T: PClipboardFormatListEntry;
begin
repeat
I := L;
J := R;
P := FList[(L + R) shr 1];
repeat
while PClipboardFormatListEntry(FList[I]).Priority < P.Priority do
Inc(I);
while PClipboardFormatListEntry(FList[J]).Priority > P.Priority do
Dec(J);
if I <= J then
begin
T := FList[I];
FList[I] := FList[J];
FList[J] := T;
Inc(I);
Dec(J);
end;
until I > J;
if L < J then
QuickSort(L, J);
L := I;
until I >= R;
end;
//--------------- end local function ----------------------------------------
begin
if FList.Count > 1 then
QuickSort(0, FList.Count - 1);
end;
//----------------------------------------------------------------------------------------------------------------------
class procedure TClipboardFormatList.Add(const FormatString: string; AClass: TVirtualTreeClass; Priority: Cardinal; AFormatEtc: TFormatEtc);
// Adds the given data to the internal list. The priority value is used to sort formats for importance. Larger priority
// values mean less priority.
var
Entry: PClipboardFormatListEntry;
begin
New(Entry);
Entry.Description := FormatString;
Entry.TreeClass := AClass;
Entry.Priority := Priority;
Entry.FormatEtc := AFormatEtc;
FList.Add(Entry);
Sort;
end;
//----------------------------------------------------------------------------------------------------------------------
class procedure TClipboardFormatList.Clear;
var
I: Integer;
begin
for I := 0 to FList.Count - 1 do
Dispose(PClipboardFormatListEntry(FList[I]));
FList.Clear;
end;
//----------------------------------------------------------------------------------------------------------------------
class procedure TClipboardFormatList.EnumerateFormats(TreeClass: TVirtualTreeClass; var Formats: TFormatEtcArray; const AllowedFormats: TClipboardFormats = nil);
// Returns a list of format records for the given class. If assigned the AllowedFormats is used to limit the
// enumerated formats to those described in the list.
var
I, Count: Integer;
Entry: PClipboardFormatListEntry;
begin
SetLength(Formats, FList.Count);
Count := 0;
for I := 0 to FList.Count - 1 do
begin
Entry := FList[I];
// Does the tree class support this clipboard format?
if TreeClass.InheritsFrom(Entry.TreeClass) then
begin
// Is this format allowed to be included?
if (AllowedFormats = nil) or (AllowedFormats.IndexOf(Entry.Description) > -1) then
begin
// The list could change before we use the FormatEtc so it is best not to pass a pointer to the true FormatEtc
// structure. Instead make a copy and send that.
Formats[Count] := Entry.FormatEtc;
Inc(Count);
end;
end;
end;
SetLength(Formats, Count);
end;
//----------------------------------------------------------------------------------------------------------------------
class procedure TClipboardFormatList.EnumerateFormats(TreeClass: TVirtualTreeClass; const Formats: TStrings);
// Returns a list of format descriptions for the given class.
var
I: Integer;
Entry: PClipboardFormatListEntry;
begin
for I := 0 to FList.Count - 1 do
begin
Entry := FList[I];
if TreeClass.InheritsFrom(Entry.TreeClass) then
Formats.Add(Entry.Description);
end;
end;
//----------------------------------------------------------------------------------------------------------------------
class function TClipboardFormatList.FindFormat(const FormatString: string): PClipboardFormatListEntry;
var
I: Integer;
Entry: PClipboardFormatListEntry;
begin
Result := nil;
for I := FList.Count - 1 downto 0 do
begin
Entry := FList[I];
if CompareText(Entry.Description, FormatString) = 0 then
begin
Result := Entry;
Break;
end;
end;
end;
//----------------------------------------------------------------------------------------------------------------------
class function TClipboardFormatList.FindFormat(const FormatString: string; var Fmt: Word): TVirtualTreeClass;
var
I: Integer;
Entry: PClipboardFormatListEntry;
begin
Result := nil;
for I := FList.Count - 1 downto 0 do
begin
Entry := FList[I];
if CompareText(Entry.Description, FormatString) = 0 then
begin
Result := Entry.TreeClass;
Fmt := Entry.FormatEtc.cfFormat;
Break;
end;
end;
end;
//----------------------------------------------------------------------------------------------------------------------
class function TClipboardFormatList.FindFormat(Fmt: Word; var Description: string): TVirtualTreeClass;
var
I: Integer;
Entry: PClipboardFormatListEntry;
begin
Result := nil;
for I := FList.Count - 1 downto 0 do
begin
Entry := FList[I];
if Entry.FormatEtc.cfFormat = Fmt then
begin
Result := Entry.TreeClass;
Description := Entry.Description;
Break;
end;
end;
end;
//Note - not using class constructors as they are not supported on C++ Builder.
initialization
TClipboardFormatList.FList := TList.Create;
finalization
TClipboardFormatList.Clear;
TClipboardFormatList.FList.Free;
end.
unit VirtualTrees.ClipBoard;
// The contents of this file are subject to the Mozilla Public License
// Version 1.1 (the "License"); you may not use this file except in compliance
// with the License. You may obtain a copy of the License at http://www.mozilla.org/MPL/
//
// Alternatively, you may redistribute this library, use and/or modify it under the terms of the
// GNU Lesser General Public License as published by the Free Software Foundation;
// either version 2.1 of the License, or (at your option) any later version.
// You may obtain a copy of the LGPL at http://www.gnu.org/copyleft/.
//
// Software distributed under the License is distributed on an "AS IS" basis,
// WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for the
// specific language governing rights and limitations under the License.
//
// The original code is VirtualTrees.pas, released September 30, 2000.
//
// The initial developer of the original code is digital publishing AG (Munich, Germany, www.digitalpublishing.de),
// written by Mike Lischke (public@soft-gems.net, www.soft-gems.net).
//
// Portions created by digital publishing AG are Copyright
// (C) 1999-2001 digital publishing AG. All Rights Reserved.
//----------------------------------------------------------------------------------------------------------------------
interface
{$WARN UNSAFE_TYPE OFF}
{$WARN UNSAFE_CAST OFF}
uses
Winapi.Windows,
Winapi.ActiveX,
System.Classes,
VirtualTrees;
type
TClipboardFormatEntry = record
ID: Word;
Description: string;
end;
var
ClipboardDescriptions: array [1..CF_MAX - 1] of TClipboardFormatEntry = (
(ID: CF_TEXT; Description: 'Plain text'), // Do not localize
(ID: CF_BITMAP; Description: 'Windows bitmap'), // Do not localize
(ID: CF_METAFILEPICT; Description: 'Windows metafile'), // Do not localize
(ID: CF_SYLK; Description: 'Symbolic link'), // Do not localize
(ID: CF_DIF; Description: 'Data interchange format'), // Do not localize
(ID: CF_TIFF; Description: 'Tiff image'), // Do not localize
(ID: CF_OEMTEXT; Description: 'OEM text'), // Do not localize
(ID: CF_DIB; Description: 'DIB image'), // Do not localize
(ID: CF_PALETTE; Description: 'Palette data'), // Do not localize
(ID: CF_PENDATA; Description: 'Pen data'), // Do not localize
(ID: CF_RIFF; Description: 'Riff audio data'), // Do not localize
(ID: CF_WAVE; Description: 'Wav audio data'), // Do not localize
(ID: CF_UNICODETEXT; Description: 'Unicode text'), // Do not localize
(ID: CF_ENHMETAFILE; Description: 'Enhanced metafile image'), // Do not localize
(ID: CF_HDROP; Description: 'File name(s)'), // Do not localize
(ID: CF_LOCALE; Description: 'Locale descriptor'), // Do not localize
(ID: CF_DIBV5; Description: 'DIB image V5') // Do not localize
);
// OLE Clipboard and drag'n drop helper
procedure EnumerateVTClipboardFormats(TreeClass: TVirtualTreeClass; const List: TStrings); overload;
procedure EnumerateVTClipboardFormats(TreeClass: TVirtualTreeClass; var Formats: TFormatEtcArray); overload;
function GetVTClipboardFormatDescription(AFormat: Word): string;
procedure RegisterVTClipboardFormat(AFormat: Word; TreeClass: TVirtualTreeClass; Priority: Cardinal); overload;
function RegisterVTClipboardFormat(const Description: string; TreeClass: TVirtualTreeClass; Priority: Cardinal;
tymed: Integer = TYMED_HGLOBAL; ptd: PDVTargetDevice = nil;
dwAspect: Integer = DVASPECT_CONTENT; lindex: Integer = -1): Word; overload;
//----------------- TClipboardFormats ----------------------------------------------------------------------------------
type
TClipboardFormatListEntry = class
public
Description: string; // The string used to register the format with Winapi.Windows.
TreeClass: TVirtualTreeClass; // The tree class which supports rendering this format.
Priority: Cardinal; // Number which determines the order of formats used in IDataObject.
FormatEtc: TFormatEtc; // The definition of the format in the IDataObject.
end;
TClipboardFormatList = class
strict private
class function GetList(): TList; static;
class property List: TList read GetList;
protected
class procedure Sort;
public
class procedure Add(const FormatString: string; AClass: TVirtualTreeClass; Priority: Cardinal; AFormatEtc: TFormatEtc);
class procedure Clear;
class procedure EnumerateFormats(TreeClass: TVirtualTreeClass; var Formats: TFormatEtcArray; const AllowedFormats: TClipboardFormats = nil); overload;
class procedure EnumerateFormats(TreeClass: TVirtualTreeClass; const Formats: TStrings); overload;
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;
end;
implementation
uses
System.SysUtils;
var
_List: TList = nil; //Note - not using class constructors as they are not supported on C++ Builder. See also issue #
procedure EnumerateVTClipboardFormats(TreeClass: TVirtualTreeClass; const List: TStrings);
begin
TClipboardFormatList.EnumerateFormats(TreeClass, List);
end;
//----------------------------------------------------------------------------------------------------------------------
procedure EnumerateVTClipboardFormats(TreeClass: TVirtualTreeClass; var Formats: TFormatEtcArray);
begin
TClipboardFormatList.EnumerateFormats(TreeClass, Formats);
end;
//----------------------------------------------------------------------------------------------------------------------
function GetVTClipboardFormatDescription(AFormat: Word): string;
begin
if TClipboardFormatList.FindFormat(AFormat, Result) = nil then
Result := '';
end;
//----------------------------------------------------------------------------------------------------------------------
procedure RegisterVTClipboardFormat(AFormat: Word; TreeClass: TVirtualTreeClass; Priority: Cardinal);
// Registers the given clipboard format for the given TreeClass.
var
I: Integer;
Buffer: array[0..2048] of Char;
FormatEtc: TFormatEtc;
begin
// Assumes a HGlobal format.
FormatEtc.cfFormat := AFormat;
FormatEtc.ptd := nil;
FormatEtc.dwAspect := DVASPECT_CONTENT;
FormatEtc.lindex := -1;
FormatEtc.tymed := TYMED_HGLOBAL;
// Determine description string of the given format. For predefined formats we need the lookup table because they
// don't have a description string. For registered formats the description string is the string which was used
// to register them.
if AFormat < CF_MAX then
begin
for I := 1 to High(ClipboardDescriptions) do
if ClipboardDescriptions[I].ID = AFormat then
begin
TClipboardFormatList.Add(ClipboardDescriptions[I].Description, TreeClass, Priority, FormatEtc);
Break;
end;
end
else
begin
GetClipboardFormatName(AFormat, Buffer, Length(Buffer));
TClipboardFormatList.Add(Buffer, TreeClass, Priority, FormatEtc);
end;
end;
//----------------------------------------------------------------------------------------------------------------------
function RegisterVTClipboardFormat(const Description: string; TreeClass: TVirtualTreeClass; Priority: Cardinal;
tymed: Integer = TYMED_HGLOBAL; ptd: PDVTargetDevice = nil; dwAspect: Integer = DVASPECT_CONTENT;
lindex: Integer = -1): Word;
// Alternative method to register a certain clipboard format for a given tree class. Registration with the
// clipboard is done here too and the assigned ID returned by the function.
// tymed may contain or'ed TYMED constants which allows to register several storage formats for one clipboard format.
var
FormatEtc: TFormatEtc;
begin
Result := RegisterClipboardFormat(PChar(Description));
FormatEtc.cfFormat := Result;
FormatEtc.ptd := ptd;
FormatEtc.dwAspect := dwAspect;
FormatEtc.lindex := lindex;
FormatEtc.tymed := tymed;
TClipboardFormatList.Add(Description, TreeClass, Priority, FormatEtc);
end;
//----------------------------------------------------------------------------------------------------------------------
class procedure TClipboardFormatList.Sort;
// Sorts all entry for priority (increasing priority value).
//--------------- local function --------------------------------------------
procedure QuickSort(L, R: Integer);
var
I, J: Integer;
P, T: TClipboardFormatListEntry;
begin
repeat
I := L;
J := R;
P := _List[(L + R) shr 1];
repeat
while TClipboardFormatListEntry(_List[I]).Priority < P.Priority do
Inc(I);
while TClipboardFormatListEntry(_List[J]).Priority > P.Priority do
Dec(J);
if I <= J then
begin
T := List[I];
_List[I] := _List[J];
_List[J] := T;
Inc(I);
Dec(J);
end;
until I > J;
if L < J then
QuickSort(L, J);
L := I;
until I >= R;
end;
//--------------- end local function ----------------------------------------
begin
if List.Count > 1 then
QuickSort(0, List.Count - 1);
end;
//----------------------------------------------------------------------------------------------------------------------
class procedure TClipboardFormatList.Add(const FormatString: string; AClass: TVirtualTreeClass; Priority: Cardinal; AFormatEtc: TFormatEtc);
// Adds the given data to the internal list. The priority value is used to sort formats for importance. Larger priority
// values mean less priority.
var
Entry: TClipboardFormatListEntry;
begin
Entry := TClipboardFormatListEntry.Create;
Entry.Description := FormatString;
Entry.TreeClass := AClass;
Entry.Priority := Priority;
Entry.FormatEtc := AFormatEtc;
List.Add(Entry);
Sort;
end;
//----------------------------------------------------------------------------------------------------------------------
class procedure TClipboardFormatList.Clear;
var
I: Integer;
begin
if Assigned(_List) then begin
for I := 0 to _List.Count - 1 do
TClipboardFormatListEntry(List[I]).Free;
_List.Clear;
end;
end;
//----------------------------------------------------------------------------------------------------------------------
class procedure TClipboardFormatList.EnumerateFormats(TreeClass: TVirtualTreeClass; var Formats: TFormatEtcArray; const AllowedFormats: TClipboardFormats = nil);
// Returns a list of format records for the given class. If assigned the AllowedFormats is used to limit the
// enumerated formats to those described in the list.
var
I, Count: Integer;
Entry: TClipboardFormatListEntry;
begin
SetLength(Formats, List.Count);
Count := 0;
for I := 0 to List.Count - 1 do
begin
Entry := List[I];
// Does the tree class support this clipboard format?
if TreeClass.InheritsFrom(Entry.TreeClass) then
begin
// Is this format allowed to be included?
if (AllowedFormats = nil) or (AllowedFormats.IndexOf(Entry.Description) > -1) then
begin
// The list could change before we use the FormatEtc so it is best not to pass a pointer to the true FormatEtc
// structure. Instead make a copy and send that.
Formats[Count] := Entry.FormatEtc;
Inc(Count);
end;
end;
end;
SetLength(Formats, Count);
end;
//----------------------------------------------------------------------------------------------------------------------
class procedure TClipboardFormatList.EnumerateFormats(TreeClass: TVirtualTreeClass; const Formats: TStrings);
// Returns a list of format descriptions for the given class.
var
I: Integer;
Entry: TClipboardFormatListEntry;
begin
for I := 0 to List.Count - 1 do
begin
Entry := List[I];
if TreeClass.InheritsFrom(Entry.TreeClass) then
Formats.Add(Entry.Description);
end;
end;
//----------------------------------------------------------------------------------------------------------------------
class function TClipboardFormatList.FindFormat(const FormatString: string): TClipboardFormatListEntry;
var
I: Integer;
Entry: TClipboardFormatListEntry;
begin
Result := nil;
for I := List.Count - 1 downto 0 do
begin
Entry := List[I];
if CompareText(Entry.Description, FormatString) = 0 then
begin
Result := Entry;
Break;
end;
end;
end;
//----------------------------------------------------------------------------------------------------------------------
class function TClipboardFormatList.FindFormat(const FormatString: string; var Fmt: Word): TVirtualTreeClass;
var
I: Integer;
Entry: TClipboardFormatListEntry;
begin
Result := nil;
for I := List.Count - 1 downto 0 do
begin
Entry := List[I];
if CompareText(Entry.Description, FormatString) = 0 then
begin
Result := Entry.TreeClass;
Fmt := Entry.FormatEtc.cfFormat;
Break;
end;
end;
end;
//----------------------------------------------------------------------------------------------------------------------
class function TClipboardFormatList.FindFormat(Fmt: Word; var Description: string): TVirtualTreeClass;
var
I: Integer;
Entry: TClipboardFormatListEntry;
begin
Result := nil;
for I := List.Count - 1 downto 0 do
begin
Entry := List[I];
if Entry.FormatEtc.cfFormat = Fmt then
begin
Result := Entry.TreeClass;
Description := Entry.Description;
Break;
end;
end;
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;
//----------------------------------------------------------------------------------------------------------------------
//
// Version 4.7.0
//
// 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.
//
// September 2004:
// - Bug fix: TVTHeaderPopupMenu.OnMenuItemClick used the wrong Tag member for the event.
//
// Modified 12 Dec 2003 by Ralf Junker <delphi@zeitungsjunge.de>.
// - Added missing default storage specifier for Options property.
// - 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
// tree's header options.
// - Added an additional check for the PopupComponent property before casting
// it hardly to a Virtual Treeview in OnMenuItemClick. See entry 31 Mar 2003.
//
// 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.
//
// Modified 31 Mar 2003 by Mike Lischke <public@soft-gems.net>.
// - 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.
//----------------------------------------------------------------------------------------------------------------------
interface
uses
Vcl.Menus, VirtualTrees;
type
TVTHeaderPopupOption = (
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.
poResizeToFitItem // Adds an item which, if clicks, resizes all columns to fit by callung TVTHeader.AutoFitColumns
);
TVTHeaderPopupOptions = set of TVTHeaderPopupOption;
TAddPopupItemType = (
apNormal,
apDisabled,
apHidden
);
TAddHeaderPopupItemEvent = procedure(const Sender: TBaseVirtualTree; const Column: TColumnIndex;
var Cmd: TAddPopupItemType) of object;
TColumnChangeEvent = procedure(const Sender: TBaseVirtualTree; const Column: TColumnIndex; Visible: Boolean) of object;
TVTMenuItem = TMenuItem;
TVTHeaderPopupMenu = class(TPopupMenu)
strict private
FOptions: TVTHeaderPopupOptions;
FOnAddHeaderPopupItem: TAddHeaderPopupItemEvent;
FOnColumnChange: TColumnChangeEvent;
strict protected
procedure DoAddHeaderPopupItem(const Column: TColumnIndex; out Cmd: TAddPopupItemType); virtual;
procedure DoColumnChange(Column: TColumnIndex; Visible: Boolean); virtual;
procedure OnMenuItemClick(Sender: TObject);
public
procedure Popup(x, y: Integer); override;
published
property Options: TVTHeaderPopupOptions read FOptions write FOptions default [];
property OnAddHeaderPopupItem: TAddHeaderPopupItemEvent read FOnAddHeaderPopupItem write FOnAddHeaderPopupItem;
property OnColumnChange: TColumnChangeEvent read FOnColumnChange write FOnColumnChange;
end;
//----------------------------------------------------------------------------------------------------------------------
implementation
uses
Winapi.Windows, System.Classes;
const
cResizeToFitMenuItemName = 'VT_ResizeToFitMenuItem';
//----------------- TVTHeaderPopupMenu ---------------------------------------------------------------------------------
procedure TVTHeaderPopupMenu.DoAddHeaderPopupItem(const Column: TColumnIndex; out Cmd: TAddPopupItemType);
begin
Cmd := apNormal;
if Assigned(FOnAddHeaderPopupItem) then
FOnAddHeaderPopupItem((PopupComponent as TBaseVirtualTree), Column, Cmd);
end;
//----------------------------------------------------------------------------------------------------------------------
procedure TVTHeaderPopupMenu.DoColumnChange(Column: TColumnIndex; Visible: Boolean);
begin
if Assigned(FOnColumnChange) then
FOnColumnChange((PopupComponent as TBaseVirtualTree), Column, Visible);
end;
//----------------------------------------------------------------------------------------------------------------------
procedure TVTHeaderPopupMenu.OnMenuItemClick(Sender: TObject);
begin
if Assigned(PopupComponent) and (PopupComponent is TBaseVirtualTree) then begin
if TVTMenuItem(Sender).Name = cResizeToFitMenuItemName then begin
TBaseVirtualTree(PopupComponent).Header.AutoFitColumns();
end
else begin
with TVTMenuItem(Sender),
TBaseVirtualTree(PopupComponent).Header.Columns.Items[Tag] do
begin
if Checked then
Options := Options - [coVisible]
else
Options := Options + [coVisible];
DoColumnChange(TVTMenuItem(Sender).Tag, not Checked);
end;
end;//else
end;
end;
//----------------------------------------------------------------------------------------------------------------------
procedure TVTHeaderPopupMenu.Popup(x, y: Integer);
resourcestring
sResizeToFit = '&Resize All Columns To Fit';
var
ColPos: TColumnPosition;
ColIdx: TColumnIndex;
NewMenuItem: TVTMenuItem;
Cmd: TAddPopupItemType;
VisibleCounter: Cardinal;
VisibleItem: TVTMenuItem;
begin
if Assigned(PopupComponent) and (PopupComponent is TBaseVirtualTree) then
begin
// Delete existing menu items.
while Items.Count > 0 do
Items[0].Free;
if poResizeToFitItem in Self.Options then begin
NewMenuItem := NewItem(sResizeToFit, 0, False, True, OnMenuItemClick, 0, cResizeToFitMenuItemName);
Items.Add(NewMenuItem);
Items.Add(NewLine());
end;//poResizeToFitItem
// Add column menu items.
with (PopupComponent as TBaseVirtualTree).Header do
begin
if hoShowImages in Options then
Self.Images := Images
else
// Remove a possible reference to image list of another tree previously assigned.
Self.Images := nil;
VisibleItem := nil;
VisibleCounter := 0;
for ColPos := 0 to Columns.Count - 1 do
begin
if poOriginalOrder in FOptions then
ColIdx := ColPos
else
ColIdx := Columns.ColumnFromPosition(ColPos);
with Columns[ColIdx] do
begin
if coVisible in Options then
Inc(VisibleCounter);
DoAddHeaderPopupItem(ColIdx, Cmd);
if Cmd <> apHidden then
begin
NewMenuItem := TVTMenuItem.Create(Self);
NewMenuItem.Tag := ColIdx;
NewMenuItem.Caption := Text;
NewMenuItem.Hint := Hint;
NewMenuItem.ImageIndex := ImageIndex;
NewMenuItem.Checked := coVisible in Options;
NewMenuItem.OnClick := OnMenuItemClick;
if Cmd = apDisabled then
NewMenuItem.Enabled := False
else
if coVisible in Options then
VisibleItem := NewMenuItem;
Items.Add(NewMenuItem);
end;
end;
end;
// Conditionally disable menu item of last enabled column.
if (VisibleCounter = 1) and (VisibleItem <> nil) and not (poAllowHideAll in FOptions) then
VisibleItem.Enabled := False;
end;
end;
inherited;
end;
//----------------------------------------------------------------------------------------------------------------------
end.
unit VirtualTrees.HeaderPopup;
//----------------------------------------------------------------------------------------------------------------------
//
// Version 4.7.0
//
// 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.
//
// September 2004:
// - Bug fix: TVTHeaderPopupMenu.OnMenuItemClick used the wrong Tag member for the event.
//
// Modified 12 Dec 2003 by Ralf Junker <delphi@zeitungsjunge.de>.
// - Added missing default storage specifier for Options property.
// - 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
// tree's header options.
// - Added an additional check for the PopupComponent property before casting
// it hardly to a Virtual Treeview in OnMenuItemClick. See entry 31 Mar 2003.
//
// 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.
//
// Modified 31 Mar 2003 by Mike Lischke <public@soft-gems.net>.
// - 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.
//----------------------------------------------------------------------------------------------------------------------
interface
uses
System.Classes,
Vcl.Menus,
VirtualTrees;
type
TVTHeaderPopupOption = (
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.
poResizeToFitItem // Adds an item which, if clicks, resizes all columns to fit by callung TVTHeader.AutoFitColumns
);
TVTHeaderPopupOptions = set of TVTHeaderPopupOption;
TColumnChangeEvent = procedure(const Sender: TBaseVirtualTree; const Column: TColumnIndex; Visible: Boolean) of object;
TVTHeaderPopupMenu = class(TPopupMenu)
strict private
FOptions: TVTHeaderPopupOptions;
FOnHeaderAddPopupItem: TVTHeaderAddPopupItemEvent;
FOnColumnChange: TColumnChangeEvent;
procedure ResizeColumnToFit(Sender: TObject);
procedure ResizeToFit(Sender: TObject);
strict protected
procedure DoAddHeaderPopupItem(const Column: TColumnIndex; out Cmd: TAddPopupItemType); virtual;
procedure DoColumnChange(Column: TColumnIndex; Visible: Boolean); virtual;
procedure OnMenuItemClick(Sender: TObject);
public
constructor Create(AOwner: TComponent); override;
procedure Popup(x, y: Integer); override;
published
property Options: TVTHeaderPopupOptions read FOptions write FOptions default [poResizeToFitItem];
property OnAddHeaderPopupItem: TVTHeaderAddPopupItemEvent read FOnHeaderAddPopupItem write FOnHeaderAddPopupItem;
property OnColumnChange: TColumnChangeEvent read FOnColumnChange write FOnColumnChange;
end;
//----------------------------------------------------------------------------------------------------------------------
implementation
uses
Winapi.Windows, System.Types;
resourcestring
sResizeColumnToFit = 'Size &Column to Fit';
sResizeToFit = 'Size &All Columns to Fit';
type
TVTMenuItem = class(TMenuItem)
public
constructor Create(AOwner: TComponent; const ACaption: string; AClickHandler: TNotifyEvent = nil); reintroduce;
end;
//----------------- TVTHeaderPopupMenu ---------------------------------------------------------------------------------
constructor TVTHeaderPopupMenu.Create(AOwner: TComponent);
begin
inherited;
FOptions := [poResizeToFitItem];
end;
procedure TVTHeaderPopupMenu.DoAddHeaderPopupItem(const Column: TColumnIndex; out Cmd: TAddPopupItemType);
begin
Cmd := apNormal;
if Assigned(FOnHeaderAddPopupItem) then
FOnHeaderAddPopupItem((PopupComponent as TBaseVirtualTree), Column, Cmd);
end;
//----------------------------------------------------------------------------------------------------------------------
procedure TVTHeaderPopupMenu.DoColumnChange(Column: TColumnIndex; Visible: Boolean);
begin
if Assigned(FOnColumnChange) then
FOnColumnChange((PopupComponent as TBaseVirtualTree), Column, Visible);
end;
//----------------------------------------------------------------------------------------------------------------------
procedure TVTHeaderPopupMenu.OnMenuItemClick(Sender: TObject);
begin
if Assigned(PopupComponent) and (PopupComponent is TBaseVirtualTree) then begin
with TBaseVirtualTree(PopupComponent).Header.Columns.Items[TVTMenuItem(Sender).Tag] do
begin
if TVTMenuItem(Sender).Checked then
Options := Options - [coVisible]
else
Options := Options + [coVisible];
end;
end;
end;
//----------------------------------------------------------------------------------------------------------------------
procedure TVTHeaderPopupMenu.Popup(x, y: Integer);
var
ColPos: TColumnPosition;
ColIdx: TColumnIndex;
NewMenuItem: TVTMenuItem;
Cmd: TAddPopupItemType;
VisibleCounter: Cardinal;
VisibleItem: TVTMenuItem;
i: Integer;
begin
if Assigned(PopupComponent) and (PopupComponent is TBaseVirtualTree) then
begin
// Delete existing menu items.
for i := Items.Count -1 downto 0 do begin
if Items[i] is TVTMenuItem then
Items[i].Free;
end;//for i
if poResizeToFitItem in Self.Options then
begin
Items.Add(TVTMenuItem.Create(Self, sResizeColumnToFit, ResizeColumnToFit));
Items.Add(TVTMenuItem.Create(Self, sResizeToFit, ResizeToFit));
Items.Add(TVTMenuItem.Create(Self, cLineCaption));
end;//poResizeToFitItem
// Add column menu items.
with (PopupComponent as TBaseVirtualTree).Header do
begin
if hoShowImages in Options then
Self.Images := Images
else
// Remove a possible reference to image list of another tree previously assigned.
Self.Images := nil;
VisibleItem := nil;
VisibleCounter := 0;
for ColPos := 0 to Columns.Count - 1 do
begin
if poOriginalOrder in FOptions then
ColIdx := ColPos
else
ColIdx := Columns.ColumnFromPosition(ColPos);
with Columns[ColIdx] do
begin
if coVisible in Options then
Inc(VisibleCounter);
DoAddHeaderPopupItem(ColIdx, Cmd);
if Cmd <> apHidden then
begin
NewMenuItem := TVTMenuItem.Create(Self, Text, OnMenuItemClick);
NewMenuItem.Tag := ColIdx;
NewMenuItem.Caption := Text;
NewMenuItem.Hint := Hint;
NewMenuItem.ImageIndex := ImageIndex;
NewMenuItem.Checked := coVisible in Options;
if Cmd = apDisabled then
NewMenuItem.Enabled := False
else
if coVisible in Options then
VisibleItem := NewMenuItem;
Items.Add(NewMenuItem);
end;
end;
end;
// Conditionally disable menu item of last enabled column.
if (VisibleCounter = 1) and (VisibleItem <> nil) and not (poAllowHideAll in FOptions) then
VisibleItem.Enabled := False;
end;
end;
inherited;
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;
end;
procedure TVclStyleScrollBarsHook.PaintScrollBars;
procedure TVclStyleScrollBarsHook.PaintScrollBars();
begin
FVertScrollBarWindow.Repaint;
FHorzScrollBarWindow.Repaint;
if FVertScrollBarWindow.HandleAllocated then begin
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;
function TVclStyleScrollBarsHook.PointInTreeHeader(const P: TPoint): Boolean;
@ -573,7 +579,8 @@ end;
procedure TVclStyleScrollBarsHook.WMKeyDown(var Msg: TMessage);
begin
CallDefaultProc(TMessage(Msg));
PaintScrollBars;
CalcScrollBarsRect;
UpdateScrollBarWindow;
Handled := True;
end;
@ -587,7 +594,8 @@ end;
procedure TVclStyleScrollBarsHook.WMLButtonDown(var Msg: TWMMouse);
begin
CallDefaultProc(TMessage(Msg));
PaintScrollBars;
CalcScrollBarsRect;
UpdateScrollBarWindow;
Handled := True;
end;
@ -1140,9 +1148,12 @@ begin
end;
initialization
TCustomStyleEngine.RegisterStyleHook(TVirtualStringTree, TVclStyleScrollBarsHook);
TCustomStyleEngine.RegisterStyleHook(TVirtualDrawTree, TVclStyleScrollBarsHook);
finalization
TCustomStyleEngine.UnRegisterStyleHook(TVirtualStringTree, TVclStyleScrollBarsHook);
TCustomStyleEngine.UnRegisterStyleHook(TVirtualDrawTree, TVclStyleScrollBarsHook);
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;
interface
uses
System.Classes,
VirtualTrees;
type
// internal worker thread
TWorkerThread = class(TThread)
private
FCurrentTree: TBaseVirtualTree;
FWaiterList: TThreadList;
FRefCount: Cardinal;
protected
procedure CancelValidation(Tree: TBaseVirtualTree);
procedure Execute; override;
public
constructor Create(CreateSuspended: Boolean);
destructor Destroy; override;
procedure AddTree(Tree: TBaseVirtualTree);
procedure RemoveTree(Tree: TBaseVirtualTree);
property CurrentTree: TBaseVirtualTree read FCurrentTree;
end;
procedure AddThreadReference;
procedure ReleaseThreadReference(Tree: TBaseVirtualTree);
var
WorkerThread: TWorkerThread;
WorkEvent: THandle;
implementation
uses
Winapi.Windows,
System.Types,
System.SysUtils;
type
TBaseVirtualTreeCracker = class(TBaseVirtualTree)
end;
//----------------- TWorkerThread --------------------------------------------------------------------------------------
procedure AddThreadReference;
unit VirtualTrees.WorkerThread;
interface
uses
System.Classes,
VirtualTrees;
type
// internal worker thread
TWorkerThread = class(TThread)
private
FCurrentTree: TBaseVirtualTree;
FWaiterList: TThreadList;
FRefCount: Integer;
class procedure EnsureCreated();
class procedure Dispose();
procedure WaitForValidationTermination(Tree: TBaseVirtualTree);
protected
procedure Execute; override;
public
constructor Create();
destructor Destroy; override;
/// For lifeteime management of the TWorkerThread
class procedure AddThreadReference;
class procedure ReleaseThreadReference();
class procedure AddTree(Tree: TBaseVirtualTree);
class procedure RemoveTree(Tree: TBaseVirtualTree);
property CurrentTree: TBaseVirtualTree read FCurrentTree;
end;
implementation
uses
Winapi.Windows,
System.Types,
System.SysUtils;
type
TBaseVirtualTreeCracker = class(TBaseVirtualTree)
end;
var
WorkerThread: TWorkerThread = nil;
WorkEvent: THandle;
//----------------- TWorkerThread --------------------------------------------------------------------------------------
class procedure TWorkerThread.EnsureCreated();
begin
if not Assigned(WorkerThread) then
begin
// Create an event used to trigger our worker thread when something is to do.
WorkEvent := CreateEvent(nil, False, False, nil);
if WorkEvent = 0 then
RaiseLastOSError;
// Create worker thread, initialize it and send it to its wait loop.
WorkerThread := TWorkerThread.Create(False);
end;
Inc(WorkerThread.FRefCount);
begin
// Create an event used to trigger our worker thread when something is to do.
WorkEvent := CreateEvent(nil, False, False, nil);
if WorkEvent = 0 then
RaiseLastOSError;
// Create worker thread, initialize it and send it to its wait loop.
WorkerThread := TWorkerThread.Create();
end;
end;
//----------------------------------------------------------------------------------------------------------------------
procedure ReleaseThreadReference(Tree: TBaseVirtualTree);
class procedure TWorkerThread.Dispose();
begin
if Assigned(WorkerThread) then
begin
Dec(WorkerThread.FRefCount);
// 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);
WorkerThread.Terminate();
SetEvent(WorkEvent);
WorkerThread := nil; //Will be freed usinf TThreaf.FreeOnTerminate
CloseHandle(WorkEvent);
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;
{$R *.res}
{$R '..\..\Resources\VirtualTreesD.dcr'}
{$R '..\..\Design\VirtualTrees.dcr'}
{$IFDEF IMPLICITBUILDING This IFDEF should not be used by users}
{$ALIGN 8}
{$ASSERTIONS ON}
{$BOOLEVAL OFF}
{$DEBUGINFO ON}
{$DEBUGINFO OFF}
{$EXTENDEDSYNTAX ON}
{$IMPORTEDDATA ON}
{$IOCHECKS ON}
{$LOCALSYMBOLS ON}
{$LONGSTRINGS ON}
{$OPENSTRINGS ON}
{$OPTIMIZATION OFF}
{$OPTIMIZATION ON}
{$OVERFLOWCHECKS OFF}
{$RANGECHECKS OFF}
{$REFERENCEINFO ON}
{$SAFEDIVIDE OFF}
{$STACKFRAMES ON}
{$STACKFRAMES OFF}
{$TYPEDADDRESS OFF}
{$VARSTRINGCHECKS ON}
{$WRITEABLECONST OFF}
{$MINENUMSIZE 1}
{$IMAGEBASE $400000}
{$DEFINE DEBUG}
{$DEFINE RELEASE}
{$ENDIF IMPLICITBUILDING}
{$DESCRIPTION 'VirtualTreeView Controls'}
{$DESIGNONLY}

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

@ -3,7 +3,7 @@
<ProjectGuid>{A34BA07B-19B6-4C21-9DEE-65FCA52D00AB}</ProjectGuid>
<MainSource>VirtualTreesD.dpk</MainSource>
<Base>True</Base>
<Config Condition="'$(Config)'==''">Debug</Config>
<Config Condition="'$(Config)'==''">Release</Config>
<AppType>Package</AppType>
<FrameworkType>VCL</FrameworkType>
<DCC_DCCCompiler>DCC32</DCC_DCCCompiler>
@ -19,11 +19,6 @@
<CfgParent>Base</CfgParent>
<Base>true</Base>
</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)'!=''">
<Cfg_1>true</Cfg_1>
<CfgParent>Base</CfgParent>
@ -35,6 +30,8 @@
<Base>true</Base>
</PropertyGroup>
<PropertyGroup Condition="'$(Base)'!=''">
<SanitizedProjectName>VirtualTreesD</SanitizedProjectName>
<DCC_HppOutput>..\..\Source</DCC_HppOutput>
<DCC_DcuOutput>..\..\build\$(Platform)</DCC_DcuOutput>
<DCC_OutputNeverBuildDcps>true</DCC_OutputNeverBuildDcps>
<DCC_Description>VirtualTreeView Controls</DCC_Description>
@ -52,20 +49,14 @@
<DCC_N>false</DCC_N>
<DCC_F>false</DCC_F>
<DCC_K>false</DCC_K>
<SanitizedProjectName>VirtualTreesD</SanitizedProjectName>
</PropertyGroup>
<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_UsePackage>vcl;VirtualTreesD;VirtualTreesR;$(DCC_UsePackage)</DCC_UsePackage>
</PropertyGroup>
<PropertyGroup Condition="'$(Base_Win64)'!=''">
<DCC_UsePackage>vcl;$(DCC_UsePackage)</DCC_UsePackage>
<DCC_UsePackage>vcl;VirtualTreesR;$(DCC_UsePackage)</DCC_UsePackage>
</PropertyGroup>
<PropertyGroup Condition="'$(Cfg_1)'!=''">
<DCC_LocalDebugSymbols>false</DCC_LocalDebugSymbols>
<DCC_Define>RELEASE;$(DCC_Define)</DCC_Define>
<DCC_SymbolReferenceInfo>0</DCC_SymbolReferenceInfo>
<DCC_DebugInformation>0</DCC_DebugInformation>
</PropertyGroup>
<PropertyGroup Condition="'$(Cfg_2)'!=''">
<DCC_Define>DEBUG;$(DCC_Define)</DCC_Define>
@ -76,7 +67,7 @@
<DelphiCompile Include="$(MainSource)">
<MainSource>MainSource</MainSource>
</DelphiCompile>
<DCCReference Include="..\..\Resources\VirtualTreesD.dcr"/>
<DCCReference Include="..\..\Design\VirtualTrees.dcr"/>
<DCCReference Include="DesignIDE.dcp"/>
<DCCReference Include="VirtualTreesR.dcp"/>
<DCCReference Include="..\..\Design\VirtualTreesReg.pas"/>
@ -127,14 +118,11 @@
<VersionInfoKeys Name="ProductVersion">1.0.0.0</VersionInfoKeys>
<VersionInfoKeys Name="Comments"/>
</VersionInfoKeys>
<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>
<Excluded_Packages />
</Delphi.Personality>
<Platforms>
<Platform value="Win32">True</Platform>
<Platform value="Win64">False</Platform>
</Platforms>
</BorlandProject>
<ProjectFileVersion>12</ProjectFileVersion>

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

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

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

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

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

@ -7,7 +7,7 @@
<AppType>Package</AppType>
<FrameworkType>VCL</FrameworkType>
<DCC_DCCCompiler>DCC32</DCC_DCCCompiler>
<ProjectVersion>15.1</ProjectVersion>
<ProjectVersion>18.4</ProjectVersion>
<Platform Condition="'$(Platform)'==''">Win32</Platform>
<TargetedPlatforms>1</TargetedPlatforms>
</PropertyGroup>
@ -52,6 +52,7 @@
<DCC_N>false</DCC_N>
<DCC_F>false</DCC_F>
<DCC_K>false</DCC_K>
<SanitizedProjectName>VirtualTreesD</SanitizedProjectName>
</PropertyGroup>
<PropertyGroup Condition="'$(Base_Win32)'!=''">
<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>
<FrameworkType>VCL</FrameworkType>
<DCC_DCCCompiler>DCC32</DCC_DCCCompiler>
<ProjectVersion>15.1</ProjectVersion>
<ProjectVersion>18.4</ProjectVersion>
<Platform Condition="'$(Platform)'==''">Win32</Platform>
<TargetedPlatforms>3</TargetedPlatforms>
</PropertyGroup>
@ -62,6 +62,7 @@
<DCC_N>false</DCC_N>
<DCC_F>false</DCC_F>
<DCC_K>false</DCC_K>
<SanitizedProjectName>VirtualTreesR</SanitizedProjectName>
</PropertyGroup>
<PropertyGroup Condition="'$(Base_Win32)'!=''">
<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.ClipBoard.pas"/>
<DCCReference Include="..\..\Source\VirtualTrees.Utils.pas"/>
<DCCReference Include="..\..\Source\VirtualTrees.Actions.pas"/>
<DCCReference Include="..\..\Source\VirtualTrees.Export.pas"/>
<DCCReference Include="..\..\Source\VirtualTrees.Actions.pas"/>
<BuildConfiguration Include="Debug">
<Key>Cfg_2</Key>
<CfgParent>Base</CfgParent>