trunk/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:	330
Committed:	Fri Feb 26 16:16:06 2021 UTC (3 years, 8 months ago) by tony
Content type:	text/x-pascal
File size:	20278 byte(s)
Log Message:	Add missing DBTreeview.pas
#	User	Rev	Content
1	tony	330	(*
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.