Marco's Web Center

Menu for Development

Site Menu
Object Pascal Handbook
Delphi Handbooks Collection
Mastering Borland Delphi 2005
(Old) White Papers
(Old)Tools
(Old) Conferences

My Other Sites
Italian Site (www.marcocantu.it)
the delphi search

Spirit of delphi

Advertising
Home My Blog Books Object Pascal Marco

Home: Code Repository: Mastering Delphi 6

Chapter 23 - Project DomCreate

Project Structure

DomCreate.dpr
program DomCreate;

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

{$R *.RES}

begin
  Application.Initialize;
  Application.CreateForm(TForm1, Form1);
  Application.Run;
end.
CreateForm.pas
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.
CreateForm.dfm
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