datasettoexcelunt.~pas

将SQL DBGRID数据导出报表为EXCEL

unit DataSetToExcelUnt;

interface

uses Classes, SysUtils, DB, DBGrids,math,Dialogs;

type
  {1 将数据源倒出 }
  TExports = class(TObject)
  private
    FBookMark: TBookMark;
    FCaption: string;
    FCol: Word;
    FDataSet: TDataSet;
    FDBGrid: TDBGrid;
    FFileStream: TFileStream;
    FRow: Word;
  protected
    procedure incColRow;
    procedure WriteFloatCell(AValue: double);
    procedure WriteIntegerCell(AValue: integer);
    procedure WriteStringCell(AValue: string);
  public
    procedure ExportExcelFile(FileName: string; bWriteTitle: Boolean = True;
            aDataSet: TDataSet = nil); overload;
    procedure ExportExcelFile(FileName: string; bWriteTitle: Boolean = True;
            aDBgrid: TDBGrid = nil); overload;
    procedure WriteCaption;
    {1 标题 }
    property Caption: string read FCaption write FCaption;
  end;
  
var
  DataSetExportExcel: TExports;

  arXlsBegin        : array[0..5] of Word = ($809, 8, 0, $10, 0, 0);

  arXlsEnd          : array[0..1] of Word = ($0A, 00);

  arXlsString       : array[0..5] of Word = ($204, 0, 0, 0, 0, 0);

  arXlsNumber       : array[0..4] of Word = ($203, 14, 0, 0, 0);

  arXlsInteger      : array[0..4] of Word = ($27E, 10, 0, 0, 0);

  arXlsBlank        : array[0..4] of Word = ($201, 6, 0, 0, $17);

implementation

uses Umain, Ufun;


{1 将数据源倒出 }
{1 将数据源倒出 }
{1 将数据源倒出 }
{1 将数据源倒出 }
{1 将数据源倒出 }
{1 将数据源倒出 }
{1 将数据源倒出 }
{
*********************************** TExports ***********************************
}
procedure TExports.ExportExcelFile(FileName: string; bWriteTitle: Boolean =
        True; aDataSet: TDataSet = nil);
var
  i: Integer;
begin
  if Assigned(aDataSet) then
  begin
    FDataSet := aDataSet;
  end;

  if FileExists(FileName) then
    DeleteFile(FileName); //文件存在，先删除
  FFileStream := TFileStream.Create(FileName, fmCreate);
  try
    //写文件头
    FFileStream.WriteBuffer(arXlsBegin, SizeOf(arXlsBegin));
    //写列头
    FCol := 0;
    FRow := 0;
    WriteCaption();
    if bWriteTitle then
    begin
      for i := 0 to FDataSet.FieldCount - 1 do
        WriteStringCell(FDataSet.Fields[i].DisplayLabel);
    end;
    //写数据集中的数据
    FDataSet.DisableControls;
    FBookMark := FDataSet.GetBookmark;
    FDataSet.First;
    while not FDataSet.Eof do
    begin
      for i := 0 to FDataSet.FieldCount - 1 do
      begin
        if FDataSet.Fields[i].FieldName='usaprc' then
           begin
           if roundto(FDataSet.FieldByName('itemrmbprc').AsCurrency,-2)>0 then
              WriteFloatCell(ffun.finquo(roundto(FDataSet.FieldByName('itemrmbprc').AsCurrency,-2),FDataSet.FieldByName('Itemptype').AsString))
            else
              WriteFloatCell(0);
           end
        else
          begin
          case FDataSet.Fields[i].DataType of
          ftSmallint, ftInteger, ftWord, ftAutoInc, ftBytes:
            WriteIntegerCell(FDataSet.Fields[i].AsInteger);
          ftFloat, ftCurrency, ftBCD:
            WriteFloatCell(FDataSet.Fields[i].AsFloat)
          else
            WriteStringCell(FDataSet.Fields[i].AsString);
          end;
          end;
      end;

      FDataSet.Next;
    end;
    //写文件尾
    FFileStream.WriteBuffer(arXlsEnd, SizeOf(arXlsEnd));
    if FDataSet.BookmarkValid(FBookMark) then
    begin
      FDataSet.GotoBookmark(FBookMark);
    end;
  finally
    FFileStream.Free;
    FDataSet.EnableControls;
    FDataSet := nil;
  end;
end;

procedure TExports.ExportExcelFile(FileName: string; bWriteTitle: Boolean =
        True; aDBgrid: TDBGrid = nil);
var
  i: Integer;
begin
  if Assigned(aDBgrid) then
  begin
    FDBGrid := aDBgrid;
  end;
  
  if FileExists(FileName) then
    DeleteFile(FileName); //文件存在，先删除
  FFileStream := TFileStream.Create(FileName, fmCreate);
  try
    //写文件头
    FFileStream.WriteBuffer(arXlsBegin, SizeOf(arXlsBegin));
    //写列头
    FCol := 0;
    FRow := 0;
    WriteCaption();
    if bWriteTitle then
    begin
      for i := 0 to FDBGrid.FieldCount - 1 do
        WriteStringCell(FDBGrid.Columns[i].Title.Caption);
    end;
    //写数据集中的数据
    FDBGrid.DataSource.DataSet.DisableControls;
    FBookMark := FDBGrid.DataSource.DataSet.GetBookmark;
    FDBGrid.DataSource.DataSet.First;
    while not FDBGrid.DataSource.DataSet.Eof do
    begin
      for i := 0 to FDBGrid.FieldCount - 1 do
      begin
        case FDBGrid.Fields[i].DataType of
          ftSmallint, ftInteger, ftWord, ftAutoInc, ftBytes:
            WriteIntegerCell(FDBGrid.Fields[i].AsInteger);
          ftFloat, ftCurrency, ftBCD:
            WriteFloatCell(FDBGrid.Fields[i].AsFloat)
        else
          WriteStringCell(FDBGrid.Fields[i].AsString);
        end;
      end;



      FDBGrid.DataSource.DataSet.Next;
    end;
    //写文件尾
    FFileStream.WriteBuffer(arXlsEnd, SizeOf(arXlsEnd));
    if FDBGrid.DataSource.DataSet.BookmarkValid(FBookMark) then
    begin
      FDBGrid.DataSource.DataSet.GotoBookmark(FBookMark);
    end;
  finally
    FFileStream.Free;
    FDBGrid.DataSource.DataSet.EnableControls;
    FDBGrid := nil;
  end;
end;

{1 增加行列号 }
procedure TExports.incColRow;
var
  FieldCount: Integer;
begin
  if Assigned(FDataSet) then
  begin
    FieldCount := FDataSet.FieldCount - 1;
  end;
  if Assigned(FDBGrid) then
  begin
    FieldCount := FDBGrid.FieldCount - 1;
  end;
  
  if FCol = FieldCount then
  begin
    Inc(FRow);
    FCol := 0;
  end else
  begin
    Inc(FCol);
  end;
end;

procedure TExports.WriteCaption;
begin
  WriteStringCell(FCaption);
  Inc(FRow);
  FCol := 0;
end;

{1 写浮点数 }
procedure TExports.WriteFloatCell(AValue: double);
begin
  arXlsNumber[2] := FRow;
  arXlsNumber[3] := FCol;
  FFileStream.WriteBuffer(arXlsNumber, SizeOf(arXlsNumber));
  FFileStream.WriteBuffer(AValue, 8);
  IncColRow;
end;

{1 写整数 }
procedure TExports.WriteIntegerCell(AValue: integer);
var
  V: Integer;
begin
  arXlsInteger[2] := FRow;
  arXlsInteger[3] := FCol;
  FFileStream.WriteBuffer(arXlsInteger, SizeOf(arXlsInteger));
  V := (AValue shl 2) or 2;
  FFileStream.WriteBuffer(V, 4);
  IncColRow;
end;

{1 写字符串数据 }
procedure TExports.WriteStringCell(AValue: string);
var
  L: Word;
begin
  L := Length(AValue);
  arXlsString[1] := 8 + L;
  arXlsString[2] := FRow;
  arXlsString[3] := FCol;
  arXlsString[5] := L;
  FFileStream.WriteBuffer(arXlsString, SizeOf(arXlsString));
  FFileStream.WriteBuffer(Pointer(AValue)^, L);
  IncColRow;
end;

initialization
  if not Assigned(DataSetExportExcel) then
  begin
    DataSetExportExcel := TExports.Create;
  end;

finalization
  if Assigned(DataSetExportExcel) then
  begin
    DataSetExportExcel.Free;
  end;

end.