最快速实现“数据集导出到 Excel 的模块供大家共享！！ ( 积分: 0 )

  • 主题发起人 主题发起人 凤冠坡
  • 开始时间 开始时间
凤

凤冠坡

Unregistered / Unconfirmed
GUEST, unregistred user!
调用方法：后面2个参数可选
1. ExportToExcel(DBGridEH1);
2. ExportToExcel(DBGridEH1, SB);
3. ExportToExcel(DBGridEH1, SB, 'ABCDE);
---------------------------------------------------------------------------
程序主过程如下：
procedure ExportToExcel(Grid: TDBGridEH; const SB: TStatusBar = nil; const HTittle: string = '请输入报表名称');
Type
SummType = array[0..200] of Real;
var
Str: string;
Book: TBookMark;
Data: TDataSet;
C1, C2: Char;
I, FN, MN, RN: integer;
ExpApp, ExpBook, Sheet: Variant;
FP: TField;
TF: TextFile;
LS: TStringList;
RG: Variant;
Summ: ^SummType;
begin
try
ExpApp := CreateOleObject('Excel.Application');
except
TellMe('没有安装 EXCEL 驱动程序，打印失败');
Exit;
end;
ShowForm.Text := '系统正在读取数据库+';
Screen.Cursor := crHourGlass;

Data := Grid.DataSource.DataSet;
FN := Grid.Columns.Count - 1;
AssignFile(TF, 'C:/Temp.Txt');
Rewrite(TF);
Str := StringOfChar(#9, FN div 2) + HTittle + #13#10;
Writeln(TF, Str);
Str := '';
//生成标题
New(Summ);
for i := 0 to FN do begin
Summ := 0;
Str := Str + Grid.Columns.FieldName + #9;
end;
Delete(Str, Length(Str), 1);
Writeln(TF, Str);

Data.DisableControls;
Book := Data.GetBookmark;
Data.First;
//生成内容
RN := Data.RecordCount;
MN := 0;
repeat
Str := '';
for I := 0 to FN do begin
FP := Grid.Columns.Field;
if FP is TNumericField then begin
Summ := Summ + FP.AsFloat;
end;
Str := Str + FP.Text + #9;
end;
Delete(Str, Length(Str), 1);
Writeln(TF, Str);
Data.Next;
MN := MN + 1;
if (MN mod 100 = 0) and (SB <> nil) then begin
SB.Panels[1].Text := Format('读取进度：%d/%d，按[ESC]键终止取数', [MN, RN]);
SB.Update;
end;
Application.ProcessMessages;
if GetKeyState(VK_ESCAPE) and 128 = 128 then Break;
until Data.eof;
if SB <> nil then begin
SB.Panels[1].Text := '';
SB.Update;
end;
Str := '合计';
for i := 0 to FN do begin
if Summ = 0 then Str := Str + #9 else
Str := Str + FloatToStr(Summ) + #9;
end;
Writeln(TF, Str);
CloseFile(TF);
Data.EnableControls;
Data.GotoBookmark(Book);
Data.FreeBookmark(Book);
ShowForm.Hide;
ShowForm.Text := '系统正在启动Execel程序+';
ExpApp.Caption := 'Delphi 程序导出的数据表格';
ExpBook := ExpApp.Workbooks.Add;
// ExpBook := ExpApp.Workbooks.Open('File01.XLS');
Sheet := ExpBook.WorkSheets[1];
Byte(C1) := FN div 26 + 64;
Byte(C2) := FN mod 26 + 65;
if C1 = #64 then C1 := #32;
Str := 'A3:' + C1 + C2 + IntToStr(MN + 4);
Sheet.Cells.NumberFormatLocal := '@';
LS := TStringList.Create;
LS.LoadFromFile('C:/Temp.TXT');
DeleteFile('C:/Temp.TXT');
Clipboard.AsText := LS.Text;
LS.Free;
Sheet.Paste;
Clipboard.Clear;
RG := Sheet.Range[Str];
RG.Font.Size := 10;
ShowForm.Hide;
ShowForm.Text := '系统正在设置表格线类型+';
RG.HorizontalAlignment := xlCenter;
RG.Borders.Item[5].LineStyle := xlNone;
RG.Borders.Item[6].LineStyle := xlNone;
for i := 7 to 12 do begin
RG.Borders.Item.LineStyle := xlContinuous;
// RG.Borders.Item.Weight := xlThin;
// RG.Borders.Item.ColorIndex := xlAutomatic;
end;
Sheet.Cells.EntireColumn.AutoFit;

Sheet.Rows['1:1'].Font.Size := 25;
Sheet.Rows['1:1'].Font.Bold := True;
Sheet.Range['A4'].Select;
Sheet.Range['A2'] := FormatDateTime('"日期："yyyy"年"mm"月"dd"日"', Date);
ExpBook.Saved := True;
ShowForm.Hide;
ExpApp.Visible := True;
Dispose(Summ);
Screen.Cursor := crDefault;
end;
 
调用方法：后面2个参数可选
1. ExportToExcel(DBGridEH1);
2. ExportToExcel(DBGridEH1, SB);
3. ExportToExcel(DBGridEH1, SB, 'ABCDE);
---------------------------------------------------------------------------
程序主过程如下：
procedure ExportToExcel(Grid: TDBGridEH; const SB: TStatusBar = nil; const HTittle: string = '请输入报表名称');
Type
SummType = array[0..200] of Real;
var
Str: string;
Book: TBookMark;
Data: TDataSet;
C1, C2: Char;
I, FN, MN, RN: integer;
ExpApp, ExpBook, Sheet: Variant;
FP: TField;
TF: TextFile;
LS: TStringList;
RG: Variant;
Summ: ^SummType;
begin
try
ExpApp := CreateOleObject('Excel.Application');
except
TellMe('没有安装 EXCEL 驱动程序，打印失败');
Exit;
end;
ShowForm.Text := '系统正在读取数据库+';
Screen.Cursor := crHourGlass;

Data := Grid.DataSource.DataSet;
FN := Grid.Columns.Count - 1;
AssignFile(TF, 'C:/Temp.Txt');
Rewrite(TF);
Str := StringOfChar(#9, FN div 2) + HTittle + #13#10;
Writeln(TF, Str);
Str := '';
//生成标题
New(Summ);
for i := 0 to FN do begin
Summ := 0;
Str := Str + Grid.Columns.FieldName + #9;
end;
Delete(Str, Length(Str), 1);
Writeln(TF, Str);

Data.DisableControls;
Book := Data.GetBookmark;
Data.First;
//生成内容
RN := Data.RecordCount;
MN := 0;
repeat
Str := '';
for I := 0 to FN do begin
FP := Grid.Columns.Field;
if FP is TNumericField then begin
Summ := Summ + FP.AsFloat;
end;
Str := Str + FP.Text + #9;
end;
Delete(Str, Length(Str), 1);
Writeln(TF, Str);
Data.Next;
MN := MN + 1;
if (MN mod 100 = 0) and (SB <> nil) then begin
SB.Panels[1].Text := Format('读取进度：%d/%d，按[ESC]键终止取数', [MN, RN]);
SB.Update;
end;
Application.ProcessMessages;
if GetKeyState(VK_ESCAPE) and 128 = 128 then Break;
until Data.eof;
if SB <> nil then begin
SB.Panels[1].Text := '';
SB.Update;
end;
Str := '合计';
for i := 0 to FN do begin
if Summ = 0 then Str := Str + #9 else
Str := Str + FloatToStr(Summ) + #9;
end;
Writeln(TF, Str);
CloseFile(TF);
Data.EnableControls;
Data.GotoBookmark(Book);
Data.FreeBookmark(Book);
ShowForm.Hide;
ShowForm.Text := '系统正在启动Execel程序+';
ExpApp.Caption := 'Delphi 程序导出的数据表格';
ExpBook := ExpApp.Workbooks.Add;
// ExpBook := ExpApp.Workbooks.Open('File01.XLS');
Sheet := ExpBook.WorkSheets[1];
Byte(C1) := FN div 26 + 64;
Byte(C2) := FN mod 26 + 65;
if C1 = #64 then C1 := #32;
Str := 'A3:' + C1 + C2 + IntToStr(MN + 4);
Sheet.Cells.NumberFormatLocal := '@';
LS := TStringList.Create;
LS.LoadFromFile('C:/Temp.TXT');
DeleteFile('C:/Temp.TXT');
Clipboard.AsText := LS.Text;
LS.Free;
Sheet.Paste;
Clipboard.Clear;
RG := Sheet.Range[Str];
RG.Font.Size := 10;
ShowForm.Hide;
ShowForm.Text := '系统正在设置表格线类型+';
RG.HorizontalAlignment := xlCenter;
RG.Borders.Item[5].LineStyle := xlNone;
RG.Borders.Item[6].LineStyle := xlNone;
for i := 7 to 12 do begin
RG.Borders.Item.LineStyle := xlContinuous;
// RG.Borders.Item.Weight := xlThin;
// RG.Borders.Item.ColorIndex := xlAutomatic;
end;
Sheet.Cells.EntireColumn.AutoFit;

Sheet.Rows['1:1'].Font.Size := 25;
Sheet.Rows['1:1'].Font.Bold := True;
Sheet.Range['A4'].Select;
Sheet.Range['A2'] := FormatDateTime('"日期："yyyy"年"mm"月"dd"日"', Date);
ExpBook.Saved := True;
ShowForm.Hide;
ExpApp.Visible := True;
Dispose(Summ);
Screen.Cursor := crDefault;
end;
 
多谢楼主无私奉献
 
感谢楼主前一段时间我还在找!!!
 
如果有图片的怎么处理呢？
 
感谢楼主！~~~
刚才试用了一下，速度比我自己写的快了2倍左右，不过5万条数据做下来，时间还是比较可观。[:)]
提点小建议：
//生成标题
New(Summ);
for i := 0 to FN do begin
Summ := 0;
[blue]Str := Str + Grid.Columns.FieldName + #9;[/blue]
end;
点击展开...

是否可以改成
代码: 
Str := Str + Grid.Columns[i].Title.Caption + #9;
 
明天我给一个快的
 
Summ 是用来进行统计数值字段的
 
to caids:

对于5万条记录，效率提高得更加明显。
 
While Not Eof do
begin
sTemp := '';
For i := 0 to FieldCount -1 do
begin
sTemp := sTemp + Fields.AsString + #9;
end;
FFieldLst.Add(sTemp);
Self.ProgressBar1.Position := Self.ProgressBar1.Position + 1;
Next;
end;

Clipbrd.Clipboard.Clear;
Clipbrd.Clipboard.AsText := FFieldLst.GetText;

Try
Self.ExcelApplication1.Connect;
Try
WorkBooks := Self.ExcelApplication1.Workbooks.Add(Null,0);
WorkSheets := WorkBooks.ActiveSheet;
WorkSheets.Cells[FStartRow,FStartCol].Select;
WorkSheets.Paste;
WorkSheets.Name := FFileName;
WorkSheets.Cells.Select;
WorkSheets.Columns.AutoFit;
if FSave then WorkSheets.SaveAs(FFileName);
Result := True;
Finally
Self.ExcelApplication1.Disconnect;
end;
Except
Result := False;
end;
 
To Supermay:
你试过没有啊，数据库集大了，速度非常慢，我以前就是这样做的，
后来才发现，这样得结果是：耗费时间随数据量增加 呈“非线性 ”
增加趋势，而经过我那样改进之后，耗费时间与数据量是“线性 ”
关系（理应如此）。
我已经说明了： S := S + 'ABCD' 这语句运行多了效率非常低！！
 
虽然 String 变量最大可以容纳 2G 字节，
但是 它已使用虚拟内存（说到底还是磁盘），
因此 每次修改 String 变量内容，都直接导致
磁盘操作， 运行String S := S + 'ABCD'；几次
就要把 S 对应区域重复写几次，时间开销是非常可观的
 
用以下的代码试一试，它不需要安装Excel即可完成转换任务，且速度快。
unit XLSFile;

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;
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.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;
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
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
fStream := TFileStream.Create(vFilename, fmOpenWrite)
else
fStream := TFileStream.Create(vFilename, fmCreate);

maxCols := 100;
maxRows := 65535;
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);
fStream.Write(aValue[1], slen);
end;

procedure SetCellAtribut(value: TSetOfAtribut; var FAtribut: array of byte);
var
i: integer;
begin
//reset
for i := 0 to High(FAtribut) do
FAtribut := 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;

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);
end;
end;

end.
 
到底谁的快啊
 
您必须登录或注册才可回复。

Similar threads

R
这是把数据库导出为EXCEL的语句，帮我看一下最后的那句是什么意思？过不了，还请帮我看看这段语句能不能成功的把PARADOX表导出为EXCEL2000(50分)
回复
6
查看
293
redwood
R
笨
大家来讨论一下如何将数据导入到数据库表中去？(100分)
回复
5
查看
147
笨猪
笨
S
抄来的，大家共享。 (0分)
回复
7
查看
242
seeme0526
S
风
大家看看,问题出在哪儿?为什么listview只宣示链表的最后一个数据.(50分)
回复
2
查看
179
风云再起
风
B
在接收端收到的数据与发送端不一致，请大家指出错误？并改下!!(50分)
回复
3
查看
130
baddy
B
后退
顶部