如何将dbgrid内的数据导入到excel表格中，请各位指点，谢谢！

Question

如题

Answer 1

算你走运啦,正好有这个,看你能不能用上
procedure TFrm_Main.SaveToExcel(dataset:TDataset);
var
    XlAPP:Variant;
    Sheet1:Variant;
    i,j:integer;
    curRow:integer;
begin
    if not DataSet.Active then exit;
    if DataSet.RecordCount<1 then exit;
    //创建excel对象
    try
        XlApp:=createoleobject('Excel.Application');
        XLApp.Visible:=false;
        XLApp.Workbooks.Add(xlWBatWorkSheet);
        Sheet1 := XLApp.Workbooks[1].WorkSheets['sheet1'];
       // XLApp.Workbooks.Options.CheckSpellingAsYouType:= False;
       // XLApp.Workbooks.Options.CheckGrammarAsYouType:= False;
       XlAPP.caption:='揭东县第一中学　学生通讯录管理系统　报表';
    except
        showmessage('你的电脑没有安装excel程序，无法完成此功能!');
        exit;
    end;
    curRow:=0;
    for j:=0 to dataset.FieldCount-1 do
    begin
        sheet1.cells[1,curRow+1]:=dataset.Fields[j].DisplayLabel;
        inc(curRow);
    end;
    //处理记录
    DataSet.First;
    i:=2;
    while not DataSet.Eof do
    begin
       //处理一行
       curRow:=0;
       for j:=0 to DataSet.FieldCount-1 do
       begin
             if (DataSet.Fields[j]<>nil) and not (dataset.Fields[j].IsBlob)then
                     Sheet1.cells[i,curRow+1]:=trim(DataSet.Fields[j].asstring)
            else
                Sheet1.cells[i,curRow+1]:='';
            inc(curRow);       end;
       i:=i+1;
       DataSet.Next;
    end;
    screen.Cursor :=crDefault ; //鼠标还原
    XLApp.Visible:=true;
end;
procedure Tfrm_Main.BitBtn1Click(Sender: TObject);
begin
  Screen.Cursor :=crHourGlass;//鼠标变漏斗状
  Frm_Main.FormStyle := fsNormal;
  showmessage('Please wait while processing......') ;
  SaveToExcel(Frm_Main.DBGrid_Excel.DataSource.DataSet);
end;

Answer 2

unit XLS_Un;interface
uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Grids,
  Forms, Dialogs, db, dbctrls, comctrls, DBGridEh;const
{BOF}
  CBOF      = $0009;
  BIT_BIFF5 = $0800;
  BOF_BIFF5 = CBOF or BIT_BIFF5;
{EOF}
  BIFF_EOF = $000a;
{Document types}
  DOCTYPE_XLS = $0010;
{Dimensions}
  DIMENSIONS = $0000;type
  TAtributCell = (acHidden,acLocked,acShaded,acBottomBorder,acTopBorder,
                acRightBorder,acLeftBorder,acLeft,acCenter,acRight,acFill);  TSetOfAtribut = set of TatributCell;  TXLSWriter = class(Tobject)
  private
    fstream:TFileStream;
    procedure WriteWord(w:word);
  protected
    procedure WriteBOF;
    procedure WriteEOF;
    procedure WriteDimension;
  public
    maxCols,maxRows:Word;
    procedure CellWord(vCol,vRow:word;aValue:word;vAtribut:TSetOfAtribut=[]);
    procedure CellDouble(vCol,vRow:word;aValue:double;vAtribut:TSetOfAtribut=[]);
    procedure CellStr(vCol,vRow:word;aValue:String;vAtribut:TSetOfAtribut=[]);
    procedure WriteField(vCol,vRow:word;Field:TField);
    constructor create(vFileName:string);
    destructor destroy;override;
  end;procedure SetCellAtribut(value:TSetOfAtribut;var FAtribut:array of byte);
procedure DataSetToXLS(ds:TDataSet;fname:String);
procedure DataGridToXLS(dg:TDBGridEh;fname:String); 
implementationprocedure DataSetToXLS(ds:TDataSet;fname:String);
var c,r:Integer;
  xls:TXLSWriter;
begin
  xls:=TXLSWriter.create(fname);
  if ds.FieldCount > xls.maxcols then
    xls.maxcols:=ds.fieldcount+1;
  try
    xls.writeBOF;
    xls.WriteDimension;
    for c:=0 to ds.FieldCount-1 do
      xls.Cellstr(0,c,ds.Fields[c].FieldName);
    r:=1;
    ds.first;
    while (not ds.eof) and (r <= xls.maxrows) do begin
      for c:=0 to ds.FieldCount-1 do
        xls.WriteField(r,c,ds.Fields[c]);
      inc(r);
      ds.next;
    end;
    xls.writeEOF;
  finally
    xls.free;
  end;
end;procedure DataGridToXLS(dg:TDBGridEH;fname:String);
var c,r:Integer;
  xls:TXLSWriter;
begin
 dg.DataSource.DataSet.DisableControls;
  xls:=TXLSWriter.create(fname);
  if dg.FieldCount > xls.maxcols then
    xls.maxcols:=dg.FieldCount+1;
  try
    xls.writeBOF;
    xls.WriteDimension;
    for c:=1 to dg.FieldCount-1 do
      xls.Cellstr(0,c,dg.Columns.Items[c].Title.Caption);
    r:=1;
    dg.DataSource.DataSet.First;
    while (not dg.DataSource.DataSet.eof) and (r <= xls.maxrows) do begin
      for c:=1 to dg.FieldCount-1 do
        xls.WriteField(r,c,dg.Fields[c]);
      inc(r);
      dg.DataSource.DataSet.Next;
    end;
    xls.writeEOF;
  finally
    xls.free;
  end;
 dg.DataSource.DataSet.EnableControls; 
end;{ TXLSWriter }constructor TXLSWriter.create(vFileName:string);
begin
  inherited create;
  if FileExists(vFilename) then
    fStream:=TFileStream.Create(vFilename,fmOpenWrite)
  else
    fStream:=TFileStream.Create(vFilename,fmCreate);  maxCols:=100;   //
  maxRows:=65535; //
end;destructor TXLSWriter.destroy;
begin
  if fStream <> nil then
    fStream.free;
  inherited;
end;procedure TXLSWriter.WriteBOF;
begin
  Writeword(BOF_BIFF5);
  Writeword(6);           // count of bytes
  Writeword(0);
  Writeword(DOCTYPE_XLS);
  Writeword(0);
end;procedure TXLSWriter.WriteDimension;
begin
  Writeword(DIMENSIONS);  // dimension OP Code
  Writeword(8);           // count of bytes
  Writeword(0);           // min cols
  Writeword(maxRows);     // max rows
  Writeword(0);           // min rowss
  Writeword(maxcols);     // max cols
end;procedure TXLSWriter.CellDouble(vCol, vRow: word; aValue: double;
  vAtribut: TSetOfAtribut);
var  FAtribut:array [0..2] of byte;
begin
  Writeword(3);           // opcode for double
  Writeword(15);          // count of byte
  Writeword(vCol);
  Writeword(vRow);
  SetCellAtribut(vAtribut,fAtribut);
  fStream.Write(fAtribut,3);
  fStream.Write(aValue,8);
end;procedure TXLSWriter.CellWord(vCol,vRow:word;aValue:word;vAtribut:TSetOfAtribut=[]);
var  FAtribut:array [0..2] of byte;
begin
  Writeword(2);           // opcode for word
  Writeword(9);           // count of byte
  Writeword(vCol);
  Writeword(vRow);
  SetCellAtribut(vAtribut,fAtribut);
  fStream.Write(fAtribut,3);
  Writeword(aValue);
end;procedure TXLSWriter.CellStr(vCol, vRow: word; aValue: String;
  vAtribut: TSetOfAtribut);
var  FAtribut:array [0..2] of byte;
  slen:byte;
begin
  Writeword(4);           // opcode for string
  slen:=length(avalue);
  Writeword(slen+8);      // count of byte
  Writeword(vCol);
  Writeword(vRow);
  SetCellAtribut(vAtribut,fAtribut);
  fStream.Write(fAtribut,3);
  fStream.Write(slen,1);
  fStream.Write(aValue[1],slen);
end;

Answer 3

procedure SetCellAtribut(value:TSetOfAtribut;var FAtribut:array of byte);
var
   i:integer;
begin
 //reset
  for i:=0 to High(FAtribut) do
    FAtribut[i]:=0;     {Byte Offset     Bit   Description                     Contents
     0          7     Cell is not hidden              0b
                      Cell is hidden                  1b
                6     Cell is not locked              0b
                      Cell is locked                  1b
                5-0   Reserved, must be 0             000000b
     1          7-6   Font number (4 possible)
                5-0   Cell format code
     2          7     Cell is not shaded              0b
                      Cell is shaded                  1b
                6     Cell has no bottom border       0b
                      Cell has a bottom border        1b
                5     Cell has no top border          0b
                      Cell has a top border           1b
                4     Cell has no right border        0b
                      Cell has a right border         1b
                3     Cell has no left border         0b
                      Cell has a left border          1b
                2-0   Cell alignment code
                           general                    000b
                           left                       001b
                           center                     010b
                           right                      011b
                           fill                       100b
                           Multiplan default align.   111b
     }     //  bit sequence 76543210     if  acHidden in value then       //byte 0 bit 7:
         FAtribut[0] := FAtribut[0] + 128;     if  acLocked in value then       //byte 0 bit 6:
         FAtribut[0] := FAtribut[0] + 64 ;     if  acShaded in value then       //byte 2 bit 7:
         FAtribut[2] := FAtribut[2] + 128;     if  acBottomBorder in value then //byte 2 bit 6
         FAtribut[2] := FAtribut[2] + 64 ;     if  acTopBorder in value then    //byte 2 bit 5
         FAtribut[2] := FAtribut[2] + 32;     if  acRightBorder in value then  //byte 2 bit 4
         FAtribut[2] := FAtribut[2] + 16;     if  acLeftBorder in value then   //byte 2 bit 3
         FAtribut[2] := FAtribut[2] + 8;     if  acLeft in value then         //byte 2 bit 1
         FAtribut[2] := FAtribut[2] + 1
     else if  acCenter in value then  //byte 2 bit 1
         FAtribut[2] := FAtribut[2] + 2
     else if acRight in value then    //byte 2, bit 0 dan bit 1
         FAtribut[2] := FAtribut[2] + 3
     else if acFill in value then     //byte 2, bit 0
         FAtribut[2] := FAtribut[2] + 4;
end;procedure TXLSWriter.WriteWord(w: word);
begin
  fstream.Write(w,2);
end;procedure TXLSWriter.WriteEOF;
begin
  Writeword(BIFF_EOF);
  Writeword(0);
end;procedure TXLSWriter.WriteField(vCol, vRow: word; Field: TField);
begin
  case field.DataType of
     ftString,ftWideString,ftBoolean,ftDate,ftDateTime,ftTime:
       Cellstr(vcol,vrow,field.asstring);
     ftAutoInc,ftSmallint,ftInteger,ftWord:
       CellWord(vcol,vRow,field.AsInteger);
     ftFloat, ftBCD:
       CellDouble(vcol,vrow,field.AsFloat);
  else
       Cellstr(vcol,vrow,EmptyStr);
  end;
end;
end.

Answer 4

procedure aa.savetoExcelClick(Sender: TObject);
var
  i,j:integer;
  ls_filename,s_Temp: string;
  ExcelApplication1: TExcelApplication;
  ExcelWorkbook1: TExcelWorkbook;
  ExcelWorksheet1: TExcelWorksheet;
begin
//运行保存为对话框
  SaveFile.Filter := 'Excel文件(*.xls)|*.xls';
  SaveFile.DefaultExt := 'xls';
  if SaveFile.Execute then
    ls_Filename := SaveFile.FileName
  else
    exit;
  ExcelApplication1:=TExcelApplication.Create(self);
  ExcelWorksheet1:=TExcelWorksheet.Create(self);
  ExcelWorkbook1:=TExcelWorkbook.Create(self);
  ExcelApplication1.Connect;
  ExcelWorkbook1.ConnectTo(
  ExcelApplication1.Workbooks.Add(ExtractFilePath(ParamStr(0))+'aa.xls', 0));
  ExcelWorksheet1.ConnectTo(ExcelWorkbook1.Worksheets[1]  as _WorkSheet);
  //表头生成
  Excelworksheet1.Cells.Item[1,1].font.size:=22;
  ExcelWorksheet1.Cells.Item[1,1].value:='结果';
  //生成列名，写入excel文件
  ADOQuery_ER.First;
//  while myQuery  for j := 1 to ADOQuery_ER.Fields.Count do
  begin
    ExcelWorksheet1.Cells.Item[3, j].Value := ADOQuery_ER.Fields[j - 1].FieldName;
  end;
  // 数据写入excel文件
  DBGrid_ER.Visible := false;
  for i := 0 to ADOQuery_ER.RecordCount - 1 do
  begin
    for j := 1 to ADOQuery_ER.Fields.Count do
    begin
      s_Temp:=ADOQuery_ER.Fields[j - 1].AsString;                  
      if trim(ADOQuery_ER.Fields.Fields[j-1].FieldName)='编号' then
        s_Temp:='['+s_Temp+']';
      ExcelWorksheet1.Cells.Item[i+4,j].Value :=s_Temp; //ADOQuery_ER.Fields[j - 1].AsString;
    end;
    ADOQuery_ER.Next;
  end;
  DBGrid_ER.Visible := true;
  //保存并关闭excel文件
  ExcelWorksheet1.SaveAs(ls_filename, xlExcel9795);
  ExcelWorkbook1.close;
  ExcelWorkbook1.Disconnect;
  ExcelApplication1.Quit;
  ExcelApplication1.Disconnect;
  ExcelApplication1.free;
  ExcelWorksheet1.free;
  ExcelWorkbook1.free;
end;

Answer 5

这样写循环的话速度会比较慢的
我有个数据表只有2000条记录结果往EXCEL里面循环写数据
花了几分钟数据才全部道入EXCEL表里面

Answer 6

其实有一个最快的办法，用ADO导是目前最快的了，你可以看DELPHBBS中的碧血剑的贴子。

Answer 7

procedure TForm12.Button1Click(Sender: TObject);
var
  eclApp, WorkBook: Variant;
  xlsFileName: String;
  i, j: Integer;
  FieldValue: String;
  SaveDialog: TSaveDialog;
    begin
      messageDlg('在数据备份前请确保关闭所有EXCEL表!',mtWarning,[mbok],0);
      SaveDialog:=TSaveDialog.Create(Application);
      SaveDialog.DefaultExt:='.xls';
      SaveDialog.Filter:= 'Excel文件|*.xls|所有文件|*.*';
   if savedialog.Execute=true then
      begin
         application.ProcessMessages;
         xlsFileName:= SaveDialog.FileName;
         form12.Caption:='数据正在备份中.....';
          try
           VarClear(eclApp);
            eclApp:=CreateOleObject('Excel.Application');
          except
            ShowMessage('您的机器里未安裝Microsoft Excel!');
            Exit;
          end;
          try
             p1.Visible:=true;
             WorkBook:= eclApp.workBooks.Add;
             DBGrid1.DataSource.DataSet.First;
             p1.min:=0;
             p1.max:=DBGrid1.DataSource.DataSet.RecordCount+DBGrid1.Columns.Count;
             p1.step:=1;
             for i:=0 to DBGrid1.Columns.Count - 1 do
              begin
                eclApp.Cells[1,i+1]:=DBGrid1.Columns.Items[i].Title.Caption;
              end;
              for i:=0 to DBGrid1.DataSource.DataSet.RecordCount-1 do
              begin
                 for j:=0 to DBGrid1.Columns.Count-1 do
                   begin                       FieldValue:=DBGrid1.Columns[j].Field.AsString;
                       eclApp.Cells[i+2, j+1]:=FieldValue;
                    end;
                p1.stepit;
                DBGrid1.DataSource.DataSet.Next;
              end;
            if FileExists(xlsFileName) then
              begin
                if Application.MessageBox('文件已经存在！' + #13 + #10 +
                           '是否进行替换？', '提示', MB_OKCANCEL +
                           MB_ICONQUESTION + MB_SYSTEMMODAL) = IDOK then
                  begin
                    DeleteFile(PChar(xlsFileName));
                    WorkBook.Saveas(xlsFileName);
                   form12.Caption:='数据已成功备份';
                    showmessage('保存EXECL文件成功，路径为:'+xlsFileName);
                    WorkBook.Close;
                    eclApp.Quit;
                    eclApp:= Unassigned;
                  end
                  else
                  begin
                   form12.Caption:='数据未备份';
                  end;
              end
            else
              begin
                WorkBook.Saveas(xlsFileName);
                form12.Caption:='数据已成功备份';
                showmessage('保存EXECL文件成功，路径为:'+xlsFileName);
                WorkBook.Close;
                eclApp.Quit;
                eclApp:= Unassigned;
              end;
          except
            screen.Cursor:= crdefault;
            form12.Caption:='数据备份出错';
            ShowMessage('不能正确操作Excel文件。可能是該文件已被其他程序打开或系統错误，需要注销您的计算机。');
            WorkBook.Close;
            eclApp.Quit;
            eclApp:=Unassigned;
          end;
        end;
   end;