Lazarus中TreeView导出XML以及XML导入TreeView

本来说是要给自己的某程序加一个xml导出功能，但是自己也没接触过xml，加之delphi和lazarus的xml部分还都不一样，折腾好久（整一天）才解决问题。。

如下是作为导出功能的组件部分：

unit treexml;

  interface
  uses msxml2_tlb, ComCtrls, dialogs, sysutils, ActiveX;

type
// saves TTreeView as XML file.
TTreeViewToXML = class
  private
    doc: IXMLDOMDocument;
    FTree: TTreeView;

    procedure XMLPopulate(BaseNode: TTreeNode; DataItem: IXMLDOMelement);
  Public
    Constructor Create(Tree: TTreeView);
    procedure SaveToFile(filename: string);
  end;

// loads TTreeView from XML file
TXMLToTreeView = class
  private
    doc: IXMLDOMDocument;
    FTree: TTreeView;

    procedure XMLLoad(BaseItem: TTreeNode; DataItem: IXMLDOMNode);
  Public
    Procedure XMLToTree(Tree: TTreeView; Const FileName: String);
  end;


implementation
constructor TTreeViewToXML.Create(Tree: TTreeView);
begin
  FTree := Tree;
end;

procedure TTreeViewToXML.XMLPopulate(BaseNode: TTreeNode; DataItem: IXMLDOMelement);
var
  SubItem: IXMLDOMElement;
  selnode: TTreeNode;
begin
  SelNode := BaseNode;
  while selnode <> nil do
    begin
      if SelNode.HasChildren then
        begin
          SubItem := doc.CreateElement('Group');
          SubItem.setAttribute('Value', SelNode.Text);
          DataItem.AppendChild(SubItem);
          XMLPopulate(SelNode.GetFirstChild, SubItem);
        end
      else
        begin
          SubItem := doc.CreateElement('Item');
          SubItem.setAttribute('Value', SelNode.Text);
          DataItem.AppendChild(SubItem);
        end;
      SelNode := SelNode.GetNextChild(SelNode);
    end;
end;

procedure TTreeViewToXML.SaveToFile(filename: string);
 var
   topnode: IXMLDOMElement;
   selnode: TTreeNode;
 begin
   //create DOM document instance
   CoInitialize(nil);
   doc := CoDOMDocument60.Create;
   doc.async := false;
//------------------------------------------------------------------------------
   topnode := doc.createElement('<span style="font-family: Arial, Helvetica, sans-serif;">TreeView</span><span style="font-family: Arial, Helvetica, sans-serif;">');//TreeView</span>
   doc.appendChild(topnode);
   selnode := FTree.Items.GetFirstNode;
   XMLPopulate(SelNode, topnode);
   doc.save(FileName);
 end;

 procedure TXMLToTreeView.XMLLoad(BaseItem: TTreeNode; DataItem: IXMLDOMNode);
   var
     item1, item2: IXMLDOMNode;
     attr: IXMLDOMNamedNodeMap;
     CurrItem: TTreeNode;
   begin
     Item1 := DataItem;
     CurrItem := nil;   // compiler complains if I don't do this
     while Item1 <> nil do
       begin
         attr := item1.attributes;
         item2 := attr.nextNode;
         while item2 <> nil do
           begin
             CurrItem := FTree.Items.AddChild(BaseItem, Item2.NodeValue);
             item2 := attr.nextNode;
           end;
         if item1.nodename = 'Group' then
           XMLLoad(CurrItem, Item1.Get_firstChild);
         Item1 := Item1.Get_nextSibling;
       end;
   end;

   Procedure TXMLToTreeView.XMLToTree(Tree: TTreeView; Const FileName: String);
    var
      item1: IXMLDOMNode;
    begin
     //create DOM document instance
      doc := CoDOMDocument60.Create;
      doc.async := false;
      FTree := Tree;
     //------------------------------------------------------------------------------
      if doc.load(FileName) then
        begin
          FTree.Items.BeginUpdate;
          FTree.Items.Clear;
          Item1 := doc.documentElement.Get_firstChild;
          XMLLoad(nil, Item1);
          FTree.Items.EndUpdate;
        end
      else
        begin
          MessageDlg(Format ('Error loading XML document.'#13 +
                             'Error number: %d'#13 +
                             'Reason: %s'#13 +
                             'Line: %d'#13 +
                             'Column: %d', [doc.parseError.errorCode,
                             doc.parseError.reason,
                             doc.parseError.line,
                             doc.parseError.linePos]), mtError, [mbOK], 0);
        end;
    end;
 end.

上面的内容如果需要实际使用（比如给每个结点添加参数之类）需要自行修改，上面这个复制并命名treeXML.pas并在你的代码里usetreexml就可以工作了。不过，这个代码依赖msxml2_tlb库，你可以在这里找到这个库适用于lazarus版本的下载。

(追加：刚把博客迁移到博客园，修正文章迁移的问题时发现上面链接失效了，于是搬到这里一份)

使用范例：

procedure TForm1.Button2Click(Sender: TObject);
var
  xml:TTreeViewToXML;
begin
  xml:=TTreeViewToXML.Create(TreeView1);
  xml.SaveToFile('a.xml');
end;