delphi 将DBGrid的数据导出到Excel文件保存

文章出自：http://blog.csdn.net/suiyunonghen/archive/2009/05/21/4207564.aspx

(*
原作者： 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;