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;

resourcestring
  sOrdinalTypeNotFound = 'Ordinal Type Expected when converting to integer string';

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(sOrdinalTypeNotFound);
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:	435
Committed:	Mon Jun 3 13:11:42 2024 UTC (3 months, 2 weeks ago) by tony
Content type:	text/x-pascal
File size:	20341 byte(s)
Log Message:	Publication of R2-7-0
#	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	tony	435	resourcestring
245			sOrdinalTypeNotFound = 'Ordinal Type Expected when converting to integer string';
246
247	tony	330	function StrIntListToVar(s: string): TVariantArray;
248			var i, idx: integer;
249			List: TStringList;
250			begin
251			List := TStringList.Create;
252			try
253			idx := 1;
254			List.Clear;
255			while idx <= Length(s) do
256			List.Add(ExtractFieldName(s,idx));
257
258			Setlength(Result,List.Count);
259			for i := 0 to List.Count - 1 do
260			Result[i] := StrToInt(List[i])
261			finally
262			List.Free
263			end;
264			end;
265
266			function VarToStrIntList(a: TVariantArray): string;
267			var i: integer;
268			begin
269			for i := 0 to Length(a) - 1 do
270			if VarIsOrdinal(a[i]) then
271			begin
272			if i = 0 then
273			Result := IntToStr(a[i])
274			else
275			Result := Result + ';' + IntToStr(a[i])
276			end
277			else
278	tony	435	raise Exception.Create(sOrdinalTypeNotFound);
279	tony	330	end;
280
281			{ TDBTreeNode }
282
283			constructor TDBTreeNode.Create(AnOwner: TTreeNodes);
284			begin
285			inherited Create(AnOwner);
286			FKeyValue := NULL;
287			end;
288
289			procedure TDBTreeNode.DeleteAll;
290			var Node, NextNode: TTreeNode;
291			begin
292			Expand(true);
293			Node := GetFirstChild;
294			while Node <> nil do
295			begin
296			NextNode := Node.GetNextSibling;
297			TDBTreeNode(Node).DeleteAll;
298			Node := NextNode;
299			end;
300			Delete
301			end;
302
303			{ TDBTreeView }
304
305			procedure TDBTreeView.ActiveChanged(Sender: TObject);
306			begin
307			if (csDesigning in ComponentState) then Exit;
308			DataSourceChanged;
309			if assigned(DataSet) and not DataSet.Active then
310			begin
311			if not assigned(FExpandNode) and not assigned(FUpdateNode) then {must really be closing}
312			Reinitialise
313			end
314			else
315			begin
316			AddNodes;
317			if not FLocatingNode and (Selected = nil) and (Items.TopLvlCount > 0) then
318			begin
319			if Length(FLastSelected) > 0 then
320			Selected := FindNode(FLastSelected,true)
321			else
322			Selected := Items.TopLvlItems[0];
323			end
324			end
325			end;
326
327			procedure TDBTreeView.AddNodes;
328			var Node: TTreeNode;
329			ChildCount: integer;
330			begin
331			if assigned(FExpandNode) or (Items.Count = 0) then
332			begin
333			ChildCount := 0;
334			FNoAddNodeToDataset := true;
335			try
336			DataSet.First;
337			while not DataSet.EOF do
338			begin
339			if (FExpandNode = nil) or (TDBTreeNode(FExpandNode).KeyValue <> DataSet.FieldByName(KeyField).AsVariant) then
340			begin
341			Node := Items.AddChild(FExpandNode,DataSet.FieldByName(TextField).AsString);
342			Node.HasChildren := (HasChildField = '') or (DataSet.FieldByName(HasChildField).AsInteger <> 0);
343			Inc(ChildCount);
344			end;
345			DataSet.Next
346			end;
347			finally
348			FNoAddNodeToDataset := false
349			end;
350			if assigned(FExpandNode) then
351			FExpandNode.HasChildren := ChildCount > 0;
352			FExpandNode := nil
353			end
354			end;
355
356			procedure TDBTreeView.DataSetChanged(Sender: TObject);
357			begin
358			// Do nothing;
359			end;
360
361			function TDBTreeView.GetDataSet: TDataSet;
362			begin
363			Result := FDataLink.DataSet
364			end;
365
366			function TDBTreeView.GetDataSource: TDataSource;
367			begin
368			Result := FDataLink.DataSource
369			end;
370
371			function TDBTreeView.GetRelationNameQualifier: string;
372			begin
373			if FRelationName <> '' then
374			Result := FRelationName + '.'
375			else
376			Result := ''
377			end;
378
379			function TDBTreeView.GetSelectedKeyValue: variant;
380			begin
381			Result := NULL;
382			if assigned(Selected) and (Selected is TDBTreeNode) then
383			Result := TDBTreeNode(Selected).KeyValue
384			end;
385
386			procedure TDBTreeView.NodeMoved(Node: TTreeNode);
387			begin
388			{Need to update Parent}
389			if ScrollToNode(TDBTreeNode(Node)) then
390			begin
391			FDataLink.Edit;
392			FModifiedNode := TDBTreeNode(Node)
393			end;
394			end;
395
396			procedure TDBTreeView.NodeUpdated(Node: TTreeNode);
397			begin
398			{Need to Update List Field}
399			if ScrollToNode(TDBTreeNode(Node)) then
400			begin
401			FDataLink.Edit;
402			FModifiedNode := TDBTreeNode(Node);
403			FDataLink.UpdateRecord
404			end;
405			end;
406
407			procedure TDBTreeView.RecordChanged(Sender: TObject; Field: TField);
408			var Node: TDBTreeNode;
409			Destination: TDBTreeNode;
410			begin
411			if DataSet.State = dsInsert then Exit;
412
413			if assigned(Field) and (Field.FieldName = TextField) then
414			begin
415			Node := FindNode(DataSet.FieldByName(KeyField).AsVariant);
416			if assigned(Node) then
417			begin
418			FUpdating := true;
419			try
420			Node.Text := Field.Text
421			finally
422			FUpdating := false
423			end;
424			end;
425			end
426			else
427			if assigned(Field) and (Field.FieldName = ImageIndexField) then
428			begin
429			Node := FindNode(DataSet.FieldByName(KeyField).AsVariant);
430			if assigned(Node) then
431			begin
432			FUpdating := true;
433			try
434			Node.ImageIndex := Field.AsInteger
435			finally
436			FUpdating := false
437			end;
438			end;
439			end
440			else
441			if assigned(Field) and (Field.FieldName = ParentField) then
442			begin
443			Node := FindNode(DataSet.FieldByName(KeyField).AsVariant);
444			if assigned(Node) then
445			begin
446			if DataSet.FieldByName(ParentField).IsNull then
447			Destination := nil
448			else
449			Destination := FindNode(DataSet.FieldByName(ParentField).AsVariant);
450
451			if (Destination = nil) or (Destination = Node.Parent) then Exit;
452
453			FUpdating := true;
454			try
455			Node.MoveTo(Destination,naAddChild);
456			finally
457			FUpdating := false
458			end;
459			end;
460			end
461			end;
462
463			procedure TDBTreeView.SetHasChildField(AValue: string);
464			begin
465			if FHasChildField = AValue then Exit;
466			FHasChildField := AValue;
467			Reinitialise
468			end;
469
470			procedure TDBTreeView.SetImageIndexField(AValue: string);
471			begin
472			if FImageIndexField = AValue then Exit;
473			FImageIndexField := AValue;
474			Reinitialise
475			end;
476
477			procedure TDBTreeView.SetKeyField(AValue: string);
478			begin
479			if FKeyField = AValue then Exit;
480			FKeyField := AValue;
481			Reinitialise
482			end;
483
484			procedure TDBTreeView.SetSelectedIndexField(AValue: string);
485			begin
486			if FSelectedIndexField = AValue then Exit;
487			FSelectedIndexField := AValue;
488			Reinitialise;
489			end;
490
491			procedure TDBTreeView.SetTextField(AValue: string);
492			begin
493			if FTextField = AValue then Exit;
494			FTextField := AValue;
495			Reinitialise
496			end;
497
498			procedure TDBTreeView.SetDataSource(AValue: TDataSource);
499			begin
500			FDataLink.DataSource := AValue;
501			DataSourceChanged;
502			end;
503
504			procedure TDBTreeView.SetParentField(AValue: string);
505			begin
506			if FParentField = AValue then Exit;
507			FParentField := AValue;
508			Reinitialise
509			end;
510
511			function TDBTreeView.ScrollToNode(Node: TDBTreeNode): boolean;
512			begin
513			Result := assigned(DataSet) and DataSet.Active and assigned(Node) and not varIsNull(Node.KeyValue);
514			if Result then
515			begin
516			if DataSet.Active and (DataSet.RecordCount > 0)
517			and DataSet.Locate(KeyField,Node.KeyValue,[]) then Exit;
518
519			FUpdateNode := Node;
520			try
521			RefreshDataset;
522			finally
523			FUpdateNode := nil
524			end;
525			Result := DataSet.FieldByName(KeyField).AsVariant = Node.KeyValue
526			end;
527			end;
528
529			procedure TDBTreeView.UpdateData(Sender: TObject);
530			begin
531			if assigned(FModifiedNode) then
532			begin
533			DataSet.FieldByName(TextField).AsString := FModifiedNode.Text;
534			if FModifiedNode.Parent = nil then
535			DataSet.FieldByName(ParentField).Clear
536			else
537			DataSet.FieldByName(ParentField).AsVariant := TDBTreeNode(FModifiedNode.Parent).KeyValue;
538			FModifiedNode := nil
539			end
540			end;
541
542			procedure TDBTreeView.Added(Node: TTreeNode);
543			begin
544			if assigned(DataSet) and DataSet.Active then
545			begin
546			if not FNoAddNodeToDataset then
547			begin
548			DataSet.Append;
549			if (Node.Text = '') and not DataSet.FieldByName(TextField).IsNull then
550			Node.Text := DataSet.FieldByName(TextField).AsString;
551			FModifiedNode := TDBTreeNode(Node);
552			FDataLink.UpdateRecord;
553			end;
554			DoOnDataInit;
555			TDBTreeNode(Node).FKeyValue := DataSet.FieldByName(KeyField).AsVariant;
556			if ImageIndexField <> '' then
557			Node.ImageIndex := DataSet.FieldByName(ImageIndexField).AsInteger;
558			if SelectedIndexField <> '' then
559			Node.SelectedIndex := DataSet.FieldByName(SelectedIndexField).AsInteger;
560			end;
561			inherited Added(Node);
562			end;
563
564			procedure TDBTreeView.DoOnDataInit;
565			begin
566			//Do nothing
567			end;
568
569			procedure TDBTreeView.Delete(Node: TTreeNode);
570			begin
571			if not (tvsUpdating in States) {TreeNodes being cleared}
572			and not (tvsManualNotify in States) {Tree Collapse with node delete}
573			and ScrollToNode(TDBTreeNode(Node)) then
574			DataSet.Delete;
575			inherited Delete(Node);
576			end;
577
578			procedure TDBTreeView.Change(Node: TTreeNode);
579			begin
580			inherited Change(Node);
581			ScrollToNode(TDBTreeNode(Node));
582			end;
583
584			function TDBTreeView.CreateNode: TTreeNode;
585			var
586			NewNodeClass: TTreeNodeClass;
587			begin
588			Result := nil;
589			if Assigned(OnCustomCreateItem) then
590			OnCustomCreateItem(Self, Result);
591			if Result = nil then
592			begin
593			NewNodeClass:=TDBTreeNode;
594			if Assigned(OnCreateNodeClass) then
595			OnCreateNodeClass(Self,NewNodeClass);
596			Result := NewNodeClass.Create(Items);
597			end;
598			end;
599
600			function TDBTreeView.CanEdit(Node: TTreeNode): Boolean;
601			begin
602			Result := inherited CanEdit(Node)
603			and assigned(DataSet) and not DataSet.FieldByName(TextField).ReadOnly
604			end;
605
606			procedure TDBTreeView.Expand(Node: TTreeNode);
607			begin
608			inherited Expand(Node);
609			if Node.HasChildren and assigned(DataSet) and (Node.GetFirstChild = nil) then
610			begin
611			FExpandNode := Node;
612			RefreshDataset;
613			Selected := Node;
614			end;
615			end;
616
617			procedure TDBTreeView.Loaded;
618			begin
619			inherited Loaded;
620			DataSourceChanged;
621			Reinitialise
622			end;
623
624			procedure TDBTreeView.NodeChanged(Node: TTreeNode;
625			ChangeEvent: TTreeNodeChangeReason);
626			begin
627			inherited NodeChanged(Node, ChangeEvent);
628			if not FNoAddNodeToDataset and not FUpdating then
629			case ChangeEvent of
630			ncTextChanged:
631			NodeUpdated(Node);
632			ncParentChanged:
633			NodeMoved(Node);
634			end;
635			end;
636
637			procedure TDBTreeView.Notification(AComponent: TComponent; Operation: TOperation
638			);
639			begin
640			inherited Notification(AComponent, Operation);
641			if (Operation = opRemove) and
642			(FDataLink <> nil) and (AComponent = DataSource) then
643			DataSource := nil;
644			end;
645
646			procedure TDBTreeView.Reinitialise;
647			begin
648			if [csDesigning,csLoading] * ComponentState <> [] then Exit;
649			FLastSelected := GetNodePath(Selected);
650			Items.Clear;
651			end;
652
653			constructor TDBTreeView.Create(TheComponent: TComponent);
654			begin
655			inherited Create(TheComponent);
656			FDataLink := TDBTreeViewDatalink.Create(self);
657			end;
658
659			destructor TDBTreeView.Destroy;
660			begin
661			if assigned(FDataLink) then FDataLink.Free;
662			inherited Destroy;
663			end;
664
665			function TDBTreeView.FindNode(KeyValuePath: TVariantArray; SelectNode: boolean
666			): TDBTreeNode;
667			var Node: TTreeNode;
668			i,j: integer;
669			begin
670			Result := nil;
671			if Length(KeyValuePath) = 0 then Exit;
672
673			FLocatingNode := true;
674			try
675			for j := 0 to Items.TopLvlCount - 1 do
676			begin
677			Node := Items.TopLvlItems[j];
678			i := 0;
679			Node.Expand(false);
680			while assigned(Node) do
681			begin
682			if not VarIsNull(TDBTreeNode(Node).KeyValue) and
683			(TDBTreeNode(Node).KeyValue = KeyValuePath[i]) then
684			begin
685			Inc(i);
686			if i = Length(KeyValuePath) then
687			begin
688			Result := TDBTreeNode(Node);
689			if SelectNode then
690			Selected := Node;
691			Exit
692			end
693			else
694			begin
695			Node.Expand(false);
696			Node := Node.GetFirstChild;
697			end
698			end
699			else
700			Node := Node.GetNextSibling
701			end
702			end
703			finally
704			FLocatingNode := false
705			end
706			end;
707
708			function TDBTreeView.FindNode(KeyValue: variant): TDBTreeNode;
709			var i: integer;
710			begin
711			Result := nil;
712			if (Selected <> nil) and (TDBTreeNode(Selected).KeyValue = KeyValue) then
713			Result := TDBTreeNode(Selected)
714			else
715			{Find it the hard way}
716			begin
717			FullExpand;
718			for i := 0 to Items.Count -1 do
719			if TDBTreeNode(Items[i]).KeyValue = KeyValue then
720			begin
721			Result := TDBTreeNode(Items[i])
722			end;
723			end;
724			end;
725
726			function TDBTreeView.GetNodePath(Node: TTreeNode): TVariantArray;
727			var aParent: TTreeNode;
728			i: integer;
729			begin
730			if not assigned(Node) or not (Node is TDBTreeNode) then
731			SetLength(Result,0)
732			else
733			begin
734			{Count length of Path}
735			i := 1;
736			aParent := Node.Parent;
737			while (aParent <> nil) do
738			begin
739			Inc(i);
740			aParent := aParent.Parent
741			end;
742
743			{Save Path}
744			Setlength(Result,i);
745			while i > 0 do
746			begin
747			Dec(i);
748			Result[i] := TDBTreeNode(Node).KeyValue;
749			Node := Node.Parent
750			end;
751			end;
752			end;
753
754			{ TDBTreeViewDatalink }
755
756			procedure TDBTreeViewDatalink.ActiveChanged;
757			begin
758			FOwner.ActiveChanged(self)
759			end;
760
761			procedure TDBTreeViewDatalink.DataSetChanged;
762			begin
763			FOwner.DataSetChanged(self)
764			end;
765
766			procedure TDBTreeViewDatalink.RecordChanged(Field: TField);
767			begin
768			FOwner.RecordChanged(self,Field);
769			end;
770
771			procedure TDBTreeViewDatalink.UpdateData;
772			begin
773			FOwner.UpdateData(self)
774			end;
775
776			constructor TDBTreeViewDatalink.Create(AOwner: TDBTreeView);
777			begin
778			inherited Create;
779			FOwner := AOwner
780			end;
781
782			end.