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)
RSS