一个将记录集直接转化为Excel文档的控件

<转贴>
{
DEM
with TDatasetToExcel.Create(nil) do
  begin
    Dataset :=qry;
    SaveExclFile('c:\a.xls',true);
  end;
  }

unit UDataSetToExcel;
interface
uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs,ADODB ,dbgrids, Db, dbtables;

type
TDatasetToExcel = class(TComponent)
  private
    FCol: word;
    FRow: word;
    FDataSet: TDataSet;
    Stream: TStream;
    FWillWriteHead: boolean;
    FBookMark: TBookmark;
    // FfileName:TfileName;
    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 Setdataset(const value: Tdataset);
    // procedure SetFileName(const value: TFileName);

    procedure SaveStream(aStream: TStream);
  public
    procedure SaveExclFile(FileName: string; WillWriteHead: Boolean);
    //constructor Create(AOwner: TComponent;aDataSet: TDataSet);
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    property Dataset: TDataset Read FDataset Write SetDataset;
    //  property FileName: TFilename 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
constructor TDatasetToExcel.Create(AOwner: TComponent);
//constructor TDatasetToExcel.Create(AOwner: TComponent;aDataSet: TDataSet);

begin
  inherited Create(AOwner);
  // FDataSet := aDataSet;
end;

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

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

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

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

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

procedure TDatasetToExcel.WriteTitle;
var
  n: word;
begin
  for n := 0 to FDataSet.FieldCount - 1 do
    begin
      WriteStringCell(FDataSet.Fields[n].FieldName);
    end;
end;

procedure TDatasetToExcel.WriteDataCell;
var
  n: word;
begin
  WritePrefix;
  if FWillWriteHead then
    WriteTitle;
  FDataSet.DisableControls;
  FBookMark := FDataSet.GetBookmark;
  FDataSet.First;
  while not FDataSet.Eof do
  begin
    for n := 0 to FDataSet.FieldCount - 1 do
    begin
      if FDataSet.Fields[n].IsNull then
        WriteBlankCell
      else
      begin
        case FDataSet.Fields[n].DataType of
          ftSmallint, ftInteger, ftWord, ftAutoInc, ftBytes:
            WriteIntegerCell(FDataSet.Fields[n].AsInteger);
          ftFloat, ftCurrency, ftBCD:
            WriteFloatCell(FDataSet.Fields[n].AsFloat);
        else
          if FDataSet.Fields[n] Is Tblobfield then  // 此类型的字段(图像等)暂无法读取显示
            WriteStringCell('')
          else
            WriteStringCell(FDataSet.Fields[n].AsString);
        end;
      end;
    end;
    FDataSet.Next;
  end;
  WriteSuffix;
  if FDataSet.BookmarkValid(FBookMark) then
    FDataSet.GotoBookmark(FBookMark);
  FDataSet.EnableControls;
end;

procedure TDatasetToExcel.SaveStream(aStream: TStream);
begin
  FCol := 0;
  FRow := 0;
  Stream := aStream;
  WriteDataCell;
end;

procedure TDatasetToExcel.SaveExclFile(FileName: string; WillWriteHead:
  Boolean);
var
  aFileStream: TFileStream;
begin
  FWillWriteHead := WillWriteHead;
  if FileExists(FileName) then
    DeleteFile(FileName);
  aFileStream := TFileStream.Create(FileName, fmCreate);
  try
    SaveStream(aFileStream);
  finally
    aFileStream.Free;
  end;
end;

destructor TDatasetToExcel.Destroy;
begin
  inherited Destroy;
end;

procedure TDatasetToExcel.Setdataset(const value: Tdataset);
begin
  Fdataset := value;
end;

end.