unit DS2XML;
interface
uses
Classes,
DB;
procedure DatasetToXML(Dataset: TDataset; FileName:
string);
implementation
uses
SysUtils;
var
SourceBuffer: PChar;
procedure WriteString(Stream: TFileStream; s:
string);
begin
StrPCopy(SourceBuffer, s);
Stream.
Write(SourceBuffer[0], StrLen(SourceBuffer));
end;
procedure WriteFileBegin(Stream: TFileStream; Dataset: TDataset);
function XMLFieldType(fld: TField):
string;
begin
case fld.DataType
of
ftString: Result := '
"string" WIDTH="' + IntToStr(fld.Size) + '
"';
ftSmallint: Result := '
"i4"';
//??
ftInteger: Result := '
"i4"';
ftWord: Result := '
"i4"';
//??
ftBoolean: Result := '
"boolean"';
ftAutoInc: Result := '
"i4" SUBTYPE="Autoinc"';
ftFloat: Result := '
"r8"';
ftCurrency: Result := '
"r8" SUBTYPE="Money"';
ftBCD: Result := '
"r8"';
//??
ftDate: Result := '
"date"';
ftTime: Result := '
"time"';
//??
ftDateTime: Result := '
"datetime"';
else
end;
if fld.Required
then
Result := Result + '
required="true"';
if fld.
Readonly then
Result := Result + '
readonly="true"';
end;
var
i: Integer;
begin
WriteString(Stream, '
<?xml version="1.0" standalone="yes"?><!-- Generated by SMExport --> ' +
'
<DATAPACKET Version="2.0">');
WriteString(Stream, '
<METADATA><FIELDS>');
{write th metadata}
with Dataset
do
for i := 0
to FieldCount-1
do
begin
WriteString(Stream, '
<FIELD attrname="' +
Fields[i].FieldName +
'
" fieldtype=' +
XMLFieldType(Fields[i]) +
'
/>');
end;
WriteString(Stream, '
</FIELDS>');
WriteString(Stream, '
<PARAMS DEFAULT_ORDER="1" PRIMARY_KEY="1" LCID="1033"/>');
WriteString(Stream, '
</METADATA><ROWDATA>');
end;
procedure WriteFileEnd(Stream: TFileStream);
begin
WriteString(Stream, '
</ROWDATA></DATAPACKET>');
end;
procedure WriteRowStart(Stream: TFileStream; IsAddedTitle: Boolean);
begin
if not IsAddedTitle
then
WriteString(Stream, '
<ROW');
end;
procedure WriteRowEnd(Stream: TFileStream; IsAddedTitle: Boolean);
begin
if not IsAddedTitle
then
WriteString(Stream, '
/>');
end;
procedure WriteData(Stream: TFileStream; fld: TField; AString: ShortString);
begin
if Assigned(fld)
and (AString <> '
')
then
WriteString(Stream, '
' + fld.FieldName + '
="' + AString + '
"');
end;
function GetFieldStr(Field: TField):
string;
function GetDig(i, j: Word):
string;
begin
Result := IntToStr(i);
while (Length(Result) < j)
do
Result := '
0' + Result;
end;
var Hour, Min, Sec, MSec: Word;
begin
case Field.DataType
of
ftBoolean: Result := UpperCase(Field.AsString);
ftDate: Result := FormatDateTime('
yyyymmdd', Field.AsDateTime);
ftTime: Result := FormatDateTime('
hhnnss', Field.AsDateTime);
ftDateTime:
begin
Result := FormatDateTime('
yyyymmdd', Field.AsDateTime);
DecodeTime(Field.AsDateTime, Hour, Min, Sec, MSec);
if (Hour <> 0)
or (Min <> 0)
or (Sec <> 0)
or (MSec <> 0)
then
Result := Result + '
T' + GetDig(Hour, 2) + '
:' + GetDig(Min, 2) + '
:' + GetDig(Sec, 2) + GetDig(MSec, 3);
end;
else
Result := Field.AsString;
end;
end;
procedure DatasetToXML(Dataset: TDataset; FileName:
string);
var
Stream: TFileStream;
bkmark: TBookmark;
i: Integer;
begin
Stream := TFileStream.Create(FileName, fmCreate);
SourceBuffer := StrAlloc(1024);
WriteFileBegin(Stream, Dataset);
with DataSet
do
begin
DisableControls;
bkmark := GetBookmark;
First;
{write a title row}
WriteRowStart(Stream, True);
for i := 0
to FieldCount-1
do
WriteData(Stream,
nil, Fields[i].DisplayLabel);
{write the end of row}
WriteRowEnd(Stream, True);
while (
not EOF)
do
begin
WriteRowStart(Stream, False);
for i := 0
to FieldCount-1
do
WriteData(Stream, Fields[i], GetFieldStr(Fields[i]));
{write the end of row}
WriteRowEnd(Stream, False);
Next;
end;
GotoBookmark(bkmark);
EnableControls;
end;
WriteFileEnd(Stream);
Stream.Free;
StrDispose(SourceBuffer);
end;
end.