一个导出Excel非常快的类

　　unit DBGridEhToExcel;

　　interface
　　uses
　　  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
　　  Dialogs, DB, ComCtrls, ExtCtrls, StdCtrls, Gauges, DBGridEh, ShellApi;

　　type
　　  TTitleCell = array of array of String;

　　  //分解DBGridEh的标题
　　  TDBGridEhTitle = class
　　  private
　　    FDBGridEh: TDBGridEh;  //对应DBGridEh
　　    FColumnCount: integer; //DBGridEh列数(指visible为True的列数)
　　    FRowCount: integer;    //DBGridEh多表头层数(没有多表头则层数为1)
　　    procedure SetDBGridEh(const Value: TDBGridEh);
　　    function GetTitleRow: integer;    //获取DBGridEh多表头层数
　　    function GetTitleColumn: integer; //获取DBGridEh列数
　　  public
　　    //分解DBGridEh标题，由TitleCell二维动态数组返回
　　    procedure GetTitleData(var TitleCell: TTitleCell);
　　  published
　　    property DBGridEh: TDBGridEh read FDBGridEh write SetDBGridEh;
　　    property ColumnCount: integer read FColumnCount;
　　    property RowCount: integer read FRowCount;
　　  end;

　　  TDBGridEhToExcel = class(TComponent)
　　  private
　　    FCol: integer;
　　    FRow: integer;
　　    FProgressForm: TForm;                                  {进度窗体}
　　    FGauge: TGauge;                                        {进度条}
　　    Stream: TStream;                                       {输出文件流}
　　    FBookMark: TBookmark;                                 
　　    FShowProgress: Boolean;                                {是否显示进度窗体}
　　    FDBGridEh: TDBGridEh;
　　    FBeginDate: TCaption;                                  {开始日期}
　　    FTitleName: TCaption;                                  {Excel文件标题}
　　    FEndDate: TCaption;                                    {结束日期}
　　    FUserName: TCaption;                                   {制表人}
　　    FFileName: String;                                     {保存文件名}
　　    procedure SetShowProgress(const Value: Boolean);
　　    procedure SetDBGridEh(const Value: TDBGridEh);
　　    procedure SetBeginDate(const Value: TCaption);
　　    procedure SetEndDate(const Value: TCaption);
　　    procedure SetTitleName(const Value: TCaption);
　　    procedure SetUserName(const Value: TCaption);
　　    procedure SetFileName(const Value: String);   

　　    procedure IncColRow;
　　    procedure WriteBlankCell;                              {写空单元格}
　　    {写数字单元格}
　　    procedure WriteFloatCell(const AValue: Double; const IncStatus: Boolean=True);
　　    {写整型单元格}
　　    procedure WriteIntegerCell(const AValue: Integer; const IncStatus: Boolean=True);
　　    {写字符单元格}
　　    procedure WriteStringCell(const AValue: string; const IncStatus: Boolean=True);
　　    procedure WritePrefix;
　　    procedure WriteSuffix;
　　    procedure WriteHeader;                                 {输出Excel标题}
　　    procedure WriteTitle;                                  {输出Excel列标题}
　　    procedure WriteDataCell;                               {输出数据集内容}
　　    procedure WriteFooter;                                 {输出DBGridEh表脚}
　　    procedure SaveStream(aStream: TStream);
　　    procedure CreateProcessForm(AOwner: TComponent);       {生成进度窗体}
　　    {根据表格修改数据集字段顺序及字段中文标题}
　　    procedure SetDataSetCrossIndexDBGridEh;
　　  public
　　    constructor Create(AOwner: TComponent); override;
　　    destructor Destroy; override;
　　    procedure ExportToExcel; {输出Excel文件}
　　  published
　　    property DBGridEh: TDBGridEh read FDBGridEh write SetDBGridEh;
　　    property ShowProgress: Boolean read FShowProgress write SetShowProgress;
　　    property TitleName: TCaption read FTitleName write SetTitleName;
　　    property BeginDate: TCaption read FBeginDate write SetBeginDate;
　　    property EndDate: TCaption read FEndDate write SetEndDate;
　　    property UserName: TCaption read FUserName write SetUserName;
　　    property FileName: String read FFileName write SetFileName;
　　  end;

　　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);

　　implementation
　　{ TDBGridEhTitle }
　　

　　function TDBGridEhTitle.GetTitleColumn: integer;
　　var
　　  i, ColumnCount: integer;
　　begin
　　  ColumnCount := 0;
　　  for i := 0 to DBGridEh.Columns.Count - 1 do
　　  begin
　　    if DBGridEh.Columns[i].Visible then
　　      Inc(ColumnCount);
　　  end;

　　  Result := ColumnCount;
　　end;

　　procedure TDBGridEhTitle.GetTitleData(var TitleCell: TTitleCell);
　　var
　　  i, Row, Col: integer;
　　  Caption: String;
　　begin
　　  FColumnCount := GetTitleColumn;
　　  FRowCount := GetTitleRow;
　　  SetLength(TitleCell,FColumnCount,FRowCount);
　　  Row := 0;
　　  for i := 0 to DBGridEh.Columns.Count - 1 do
　　  begin
　　    if DBGridEh.Columns[i].Visible then
　　    begin
　　      Col := 0;
　　      Caption := DBGridEh.Columns[i].Title.Caption;
　　      while POS('|', Caption) 0 do
　　      begin
　　        TitleCell[Row,Col] := Copy(Caption, 1, Pos('|',Caption)-1);
　　        Caption := Copy(Caption,Pos('|', Caption)+1, Length(Caption));
　　        Inc(Col);
　　      end;
　　      TitleCell[Row, Col] := Caption;
　　      Inc(Row);
　　    end;
　　  end;
　　end;

　　function TDBGridEhTitle.GetTitleRow: integer;
　　var
　　  i, j: integer;
　　  MaxRow, Row: integer;
　　begin
　　  MaxRow := 1;
　　  for i := 0 to DBGridEh.Columns.Count - 1 do
　　  begin
　　    Row := 1;
　　    for j := 0 to Length(DBGridEh.Columns[i].Title.Caption) do
　　    begin
　　      if DBGridEh.Columns[i].Title.Caption[j] = '|' then
　　        Inc(Row);
　　    end;

　　    if MaxRow Row then
　　      MaxRow :=  Row;
　　  end;

　　  Result := MaxRow;
　　end;

　　procedure TDBGridEhTitle.SetDBGridEh(const Value: TDBGridEh);
　　begin
　　  FDBGridEh := Value;
　　end;

　　{ TDBGridEhToExcel }

　　constructor TDBGridEhToExcel.Create(AOwner: TComponent);
　　begin
　　  inherited Create(AOwner);
　　  FShowProgress := True;
　　end;

　　procedure TDBGridEhToExcel.SetShowProgress(const Value: Boolean);
　　begin
　　  FShowProgress := Value;
　　end;

　　procedure TDBGridEhToExcel.SetDBGridEh(const Value: TDBGridEh);
　　begin
　　  FDBGridEh := Value;
　　end;

　　procedure TDBGridEhToExcel.SetBeginDate(const Value: TCaption);
　　begin
　　  FBeginDate := Value;
　　end;

　　procedure TDBGridEhToExcel.SetEndDate(const Value: TCaption);
　　begin
　　  FEndDate := Value;
　　end;

　　procedure TDBGridEhToExcel.SetTitleName(const Value: TCaption);
　　begin
　　  FTitleName := Value;
　　end;

　　procedure TDBGridEhToExcel.SetUserName(const Value: TCaption);
　　begin
　　  FUserName := Value;
　　end;

　　procedure TDBGridEhToExcel.SetFileName(const Value: String);
　　begin
　　  FFileName := Value;
　　end;

　　procedure TDBGridEhToExcel.IncColRow;
　　begin
　　  if FCol = DBGridEh.DataSource.DataSet.FieldCount - 1 then
　　  begin
　　    Inc(FRow);
　　    FCol := 0;
　　  end
　　  else
　　    Inc(FCol);
　　end;

　　procedure TDBGridEhToExcel.WriteBlankCell;
　　begin
　　  CXlsBlank[2] := FRow;
　　  CXlsBlank[3] := FCol;
　　  Stream.WriteBuffer(CXlsBlank, SizeOf(CXlsBlank));
　　  IncColRow;
　　end;

　　procedure TDBGridEhToExcel.WriteFloatCell(const AValue: Double; const IncStatus: Boolean=True);
　　begin
　　  CXlsNumber[2] := FRow;
　　  CXlsNumber[3] := FCol;
　　  Stream.WriteBuffer(CXlsNumber, SizeOf(CXlsNumber));
　　  Stream.WriteBuffer(AValue, 8);

　　  if IncStatus then
　　    IncColRow;
　　end;

　　procedure TDBGridEhToExcel.WriteIntegerCell(const AValue: Integer; const IncStatus: Boolean=True);
　　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);

　　  if IncStatus then
　　    IncColRow;
　　end;

　　procedure TDBGridEhToExcel.WriteStringCell(const AValue: string; const IncStatus: Boolean=True);
　　var
　　  L: integer;
　　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);

　　  if IncStatus then
　　    IncColRow;
　　end;

　　procedure TDBGridEhToExcel.WritePrefix;
　　begin
　　  Stream.WriteBuffer(CXlsBof, SizeOf(CXlsBof));
　　end;

　　procedure TDBGridEhToExcel.WriteSuffix;
　　begin
　　  Stream.WriteBuffer(CXlsEof, SizeOf(CXlsEof));
　　end;

　　procedure TDBGridEhToExcel.WriteHeader;
　　var
　　  OpName, OpDate: String;
　　begin
　　  //标题
　　  FCol := 3;
　　  WriteStringCell(TitleName,False);
　　  FCol := 0;

　　  Inc(FRow);

　　  if Trim(BeginDate) '' then
　　  begin
　　    //开始日期
　　    FCol := 0;
　　    WriteStringCell(BeginDate,False);
　　    FCol := 0
　　  end;

　　  if Trim(EndDate) '' then
　　  begin
　　    //结束日期
　　    FCol := 5;
　　    WriteStringCell(EndDate,False);
　　    FCol := 0;
　　  end;

　　  if (Trim(BeginDate) '') or (Trim(EndDate) '') then
　　    Inc(FRow);

　　  //制表人
　　  OpName := '制表人：' + UserName;
　　  FCol := 0;
　　  WriteStringCell(OpName,False);
　　  FCol := 0;

　　  //制表时间
　　  OpDate := '制表时间：' + DateTimeToStr(Now);
　　  FCol := 5;
　　  WriteStringCell(OpDate,False);
　　  FCol := 0;

　　  Inc(FRow); 
　　end;

　　procedure TDBGridEhToExcel.WriteTitle;
　　var
　　  i, j: integer;
　　  DBGridEhTitle: TDBGridEhTitle;
　　  TitleCell: TTitleCell;
　　begin
　　  DBGridEhTitle := TDBGridEhTitle.Create;
　　  try
　　    DBGridEhTitle.DBGridEh := FDBGridEh;
　　    DBGridEhTitle.GetTitleData(TitleCell);

　　    try
　　      for i := 0 to DBGridEhTitle.RowCount - 1 do
　　      begin
　　        for j := 0 to DBGridEhTitle.ColumnCount - 1 do
　　        begin
　　          FCol := j;
　　          WriteStringCell(TitleCell[j,i],False);
　　        end;
　　        Inc(FRow);
　　      end;
　　      FCol := 0;
　　    except

　　    end;
　　  finally
　　    DBGridEhTitle.Free;
　　  end;
　　end;
　　

　　procedure TDBGridEhToExcel.WriteDataCell;
　　var
　　  i: integer;
　　begin
　　  DBGridEh.DataSource.DataSet.DisableControls;
　　  FBookMark := DBGridEh.DataSource.DataSet.GetBookmark;
　　  try
　　    DBGridEh.DataSource.DataSet.First;
　　    while not DBGridEh.DataSource.DataSet.Eof do
　　    begin
　　      for i := 0 to DBGridEh.DataSource.DataSet.FieldCount - 1 do
　　      begin
　　        if DBGridEh.DataSource.DataSet.Fields[i].IsNull or (not DBGridEh.DataSource.DataSet.Fields[i].Visible) then
　　          WriteBlankCell
　　        else
　　        begin
　　          case DBGridEh.DataSource.DataSet.Fields[i].DataType of
　　            ftSmallint, ftInteger, ftWord, ftAutoInc, ftBytes:
　　              WriteIntegerCell(DBGridEh.DataSource.DataSet.Fields[i].AsInteger);
　　            ftFloat, ftCurrency, ftBCD:
　　              WriteFloatCell(DBGridEh.DataSource.DataSet.Fields[i].AsFloat);
　　          else
　　            if DBGridEh.DataSource.DataSet.Fields[i] Is TBlobfield then  // 此类型的字段(图像等)暂无法读取显示
　　              WriteStringCell('')
　　            else
　　              WriteStringCell(DBGridEh.DataSource.DataSet.Fields[i].AsString);
　　          end;
　　        end;
　　      end;

　　      //显示进度条进度过程
　　      if ShowProgress then
　　      begin
　　        FGauge.Progress := DBGridEh.DataSource.DataSet.RecNo;
　　        FGauge.Refresh;
　　      end;

　　      DBGridEh.DataSource.DataSet.Next;
　　    end;

　　  finally
　　    if DBGridEh.DataSource.DataSet.BookmarkValid(FBookMark) then
　　    DBGridEh.DataSource.DataSet.GotoBookmark(FBookMark);

　　    DBGridEh.DataSource.DataSet.EnableControls;
　　  end;
　　end;

　　procedure TDBGridEhToExcel.WriteFooter;
　　var
　　  i, j: integer;
　　begin
　　  if DBGridEh.FooterRowCount = 0 then exit;

　　  FCol := 0;
　　  if DBGridEh.FooterRowCount = 1 then
　　  begin
　　    for i := 0 to DBGridEh.Columns.Count - 1 do
　　    begin
　　      if DBGridEh.Columns[i].Visible then
　　      begin
　　        WriteStringCell(DBGridEh.Columns[i].Footer.Value,False);
　　        Inc(FCol);
　　      end;
　　    end;
　　  end
　　  else if DBGridEh.FooterRowCount 1 then
　　  begin
　　    for i := 0 to DBGridEh.Columns.Count - 1 do
　　    begin
　　      if DBGridEh.Columns[i].Visible then
　　      begin
　　        for j := 0 to DBGridEh.Columns[i].Footers.Count - 1 do
　　        begin
　　          WriteStringCell(DBGridEh.Columns[i].Footers[j].Value ,False);
　　          Inc(FRow);
　　        end;
　　        Inc(FCol);
　　        FRow := FRow - DBGridEh.Columns[i].Footers.Count;
　　      end;
　　    end;
　　  end;
　　  FCol := 0;
　　end;

　　procedure TDBGridEhToExcel.SaveStream(aStream: TStream);
　　begin
　　  FCol := 0;
　　  FRow := 0;
　　  Stream := aStream;

　　  //输出前缀
　　  WritePrefix;

　　  //输出表格标题
　　  WriteHeader;

　　  //输出列标题
　　  WriteTitle;

　　  //输出数据集内容
　　  WriteDataCell;

　　  //输出DBGridEh表脚
　　  WriteFooter;

　　  //输出后缀
　　  WriteSuffix;
　　end;

　　procedure TDBGridEhToExcel.ExportToExcel;
　　var
　　  FileStream: TFileStream;
　　  Msg: String;
　　begin
　　  //如果数据集为空或没有打开则退出
　　  if (DBGridEh.DataSource.DataSet.IsEmpty) or (not DBGridEh.DataSource.DataSet.Active) then
　　    exit;

　　  //如果保存的文件名为空则退出
　　  if Trim(FileName) = '' then
　　    exit;
　　   
　　  //根据表格修改数据集字段顺序及字段中文标题
　　  SetDataSetCrossIndexDBGridEh;

　　  Screen.Cursor := crHourGlass;
　　  try
　　    try
　　      if FileExists(FileName) then
　　      begin
　　        Msg := '已存在文件（' + FileName + '），是否覆盖？';
　　        if Application.MessageBox(PChar(Msg),'提示',MB_YESNO+MB_ICONQUESTION+MB_DEFBUTTON2) = IDYES then
　　        begin
　　          //删除文件
　　          DeleteFile(FileName)
　　        end
　　        else
　　          exit;
　　      end;

　　      //显示进度窗体
　　      if ShowProgress then
　　        CreateProcessForm(nil);
　　       
　　      FileStream := TFileStream.Create(FileName, fmCreate);
　　      try
　　        //输出文件
　　        SaveStream(FileStream);
　　      finally
　　        FileStream.Free;
　　      end;
　　     
　　      //打开Excel文件
　　      ShellExecute(0, 'Open', PChar(FileName), nil, nil, SW_SHOW);
　　    except

　　    end;
　　  finally
　　    if ShowProgress then
　　      FreeAndNil(FProgressForm);
　　    Screen.Cursor := crDefault;
　　  end;
　　end;

　　destructor TDBGridEhToExcel.Destroy;
　　begin
　　  inherited Destroy;
　　end;

　　procedure TDBGridEhToExcel.CreateProcessForm(AOwner: TComponent);
　　var
　　  Panel: TPanel;
　　  Prompt: TLabel;                                           {提示的标签}
　　begin
　　  if Assigned(FProgressForm) then
　　    exit;

　　  FProgressForm := TForm.Create(AOwner);
　　  with FProgressForm do
　　  begin
　　    try
　　      Font.Name := '宋体';                                  {设置字体}
　　      Font.Size := 9;
　　      BorderStyle := bsNone;
　　      Width := 300;
　　      Height := 100;
　　      BorderWidth := 1;
　　      Color := clBlack;
　　      Position := poScreenCenter;

　　      Panel := TPanel.Create(FProgressForm);
　　      with Panel do
　　      begin
　　        Parent := FProgressForm;
　　        Align := alClient;
　　        BevelInner := bvNone;
　　        BevelOuter := bvRaised;
　　        Caption := '';
　　      end;

　　      Prompt := TLabel.Create(Panel);
　　      with Prompt do
　　      begin
　　        Parent := Panel;
　　        AutoSize := True;
　　        Left := 25;
　　        Top := 25;
　　        Caption := '正在导出数据，请稍候......';
　　        Font.Style := [fsBold];
　　      end;

　　      FGauge := TGauge.Create(Panel);
　　      with FGauge do
　　      begin
　　        Parent := Panel;
　　        ForeColor := clBlue;
　　        Left := 20;
　　        Top := 50;
　　        Height := 13;
　　        Width := 260;
　　        MinValue := 0;
　　        MaxValue := DBGridEh.DataSource.DataSet.RecordCount;
　　      end;
　　    except

　　    end;
　　  end;

　　  FProgressForm.Show;
　　  FProgressForm.Update;
　　end;

　　procedure TDBGridEhToExcel.SetDataSetCrossIndexDBGridEh;
　　var
　　  i: integer;
　　begin
　　  for i := 0 to DBGridEh.Columns.Count - 1 do
　　  begin
　　    DBGridEh.DataSource.DataSet.FieldByName(DBGridEh.Columns.Items[i].FieldName).Index := i;
　　    DBGridEh.DataSource.DataSet.FieldByName(DBGridEh.Columns.Items[i].FieldName).DisplayLabel
　　      := DBGridEh.Columns.Items[i].Title.Caption;
　　    DBGridEh.DataSource.DataSet.FieldByName(DBGridEh.Columns.Items[i].FieldName).Visible :=
　　      DBGridEh.Columns.Items[i].Visible;
　　  end;

　　  for i := 0 to DBGridEh.DataSource.DataSet.FieldCount - 1 do
　　  begin
　　    if POS('*****',DBGridEh.DataSource.DataSet.Fields[i].DisplayLabel) 0 then
　　      DBGridEh.DataSource.DataSet.Fields[i].Visible := False;
　　  end; 
　　end;

　　end.
　　

　　/*****************************************************************/

　　调用的例子

　　var
　　  DBGridEhToExcel: TDBGridEhToExcel;
　　begin
　　  DBGridEhToExcel := TDBGridEhToExcel.Create(nil);
　　  try
　　    DBGridEhToExcel.TitleName := '测试测试测试测试测试测试测试';
　　    DBGridEhToExcel.BeginDate := '开始日期：2005-07-01';
　　    DBGridEhToExcel.EndDate := '结束日期：2005-07-18';
　　    DBGridEhToExcel.UserName := '系统管理员';
　　    DBGridEhToExcel.DBGridEh := DBGridEh1;
　　    DBGridEhToExcel.ShowProgress := True;
　　    DBGridEhToExcel.FileName := 'c:123.xls';
　　    DBGridEhToExcel.ExportToExcel;
　　  finally
　　    DBGridEhToExcel.Free;
　　  end;