Project Structure

• DomCreate.dpr
• CreateForm.pas
• CreateForm.dfm

program DomCreate;

uses
  Forms,
  CreateForm in 'CreateForm.pas' {Form1};

{$R *.RES}

begin
  Application.Initialize;
  Application.CreateForm(TForm1, Form1);
  Application.Run;
end.

unit CreateForm;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, xmldom,
  XMLIntf, msxmldom, XMLDoc, DB, DBTables, ComCtrls, StdCtrls, TypInfo,
  ExtCtrls, Menus;

type
  TForm1 = class(TForm)
    btnSimple: TButton;
    Memo1: TMemo;
    btnTable: TButton;
    btnObject: TButton;
    Table1: TTable;
    TreeView1: TTreeView;
    btnTree: TButton;
    XMLDoc: TXMLDocument;
    Button1: TButton;
    btnRTTI: TButton;
    Panel1: TPanel;
    Panel2: TPanel;
    Splitter1: TSplitter;
    procedure btnSimpleClick(Sender: TObject);
    procedure btnTableClick(Sender: TObject);
    procedure btnObjectClick(Sender: TObject);
    procedure btnTreeClick(Sender: TObject);
    procedure btnRTTIClick(Sender: TObject);
  private
    procedure DomToTree(XmlNode: IXMLNode; TreeNode: TTreeNode);
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.btnSimpleClick(Sender: TObject);
var
  iXml: IDOMDocument;
  iRoot, iNode, iNode2, iChild, iAttribute: IDOMNode;
begin
  // empty the document
  XMLDoc.Active := False;
  XMLDoc.XML.Text := '';
  XMLDoc.Active := True;

  // root
  iXml := XmlDoc.DOMDocument;
  iRoot := iXml.appendChild (iXml.createElement ('xml'));
  // node "test"
  iNode := iRoot.appendChild (iXml.createElement ('test'));
  iNode.appendChild (iXml.createElement ('test2'));
  iChild := iNode.appendChild (iXml.createElement ('test3'));
  iChild.appendChild (iXml.createTextNode('simple value'));
  iNode.insertBefore (iXml.createElement ('test4'), iChild);

  // node replication
  iNode2 := iNode.cloneNode (True);
  iRoot.appendChild (iNode2);

  // add an attribute
  iAttribute := iXml.createAttribute ('color');
  iAttribute.nodeValue := 'red';
  iNode2.attributes.setNamedItem (iAttribute);

  // show XML in memo
  Memo1.Lines.Text := FormatXMLData (XMLDoc.XML.Text);
end;

procedure DataSetToDOM (RootName, RecordName: string;
  XMLDoc: TXmlDocument; DataSet: TDataSet);
var
  iNode, iChild: IXMLNode;
  i: Integer;
begin
  DataSet.Open;
  DataSet.First;
  // root
  XMLDoc.DocumentElement := XMLDoc.CreateNode (RootName);

  // add table data
  while not DataSet.EOF do
  begin
    // add a node for each record
    iNode := XMLDoc.DocumentElement.AddChild (RecordName);
    for I := 0 to DataSet.FieldCount - 1 do
    begin
      // add an element for each field
      iChild := iNode.AddChild (DataSet.Fields[i].FieldName);
      iChild.Text := DataSet.Fields[i].AsString;
    end;
    DataSet.Next;
  end;
end;

procedure TForm1.btnTableClick(Sender: TObject);
begin
  // empty the document
  XMLDoc.Active := False;
  XMLDoc.XML.Text := '';
  XMLDoc.Active := True;

  // add the table to the DOM
  DataSetToDOM ('customers', 'customer', XMLDoc, Table1);

  // show XML in memo
  Memo1.Lines := XmlDoc.XML;
end;

procedure AddAttr (iNode: IDOMNode; Name, Value: string);
var
  iAttr: IDOMNode;
begin
  iAttr := iNode.ownerDocument.createAttribute (name);
  iAttr.nodeValue := Value;
  iNode.attributes.setNamedItem (iAttr);
end;

procedure TForm1.btnObjectClick(Sender: TObject);
var
  iXml: IDOMDocument;
  iRoot: IDOMNode;
begin
  // empty the document
  XMLDoc.Active := False;
  XMLDoc.XML.Text := '';
  XMLDoc.Active := True;

  // root
  iXml := XmlDoc.DOMDocument;
  iRoot := iXml.appendChild (
    iXml.createElement ('Button1'));

  // a few properties as attributes (might also be nodes)
  AddAttr (iRoot, 'Name', Button1.Name);
  AddAttr (iRoot, 'Caption', Button1.Caption);
  AddAttr (iRoot, 'Font.Name', Button1.Font.Name); // sub-elements?
  AddAttr (iRoot, 'Left', IntToStr (Button1.Left));
  AddAttr (iRoot, 'Hint', Button1.Hint);

  // show XML in memo
  Memo1.Lines := XmlDoc.XML;
end;

procedure TForm1.DomToTree (XmlNode: IXMLNode; TreeNode: TTreeNode);
var
  I: Integer;
  NewTreeNode: TTreeNode;
  NodeText: string;
  AttrNode: IXMLNode;
begin
  // skip text nodes and other special cases
  if not (XmlNode.NodeType = ntElement) then
    Exit;
  // add the node itself
  NodeText := XmlNode.NodeName;
  if XmlNode.IsTextElement then
    NodeText := NodeText + ' = ' + XmlNode.Text;
  NewTreeNode := TreeView1.Items.AddChild(TreeNode, NodeText);
  // add attributes
  for I := 0 to xmlNode.AttributeNodes.Count - 1 do
  begin
    AttrNode := xmlNode.AttributeNodes.Nodes[I];
    TreeView1.Items.AddChild(NewTreeNode,
      '[' + AttrNode.NodeName + ' = "' + AttrNode.Text + '"]');
  end;
  // add each child node
  if XmlNode.HasChildNodes then
    for I := 0 to xmlNode.ChildNodes.Count - 1 do
      DomToTree (xmlNode.ChildNodes.Nodes [I], NewTreeNode);
end;

procedure TForm1.btnTreeClick(Sender: TObject);
begin
  TreeView1.Items.BeginUpdate;
  try
    TreeView1.Items.Clear;
    DomToTree (XmlDoc.DocumentElement, nil);
    TreeView1.FullExpand;
  finally
    TreeView1.Items.EndUpdate;
  end;
end;

procedure ComponentToDOM (iNode: IXmlNode; Comp: TPersistent);
var
  nProps, i: Integer;
  PropList: PPropList;
  Value: Variant;
  newNode: IXmlNode;
begin
  // get list of properties
  nProps := GetTypeData (Comp.ClassInfo)^.PropCount;
  GetMem (PropList, nProps * SizeOf(Pointer));
  try
    GetPropInfos (Comp.ClassInfo, PropList);

    // shortcut: use variants...
    for i := 0 to nProps - 1 do
    begin
      Value := GetPropValue (Comp, PropList [i].Name);
      NewNode := iNode.AddChild(PropList [i].Name);
      NewNode.Text := Value;
      if (PropList [i].PropType^.Kind = tkClass) and (Value <> 0) then
        if TObject (Integer(Value)) is TComponent then
          NewNode.Text := TComponent (Integer(Value)).Name
        else
          // TPersistent but not TComponent: recurse
          ComponentToDOM (newNode, TObject (Integer(Value)) as TPersistent);
    end;
  finally
    FreeMem (PropList);
  end;
end;

procedure TForm1.btnRTTIClick(Sender: TObject);
begin
  // empty the document
  XMLDoc.Active := False;
  XMLDoc.XML.Text := '';
  XMLDoc.Active := True;

  // create the root for the object and adds its properties
  XMLDoc.DocumentElement := XMLDoc.CreateNode(self.ClassName);
  ComponentToDOM (XMLDoc.DocumentElement, self);

  // show XML in memo
  Memo1.Lines := XmlDoc.XML;
end;

end.

object Form1: TForm1
  Left = 192
  Top = 107
  Width = 571
  Height = 412
  Caption = 'DomCreate'
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'MS Sans Serif'
  Font.Style = []
  OldCreateOrder = False
  PixelsPerInch = 96
  TextHeight = 13
  object Panel1: TPanel
    Left = 0
    Top = 0
    Width = 97
    Height = 385
    Align = alLeft
    TabOrder = 0
    object btnObject: TButton
      Left = 8
      Top = 72
      Width = 75
      Height = 25
      Caption = 'Object'
      TabOrder = 0
      OnClick = btnObjectClick
    end
    object btnSimple: TButton
      Left = 8
      Top = 8
      Width = 75
      Height = 25
      Caption = 'Simple'
      TabOrder = 1
      OnClick = btnSimpleClick
    end
    object btnTable: TButton
      Left = 8
      Top = 40
      Width = 75
      Height = 25
      Caption = 'Table'
      TabOrder = 2
      OnClick = btnTableClick
    end
    object btnTree: TButton
      Left = 8
      Top = 184
      Width = 75
      Height = 25
      Caption = 'Tree'
      TabOrder = 3
      OnClick = btnTreeClick
    end
    object Button1: TButton
      Left = 8
      Top = 216
      Width = 75
      Height = 25
      Caption = 'Button1'
      TabOrder = 4
    end
    object btnRTTI: TButton
      Left = 8
      Top = 104
      Width = 75
      Height = 25
      Caption = 'RTTI'
      TabOrder = 5
      OnClick = btnRTTIClick
    end
  end
  object Panel2: TPanel
    Left = 97
    Top = 0
    Width = 466
    Height = 385
    Align = alClient
    BevelOuter = bvNone
    TabOrder = 1
    object Splitter1: TSplitter
      Left = 0
      Top = 185
      Width = 466
      Height = 3
      Cursor = crVSplit
      Align = alTop
    end
    object TreeView1: TTreeView
      Left = 0
      Top = 188
      Width = 466
      Height = 197
      Align = alClient
      Indent = 19
      TabOrder = 0
    end
    object Memo1: TMemo
      Left = 0
      Top = 0
      Width = 466
      Height = 185
      Align = alTop
      TabOrder = 1
    end
  end
  object Table1: TTable
    DatabaseName = 'DBDEMOS'
    TableName = 'customer.db'
    Left = 232
    Top = 72
  end
  object XMLDoc: TXMLDocument
    Active = True
    NodeIndentStr = '    '
    Options = [doNodeAutoCreate, doNodeAutoIndent, doAttrNull, doAutoPrefix, doNamespaceDecl]
    Left = 296
    Top = 72
    DOMVendorDesc = 'MSXML'
  end
end