datasettoexcelunt.pas

本程序是在实施用友ERP时根据客户要求专门为用友U8开发的生产标准生产成本的二次开发程序。

UNIT DataSetToExcelUnt;

INTERFACE

USES Classes, SysUtils, DB, DBGrids;

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

{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].FieldName);
    END;
    //写数据集中的数据
    FDataSet.DisableControls;
    FBookMark := FDataSet.GetBookmark;
    FDataSet.First;
    WHILE NOT FDataSet.Eof DO
    BEGIN
      FOR i := 0 TO FDataSet.FieldCount - 1 DO
      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;
      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
  FieldCount := 1;
  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.