本来说是要给自己的某程序加一个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.'# +
'Error number: %d'# +
'Reason: %s'# +
'Line: %d'# +
'Column: %d', [doc.parseError.errorCode,
doc.parseError.reason,
doc.parseError.line,
doc.parseError.linePos]), mtError, [mbOK], );
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;