把数据集保存为Excel格式的一个实现

经常看到有人问如何把Delphi中的数据集导入Excel中，这里提供了一个实现。

在做项目时，很多情况下，客户需要对程序中数据集再加工，再利用，如报表。
这时，就需要把DataSet导入到一个客户比较熟悉的格式中去。Excel是首选了。

该程序在Delphi4,5下编译通过，已被用在多个项目中。还被集成在笔者所写的一个小组件TDBNavigateButton中

 

{-------------------------------------------------------------------------------------------------
单元：uExcelTools
作者：  Bear
功能：保存数据集，如TTable,TQuery,TClientDataSet等为Excel文件，
          包含标题，可以只将一部分字段导出
           这一点通过设置DataSet中要不导出字段的Tag值大于某一个值来处理
原理：调用 Microsoft Excel Ole对象
调用方式： 
                 Function DataSetToExcel(
                     DataSet:TDataSet;FieldTagMax:Integer;
                      Visible:Boolean;ExcelFileName:String=''): Boolean;
--------------------------------------------------------------------------------------------------}

unit UExcelTools;

interface

uses
  classes, comctrls, stdctrls, windows, Dialogs, controls, SysUtils,
  Db,forms,DBClient,ComObj;

//把数据集导入ExcelSheet的核心函数
function DataSetToExcelSheet
            (
             DataSet     :TDataSet;
             FieldTagMax :Integer;   // 字段的Tag值如果大于这个值，就不导出到Excel
             Sheet       :OleVariant
             ): Boolean;

//实际使用的函数，内部调用了DataSetToExcelSheet，在外面加入UI接口和错误处理
function DataSetToExcel
            (
             DataSet     :TDataSet;   // 要转换的数据集
             FieldTagMax :Integer;  // 字段的Tag值如果大于这个值，就不导出到Excel
             Visible     :Boolean;      // 是否让做转换工作的Excel可见
             ExcelFileName:String='' // Excel文件名，*.xls
             ): Boolean;

implementation

Function DataSetToExcelSheet(DataSet:TDataSet;FieldTagMax:Integer;Sheet:OleVariant): Boolean;
var
   Row,Col,FieldIndex :Integer;
   BK:TBookMark;
begin
   Result := False;
   if not Dataset.Active then exit;
   BK:=DataSet.GetBookMark;
   DataSet.DisableControls;

   Sheet.Activate;
   try

     // 列标题
     Row:=1;
     Col:=1;
     for FieldIndex:=0 to DataSet.FieldCount-1 do
         begin
         if DataSet.Fields[FieldIndex].Tag <= FieldTagMax then
            begin
            Sheet.Cells(Row,Col)  :=DataSet.Fields[FieldIndex].DisplayLabel;
            Inc(Col);
            end;
         end;
     // 表内容
     DataSet.First;
     while Not DataSet.Eof do
        begin
        Row:=Row+1;
        Col:=1;
        for FieldIndex:=0 to DataSet.FieldCount-1 do
            begin
            if DataSet.Fields[FieldIndex].Tag <= FieldTagMax then
               begin
               Sheet.Cells(Row,Col):=DataSet.Fields[FieldIndex].AsString;
               Inc(Col);
               end;
            end;
        DataSet.Next;
        end;

     Result := True;
     finally
       DataSet.GotoBookMark(BK);
       DataSet.EnableControls;
    end;

 
end;
Function DataSetToExcel(
                  DataSet:TDataSet;FieldTagMax:Integer;
                  Visible:Boolean;ExcelFileName:String=''): Boolean;
var
   ExcelObj, Excel, WorkBook, Sheet: OleVariant;
    OldCursor:TCursor;
   SaveDialog:TSaveDialog;
begin
   Result := False;
   if not Dataset.Active then exit;

   OldCursor:=Screen.Cursor;
   Screen.Cursor:=crHourGlass;

   try
      ExcelObj := CreateOleObject('Excel.Sheet');
      Excel := ExcelObj.Application;
      Excel.Visible := Visible ;
      WorkBook := Excel.Workbooks.Add ;
      Sheet:= WorkBook.Sheets[1];
   except
      MessageBox(GetActiveWindow,'无法调用Mircorsoft Excel! '+chr(13)+chr(10)+
                    '请检查是否安装了Mircorsoft Excel。','提示',MB_OK+MB_ICONINFORMATION);
      Screen.Cursor:=OldCursor;
      Exit;
   end;

   Result:=DataSetToExcelSheet(DataSet,FieldTagMax,Sheet) ;
   if Result then
      if Not Visible then
         begin
         if ExcelFileName<>''
            then WorkBook.SaveAs(FileName:=ExcelFileName)
            else begin
                 SaveDialog:=TSaveDialog.Create(Nil);
                 SaveDialog.Filter := 'Microsoft Excel 文件|*.xls';
                 Result:=SaveDialog.Execute;
                 UpdateWindow(GetActiveWindow);
                 if Result then
                    WorkBook.SaveAs(FileName:=SaveDialog.FileName);
                 SaveDialog.Free;
                 end;
         Excel.Quit;
         end;
   Screen.Cursor:=OldCursor;
end;

 

end.

 

 

 

本文地址：http://com.8s8s.com/it/it6063.htm