如何将treeview转为xml？(30分)

如何将treeview结构转为xml？

可以将treeview结构转为xml吗？

procedure TTreeView1Form.SaveXMLTree(var ToFile:TextFile; RootTreeNode: TTreeNode);
var
i:integer;
//c:TTreeNode;
TreeNodeData1:^TTreeNodeData;
begin
for i:=0 to RootTreeNode.Count-1 do
begin
if RootTreeNode.Item.Data=pointer(-1) then break;
TreeNodeData1:=RootTreeNode.Item.Data;
if TreeNodeData1 <> nil then

begin
if TreeNodeData1[csNODE] = 'Project' then
WriteLn(ToFile,'<Project name="'+RootTreeNode.Item.Text + '" projectTypeName="'+ TreeNodeData1[csNODETYPE]+ '" >');

if TreeNodeData1[csNODE] = 'Folder' then
WriteLn(ToFile, '<Folder folderType="'+TreeNodeData1[csNODETYPE] + '" name="'+ RootTreeNode.Item.Text +
'" defaultFolderName="'+ TreeNodeData1[csNAME]+
'" DefaultJianYanPiFileName="'+ TreeNodeData1[csDefaultJianYanPiFileName]+
'"> ');


if TreeNodeData1[csNODE] = 'File' then
WriteLn(ToFile, '<File fileType="'+ TreeNodeData1[csNODETYPE]+ '" name="'+ RootTreeNode.Item.Text +
'" defaultFileName="'+ TreeNodeData1[csDEFAULTFAULTFILENAME]+ '" filePathName="'+ TreeNodeData1[csFILEPATHNAME]+'"/> ');
end;
SaveXMLTree(ToFile,RootTreeNode.Item);

if not (TreeNodeData1 = pointer(-1)) then
begin
if TreeNodeData1[csNODE] = 'Folder' then
WriteLn(ToFile,'</Folder>');
if TreeNodeData1[csNODE] = 'Project' then
WriteLn(ToFile,'</Project>');

end;

end;
end;

不是很清楚

将treeview以xml形式保存下来？

这是我在网上看到的一段treeview转xml的vb代码，哪位能转成delphi

Private Sub WriteTreeToDOM(ByRefTreeNode As Node, _
ByRefXMLNode As IXMLDOMNode)
Dim objNewNode As IXMLDOMNode
Dim objDOM As DOMDocument
Dim objChildNode As Node

On Error GoTo ERR_HANDLER

Set objDOM = XMLNode.ownerDocument
If objDOM Is Nothing Then
Set objDOM = XMLNode
End If

Set objNewNode = objDOM.createElement(TreeNode.Text)

'Add treeview node as child
Call XMLNode.appendChild(objNewNode)

'Process child nodes
If TreeNode.children > 0 Then
Set objChildNode = TreeNode.Child

Do Until objChildNode Is Nothing
Call WriteTreeToDOM(objChildNode, objNewNode)
Set objChildNode = objChildNode.Next
Loop
End If

ERR_HANDLER:
If Err.Number <> 0 Then
MsgBoxErr.Description
End If
End Sub

这个你看看，别人做的
http://www.delphibbs.com/delphibbs/dispq.asp?lid=2343602
XML解析类
这个的效率还是很高的，只比MS封装的XML COM组件效率低一点。
测试10K大的文件，循环1000次只慢0.25秒
{***************************************************************}
{ }
{ }
{ }
{ }
{ }
{ }
{ 封装的XMLTree类、节点属性类，节点类 }
{ }
{ wr960204(王锐) 2003/12/10 }
{ QQ：42088303 }
{ }
{***************************************************************}
unit UnitXMLTree;

interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs;

type
TCustomXMLTree = class;
TXMLNode = class;

TNodeAttrib = class
private
AttribName: WideString;
AttribValue: Variant;
end;

TXMLNode = class(TPersistent)
private
FXMLNodes: TList;
FAttribs: TList;
FParentNode: TXMLNode;
FNodeName: WideString;
FText: WideString;
FHeadStr: string;

procedure ClearAttrib;

function GetAttribName(Index: Integer): WideString;
function GetXMLNodes(Index: Integer): TXMLNode;
function GetAttribCount: Integer;
function GetAttrib(AttribName: string): Variant;
procedure SetAttrib(AttribName: string; const Value: Variant);
function GetAttribByIndex(Index: Integer): Variant;
procedure SetAttribByIndex(Index: Integer; const Value: Variant);
function GetNodeCount: Integer;
public
procedure Delete(Index: Integer); virtual;
procedure DeleteMe(); //把自身从父结点中删除
procedure Append(const AName: string); virtual;
procedure Insert(Index: Integer; const AName: string); virtual;
procedure Clear;

function SaveToText(const ASaveSelf: Boolean = True): WideString; virtual;

constructor Create(AOwner: TXMLNode);
destructor Destroy; override;

property NodeName: WideString read FNodeName write FNodeName;
property Text: WideString read FText write FText;

property XMLNodes[Index: Integer]: TXMLNode read GetXMLNodes;
property AttribCount: Integer read GetAttribCount;
property Attribs[AttribName: string]: Variant read GetAttrib write
SetAttrib;
property AttribIndexOf[Index: Integer]: Variant read GetAttribByIndex write
SetAttribByIndex;
property NodeCount: Integer read GetNodeCount;
end;

TCustomXMLTree = class(TComponent)
private
FVersion: string;
FEncoding: string;
FUpDating: Boolean;
FXMLText: TStringList;
FRootNode: TXMLNode;
function GetXMLText: TStringList;
procedure SetVersion(const Value: string);
procedure SetEncoding(const Value: string);
protected
procedure CreateTree; virtual; //把文本解析成树
procedure CreateText; virtual; //把树解析成文本
procedure XMLTextChange(Sender: TObject); virtual;
procedure SetXMLText(const Value: TStringList); virtual;
public

property XMLText: TStringList read GetXMLText write SetXMLText;
property RootNode: TXMLNode read FRootNode;
property Version: string read FVersion write SetVersion;
property Encoding: string read FEncoding write SetEncoding;

constructor Create(AOwner: TComponent); override;
destructor Destroy; override;

end;

implementation

uses
UnitAssistant;

{ TCustomXMLTree }

constructor TCustomXMLTree.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FUpDating := False;
FXMLText := TStringList.Create;
FXMLText.OnChange := XMLTextChange;
FRootNode := TXMLNode.Create(nil);
end;

destructor TCustomXMLTree.Destroy;
begin
FRootNode.Free;
FXMLText.Free;
inherited Destroy;
end;

procedure TCustomXMLTree.CreateText;
var
XMLInfo : string;
begin
XMLInfo := format('<?xml version="%s" encoding="%s"?>',
[FVersion, FEncoding]);
FUpDating := True;
FXMLText.Text := FRootNode.SaveToText(False);
FXMLText.Insert(0, XMLInfo);
FUpDating := False;
end;

procedure TCustomXMLTree.CreateTree;
var
XMLParser : TXMLParser;
begin
FRootNode.Clear;
XMLParser := TXMLParser.Create(FRootNode);
try
XMLParser.Text := FXMLText.Text;
while XMLParser.NextToken.TokenType <> tkEOF do
begin
end;
FVersion := XMLParser.Version;
FEncoding := XMLParser.Encoding;
finally
XMLParser.Free;
end;
end;

function TCustomXMLTree.GetXMLText: TStringList;
begin
if FXMLText.Text <> '' then
begin
CreateText;
end;
Result := FXMLText;
end;

procedure TCustomXMLTree.SetXMLText(const Value: TStringList);
begin
if (Value <> nil) and (Value.Text <> FXMLText.Text) then
begin
FXMLText.Assign(Value);
CreateTree;
end;
end;

procedure TCustomXMLTree.XMLTextChange(Sender: TObject);
begin
if FUpDating then
Exit;
CreateTree;
end;

procedure TCustomXMLTree.SetVersion(const Value: string);
begin
FVersion := Value;
end;

procedure TCustomXMLTree.SetEncoding(const Value: string);
begin
FEncoding := Value;
end;

{ TXMLNode }

procedure TXMLNode.Append(const AName: string);
var
TmpNode : TXMLNode;
begin
TmpNode := TXMLNode.Create(nil);
TmpNode.NodeName := AName;
TmpNode.FParentNode := Self;
FXMLNodes.Add(TmpNode);
end;

procedure TXMLNode.Delete(Index: Integer);
begin
TXMLNode(FXMLNodes[Index]).Free;
FXMLNodes.Delete(Index);
end;

procedure TXMLNode.DeleteMe;
begin
if FParentNode = nil then
begin
//不能删除一个没有父结点的节点
end
else
begin
FParentNode.Delete(FParentNode.FXMLNodes.IndexOf(Self));
end;
end;

procedure TXMLNode.Insert(Index: Integer; const AName: string);
var
TmpNode : TXMLNode;
begin
TmpNode := TXMLNode.Create(nil);
try
TmpNode.NodeName := AName;
TmpNode.FParentNode := Self;
FXMLNodes.Insert(Index, TmpNode);
except
TmpNode.Free;
end;
end;

constructor TXMLNode.Create(AOwner: TXMLNode);
begin
FXMLNodes := TList.Create;
FAttribs := TList.Create;
FParentNode := AOwner;
if FParentNode <> nil then
FParentNode.FXMLNodes.Add(Self);
end;

destructor TXMLNode.Destroy;
begin
ClearAttrib;
FAttribs.Free;
Clear;
FXMLNodes.Free;
inherited Destroy;
end;

function TXMLNode.SaveToText(const ASaveSelf: Boolean = True): WideString;
var
TmpStr : WideString;
I : Integer;
AttribValue : string;
begin
if ASaveSelf then
begin
TmpStr :='<' + NodeName + ' ';
for I := 0 to AttribCount - 1 do
begin
if not VarIsNull(AttribIndexOf) then //写属性
begin
AttribValue := VarToStr(AttribIndexOf);
TmpStr := TmpStr + Format('%s="%s" ', [GetAttribName(I), AttribValue]);
end;
end;
end;
if (NodeCount = 0) and (FText = '') then //如果没有节点
begin
if ASaveSelf then
begin
TmpStr := TmpStr + '/>' + #13;
end;
end
else
begin
if ASaveSelf then
TmpStr := TmpStr + '>' + #13;
if (NodeCount = 0) then
begin
TmpStr := TmpStr + FText + #13;
end
else
begin
for I := 0 to NodeCount - 1 do
begin
TmpStr := TmpStr + XMLNodes.SaveToText;
end;
end;
if ASaveSelf then
TmpStr := TmpStr + Format('</%s >' + #13, [NodeName]);
end;
Result := TmpStr;
end;

function TXMLNode.GetXMLNodes(Index: Integer): TXMLNode;
begin
Result := TXMLNode(FXMLNodes[Index]);
end;

function TXMLNode.GetAttribCount: Integer;
begin
Result := FAttribs.Count;
end;

function TXMLNode.GetAttrib(AttribName: string): Variant;
var
I : Integer;
begin
Result := NULL;
for I := 0 to FAttribs.Count - 1 do
begin
if TNodeAttrib(FAttribs).AttribName = AttribName then
begin
Result := TNodeAttrib(FAttribs).AttribValue;
Exit;
end;
end;
end;

procedure TXMLNode.SetAttrib(AttribName: string; const Value: Variant);
var
I : Integer;
Attrib : TNodeAttrib;
begin
for I := 0 to FAttribs.Count - 1 do
begin
if TNodeAttrib(FAttribs).AttribName = AttribName then
begin
TNodeAttrib(FAttribs).AttribValue := Value;
if (Value = NULL) or (Value = '') then
begin
TNodeAttrib(FAttribs).Free;
FAttribs.Delete(I);
end;
Exit;
end;
end;
Attrib := TNodeAttrib.Create;
FAttribs.Add(Attrib);
Attrib.AttribName := AttribName;
Attrib.AttribValue := Value;
end;

function TXMLNode.GetAttribByIndex(Index: Integer): Variant;
begin
Result := TNodeAttrib(FAttribs[Index]).AttribValue;
end;

procedure TXMLNode.SetAttribByIndex(Index: Integer; const Value: Variant);
var
Attrib : TNodeAttrib;
begin
Attrib := TNodeAttrib(FAttribs[Index]);
Attrib.AttribValue := Value;
end;

function TXMLNode.GetAttribName(Index: Integer): WideString;
begin
Result := TNodeAttrib(FAttribs[Index]).AttribName;
end;

function TXMLNode.GetNodeCount: Integer;
begin
Result := Self.FXMLNodes.Count;
end;

procedure TXMLNode.Clear;
var
I : Integer;
begin
for I := FXMLNodes.Count - 1 downto 0 do
begin
TXMLNode(FXMLNodes).Free;
FXMLNodes.Delete(I);
end;
end;

procedure TXMLNode.ClearAttrib;
var
I : Integer;
begin
for I := FAttribs.Count - 1 downto 0 do
begin
TNodeAttrib(FAttribs).Free;
FAttribs.Delete(I);
end;
end;

end.


{***************************************************************}
{ }
{ }
{ }
{ }
{ }
{ }
{ 封装的XML语法解析器和XML节点对象堆栈 }
{ }
{ wr960204(王锐) 2003/12/10 }
{ QQ：42088303 }
{ }
{***************************************************************}

unit UnitAssistant;

interface

uses
UnitXMLTree,
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs;

type
TTonkenType = (tkNode, tkEndNode, tkAttrib, tkEOF);

TToken = record
TokenType: TTonkenType;
TokenStr: string;
end;

type
TXMLStack = class;

TXMLParser = class //XML文本解析
private
FVersion: string;
FEncoding: string;
FStack: TXMLStack;
FOwner: TXMLNode;
FCurrentNode: TXMLNode;
FText: string;
FSourcePtr: PChar;
FSourceLine: Integer;
function GetSymbol: string;
function GetAttribValue: string;
procedure SkipBlanks;
procedure GetNextNode;
procedure SetText(const Value: string);
public
property Text: string read FText write SetText;
property Version: string read FVersion write FVersion;
property Encoding: string read FEncoding write FEncoding;

function NextToken: TToken;
constructor Create(AOwner: TXMLNode);
destructor Destroy; override;
end;

{ TXMLStack }

TXMLStack = class //XML栈类
private
FItems: TList;
FOwner: TXMLParser;
public
constructor Create(AOwner: TXMLParser);
destructor Destroy; override;

procedure Push(const ANode: TXMLNode); //压入
function Pop: TXMLNode; //弹出

end;

implementation

constructor TXMLStack.Create(AOwner: TXMLParser);
begin
FItems := TList.Create;
FOwner := AOwner;
end;

destructor TXMLStack.Destroy;
begin
FItems.Free;
inherited Destroy;
end;

function TXMLStack.Pop: TXMLNode;
var
Index : Integer;
begin
Result := nil;
Index := FItems.Count - 1;
if Index = -1 then
begin
Exit;
end;
Result := TXMLNode(FItems[Index]);
if (Index - 1) <> -1 then
FOwner.FCurrentNode := TXMLNode(FItems[Index - 1]);
FItems.Delete(Index);
end;

procedure TXMLStack.Push(const ANode: TXMLNode);
begin
FItems.Add(ANode);
FOwner.FCurrentNode := ANode;
end;

{ TXMLParser }

constructor TXMLParser.Create(AOwner: TXMLNode);
begin
FOwner := AOwner;
FCurrentNode := AOwner;
FStack := TXMLStack.Create(Self);
end;

destructor TXMLParser.Destroy;
begin
FStack.Free;
inherited Destroy;
end;

function TXMLParser.GetAttribValue: string;
var
I, J : Integer;
S : PChar;
begin
SkipBlanks;
case FSourcePtr^ of
'"':
begin
Inc(FSourcePtr);
J := 0;
S := FSourcePtr;
while True do
begin
case FSourcePtr^ of
'"':
begin
Inc(FSourcePtr);
if FSourcePtr^ <> '"' then
Break;
end;
end; {end case}
Inc(J);
Inc(FSourcePtr);
end; {end while}
end;
else
//raise EParserError;
end;
SetString(Result, S, J);
end;

procedure TXMLParser.GetNextNode;
begin

end;

function TXMLParser.GetSymbol: string;
var
I, J : Integer;
S : PChar;
begin
SkipBlanks;
S := FSourcePtr;
case FSourcePtr^ of
'A'..'Z', 'a'..'z', '_':
begin
Inc(FSourcePtr);
while FSourcePtr^ in ['A'..'Z', 'a'..'z', '0'..'9', '_'] do
Inc(FSourcePtr);
SetString(Result, S, FSourcePtr - S);
end;
else
Inc(FSourcePtr);
end;
end;

function TXMLParser.NextToken: TToken;

var
I, J : Integer;
S : PChar;
TmpStr : string;

procedure SetAttribs(Obj: TXMLNode);
var
AttribName, AttribValue: string;
begin
AttribName := GetSymbol; //得到属性名
SkipBlanks;
Inc(FSourcePtr); //得到"="
SkipBlanks;
AttribValue := GetAttribValue; //得到属性名
Obj.Attribs[AttribName] := AttribValue;
end;

procedure CreateObj;
var
Obj : TXMLNode;
begin
Obj := TXMLNode.Create(FCurrentNode);
Obj.NodeName := GetSymbol;
FStack.Push(Obj);

SkipBlanks;
while not (FSourcePtr^ in [#0, '>', '/']) do
begin
SetAttribs(Obj);
SkipBlanks;
end;
end;
var
AttribName : string;
TmpNode : TXMLNode;
begin
SkipBlanks;
case FSourcePtr^ of
#0:
begin
Result.TokenType := tkEOF;
Result.TokenStr := '';
Exit;
end;
'<':
begin
SkipBlanks;
case (FSourcePtr + 1)^ of
'?': //开头1行的描述"<?......?>"
begin
Inc(FSourcePtr, 2);

while not ((FSourcePtr^ = '?') and ((FSourcePtr + 1)^ = '>')) do
begin
SkipBlanks;
AttribName := '';
AttribName := AnsiUpperCase(GetSymbol);
if AttribName = AnsiUpperCase('version') then
begin
SkipBlanks;
Inc(FSourcePtr); //跳过等号
FVersion := GetAttribValue;
end;
if AttribName = AnsiUpperCase('Encoding') then
begin
SkipBlanks;
Inc(FSourcePtr); //跳过等号
FEncoding := GetAttribValue;
end;
end;
Inc(FSourcePtr, 2);
end;
'/': //结束符 "</类名"
begin
Inc(FSourcePtr, 2);
//循环弹出，直到遇到为止。因为有时特殊的XML例如Html是不闭合的
//例如<p>就可以不闭合

while True do
begin
TmpNode := FStack.Pop;
TmpStr := GetSymbol;
if (TmpNode = nil) or (TmpNode.NodeName = TmpStr) then
Break;

end;

while (FSourcePtr^ <> '>') do
begin
Inc(FSourcePtr);
if FSourcePtr^ = #0 then
Exit;
end;
Inc(FSourcePtr);
end;
else //生成对象节点 "<类名"
begin
Inc(FSourcePtr);
CreateObj;
case FSourcePtr^ of
'>':
begin
Inc(FSourcePtr);
end;
'/':
begin
Inc(FSourcePtr);
while (FSourcePtr^ <> '>') do
begin
Inc(FSourcePtr);
end;
FStack.Pop;
end;
end;
end;
end; {end case}
end;
else
Inc(FSourcePtr);
end; {end case}
end;

procedure TXMLParser.SetText(const Value: string);
begin
FText := Value;
FSourcePtr := PChar(FText);
end;

procedure TXMLParser.SkipBlanks;
begin
while True do
begin
case FSourcePtr^ of
#0:
begin
Exit;
end;
#10:
Inc(FSourceLine);
#33..#255:
Exit;
end;
Inc(FSourcePtr);
end;
end;

end.

多人接受答案了。