journaling/ibcontrols/DBTreeView.pas

(*
 *  IBX For Lazarus (Firebird Express)
 *
 *  The contents of this file are subject to the Initial Developer's
 *  Public License Version 1.0 (the "License"); you may not use this
 *  file except in compliance with the License. You may obtain a copy
 *  of the License here:
 *
 *    http://www.firebirdsql.org/index.php?op=doc&id=idpl
 *
 *  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 Initial Developer of the Original Code is Tony Whyman.
 *
 *  The Original Code is (C) 2015 Tony Whyman, MWA Software
 *  (http://www.mwasoftware.co.uk).
 *
 *  All Rights Reserved.
 *
 *  Contributor(s): ______________________________________.
 *
*)
unit DBTreeView;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs, ComCtrls,
  DB;

type
  {
    TDBTreeView is intended to be a data aware descendent of TCustomTreeView and used to display
    hierarchically structured data in a natural manner. Nodes can be deleted, moved
    and added to the tree and each change is reflected in the underlying dataset. The
    Node text can similarly be edited.
  }

  TVariantArray = array of variant;

  TDBTreeView = class;

  { TDBTreeViewDatalink }

  TDBTreeViewDatalink = class(TDataLink)
  private
    FOwner: TDBTreeView;
  protected
    procedure ActiveChanged; override;
    procedure DataSetChanged; override;
    procedure RecordChanged(Field: TField); override;
    procedure UpdateData; override;
  public
    constructor Create(AOwner: TDBTreeView);
  end;

  { TDBTreeNode }

  TDBTreeNode = class(TTreeNode)
  private
    FKeyValue: variant;
  public
    constructor Create(AnOwner: TTreeNodes); override;
    procedure DeleteAll;
    property KeyValue: variant read FKeyValue;
  end;

  TDBTreeView = class(TCustomTreeView)
  private
    { Private declarations }
    FDataLink: TDBTreeViewDatalink;
    FHasChildField: string;
    FImageIndexField: string;
    FKeyField: string;
    FSelectedIndexField: string;
    FTextField: string;
    FParentField: string;
    FNoAddNodeToDataset: boolean;
    FRelationName: string;
    FModifiedNode: TDBTreeNode;
    FLastSelected: TVariantArray;
    procedure ActiveChanged(Sender: TObject);
    procedure AddNodes;
    procedure DataSetChanged(Sender: TObject);
    function GetDataSet: TDataSet;
    function GetDataSource: TDataSource;
    function GetSelectedKeyValue: variant;
    procedure NodeMoved(Node: TTreeNode);
    procedure RecordChanged(Sender: TObject; Field: TField);
    procedure SetHasChildField(AValue: string);
    procedure SetImageIndexField(AValue: string);
    procedure SetKeyField(AValue: string);
    procedure SetSelectedIndexField(AValue: string);
    procedure SetTextField(AValue: string);
    procedure SetDataSource(AValue: TDataSource);
    procedure SetParentField(AValue: string);
    procedure UpdateData(Sender: TObject);
   protected
     { Protected declarations }
     FExpandNode: TTreeNode;
     FUpdateNode: TDBTreeNode;
     FUpdating: boolean;
     FLocatingNode: boolean;
     procedure Added(Node: TTreeNode); override;
     procedure DataSourceChanged; virtual; abstract;
     procedure DoOnDataInit; virtual;
     procedure Delete(Node: TTreeNode); override;
     procedure Change(Node: TTreeNode); override;
     function CreateNode: TTreeNode; override;
     function CanEdit(Node: TTreeNode): Boolean; override;
     procedure Expand(Node: TTreeNode); override;
     function GetRelationNameQualifier: string;
     procedure Loaded; override;
     procedure NodeChanged(Node: TTreeNode; ChangeEvent: TTreeNodeChangeReason); override;
     procedure Notification(AComponent: TComponent; Operation: TOperation); override;
     procedure NodeUpdated(Node: TTreeNode); virtual;
     procedure Reinitialise;
     procedure RefreshDataset; virtual; abstract;
     function ScrollToNode(Node: TDBTreeNode): boolean; virtual;
  public
    { Public declarations }
    constructor Create(TheComponent: TComponent); override;
    destructor Destroy; override;
    function FindNode(KeyValuePath: TVariantArray; SelectNode: boolean): TDBTreeNode; overload;
    function FindNode(KeyValue: variant): TDBTreeNode; overload;
    function GetNodePath(Node: TTreeNode): TVariantArray;
    property DataSet: TDataSet read GetDataSet;
    property SelectedKeyValue: variant read GetSelectedKeyValue;
  published
    { Published declarations }
    property Align;
    property Anchors;
    property AutoExpand;
    property BorderSpacing;
    //property BiDiMode;
    property BackgroundColor;
    property BorderStyle;
    property BorderWidth;
    property Color;
    property Constraints;
    property TextField: string read FTextField write SetTextField;
    property DataSource: TDataSource read GetDataSource write SetDataSource;
    property DefaultItemHeight;
    property DragKind;
    property DragCursor;
    property DragMode;
    property Enabled;
    property ExpandSignColor;
    property ExpandSignType;
    property Font;
    property HideSelection;
    property HotTrack;
    property Images;
    property Indent;
    property HasChildField: string read FHasChildField write SetHasChildField;
    property ImageIndexField: string read FImageIndexField write SetImageIndexField;
    property SelectedIndexField: string read FSelectedIndexField write SetSelectedIndexField;
    property KeyField: string read FKeyField write SetKeyField;
    property MultiSelect;
    property MultiSelectStyle;
    //property ParentBiDiMode;
    property ParentColor default False;
    property ParentField: string read FParentField write SetParentField;
    property ParentFont;
    property ParentShowHint;
    property PopupMenu;
    property ReadOnly;
    property RelationName: string read FRelationName write FRelationName;
    property RightClickSelect;
    property RowSelect;
    property ScrollBars;
    property SelectionColor;
    property ShowButtons;
    property ShowHint;
    property ShowLines;
    property ShowRoot;
    property StateImages;
    property TabOrder;
    property TabStop default True;
    property Tag;
    property ToolTips;
    property Visible;
    property OnAddition;
    property OnAdvancedCustomDraw;
    property OnAdvancedCustomDrawItem;
    property OnChange;
    property OnChanging;
    property OnClick;
    property OnCollapsed;
    property OnCollapsing;
    property OnCompare;
    property OnContextPopup;
    property OnCreateNodeClass;
    property OnCustomCreateItem;
    property OnCustomDraw;
    property OnCustomDrawItem;
    property OnDblClick;
    property OnDeletion;
    property OnDragDrop;
    property OnDragOver;
    property OnEdited;
    property OnEditing;
    property OnEditingEnd;
    //property OnEndDock;
    property OnEndDrag;
    property OnEnter;
    property OnExit;
    property OnExpanded;
    property OnExpanding;
    property OnGetImageIndex;
    property OnGetSelectedIndex;
    property OnKeyDown;
    property OnKeyPress;
    property OnKeyUp;
    property OnMouseDown;
    property OnMouseEnter;
    property OnMouseLeave;
    property OnMouseMove;
    property OnMouseUp;
    property OnNodeChanged;
    property OnSelectionChanged;
    property OnShowHint;
    //property OnStartDock;
    property OnStartDrag;
    property OnUTF8KeyPress;
    property Options;
    property Items;
    property TreeLineColor;
    property TreeLinePenStyle;
  end;

  function StrIntListToVar(s: string): TVariantArray;
  function VarToStrIntList(a: TVariantArray): string;

implementation

uses Variants;

function StrIntListToVar(s: string): TVariantArray;
var i, idx: integer;
    List: TStringList;
begin
  List := TStringList.Create;
  try
    idx := 1;
    List.Clear;
    while idx <= Length(s) do
       List.Add(ExtractFieldName(s,idx));

    Setlength(Result,List.Count);
    for i := 0 to List.Count - 1 do
        Result[i] := StrToInt(List[i])
  finally
    List.Free
  end;
end;

function VarToStrIntList(a: TVariantArray): string;
var i: integer;
begin
  for i := 0 to Length(a) - 1 do
      if VarIsOrdinal(a[i]) then
      begin
        if i = 0 then
           Result := IntToStr(a[i])
        else
          Result := Result + ';' + IntToStr(a[i])
      end
      else
        raise Exception.Create('Ordinal Type Expected when converting to integer string');
end;

{ TDBTreeNode }

constructor TDBTreeNode.Create(AnOwner: TTreeNodes);
begin
  inherited Create(AnOwner);
  FKeyValue := NULL;
end;

procedure TDBTreeNode.DeleteAll;
var Node, NextNode: TTreeNode;
begin
    Expand(true);
    Node := GetFirstChild;
    while Node <> nil do
    begin
      NextNode := Node.GetNextSibling;
      TDBTreeNode(Node).DeleteAll;
      Node := NextNode;
    end;
    Delete
end;

{ TDBTreeView }

procedure TDBTreeView.ActiveChanged(Sender: TObject);
begin
  if (csDesigning in ComponentState) then Exit;
  DataSourceChanged;
  if assigned(DataSet) and not DataSet.Active then
  begin
    if not assigned(FExpandNode) and not assigned(FUpdateNode) then {must really be closing}
      Reinitialise
  end
  else
  begin
    AddNodes;
    if not FLocatingNode and (Selected = nil) and (Items.TopLvlCount > 0) then
    begin
      if Length(FLastSelected) > 0 then
         Selected := FindNode(FLastSelected,true)
      else
        Selected := Items.TopLvlItems[0];
    end
  end
end;

procedure TDBTreeView.AddNodes;
var Node: TTreeNode;
    ChildCount: integer;
begin
  if assigned(FExpandNode) or (Items.Count = 0) then
  begin
    ChildCount := 0;
    FNoAddNodeToDataset := true;
    try
      DataSet.First;
      while not DataSet.EOF do
      begin
        if (FExpandNode = nil) or (TDBTreeNode(FExpandNode).KeyValue <> DataSet.FieldByName(KeyField).AsVariant) then
        begin
          Node := Items.AddChild(FExpandNode,DataSet.FieldByName(TextField).AsString);
          Node.HasChildren := (HasChildField = '') or (DataSet.FieldByName(HasChildField).AsInteger <> 0);
          Inc(ChildCount);
        end;
        DataSet.Next
      end;
    finally
      FNoAddNodeToDataset := false
    end;
    if assigned(FExpandNode) then
      FExpandNode.HasChildren := ChildCount > 0;
    FExpandNode := nil
  end
end;

procedure TDBTreeView.DataSetChanged(Sender: TObject);
begin
//  Do nothing;
end;

function TDBTreeView.GetDataSet: TDataSet;
begin
  Result := FDataLink.DataSet
end;

function TDBTreeView.GetDataSource: TDataSource;
begin
  Result := FDataLink.DataSource
end;

function TDBTreeView.GetRelationNameQualifier: string;
begin
  if FRelationName <> '' then
     Result := FRelationName + '.'
  else
    Result := ''
end;

function TDBTreeView.GetSelectedKeyValue: variant;
begin
  Result := NULL;
  if assigned(Selected) and (Selected is TDBTreeNode) then
     Result := TDBTreeNode(Selected).KeyValue
end;

procedure TDBTreeView.NodeMoved(Node: TTreeNode);
begin
  {Need to update Parent}
  if ScrollToNode(TDBTreeNode(Node))  then
  begin
      FDataLink.Edit;
      FModifiedNode := TDBTreeNode(Node)
  end;
end;

procedure TDBTreeView.NodeUpdated(Node: TTreeNode);
begin
  {Need to Update List Field}
  if ScrollToNode(TDBTreeNode(Node)) then
  begin
    FDataLink.Edit;
    FModifiedNode := TDBTreeNode(Node);
    FDataLink.UpdateRecord
  end;
end;

procedure TDBTreeView.RecordChanged(Sender: TObject; Field: TField);
var Node: TDBTreeNode;
    Destination: TDBTreeNode;
begin
  if DataSet.State = dsInsert then Exit;

  if assigned(Field) and (Field.FieldName = TextField) then
  begin
    Node := FindNode(DataSet.FieldByName(KeyField).AsVariant);
    if assigned(Node) then
    begin
      FUpdating := true;
      try
        Node.Text := Field.Text
      finally
        FUpdating := false
      end;
    end;
  end
  else
  if assigned(Field) and (Field.FieldName = ImageIndexField) then
  begin
    Node := FindNode(DataSet.FieldByName(KeyField).AsVariant);
    if assigned(Node) then
    begin
      FUpdating := true;
      try
        Node.ImageIndex := Field.AsInteger
      finally
        FUpdating := false
      end;
    end;
  end
  else
  if assigned(Field) and (Field.FieldName = ParentField) then
  begin
    Node := FindNode(DataSet.FieldByName(KeyField).AsVariant);
    if assigned(Node)  then
    begin
      if DataSet.FieldByName(ParentField).IsNull then
         Destination := nil
      else
        Destination := FindNode(DataSet.FieldByName(ParentField).AsVariant);

      if (Destination = nil) or (Destination = Node.Parent) then Exit;

      FUpdating := true;
      try
        Node.MoveTo(Destination,naAddChild);
      finally
        FUpdating := false
      end;
    end;
  end
end;

procedure TDBTreeView.SetHasChildField(AValue: string);
begin
  if FHasChildField = AValue then Exit;
  FHasChildField := AValue;
  Reinitialise
end;

procedure TDBTreeView.SetImageIndexField(AValue: string);
begin
  if FImageIndexField = AValue then Exit;
  FImageIndexField := AValue;
  Reinitialise
end;

procedure TDBTreeView.SetKeyField(AValue: string);
begin
  if FKeyField = AValue then Exit;
  FKeyField := AValue;
  Reinitialise
end;

procedure TDBTreeView.SetSelectedIndexField(AValue: string);
begin
  if FSelectedIndexField = AValue then Exit;
  FSelectedIndexField := AValue;
  Reinitialise;
end;

procedure TDBTreeView.SetTextField(AValue: string);
begin
  if FTextField = AValue then Exit;
  FTextField := AValue;
  Reinitialise
end;

procedure TDBTreeView.SetDataSource(AValue: TDataSource);
begin
  FDataLink.DataSource := AValue;
  DataSourceChanged;
end;

procedure TDBTreeView.SetParentField(AValue: string);
begin
  if FParentField = AValue then Exit;
  FParentField := AValue;
  Reinitialise
end;

function TDBTreeView.ScrollToNode(Node: TDBTreeNode): boolean;
begin
  Result :=  assigned(DataSet) and DataSet.Active and assigned(Node) and not varIsNull(Node.KeyValue);
  if Result then
  begin
    if DataSet.Active and (DataSet.RecordCount > 0)
         and DataSet.Locate(KeyField,Node.KeyValue,[]) then Exit;

    FUpdateNode := Node;
    try
      RefreshDataset;
    finally
      FUpdateNode := nil
    end;
    Result := DataSet.FieldByName(KeyField).AsVariant = Node.KeyValue
  end;
end;

procedure TDBTreeView.UpdateData(Sender: TObject);
begin
  if assigned(FModifiedNode) then
  begin
    DataSet.FieldByName(TextField).AsString := FModifiedNode.Text;
    if FModifiedNode.Parent = nil then
      DataSet.FieldByName(ParentField).Clear
    else
      DataSet.FieldByName(ParentField).AsVariant := TDBTreeNode(FModifiedNode.Parent).KeyValue;
    FModifiedNode := nil
  end
end;

procedure TDBTreeView.Added(Node: TTreeNode);
begin
  if assigned(DataSet) and DataSet.Active then
  begin
    if not FNoAddNodeToDataset then
    begin
      DataSet.Append;
      if (Node.Text = '') and not DataSet.FieldByName(TextField).IsNull then
         Node.Text := DataSet.FieldByName(TextField).AsString;
      FModifiedNode := TDBTreeNode(Node);
      FDataLink.UpdateRecord;
    end;
    DoOnDataInit;
    TDBTreeNode(Node).FKeyValue := DataSet.FieldByName(KeyField).AsVariant;
    if ImageIndexField <> '' then
      Node.ImageIndex := DataSet.FieldByName(ImageIndexField).AsInteger;
    if SelectedIndexField <> '' then
      Node.SelectedIndex := DataSet.FieldByName(SelectedIndexField).AsInteger;
  end;
  inherited Added(Node);
end;

procedure TDBTreeView.DoOnDataInit;
begin
  //Do nothing
end;

procedure TDBTreeView.Delete(Node: TTreeNode);
begin
  if not (tvsUpdating in States) {TreeNodes being cleared}
     and not (tvsManualNotify in States) {Tree Collapse with node delete}
     and ScrollToNode(TDBTreeNode(Node)) then
     DataSet.Delete;
  inherited Delete(Node);
end;

procedure TDBTreeView.Change(Node: TTreeNode);
begin
  inherited Change(Node);
  ScrollToNode(TDBTreeNode(Node));
end;

function TDBTreeView.CreateNode: TTreeNode;
var
  NewNodeClass: TTreeNodeClass;
begin
  Result := nil;
  if Assigned(OnCustomCreateItem) then
    OnCustomCreateItem(Self, Result);
  if Result = nil then
  begin
    NewNodeClass:=TDBTreeNode;
    if Assigned(OnCreateNodeClass) then
      OnCreateNodeClass(Self,NewNodeClass);
    Result := NewNodeClass.Create(Items);
  end;
end;

function TDBTreeView.CanEdit(Node: TTreeNode): Boolean;
begin
  Result := inherited CanEdit(Node)
              and assigned(DataSet) and not DataSet.FieldByName(TextField).ReadOnly
end;

procedure TDBTreeView.Expand(Node: TTreeNode);
begin
  inherited Expand(Node);
  if Node.HasChildren and assigned(DataSet) and (Node.GetFirstChild = nil) then
  begin
    FExpandNode := Node;
    RefreshDataset;
    Selected := Node;
  end;
end;

procedure TDBTreeView.Loaded;
begin
  inherited Loaded;
  DataSourceChanged;
  Reinitialise
end;

procedure TDBTreeView.NodeChanged(Node: TTreeNode;
  ChangeEvent: TTreeNodeChangeReason);
begin
  inherited NodeChanged(Node, ChangeEvent);
  if not FNoAddNodeToDataset and not FUpdating then
  case ChangeEvent of
  ncTextChanged:
    NodeUpdated(Node);
  ncParentChanged:
    NodeMoved(Node);
  end;
end;

procedure TDBTreeView.Notification(AComponent: TComponent; Operation: TOperation
  );
begin
  inherited Notification(AComponent, Operation);
  if (Operation = opRemove) and
     (FDataLink <> nil) and (AComponent = DataSource) then
     DataSource := nil;
end;

procedure TDBTreeView.Reinitialise;
begin
  if [csDesigning,csLoading] * ComponentState <> [] then Exit;
  FLastSelected := GetNodePath(Selected);
  Items.Clear;
end;

constructor TDBTreeView.Create(TheComponent: TComponent);
begin
  inherited Create(TheComponent);
  FDataLink := TDBTreeViewDatalink.Create(self);
end;

destructor TDBTreeView.Destroy;
begin
  if assigned(FDataLink) then FDataLink.Free;
  inherited Destroy;
end;

function TDBTreeView.FindNode(KeyValuePath: TVariantArray; SelectNode: boolean
  ): TDBTreeNode;
var Node: TTreeNode;
    i,j: integer;
begin
  Result := nil;
  if Length(KeyValuePath) = 0 then Exit;

  FLocatingNode := true;
  try
   for j := 0 to Items.TopLvlCount - 1 do
   begin
    Node := Items.TopLvlItems[j];
    i := 0;
    Node.Expand(false);
    while assigned(Node)  do
    begin
      if not VarIsNull(TDBTreeNode(Node).KeyValue) and
                        (TDBTreeNode(Node).KeyValue = KeyValuePath[i]) then
      begin
        Inc(i);
        if i = Length(KeyValuePath) then
        begin
          Result := TDBTreeNode(Node);
          if SelectNode then
             Selected := Node;
          Exit
        end
        else
        begin
          Node.Expand(false);
          Node := Node.GetFirstChild;
        end
      end
      else
        Node := Node.GetNextSibling
    end
   end
  finally
    FLocatingNode := false
  end
end;

function TDBTreeView.FindNode(KeyValue: variant): TDBTreeNode;
var i: integer;
begin
  Result := nil;
  if (Selected <> nil) and (TDBTreeNode(Selected).KeyValue = KeyValue) then
     Result := TDBTreeNode(Selected)
  else
  {Find it the hard way}
  begin
    FullExpand;
    for i := 0 to Items.Count -1 do
      if TDBTreeNode(Items[i]).KeyValue = KeyValue then
      begin
        Result := TDBTreeNode(Items[i])
      end;
  end;
end;

function TDBTreeView.GetNodePath(Node: TTreeNode): TVariantArray;
var aParent: TTreeNode;
    i: integer;
begin
  if not assigned(Node) or not (Node is TDBTreeNode) then
     SetLength(Result,0)
  else
  begin
    {Count length of Path}
    i := 1;
    aParent := Node.Parent;
    while (aParent <> nil) do
    begin
        Inc(i);
        aParent := aParent.Parent
    end;

    {Save Path}
    Setlength(Result,i);
    while i > 0 do
    begin
      Dec(i);
      Result[i] := TDBTreeNode(Node).KeyValue;
      Node := Node.Parent
    end;
  end;
end;

{ TDBTreeViewDatalink }

procedure TDBTreeViewDatalink.ActiveChanged;
begin
  FOwner.ActiveChanged(self)
end;

procedure TDBTreeViewDatalink.DataSetChanged;
begin
  FOwner.DataSetChanged(self)
end;

procedure TDBTreeViewDatalink.RecordChanged(Field: TField);
begin
  FOwner.RecordChanged(self,Field);
end;

procedure TDBTreeViewDatalink.UpdateData;
begin
  FOwner.UpdateData(self)
end;

constructor TDBTreeViewDatalink.Create(AOwner: TDBTreeView);
begin
  inherited Create;
  FOwner := AOwner
end;

end.
Revision:	362
Committed:	Tue Dec 7 13:27:39 2021 UTC (3 years ago) by tony
Content type:	text/x-pascal
File size:	20278 byte(s)
Log Message:	initiate test release
#	Content
1	(*
2	* IBX For Lazarus (Firebird Express)
3	*
4	* The contents of this file are subject to the Initial Developer's
5	* Public License Version 1.0 (the "License"); you may not use this
6	* file except in compliance with the License. You may obtain a copy
7	* of the License here:
8	*
9	* http://www.firebirdsql.org/index.php?op=doc&id=idpl
10	*
11	* Software distributed under the License is distributed on an "AS
12	* IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or
13	* implied. See the License for the specific language governing rights
14	* and limitations under the License.
15	*
16	* The Initial Developer of the Original Code is Tony Whyman.
17	*
18	* The Original Code is (C) 2015 Tony Whyman, MWA Software
19	* (http://www.mwasoftware.co.uk).
20	*
21	* All Rights Reserved.
22	*
23	* Contributor(s): ______________________________________.
24	*
25	*)
26	unit DBTreeView;
27
28	{$mode objfpc}{$H+}
29
30	interface
31
32	uses
33	Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs, ComCtrls,
34	DB;
35
36	type
37	{
38	TDBTreeView is intended to be a data aware descendent of TCustomTreeView and used to display
39	hierarchically structured data in a natural manner. Nodes can be deleted, moved
40	and added to the tree and each change is reflected in the underlying dataset. The
41	Node text can similarly be edited.
42	}
43
44	TVariantArray = array of variant;
45
46	TDBTreeView = class;
47
48	{ TDBTreeViewDatalink }
49
50	TDBTreeViewDatalink = class(TDataLink)
51	private
52	FOwner: TDBTreeView;
53	protected
54	procedure ActiveChanged; override;
55	procedure DataSetChanged; override;
56	procedure RecordChanged(Field: TField); override;
57	procedure UpdateData; override;
58	public
59	constructor Create(AOwner: TDBTreeView);
60	end;
61
62	{ TDBTreeNode }
63
64	TDBTreeNode = class(TTreeNode)
65	private
66	FKeyValue: variant;
67	public
68	constructor Create(AnOwner: TTreeNodes); override;
69	procedure DeleteAll;
70	property KeyValue: variant read FKeyValue;
71	end;
72
73	TDBTreeView = class(TCustomTreeView)
74	private
75	{ Private declarations }
76	FDataLink: TDBTreeViewDatalink;
77	FHasChildField: string;
78	FImageIndexField: string;
79	FKeyField: string;
80	FSelectedIndexField: string;
81	FTextField: string;
82	FParentField: string;
83	FNoAddNodeToDataset: boolean;
84	FRelationName: string;
85	FModifiedNode: TDBTreeNode;
86	FLastSelected: TVariantArray;
87	procedure ActiveChanged(Sender: TObject);
88	procedure AddNodes;
89	procedure DataSetChanged(Sender: TObject);
90	function GetDataSet: TDataSet;
91	function GetDataSource: TDataSource;
92	function GetSelectedKeyValue: variant;
93	procedure NodeMoved(Node: TTreeNode);
94	procedure RecordChanged(Sender: TObject; Field: TField);
95	procedure SetHasChildField(AValue: string);
96	procedure SetImageIndexField(AValue: string);
97	procedure SetKeyField(AValue: string);
98	procedure SetSelectedIndexField(AValue: string);
99	procedure SetTextField(AValue: string);
100	procedure SetDataSource(AValue: TDataSource);
101	procedure SetParentField(AValue: string);
102	procedure UpdateData(Sender: TObject);
103	protected
104	{ Protected declarations }
105	FExpandNode: TTreeNode;
106	FUpdateNode: TDBTreeNode;
107	FUpdating: boolean;
108	FLocatingNode: boolean;
109	procedure Added(Node: TTreeNode); override;
110	procedure DataSourceChanged; virtual; abstract;
111	procedure DoOnDataInit; virtual;
112	procedure Delete(Node: TTreeNode); override;
113	procedure Change(Node: TTreeNode); override;
114	function CreateNode: TTreeNode; override;
115	function CanEdit(Node: TTreeNode): Boolean; override;
116	procedure Expand(Node: TTreeNode); override;
117	function GetRelationNameQualifier: string;
118	procedure Loaded; override;
119	procedure NodeChanged(Node: TTreeNode; ChangeEvent: TTreeNodeChangeReason); override;
120	procedure Notification(AComponent: TComponent; Operation: TOperation); override;
121	procedure NodeUpdated(Node: TTreeNode); virtual;
122	procedure Reinitialise;
123	procedure RefreshDataset; virtual; abstract;
124	function ScrollToNode(Node: TDBTreeNode): boolean; virtual;
125	public
126	{ Public declarations }
127	constructor Create(TheComponent: TComponent); override;
128	destructor Destroy; override;
129	function FindNode(KeyValuePath: TVariantArray; SelectNode: boolean): TDBTreeNode; overload;
130	function FindNode(KeyValue: variant): TDBTreeNode; overload;
131	function GetNodePath(Node: TTreeNode): TVariantArray;
132	property DataSet: TDataSet read GetDataSet;
133	property SelectedKeyValue: variant read GetSelectedKeyValue;
134	published
135	{ Published declarations }
136	property Align;
137	property Anchors;
138	property AutoExpand;
139	property BorderSpacing;
140	//property BiDiMode;
141	property BackgroundColor;
142	property BorderStyle;
143	property BorderWidth;
144	property Color;
145	property Constraints;
146	property TextField: string read FTextField write SetTextField;
147	property DataSource: TDataSource read GetDataSource write SetDataSource;
148	property DefaultItemHeight;
149	property DragKind;
150	property DragCursor;
151	property DragMode;
152	property Enabled;
153	property ExpandSignColor;
154	property ExpandSignType;
155	property Font;
156	property HideSelection;
157	property HotTrack;
158	property Images;
159	property Indent;
160	property HasChildField: string read FHasChildField write SetHasChildField;
161	property ImageIndexField: string read FImageIndexField write SetImageIndexField;
162	property SelectedIndexField: string read FSelectedIndexField write SetSelectedIndexField;
163	property KeyField: string read FKeyField write SetKeyField;
164	property MultiSelect;
165	property MultiSelectStyle;
166	//property ParentBiDiMode;
167	property ParentColor default False;
168	property ParentField: string read FParentField write SetParentField;
169	property ParentFont;
170	property ParentShowHint;
171	property PopupMenu;
172	property ReadOnly;
173	property RelationName: string read FRelationName write FRelationName;
174	property RightClickSelect;
175	property RowSelect;
176	property ScrollBars;
177	property SelectionColor;
178	property ShowButtons;
179	property ShowHint;
180	property ShowLines;
181	property ShowRoot;
182	property StateImages;
183	property TabOrder;
184	property TabStop default True;
185	property Tag;
186	property ToolTips;
187	property Visible;
188	property OnAddition;
189	property OnAdvancedCustomDraw;
190	property OnAdvancedCustomDrawItem;
191	property OnChange;
192	property OnChanging;
193	property OnClick;
194	property OnCollapsed;
195	property OnCollapsing;
196	property OnCompare;
197	property OnContextPopup;
198	property OnCreateNodeClass;
199	property OnCustomCreateItem;
200	property OnCustomDraw;
201	property OnCustomDrawItem;
202	property OnDblClick;
203	property OnDeletion;
204	property OnDragDrop;
205	property OnDragOver;
206	property OnEdited;
207	property OnEditing;
208	property OnEditingEnd;
209	//property OnEndDock;
210	property OnEndDrag;
211	property OnEnter;
212	property OnExit;
213	property OnExpanded;
214	property OnExpanding;
215	property OnGetImageIndex;
216	property OnGetSelectedIndex;
217	property OnKeyDown;
218	property OnKeyPress;
219	property OnKeyUp;
220	property OnMouseDown;
221	property OnMouseEnter;
222	property OnMouseLeave;
223	property OnMouseMove;
224	property OnMouseUp;
225	property OnNodeChanged;
226	property OnSelectionChanged;
227	property OnShowHint;
228	//property OnStartDock;
229	property OnStartDrag;
230	property OnUTF8KeyPress;
231	property Options;
232	property Items;
233	property TreeLineColor;
234	property TreeLinePenStyle;
235	end;
236
237	function StrIntListToVar(s: string): TVariantArray;
238	function VarToStrIntList(a: TVariantArray): string;
239
240	implementation
241
242	uses Variants;
243
244	function StrIntListToVar(s: string): TVariantArray;
245	var i, idx: integer;
246	List: TStringList;
247	begin
248	List := TStringList.Create;
249	try
250	idx := 1;
251	List.Clear;
252	while idx <= Length(s) do
253	List.Add(ExtractFieldName(s,idx));
254
255	Setlength(Result,List.Count);
256	for i := 0 to List.Count - 1 do
257	Result[i] := StrToInt(List[i])
258	finally
259	List.Free
260	end;
261	end;
262
263	function VarToStrIntList(a: TVariantArray): string;
264	var i: integer;
265	begin
266	for i := 0 to Length(a) - 1 do
267	if VarIsOrdinal(a[i]) then
268	begin
269	if i = 0 then
270	Result := IntToStr(a[i])
271	else
272	Result := Result + ';' + IntToStr(a[i])
273	end
274	else
275	raise Exception.Create('Ordinal Type Expected when converting to integer string');
276	end;
277
278	{ TDBTreeNode }
279
280	constructor TDBTreeNode.Create(AnOwner: TTreeNodes);
281	begin
282	inherited Create(AnOwner);
283	FKeyValue := NULL;
284	end;
285
286	procedure TDBTreeNode.DeleteAll;
287	var Node, NextNode: TTreeNode;
288	begin
289	Expand(true);
290	Node := GetFirstChild;
291	while Node <> nil do
292	begin
293	NextNode := Node.GetNextSibling;
294	TDBTreeNode(Node).DeleteAll;
295	Node := NextNode;
296	end;
297	Delete
298	end;
299
300	{ TDBTreeView }
301
302	procedure TDBTreeView.ActiveChanged(Sender: TObject);
303	begin
304	if (csDesigning in ComponentState) then Exit;
305	DataSourceChanged;
306	if assigned(DataSet) and not DataSet.Active then
307	begin
308	if not assigned(FExpandNode) and not assigned(FUpdateNode) then {must really be closing}
309	Reinitialise
310	end
311	else
312	begin
313	AddNodes;
314	if not FLocatingNode and (Selected = nil) and (Items.TopLvlCount > 0) then
315	begin
316	if Length(FLastSelected) > 0 then
317	Selected := FindNode(FLastSelected,true)
318	else
319	Selected := Items.TopLvlItems[0];
320	end
321	end
322	end;
323
324	procedure TDBTreeView.AddNodes;
325	var Node: TTreeNode;
326	ChildCount: integer;
327	begin
328	if assigned(FExpandNode) or (Items.Count = 0) then
329	begin
330	ChildCount := 0;
331	FNoAddNodeToDataset := true;
332	try
333	DataSet.First;
334	while not DataSet.EOF do
335	begin
336	if (FExpandNode = nil) or (TDBTreeNode(FExpandNode).KeyValue <> DataSet.FieldByName(KeyField).AsVariant) then
337	begin
338	Node := Items.AddChild(FExpandNode,DataSet.FieldByName(TextField).AsString);
339	Node.HasChildren := (HasChildField = '') or (DataSet.FieldByName(HasChildField).AsInteger <> 0);
340	Inc(ChildCount);
341	end;
342	DataSet.Next
343	end;
344	finally
345	FNoAddNodeToDataset := false
346	end;
347	if assigned(FExpandNode) then
348	FExpandNode.HasChildren := ChildCount > 0;
349	FExpandNode := nil
350	end
351	end;
352
353	procedure TDBTreeView.DataSetChanged(Sender: TObject);
354	begin
355	// Do nothing;
356	end;
357
358	function TDBTreeView.GetDataSet: TDataSet;
359	begin
360	Result := FDataLink.DataSet
361	end;
362
363	function TDBTreeView.GetDataSource: TDataSource;
364	begin
365	Result := FDataLink.DataSource
366	end;
367
368	function TDBTreeView.GetRelationNameQualifier: string;
369	begin
370	if FRelationName <> '' then
371	Result := FRelationName + '.'
372	else
373	Result := ''
374	end;
375
376	function TDBTreeView.GetSelectedKeyValue: variant;
377	begin
378	Result := NULL;
379	if assigned(Selected) and (Selected is TDBTreeNode) then
380	Result := TDBTreeNode(Selected).KeyValue
381	end;
382
383	procedure TDBTreeView.NodeMoved(Node: TTreeNode);
384	begin
385	{Need to update Parent}
386	if ScrollToNode(TDBTreeNode(Node)) then
387	begin
388	FDataLink.Edit;
389	FModifiedNode := TDBTreeNode(Node)
390	end;
391	end;
392
393	procedure TDBTreeView.NodeUpdated(Node: TTreeNode);
394	begin
395	{Need to Update List Field}
396	if ScrollToNode(TDBTreeNode(Node)) then
397	begin
398	FDataLink.Edit;
399	FModifiedNode := TDBTreeNode(Node);
400	FDataLink.UpdateRecord
401	end;
402	end;
403
404	procedure TDBTreeView.RecordChanged(Sender: TObject; Field: TField);
405	var Node: TDBTreeNode;
406	Destination: TDBTreeNode;
407	begin
408	if DataSet.State = dsInsert then Exit;
409
410	if assigned(Field) and (Field.FieldName = TextField) then
411	begin
412	Node := FindNode(DataSet.FieldByName(KeyField).AsVariant);
413	if assigned(Node) then
414	begin
415	FUpdating := true;
416	try
417	Node.Text := Field.Text
418	finally
419	FUpdating := false
420	end;
421	end;
422	end
423	else
424	if assigned(Field) and (Field.FieldName = ImageIndexField) then
425	begin
426	Node := FindNode(DataSet.FieldByName(KeyField).AsVariant);
427	if assigned(Node) then
428	begin
429	FUpdating := true;
430	try
431	Node.ImageIndex := Field.AsInteger
432	finally
433	FUpdating := false
434	end;
435	end;
436	end
437	else
438	if assigned(Field) and (Field.FieldName = ParentField) then
439	begin
440	Node := FindNode(DataSet.FieldByName(KeyField).AsVariant);
441	if assigned(Node) then
442	begin
443	if DataSet.FieldByName(ParentField).IsNull then
444	Destination := nil
445	else
446	Destination := FindNode(DataSet.FieldByName(ParentField).AsVariant);
447
448	if (Destination = nil) or (Destination = Node.Parent) then Exit;
449
450	FUpdating := true;
451	try
452	Node.MoveTo(Destination,naAddChild);
453	finally
454	FUpdating := false
455	end;
456	end;
457	end
458	end;
459
460	procedure TDBTreeView.SetHasChildField(AValue: string);
461	begin
462	if FHasChildField = AValue then Exit;
463	FHasChildField := AValue;
464	Reinitialise
465	end;
466
467	procedure TDBTreeView.SetImageIndexField(AValue: string);
468	begin
469	if FImageIndexField = AValue then Exit;
470	FImageIndexField := AValue;
471	Reinitialise
472	end;
473
474	procedure TDBTreeView.SetKeyField(AValue: string);
475	begin
476	if FKeyField = AValue then Exit;
477	FKeyField := AValue;
478	Reinitialise
479	end;
480
481	procedure TDBTreeView.SetSelectedIndexField(AValue: string);
482	begin
483	if FSelectedIndexField = AValue then Exit;
484	FSelectedIndexField := AValue;
485	Reinitialise;
486	end;
487
488	procedure TDBTreeView.SetTextField(AValue: string);
489	begin
490	if FTextField = AValue then Exit;
491	FTextField := AValue;
492	Reinitialise
493	end;
494
495	procedure TDBTreeView.SetDataSource(AValue: TDataSource);
496	begin
497	FDataLink.DataSource := AValue;
498	DataSourceChanged;
499	end;
500
501	procedure TDBTreeView.SetParentField(AValue: string);
502	begin
503	if FParentField = AValue then Exit;
504	FParentField := AValue;
505	Reinitialise
506	end;
507
508	function TDBTreeView.ScrollToNode(Node: TDBTreeNode): boolean;
509	begin
510	Result := assigned(DataSet) and DataSet.Active and assigned(Node) and not varIsNull(Node.KeyValue);
511	if Result then
512	begin
513	if DataSet.Active and (DataSet.RecordCount > 0)
514	and DataSet.Locate(KeyField,Node.KeyValue,[]) then Exit;
515
516	FUpdateNode := Node;
517	try
518	RefreshDataset;
519	finally
520	FUpdateNode := nil
521	end;
522	Result := DataSet.FieldByName(KeyField).AsVariant = Node.KeyValue
523	end;
524	end;
525
526	procedure TDBTreeView.UpdateData(Sender: TObject);
527	begin
528	if assigned(FModifiedNode) then
529	begin
530	DataSet.FieldByName(TextField).AsString := FModifiedNode.Text;
531	if FModifiedNode.Parent = nil then
532	DataSet.FieldByName(ParentField).Clear
533	else
534	DataSet.FieldByName(ParentField).AsVariant := TDBTreeNode(FModifiedNode.Parent).KeyValue;
535	FModifiedNode := nil
536	end
537	end;
538
539	procedure TDBTreeView.Added(Node: TTreeNode);
540	begin
541	if assigned(DataSet) and DataSet.Active then
542	begin
543	if not FNoAddNodeToDataset then
544	begin
545	DataSet.Append;
546	if (Node.Text = '') and not DataSet.FieldByName(TextField).IsNull then
547	Node.Text := DataSet.FieldByName(TextField).AsString;
548	FModifiedNode := TDBTreeNode(Node);
549	FDataLink.UpdateRecord;
550	end;
551	DoOnDataInit;
552	TDBTreeNode(Node).FKeyValue := DataSet.FieldByName(KeyField).AsVariant;
553	if ImageIndexField <> '' then
554	Node.ImageIndex := DataSet.FieldByName(ImageIndexField).AsInteger;
555	if SelectedIndexField <> '' then
556	Node.SelectedIndex := DataSet.FieldByName(SelectedIndexField).AsInteger;
557	end;
558	inherited Added(Node);
559	end;
560
561	procedure TDBTreeView.DoOnDataInit;
562	begin
563	//Do nothing
564	end;
565
566	procedure TDBTreeView.Delete(Node: TTreeNode);
567	begin
568	if not (tvsUpdating in States) {TreeNodes being cleared}
569	and not (tvsManualNotify in States) {Tree Collapse with node delete}
570	and ScrollToNode(TDBTreeNode(Node)) then
571	DataSet.Delete;
572	inherited Delete(Node);
573	end;
574
575	procedure TDBTreeView.Change(Node: TTreeNode);
576	begin
577	inherited Change(Node);
578	ScrollToNode(TDBTreeNode(Node));
579	end;
580
581	function TDBTreeView.CreateNode: TTreeNode;
582	var
583	NewNodeClass: TTreeNodeClass;
584	begin
585	Result := nil;
586	if Assigned(OnCustomCreateItem) then
587	OnCustomCreateItem(Self, Result);
588	if Result = nil then
589	begin
590	NewNodeClass:=TDBTreeNode;
591	if Assigned(OnCreateNodeClass) then
592	OnCreateNodeClass(Self,NewNodeClass);
593	Result := NewNodeClass.Create(Items);
594	end;
595	end;
596
597	function TDBTreeView.CanEdit(Node: TTreeNode): Boolean;
598	begin
599	Result := inherited CanEdit(Node)
600	and assigned(DataSet) and not DataSet.FieldByName(TextField).ReadOnly
601	end;
602
603	procedure TDBTreeView.Expand(Node: TTreeNode);
604	begin
605	inherited Expand(Node);
606	if Node.HasChildren and assigned(DataSet) and (Node.GetFirstChild = nil) then
607	begin
608	FExpandNode := Node;
609	RefreshDataset;
610	Selected := Node;
611	end;
612	end;
613
614	procedure TDBTreeView.Loaded;
615	begin
616	inherited Loaded;
617	DataSourceChanged;
618	Reinitialise
619	end;
620
621	procedure TDBTreeView.NodeChanged(Node: TTreeNode;
622	ChangeEvent: TTreeNodeChangeReason);
623	begin
624	inherited NodeChanged(Node, ChangeEvent);
625	if not FNoAddNodeToDataset and not FUpdating then
626	case ChangeEvent of
627	ncTextChanged:
628	NodeUpdated(Node);
629	ncParentChanged:
630	NodeMoved(Node);
631	end;
632	end;
633
634	procedure TDBTreeView.Notification(AComponent: TComponent; Operation: TOperation
635	);
636	begin
637	inherited Notification(AComponent, Operation);
638	if (Operation = opRemove) and
639	(FDataLink <> nil) and (AComponent = DataSource) then
640	DataSource := nil;
641	end;
642
643	procedure TDBTreeView.Reinitialise;
644	begin
645	if [csDesigning,csLoading] * ComponentState <> [] then Exit;
646	FLastSelected := GetNodePath(Selected);
647	Items.Clear;
648	end;
649
650	constructor TDBTreeView.Create(TheComponent: TComponent);
651	begin
652	inherited Create(TheComponent);
653	FDataLink := TDBTreeViewDatalink.Create(self);
654	end;
655
656	destructor TDBTreeView.Destroy;
657	begin
658	if assigned(FDataLink) then FDataLink.Free;
659	inherited Destroy;
660	end;
661
662	function TDBTreeView.FindNode(KeyValuePath: TVariantArray; SelectNode: boolean
663	): TDBTreeNode;
664	var Node: TTreeNode;
665	i,j: integer;
666	begin
667	Result := nil;
668	if Length(KeyValuePath) = 0 then Exit;
669
670	FLocatingNode := true;
671	try
672	for j := 0 to Items.TopLvlCount - 1 do
673	begin
674	Node := Items.TopLvlItems[j];
675	i := 0;
676	Node.Expand(false);
677	while assigned(Node) do
678	begin
679	if not VarIsNull(TDBTreeNode(Node).KeyValue) and
680	(TDBTreeNode(Node).KeyValue = KeyValuePath[i]) then
681	begin
682	Inc(i);
683	if i = Length(KeyValuePath) then
684	begin
685	Result := TDBTreeNode(Node);
686	if SelectNode then
687	Selected := Node;
688	Exit
689	end
690	else
691	begin
692	Node.Expand(false);
693	Node := Node.GetFirstChild;
694	end
695	end
696	else
697	Node := Node.GetNextSibling
698	end
699	end
700	finally
701	FLocatingNode := false
702	end
703	end;
704
705	function TDBTreeView.FindNode(KeyValue: variant): TDBTreeNode;
706	var i: integer;
707	begin
708	Result := nil;
709	if (Selected <> nil) and (TDBTreeNode(Selected).KeyValue = KeyValue) then
710	Result := TDBTreeNode(Selected)
711	else
712	{Find it the hard way}
713	begin
714	FullExpand;
715	for i := 0 to Items.Count -1 do
716	if TDBTreeNode(Items[i]).KeyValue = KeyValue then
717	begin
718	Result := TDBTreeNode(Items[i])
719	end;
720	end;
721	end;
722
723	function TDBTreeView.GetNodePath(Node: TTreeNode): TVariantArray;
724	var aParent: TTreeNode;
725	i: integer;
726	begin
727	if not assigned(Node) or not (Node is TDBTreeNode) then
728	SetLength(Result,0)
729	else
730	begin
731	{Count length of Path}
732	i := 1;
733	aParent := Node.Parent;
734	while (aParent <> nil) do
735	begin
736	Inc(i);
737	aParent := aParent.Parent
738	end;
739
740	{Save Path}
741	Setlength(Result,i);
742	while i > 0 do
743	begin
744	Dec(i);
745	Result[i] := TDBTreeNode(Node).KeyValue;
746	Node := Node.Parent
747	end;
748	end;
749	end;
750
751	{ TDBTreeViewDatalink }
752
753	procedure TDBTreeViewDatalink.ActiveChanged;
754	begin
755	FOwner.ActiveChanged(self)
756	end;
757
758	procedure TDBTreeViewDatalink.DataSetChanged;
759	begin
760	FOwner.DataSetChanged(self)
761	end;
762
763	procedure TDBTreeViewDatalink.RecordChanged(Field: TField);
764	begin
765	FOwner.RecordChanged(self,Field);
766	end;
767
768	procedure TDBTreeViewDatalink.UpdateData;
769	begin
770	FOwner.UpdateData(self)
771	end;
772
773	constructor TDBTreeViewDatalink.Create(AOwner: TDBTreeView);
774	begin
775	inherited Create;
776	FOwner := AOwner
777	end;
778
779	end.