Delphi—将 TDBGrid 数据导出至 Excel (支持多sheet)

procedure TfrmList.SaveToExcel(dg:TDBGrid;ado:TADOQuery);
var
  MsExcel,sheet:variant;
  dialogSave:TSaveDialog;
  i:integer;
  s,str:string;
  strlist:TStringList;
  fExist:boolean;
begin
dialogsave:=TSaveDialog.Create(Application);
dialogsave.Filter:='Excel文件(*.xls) |*.xls';
str:=formatdatetime('yymmddhhmmss',now);
if dialogsave.Execute then
  begin
    screen.Cursor:=crHourGlass;
    //****创建MSEXCEL对象
    try
      MsExcel:=CreateOleObject('Excel.Application');
    except
      showmessage('请确定您的计算机是否已正确安装Microsoft Excel ?');
      freeandnil(dialogsave);
      screen.Cursor:= crDefault;
      exit;
    end;
    try
      //****为新工作表命名，默认为当前的日期时间
      if InputQuery('输入工作表名称','该类文件允许以多个工作表的形式进行保存，请输入该工作表的名称',str) then
        begin
        //****以下代码先检测导出的文件是否已存在，如果已存在，则打开并增加一工作表，否则新建
          if fileExists(dialogsave.FileName) then
            begin
              fExist:=true;
              msexcel.workbooks.open(dialogsave.FileName); //打开已存在的文件
              sheet:=msexcel.worksheets.add;  //新增一工作表
            end
          else
            begin
              fExist:=false;
              msexcel.workbooks.add;   //新建一工作簿
              sheet:=msexcel.workbooks[1].worksheets[1];
            end;
         //****以下代码将DBGrid内容复制到粘贴板中
          strlist:=Tstringlist.Create;
          s:='';
          for i:=0 to dg.FieldCount-1 do   //将标题行加入字符串S中
            s:=s+dg.Fields[i].FieldName+#9;
          strlist.Add(S);     //将标题行加入至字符串列表strList中
          ado.First;
          while not ado.Eof do  //穷举数据库，并加入字符串列表中
            begin
              s:='';
              for i:=0 to dg.FieldCount-1 do
                s:= s+dg.Fields[i].AsString+#9;
              strlist.Add(s);
              ado.Next;
            end;
          clipboard.AsText:=strlist.Text;  //将字符串列表内容加入到粘贴板
          sheet.cells.NumberFormatLocal:='@'; //设置工作表字体格式为文本
          sheet.cells.Font.Size:='10';   //设置字体大小
          sheet.Paste;   //粘贴
          sheet.name:=str;  //为工作表命名
          if fExist then      //保存文件
            msexcel.workbooks[1].save
          else
            msexcel.workbooks[1].SaveAs(dialogsave.filename);
        showmessage(文件已成功导出至以下位置: '+dialogsave.filename);
        end;
    except
      showmessage(文件不可用，请稍后重试！');
      freeandnil(strlist);
      msexcel.quit;   //退出Excel
      msexcel:=Unassigned ; //释放MSEXCEL对象
      freeandnil(dialogsave);
      screen.Cursor:= crDefault;
      exit;
    end;
    freeandnil(strlist);
    msexcel.quit;   //退出Excel
    msexcel:=Unassigned ; //释放MSEXCEL对象
    freeandnil(dialogsave);
    screen.Cursor:= crDefault;
  end;
end;