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:

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

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)


Nabízíme Delphi školení na různá témata, primárně ve Vaší firmě.

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

Partial English version.

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 nebo burzy práce).

Pokud chcete podpořit tento server libovolnou částkou, můžete použít PayPal. Moc děkuji.

Delphi Certified Developer

O Delphi.cz

Delphi je jediný moderní RAD nástroj podporující tvorbu nativních aplikací pro platformu Win32, Win64 , Mac OSX a na iPhone a Android (s výhledem na další platformy díky FireMonkey) na současném trhu (včetně Windows 8.1).

V současnosti je světová komunita přes dva miliónů vývojářů.

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.

Anketa

Poslední komentáře

Comment RSS