数据导出到Excel

Question

请问哪位有把数据导入到Excel的模块代码...?谢谢，急需

Answer 1

procedure TfQuery.sbtnStockSaveClick(Sender: TObject);
var
  sFileName,My_FileName,sPallet : String;
  MsExcel, MsExcelWorkBook : Variant;
  i,iIndex,iTest : Integer;
begin
  if qryStockBase.RecordCount<1  then exit;
  
  if  not  FileExists(ExtractFilePath(Application.EXEName)+'StockQuery.xlt') then
  begin
    MessageDlg('StockQuery.xlt Not Exist!',mtWarning,[mbOK],0);
    exit;
  end;
  sFileName := ExtractFilePath(Application.EXEName)+'StockQuery.xlt';
  try
    try
      iTest :=1;
      MsExcel := CreateOleObject('Excel.Application');
      iTest := 2;
      MsExcelWorkBook := MsExcel.WorkBooks.Open(sFileName);
      iTest:=3;
      MsExcel.Worksheets['Sheet1'].select;
      MsExcel.Worksheets[1].name:='Data';
      if Sender = sbtnStockSave then
        if  not (SaveDialog1.Execute) then exit;
      iTest:=4;
      SaveExcel(MsExcel,MsExcelWorkBook);
      iTest:=5;
        if  Sender = sbtnStockSave then
        begin
        iTest:=6;
           SaveDialog1.InitialDir := ExtractFilePath('C:\');
           SaveDialog1.DefaultExt := 'xls';
           SaveDialog1.Filter := 'All Files(*.xlt)|*.xlt|All Files(*.xls)|*.xls';
          iTest:=7;
          sFileName := SaveDialog1.FileName;
          iTest:=8;
          //MsExcel.Run('Macro');
          MsExcelWorkBook.SaveAs(sFileName);
          showmessage('Save Excel OK!!');
        end else
        begin
          MsExcel.Run('Macro');
          MsExcel.WorkSheets['Data'].PrintOut;
          showmessage('Print Excel OK!!');
        end;
    Except
      ShowMessage('Could not start Microsoft Excel.('+IntToStr(iTest)+')');
    end;
  finally
    MsExcelWorkBook.close(False);
    MsExcel.Application.Quit;
    MsExcel:=Null;
   end;
end;procedure TfQuery.SaveExcel(MsExcel,MsExcelWorkBook:Variant);
var
  i:integer;
begin
   //for i:=1 to csgriddata.RowCount-1 do
   i:=1;
   qryStockBase.First;
   while not qryStockBase.Eof do
   begin
      MsExcel.WorkSheets['Data'].Range['A'+inttostr(4+i)].Value :=qryStockBase.FieldByName('STATUS').AsString;
      MsExcel.WorkSheets['Data'].Range['C'+inttostr(4+i)].Value :=qryStockBase.FieldByName('PART_NO').AsString;
      MsExcel.WorkSheets['Data'].Range['E'+inttostr(4+i)].Value :=qryStockBase.FieldByName('QTY').AsString;
      INC(i);
      qryStockBase.Next;
   end;
   
end;

Answer 2

//下面这个是速度最快的了。
{
    功能：将数据集的数据导入Excel;
    用法：With ExportXls.Create(TDataSet(ADOQuery1)) do
          Try
            Save2File(SaveDialog1.FileName, True);
          finally
            Free;
          end;}unit uExportXls;interfaceuses
  DB,Classes;var
  CXlsBof: array[0..5] of Word = ($809, 8, 0, $10, 0, 0);
  CXlsEof: array[0..1] of Word = ($0A, 00);
  CXlsLabel: array[0..5] of Word = ($204, 0, 0, 0, 0, 0);
  CXlsNumber: array[0..4] of Word = ($203, 14, 0, 0, 0);
  CXlsRk: array[0..4] of Word = ($27E, 10, 0, 0, 0);
  CXlsBlank: array[0..4] of Word = ($201, 6, 0, 0, $17);type
  TFldRec = record
    Title: string;
    Width: Integer;
  end;  ExportXls = class(TObject)
  Private
    FCol: word;
    FRow: word;
    FDataSet: TDataSet;
    Stream: TStream;
    FWillWriteHead: boolean;
    FBookMark: TBook;
    procedure IncColRow;
    procedure WriteBlankCell;
    procedure WriteFloatCell(const AValue: Double);
    procedure WriteIntegerCell(const AValue: Integer);
    procedure WriteStringCell(const AValue: string);
    procedure WritePrefix;
    procedure WriteSuffix;
    procedure WriteTitle;
    procedure WriteDataCell;    procedure Save2Stream(aStream: TStream);
  Public
    procedure SaveToXlsFile(FileName: string; WillWriteHead: Boolean);
    constructor Create(aDataSet: TDataSet);
  end;
procedure ExportToXLS(const FileName: string; DataSet: TDataSet);// Boolean;
implementationuses SysUtils;procedure ExportToXLS(const FileName: string; DataSet: TDataSet);// Boolean;
begin
  //if DataSet.Active then
 // Result := False;
  with ExportXls.Create(DataSet) do
  try
    SaveToXlsFile(FileName, True);
 //   Result := True;
  finally
    Free;
  end;
end;constructor ExportXls.Create(aDataSet: TDataSet);
begin
  inherited Create;
  FDataSet := aDataSet;
end;procedure ExportXls.IncColRow;
begin
  if FCol = FDataSet.FieldCount - 1 then
  begin
    Inc(FRow);
    FCol := 0;
  end
  else
    Inc(FCol);
end;procedure ExportXls.WriteBlankCell;
begin
  CXlsBlank[2] := FRow;
  CXlsBlank[3] := FCol;
  Stream.WriteBuffer(CXlsBlank, SizeOf(CXlsBlank));
  IncColRow;
end;procedure ExportXls.WriteFloatCell(const AValue: Double);
begin
  CXlsNumber[2] := FRow;
  CXlsNumber[3] := FCol;
  Stream.WriteBuffer(CXlsNumber, SizeOf(CXlsNumber));
  Stream.WriteBuffer(AValue, 8);
  IncColRow;
end;procedure ExportXls.WriteIntegerCell(const AValue: Integer);
var
  V: Integer;
begin
  CXlsRk[2] := FRow;
  CXlsRk[3] := FCol;
  Stream.WriteBuffer(CXlsRk, SizeOf(CXlsRk));
  V := (AValue shl 2) or 2;
  Stream.WriteBuffer(V, 4);
  IncColRow;
end;procedure ExportXls.WriteStringCell(const AValue: string);
var
  L: Word;
begin
  L := Length(AValue);
  CXlsLabel[1] := 8 + L;
  CXlsLabel[2] := FRow;
  CXlsLabel[3] := FCol;
  CXlsLabel[5] := L;
  Stream.WriteBuffer(CXlsLabel, SizeOf(CXlsLabel));
  Stream.WriteBuffer(Pointer(AValue)^, L);
  IncColRow;
end;procedure ExportXls.WritePrefix;
begin
  Stream.WriteBuffer(CXlsBof, SizeOf(CXlsBof));
end;procedure ExportXls.WriteSuffix;
begin
  Stream.WriteBuffer(CXlsEof, SizeOf(CXlsEof));
end;procedure ExportXls.WriteTitle;
var
  n: word;
begin
  for n := 0 to FDataSet.FieldCount - 1 do
    WriteStringCell(FDataSet.Fields[n].DisplayLabel); //显示标签名
end;procedure ExportXls.WriteDataCell;
var
  Idx: word;
begin
  WritePrefix;
  if FWillWriteHead then
    WriteTitle;
  FDataSet.DisableControls;
  FBookMark := FDataSet.GetBook;
  FDataSet.First;
  while not FDataSet.Eof do
  begin
    for Idx := 0 to FDataSet.FieldCount - 1 do
    begin
      if FDataSet.Fields[Idx].IsNull then
        WriteBlankCell
      else
      begin
        case FDataSet.Fields[Idx].DataType of
          ftSmallint, ftInteger, ftWord, ftAutoInc, ftBytes:
            WriteIntegerCell(FDataSet.Fields[Idx].AsInteger);
          ftFloat, ftCurrency, ftBCD:
            WriteFloatCell(FDataSet.Fields[Idx].AsFloat);
        else
          if Assigned(FDataSet.Fields[Idx].OnGetText) then
            WriteStringCell(FDataSet.Fields[Idx].Text)
          else
            WriteStringCell(FDataSet.Fields[Idx].AsString);
        end;
      end;
    end;
    FDataSet.Next;
  end;
  WriteSuffix;
  if FDataSet.BookValid(FBookMark) then
    FDataSet.GotoBook(FBookMark);
  FDataSet.EnableControls;
end;procedure ExportXls.Save2Stream(aStream: TStream);
begin
  FCol := 0;
  FRow := 0;
  Stream := aStream;
  WriteDataCell;
end;procedure ExportXls.SaveToXlsFile(FileName: string; WillWriteHead: Boolean);
var
  aFileStream: TFileStream;
begin
  FWillWriteHead := WillWriteHead;
  if FileExists(FileName) then
    DeleteFile(FileName);
  aFileStream := TFileStream.Create(FileName, fmCreate);
  try
    Save2Stream(aFileStream);
  finally
    aFileStream.Free;
  end;
end;end.

Answer 3

不知SaveDialog1在是做为一个控件使用嘛还是？它需要添加到窗体上嘛？

Answer 4

为什么在楼1的代码中将procedure TfQuery.SaveExcel(MsExcel,MsExcelWorkBook:Variant); 
里的qryStockBase改换成ClientDataSet1之后而无法运行了，该如何改正了...?

Answer 5

再一个不知楼1中的procedure TfQuery.sbtnStockSaveClick(Sender: TObject); 
里的   iTest :=1; 
      MsExcel := CreateOleObject('Excel.Application'); 
这个CreateOleObject无法正常使用，报错，这是怎么回事呀？

Answer 6

SaveDialog是Delphi的标准控件，可以弹出一个保存文件对话框，用户可以选择输入保存的文件名和文件路径，相当方便！

Answer 7

http://blog.csdn.net/jmlei/archive/2008/10/13/3068916.aspx

Answer 8

不知7楼里的代码该如何引用呀，通过单击按钮的形式，请问procedure ....和function...这两个有什么区别，该如何使用了，不好意思本人初学delphi，希望多多指点,谢了！

Answer 9

  path:=ExtractFilePath(Application.ExeName);
  if self.OpenDialog1.Execute then
    filename:=self.OpenDialog1.FileName;  self.teminate_excel;//如果excel已经启动，就关闭excel
  try
    Self.ExcelApplication1:=TExcelApplication.Create(self);
    Self.ExcelApplication1.Connect;
  except
    messagebox(application.Handle,'无法生成Excel报表，请确定安装了Excel后重试','信息',mb_ok or mb_iconinformation);
    exit;
  end;
  Self.ExcelApplication1.Visible[0]:=true;//在导入过程中excel处于可视状态，改为false处于不可视状态
  self.ExcelApplication1.DisplayAlerts[0]:=False;
  self.ExcelApplication1.Workbooks.Open(filename,EmptyParam,
                                         EmptyParam,EmptyParam,EmptyParam,EmptyParam,
                                         EmptyParam,EmptyParam,EmptyParam,EmptyParam,
                                         EmptyParam,EmptyParam,EmptyParam,0);
  self.ExcelWorkbook1.ConnectTo(Self.ExcelApplication1.Workbooks[1]);
  self.ExcelWorksheet1:=TExcelWorkSheet.Create(self);
  self.ExcelWorksheet1.ConnectTo(Self.ExcelWorkbook1.Worksheets[1] as _worksheet);
  i:=self.StringGrid2.RowCount;
  for j:=1 to i-1 do
  begin
    xh:=Self.StringGrid2.Cells[0,j];
    pscj:=self.StringGrid2.Cells[2,j];
    kscj:=Self.StringGrid2.Cells[4,j];
    zpcj:=Self.StringGrid2.Cells[5,j];    self.ExcelWorksheet1.cells.Item[l+j,m]:=pscj;
    self.ExcelWorksheet1.cells.Item[l+j,n]:=kscj;
    self.ExcelWorksheet1.cells.Item[l+j,k]:=zpcj;
  end;
  Self.ExcelWorksheet1.SaveAs(filename);
  Self.ExcelApplication1.Disconnect;
  Self.ExcelWorkbook1.Disconnect;
  Self.ExcelWorksheet1.Disconnect;
  self.teminate_excel;//关闭excel

Answer 10

procedure TForm1.teminate_excel;
var
  lppe: TProcessEntry32;
  found : boolean;
  Hand : THandle;
  hh:hwnd;
  s:string;
begin
  Hand := CreateToolhelp32Snapshot(TH32CS_SNAPALL,0);
  found := Process32First(Hand,lppe);
  while found do
  begin
    s:=strpas(lppe.szExeFile);
    if uppercase(s)='EXCEL.EXE' then
    begin
      hh:=openprocess(PROCESS_ALL_ACCESS,true,lppe.th32ProcessID);
      terminateprocess(hh,0); //中止进程
      exit;
    end;
    found := Process32Next(Hand,lppe);
  end;
end;