修改的一个导出DataSet到xls的单元.docx
《修改的一个导出DataSet到xls的单元.docx》由会员分享，可在线阅读，更多相关《修改的一个导出DataSet到xls的单元.docx（23页珍藏版）》请在冰豆网上搜索。
修改的一个导出DataSet到xls的单元
修改的一个导出DataSet到xls的单元
关键词:
修改的一个导出DataSet到xls的单元
//首先感谢原作者，但当初在csdn上搜索到该单元时，就没原作者的信息（程序里的有些乱码的注释应该是原作者留下的吧？
呵呵）
//有不足的地方还请各位看官多多指点哈^_^
（*ModifyBy角落的青苔@2005/05/13
说明：
增加导出过程中的回调功能（用户停止，进度条）
是否在第一行插入FieldName
改错：
以前只能对word类型数值写入，DWord会RangeCheckerror；已修正，见CellInteger
//这个单元原来的Col和Row刚好弄反了（已修正）:
-（
增加导出分页的功能，因为xls单页不能超过65536行（采用的笨办法，不知谁有好一点的方法吗？
比如直接写标记表示分页？
）
*）
unitUnitXLSFile;
interface
uses
Windows,Messages,Variants,SysUtils,Classes,Graphics,Controls,Forms,Dialogs,
DB,DBGrids,OleServer,Excel2000;
const_MSG_XLSWriterIsRuning='有其它任务正在导出数据，暂时不能执行该操作，请稍后重试！
';
type
TUserCommand=（UserStop,UserNeedSave,UserNotSave,UserSkip,UserDoNothing）;
TExportXls_CallBackProc=procedure（iPos:
Real）ofobject;
TAtributCell=（acHidden,acLocked,acShaded,acBottomBorder,acTopBorder,
acRightBorder,acLeftBorder,acLeft,acCenter,acRight,acFill）;
TSetOfAtribut=setofTatributCell;
TXLSWriter=class（TObject）
private
fstream:
TFileStream;
procedureWriteWord（w:
word）;
procedureSetCellAtribut（value:
TSetOfAtribut;varFAtribut:
arrayofbyte）;
protected
procedureWriteBOF;
procedureWriteEOF;
procedureWriteDimension;
public
maxCols,maxRows:
Word;
//addby角落的青苔@2005/05/18
procedureCellInteger（vRow,vCol:
word;aValue:
Integer;vAtribut:
TSetOfAtribut=[]）;
procedureCellDouble（vRow,vCol:
word;aValue:
double;vAtribut:
TSetOfAtribut=[]）;
procedureCellStr（vRow,vCol:
word;aValue:
String;vAtribut:
TSetOfAtribut=[]）;
procedureWriteField（vRow,vCol:
word;Field:
TField）;
constructorCreate（vFileName:
string;constvMaxCols:
Integer=100;constvMaxRows:
Integer=65534）;
destructorDestroy;override;
end;
procedureDataSetToXLS（ds:
TDataSet;fname:
String）;
//AddBy角落的青苔@2005/05/13//只能导出最多65536条记录
procedureDBGridToXLS（Grid:
TDBGrid;fname:
String;bSetFieldName:
Boolean;CallFunc:
TExportXls_CallBackProc;bAskForStop:
Boolean=True）;
//AddBy角落的青苔@2005/05/19
//突破xls单页65536行的限制，把数据分成数页
functionDBGridToXlsEx（Grid:
TDBGrid;fname:
String;bSetFieldName:
Boolean;CallFunc:
TExportXls_CallBackProc;constbAskForStop:
Boolean=True;constbNeedUnite:
Boolean=True）:
Integer;
//将数个XLS合并成一个（分页），必须保证Path最后无'\'或'/'，实际已经做成线程，以免程序无响应
procedureUniteSeveralXLSToOne（constTmpFlag,Path,FileName:
String;constiStart,iEnd:
Integer）;
//procedureStringGridToXLS（grid:
TStringGrid;fname:
String）;
var
G_UserCmd:
TUserCommand;
G_XLSWriterIsRuning:
Boolean;//是否有XLSWriter实例在运行，因为G_UserCmd是全局变量，防止被非法刷新
implementation
const
{BOF}
CBOF=$0009;
BIT_BIFF5=$0800;
BOF_BIFF5=CBOForBIT_BIFF5;
{EOF}
BIFF_EOF=$000a;
{Documenttypes}
DOCTYPE_XLS=$0010;
{Dimensions}
DIMENSIONS=$0000;
var
CXlsBof:
array[0..5]ofWord=（$809,8,0,$10,0,0）;
CXlsEof:
array[0..1]ofWord=（$0A,00）;
CXlsLabel:
array[0..5]ofWord=（$204,0,0,0,0,0）;
CXlsNumber:
array[0..4]ofWord=（$203,14,0,0,0）;
CXlsRk:
array[0..4]ofWord=（$27E,10,0,0,0）;
CXlsBlank:
array[0..4]ofWord=（$201,6,0,0,$17）;
type
//合并数个Xls为一个多页面xls的线程
TUniteSeveralXLSToOneThread=class（TThread）
private
TmpFlag:
String;
Path:
String;
FileName:
String;
iStart:
Integer;
iEnd:
Integer;
protected
mCompleted:
Boolean;
procedureExecute;override;
public
constructorCreate（const_TmpFlag,_Path,_FileName:
String;const_iStart,_iEnd:
Integer）;
destructorDestroy;override;
end;
//根据StrFlags在FullStr最后出现的位置，将FullStr分割成两部分，取得的两部分均不包含StrFlags
procedureSplitStrToTwoPartByLastFlag（constFullStr,StrFlags:
String;varstrLeft,strRight:
String）;
variPos:
Integer;
begin
iPos:
=LastDelimiter（StrFlags,FullStr）;
strLeft:
=Copy（FullStr,1,iPos-1）;
strRight:
=Copy（FullStr,iPos+1,Length（FullStr）-iPos）;
end;
constructorTUniteSeveralXLSToOneThread.Create（const_TmpFlag,_Path,_FileName:
String;const_iStart,_iEnd:
Integer）;
begin
inheritedCreate（True）;
TmpFlag:
=_TmpFlag;
Path:
=_Path;
FileName:
=_FileName;
iStart:
=_iStart;
iEnd:
=_iEnd;
mCompleted:
=False;
Resume（）;
end;
destructorTUniteSeveralXLSToOneThread.Destroy;
begin
inherited;
end;
procedureTUniteSeveralXLSToOneThread.Execute;
const
_HeadLetterOfXls:
Array[1..52]ofString//注意这里只定义了52列，需要增加就自己动手，最多256列
=（'A','B','C','D','E','F','G','H','I','J','K','L','M',
'N','O','P','Q','R','S','T','U','V','W','X','Y','Z',
'AA','AB','AC','AD','AE','AF','AG','AH','AI','AJ','AK','AL','AM',
'AN','AO','AP','AQ','AR','AS','AT','AU','AV','AW','AX','AY','AZ'）;
_XlsResCaption='FKULWJS_SKSLA_892x_RES';
_XlsTmpCaption='FKULWJS_SKSLA_892x_TMP';
var
XlsAppRes,XlsAppTmp:
TExcelApplication;
wkBookRes,wkBookTmp:
_WorkBook;
wkSheetRes,wkSheetTmp:
_WorkSheet;
LCID_Res,LCID_Tmp:
Integer;
Pos_LeftTop,Pos_RightBottom:
String;//Xls中左上、右下位置
XlsAppHwnd:
THandle;
bDontSave:
Boolean;
i:
Integer;
StrName,StrExt:
String;//文件名及扩展名
begin
FreeOnTerminate:
=True;
ifTerminatedthenExit;
SplitStrToTwoPartByLastFlag（FileName,'.',StrName,StrExt）;
try
Screen.Cursor:
=crHourGlass;
bDontSave:
=False;
XlsAppRes:
=TExcelApplication.Create（Nil）;
withXlsAppResdo
begin
Connect;
Visible[0]:
=False;
LCID_Res:
=GetUserDefaultLCID（）;
DisplayAlerts[LCID_Res]:
=False;
Caption:
=_XlsResCaption;
wkBookRes:
=WorkBooks.Add（EmptyParam,LCID_Res）;
end;
XlsAppTmp:
=TExcelApplication.Create（Nil）;
withXlsAppTmpdo
begin
Connect;
Visible[0]:
=False;
LCID_Tmp:
=GetUserDefaultLCID（）;
DisplayAlerts[LCID_Tmp]:
=False;
Caption:
=_XlsTmpCaption;
end;
fori:
=iStarttoiEnddo
begin
ifi<=3thenwkSheetRes:
=wkBookRes.Sheets[i]as_WorkSheet
else
begin
wkBookRes.Sheets.Add（EmptyParam,wkSheetRes,1,EmptyParam,LCID_Res）;
wkSheetRes:
=wkBookRes.Sheets[i]as_WorkSheet;
end;
wkBookTmp:
=XlsAppTmp.WorkBooks.Open（Path+'\'+TmpFlag+IntToStr（i）+FileName,EmptyParam,EmptyParam,
EmptyParam,EmptyParam,EmptyParam,EmptyParam,
EmptyParam,EmptyParam,EmptyParam,EmptyParam,
EmptyParam,EmptyParam,LCID_Tmp）;
Pos_LeftTop:
='A1';
wkSheetTmp:
=XlsAppTmp.ActiveSheetas_WorkSheet;
Pos_RightBottom:
=_HeadLetterOfXls[wkSheetTmp.UsedRange[LCID_Tmp].Columns.Count]+IntToStr（wkSheetTmp.UsedRange[LCID_Tmp].Rows.Count）;
XlsAppTmp.Range[Pos_LeftTop,Pos_RightBottom].Copy（EmptyParam）;
wkSheetRes.Activate（LCID_Res）;
wkSheetRes.Range[Pos_LeftTop,Pos_RightBottom].Select;
wkSheetRes.Paste（EmptyParam,EmptyParam,LCID_Res）;
wkSheetRes.Columns.AutoFit;
wkSheetRes.Range['A1','A1'].Select;
wkSheetRes.Name:
=StrName+'_'+IntToStr（i）;
end;
finally
try
（wkBookRes.Sheets[1]as_WorkSheet）.Activate（LCID_Res）;
wkBookRes.Close（Not（bDontSave）,Path+'\'+FileName,EmptyParam,LCID_Res）;
XlsAppRes.Quit;
XlsAppRes.Disconnect;
finally
//杀死未关闭的Excel进程
XlsAppHwnd:
=FindWindow（Nil,_XlsResCaption）;
ifXlsAppHwnd<>0thenSendMessage（XlsAppHwnd,WM_CLOSE,0,0）;
end;
try
//wkBookTmp.Close（False,Path+'\'+TmpFlag+IntToStr（i）+FileName,EmptyParam,LCID_Tmp）;
XlsAppTmp.Quit;
XlsAppTmp.Disconnect;
finally
XlsAppHwnd:
=FindWindow（Nil,_XlsTmpCaption）;
ifXlsAppHwnd<>0thenSendMessage（XlsAppHwnd,WM_CLOSE,0,0）;
//TerminateProcess（XlsAppHwnd,0）;
end;
mCompleted:
=True;
Screen.Cursor:
=crDefault;
end;
end;
procedureDataSetToXLS（ds:
TDataSet;fname:
String）;
varc,r:
Integer;
xls:
TXLSWriter;
begin
xls:
=TXLSWriter.create（fname）;
ifds.FieldCount>xls.maxcolsthen
xls.maxcols:
=ds.fieldcount+1;
try
xls.writeBOF;
xls.WriteDimension;
forc:
=0tods.FieldCount-1do
xls.Cellstr（0,c,ds.Fields[c].DisplayLabel）;
r:
=1;
ds.first;
while（notds.eof）and（r<=xls.maxrows）dobegin
forc:
=0tods.FieldCount-1do
ifds.Fields[c].AsString<>''then
xls.WriteField（r,c,ds.Fields[c]）;
inc（r）;
ds.next;
end;
xls.writeEOF;
finally
xls.free;
end;
end;
procedureDBGridToXLS（Grid:
TDBGrid;fname:
String;bSetFieldName:
Boolean;CallFunc:
TExportXls_CallBackProc;bAskForStop:
Boolean=True）;
varc,r,i:
Integer;
xls:
TXLSWriter;
nTotalCount,nCurrentCount:
Integer;
bDontSave:
Boolean;
begin
bDontSave:
=False;
Grid.DataSource.DataSet.DisableControls;
xls:
=TXLSWriter.create（fname）;
ifGrid.FieldCount>xls.maxcolsthen
xls.maxcols:
=Grid.fieldcount+1;
try
G_XLSWriterIsRuning:
=True;
xls.writeBOF;
xls.WriteDimension;
ifbSetFieldNamethen
begin
forc:
=0toGrid.FieldCount-1do
xls.Cellstr（0,c,Grid.Fields[c].FieldName）;
r:
=2;
end
elser:
=1;
forc:
=0toGrid.FieldCount-1do
xls.Cellstr（r-1,c,Grid.Fields[c].DisplayLabel）;
nTotalCount:
=Grid.DataSource.DataSet.RecordCount;
nCurrentCount:
=0;
bDontSave:
=False;
Grid.DataSource.DataSet.First;
fori:
=0tonTotalCount-1do
begin
Application.ProcessMessages;
ifr>xls.maxrowsthenRaiseException.Create（'导出的数据超过'+IntToStr（xls.maxrows）+'条记录，操作失败！
'）;
Inc（nCurrentCount）;
CallFunc（nCurrentCount/nTotalCount）;
ifG_UserCmd=UserStopthen
begin
ifbAskForStopthen
caseApplication.MessageBox（'您停止了导出数据，请问需要保存吗？
（选择“取消”继续导出）','询问',MB_YESNOCANCEL）of
IDYES:
Break;
IDNO:
begin
bDontSave:
=True;
RaiseException.Create（'用户停止，导出数据未保存！
'）;
end;
IDCANCEL:
G_UserCmd:
=UserDoNothing;
end
elsebeginbDontSave:
=True;RaiseException.Create（'用户停止，导出数据未保存！
'）;end;
end;
forc:
=0toGrid.FieldCount-1do
if（Grid.Fields[c].AsString<>''）then
xls.WriteField（r,c,Grid.Fields[c]）;
inc（r）;
Grid.DataSource.DataSet.Next;
end;
finally
xls.writeEOF;
xls.free;
ifbDontSavethenDeleteFile（fname）;
Grid.DataSource.DataSet.EnableControls;
G_XLSWriterIsRuning:
=False;
end;
end;
//将数个XLS合并成一个（分页）
procedureUniteSeveralXLSToOne（constTmpFlag,Path,FileName:
String;constiStart,iEnd:
Integer）;
const
_HeadLetterOfXls:
Array[1..52]ofString
=（'A','B','C','D','E','F','G','H','I','J','K','L','M',
'N','O','P','Q','R','S','T','U','V','W','X','Y','Z',
'AA','AB','AC','AD','AE','AF','AG','AH','AI','AJ','AK','AL','AM',
'AN
升级会员 