Export to XLS without Excel from Delphi

by Radek Červinka 14. February 2011 21:42

Usually for export to XLS is used Excel through automation, but I'm looking for an alternative solution without Excel (CSV is not good alternative and primary target is OpenOffice). And I finally found both commercial and OSS solutions.

Commercial solution is provided by scalabium.com or SM Software and the second can also read. For my purpose both are so complex (and expensive, because this problem is only small code part). But this information can be important for someone else.

From OSS solutions is often recommended TmxNativeExcel in combination with TmxExports (same page). It would allow exports to XLS version BIFF 2 - 5. BIFF5 is probably Excel 5.0, but can be opened in current version of Excel or OpenOffice Calc. But it did not work for me fine.

At the end I finally found (in deep China Internet) snippet of code for export to BIFF5 and for my surprise work almost correctly - except diacritics (for not familiar with Czech language - our language is full of diacritics), but this is not problem of English language.

Google give me hint about code pages in XLS - XLS file format (really big PDF from OpenOffice) and thanks to this excellent PDF I wrote about five lines for proper CodePage support (for me CP1250 - BIFF5 is not unicode) and fixed small UNICODE Delphi problems and small problem about file create.

This unit include procedure for export TDataset to XLS.

And small hint for code hackers::

    1procedure TXLSWriter.WriteCodePage;
    2begin
    3  WriteWord($0042); // OPCODE CODEPAGE see PDF
    4  WriteWord($0002); // size: 2 bytes
    5  WriteWord($04E2); // CP1250
    6  //- >http://sc.openoffice.org/excelfileformat.pdf , section 5.17
    7end;

First line is section code (see PDF), next is size of following data (it's unclear in PDF) and finally data. BTW: important is write this in right position during generate of file - see TDataSet export.

Maybe it will be useful to someone.

source code: uNativeXLSExport.pas.

unit uNativeXLSExport;

// based on internet, generate basic BIFF5 XLS
// http://sc.openoffice.org/excelfileformat.pdf
// CodePage support (see WriteCodePage)
// and Unicode compatibility  - Radek Cervinka, delphi.cz
interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Grids, Forms,
  Dialogs, db, dbctrls, comctrls;

const
  { BOF }
  CBOF = $0009;
  BIT_BIFF5 = $0800;
  BOF_BIFF5 = CBOF or BIT_BIFF5;
  { EOF }
  BIFF_EOF = $000A;
  { Document types }
  DOCTYPE_XLS = $0010;
  { Dimensions }
  DIMENSIONS = $0000;

type
  TAtributCell = (acHidden, acLocked, acShaded, acBottomBorder, acTopBorder,
    acRightBorder, acLeftBorder, acLeft, acCenter, acRight, acFill);

  TSetOfAtribut = set of TAtributCell;

  TXLSWriter = class(Tobject)
  private
    fstream: TFileStream;
    procedure WriteWord(w: word);
  protected
    procedure WriteBOF;
    procedure WriteEOF;
    procedure WriteDimension;
    procedure WriteCodePage;
  public
    maxCols, maxRows: word;
    procedure CellWord(vCol, vRow: word; aValue: word;
      vAtribut: TSetOfAtribut = []);
    procedure CellDouble(vCol, vRow: word; aValue: double;
      vAtribut: TSetOfAtribut = []);
    procedure CellStr(vCol, vRow: word; aValue: String;
      vAtribut: TSetOfAtribut = []);
    procedure WriteField(vCol, vRow: word; Field: TField);
    constructor create(vFileName: string);
    destructor Destroy; override;
  end;

procedure SetCellAtribut(value: TSetOfAtribut; var FAtribut: array of byte);
procedure DataSetToXLS(ds: TDataSet; fname: String);
procedure StringGridToXLS(grid: TStringGrid; fname: String);

implementation

procedure DataSetToXLS(ds: TDataSet; fname: String);
var
  c, r: Integer;
  xls: TXLSWriter;
begin
  xls := TXLSWriter.create(fname);
  if ds.FieldCount > xls.maxCols then
    xls.maxCols := ds.FieldCount + 1;
  try
    xls.WriteBOF;
    xls.WriteCodePage;

    xls.WriteDimension;
    for c := 0 to ds.FieldCount - 1 do
      xls.CellStr(0, c, ds.Fields[c].FieldName);
    r := 1;
    ds.first;
    while (not ds.eof) and (r <= xls.maxRows) do
    begin
      for c := 0 to ds.FieldCount - 1 do
        xls.WriteField(r, c, ds.Fields[c]);
      inc(r);
      ds.next;
    end;
    xls.WriteEOF;

    // <2002-11-17> dllee
    // ?? Dimension ?? wirteEOF ??,???? if ??? Seek ?? position
    // if r > xls.maxrows then begin
    // xls.maxrows:=r+1;
    // xls.fstream.Seek(10,soFromBeginning);
    // xls.WriteDimension;
    // end;
    // ????? maxrows ?????,????????? 65535,??,?????
  finally
    xls.free;
  end;
end;

procedure StringGridToXLS(grid: TStringGrid; fname: String);
var
  c, r, rMax: Integer;
  xls: TXLSWriter;
begin
  xls := TXLSWriter.create(fname);
  rMax := grid.RowCount;
  if grid.ColCount > xls.maxCols then
    xls.maxCols := grid.ColCount + 1;
  if rMax > xls.maxRows then // ???????? 65535 Rows
    rMax := xls.maxRows;
  try
    xls.WriteBOF;
    xls.WriteDimension;
    for c := 0 to grid.ColCount - 1 do
      for r := 0 to rMax - 1 do
        xls.CellStr(r, c, grid.Cells[c, r]);
    xls.WriteEOF;
  finally
    xls.free;
  end;
end;

{ TXLSWriter }

constructor TXLSWriter.create(vFileName: string);
begin
  inherited create;
  if FileExists(vFileName) then
  begin
    fstream := TFileStream.create(vFileName, fmOpenWrite);
    fstream.Size := 0;
  end
  else
    fstream := TFileStream.create(vFileName, fmCreate);

  maxCols := 100; // <2002-11-17> dllee Column ???????? 65535, ??????
  maxRows := 65535; // <2002-11-17> dllee ???????????,?????????????????
end;

destructor TXLSWriter.destroy;
begin
  if fstream <> nil then
    fstream.free;
  inherited;
end;

procedure TXLSWriter.WriteBOF;
begin
  WriteWord(BOF_BIFF5);
  WriteWord(6); // count of bytes
  WriteWord(0);
  WriteWord(DOCTYPE_XLS);
  WriteWord(0);
end;

procedure TXLSWriter.WriteDimension;
begin
  WriteWord(DIMENSIONS); // dimension OP Code
  WriteWord(8); // count of bytes
  WriteWord(0); // min cols
  WriteWord(maxRows); // max rows
  WriteWord(0); // min rowss
  WriteWord(maxCols); // max cols
end;

procedure TXLSWriter.CellDouble(vCol, vRow: word; aValue: double;
  vAtribut: TSetOfAtribut);
var
  FAtribut: array [0 .. 2] of byte;
begin
  WriteWord(3); // opcode for double
  WriteWord(15); // count of byte
  WriteWord(vCol);
  WriteWord(vRow);
  SetCellAtribut(vAtribut, FAtribut);
  fstream.Write(FAtribut, 3);
  fstream.Write(aValue, 8);
end;

procedure TXLSWriter.CellWord(vCol, vRow: word; aValue: word;
  vAtribut: TSetOfAtribut = []);
var
  FAtribut: array [0 .. 2] of byte;
begin
  WriteWord(2); // opcode for word
  WriteWord(9); // count of byte
  WriteWord(vCol);
  WriteWord(vRow);
  SetCellAtribut(vAtribut, FAtribut);
  fstream.Write(FAtribut, 3);
  WriteWord(aValue);
end;

procedure TXLSWriter.CellStr(vCol, vRow: word; aValue: String;
  vAtribut: TSetOfAtribut);
var
  FAtribut: array [0 .. 2] of byte;
  slen: byte;
begin
  WriteWord(4); // opcode for string
  slen := length(aValue);
  WriteWord(slen + 8); // count of byte
  WriteWord(vCol);
  WriteWord(vRow);

  SetCellAtribut(vAtribut, FAtribut);
  fstream.Write(FAtribut, 3);

  fstream.Write(slen, 1);
{$IFDEF UNICODE}
  fstream.Write(AnsiString(aValue)[1], slen);
{$ELSE}
  fstream.Write(aValue[1], slen);
{$ENDIF}
end;

procedure SetCellAtribut(value: TSetOfAtribut; var FAtribut: array of byte);
var
  i: Integer;
begin
  // reset
  for i := 0 to High(FAtribut) do
    FAtribut[i] := 0;

  { Byte Offset     Bit   Description                     Contents
    0          7     Cell is not hidden              0b
    Cell is hidden                  1b
    6     Cell is not locked              0b
    Cell is locked                  1b
    5-0   Reserved, must be 0             000000b
    1          7-6   Font number (4 possible)
    5-0   Cell format code
    2          7     Cell is not shaded              0b
    Cell is shaded                  1b
    6     Cell has no bottom border       0b
    Cell has a bottom border        1b
    5     Cell has no top border          0b
    Cell has a top border           1b
    4     Cell has no right border        0b
    Cell has a right border         1b
    3     Cell has no left border         0b
    Cell has a left border          1b
    2-0   Cell alignment code
    general                    000b
    left                       001b
    center                     010b
    right                      011b
    fill                       100b
    Multiplan default align.   111b
  }

  // bit sequence 76543210

  if acHidden in value then // byte 0 bit 7:
    FAtribut[0] := FAtribut[0] + 128;

  if acLocked in value then // byte 0 bit 6:
    FAtribut[0] := FAtribut[0] + 64;

  if acShaded in value then // byte 2 bit 7:
    FAtribut[2] := FAtribut[2] + 128;

  if acBottomBorder in value then // byte 2 bit 6
    FAtribut[2] := FAtribut[2] + 64;

  if acTopBorder in value then // byte 2 bit 5
    FAtribut[2] := FAtribut[2] + 32;

  if acRightBorder in value then // byte 2 bit 4
    FAtribut[2] := FAtribut[2] + 16;

  if acLeftBorder in value then // byte 2 bit 3
    FAtribut[2] := FAtribut[2] + 8;

  // <2002-11-17> dllee ?? 3 bit ??? 1 ???
  if acLeft in value then // byte 2 bit 1
    FAtribut[2] := FAtribut[2] + 1
  else if acCenter in value then // byte 2 bit 1
    FAtribut[2] := FAtribut[2] + 2
  else if acRight in value then // byte 2, bit 0 dan bit 1
    FAtribut[2] := FAtribut[2] + 3
  else if acFill in value then // byte 2, bit 0
    FAtribut[2] := FAtribut[2] + 4;
end;

procedure TXLSWriter.WriteWord(w: word);
begin
  fstream.Write(w, 2);
end;

procedure TXLSWriter.WriteEOF;
begin
  WriteWord(BIFF_EOF);
  WriteWord(0);
end;

procedure TXLSWriter.WriteField(vCol, vRow: word; Field: TField);
begin
  case Field.DataType of
    ftString, ftWideString, ftBoolean, ftDate, ftDateTime, ftTime:
      CellStr(vCol, vRow, Field.asstring);
    ftAutoInc, ftSmallint, ftInteger, ftWord:
      CellWord(vCol, vRow, Field.AsInteger);
    ftFloat, ftBCD:
      CellDouble(vCol, vRow, Field.AsFloat);
  else
    CellStr(vCol, vRow, EmptyStr); // <2002-11-17> dllee ??????????
  end;
end;

procedure TXLSWriter.WriteCodePage;
begin
  WriteWord($0042); // OPCODE CODEPAGE
  WriteWord($0002); // size
  WriteWord($04E2); // CP1250
  //- >http://sc.openoffice.org/excelfileformat.pdf , section 5.17
end;

end.

And for info - languages code from PDF (when PDF is not available):

016FH = 367 = ASCII
01B5H = 437 = IBM PC CP-437 (US)
02D0H = 720 = IBM PC CP-720 (OEM Arabic)
02E1H = 737 = IBM PC CP-737 (Greek)
0307H = 775 = IBM PC CP-775 (Baltic)
0352H = 850 = IBM PC CP-850 (Latin I)
0354H = 852 = IBM PC CP-852 (Latin II (Central European))
0357H = 855 = IBM PC CP-855 (Cyrillic)
0359H = 857 = IBM PC CP-857 (Turkish)
035AH = 858 = IBM PC CP-858 (Multilingual Latin I with Euro)
035CH = 860 = IBM PC CP-860 (Portuguese)
035DH = 861 = IBM PC CP-861 (Icelandic)
035EH = 862 = IBM PC CP-862 (Hebrew)
035FH = 863 = IBM PC CP-863 (Canadian (French))
0360H = 864 = IBM PC CP-864 (Arabic)
0361H = 865 = IBM PC CP-865 (Nordic)
0362H = 866 = IBM PC CP-866 (Cyrillic (Russian))
0365H = 869 = IBM PC CP-869 (Greek (Modern))
036AH = 874 = Windows CP-874 (Thai)
03A4H = 932 = Windows CP-932 (Japanese Shift-JIS)
03A8H = 936 = Windows CP-936 (Chinese Simplified GBK)
03B5H = 949 = Windows CP-949 (Korean (Wansung))
03B6H = 950 = Windows CP-950 (Chinese Traditional BIG5)
04B0H = 1200 = UTF-16 (BIFF8)
04E2H = 1250 = Windows CP-1250 (Latin II) (Central European)
04E3H = 1251 = Windows CP-1251 (Cyrillic)
04E4H = 1252 = Windows CP-1252 (Latin I) (BIFF4-BIFF5)
04E5H = 1253 = Windows CP-1253 (Greek)
04E6H = 1254 = Windows CP-1254 (Turkish)
04E7H = 1255 = Windows CP-1255 (Hebrew)
04E8H = 1256 = Windows CP-1256 (Arabic)
04E9H = 1257 = Windows CP-1257 (Baltic)
04EAH = 1258 = Windows CP-1258 (Vietnamese)
0551H = 1361 = Windows CP-1361 (Korean (Johab))
2710H = 10000 = Apple Roman
8000H = 32768 = Apple Roman
8001H = 32769 = Windows CP-1252 (Latin I) (BIFF2-BIFF3)

Tags: ,

Components

Comments are closed