本来说是要给自己的某程序加一个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,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;原文链接:/xml/298327.html