Экспорт TDataSet в XML файл

{Unit to export a dataset to XML} 
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. 

// Example: 

uses DS2XML; 

procedure TForm1.Button1Click(Sender: TObject); 
  begin  DatasetToXML(Table1, 'test.xml'); 
  end;