Delphi: DataSet To XML

procedure DatasetToXML(Dataset: TDataset; FileName: string);

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, '  ' +
                     '');
 WriteString(Stream, '');

 {write th metadata}
 with Dataset do
   for i := 0 to FieldCount-1 do
   begin
     WriteString(Stream, '');
   end;
 WriteString(Stream, '');
 WriteString(Stream, '');
 WriteString(Stream, '');
end;

procedure WriteFileEnd(Stream: TFileStream);
begin
 WriteString(Stream, '');
end;

procedure WriteRowStart(Stream: TFileStream; IsAddedTitle: Boolean);
begin
 if not IsAddedTitle then
   WriteString(Stream, '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.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, GetFieldStr(Fields));
     {write the end of row}
     WriteRowEnd(Stream, False);

     Next;
   end;

   GotoBookmark(bkmark);
   EnableControls;
 end;

 WriteFileEnd(Stream);
 Stream.Free;
 StrDispose(SourceBuffer);
end;

end.