unit QExport4DBF;

{$I QExport4VerCtrl.inc}

interface

uses
  {$IFDEF VCL16}
    System.Classes,
    System.SysUtils,
    System.Variants,
  {$ELSE}
    Classes,
    SysUtils,
    {$IFDEF VCL6}
    Variants,
    {$ENDIF}
  {$ENDIF}
  QExport4,
  QExport4IniFiles;

const
  dBaseIII = $03;
  dBaseIIIMemo = $83;
  dBaseIVMemo = $8B;
  dBaseIVSQL = $63;
  FoxPro = $05;
  FoxProMemo = $F5;

  dftString  = 'C';  // char (symbol(s))
  dftBoolean = 'L';  // boolean
  dftNumber  = 'N';  // number
  dftDate    = 'D';  // date
  dftMemo    = 'M';  // memo
  dftFloat   = 'F';  // float -- not in DBaseIII

  MAX_FIELD_NAME_LEN = 10;

type

  TFieldName = array[1..MAX_FIELD_NAME_LEN] of AnsiChar;

  TDBFHeader = packed record { *** First record ***  L=32 }
   {+0} DBType,
   {+1} Year,
   {+2} Month,
   {+3} Day: Byte;
   {+4} RecCount: LongInt;
   {+8} HeaderSize: Word;
   {+10} RecordSize: Longint;
   {+14} FDelayTrans: Byte;
   {+15} Reserve2: array[1..13] of Byte;
   {+28} FlagMDX: Byte;
   {+29} Reserve3: array[1..3] of Byte;
  end;

  PDBFFieldDescriptor = ^TDBFFieldDescriptor;
  TDBFFieldDescriptor = packed record { *** Field Descriptor *** L= 32 }
    {+0}  FieldName: TFieldName;
(*dee    {+10} FieldEnd: Char;
    {+11} FieldType: Char;
*)
    {+10} FieldEnd: AnsiChar;
    {+11} FieldType: AnsiChar;
    {+12} FieldDisp: LongInt;
    {+16} FieldLen,
    {+17} FieldDec: Byte;
    {+18} A1: array[1..13] of Byte;
    {+31} FlagTagMDX: Byte;
  end;

  //TMemoType = (mtNone, mtDBT, mtFPT);
  TQExport4DBF = class;

  TQDBFWriter = class(TQExportWriter)
  private
    DBFHeader: TDBFHeader;
    DList: TList;
    {$IFDEF QE_UNICODE}
    FExportCharsetType: TQExportCharsetType;
    {$ENDIF}
    MemoStream: TFileStream;
    MemoRecord: PByteArray;
    NextMemoRecord: integer;

    function GetDBFExport: TQExport4DBF;
  protected
    property DBFExport: TQExport4DBF read GetDBFExport;
  public
    constructor Create(AOwner: TQExport4; AStream: TStream); override;
    destructor Destroy; override;
    procedure AddFieldDef(Descriptor: PDBFFieldDescriptor);
    procedure CreateDBF;
    procedure DestroyDBF;
{$IFDEF VCL12}
    procedure WriteData(Num: integer; const AData: string);
{$ELSE}
    procedure WriteData(Num: integer; const Data: String);
{$ENDIF}
    function WriteMemo(Index: integer): integer;
    {$IFDEF QE_UNICODE}
    property ExportCharsetType: TQExportCharsetType read FExportCharsetType write
        FExportCharsetType;
    {$ENDIF}
  end;

  TQExport4DBF = class(TQExport4Text)
  private
    FColumnsPrecision: TStrings;
    FOldDecimalSeparator: char;
    FOldFormats: TQExportFormats;
    FDefaultFloatSize: integer;
    FDefaultFloatDecimal: integer;
    FExportTimeAsStr: Boolean;
    function GetMemoFileName: string;
    function GetNullValue: string;
    procedure SetNullValue(const Value: string);
    procedure SetColumnsPrecision(Value: TStrings);
    procedure GetColumnSizeDecimal(const ColumnName: string; var Size,
      Decimal: integer);
    procedure CreateDatabase;
    procedure FinalizeDatabase;
  protected
    function GetWriterClass: TQExportWriterClass; override;
    function GetWriter: TQDBFWriter;

    procedure BeginExport; override;
    procedure EndExport; override;
    procedure BeforeExport; override;
    procedure AfterExport; override;

    procedure WriteDataRow; override;
    procedure SaveProperties(IniFile: TQIniFile); override;
    procedure LoadProperties(IniFile: TQIniFile); override;

    property MemoFileName: string read GetMemoFileName;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    property Captions;
    property ColumnsLength;
    property ColumnsPrecision: TStrings read FColumnsPrecision
      write SetColumnsPrecision;
    property DefaultFloatSize: integer read FDefaultFloatSize
      write FDefaultFloatSize default 15;
    property DefaultFloatDecimal: integer read FDefaultFloatDecimal
      write FDefaultFloatDecimal default 4;
    property ExportTimeAsStr: Boolean read FExportTimeAsStr write FExportTimeAsStr;
    property NullValue: string read GetNullValue write SetNullValue;
  end;

  TShortFieldNameGenerator = class
  private
    FFieldNames: TStringList;
    function GetNumberString(const AValue: Integer): string;
    function IncNumberString(const AValue: string): string;
  public
    constructor Create;
    destructor Destroy; override;
    function GetShortFieldName(AFieldName: string): string;
  end;

implementation

uses
  {$IFDEF VCL16}
    Data.DB,
    Winapi.Windows,
    System.Math,
  {$ELSE}
    DB,
    {$IFDEF VCL9}
      Windows,
    {$ENDIF}
    Math,
  {$ENDIF}
    QExport4Common,
    QExport4Types;

const
  STrue  = 'TRUE';
  SFalse = 'FALSE';


{ TQDBFWriter }

procedure TQDBFWriter.AddFieldDef(Descriptor: PDBFFieldDescriptor);
begin
  DList.Add(Descriptor);
end;

constructor TQDBFWriter.Create(AOwner: TQExport4; AStream: TStream);
begin
  inherited;
  DList := TList.Create;
end;

procedure TQDBFWriter.CreateDBF;
var
  B: Byte;
  I: Integer;
  Y, M, D : Word;
begin
  FillChar(DBFHeader, 32, #0);
  DecodeDate(Date, Y, M, D);
  with DBFHeader do
  begin
    if (Owner as TQExport4DBF).Columns.ContainsBLOB and
       (Stream is TFileStream) then
    begin
      DBType := dBaseIIIMemo;
      MemoStream := TFileStream.Create((Owner as TQExport4DBF).MemoFileName, fmCreate);
      GetMem(MemoRecord, 512);
      FillChar(MemoRecord^, 512, #0);
      MemoStream.WriteBuffer(MemoRecord^, 512);
      NextMemoRecord := 1;
    end
    else DBType := dBaseIII;

    Year := Y - 2000;
    Month := M;
    Day := D;
    HeaderSize := (DList.Count + 1) * 32 + 1;
    RecordSize := 1;
    for I := 0 to DList.Count - 1 do
      RecordSize := RecordSize + PDBFFieldDescriptor(DList[I])^.FieldLen;
  end;
  Stream.WriteBuffer(DBFHeader, SizeOf(DBFHeader));
  for I := 0 to DList.Count - 1 do
    Stream.WriteBuffer(PDBFFieldDescriptor(DList[I])^, 32);
  B := $0D; // End of DBF Header
  Stream.WriteBuffer(B, SizeOf(B));
end;

destructor TQDBFWriter.Destroy;
var
  i: Integer;
begin
  for i := 0 to DList.Count - 1 do
    if Assigned(DList.Items[i]) then
      Dispose(PDBFFieldDescriptor(DList.Items[i]));
  DList.Free;
  inherited;
end;

procedure TQDBFWriter.DestroyDBF;
begin
  if Assigned(MemoStream) then
  begin
    MemoStream.Seek(0, soFromBeginning);
    MemoStream.Write(NextMemoRecord, SizeOf(Integer));
    MemoStream.Free;
  end;
end;

function TQDBFWriter.GetDBFExport: TQExport4DBF;
begin
  Result := Owner as TQExport4DBF;
end;

{$IFDEF VCL12}
procedure TQDBFWriter.WriteData(Num: integer; const AData: string);
{$else}
procedure TQDBFWriter.WriteData(Num: integer; const Data: string);
{$endif}

  {$IFDEF QE_UNICODE}
  procedure WriteUsingCharset(WS: WideString; const DataLen: Integer);
  var
    s: AnsiString;
  begin
    if not Assigned(Owner) then
      Exit;
    if WS = EmptyStr then
      Exit;

    case ExportCharsetType of
      ectLocalANSI, ectLocalOEM, ectLocalMAC:
        begin
          s := WideStringToString(WS, Integer(ExportCharsetType));
          if length(s) <> DataLen then
            SetLength(s, DataLen);
          Stream.WriteBuffer(s[1], DataLen);
        end;
      ectUTF8:
        begin
          s := UTF8Encode(WS);
          if length(s) <> DataLen then
            SetLength(s, DataLen);
          Stream.WriteBuffer(s[1], DataLen);
        end;
    end;
  end;
  {$ENDIF}

const
  NewRecordMarker: Byte = $20;
  SDBFTrue  = 'T';
  SDBFFalse = 'F';
var
  RCount, LengthData: integer;
{$IFDEF VCL12}
  Data: AnsiString;
{$ENDIF}
  _Data: AnsiString;
  DD: TDateTime;
begin
{$IFDEF VCL12}
  Data := AnsiString(AData);
{$ENDIF}
  //igorp AV
  if Length(Data) > PDBFFieldDescriptor(DList[Num])^.FieldLen then
    LengthData := PDBFFieldDescriptor(DList[Num])^.FieldLen
  else
    LengthData := Length(Data);
  //\igorp
  SetLength(_Data, PDBFFieldDescriptor(DList[Num])^.FieldLen);
  FillChar(_Data[1], Length(_Data), ' ');
  if string(Data) <> EmptyStr then
  begin
    case PDBFFieldDescriptor(DList[Num])^.FieldType of
      dftString:
          if Length(Data) > 254 // !!!
            then Move(Data[1], _Data[1], 254) // !!!
            else Move(Data[1], _Data[1], Length(Data));
      dftNumber:
        begin
          Move(Data[1], _Data[Max(Length(_Data) - Length(Data) + 1, 1)], LengthData);
        end;
      dftDate: begin
          DD := StrToDateTime(string(Data));
          _Data := AnsiString(FormatDateTime('yyyymmdd', DD));
         if string(_Data) = EmptyStr then
         begin
           SetLength(_Data, 8);
           FillChar(_Data[1], 8, ' ');
         end;
      end;
      dftBoolean: begin
        if Pos(STrue, UpperCase(string(Data))) > 0 then
          _Data[1] := SDBFTrue
        else
        if Pos(SFalse, UpperCase(string(Data))) > 0 then
          _Data[1] := SDBFFalse
        else
          _Data[1] := ' ';
      end;
    end;
  end;
//  if (Num = 0) then
//  begin
//    Stream.WriteBuffer(NewRecordMarker, 1); // it's new record
//    // update record count
//    CurPos := Stream.Position; // save current position
//    Stream.Position := 4;
//    Stream.ReadBuffer(RCount, 4);
//    Inc(RCount);
//    Stream.Position := 4;
//    Stream.WriteBuffer(RCount, 4);
//    Stream.Position := CurPos; // restore current position
//  end;
  {$IFDEF QE_UNICODE}
  WriteUsingCharset(string(_Data), Length(_Data)); //alex c - используется локальная функция, иначе при перекодировке идет смещение поля
  {$ELSE}
  Write(_Data);
  {$ENDIF}
  RCount := Length(_Data);
  if RCount = 0 then
    {$IFDEF VCL16}System.SysUtils{$ELSE}SysUtils{$ENDIF}.Beep;
end;

function TQDBFWriter.WriteMemo(Index: integer): integer;
var
  Field: TField;
  FieldBuffer: TMemoryStream;
  Size, Position: integer;
  Finish: byte;
begin
  Result := -1;
  if not ((Owner as TQExport4DBF).ExportSource in [esDataSet, esDBGrid]) then Exit;

  Field := nil;
  case (Owner as TQExport4DBF).ExportSource of
    esDataSet: Field := DBFExport.DataSet.FindField(DBFExport.Columns.Items[Index].Name);
    {$IFNDEF NOGUI}
    esDBGrid: Field := DBFExport.DBGrid.DataSource.DataSet.FindField(DBFExport.Columns[Index].Name);
    {$ENDIF}
  end;
  if not Assigned(Field) or not (Field is TBlobField) then Exit;

  Size := (Field as TBlobField).BlobSize;
  if (Size <= 0) {or (Size > 65536) #DATEXP-902} then Exit;
  FieldBuffer := TMemoryStream.Create;
  try
    {$IFDEF QE_UNICODE}
      {$IFDEF VCL10}
      if (Field is TMemoField) or (Field is TWideMemoField) then // otherwise AV, if non-memo field and data len 1 (Zeos) 
        WriteToStreamUsingCharset(FieldBuffer, Field.AsWideString, ExportCharsetType)
      else
        (Field as TBlobField).SaveToStream(FieldBuffer);
      {$ELSE}
      (Field as TBlobField).SaveToStream(FieldBuffer);
      {$ENDIF}
    {$ELSE}
    (Field as TBlobField).SaveToStream(FieldBuffer);
    {$ENDIF}
    Finish := $1A;
    FieldBuffer.WriteBuffer(Finish, SizeOf(Byte));
    FieldBuffer.WriteBuffer(Finish, SizeOf(Byte));
    FieldBuffer.Position := 0;

    Result := NextMemoRecord;
    while (FieldBuffer.Size - FieldBuffer.Position) > 512 do begin
      FillChar(MemoRecord^, 512, #0);
      FieldBuffer.ReadBuffer(MemoRecord^, 512);
      MemoStream.Write(MemoRecord^, 512);
      Inc(NextMemoRecord);
    end;
    Size := FieldBuffer.Size;
    Position := FieldBuffer.Position;
    if (Size - Position) > 0 then
    begin
      FillChar(MemoRecord^, 512, #0);
      FieldBuffer.ReadBuffer(MemoRecord^, Size - Position);
      MemoStream.WriteBuffer(MemoRecord^, 512);
      Inc(NextMemoRecord);
    end;
  finally
    FieldBuffer.Free;
  end;
end;

{ TQExport4DBF }

constructor TQExport4DBF.Create(AOwner: TComponent);
begin
  inherited;
  FColumnsPrecision := TStringList.Create;
  FDefaultFloatSize := 15;
  FDefaultFloatDecimal := 4;
  Formats.NullString := S_NULL_STRING;
  Formats.IntegerFormat := '#';
  {$IFDEF QE_UNICODE}
  CharsetType := ectLocalANSI;
  {$ENDIF}
end;

procedure TQExport4DBF.CreateDatabase;
var
  sfnGen: TShortFieldNameGenerator; 
  i, CurrDisp: integer;
  FD: PDBFFieldDescriptor;
  str: AnsiString;
  s, d: integer;
begin
  CurrDisp := 0;
  sfnGen := TShortFieldNameGenerator.Create;
  try
    for i := 0 to Columns.Count - 1 do
    begin
      //if Columns[i].IsBlob and not Columns[i].IsMemo then Continue;
      New(FD);
      FillChar(FD^, 32, #0);

      str := AnsiString(GetColCaption(i));

      if Length(str) > 10 then
        str := AnsiString(sfnGen.GetShortFieldName(String(str)));
      
      Move( AnsiString(UpperCase(str))[1], FD^.FieldName,
        Length(str) * SizeOf(AnsiChar));
      FD^.FieldEnd := #0;

      if Columns[i].IsBlob then
      begin
        FD^.FieldType := dftMemo;
        FD^.FieldLen := 10;
        FD^.FieldDec := 0;
      end
      else begin
        case Columns[i].ColType of
          ectInteger: begin
            FD^.FieldType := dftNumber;
            FD^.FieldLen := 11;
            FD^.FieldDec := 0;
          end;
          ectBigint: begin
            FD^.FieldType := dftNumber;
            FD^.FieldLen := 20;
            FD^.FieldDec := 0;
          end;
          ectString: begin
            FD^.FieldType := dftString;
            if Columns[i].Length > 254 then
              FD^.FieldLen := 254
            else
              FD^.FieldLen := Columns[i].Length;
            FD^.FieldDec := 0;
          end;
          ectFloat, ectCurrency: begin
            GetColumnSizeDecimal(Columns[i].Name, s, d);
            FD^.FieldType := dftNumber;
            FD^.FieldLen := s;
            FD^.FieldDec := d;
          end;
          ectNumeric: begin
            GetColumnSizeDecimal(Columns[i].Name, s, d);
            FD^.FieldType := dftNumber;
            FD^.FieldLen := s;
            FD^.FieldDec := d;
          end;
          ectDate, ectTime, ectDateTime: begin
            if ExportTimeAsStr and (Columns[i].ColType in [ectTime, ectDateTime]) then
            begin
              FD^.FieldType := dftString;
              if not Columns[i].Length > 25 then
                FD^.FieldLen := Columns[i].Length
              else
                FD^.FieldLen := 25;
              Columns[i].ColType := ectString;
              FD^.FieldDec := 0;
            end
            else
            begin
              FD^.FieldType := dftDate;
              FD^.FieldLen := 8;
              FD^.FieldDec := 0;
            end;
          end;
          ectBoolean: begin
            FD^.FieldType := dftBoolean;
            FD^.FieldLen := 1;
            FD^.FieldDec := 0;
          end
          else begin
            FD^.FieldType := dftString;
            FD^.FieldLen := 50; //10; igorp при неопознанных > 10 (например GUID) вываливается AV
            FD^.FieldDec := 0;
          end;
        end;
      end;
      FD^.FieldDisp := CurrDisp;
      CurrDisp := CurrDisp + FD^.FieldLen;
      GetWriter.AddFieldDef(FD);
    end;
  finally
    sfnGen.Free;
  end;
  GetWriter.CreateDBF;
end;

destructor TQExport4DBF.Destroy;
begin
  FColumnsPrecision.Free;
  inherited;
end;

procedure TQExport4DBF.FinalizeDatabase;
begin
  GetWriter.Write(Chr($1A));
  GetWriter.DestroyDBF;
end;

procedure TQExport4DBF.AfterExport;
begin
  {$IFDEF VCL16}System.SysUtils{$ELSE}SysUtils{$ENDIF}.{$IFDEF VCL17}FormatSettings.{$ENDIF}DecimalSeparator :=
    FOldDecimalSeparator;
  if Assigned(FOldFormats) then
    Formats.Assign(FOldFormats);
  inherited;
end;

procedure TQExport4DBF.BeforeExport;
begin
  inherited;
  FOldDecimalSeparator :=
    {$IFDEF VCL16}System.SysUtils{$ELSE}SysUtils{$ENDIF}.{$IFDEF VCL17}FormatSettings.{$ENDIF}DecimalSeparator;
  {$IFNDEF VCL14}
  SysUtils.DecimalSeparator := '.';
  {$ENDIF}
  if not Assigned(FOldFormats) then
    FOldFormats := TQExportFormats.Create;
  FOldFormats.Assign(Formats);
  Formats.IntegerFormat := '0';
  Formats.FloatFormat := '0.#';
  Formats.DateFormat :=
  {$IFDEF VCL16}System.SysUtils{$ELSE}SysUtils{$ENDIF}.{$IFDEF VCL17}FormatSettings.{$ENDIF}ShortDateFormat;
  if not ExportTimeAsStr then
  begin
    Formats.TimeFormat := {$IFDEF VCL16}System.SysUtils{$ELSE}SysUtils{$ENDIF}.{$IFDEF VCL17}FormatSettings.{$ENDIF}ShortTimeFormat;
    Formats.DateTimeFormat := {$IFDEF VCL16}System.SysUtils{$ELSE}SysUtils{$ENDIF}.{$IFDEF VCL17}FormatSettings.{$ENDIF}ShortDateFormat + ' ' +
      {$IFDEF VCL16}System.SysUtils{$ELSE}SysUtils{$ENDIF}.{$IFDEF VCL17}FormatSettings.{$ENDIF}ShortTimeFormat;
  end;
  Formats.CurrencyFormat := Formats.FloatFormat;
  Formats.BooleanTrue := STrue;
  Formats.BooleanFalse := SFalse;
end;

procedure TQExport4DBF.BeginExport;
begin
  inherited;
  CreateDatabase;
end;

procedure TQExport4DBF.EndExport;
begin
  FinalizeDatabase;
  inherited;
end;

function TQExport4DBF.GetMemoFileName: string;
begin
  Result := ChangeFileExt(FileName, '.dbt');
end;

function TQExport4DBF.GetNullValue: string;
begin
  Result := Formats.NullString;
end;

procedure TQExport4DBF.SetColumnsPrecision(Value: TStrings);
begin
  FColumnsPrecision.Assign(Value);
end;

procedure TQExport4DBF.SetNullValue(const Value: string);
begin
  if Formats.NullString <> Value then
    Formats.NullString := Value;
end;


procedure TQExport4DBF.GetColumnSizeDecimal(const ColumnName: string; var Size,
  Decimal: integer);
var
  j: integer;
  str: string;
  Col: TQExportColumn;
begin
  Size := FDefaultFloatSize;
  Decimal := FDefaultFloatDecimal;
  j := FColumnsPrecision.IndexOfName(ColumnName);
  if j > -1 then
  begin
      str := FColumnsPrecision.Values[FColumnsPrecision.Names[j]];
      j := Pos(',', str);
      if j > 0 then
      begin
        Size := StrToIntDef(Copy(str, 1, j - 1), 0);
        Decimal := StrToIntDef(Copy(str, j + 1, Length(str) - j), 0);
        if (Size <= 0) and (Decimal <= 0) then
        begin
          Size := FDefaultFloatSize;
          Decimal := FDefaultFloatDecimal;
        end;
      end;
   end
   else
   begin
     Col := Columns[Columns.IndexOfName(ColumnName)];
     if (Col <> nil) and (Col.ColType = ectNumeric) and (Col.NumPrecision > 0)
     then begin
       Size := Col.NumPrecision + 2; //знак и разделитель
       Decimal := Col.NumSize;
     end else
     begin
       Size := FDefaultFloatSize;
       Decimal := FDefaultFloatDecimal;
     end;
   end;
end;

function TQExport4DBF.GetWriter: TQDBFWriter;
begin
  Result := TQDBFWriter(inherited GetWriter);
end;

function TQExport4DBF.GetWriterClass: TQExportWriterClass;
begin
  Result := TQDBFWriter;
end;

procedure TQExport4DBF.LoadProperties(IniFile: TQIniFile);
begin
  inherited;
  with IniFile do begin
    ColumnsLength.Clear;
    ReadSectionValues(S_LENGTH, ColumnsLength);
  end;
end;

procedure TQExport4DBF.SaveProperties(IniFile: TQIniFile);
var
  i: integer;
begin
  inherited;
  with IniFile do begin
    EraseSection(S_LENGTH);
    for i := 0 to ColumnsLength.Count - 1 do
      WriteString(S_LENGTH, Format('%s%d', [S_Line, i]), ColumnsLength[i]);
  end;
end;

procedure TQExport4DBF.WriteDataRow;
var
  i, Address: integer;
  fmtstr, str: string;
  s, d,
  QuotePos: integer;

  procedure IncRecCount;
  const
    NewRecordMarker: Byte = $20;
  var
    CurPos, RCount: integer;
  begin
    GetWriter.Stream.WriteBuffer(NewRecordMarker, 1); // it's new record
    // update record count
    CurPos := GetWriter.Stream.Position; // save current position
    GetWriter.Stream.Position := 4;
    GetWriter.Stream.ReadBuffer(RCount, 4);
    Inc(RCount);
    GetWriter.Stream.Position := 4;
    GetWriter.Stream.WriteBuffer(RCount, 4);
    GetWriter.Stream.Position := CurPos; // restore current position
  end;

begin
  for i := 0 to ExportRow.Count - 1 do begin

    //if Columns[i].IsBlob and not Columns[i].IsMemo then Continue;

    //alex c
    {$IFDEF QE_UNICODE}
    TQDBFWriter(GetWriter).ExportCharsetType := CharsetType;
    {$ENDIF}

    str := GetExportedValue(ExportRow[i]);
    //if AnsiCompareText(str, 'null') = 0 then str := EmptyStr;
    if VarIsNull(ExportRow[i].Data) or VarIsEmpty(ExportRow[i].Data) then
      str := EmptyStr;

    if i = 0 then IncRecCount;

    if Columns[i].ColType in [ectFloat, ectCurrency, ectNumeric] then
    begin
      if str = EmptyStr then
      begin
//        str := Formats.NullString;
        GetWriter.WriteData(i, str);
      end
      else begin
        GetColumnSizeDecimal(ExportRow[i].Name, s, d);
        fmtstr := Format('%%%d.%df', [s, d]);
        str := ExportRow[i].Data;
        str := Format(fmtstr, [StrToFloat(str)]);
        {[ExportRow[i].Data] - Format '%15.4f' invalid or incompatible with argument}
        QuotePos := Pos(',', str);
        if QuotePos > 0 then
          str[QuotePos] := '.';
        GetWriter.WriteData(i, str)
      end;
    end
    else if Columns[i].IsBlob then
    begin
      if (GetWriter.Stream is TFileStream) then
      begin
        Address := GetWriter.WriteMemo(i);
        str := '          ';
        if Address > -1 then
        begin
          str := IntToStr(Address);
          while Length(str) < 10 do str := ' ' + str;
        end;
        GetWriter.Stream.Write(str[1], 10);
      end
    end
    else GetWriter.WriteData(i, str);
  end;
end;

{ TShortFieldNameGenerator }

constructor TShortFieldNameGenerator.Create;
begin
  inherited;
  FFieldNames := TStringList.Create;
  FFieldNames.Sorted := True;
  FFieldNames.Duplicates := dupIgnore;
end;

destructor TShortFieldNameGenerator.Destroy;
begin
  FFieldNames.Free;
  inherited;
end;

function TShortFieldNameGenerator.GetNumberString(const AValue: Integer): string;
begin
  Result := Format('~%d', [AValue]);
end;

function TShortFieldNameGenerator.GetShortFieldName(AFieldName: string): string;
var
  i: Integer;
  ns: string;
begin
  Delete(AFieldName, MAX_FIELD_NAME_LEN + 1, MaxInt);
  Result := AFieldName;
  if FFieldNames.Find(AFieldName, i) then
  begin
    FFieldNames.Objects[i] := TObject(Integer(FFieldNames.Objects[i]) + 1);
    ns := GetNumberString(Integer(FFieldNames.Objects[i]));
    Delete(AFieldName, MAX_FIELD_NAME_LEN - Length(ns) + 1, Length(ns));
    Result := AFieldName + ns;
    if FFieldNames.Find(Result, i) then
      Result := IncNumberString(Result);
    FFieldNames.AddObject(Result, TObject(0));
  end
  else
    FFieldNames.AddObject(AFieldName, TObject(0));
end;

function TShortFieldNameGenerator.IncNumberString(const AValue: string): string;
var
  p, n: Integer;
  s, ns: string;
begin
  Result := AValue;
  p := Pos('~', AValue);
  if p = 0 then Exit;
  s := Copy(AValue, p + 1, MaxInt);
  n := StrToIntDef(s, -1);
  if n = -1 then Exit;
  Inc(n);
  ns := GetNumberString(n);
  Delete(Result, MAX_FIELD_NAME_LEN - Length(ns) + 1, Length(ns));
  Result := Result + ns;
end;

end.

