//采用BIFF8格式规范二进制流写入XLS文件
function TsycFunctionSet.sycExportDateToExcel(ASender: TDBGrid): Boolean;
var arXlsBegin: array[0..5] of Word ;
var arXlsEnd: array[0..1] of Word;
var arXlsString: array[0..5] of Word;
var arXlsNumber: array[0..4] of Word;
var arXlsInteger: array[0..4] of Word;
var arXlsBlank: array[0..4] of Word;
var i : Integer;
var Col, Row: WORD;
var aBookMark: TBookMark;
var aFileStream: TFileStream;
var aSaveDlg : TSaveDialog;
var xlsFileName : string;
//--------------内嵌写单元格函数开始-----------------------
procedure XLSWriteStringCell(nRow,nCol : WORD;AValue: String);//写字符串数据
var L: Word;
var _str : AnsiString;
begin
_str:=AnsiString(AValue);//强制类型转换,兼容Delphi2009,采用String类型要乱码,Delphi2007以下此行代码无所谓
L := Length(_str);//Length返回的字符个数,采用AnsiString也就是字节长度
arXlsString[1] := 8 + L;
arXlsString[2] := nRow;
arXlsString[3] := nCol;
arXlsString[5] := L;
aFileStream.WriteBuffer(arXlsString, SizeOf(arXlsString));
aFileStream.WriteBuffer(Pointer(_str)^, L);//字节长度
end;procedure XLSWriteIntegerCell(nRow,nCol : WORD;AValue: Integer);//写整数
var V: DWORD;
begin
arXlsInteger[2] := nRow;
arXlsInteger[3] := nCol;
aFileStream.WriteBuffer(arXlsInteger, SizeOf(arXlsInteger));
V := (AValue shl 2) or 2;
aFileStream.WriteBuffer(V, 4);
end;procedure XLSWriteFloatCell(nRow,nCol : WORD;AValue: Double);//写浮点数
begin
arXlsNumber[2] := nRow;
arXlsNumber[3] := nCol;
aFileStream.WriteBuffer(arXlsNumber, SizeOf(arXlsNumber));
aFileStream.WriteBuffer(AValue, 8);
end;
//--------------内嵌写单元格函数结束-----------------------
begin
//-----------------------主函数体开始------------------------
//单元格记录的BIFF8定义,直所以用代码初始化数组,就是为了函数绿色嘛
arXlsBegin[0]:=$809;arXlsBegin[1]:=8;arXlsBegin[2]:=0;arXlsBegin[3]:=$10;arXlsBegin[4]:=0;arXlsBegin[5]:=0 ;
arXlsEnd[0]:=$0A;arXlsEnd[1]:=0;
arXlsString[0]:=$204;arXlsString[1]:=0;arXlsString[2]:=0;arXlsString[3]:=0;arXlsString[4]:=0;arXlsString[5]:=0;
arXlsNumber[0]:=$203;arXlsNumber[1]:=14;arXlsNumber[2]:=0;arXlsNumber[3]:=0;arXlsNumber[4]:=0;
arXlsInteger[0]:=$27E;arXlsInteger[1]:=10;arXlsInteger[2]:=0;arXlsInteger[3]:=0;arXlsInteger[4]:=0;
arXlsBlank[0]:=$201;arXlsBlank[1]:=6;arXlsBlank[2]:=0;arXlsBlank[3]:=0;arXlsBlank[4]:=$17;//将DBGrid数据导出到Excel表
Result:=False;
if ASender=nil then
Exit;
if not Assigned(ASender) then
Exit; //数据表未分配
if ASender.Columns.Count=0 then
Exit;//DBGrid没有固定列
if not Assigned(ASender.DataSource) then
Exit; //数据源表未分配
if not Assigned(ASender.DataSource.DataSet) then
Exit; //数据集未分配
if not ASender.DataSource.DataSet.Active then
Exit; //数据集未打开
if ASender.DataSource.DataSet.RecordCount=0 then
Exit; //数据集无记录
if ASender.DataSource.DataSet.RecordCount>65535 then
begin
if Application.MessageBox('由于数据量太多,Excel电子表格只能容纳最前面的65535条资料,之后的资料无法导出,确认要导出吗!','提示',MB_ICONQUESTION or MB_YESNO)<>mrYes then
Exit;//用户放弃导出
end;
aSaveDlg:=TSaveDialog.Create(nil);
aSaveDlg.Title:='输入导出数据的Excel电子表格文件名称';
aSaveDlg.Filter:='Microsoft Excel电子表格文件|*.XLS';
aSaveDlg.DefaultExt:='XLS';
aSaveDlg.Options:=[ofHideReadOnly,ofFileMustExist,ofPathMustExist];
if not aSaveDlg.Execute then
begin //注意此对话框用户可能改变程序的“当前文件夹”位置,函数反会后,为了程序更健壮,建议处理重置当前文件夹位置
aSaveDlg.Free;
Exit;//文件打开失败或用户撤销
end;
xlsFileName:=aSaveDlg.FileName;//存盘文件名称
aSaveDlg.Free;if FileExists(xlsFileName) then
DeleteFile(xlsFileName); //如果选择的导出文件存在,先删除aFileStream := TFileStream.Create(xlsFileName, fmCreate);
ASender.DataSource.DataSet.DisableControls;
try
//写文件头
aFileStream.WriteBuffer(arXlsBegin, SizeOf(arXlsBegin)); Col:=0;Row:=0;//内XSL表格坐标变量
//写列头,为第0行
for i:=0 to ASender.Columns.Count-1 do
begin //仅导出选中列的标题,并且该列是可见的,并且列标题没有字体删除线风格
XLSWriteStringCell(Row,Col,ASender.Columns.Items[i].Title.Caption);
Inc(Col);
end;
//写数据集中的数据,从第1行
Row:=1;Col:=0;
aBookMark := ASender.DataSource.DataSet.GetBook;//保存数据集导出前的光标位置
ASender.DataSource.DataSet.First;
while not ASender.DataSource.DataSet.Eof do
begin
for i := 0 to ASender.Columns.Count-1 do
begin
case ASender.Columns[i].Field.DataType of
ftSmallint, ftInteger, ftWord, ftAutoInc: //整数字段
XLSWriteIntegerCell(Row,Col,ASender.Columns[i].Field.AsInteger);
ftFloat, ftCurrency, ftBCD://浮点字段
XLSWriteFloatCell(Row,Col,ASender.Columns[i].Field.AsFloat)
else //其它所有类型字段,此处用DisplayText,而不用AsString ,为了模仿和DBGrid里面完全一致的显示效果,所谓的所见即所得效果嘛...
XLSWriteStringCell(Row,Col,ASender.Columns[i].Field.DisplayText);
end;//end of case of
Inc(Col);//一行内增加列数
end;//end of for
if Row=65535 then
Break;//写完第65535行后(如果有),直接退出循环,包括标题,最多65536行(行标从0到65535)
Inc(Row);//开始新的一行
Col:=0;//新的一行开始,从第0列开始计数
ASender.DataSource.DataSet.Next;
end;// end of while
//写文件尾
aFileStream.WriteBuffer(arXlsEnd, SizeOf(arXlsEnd));
if ASender.DataSource.DataSet.BookValid(aBookMark) then
ASender.DataSource.DataSet.GotoBook(aBookMark);//还原数据集导出前的光标位置
Result:=True;
except
Result:=False;
end; //end of try//存盘文件
aFileStream.Free;
ASender.DataSource.DataSet.EnableControls;end;
function TsycFunctionSet.sycExportDateToExcel(ASender: TDBGrid): Boolean;
var arXlsBegin: array[0..5] of Word ;
var arXlsEnd: array[0..1] of Word;
var arXlsString: array[0..5] of Word;
var arXlsNumber: array[0..4] of Word;
var arXlsInteger: array[0..4] of Word;
var arXlsBlank: array[0..4] of Word;
var i : Integer;
var Col, Row: WORD;
var aBookMark: TBookMark;
var aFileStream: TFileStream;
var aSaveDlg : TSaveDialog;
var xlsFileName : string;
//--------------内嵌写单元格函数开始-----------------------
procedure XLSWriteStringCell(nRow,nCol : WORD;AValue: String);//写字符串数据
var L: Word;
var _str : AnsiString;
begin
_str:=AnsiString(AValue);//强制类型转换,兼容Delphi2009,采用String类型要乱码,Delphi2007以下此行代码无所谓
L := Length(_str);//Length返回的字符个数,采用AnsiString也就是字节长度
arXlsString[1] := 8 + L;
arXlsString[2] := nRow;
arXlsString[3] := nCol;
arXlsString[5] := L;
aFileStream.WriteBuffer(arXlsString, SizeOf(arXlsString));
aFileStream.WriteBuffer(Pointer(_str)^, L);//字节长度
end;procedure XLSWriteIntegerCell(nRow,nCol : WORD;AValue: Integer);//写整数
var V: DWORD;
begin
arXlsInteger[2] := nRow;
arXlsInteger[3] := nCol;
aFileStream.WriteBuffer(arXlsInteger, SizeOf(arXlsInteger));
V := (AValue shl 2) or 2;
aFileStream.WriteBuffer(V, 4);
end;procedure XLSWriteFloatCell(nRow,nCol : WORD;AValue: Double);//写浮点数
begin
arXlsNumber[2] := nRow;
arXlsNumber[3] := nCol;
aFileStream.WriteBuffer(arXlsNumber, SizeOf(arXlsNumber));
aFileStream.WriteBuffer(AValue, 8);
end;
//--------------内嵌写单元格函数结束-----------------------
begin
//-----------------------主函数体开始------------------------
//单元格记录的BIFF8定义,直所以用代码初始化数组,就是为了函数绿色嘛
arXlsBegin[0]:=$809;arXlsBegin[1]:=8;arXlsBegin[2]:=0;arXlsBegin[3]:=$10;arXlsBegin[4]:=0;arXlsBegin[5]:=0 ;
arXlsEnd[0]:=$0A;arXlsEnd[1]:=0;
arXlsString[0]:=$204;arXlsString[1]:=0;arXlsString[2]:=0;arXlsString[3]:=0;arXlsString[4]:=0;arXlsString[5]:=0;
arXlsNumber[0]:=$203;arXlsNumber[1]:=14;arXlsNumber[2]:=0;arXlsNumber[3]:=0;arXlsNumber[4]:=0;
arXlsInteger[0]:=$27E;arXlsInteger[1]:=10;arXlsInteger[2]:=0;arXlsInteger[3]:=0;arXlsInteger[4]:=0;
arXlsBlank[0]:=$201;arXlsBlank[1]:=6;arXlsBlank[2]:=0;arXlsBlank[3]:=0;arXlsBlank[4]:=$17;//将DBGrid数据导出到Excel表
Result:=False;
if ASender=nil then
Exit;
if not Assigned(ASender) then
Exit; //数据表未分配
if ASender.Columns.Count=0 then
Exit;//DBGrid没有固定列
if not Assigned(ASender.DataSource) then
Exit; //数据源表未分配
if not Assigned(ASender.DataSource.DataSet) then
Exit; //数据集未分配
if not ASender.DataSource.DataSet.Active then
Exit; //数据集未打开
if ASender.DataSource.DataSet.RecordCount=0 then
Exit; //数据集无记录
if ASender.DataSource.DataSet.RecordCount>65535 then
begin
if Application.MessageBox('由于数据量太多,Excel电子表格只能容纳最前面的65535条资料,之后的资料无法导出,确认要导出吗!','提示',MB_ICONQUESTION or MB_YESNO)<>mrYes then
Exit;//用户放弃导出
end;
aSaveDlg:=TSaveDialog.Create(nil);
aSaveDlg.Title:='输入导出数据的Excel电子表格文件名称';
aSaveDlg.Filter:='Microsoft Excel电子表格文件|*.XLS';
aSaveDlg.DefaultExt:='XLS';
aSaveDlg.Options:=[ofHideReadOnly,ofFileMustExist,ofPathMustExist];
if not aSaveDlg.Execute then
begin //注意此对话框用户可能改变程序的“当前文件夹”位置,函数反会后,为了程序更健壮,建议处理重置当前文件夹位置
aSaveDlg.Free;
Exit;//文件打开失败或用户撤销
end;
xlsFileName:=aSaveDlg.FileName;//存盘文件名称
aSaveDlg.Free;if FileExists(xlsFileName) then
DeleteFile(xlsFileName); //如果选择的导出文件存在,先删除aFileStream := TFileStream.Create(xlsFileName, fmCreate);
ASender.DataSource.DataSet.DisableControls;
try
//写文件头
aFileStream.WriteBuffer(arXlsBegin, SizeOf(arXlsBegin)); Col:=0;Row:=0;//内XSL表格坐标变量
//写列头,为第0行
for i:=0 to ASender.Columns.Count-1 do
begin //仅导出选中列的标题,并且该列是可见的,并且列标题没有字体删除线风格
XLSWriteStringCell(Row,Col,ASender.Columns.Items[i].Title.Caption);
Inc(Col);
end;
//写数据集中的数据,从第1行
Row:=1;Col:=0;
aBookMark := ASender.DataSource.DataSet.GetBook;//保存数据集导出前的光标位置
ASender.DataSource.DataSet.First;
while not ASender.DataSource.DataSet.Eof do
begin
for i := 0 to ASender.Columns.Count-1 do
begin
case ASender.Columns[i].Field.DataType of
ftSmallint, ftInteger, ftWord, ftAutoInc: //整数字段
XLSWriteIntegerCell(Row,Col,ASender.Columns[i].Field.AsInteger);
ftFloat, ftCurrency, ftBCD://浮点字段
XLSWriteFloatCell(Row,Col,ASender.Columns[i].Field.AsFloat)
else //其它所有类型字段,此处用DisplayText,而不用AsString ,为了模仿和DBGrid里面完全一致的显示效果,所谓的所见即所得效果嘛...
XLSWriteStringCell(Row,Col,ASender.Columns[i].Field.DisplayText);
end;//end of case of
Inc(Col);//一行内增加列数
end;//end of for
if Row=65535 then
Break;//写完第65535行后(如果有),直接退出循环,包括标题,最多65536行(行标从0到65535)
Inc(Row);//开始新的一行
Col:=0;//新的一行开始,从第0列开始计数
ASender.DataSource.DataSet.Next;
end;// end of while
//写文件尾
aFileStream.WriteBuffer(arXlsEnd, SizeOf(arXlsEnd));
if ASender.DataSource.DataSet.BookValid(aBookMark) then
ASender.DataSource.DataSet.GotoBook(aBookMark);//还原数据集导出前的光标位置
Result:=True;
except
Result:=False;
end; //end of try//存盘文件
aFileStream.Free;
ASender.DataSource.DataSet.EnableControls;end;
解决方案 »
- 复制文件时窗体怎么不显示
- 老冯终于穿上Five条panties.特开Virgin仓以答谢各位社员.老冯潜水前之作同期公布。
- 托盘图标为什么在程序退出后还不消失?
- 用delphi开的程序在win2000中可以。为什么在XP中不可以。
- jpg->bmp
- 在DBGrid中怎么实现拖动?
- 用了NMUDP构件就不能关机怎么办?急!!!
- 各位大哥大姐,帮帮忙吧,近来看看这个日期嵌套查询问题!!!!!!!!!!!!!!!!!!!!!!!!!!!
- 我的第二张表为什么不能保存?~进来看看代码!
- 有可以完成Object Inspector功能的控件吗?
- 关于DELPHI 编写 IIS的ISAPI过滤问题。急
- 急,新手求如何按照固定格式向数据库中批量插入数据
以上代码我是从网上Copy过来的。导出Excel一般是两种方法
1.采用OLE机制,激活EXCELApplication,添加数据进去,这样的功能强大,能完成很多格式化,工作表相关的功能。
缺点是速度慢,而且用户机器上必须安装Excel应用程序。2.根据微软公布的BIFF文件格式,直接二进制流读写Excel表格文件,优点是速度快,客户机器上不需要安装Excel应用程序。缺点是功能有限(起码要实现更多复杂的功能,得对BIFF格式有非常熟悉的研究)导出Excel面临的一般性常见问题
1。速度问题,速度快,用二进制流读写,不过功能有限。OLE方式速度慢,功能强大。
2。数据量的问题。Excel单张数据表最大容量是65536行。因此超过次限制的大量数据,只能新建工作表继续导入,直到导出完毕
3。客户机是否安装Office软件。OLE方式要求必须安装,并且OLE服务注册正常,某些精简安装版本一些COM服务注册不正常,导致OLE导出失败,这个是程序员无法预知的。目前,Delphi有很多现成的控件可以直接二进制方式读写Excel文件,盒子也有下载的。
鉴于绿色轻便的要求,我copy了一段代码,这个函数单独运行,外部依赖小,而且代码非常简单,同时兼容D6-D2007,Delphi2009,不会出现乱码。考虑到大多数情况下,我们导出数据到Excel都是普通的二维表,数据类型不复杂,以上这个函数能处理大多数常见情况。分不多,同新手交流学习,因为代码我也是copy后处理了下为绿色函数而已。老鸟就不要扔砖头了。
下面的代码是从www.aiDelphi.com中找到的。与楼主的代码基本一致!
使用方法是
Var MyExcel : TDS2Excel
Begin
: : : :
MyExcel := TDS2Excel.Create(aDataSet: TDataSet;aDBGrid:TDBGrid)
Save2File(XLS文件名, WillWriteHead); //文件名,字段名做表格列头。
// Save2Files(WillWriteHead: Boolean); 该过程会自动弹出文件对话框,供用户自己选择文件名
: : : :
End ;实际上Express的cxGride控件也是采用这种方法实现数据表格导出到Excal的。
===============================
DELPHI 写EXCEL的XLS格式文件
===============================
unit ObjectUnit;interfaceUses
DB, Classes, Dialogs,DBGrids,Controls;
var
CXlsBof: array[0..5] of Word = ($809, 8, 0, $10, 0, 0);
CXlsEof: array[0..1] of Word = ($0A, 00);
CXlsLabel: array[0..5] of Word = ($204, 0, 0, 0, 0, 0);
CXlsNumber: array[0..4] of Word = ($203, 14, 0, 0, 0);
CXlsRk: array[0..4] of Word = ($27E, 10, 0, 0, 0);
CXlsBlank: array[0..4] of Word = ($201, 6, 0, 0, $17);Type
TDS2Excel = Class(TObject)
Private
FCol: word;
FRow: word;
FDataSet: TDataSet;
FDbGrid :TDbGrid;
Stream: TStream;
FWillWriteHead: boolean;
FBookMark: TBook;
procedure IncColRow;
procedure WriteBlankCell;
procedure WriteFloatCell(const AValue: Double);
procedure WriteIntegerCell(const AValue: Integer);
procedure WriteStringCell(const AValue: string);
procedure WritePrefix;
procedure WriteSuffix;
procedure WriteTitle;
procedure WriteDataCell; procedure Save2Stream(aStream: TStream);
Public
procedure Save2File(FileName: string; WillWriteHead: Boolean);
procedure Save2Files(WillWriteHead: Boolean);
Constructor Create(aDataSet: TDataSet;aDBGrid:TDBGrid);
end;implementationuses SysUtils;Constructor TDS2Excel.Create(aDataSet: TDataSet;aDBGrid:TDBGrid);
begin
inherited Create;
FDataSet := aDataSet;
FDbGrid :=aDbGrid;
end;
procedure TDS2Excel.IncColRow;
begin
if FDbGrid<>nil then
begin
if FCol = FDbGrid.Columns.Count - 1 then
begin
Inc(FRow);
FCol :=0;
end
else
Inc(FCol);
end else
begin
if FCol = FDataSet.FieldCount - 1 then
begin
Inc(FRow);
FCol :=0;
end
else
Inc(FCol);
end;
end;procedure TDS2Excel.WriteBlankCell;
begin
CXlsBlank[2] := FRow;
CXlsBlank[3] := FCol;
Stream.WriteBuffer(CXlsBlank, SizeOf(CXlsBlank));
IncColRow;
end;procedure TDS2Excel.WriteFloatCell(const AValue: Double);
begin
CXlsNumber[2] := FRow;
CXlsNumber[3] := FCol;
Stream.WriteBuffer(CXlsNumber, SizeOf(CXlsNumber));
Stream.WriteBuffer(AValue, 8);
IncColRow;
end;procedure TDS2Excel.WriteIntegerCell(const AValue: Integer);
var
V: Integer;
begin
CXlsRk[2] := FRow;
CXlsRk[3] := FCol;
Stream.WriteBuffer(CXlsRk, SizeOf(CXlsRk));
V := (AValue shl 2) or 2;
Stream.WriteBuffer(V, 4);
IncColRow;
end;procedure TDS2Excel.WriteStringCell(const AValue: string);
var
L: Word;
begin
L := Length(AValue);
CXlsLabel[1] := 8 + L;
CXlsLabel[2] := FRow;
CXlsLabel[3] := FCol;
CXlsLabel[5] := L;
Stream.WriteBuffer(CXlsLabel, SizeOf(CXlsLabel));
Stream.WriteBuffer(Pointer(AValue)^, L);
IncColRow;
end;procedure TDS2Excel.WritePrefix;
begin
Stream.WriteBuffer(CXlsBof, SizeOf(CXlsBof));
end;procedure TDS2Excel.WriteSuffix;
begin
Stream.WriteBuffer(CXlsEof, SizeOf(CXlsEof));
end;procedure TDS2Excel.WriteTitle;
var
n: word;
begin
if FDbGrid <> nil then
for n := 0 to FDBGrid.Columns.Count - 1 do
WriteStringCell(FDBGrid.Columns[n].Title.Caption)
else
for n := 0 to FDataSet.FieldCount - 1 do
WriteStringCell(FDataSet.Fields[n].FieldName);
end;procedure TDS2Excel.WriteDataCell;
var
n: word;
begin WritePrefix;
if FWillWriteHead then WriteTitle;
FDataSet.DisableControls;
FBookMark := FDataSet.GetBook;
FDataSet.First; if FDbGrid=nil then
begin
while not FDataSet.Eof do
begin
for n := 0 to FDataSet.FieldCount - 1 do
begin
try
if FDataSet.Fields[n].IsNull then
WriteBlankCell
else begin
case FDataSet.Fields[n].DataType of
ftSmallint, ftInteger, ftWord, ftAutoInc, ftBytes:
WriteIntegerCell(FDataSet.Fields[n].AsInteger);
ftFloat, ftCurrency, ftBCD:
WriteFloatCell(FDataSet.Fields[n].AsFloat);
ftTypedBinary:
else
WriteStringCell(FDataSet.Fields[n].AsString);
end;
end;
except
WriteBlankCell;
end;
end;
FDataSet.Next;
end;
end else begin
while not FDbGrid.DataSource.DataSet.Eof do
begin for n := 0 to FDbGrid.Columns.Count - 1 do
begin if FDbGrid.Columns[n].Field.IsNull then
WriteBlankCell
else begin
case FDbGrid.Columns[n].Field.DataType of
ftSmallint, ftInteger, ftWord, ftAutoInc, ftBytes:
WriteIntegerCell(FDbGrid.Columns[n].Field.AsInteger);
ftFloat, ftCurrency, ftBCD:
WriteFloatCell(FDbGrid.Columns[n].Field.AsFloat);
else
WriteStringCell(FDbGrid.Columns[n].Field.AsString);
end;
end;
end;
FDbGrid.DataSource.DataSet.Next
end;
end;
WriteSuffix;
if FDataSet.BookValid(FBookMark) then FDataSet.GotoBook(FBookMark);
FDataSet.EnableControls;
end;procedure TDS2Excel.Save2Stream(aStream: TStream);
begin
FCol := 0;
FRow := 0;
Stream := aStream;
WriteDataCell;
end;procedure TDS2Excel.Save2File(FileName: string; WillWriteHead: Boolean);
var
aFileStream: TFileStream;
begin
FWillWriteHead := WillWriteHead;
if FileExists(FileName) then DeleteFile(FileName);
aFileStream := TFileStream.Create(FileName, fmCreate);
Try
Save2Stream(aFileStream);
Finally
aFileStream.Free;
end;
end;procedure TDS2Excel.Save2FileS(WillWriteHead: Boolean);
var
SaveDialog11: TSaveDialog;
begin
SaveDialog11 := TSaveDialog.Create(nil);
Try
SaveDialog11.Filter := 'Excel文档|*.xls';
SaveDialog11.InitialDir := 'D:\';
SaveDialog11.FileName:='*.xls';
if not SaveDialog11.Execute then exit;
if FileExists(SaveDialog11.FileName) then DeleteFile(SaveDialog11.FileName);
Save2File(SaveDialog11.FileName, WillWriteHead);
Finally
SaveDialog11.Free;
end;
end;end.