本文整理自网络，侵删。
近来一段时间忙的慌，接了个帮人升级系统的小单子。其中涉及到将DbGrid的数据转到Excel文件并保存的功能，其实本身倒也不难。只是有些麻烦。想想这种功能，肯定有先人已经写好的现成东西直接拿过来用就应该OK了。于是Google一番，果然有很多类似的例子代码，俺在盒子上找到了和俺的需求相近的一个代码DbGrid2Excel这个代码。他那个写的确实不错，但是有些地方也还是不能尽如人意的哈，于是就在他的代码上修改了下，同时新增加了进度提示的窗口，导出时能随时取消的功能。分页方面不再固定死了，而是由用户规定一个表中最多能存放多少条数据。同时增加表名称的设置。呵呵，废话也不多说，直接贴代码吧
DelphiCode: (*原作者： iamdream(delphi盒子)
修改： 不得闲
功能： 将DbGrid数据保存到Excel
参数：
Grid指定表格
FileName指定要保存的文件名
MaxPageRowCount指定一页最多的支持行数
ShowProgress 指定是否显示进度条
用法：
SaveDbGridAsExcel(DBGrid1,'C:\2.xls','表测试',2000);
*)
procedure SaveDbGridAsExcel(Grid: TDBGrid;const FileName,title: string;
const MaxPageRowCount: Integer = 65535;const ShowProgress: Boolean = True);
const
MAX_VAR_ONCE = 1000; //一次导出的条数
var //返回导出记录条数
Excel, varCells: Variant;
MySheet, MyCells, Cell1, Cell2, Range: OleVariant;
iRow, iCol, iSheetIdx, iVarCount, iCurRow: integer;
CurPos: TBookmark;
ProgressForm: TForm;
Prompt: TLabel;
progressBar: TProgressBar;
Panel : TPanel;
Button : TButton;
procedure ReSetObjEvent(OldEventAddr: pointer;NewEventValue: pointer;ReSetObject: TObject);
begin
TMethod(OldEventAddr^).Code := NewEventValue;
TMethod(OldEventAddr^).Data := ReSetObject;
end;
procedure ButtonClick(BtnObject: TObject;Sender: TObject);
begin
TComponent(BtnObject).Tag := Integer(MessageBox(Application.Handle,
'真的要终止数据的导出吗？','确认',
MB_OKCANCEL + MB_ICONINFORMATION) = IDOK);
end;
procedure CreateProgressForm;
begin
ProgressForm := TForm.Create(nil);
With ProgressForm do
begin
Font.Name := '宋体';
Font.Size := 10;
BorderStyle := bsNone;
Width := 280;
Height := 120;
BorderWidth := 1;
Color := clBackground;
Position := poOwnerFormCenter;
end;
Panel := TPanel.Create(ProgressForm);
with Panel do { Create Panel }
begin
Parent := ProgressForm;
Align := alClient;
BevelInner := bvNone;
BevelOuter := bvNone;
Caption := '';
end;
Prompt := TLabel.Create(Panel);
with Prompt do { Create Label }
begin
Parent := Panel;
Left := 20;
Top := 25;
Caption := '正在启动Excel，请稍候……';
end;
progressBar := TProgressBar.Create(panel);
with ProgressBar do { Create ProgressBar }
begin
Step := 1;
Parent := Panel;
Smooth := true;
Left := 20;
Top := 50;
Height := 18;
Width := 260;
end;
Button := TButton.Create(Panel);
with Button do { Create Cancel Button }
begin
Parent := Panel;
Left := 115;
Top := 80;
Caption := '关闭';
end;
ReSetObjEvent(@@Button.OnClick,@ButtonClick,Button);
ProgressForm.FormStyle := fsStayOnTop;
ProgressForm.Show;
ProgressForm.Update;
end;
begin
if (Grid.DataSource <> nil) and
(Grid.DataSource.DataSet <> nil) and
Grid.DataSource.DataSet.Active then
begin
Grid.DataSource.DataSet.DisableControls;
CurPos := Grid.DataSource.DataSet.GetBookmark;
Grid.DataSource.DataSet.First;
try
if ShowProgress then
begin
CreateProgressForm;
Button.Tag := 0;
end;
Excel := CreateOleObject('Excel.Application');
Excel.WorkBooks.Add;
Excel.Visible := False;
except
Application.Messagebox('Excel 没有安装!','操作提示', MB_IConERROR + mb_Ok);
Screen.Cursor := crDefault;
Grid.DataSource.DataSet.GotoBookmark(CurPos);
Grid.DataSource.DataSet.FreeBookmark(CurPos);
Grid.DataSource.DataSet.EnableControls;
if ProgressForm <> nil then
ProgressForm.Free;
exit;
end;
if Grid.DataSource.DataSet.RecordCount <= MAX_VAR_ONCE then
iVarCount := Grid.DataSource.DataSet.RecordCount
else iVarCount := MAX_VAR_ONCE;
varCells := VarArrayCreate([1, iVarCount,1,Grid.FieldCount],varVariant);
iSheetIdx := 1;
iRow := 0;
if ShowProgress then
begin
ProgressBar.Position := 0;
Prompt.Caption := '请等待，正在导出数据……';
ProgressBar.Max := Grid.DataSource.DataSet.RecordCount;
end;
while (not Grid.DataSource.DataSet.Eof and not ShowProgress) or
(not Grid.DataSource.DataSet.Eof and ShowProgress and (Button.Tag = 0)) do
begin
if (iRow = 0) or (iRow > MaxPageRowCount + 1) then
begin
if iSheetIdx <= Excel.WorkBooks[1].WorkSheets.Count then
MySheet := Excel.WorkBooks[1].WorkSheets[iSheetIdx]
else
MySheet := Excel.WorkBooks[1].WorkSheets.Add(NULL, MySheet);//加在后面
MySheet.Name := Title + IntToStr(iSheetIdx);
MyCells := MySheet.Cells;
Inc(iSheetIdx);
//开始新的数据表
iRow := 1;
//写入表头
for iCol := 1 to Grid.FieldCount do
begin
MySheet.Cells[1, iCol] := Grid.Columns[iCol-1].Title.Caption;
MySheet.Cells[1, iCol].Font.Bold := True;
if (Grid.Fields[iCol - 1].DataType = ftString) or
(Grid.Fields[iCol - 1].DataType = ftWideString) then
//对于“字符串”型数据则设Excel单元格为“文本”型
MySheet.Columns[iCol].NumberFormatLocal := '@';
end;
Inc(iRow);
end;
iCurRow := 1;
while (not Grid.DataSource.DataSet.Eof and not ShowProgress) or
(not Grid.DataSource.DataSet.Eof and ShowProgress and (Button.Tag = 0)) do
begin
for iCol := 1 to Grid.FieldCount do
begin
Application.ProcessMessages;
if Grid.Fields[iCol - 1].IsBlob then
varCells[iCurRow, iCol] := '二进制数据'
else varCells[iCurRow, iCol] := Grid.Fields[iCol-1].AsString;
end;
Inc(iRow);
Inc(iCurRow);
if ShowProgress then
ProgressBar.Position := ProgressBar.Position + 1;
Application.ProcessMessages;
Grid.DataSource.DataSet.Next;
if (iCurRow > iVarCount) or (iRow > MaxPageRowCount + 1) then
begin
Application.ProcessMessages;
Break;
end;
end;
Cell1 := MyCells.Item[iRow - iCurRow + 1, 1];
Cell2 := MyCells.Item[iRow - 1,Grid.FieldCount];
Range := MySheet.Range[Cell1 ,Cell2];
Range.Value := varCells;
MySheet.Columns.AutoFit;
Cell1 := Unassigned;
Cell2 := Unassigned;
Range := Unassigned;
Application.ProcessMessages;
end;
if (ShowProgress and (Button.Tag = 0)) or not ShowProgress then
MySheet.saveas(FileName);
MyCells := Unassigned;
varCells := Unassigned;
Excel.WorkBooks[1].Saved := True;
MySheet.application.quit;
Excel.quit;
Excel := Unassigned;
if CurPos <> nil then
begin
Grid.DataSource.DataSet.GotoBookmark(CurPos);
Grid.DataSource.DataSet.FreeBookmark(CurPos);
end;
Grid.DataSource.DataSet.EnableControls;
if ProgressForm <> nil then
ProgressForm.Free;
end;
end;
本文来自CSDN博客，转载请标明出处：http://blog.csdn.net/suiyunonghen/archive/2009/05/21/4207564.aspx 相关阅读 >>
Delphi tnethttpclient https忽略证书验证
更多相关阅读请进入《Delphi》频道 >>
