Export do XLS bez excelu v Delphi

vložil Radek Červinka 8. ledna 2011 23:42

Většinou se pro export do Excelu používá automatizace přes Excel, ale pro náš CRM systém jsem hledal alternativu pro export dat do XLS bez Excelu (ne CSV není to pravé) a nakonec jsem našel jsem jak komerční, tak OSS řešení.

Komerční řešení je od scalabium.com nebo od SM Software, přičemž druhé umí i čtení. Pro mé účely je oboje příliš komplexní (a řekněme, že každá Kč je dobrá). Ale někdo tuto informaci snad může potřebovat.

Z OSS řešení je často doporučován TmxNativeExcel v kombinaci s TmxExports (stejná stránka). Měl by umožnit export do XLS ve verzích BIFF 2 - 5. BIFF5 je asi Excel 5.0, ale každopádně jde otevřít i v aktuální verzi Excelu a OpenOffice. Ale u mne nefungoval v pořadku.

Nakonec jsem v hlubinách Internetu v Číně (mimochodem je tam Delphi opravdu moc populární) vyhrabal kus kódu, který umí základní export do BIFF5 a překvapivě fungoval skoro dobře - až na diakritiku.

Když jsem pátral po diakritice v XLS, tak mi google předhodil popis formátu XLS (opravdu velké PDF) na stránkách OpenOffice a díky němu jsem do exportu dopsal pět řádků na nastavení správné kódové stránky (CP1250 - BIFF5 není unicode) a zároveň jsem opravil drobný problém s UNICODE Delphi a vytváření souboru.

Kromě jiného obsahuje přímo proceduru pro export TDataset do XLS.

Jen kdyby chtěl někdo něco doplnit do kódu:

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

Nejdříve se zapisuje kód sekce (viz to PDF), následně velikost následujících dat (to z toho PDF není moc jasné) a pak data. Jen se to musí zapsat na správné místo - viz. export TDataSet.

Tak snad se to někomu bude hodit. Pokud někdo zná jinou možnost klidně může použít komentáře.

zdroják: 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.

Jen pro úplnost kódy jazyka z uvedeného PDF (kdyby nebylo dostupné):

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)

Tagy: ,

Komponenty

Komentáře

1.5.2012 14:54:35 #

radomir23

Dobrý den mozem sa opytat tak ako ste to upravili mi bude z dbgridu správne ukladat do xls ?

v db gridu mam slovenské a anglické vyrazy.

inac max colomn a row sa neda zvecsit office 2010 sa mi zda ze podporuje okolo milion uz neviem presne

velmi pekne dakujem

radomir23

Komentování ukončeno

Naše nabídka

MVP
Ing. Radek Červinka - Embarcadero MVP
profil na linkedin, Twitter:@delphicz

Nabízím placené poradenství a konzultace v oblasti programování a vývoje SW.
Dále nabízíme i vývoj speciálního software na zakázku.

Neváhejte nás kontaktovat (i ohledně reklamy).

love Delphi

O Delphi.cz

Delphi je moderní RAD nástroj podporující tvorbu nativních aplikací pro platformu Win32, Win64, Mac OSX, Linux a na iPhone a Android.

Delphi.cz je nezávislý portál pro uživatele Delphi. Portál není koncipován pro úplné začátečníky, i když i ti se zde nebudou nudit, ale spíše na programátory, kteří již něco znají a chtějí své znalosti dále rozvíjet a sledovat novinky.

Poslední komentáře

Comment RSS

Dle měsíců