Lazarus中TreeView导出XML以及XML导入TreeView
本来说是要给自己的某程序加一个xml导出功能，但是自己也没接触过xml，加之delphi和lazarus的xml部分还都不一样，折腾好久（整一天）才解决问题。。
如下是作为导出功能的组件部分：
1 unit treexml; 2 3 interface 4 uses msxml2_tlb, ComCtrls, dialogs, sysutils, ActiveX; 5 6 type 7 // saves TTreeView as XML file. 8 TTreeViewToXML = class 9 private 10 doc: IXMLDOMDocument; 11 FTree: TTreeView; 12 13 procedure XMLPopulate(BaseNode: TTreeNode; DataItem: IXMLDOMelement); 14 Public 15 Constructor Create(Tree: TTreeView); 16 procedure SaveToFile(filename: string); 17 end; 18 19 // loads TTreeView from XML file 20 TXMLToTreeView = class 21 private 22 doc: IXMLDOMDocument; 23 FTree: TTreeView; 24 25 procedure XMLLoad(BaseItem: TTreeNode; DataItem: IXMLDOMNode); 26 Public 27 Procedure XMLToTree(Tree: TTreeView; Const FileName: String); 28 end; 29 30 31 implementation 32 constructor TTreeViewToXML.Create(Tree: TTreeView); 33 begin 34 FTree := Tree; 35 end; 36 37 procedure TTreeViewToXML.XMLPopulate(BaseNode: TTreeNode; DataItem: IXMLDOMelement); 38 var 39 SubItem: IXMLDOMElement; 40 selnode: TTreeNode; 41 begin 42 SelNode := BaseNode; 43 while selnode <> nil do 44 begin 45 if SelNode.HasChildren then 46 begin 47 SubItem := doc.CreateElement('Group'); 48 SubItem.setAttribute('Value', SelNode.Text); 49 DataItem.AppendChild(SubItem); 50 XMLPopulate(SelNode.GetFirstChild, SubItem); 51 end 52 else 53 begin 54 SubItem := doc.CreateElement('Item'); 55 SubItem.setAttribute('Value', SelNode.Text); 56 DataItem.AppendChild(SubItem); 57 end; 58 SelNode := SelNode.GetNextChild(SelNode); 59 end; 60 end; 61 62 procedure TTreeViewToXML.SaveToFile(filename: string); 63 var 64 topnode: IXMLDOMElement; 65 selnode: TTreeNode; 66 begin 67 //create DOM document instance 68 CoInitialize(nil); 69 doc := CoDOMDocument60.Create; 70 doc.async := false; 71 //------------------------------------------------------------------------------ 72 topnode := doc.createElement('<span style="font-family: Arial, Helvetica, sans-serif;">TreeView</span><span style="font-family: Arial, Helvetica, sans-serif;">');//TreeView</span> 73 doc.appendChild(topnode); 74 selnode := FTree.Items.GetFirstNode; 75 XMLPopulate(SelNode, topnode); 76 doc.save(FileName); 77 end; 78 79 procedure TXMLToTreeView.XMLLoad(BaseItem: TTreeNode; DataItem: IXMLDOMNode); 80 var 81 item1, item2: IXMLDOMNode; 82 attr: IXMLDOMNamedNodeMap; 83 CurrItem: TTreeNode; 84 begin 85 Item1 := DataItem; 86 CurrItem := nil; // compiler complains if I don't do this 87 while Item1 <> nil do 88 begin 89 attr := item1.attributes; 90 item2 := attr.nextNode; 91 while item2 <> nil do 92 begin 93 CurrItem := FTree.Items.AddChild(BaseItem, Item2.NodeValue); 94 item2 := attr.nextNode; 95 end; 96 if item1.nodename = 'Group' then 97 XMLLoad(CurrItem, Item1.Get_firstChild); 98 Item1 := Item1.Get_nextSibling; 99 end; 100 end; 101 102 Procedure TXMLToTreeView.XMLToTree(Tree: TTreeView; Const FileName: String); 103 var 104 item1: IXMLDOMNode; 105 begin 106 //create DOM document instance 107 doc := CoDOMDocument60.Create; 108 doc.async := false; 109 FTree := Tree; 110 //------------------------------------------------------------------------------ 111 if doc.load(FileName) then 112 begin 113 FTree.Items.BeginUpdate; 114 FTree.Items.Clear; 115 Item1 := doc.documentElement.Get_firstChild; 116 XMLLoad(nil, Item1); 117 FTree.Items.EndUpdate; 118 end 119 else 120 begin 121 MessageDlg(Format ('Error loading XML document.'#13 + 122 'Error number: %d'#13 + 123 'Reason: %s'#13 + 124 'Line: %d'#13 + 125 'Column: %d', [doc.parseError.errorCode, 126 doc.parseError.reason, 127 doc.parseError.line, 128 doc.parseError.linePos]), mtError, [mbOK], 0); 129 end; 130 end; 131 end.
上面的内容如果需要实际使用（比如给每个结点添加参数之类）需要自行修改，上面这个复制并命名treeXML.pas并在你的代码里usetreexml就可以工作了。不过，这个代码依赖msxml2_tlb库，你可以在这里找到这个库适用于lazarus版本的下载。
(追加：刚把博客迁移到博客园，修正文章迁移的问题时发现上面链接失效了，于是搬到这里一份)
使用范例：
1 procedure TForm1.Button2Click(Sender: TObject); 2 var 3 xml:TTreeViewToXML; 4 begin 5 xml:=TTreeViewToXML.Create(TreeView1); 6 xml.SaveToFile('a.xml'); 7 end;
