TAdoQuery导出数据到Excel

procedure TFrmZjMoveSch.BitBtn2Click(Sender: TObject);
var
  WD: TWriteData ;
begin
  WD := TWriteData.Create ;
  WD.Qry := qryZjMoveSch;
  WD.Summary.Add('铸件移交计划:');
  WD.Summary.Add('所有生产批号!');
  WD.Summary.Add('Create by: '+FrmMain.UserName);
  WD.Summary.Add(DateToStr(now));
  try

    if SaveDialog1.Execute then
    WD.ExportToFile(SaveDialog1.FileName, true);
  finally
    WD.Free ;
  end;
//
end;


unit WriteData;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, Grids, DBGridEh, DB, ADODB, StdCtrls, Buttons, XPMenu, DBGrids;

//目标是：  通过普通AdoQuery来导出数据！
//Create by yxf
//Date: 2004-10-05
// 

type

  TColumnsList = class(TList)
  private
    function GetColumn(Index: Integer): TColumn;
    procedure SetColumn(Index: Integer; const Value: TColumn);
  public
    property Items[Index: Integer]: TColumn read GetColumn write SetColumn; default;
  end;

  TColCellParams = class
  protected
    FAlignment: TAlignment;
    FBackground: TColor;
    FCol: Longint;
    FFont: TFont;
    FImageIndex: Integer;
    FReadOnly: Boolean;
    FRow: Longint;
    FState: TGridDrawState;
    FText: String;
  public
    property Alignment: TAlignment read FAlignment write FAlignment;
    property Background: TColor read FBackground write FBackground;
    property Col: Longint read FCol;
    property Font: TFont read FFont;
    property ImageIndex: Integer read FImageIndex write FImageIndex;
    property ReadOnly: Boolean read FReadOnly write FReadOnly;
    property Row: Longint read FRow;
    property State: TGridDrawState read FState;
    property Text: String read FText write FText;
  end;

  TWriteData = class
  private
    //FColCellParamsEh: TColCellParamsEh;
    FDBGrid: TCustomDBGrid;
    FQry: TAdoQuery;
    //FExpCols: TColumnsEhList;
    FStream: TStream;
    //function GetFooterValue(Row, Col: Integer): String;
    //procedure CalcFooterValues;
    FCol, FRow: Word;
    FSummary: TStringList;
//    FColumns: TColumnsList;
//    FCount: integer;//列总和

  protected
//    FooterValues: PFooterValues;
    procedure WriteBlankCell;
    procedure WriteEnter;   
    procedure WriteIntegerCell(const AValue: Integer);
    procedure WriteFloatCell(const AValue: Double);
    procedure WriteStringCell(const AValue: String);
    procedure IncColRow;
    procedure WritePrefix;
    procedure WriteSuffix;
    procedure WriteTitle;
    procedure WriteRecord(ColumnsList: TColumnsList);
    procedure WriteDataCell(Column: TColumn; FColCellParams: TColCellParams);
    //procedure WriteFooter(ColumnsList: TColumnsEhList; FooterNo: Integer);
    //procedure WriteFooterCell(DataCol, Row: Integer; Column: TColumnEh; AFont: TFont;
  //    Background: TColor; Alignment: TAlignment; Text: String);
    property Stream: TStream read FStream write FStream;
    //property ExpCols: TColumnsEhList read FExpCols write FExpCols;
  public
    constructor Create;
    destructor Destroy; override;
    procedure ExportToStream(AStream: TStream; IsExportAll: Boolean);
    procedure ExportToFile(FileName: String; IsExportAll: Boolean);
    property Summary: TStringList read FSummary write FSummary;
    property Qry: TAdoQuery read FQry write FQry;
    property DBGrid: TCustomDBGrid read FDBGrid write FDBGrid;
  end;

implementation

{ TWriteData }

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

constructor TWriteData.Create;
begin
//  FDBGrid := TCustomDBGrid.Create(self);
  FSummary := TStringList.Create ;
  inherited;
end;

destructor TWriteData.Destroy;
begin
  FSummary.Free ;
  inherited;
end;

procedure TWriteData.ExportToFile(FileName: String; IsExportAll: Boolean);
var FileStream: TFileStream;
begin
  FileStream := TFileStream.Create(FileName, fmCreate);
  try
    ExportToStream(FileStream, IsExportAll);
  finally
    FileStream.Free;
  end;
end;

procedure TWriteData.ExportToStream(AStream: TStream;
  IsExportAll: Boolean);
var
//  ColList: TColumnsEhList;
  BookMark: Pointer;
  i: Integer;
begin

  FCol := 0;
  FRow := 0;

  Stream := AStream;

  WritePrefix;
    //写标题

  WriteTitle;
  BookMark := Qry.GetBookmark;

  Qry.DisableControls ;
  Screen.Cursor := crSQLWait;
  try
    if not Qry.Active then Qry.Open ;
    Qry.First ;
    While not Qry.Eof do
    begin
      for I := 0 to Qry.FieldCount - 1 do
      begin
        case Qry.Fields[i].DataType of
          ftSmallint, ftInteger, ftWord, ftAutoInc, ftBytes:
            WriteIntegerCell(Qry.Fields[i].AsInteger );
          ftFloat, ftCurrency, ftBCD{$IFDEF EH_LIB_6}, ftFMTBcd{$ENDIF}:
            WriteFloatCell(Qry.Fields[i].AsFloat);
        else
          WriteStringCell(Qry.Fields[i].AsString );
        end;
      end;
      Qry.Next ;
    end;
  finally
    Qry.GotoBookmark(BookMark);
    Qry.EnableControls ;
    Qry.FreeBookmark(BookMark);
    WriteEnter;
    WriteStringCell('查询条件:');
    WriteEnter;
    for I:= 0 to FSummary.Count - 1 do
    begin
      if FSummary.Strings[I] = '#13' then WriteEnter else
        WriteStringCell(FSummary.Strings[I]);
      WriteEnter;
    end;
    Screen.Cursor := crdefault;   
  end;
  WriteSuffix;
  ShowMessage('数据导入成功完成!');
//具体处理导出设置
end;

procedure TWriteData.IncColRow;
begin
  if FCol = Qry.FieldCount - 1 then
  begin
    Inc(FRow);
    FCol := 0;
  end else
    Inc(FCol);
end;

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

procedure TWriteData.WriteDataCell(Column: TColumn;
  FColCellParams: TColCellParams);
begin
  if Column.Field = nil then
    WriteBlankCell
//  else if Column.GetColumnType = ctKeyPickList then
//    WriteStringCell(FColCellParamsEh.Text)
  else if Column.Field.IsNull then
    WriteBlankCell
  else
    with Column.Field do
      case DataType of
        ftSmallint, ftInteger, ftWord, ftAutoInc, ftBytes:
          WriteIntegerCell(AsInteger);
        ftFloat, ftCurrency, ftBCD:
          WriteFloatCell(AsFloat);
      else
        WriteStringCell(FColCellParams.Text);
      end;
end;

procedure TWriteData.WriteEnter;
begin
  FCol := Qry.FieldCount - 1;
  WriteStringCell('');
//  FCol := Qry.FieldCount - 1; 
end;

procedure TWriteData.WriteFloatCell(const AValue: Double);
begin
  CXlsNumber[2] := FRow;
  CXlsNumber[3] := FCol;
  Stream.WriteBuffer(CXlsNumber, SizeOf(CXlsNumber));
  Stream.WriteBuffer(AValue, 8);
  IncColRow;
end;

procedure TWriteData.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 TWriteData.WritePrefix;
begin
  Stream.WriteBuffer(CXlsBof, SizeOf(CXlsBof));
end;

procedure TWriteData.WriteRecord(ColumnsList: TColumnsList);
var //i: Integer;
  AFont: TFont;
//    State:TGridDrawState;
begin
  AFont := TFont.Create;
  try
//    for i := 0 to ColumnsList.Count - 1 do
    begin
  //    AFont.Assign(ColumnsList[i].Font);

    //  with TColCellParamsEhCracker(FColCellParamsEh) do
      begin
       // FRow := -1;
        //FCol := -1;
 //       FState := [];
//        FFont := AFont;
//        Background := ColumnsList[i].Color;
//        Alignment := ColumnsList[i].Alignment;
//        ImageIndex := ColumnsList[i].GetImageIndex;
       // Text := ColumnsList[i].DisplayName;
//        CheckboxState := ColumnsList[i].CheckboxState;

//        if Assigned(DBGridEh.OnGetCellParams) then
//          DBGridEh.OnGetCellParams(DBGridEh, ColumnsList[i], FFont, FBackground, FState);

//        ColumnsList[i].GetColCellParams(False, FColCellParamsEh);

        //WriteDataCell(ColumnsList[i], FColCellParamsEh);

      end;
    end;
  finally
    AFont.Free;
  end;
end;

procedure TWriteData.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 TWriteData.WriteSuffix;
begin
  Stream.WriteBuffer(CXlsEof, SizeOf(CXlsEof));
end;

procedure TWriteData.WriteTitle;
var
  I: Integer;
begin

//这里需要重新定义
//遍历列 明细 填写标题
  for I := 0 to Qry.FieldCount - 1 do
  begin
    WriteStringCell(Qry.Fields[i].DisplayLabel );
  end;
end;

{ TColumnsList }

function TColumnsList.GetColumn(Index: Integer): TColumn;
begin
  Result := Get(Index);
end;

procedure TColumnsList.SetColumn(Index: Integer; const Value: TColumn);
begin
  Put(Index, Value);
end;

end.

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