Zbudowanie XML z węzłów zapisanych w bazie danych

unit Unit4;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics, xmldoc, xmlintf,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, generics.Collections, Vcl.ComCtrls, Data.DBXFirebird, Data.DB, Data.SqlExpr, Vcl.StdCtrls;

Type
  TelementsList = class;

  Telement = class
    id: int64;
    parentId: int64;
    elementName: string;
    childNodes: TelementsList;
    constructor Create;
    destructor Destroy;
  end;

  TelementsList = class(TobjectList<Telement>)
    procedure prepareTree;
  end;

type
  TForm4 = class(TForm)
    FbconnectionConnection: TSQLConnection;
    Button1: TButton;
    Memo1: TMemo;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure Button1Click(Sender: TObject);
  public
    xml: Ixmldocument;
    elementsList: TelementsList;
    procedure createXml;
    procedure loadFromdb;
  end;

var
  Form4: TForm4;

implementation

{$R *.dfm}
{ TelementsList }

procedure TelementsList.prepareTree;
var
  I, j: Integer;
begin
  for I := 0 to self.Count - 1 do
    for j := 0 to self.Count - 1 do
      if self[I] <> self[j] then
        if self[j].parentId = self[I].id then
          self[I].childNodes.Add(self[j]);
end;

{ Telement }

constructor Telement.Create;
begin
  self.childNodes := TelementsList.Create(false);
end;

destructor Telement.Destroy;
begin
  self.childNodes.Free;
end;

{ TForm4 }

procedure addToXml(aElement: Telement; aParentNode: IxmlNode);
var
  newNode: IxmlNode;
  I: Integer;
begin
  newNode := aParentNode.AddChild(aElement.elementName);
  newNode.SetAttributeNS('ID', '', inttostr(aElement.id));
  for I := 0 to aElement.childNodes.Count - 1 do
    addToXml(aElement.childNodes[I], newNode);
end;

procedure TForm4.Button1Click(Sender: TObject);
begin
  self.loadFromdb;
end;

procedure TForm4.createXml;
var
  I: Integer;
  rootNode: IxmlNode;
begin
  self.xml.Active := true;
  self.xml.Options := self.xml.Options + [doNodeAutoindent];
  rootNode := self.xml.AddChild('root');
  for I := 0 to self.elementsList.Count - 1 do
    if (self.elementsList[I].parentId = 0) then
      addToXml(self.elementsList[I], rootNode);
end;

procedure TForm4.FormCreate(Sender: TObject);
begin
  self.elementsList := TelementsList.Create(true);
  xml := txmldocument.Create(nil);
end;

procedure TForm4.FormDestroy(Sender: TObject);
begin
  self.elementsList.Free;
end;

procedure TForm4.loadFromdb;
var
  tsql: tsqldataset;
  newElement: Telement;
begin
  self.elementsList.Clear;
  tsql := tsqldataset.Create(nil);
  try
    tsql.SQLConnection := self.FbconnectionConnection;
    tsql.CommandText := //
      'select ' + //
      '   id, ' + //
      '   parent_id, ' + //
      '   node_name ' + //
      'from ' + //
      '   new_table';
    tsql.Open;
    while not tsql.eof do
    begin
      newElement := Telement.Create;
      newElement.id := tsql.FieldByName('id').AsLargeInt;
      newElement.parentId := tsql.FieldByName('parent_id').AsLargeInt;
      newElement.elementName := trim(tsql.FieldByName('node_name').AsString);
      self.elementsList.Add(newElement);
      tsql.Next;
    end;
  finally
    tsql.Free;
  end;
 
  self.elementsList.prepareTree;
  self.createXml;
  self.Memo1.Lines.Clear;
  self.Memo1.Font.Name := 'COURIER NEW';
  self.Memo1.Lines.Text := self.xml.xml.Text;
end;

end.

function findNodeById(aNode: IxmlNode; aId: Integer): IxmlNode;
var
  I: Integer;
begin
  result := nil;
  if aNode.HasAttribute('ID') then
    if aNode.Attributes['ID'] = inttostr(aId) then
    begin
      result := aNode;
      exit;
    end;
  for I := 0 to aNode.childNodes.Count - 1 do
    if aNode.childNodes[I].NodeType = tnodetype.ntElement then
    begin
      result := findNodeById(aNode.childNodes[I], aId);
      if result <> nil then
        exit;
    end;
end;

procedure TForm4.Button2Click(Sender: TObject);
var
  res: IxmlNode;
begin
  res := findNodeById(self.xml.ChildNodes.FindNode('root'), 8);
  if res <> nil then
  begin
    res.Text := 'node value';
    showmessage(res.NodeName + #13 + res.NodeValue);
  end;
end;

Type TelementsList = class(TobjectList<Telement>)
    rootElement: Telement;
    procedure prepareTree;
    procedure AfterConstruction; override;
  end;

procedure TelementsList.AfterConstruction;
begin
  inherited;
  self.rootElement := nil;
end;


procedure TelementsList.prepareTree;
var
  I, j: Integer;
begin
  self.rootElement := nil;
  for I := 0 to self.Count - 1 do
  begin
    if self[I].parentId = 0 then
      if self.rootElement = nil then
        self.rootElement := self[I]
      else
        raise Exception.Create('Znaleziono więcej niż jeden element zerowy (root) ');
    for j := 0 to self.Count - 1 do
      if self[I] <> self[j] then
        if self[j].parentId = self[I].id then
          self[I].childNodes.Add(self[j]);
  end;
  if self.rootElement = nil then
    raise Exception.Create('Brak elementu zerowego (root) ');
end;


procedure TForm4.createXml;
var
  I: Integer;
  rootNode: IxmlNode;
begin
  self.xml.Active := true;
  self.xml.Options := self.xml.Options + [doNodeAutoindent];
  rootNode := self.xml.AddChild(self.elementsList.rootElement.elementName);
  rootNode.SetAttributeNS('ID', '', inttostr(self.elementsList.rootElement.id));
  for I := 0 to self.elementsList.rootElement.childNodes.Count - 1 do
    addToXml(self.elementsList.rootElement.childNodes[I], rootNode);
end;