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.