修改的一个导出DataSet到xls的单元.docx
《修改的一个导出DataSet到xls的单元.docx》由会员分享,可在线阅读,更多相关《修改的一个导出DataSet到xls的单元.docx(23页珍藏版)》请在冰豆网上搜索。
![修改的一个导出DataSet到xls的单元.docx](https://file1.bdocx.com/fileroot1/2022-11/23/c560a860-3085-460a-a8dc-ceaea627d7a8/c560a860-3085-460a-a8dc-ceaea627d7a81.gif)
修改的一个导出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