支持xml的控件

来源:百度文库 编辑:神马文学网 时间:2024/03/29 02:10:48
以前帮别人写的一个例子,你可以参考一下 :)
unit Main;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
OleServer, MSXML2_TLB, StdCtrls, AppEvnts, ComCtrls, XMLTreeView;
type
EXMLError              = class(Exception);
EXMLLoadError          = class(EXMLError);
EXMLSaveError          = class(EXMLError);
EXMLParseError         = class(EXMLError);
type
TfrmMain = class(TForm)
memXML: TMemo;
btnLoad: TButton;
dlgOpen: TOpenDialog;
AppEvents: TApplicationEvents;
lblTagName: TLabel;
edtTagName: TEdit;
lstChildren: TListBox;
btnTree: TButton;
treeNode: TTreeView;
dlgSave: TSaveDialog;
btnSave: TButton;
XMLTree: TXMLTreeView;
btnLoadFromFile: TButton;
btnSaveToFile: TButton;
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure btnLoadClick(Sender: TObject);
procedure AppEventsException(Sender: TObject; E: Exception);
procedure edtTagNameChange(Sender: TObject);
procedure btnTreeClick(Sender: TObject);
procedure btnSaveClick(Sender: TObject);
procedure btnLoadFromFileClick(Sender: TObject);
procedure btnSaveToFileClick(Sender: TObject);
private
xmlDoc: IXMLDOMDocument2;
public
{ Public declarations }
end;
var
frmMain: TfrmMain;
implementation
{$R *.DFM}
procedure TfrmMain.FormCreate(Sender: TObject);
begin
xmlDoc := CoDOMDocument.Create;
end;
procedure TfrmMain.FormDestroy(Sender: TObject);
begin
xmlDoc := nil;
end;
procedure TfrmMain.btnLoadClick(Sender: TObject);
begin
with dlgOpen, xmlDoc do
if Execute then
begin
if not Load(FileName) then
raise EXMLLoadError.CreateFmt('载入XML文档失败!', [FileName])
else
with memXML.Lines do
begin
Clear;
Text := documentElement.xml;
end;
end;
end;
procedure TfrmMain.btnSaveClick(Sender: TObject);
begin
with dlgSave do
if Execute then
xmlDoc.Save(FileName);
end;
procedure TfrmMain.AppEventsException(Sender: TObject; E: Exception);
begin
if E is EXMLError then
with xmlDoc.parseError do
begin
MessageDlg(Format('处理文档"%s"时因"%s"发生0x%x号错误在第%d行%d个字符(全文第%d个字符)'#13#10'错误文本: %s'#13#10'提示信息: %s',
[url, reason, errorCode, line, linepos, filepos + 1, srcText, E.Message]), mtError, [mbAbort], 0);
end
else
Application.ShowException(E);
end;
procedure TfrmMain.edtTagNameChange(Sender: TObject);
var
I: Integer;
begin
if edtTagName.Text <> '' then
with xmlDoc.getElementsByTagName(UpperCase(edtTagName.Text)) do
with lstChildren.Items do
begin
Clear;
for I := 0 to length - 1 do
Add(item[I].text);
end;
end;
procedure TfrmMain.btnTreeClick(Sender: TObject);
procedure DoTree(ANode: IXMLDOMNode; Parent: TTreeNode);
var
I: Integer;
CurNode: TTreeNode;
begin
with ANode do
case nodeType of
NODE_ELEMENT:
begin
if ParentNode = nil then
CurNode := treeNode.Items.Add(nil, nodeName)
else
CurNode := treeNode.Items.AddChild(Parent, nodeName);
if hasChildNodes then
with childNodes do
for I := 0 to length - 1 do
DoTree(IXMLDOMElement(item[I]), CurNode);
end;
NODE_TEXT:
treeNode.Items.AddChild(Parent, ANode.text);
end;
end;
begin
with treeNode.Items do
begin
Clear;
BeginUpdate;
DoTree(xmlDoc.documentElement, nil);
treeNode.FullExpand;
EndUpdate;
end;
end;
procedure TfrmMain.btnLoadFromFileClick(Sender: TObject);
begin
with dlgOpen do
if Execute then
XMLTree.LoadFromFile(FileName);
end;
procedure TfrmMain.btnSaveToFileClick(Sender: TObject);
begin
with dlgSave do
if Execute then
XMLTree.SaveToFile(FileName);
end;
end.