支持xml的控件

以前帮别人写的一个例子，你可以参考一下 :)

unit Main;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  OleServer, MSXML2_TLB, StdCtrls, AppEvnts, ComCtrls, XMLTreeView;

type
  EXMLError              = class(Exception);
  EXMLLoadError          = class(EXMLError);
  EXMLSaveError          = class(EXMLError);
  EXMLParseError         = class(EXMLError);

type
  TfrmMain = class(TForm)
    memXML: TMemo;
    btnLoad: TButton;
    dlgOpen: TOpenDialog;
    AppEvents: TApplicationEvents;
    lblTagName: TLabel;
    edtTagName: TEdit;
    lstChildren: TListBox;
    btnTree: TButton;
    treeNode: TTreeView;
    dlgSave: TSaveDialog;
    btnSave: TButton;
    XMLTree: TXMLTreeView;
    btnLoadFromFile: TButton;
    btnSaveToFile: TButton;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure btnLoadClick(Sender: TObject);
    procedure AppEventsException(Sender: TObject; E: Exception);
    procedure edtTagNameChange(Sender: TObject);
    procedure btnTreeClick(Sender: TObject);
    procedure btnSaveClick(Sender: TObject);
    procedure btnLoadFromFileClick(Sender: TObject);
    procedure btnSaveToFileClick(Sender: TObject);
  private
    xmlDoc: IXMLDOMDocument2;
  public
    { Public declarations }
  end;

var
  frmMain: TfrmMain;

implementation

{$R *.DFM}

procedure TfrmMain.FormCreate(Sender: TObject);
begin
  xmlDoc := CoDOMDocument.Create;
end;

procedure TfrmMain.FormDestroy(Sender: TObject);
begin
  xmlDoc := nil;
end;

procedure TfrmMain.btnLoadClick(Sender: TObject);
begin
  with dlgOpen, xmlDoc do
  if Execute then
  begin
    if not Load(FileName) then
      raise EXMLLoadError.CreateFmt('载入XML文档失败！', [FileName])
    else
    with memXML.Lines do
    begin
      Clear;
      Text := documentElement.xml;
    end;
  end;
end;

procedure TfrmMain.btnSaveClick(Sender: TObject);
begin
  with dlgSave do
  if Execute then
    xmlDoc.Save(FileName);
end;

procedure TfrmMain.AppEventsException(Sender: TObject; E: Exception);
begin
  if E is EXMLError then
  with xmlDoc.parseError do
  begin
    MessageDlg(Format('处理文档"%s"时因"%s"发生0x%x号错误在第%d行%d个字符(全文第%d个字符)'#13#10'错误文本: %s'#13#10'提示信息: %s',
                      [url, reason, errorCode, line, linepos, filepos + 1, srcText, E.Message]), mtError, [mbAbort], 0);
  end
  else
    Application.ShowException(E);
end;

procedure TfrmMain.edtTagNameChange(Sender: TObject);
var
  I: Integer;
begin
  if edtTagName.Text <> '' then
  with xmlDoc.getElementsByTagName(UpperCase(edtTagName.Text)) do
  with lstChildren.Items do
  begin
    Clear;
    for I := 0 to length - 1 do
      Add(item[I].text);
  end;
end;

procedure TfrmMain.btnTreeClick(Sender: TObject);
  procedure DoTree(ANode: IXMLDOMNode; Parent: TTreeNode);
  var
    I: Integer;
    CurNode: TTreeNode;
  begin
    with ANode do
    case nodeType of
      NODE_ELEMENT:
      begin
        if ParentNode = nil then
          CurNode := treeNode.Items.Add(nil, nodeName)
        else
          CurNode := treeNode.Items.AddChild(Parent, nodeName);
        if hasChildNodes then
        with childNodes do
          for I := 0 to length - 1 do
            DoTree(IXMLDOMElement(item[I]), CurNode);
      end;
      NODE_TEXT:
        treeNode.Items.AddChild(Parent, ANode.text);
    end;
  end;
begin
  with treeNode.Items do
  begin
    Clear;
    BeginUpdate;
    DoTree(xmlDoc.documentElement, nil);
    treeNode.FullExpand;
    EndUpdate;
  end;
end;

procedure TfrmMain.btnLoadFromFileClick(Sender: TObject);
begin
  with dlgOpen do
  if Execute then
    XMLTree.LoadFromFile(FileName);
end;

procedure TfrmMain.btnSaveToFileClick(Sender: TObject);
begin
  with dlgSave do
  if Execute then
    XMLTree.SaveToFile(FileName);
end;

end.