how to add objects to virtualtreeview - delphi

In short, I'm trying to add Object into VirtualTreeView but am always getting error EAccessViolation at CellText I'm wondering about the reason for the error i tried to do my best but without result...
this is my attempt:
TForm1 = class(TForm)
private
public
end;
TPerson = class;
PPersonNode = ^TPersonNode;
TPersonNode = record
PersonObj: TPerson;
end;
TPerson = class(TObject)
private
FName: string;
public
property Name: string read FName write FName;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
PersonRec: PPersonNode;
begin
PersonRec := VirtualStringTree1.GetNodeData(VirtualStringTree1.AddChild(nil));
PersonRec.PersonObj := TPerson.Create;
PersonRec.PersonObj.Name := 'aaa';
end;
procedure TForm1.VirtualStringTree1GetNodeDataSize(Sender: TBaseVirtualTree;
var NodeDataSize: Integer);
begin
NodeDataSize := SizeOf(TPersonNode);
end;
procedure TForm1.VirtualStringTree1GetText(Sender: TBaseVirtualTree;
Node: PVirtualNode; Column: TColumnIndex; TextType: TVSTTextType;
var CellText: string);
var
PersonRec: PPersonNode;
begin
PersonRec := Sender.GetNodeData(Node);
CellText := PersonRec.PersonObj.Name;
end;


It looks like the OnGetText event is being fired before the TPerson object has been created. Try checking that the object isn't nil first:
procedure TForm1.VirtualStringTree1GetText(Sender: TBaseVirtualTree;
Node: PVirtualNode; Column: TColumnIndex; TextType: TVSTTextType;
var CellText: string);
var
PersonRec: PPersonNode;
begin
PersonRec := Sender.GetNodeData(Node);
if PersonRec <> nil then // <- check that the object has been created
CellText := PersonRec.PersonObj.Name;
end;


I would change this:
procedure TForm1.Button1Click(Sender: TObject);
var
PersonRec: PPersonNode;
begin
PersonRec := VirtualStringTree1.GetNodeData(VirtualStringTree1.AddChild(VirtualStringTree1.RootNode));
PersonRec.PersonObj := TPerson.Create;
PersonRec.PersonObj.Name := 'aaa';
end;
and this:
procedure TForm1.VirtualStringTree1GetText(Sender: TBaseVirtualTree;
Node: PVirtualNode; Column: TColumnIndex; TextType: TVSTTextType;
var CellText: string);
var
PersonRec: PPersonNode;
begin
if Assigned(Node) then
begin
PersonRec := Sender.GetNodeData(Node);
CellText := PersonRec.PersonObj.Name;
end;
end;

Related

Cannot select the root node in Virtual Tree View

I am using Delphi XE3 with Virtual Tree View.
My codes are below:
type
TMyData = record
Caption: string;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
RootNode: PVirtualNode;
PData: ^TMyData;
begin
RootNode := tvItems.AddChild(nil);
PData := tvItems.GetNodeData(RootNode);
PData^.Caption := 'This is a test node';
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
tvItems.NodeDataSize := SizeOf(TMyData);
end;
procedure TForm1.tvItemsGetText(Sender: TBaseVirtualTree; Node: PVirtualNode;
Column: TColumnIndex; TextType: TVSTTextType; var CellText: string);
var
PData: ^TMyData;
begin
if Assigned(Node) then
begin
PData := tvItems.GetNodeData(Node);
if Assigned(PData) then
Celltext := PData^.Caption;
end;
end;
When I click the "Button1", the root node will be created. However, when my mouse clicks the node text, it will not be selected.
Some of my findings:
One must clicks to the beginning of the node text to select the node. If clicking in middle or in the end of the node text, then the node will not be selected.
If I change tvItemsGetText to below, then the problem disappears:
procedure TForm1.tvItemsGetText(Sender: TBaseVirtualTree; Node: PVirtualNode;
Column: TColumnIndex; TextType: TVSTTextType; var CellText: string);
var
PData: ^TMyData;
begin
CellText := 'This is a test node';
end;
I set a breakpoint in tvItemsGetText and find it will be invoked several times. At the first several times, the PData will be nil, which makes the CellText empty. At the final invokation, the PData will become valid and the CellText will be set to 'This is a test node'.
It seems that the range that allow mouse click and select the node is determined by the initial texts of the node. If the initial text is empty string, then one must click at the very beginning of the node to select it.
Is this a bug of Virtual Tree View?

There are several ways to init new node by user data.
1. Using OnInitNode event:
procedure TForm5.Button1Click(Sender: TObject);
begin
vt1.InsertNode(nil, amAddChildLast); // internal calls vt1InitNode
end;
procedure TForm5.vt1InitNode(Sender: TBaseVirtualTree; ParentNode, Node: PVirtualNode;
var InitialStates: TVirtualNodeInitStates);
var
PData: ^TMyData;
begin
PData := Sender.GetNodeData(Node);
PData^.Caption := 'This is a test node';
end;
2 Using UserData param
Variant 1. Dynamic data
Do not forget to remove InitNode event and dont set NodeDataSize property
type
TMyData = record
Caption: string;
end;
PMyData = ^TMyData;
procedure TForm5.Button1Click(Sender: TObject);
var
p: PMyData;
begin
New(p);
p.Caption:='This is a test node';
vt1.InsertNode(nil, amAddChildLast, p); // create node with initialized user data
// by default VirtualTree use NodeDataSize = SizeOf(pointer),
// so there is no reason to use GetNodeDataSize event
end;
procedure TForm5.vt1GetText(Sender: TBaseVirtualTree; Node: PVirtualNode;
Column: TColumnIndex; TextType: TVSTTextType;
var CellText: string);
var
PData: PMyData;
begin
if Assigned(Node) then
begin
PData := PMyData(Sender.GetNodeData(Node)^); // little modification
// for correct access to dynamic node data
if Assigned(PData) then
CellText := PData.Caption;
end;
end;
procedure TForm5.vt1FreeNode(Sender: TBaseVirtualTree; Node: PVirtualNode);
var
p: PMyData;
begin
p:=PMyData(Sender.GetNodeData(Node)^);
Dispose(p); // as you allocate memory for user data - you should free it to avoid memory leaks
end;
Variant 2. Objects
Add new private function to your form:
private
{ Private declarations }
function GetObjectByNode<T: class>(Node: PVirtualNode): T;
// do not forget to include System.Generics.Collections to `uses`
realization:
function TForm5.GetObjectByNode<T>(Node: PVirtualNode): T;
var
NodeData: Pointer;
tmpObject: TObject;
begin
Result := nil;
if not Assigned(Node) then
exit;
NodeData := vt1.GetNodeData(Node);
if Assigned(NodeData) then
tmpObject := TObject(NodeData^);
if tmpObject is T then
Result := T(tmpObject)
else
Result := nil;
end;
And the main code (almost identical to variant 1):
procedure TForm5.Button1Click(Sender: TObject);
var
d: TMyData;
begin
d := TMyData.Create;
d.Caption := 'This is a test node';
vt1.InsertNode(nil, amAddChildLast, d);
end;
procedure TForm5.vt1FreeNode(Sender: TBaseVirtualTree; Node: PVirtualNode);
var
d: TMyData;
begin
d := GetObjectByNode<TMyData>(Node);
d.Free;
end;
procedure TForm5.vt1GetText(Sender: TBaseVirtualTree; Node: PVirtualNode;
Column: TColumnIndex; TextType: TVSTTextType;
var CellText: string);
var
d: TMyData;
begin
d := GetObjectByNode<TMyData>(Node);
if Assigned(d) then
CellText := d.Caption;
end;

dragNdrop all columns between two VirtualTreeView

How to copy all columns between two VirtualTreeView? In my case only the first one is copied.
I use VirtualTreeView v6.6.
The code that I'm using:
type
PItemNode1 = ^TItemNode1;
TItemNode1 = record
Name: WideString;
Order: string;
Quantity:String;
end;
type
PItemNode2 = ^TItemNode2;
TItemNode2 = record
Name: WideString;
Order: string;
end;
procedure TForm1.FormCreate(Sender: TObject);
var
Node: PVirtualNode;
begin
VT.NodeDataSize := SizeOf(TItemNode1);
VT2.NodeDataSize := SizeOf(TItemNode2);
VT.RootNodeCount := 2;
VT2.RootNodeCount := 10;
end;
Procedure for inserting OLE data
procedure TForm1.InsertData(Sender: TVirtualStringTree; DataObject: IDataObject;
Formats: TFormatArray; Effect: Integer; Mode: TVTNodeAttachMode);
var
FormatAccepted: Boolean;
i: Integer;
begin
FormatAccepted := false;
for i := 0 to High(Formats) do
begin
if Formats[i] = CF_VIRTUALTREE then
begin
if not FormatAccepted then
begin
Sender.ProcessDrop(DataObject, Sender.DropTargetNode, Effect, Mode);
FormatAccepted := True;
end;
end;
end;
end;
Drag and Drop precedures
procedure TForm1.VT2DragAllowed(Sender: TBaseVirtualTree; Node: PVirtualNode;
Column: TColumnIndex; var Allowed: Boolean);
begin
Allowed := True;
end;
procedure TForm1.VT2DragDrop(Sender: TBaseVirtualTree; Source: TObject;
DataObject: IDataObject; Formats: TFormatArray; Shift: TShiftState;
Pt: TPoint; var Effect: Integer; Mode: TDropMode);
procedure DetermineEffect;
begin
if Shift = [] then
begin
if Source = Sender then
Effect := DROPEFFECT_MOVE
else
Effect := DROPEFFECT_COPY;
end
else
begin
if (Shift = [ssAlt]) or (Shift = [ssCtrl, ssAlt]) then
Effect := DROPEFFECT_LINK
else if Shift = [ssCtrl] then
Effect := DROPEFFECT_COPY
else
end;
end;
var
Attachmode: TVTNodeAttachMode;
Nodes: TNodeArray;
i: Integer;
begin
Nodes := nil;
case Mode of
dmAbove:
Attachmode := amInsertBefore;
dmOnNode:
Attachmode := amAddChildLast;
dmBelow:
Attachmode := amInsertAfter;
else
Attachmode := amNowhere;
end;
if DataObject = nil then
begin
//VCL
if Source is TVirtualStringTree then
begin
DetermineEffect;
Nodes := VT2.GetSortedSelection(True);
if Effect = DROPEFFECT_COPY then
begin
for i := 0 to High(Nodes) do
VT2.CopyTo(Nodes[i], Sender.DropTargetNode, Attachmode, false);
end
else
for i := 0 to High(Nodes) do
VT2.MoveTo(Nodes[i], Sender.DropTargetNode, Attachmode, false);
end;
end
else
begin
// OLE drag&drop.
if Source is TBaseVirtualTree then
DetermineEffect
else
begin
if Boolean(Effect and DROPEFFECT_COPY) then
Effect := DROPEFFECT_COPY
else
Effect := DROPEFFECT_MOVE;
end;
InsertData(Sender as TVirtualStringTree, DataObject, Formats, Effect,
Attachmode);
end;
end;
procedure TForm1.VT2DragOver(Sender: TBaseVirtualTree; Source: TObject;
Shift: TShiftState; State: TDragState; Pt: TPoint; Mode: TDropMode;
var Effect: Integer; var Accept: Boolean);
// Return True, if AParent - child node of ANode.
function IsNodeParent(AParent, ANode: PVirtualNode): Boolean;
var
NextParent: PVirtualNode;
begin
NextParent := AParent;
repeat
NextParent := NextParent.Parent;
until (NextParent = Sender.RootNode) or (NextParent = nil) or
(NextParent = ANode);
Result := ANode = NextParent;
end;
var
i: Integer;
Nodes: TNodeArray;
begin
Accept := True;
if (Assigned(Sender.DropTargetNode)) and
(Sender.DropTargetNode <> Sender.RootNode) then
Nodes := (Sender as TVirtualStringTree).GetSortedSelection(True);
if Length(Nodes) > 0 then
begin
for i := 0 to Length(Nodes) - 1 do
begin
Accept :=
(not IsNodeParent(Sender.DropTargetNode, Nodes[i]))
and (not(Sender.DropTargetNode = Nodes[i]));
if not Accept then Exit;
end;
end;
end;
Initialize the nodes of VT2(right VT in the picture above )and get the text for them
procedure TForm1.VT2GetText(Sender: TBaseVirtualTree; Node: PVirtualNode;
Column: TColumnIndex; TextType: TVSTTextType; var CellText: string);
var
ItemNode: PItemNode2;
begin
ItemNode := Sender.GetNodeData(Node);
if Assigned(ItemNode) then
begin
case Column of
0:
CellText := ItemNode^.Name;
1:
CellText := ItemNode^.Order;
end;
end;
end;
procedure TForm1.VT2InitNode(Sender: TBaseVirtualTree;
ParentNode, Node: PVirtualNode; var InitialStates: TVirtualNodeInitStates);
var
ItemNode: PItemNode2;
begin
ItemNode := Sender.GetNodeData(Node);
if Assigned(ItemNode) then
if Length(ItemNode^.Name) = 0 then
ItemNode^.Name := 'Node Index № ' + IntToStr(Node.Index);
ItemNode^.Order := IntToStr(Node.Index);
end;
Get a new text after the node is dropped
procedure TForm1.VT2NewText(Sender: TBaseVirtualTree; Node: PVirtualNode;
Column: TColumnIndex; NewText: string);
var
ItemNode: PItemNode2;
begin
ItemNode := Sender.GetNodeData(Node);
if Assigned(ItemNode) then
begin
case Column of
0:
ItemNode^.Name := NewText;
1:
ItemNode^.Order := NewText; // I've checked this line in the debugger. It is skipped
end;
end;
end;
Initialize the nodes of VT(left VT in the picture above )and get the text for them
procedure TForm1.VTGetText(Sender: TBaseVirtualTree; Node: PVirtualNode;
Column: TColumnIndex; TextType: TVSTTextType; var CellText: string);
var
ItemNode: PItemNode1;
begin
ItemNode := Sender.GetNodeData(Node);
if Assigned(ItemNode) then
case Column of
0:
CellText := ItemNode^.Name;
1:
CellText := ItemNode^.Order;
end;
end;
procedure TForm1.VTInitNode(Sender: TBaseVirtualTree; ParentNode,
Node: PVirtualNode; var InitialStates: TVirtualNodeInitStates);
var
ItemNode: PItemNode1;
begin
ItemNode := Sender.GetNodeData(Node);
if Assigned(ItemNode) then
if Length(ItemNode^.Name) = 0 then
ItemNode^.Name := 'VT1_Node № ' + IntToStr(Node.Index);
ItemNode^.Order := IntToStr(Node.Index);
end;
end.

Icons in TVirtualStringTree painted with exception

This is very small project to reproduce the problem (VirtualStringTree version 6.5):
type
TForm1 = class(TForm)
vstTest: TVirtualStringTree;
Images: TImageList;
procedure FormCreate(Sender: TObject);
procedure vstTestGetText(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex;
TextType: TVSTTextType; var CellText: string);
procedure vstTestGetImageIndex(Sender: TBaseVirtualTree; Node: PVirtualNode; Kind: TVTImageKind;
Column: TColumnIndex; var Ghosted: Boolean; var ImageIndex: TImageIndex);
private
{ Private declarations }
public
{ Public declarations }
end;
PTestRec = ^TTestRec;
TTestRec = record
Col1: string;
Col2: string;
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.FormCreate(Sender: TObject);
var
Node: PVirtualNode;
Data: PTestRec;
begin
vstTest.Header.Columns.Add;
vstTest.Header.Columns.Add;
vstTest.Header.Options := vstTest.Header.Options + [hoVisible];
vstTest.Images := Images;
vstTest.NodeDataSize := SizeOf(TTestRec);
Node := vstTest.AddChild(nil);
Data := vstTest.GetNodeData(Node);
Data.Col1 := 'Col1';
Data.Col2 := 'Col2';
end;
procedure TForm1.vstTestGetImageIndex(Sender: TBaseVirtualTree; Node: PVirtualNode;
Kind: TVTImageKind; Column: TColumnIndex; var Ghosted: Boolean; var ImageIndex: TImageIndex);
begin
if Column = 0 then
ImageIndex := 0;
end;
procedure TForm1.vstTestGetText(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex;
TextType: TVSTTextType; var CellText: string);
var
Data: PTestRec;
begin
Data := vstTest.GetNodeData(Node);
case Column of
0: CellText := Data.Col1;
1: CellText := Data.Col2;
end;
end;
Form contain ImageList, which contain only one icon. Done. Now we can run the program and get exception when moving mouse cursor over Icon:
Exception class EAssertionFailed with message 'An image index was supplied for TVTImageKind.ikState but no image list was supplied. (C:\Program Files\VirtualTreeView\Source\VirtualTrees.pas, line 20248)'. Process Project1.exe (3232)
As you can see I'm not use StateImages and OnGetImageIndexEx. Why this? This is from VirtualTrees code on the line 12635
WithStateImages := Assigned(FStateImages) or Assigned(OnGetImageIndexEx);

procedure TForm1.vstTestGetImageIndex(Sender: TBaseVirtualTree; Node: PVirtualNode;
Kind: TVTImageKind; Column: TColumnIndex; var Ghosted: Boolean;
var ImageIndex: TImageIndex);
begin
if Column = 0 then
ImageIndex := 0;
end;
This code ignores the Kind argument. That argument can have one of the values from this enumeration:
TVTImageKind = (
ikNormal,
ikSelected,
ikState,
ikOverlay
);
If you return a value for ikState then you must have also provided state images. That is what the error message is telling you. I guess that your event handler should discriminate like so:
procedure TForm1.vstTestGetImageIndex(Sender: TBaseVirtualTree; Node: PVirtualNode;
Kind: TVTImageKind; Column: TColumnIndex; var Ghosted: Boolean;
var ImageIndex: TImageIndex);
begin
case Kind of
ikNormal, ikSelected:
if Column = 0 then
ImageIndex := 0;
end;
end;

How to implement a TStringGrid using virtual tree view?

How to implement a TStringGrid using virtual tree view? Does anyone have an example?

I exceeded the character limit on my original answer with this unit, so here it is in a separate answer.
{===============================================================================
Copyright © BJM Software
http://www.bjmsoftware.com
===============================================================================}
unit BaseTree_fr;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ExtCtrls, ImgList, VirtualTrees, Contnrs
, DomainObject_intf, Base_fr
;
type
RTreeData = record
CDO: TCustomDomainObject;
end;
PTreeData = ^RTreeData;
TBaseTreeEvent = procedure of object;
TCDONodeList = class(TObject)
private
FCDOs: TObjectList;
FNodes: TList;
protected
public
constructor Create;
destructor Destroy; override;
procedure Add(ACDO: TCustomDomainObject; ANode: PVirtualNode);
procedure Clear;
function IndexOfCDO(ACDO: TCustomDomainObject): Integer;
function NodeOf(ACDO: TCustomDomainObject): PVirtualNode;
procedure Remove(ACDO: TCustomDomainObject);
procedure InvalidateNodeFor(ACDO: TCustomDomainObject; AEvent: TCDOEvent);
function IndexOfNode(ANode: PVirtualNode): Integer;
function CDOOf(ANode: PVirtualNode): TCustomDomainObject;
procedure InvalidateNode(ANode: PVirtualNode);
end;
TBaseTreeFrame = class(TBaseFrame, ICDOObserver)
Frame_Vst: TVirtualStringTree;
procedure Frame_VstGetImageIndex(Sender: TBaseVirtualTree;
Node: PVirtualNode; Kind: TVTImageKind; Column: TColumnIndex;
var Ghosted: Boolean; var ImageIndex: Integer);
procedure Frame_VstGetText(Sender: TBaseVirtualTree;
Node: PVirtualNode; Column: TColumnIndex; TextType: TVSTTextType;
var CellText: WideString);
procedure Frame_VstFocusChanged(Sender: TBaseVirtualTree;
Node: PVirtualNode; Column: TColumnIndex);
procedure Frame_VstDblClick(Sender: TObject);
procedure Frame_VstInitNode(Sender: TBaseVirtualTree; ParentNode,
Node: PVirtualNode; var InitialStates: TVirtualNodeInitStates);
procedure Frame_VstInitChildren(Sender: TBaseVirtualTree;
Node: PVirtualNode; var ChildCount: Cardinal);
procedure Frame_VstCompareNodes(Sender: TBaseVirtualTree; Node1,
Node2: PVirtualNode; Column: TColumnIndex; var Result: Integer);
procedure Frame_VstChecked(Sender: TBaseVirtualTree;
Node: PVirtualNode);
private
FNodeCheckType: TCheckType;
FOnCDOChanged: TCDONotifyEvent;
FOnDoubleClicked: TCDONotifyEvent;
FOnSelectionChanged: TCDONotifyEvent;
FOnShowColumnHeaders: TBaseTreeEvent;
protected
FNodeList: TCDONodeList;
procedure ClearFrame; override;
procedure ClearHeaders; override;
function FindParentNode(ACDO: TCustomDomainObject; AParent:
TCustomDomainObject): PVirtualNode;
function GetImageIndexFor(ACDO: TCustomDomainObject; Selected: boolean):
Integer; virtual;
procedure ShowDobs(ACDO: TCustomDomainObject; AParent: TCustomDomainObject); override;
procedure ShowDomainObject(ACDO: TCustomDomainObject; AParent:
TCustomDomainObject); override;
procedure RemoveDomainObject(ACDO: TCustomDomainObject; AParent:
TCustomDomainObject);
procedure SetCDO(const Value: TCustomDomainObject); override;
function ShowChildrenOfList(AFromCDO: TCustomDomainObject): TCustomDomainObject;
virtual;
procedure UpdateCDO(ACDO: TCustomDomainObject; AEvent: TCDOEvent);
procedure HandleDoubleClicked(ACDO: TCustomDomainObject); virtual;
procedure HandleSelectionChanged(ACDO: TCustomDomainObject); virtual;
procedure DoCDOChanged(ACDO: TCustomDomainObject);
procedure DoDoubleClicked(ACDO: TCustomDomainObject);
procedure DoSelectionChanged(ACDO: TCustomDomainObject);
procedure DoShowColumnHeaders;
procedure BeginLoad; override;
procedure EndLoad; override;
procedure ShowColumnHeaders; override;
procedure AddDomainObject(ACDO: TCustomDomainObject; AParent:
TCustomDomainObject);
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure CheckAll;
function CheckedCount: integer;
procedure FocusOn(ACDO: TCustomDomainObject);
function GetTree: TCustomDomainObject;
function GetSelection: TCustomDomainObject;
procedure UncheckAll;
property NodeCheckType: TCheckType read FNodeCheckType write FNodeCheckType;
property OnCDOChanged: TCDONotifyEvent read FOnCDOChanged write FOnCDOChanged;
property OnDoubleClicked: TCDONotifyEvent read FOnDoubleClicked write
FOnDoubleClicked;
property OnSelectionChanged: TCDONotifyEvent read FOnSelectionChanged
write FOnSelectionChanged;
property OnShowColumnHeaders: TBaseTreeEvent read FOnShowColumnHeaders
write FOnShowColumnHeaders;
end;
implementation
{$R *.dfm}
uses
BaseGUIApp_fm
, DomainObject_cls
, GUIApplication_cls
;
constructor TCDONodeList.Create;
begin
FCDOs := TObjectList.Create( false );
FNodes := TList.Create;
end;
destructor TCDONodeList.Destroy;
begin
FCDOs.Free;
FNodes.Free;
inherited;
end;
procedure TCDONodeList.Add(ACDO: TCustomDomainObject; ANode: PVirtualNode);
begin
FCDOs.Add( ACDO );
FNodes.Add( ANode );
end;
function TCDONodeList.CDOOf(ANode: PVirtualNode): TCustomDomainObject;
var
Idx: integer;
begin
Idx := FNodes.IndexOf( ANode );
if Idx = -1 then begin
Result := nil;
end else begin
Result := TCustomDomainObject( FCDOs[Idx] );
end;
end;
function TCDONodeList.IndexOfCDO(ACDO: TCustomDomainObject): Integer;
begin
Result := FCDOs.IndexOf( ACDO );
end;
function TCDONodeList.IndexOfNode(ANode: PVirtualNode): Integer;
begin
Result := FNodes.IndexOf( ANode );
end;
procedure TCDONodeList.InvalidateNode(ANode: PVirtualNode);
var
Tree: TBaseVirtualTree;
begin
Tree := TreeFromNode( ANode );
Tree.InvalidateNode( ANode );
end;
procedure TCDONodeList.InvalidateNodeFor(ACDO: TCustomDomainObject; AEvent:
TCDOEvent);
var
Idx: integer;
Node: PVirtualNode;
Tree: TBaseVirtualTree;
begin
Idx := FCDOs.IndexOf( ACDO );
if Idx > -1 then begin // Just in case
Node := PVirtualNode( FNodes[Idx] );
Tree := TreeFromNode( Node );
Tree.InvalidateNode( Node );
end;
end;
function TCDONodeList.NodeOf(ACDO: TCustomDomainObject): PVirtualNode;
var
Idx: integer;
begin
Idx := FCDOs.IndexOf( ACDO );
if Idx = -1 then begin
Result := nil;
end else begin
Result := PVirtualNode( FNodes[Idx] );
end;
end;
procedure TCDONodeList.Remove(ACDO: TCustomDomainObject);
begin
FNodes.Delete( FCDOs.Remove( ACDO ) );
end;
procedure TBaseTreeFrame.ClearFrame;
begin
inherited;
Frame_Vst.Clear;
FNodeList.Clear;
DoSelectionChanged( nil );
end;
constructor TBaseTreeFrame.Create(AOwner: TComponent);
begin
FNodeList := TCDONodeList.Create;
inherited;
Frame_Vst.DefaultText := '';
Frame_Vst.DragOperations := [];
Frame_Vst.NodeDataSize := SizeOf( RTreeData );
// // This is causing heavy recursions and InitNode executions!!!
// Frame_Vst.TreeOptions.AutoOptions := Frame_Vst.TreeOptions.AutoOptions
// + [toAutoSort];
Frame_Vst.TreeOptions.MiscOptions := Frame_Vst.TreeOptions.MiscOptions
- [toEditable]
+ [toCheckSupport{, toReadOnly}]
;
Frame_Vst.TreeOptions.PaintOptions := Frame_Vst.TreeOptions.PaintOptions
- [toHideFocusRect, toHideSelection];
Frame_Vst.TreeOptions.SelectionOptions := Frame_Vst.TreeOptions.SelectionOptions
// - []
+ [toFullRowSelect]
;
Frame_Vst.Images := TBaseGUIAppForm( GUIApp.MainForm ).Images;
Frame_Vst.Header.Images := TBaseGUIAppForm( GUIApp.MainForm ).HeaderImages;
Frame_Vst.NodeDataSize := sizeof( RTreeData );
end;
destructor TBaseTreeFrame.Destroy;
begin
FNodeList.Free;
inherited;
end;
procedure TBaseTreeFrame.RemoveDomainObject(ACDO: TCustomDomainObject; AParent:
TCustomDomainObject);
var
Node: PVirtualNode;
begin
Node := FNodeList.NodeOf( ACDO );
if Node <> nil then begin
FNodeList.Remove( ACDO );
Frame_Vst.DeleteNode( Node );
end;
end;
procedure TBaseTreeFrame.SetCDO(const Value: TCustomDomainObject);
begin
if Value <> FCDO then begin
if FCDO <> nil then begin
FCDO.DetachObserver( self );
end;
inherited;
if FCDO <> nil then begin
FCDO.AttachObserver( self );
end;
end;
end;
procedure TBaseTreeFrame.ShowDomainObject(ACDO: TCustomDomainObject; AParent:
TCustomDomainObject);
begin
// We are dealing with a virtual tree that asks for its data, and so we don't
// need to do anything here.
end;
procedure TBaseTreeFrame.UpdateCDO(ACDO: TCustomDomainObject; AEvent:
TCDOEvent);
//var
// Node: PVirtualNode;
begin
if ACDO = CDO then begin // Root that isn't shown.
end else begin
case AEvent of
ceAddedToList: begin
AddDomainObject( ACDO, ACDO.Container );
FocusOn( ACDO );
end;
ceSaved: begin
FNodeList.InvalidateNodeFor( ACDO, AEvent );
DoCDOChanged( ACDO );
end;
ceRemovedFromList: begin
RemoveDomainObject( ACDO, ACDO.Container );
end;
// ceCheckStateChanged: begin
// FNodeList.InvalidateNodeFor( ACDO, AEvent );
// end;
(*
ceListReloaded: begin
Node := FNodeList.NodeOf( ACDO );
Frame_Vst.ReInitNode( Node, true );
// FNodeList.InvalidateNodeFor( ACDO, AEvent );
end;
*)
end;
end;
end;
procedure TBaseTreeFrame.Frame_VstGetImageIndex(Sender: TBaseVirtualTree;
Node: PVirtualNode; Kind: TVTImageKind; Column: TColumnIndex;
var Ghosted: Boolean; var ImageIndex: Integer);
var
ACDO: TCustomDomainObject;
NodeData: ^RTreeData;
begin
inherited;
Case Column of
-1, 0 : begin
NodeData := Sender.GetNodeData( Node );
ACDO := NodeData.CDO;
case Kind of
ikState: ImageIndex := -1;
ikNormal: ImageIndex := GetImageIndexFor( ACDO, false );
ikSelected: ImageIndex := GetImageIndexFor( ACDO, true );
ikOverlay: ImageIndex := -1;
else
ImageIndex := -1;
end;
end;
else
end;
end;
procedure TBaseTreeFrame.Frame_VstGetText(Sender: TBaseVirtualTree;
Node: PVirtualNode; Column: TColumnIndex; TextType: TVSTTextType;
var CellText: WideString);
begin
inherited;
// Should be abstract.
end;
procedure TBaseTreeFrame.Frame_VstFocusChanged(Sender: TBaseVirtualTree;
Node: PVirtualNode; Column: TColumnIndex);
var
ACDO: TCustomDomainObject;
NodeData: ^RTreeData;
begin
inherited;
NodeData := Sender.GetNodeData( Node );
ACDO := NodeData.CDO;
HandleSelectionChanged( ACDO );
end;
procedure TBaseTreeFrame.HandleSelectionChanged(ACDO: TCustomDomainObject);
begin
DoSelectionChanged( ACDO );
end;
function TBaseTreeFrame.GetSelection: TCustomDomainObject;
var
Node: PVirtualNode;
NodeData: ^RTreeData;
begin
Node := Frame_Vst.FocusedNode;
if Node = nil then begin
Result := nil;
end else begin
NodeData := Frame_Vst.GetNodeData( Node );
Result := NodeData.CDO;
end;
end;
procedure TBaseTreeFrame.DoSelectionChanged(ACDO: TCustomDomainObject);
begin
if assigned( FOnSelectionChanged ) then begin
FOnSelectionChanged( ACDO );
end;
end;
procedure TBaseTreeFrame.DoCDOChanged(ACDO: TCustomDomainObject);
begin
if assigned( FOnCDOChanged ) then begin
FOnCDOChanged( ACDO );
end;
end;
procedure TBaseTreeFrame.Frame_VstDblClick(Sender: TObject);
var
ACDO: TCustomDomainObject;
NodeData: ^RTreeData;
Tree: TBaseVirtualTree;
begin
inherited;
if Sender is TBaseVirtualTree then begin
Tree := TBaseVirtualTree( Sender );
if Tree.FocusedNode <> nil then begin
NodeData := Tree.GetNodeData( Tree.FocusedNode );
ACDO := NodeData.CDO;
HandleDoubleClicked( ACDO );
end;
end;
end;
procedure TBaseTreeFrame.HandleDoubleClicked(ACDO: TCustomDomainObject);
begin
DoDoubleClicked( ACDO );
end;
procedure TBaseTreeFrame.DoDoubleClicked(ACDO: TCustomDomainObject);
begin
if assigned( FOnDoubleClicked ) then begin
FOnDoubleClicked( ACDO );
end;
end;
procedure TBaseTreeFrame.BeginLoad;
begin
inherited;
Frame_Vst.BeginUpdate;
end;
procedure TBaseTreeFrame.EndLoad;
begin
Frame_Vst.EndUpdate;
inherited;
end;
procedure TBaseTreeFrame.DoShowColumnHeaders;
begin
if assigned( FOnShowColumnHeaders ) then begin
FOnShowColumnHeaders;
end;
end;
procedure TBaseTreeFrame.ShowColumnHeaders;
begin
inherited;
DoShowColumnHeaders;
end;
procedure TBaseTreeFrame.ClearHeaders;
begin
inherited;
Frame_Vst.Header.Columns.Clear;
end;
procedure TCDONodeList.Clear;
begin
FCDOs.Clear;
FNodes.Clear;
end;
function TBaseTreeFrame.GetImageIndexFor(ACDO: TCustomDomainObject;
Selected: boolean): Integer;
begin
// Should be abstract.
Result := -1;
end;
procedure TBaseTreeFrame.ShowDobs(ACDO, AParent: TCustomDomainObject);
begin
// We are dealing with a virtual tree that asks for its data, so we don't
// need to do anything here.
inherited;
if CDO <> nil then begin
Frame_Vst.RootNodeCount := CDO.CDOCount;
end else begin
Frame_Vst.RootNodeCount := 0;
end;
end;
procedure TBaseTreeFrame.Frame_VstInitNode(Sender: TBaseVirtualTree;
ParentNode, Node: PVirtualNode;
var InitialStates: TVirtualNodeInitStates);
var
ParentNodeData: ^RTreeData;
ParentNodeCDO: TCustomDomainObject;
NodeData: ^RTreeData;
ChildCDO: TCustomDomainObject;
ChildCDOCount: Cardinal;
begin
// Attach CDO to Node, but wich CDO???
// And tell Node whether it can have children. We don't care yet how many.
inherited;
if ParentNode = nil then begin
ParentNodeCDO := CDO;
end else begin
ParentNodeData := Frame_Vst.GetNodeData( ParentNode );
ParentNodeCDO := ParentNodeData.CDO;
end;
NodeData := Frame_Vst.GetNodeData( Node );
if NodeData.CDO = nil then begin
ChildCDO := ShowChildrenOfList( ParentNodeCDO );
if ( ChildCDO <> nil ) then begin
// Prevent warning on comparing signed/unsiged types.
ChildCDOCount := ChildCDO.CDOCount;
if ( ChildCDOCount > Node.Index ) then begin
// if ChildCDO is TDomainObject then begin
// NodeData.CDO := ParentNodeCDO.CDO[Node.Index];
// end else if NodeData.CDO is TDomainObjectList then begin
NodeData.CDO := ChildCDO.CDO[Node.Index];
// end;
FNodeList.Add( NodeData.CDO, Node );
end;
end;
end else begin
// CDO is already set when node was added through AddDomainObject.
end;
Node.CheckType := NodeCheckType;
Sender.CheckState[Node] := csUncheckedNormal;
end;
procedure TBaseTreeFrame.Frame_VstInitChildren(Sender: TBaseVirtualTree;
Node: PVirtualNode; var ChildCount: Cardinal);
begin
inherited;
// This is called when user has clicked on a plus sign.
// We only need to tell the tree for how many children to prepare.
{ TODO -cWishList : This could be defaulted to something like
var
NodeData: ^RTreeData;
begin
inherited;
NodeData := Sender.GetNodeData( Node );
ChildCount := 0;
if NodeData.CDO is TCustomDomainObjectList then begin
ChildCount := NodeData.CDO.CDOCount;
end;
}
end;
procedure TBaseTreeFrame.AddDomainObject(ACDO: TCustomDomainObject; AParent:
TCustomDomainObject);
var
Node: PVirtualNode;
NodeData: ^RTreeData;
ParentNode: PVirtualNode;
begin
inherited;
Node := FNodeList.NodeOf( ACDO );
ParentNode := FindParentNode( ACDO, AParent );
if Node = nil then begin
Frame_Vst.BeginUpdate; // Prevent auto sorting
try
if ParentNode = nil then begin // we need the tree's root
ParentNode := Frame_Vst.RootNode;
Frame_Vst.RootNodeCount := Frame_Vst.RootNodeCount + 1;
end else begin
Frame_Vst.ChildCount[ParentNode] := Frame_Vst.ChildCount[ParentNode] + 1;
end;
Node := Frame_Vst.GetLastChild( ParentNode );
finally
Frame_Vst.EndUpdate;
end;
NodeData := Frame_Vst.GetNodeData( Node );
NodeData.CDO := ACDO;
FNodeList.Add( ACDO, Node );
end else begin
// it exists, so nothing to do.
end;
end;
procedure TBaseTreeFrame.Frame_VstCompareNodes(Sender: TBaseVirtualTree;
Node1, Node2: PVirtualNode; Column: TColumnIndex; var Result: Integer);
var
Node1Data: ^RTreeData;
Node2Data: ^RTreeData;
Node1CDO: TCustomDomainObject;
Node2CDO: TCustomDomainObject;
begin
inherited;
Node1Data := Frame_Vst.GetNodeData( Node1 );
Node2Data := Frame_Vst.GetNodeData( Node2 );
Node1CDO := Node1Data.CDO;
Node2CDO := Node2Data.CDO;
//
if ( Node1CDO = nil ) or ( Node2CDO = nil ) then begin
Result := 0;
end else if ( Node1CDO is TDomainObjectList ) <> ( Node2CDO is TDomainObjectList ) then begin
if Node1CDO is TDomainObjectList then begin
Result := -1;
end else begin
Result := 1;
end;
end else begin
Result := AnsiCompareText( Node1CDO.SortString, Node2CDO.SortString );
end;
end;
function TBaseTreeFrame.ShowChildrenOfList(AFromCDO: TCustomDomainObject):
TCustomDomainObject;
begin
// Should be abstract?
Result := AFromCDO;
end;
procedure TBaseTreeFrame.FocusOn(ACDO: TCustomDomainObject);
var
FocusOnNode: PVirtualNode;
begin
FocusOnNode := FNodeList.NodeOf( ACDO );
if FocusOnNode <> nil then begin
Frame_Vst.FocusedNode := FocusOnNode;
Frame_Vst.ClearSelection;
Frame_Vst.Selected[FocusOnNode] := true;
end;
end;
function TBaseTreeFrame.FindParentNode(ACDO,
AParent: TCustomDomainObject): PVirtualNode;
begin
Result := FNodeList.NodeOf( AParent );
if Result = nil then begin
if AParent.Container <> nil then begin
Result := FindParentNode( AParent, AParent.Container );
end;
end;
end;
function TBaseTreeFrame.GetTree: TCustomDomainObject;
begin
Result := CDO;
end;
procedure TBaseTreeFrame.CheckAll;
var
Run: PVirtualNode;
begin
Frame_Vst.BeginUpdate;
try
Run := Frame_Vst.GetFirstVisible;
while Assigned( Run ) do begin
Run.CheckState := csCheckedNormal;
Run := Frame_Vst.GetNextVisible( Run );
end;
GetTree.CheckAll;
finally
Frame_Vst.EndUpdate;
end;
end;
procedure TBaseTreeFrame.UncheckAll;
var
Run: PVirtualNode;
begin
Frame_Vst.BeginUpdate;
try
Run := Frame_Vst.GetFirstVisible;
while Assigned( Run ) do begin
Run.CheckState := csUncheckedNormal;
Run := Frame_Vst.GetNextVisible( Run );
end;
GetTree.UncheckAll;
finally
Frame_Vst.EndUpdate;
end;
end;
function TBaseTreeFrame.CheckedCount: integer;
var
Run: PVirtualNode;
begin
Result := 0;
Run := Frame_Vst.GetFirstVisible;
while Assigned( Run ) do begin
if Run.CheckState in [csCheckedNormal, csCheckedPressed] then begin
inc( Result );
end;
Run := Frame_Vst.GetNextVisible( Run );
end;
end;
procedure TBaseTreeFrame.Frame_VstChecked(Sender: TBaseVirtualTree;
Node: PVirtualNode);
var
ACDO: TCustomDomainObject;
NodeData: ^RTreeData;
begin
inherited;
NodeData := Sender.GetNodeData( Node );
ACDO := NodeData.CDO;
if ACDO <> nil then begin
ACDO.Checked := ( Node.CheckState in [csCheckedNormal, csCheckedPressed] );
end;
end;
end.

An example, though it does cater for a tree structure, can be found here:
http://www.bjmsoftware.com/delphistuff/virtualstringtreeexample.zip
It's something I have been playing with to start some new base frames, so there may be stuff in there you do not need. The BaseTree_fr unit contains the VirtualStringTree stuff from an old project. The Tree_fm.pas unit contains my new effort. Tree_fm.pas doesn't yet include dynamically adding new nodes and deleting existing ones, but you can find that in the BaseTree_fr unit.
To keep in the spirit of StackOverflow standing on its own two feet, I am including both units here.
The new effort
unit Tree_fm;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, VirtualTrees, StdCtrls, DomainObject, DogBreed, ImgList;
type
RTreeData = record
CDO: TCustomDomainObject;
end;
PTreeData = ^RTreeData;
TForm1 = class(TForm)
VirtualStringTree1: TVirtualStringTree;
Button1: TButton;
Button2: TButton;
Button3: TButton;
Button4: TButton;
Button5: TButton;
HeaderImages: TImageList;
TreeImages: TImageList;
StateImages: TImageList;
procedure VirtualStringTree1Checked(Sender: TBaseVirtualTree; Node:
PVirtualNode);
procedure VirtualStringTree1CompareNodes(Sender: TBaseVirtualTree; Node1,
Node2: PVirtualNode; Column: TColumnIndex; var Result: Integer);
procedure VirtualStringTree1DblClick(Sender: TObject);
procedure VirtualStringTree1FocusChanged(Sender: TBaseVirtualTree; Node:
PVirtualNode; Column: TColumnIndex);
procedure VirtualStringTree1GetImageIndex(Sender: TBaseVirtualTree; Node:
PVirtualNode; Kind: TVTImageKind; Column: TColumnIndex; var Ghosted:
Boolean; var ImageIndex: Integer);
procedure VirtualStringTree1GetText(Sender: TBaseVirtualTree; Node:
PVirtualNode; Column: TColumnIndex; TextType: TVSTTextType; var CellText:
string);
procedure VirtualStringTree1InitChildren(Sender: TBaseVirtualTree; Node:
PVirtualNode; var ChildCount: Cardinal);
procedure VirtualStringTree1InitNode(Sender: TBaseVirtualTree; ParentNode,
Node: PVirtualNode; var InitialStates: TVirtualNodeInitStates);
private
FIsLoading: Boolean;
FCDO: TCustomDomainObject;
protected
procedure BeginLoad;
procedure EndLoad;
procedure ClearFrame;
procedure ClearHeaders;
procedure ShowColumnHeaders;
procedure ShowDomainObject(aCDO, aParent: TCustomDomainObject);
procedure ShowDomainObjects(aCDO, aParent: TCustomDomainObject);
procedure AddColumnHeaders(aColumns: TVirtualTreeColumns); virtual;
function GetColumnText(aCDO: TCustomDomainObject; aColumn: TColumnIndex;
var aCellText: string): Boolean; virtual;
protected
property CDO: TCustomDomainObject read FCDO write FCDO;
public
constructor Create(AOwner: TComponent); override;
procedure Load(aCDO: TCustomDomainObject);
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.AddColumnHeaders(aColumns: TVirtualTreeColumns);
var
Col: TVirtualTreeColumn;
begin
Col := aColumns.Add;
Col.Text := 'Breed(Group)';
Col.Width := 200;
Col := aColumns.Add;
Col.Text := 'Average Age';
Col.Width := 100;
Col.Alignment := taRightJustify;
Col := aColumns.Add;
Col.Text := 'CDO.Count';
Col.Width := 100;
Col.Alignment := taRightJustify;
end;
procedure TForm1.BeginLoad;
begin
FIsLoading := True;
VirtualStringTree1.BeginUpdate;
end;
procedure TForm1.ClearFrame;
begin
VirtualStringTree1.Clear;
// FNodeList.Clear;
// DoSelectionChanged(nil);
end;
procedure TForm1.ClearHeaders;
begin
VirtualStringTree1.Header.Columns.Clear;
end;
constructor TForm1.Create(AOwner: TComponent);
begin
inherited;
VirtualStringTree1.DefaultText := '';
VirtualStringTree1.NodeDataSize := SizeOf(RTreeData);
VirtualStringTree1.Header.Options := VirtualStringTree1.Header.Options
//- []
+ [hoDblClickResize, hoHotTrack, hoShowImages]
;
VirtualStringTree1.Header.Style := hsXPStyle;
VirtualStringTree1.TreeOptions.AnimationOptions := VirtualStringTree1.TreeOptions.AnimationOptions
//- []
//+ []
;
VirtualStringTree1.TreeOptions.AutoOptions := VirtualStringTree1.TreeOptions.AutoOptions
//- []
// toAutoSort is (was once?) causing heavy recursions and InitNode executions!!!
// It isn't now, but it does cause the entire tree to be loaded!
+ [{toAutoSort,}{ toAutoHideButtons}]
;
//VirtualStringTree1.TreeOptions.ExportMode := emChecked;
VirtualStringTree1.TreeOptions.MiscOptions := VirtualStringTree1.TreeOptions.MiscOptions
- [toInitOnSave]
+ [toCheckSupport]
;
VirtualStringTree1.TreeOptions.PaintOptions := VirtualStringTree1.TreeOptions.PaintOptions
- [toShowTreeLines]
+ [toHotTrack, toGhostedIfUnfocused, toUseExplorerTheme]
;
VirtualStringTree1.TreeOptions.SelectionOptions := VirtualStringTree1.TreeOptions.SelectionOptions
//- []
+ [toExtendedFocus, toFullRowSelect, toMultiSelect]
;
VirtualStringTree1.TreeOptions.StringOptions := VirtualStringTree1.TreeOptions.StringOptions
//- []
//+ []
;
VirtualStringTree1.Header.Images := HeaderImages;
VirtualStringTree1.CheckImageKind := ckXP;
VirtualStringTree1.CustomCheckImages := nil;
VirtualStringTree1.Images := TreeImages;
VirtualStringTree1.StateImages := StateImages;
//VirtualStringTree1.ClipboardFormats := ;
//VirtualStringTree1.DragMode := dmAutomatic;
VirtualStringTree1.DragOperations := [];
end;
procedure TForm1.EndLoad;
begin
VirtualStringTree1.EndUpdate;
FIsLoading := False;
end;
function TForm1.GetColumnText(aCDO: TCustomDomainObject; aColumn: TColumnIndex;
var aCellText: string): Boolean;
begin
if Assigned(aCDO) then begin
case aColumn of
-1, 0: begin
aCellText := aCDO.DisplayString;
end;
1: begin
if aCDO.InheritsFrom(TDogBreed) then begin
aCellText := IntToStr(TDogBreed(aCDO).AverageAge);
end;
end;
2: begin
aCellText := IntToStr(aCDO.Count);
end;
else
// aCellText := '';
end;
Result := True;
end else begin
Result := False;
end;
end;
procedure TForm1.Load(aCDO: TCustomDomainObject);
begin
// This would be in a more generic ancestor.
BeginLoad;
try
if Assigned(CDO) then begin
ClearHeaders;
ClearFrame;
end;
CDO := aCDO;
if Assigned(CDO) then begin
ShowColumnHeaders;
ShowDomainObjects(CDO, nil);
end;
finally
EndLoad;
end;
end;
procedure TForm1.ShowColumnHeaders;
begin
AddColumnHeaders(VirtualStringTree1.Header.Columns);
if VirtualStringTree1.Header.Columns.Count > 0 then begin
VirtualStringTree1.Header.Options := VirtualStringTree1.Header.Options
+ [hoVisible];
end;
end;
procedure TForm1.ShowDomainObject(aCDO, aParent: TCustomDomainObject);
begin
// We are dealing with a virtual tree that asks for its data, and so we don't
// need to do anything here.
end;
procedure TForm1.ShowDomainObjects(aCDO, aParent: TCustomDomainObject);
begin
// We are dealing with a virtual tree that asks for its data, and so we only need
// to set the number of nodes under the root.
if Assigned(aCDO) then begin
VirtualStringTree1.RootNodeCount := aCDO.Count;
end else begin
VirtualStringTree1.RootNodeCount := 0;
end;
end;
procedure TForm1.VirtualStringTree1Checked(Sender: TBaseVirtualTree; Node:
PVirtualNode);
begin
(*
procedure TBaseTreeFrame.Frame_VstChecked(Sender: TBaseVirtualTree;
Node: PVirtualNode);
var
ACDO: TCustomDomainObject;
NodeData: ^RTreeData;
begin
inherited;
NodeData := Sender.GetNodeData(Node);
ACDO := NodeData.CDO;
if ACDO <> nil then begin
ACDO.Checked := (Node.CheckState in [csCheckedNormal, csCheckedPressed]);
end;
end;
*)
end;
procedure TForm1.VirtualStringTree1CompareNodes(Sender: TBaseVirtualTree;
Node1, Node2: PVirtualNode; Column: TColumnIndex; var Result: Integer);
begin
beep;
(*
procedure TBaseTreeFrame.Frame_VstCompareNodes(Sender: TBaseVirtualTree;
Node1, Node2: PVirtualNode; Column: TColumnIndex; var Result: Integer);
var
Node1Data: ^RTreeData;
Node2Data: ^RTreeData;
Node1CDO: TCustomDomainObject;
Node2CDO: TCustomDomainObject;
begin
inherited;
Node1Data := Frame_Vst.GetNodeData(Node1);
Node2Data := Frame_Vst.GetNodeData(Node2);
Node1CDO := Node1Data.CDO;
Node2CDO := Node2Data.CDO;
//
if (Node1CDO = nil) or (Node2CDO = nil) then begin
Result := 0;
end else if (Node1CDO is TDomainObjectList) <> (Node2CDO is TDomainObjectList) then begin
if Node1CDO is TDomainObjectList then begin
Result := -1;
end else begin
Result := 1;
end;
end else begin
Result := AnsiCompareText(Node1CDO.SortString, Node2CDO.SortString);
end;
end;
*)
end;
procedure TForm1.VirtualStringTree1DblClick(Sender: TObject);
begin
(*
procedure TBaseTreeFrame.Frame_VstDblClick(Sender: TObject);
var
ACDO: TCustomDomainObject;
NodeData: ^RTreeData;
Tree: TBaseVirtualTree;
begin
inherited;
if Sender is TBaseVirtualTree then begin
Tree := TBaseVirtualTree(Sender);
if Tree.FocusedNode <> nil then begin
NodeData := Tree.GetNodeData(Tree.FocusedNode);
ACDO := NodeData.CDO;
HandleDoubleClicked(ACDO);
end;
end;
end;
procedure TBaseTreeFrame.HandleDoubleClicked(ACDO: TCustomDomainObject);
begin
DoDoubleClicked(ACDO);
end;
procedure TBaseTreeFrame.DoDoubleClicked(ACDO: TCustomDomainObject);
begin
if assigned(FOnDoubleClicked) then begin
FOnDoubleClicked(ACDO);
end;
end;
*)
end;
procedure TForm1.VirtualStringTree1FocusChanged(Sender: TBaseVirtualTree; Node:
PVirtualNode; Column: TColumnIndex);
begin
(*
procedure TBaseTreeFrame.Frame_VstFocusChanged(Sender: TBaseVirtualTree;
Node: PVirtualNode; Column: TColumnIndex);
var
ACDO: TCustomDomainObject;
NodeData: ^RTreeData;
begin
inherited;
NodeData := Sender.GetNodeData(Node);
ACDO := NodeData.CDO;
HandleSelectionChanged(ACDO);
end;
procedure TBaseTreeFrame.HandleSelectionChanged(ACDO: TCustomDomainObject);
begin
DoSelectionChanged(ACDO);
end;
procedure TBaseTreeFrame.DoSelectionChanged(ACDO: TCustomDomainObject);
begin
if assigned(FOnSelectionChanged) then begin
FOnSelectionChanged(ACDO);
end;
end;
*)
end;
procedure TForm1.VirtualStringTree1GetImageIndex(Sender: TBaseVirtualTree;
Node: PVirtualNode; Kind: TVTImageKind; Column: TColumnIndex; var Ghosted:
Boolean; var ImageIndex: Integer);
begin
(*
procedure TBaseTreeFrame.Frame_VstGetImageIndex(Sender: TBaseVirtualTree;
Node: PVirtualNode; Kind: TVTImageKind; Column: TColumnIndex;
var Ghosted: Boolean; var ImageIndex: Integer);
var
ACDO: TCustomDomainObject;
NodeData: ^RTreeData;
begin
inherited;
Case Column of
-1, 0 : begin
NodeData := Sender.GetNodeData(Node);
ACDO := NodeData.CDO;
case Kind of
ikState: ImageIndex := -1;
ikNormal: ImageIndex := GetImageIndexFor(ACDO, false);
ikSelected: ImageIndex := GetImageIndexFor(ACDO, true);
ikOverlay: ImageIndex := -1;
else
ImageIndex := -1;
end;
end;
else
end;
*)
end;
procedure TForm1.VirtualStringTree1GetText(Sender: TBaseVirtualTree; Node:
PVirtualNode; Column: TColumnIndex; TextType: TVSTTextType; var CellText:
string);
var
NodeData: ^RTreeData;
begin
NodeData := Sender.GetNodeData(Node);
if GetColumnText(NodeData.CDO, Column, {var}CellText) then
else begin
if Assigned(NodeData.CDO) then begin
case Column of
-1, 0: CellText := NodeData.CDO.DisplayString;
end;
end;
end;
end;
procedure TForm1.VirtualStringTree1InitChildren(Sender: TBaseVirtualTree; Node:
PVirtualNode; var ChildCount: Cardinal);
var
NodeData: ^RTreeData;
begin
// This is called when user has clicked on a plus sign.
// We only need to tell the tree for how many children to prepare.
ChildCount := 0;
NodeData := Sender.GetNodeData(Node);
if Assigned(NodeData.CDO) then begin
ChildCount := NodeData.CDO.Count;
end;
end;
procedure TForm1.VirtualStringTree1InitNode(Sender: TBaseVirtualTree;
ParentNode, Node: PVirtualNode; var InitialStates: TVirtualNodeInitStates);
var
ParentNodeData: ^RTreeData;
ParentNodeCDO: TCustomDomainObject;
NodeData: ^RTreeData;
begin
if Assigned(ParentNode) then begin
ParentNodeData := VirtualStringTree1.GetNodeData(ParentNode);
ParentNodeCDO := ParentNodeData.CDO;
end else begin
ParentNodeCDO := CDO;
end;
NodeData := VirtualStringTree1.GetNodeData(Node);
if Assigned(NodeData.CDO) then begin
// CDO was already set, for example when added through AddDomainObject.
end else begin
if Assigned(ParentNodeCDO) then begin
if ParentNodeCDO.Count > Node.Index then begin
NodeData.CDO := ParentNodeCDO.CDO[Node.Index];
if NodeData.CDO.Count > 0 then begin
InitialStates := InitialStates + [ivsHasChildren];
end;
// FNodeList.Add(NodeData.CDO, Node);
end;
end;
end;
Sender.CheckState[Node] := csUncheckedNormal;
end;
end.
And the old one
Check in second answer, I exceeded the text character limit...

Delphi - ListView or similar with owner draw button

How do I do create a listview (or similar) with a button on each line? The button needs to be able to have different text/color on each line as required.
I'm sure Virtual Treeview would be perfect for this, but I'm a little lost with it.
Thanks
-Brad

With a virtualtreeview...... add vstButton to your uses and select your Virtualtreeview in the object inspector and set the following events for your tree:
procedure TForm1.VSTCreateEditor(Sender: TBaseVirtualTree; Node: PVirtualNode;
Column: TColumnIndex; out EditLink: IVTEditLink);
begin
EditLink:=TStringEditLink.Create;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
VST.NodeDataSize := SizeOf(TTreeData);
AddRandomNodesToTree(Vst);
end;
procedure TForm1.VSTFreeNode(Sender: TBaseVirtualTree;
Node: PVirtualNode);
var
Data: PTreeData;
begin
Data:=VST.GetNodeData(Node);
if Assigned(Data) then begin
Data^.Column0 := '';
Data^.Column1 := '';
Data^.Column2 := '';
end;
end;
procedure TForm1.VSTGetText(Sender: TBaseVirtualTree;
Node: PVirtualNode; Column: TColumnIndex; TextType: TVSTTextType;
var CellText: string);
var
Data: PTreeData;
begin
Data := VST.GetNodeData(Node);
case Column of
0: CellText := Data^.Column0;
1: CellText := Data^.Column1;
2: CellText := Data^.Column2;
end;
end;
procedure TForm1.VSTNewText(Sender: TBaseVirtualTree; Node: PVirtualNode;
Column: TColumnIndex; NewText: string);
Var
Data: PTreeData;
begin
Data := VST.GetNodeData(Node);
Case Column of
0: Data^.Column0:= NewText;
1: Data^.Column1:= NewText;
2: Data^.Column2:= NewText;
End;
end;
procedure TForm1.VSTPaintText(Sender: TBaseVirtualTree;
const TargetCanvas: TCanvas; Node: PVirtualNode; Column: TColumnIndex;
TextType: TVSTTextType);
Var
Data: PTreeData;
begin
if Odd(Node.Index) then
TargetCanvas.Font.Color:= clRed;
end;
... this assumes the record is:
type
PTreeData = ^TTreeData;
TTreeData = record
Column0: String;
Column1: String;
Column2: String;
end;
...add the following unit:
unit vstButton;
interface
uses
Classes, SysUtils, Forms, Controls, Graphics, Dialogs, VirtualTrees,
messages, windows, StdCtrls, ShlObj;
type
TStringEditLink = class(TInterfacedObject, IVTEditLink)
private
FEdit: TWinControl;
FTree: TVirtualStringTree;
FNode: PVirtualNode;
FColumn: Integer;
FSelectedFolder: string;
protected
procedure ButtonClick(Sender: TObject);
public
destructor Destroy; override;
function BeginEdit: Boolean; stdcall;
function CancelEdit: Boolean; stdcall;
function EndEdit: Boolean; stdcall;
function GetBounds: TRect; stdcall;
function PrepareEdit(Tree: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex): Boolean; stdcall;
procedure ProcessMessage(var Message: TMessage); stdcall;
procedure SetBounds(R: TRect); stdcall;
end;
function GetFolderDialog(Handle: Integer; Caption: string; var strFolder: string): Boolean;
implementation
destructor TStringEditLink.Destroy;
begin
FEdit.Free;
inherited;
end;
procedure TStringEditLink.ButtonClick(Sender: TObject);
var
s: string;
begin
s := 'c:\';
if GetFolderDialog(Application.Handle, 'Select a folder', s) then
FSelectedFolder := s;
FTree.EndEditNode;
FTree.setfocus;
end;
function TStringEditLink.BeginEdit: Boolean;
begin
Result := True;
FSelectedFolder := FTree.Text[FNode, FColumn];
TButton(FEdit).CAption := FTree.Text[FNode, FColumn];
FEdit.Show;
FEdit.SetFocus;
end;
function TStringEditLink.CancelEdit: Boolean;
begin
Result := True;
FEdit.Hide;
FTree.EndEditNode;
FTree.setfocus;
end;
function TStringEditLink.EndEdit: Boolean;
var
S: WideString;
begin
Result := True;
FTree.Text[FNode, FColumn] := FSelectedFolder;
FTree.InvalidateNode(FNode);
FEdit.Hide;
FTree.SetFocus;
end;
function TStringEditLink.GetBounds: TRect;
begin
Result := FEdit.BoundsRect;
end;
function TStringEditLink.PrepareEdit(Tree: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex): Boolean;
begin
Result := True;
FTree := Tree as TVirtualStringTree;
FNode := Node;
FColumn := Column;
FEdit.Free;
FEdit := nil;
FEdit := TButton.Create(nil);
with FEdit as TButton do
begin
Visible := False;
Parent := Tree;
Font.Color := FTree.Colors.HeaderHotColor;
OnClick := ButtonClick;
end;
end;
procedure TStringEditLink.ProcessMessage(var Message: TMessage);
begin
FEdit.WindowProc(Message);
end;
procedure TStringEditLink.SetBounds(R: TRect);
var
Dummy: Integer;
begin
FTree.Header.Columns.GetColumnBounds(FColumn, Dummy, R.Right);
FEdit.BoundsRect := R;
end;
//------------------------------------------------------------------------------\\
function BrowseCallbackProc(hwnd: HWND; uMsg: UINT; lParam: LPARAM; lpData: LPARAM): Integer; stdcall;
begin
if (uMsg = BFFM_INITIALIZED) then
SendMessage(hwnd, BFFM_SETSELECTION, 1, lpData);
BrowseCallbackProc := 0;
end;
function GetFolderDialog(Handle: Integer; Caption: string; var strFolder: string): Boolean;
const
BIF_STATUSTEXT = $0004;
BIF_NEWDIALOGSTYLE = $0040;
BIF_RETURNONLYFSDIRS = $0080;
BIF_SHAREABLE = $0100;
BIF_USENEWUI = BIF_EDITBOX or BIF_NEWDIALOGSTYLE;
var
BrowseInfo: TBrowseInfo;
ItemIDList: PItemIDList;
JtemIDList: PItemIDList;
Path: PChar;
begin
Result := False;
Path := StrAlloc(MAX_PATH);
SHGetSpecialFolderLocation(Handle, CSIDL_DRIVES, JtemIDList);
with BrowseInfo do
begin
hwndOwner := GetActiveWindow;
pidlRoot := JtemIDList;
SHGetSpecialFolderLocation(hwndOwner, CSIDL_DRIVES, JtemIDList);
{ return display name of item selected }
pszDisplayName := StrAlloc(MAX_PATH);
{ set the title of dialog }
lpszTitle := PChar(Caption);//'Select the folder';
{ flags that control the return stuff }
lpfn := #BrowseCallbackProc;
{ extra info that's passed back in callbacks }
lParam := LongInt(PChar(strFolder));
end;
ItemIDList := SHBrowseForFolder(BrowseInfo);
if (ItemIDList <> nil) then
if SHGetPathFromIDList(ItemIDList, Path) then
begin
strFolder := Path;
Result := True
end;
end;
End.
the above code is based upon code found at this website:
http://wiki.freepascal.org/VirtualTreeview_Example_for_Lazarus
If you look at the unit vstButton, to get a TEdit, or TCombo...etc... just replace any TButton reference with TEdit or TCombo etc... adjust events for it etc... The above link code actually uses a TCombo
that website helped me alot to learn how to use the virtualtreeview
the above code will insert a Tbutton into every cell, and when you click on the button it will open a BrowseForFolder dialog and insert the result back into the virtualtreeview cell
Hope this helps
did you want a button visible in a cell column all the time? Could simulate the button with an image... like a dropdown mark on one side of the cell

Resources