Dataset-Daten als XLS-Datei ohne Excel abspeichern

[Chemiker]

Hallo,

mit dieser Unit werden die Daten von DataSet in ein XLS-File gespeichert, ohne Excel aufzurufen. Die Daten werden als Text abgespeichert, ohne Formatierung.

Delphi-Quellcode:

unit uXLSExcelDateiClass;
{
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Unit:       uXLSExcelDateiClass
letz.Ändr.: 01.05.2009
Version:    1.00 // abgespeckte Version für die DP
Funktion:   Die Daten von TDataSet werden in einer Excel-Datei (.XLS) ab-
            gespeichert. 
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
}
interface

uses
  Classes, SysUtils, DB, Variants, Messages, Dialogs; 

const
   XLS_WORKSSHEET= $10;
   XLS_BOF       = $809;
   XLS_BIFFVER   = $600; 
   XLS_LABEL     = $204;
   XLS_EOF       = $A0;
   XLS_EXCEL_VERSION = 1;          
  
type  
  TXLS_BOFRec= packed record     // Start des Datenblockes 
    RecCode: Word;               // $809 BOF 
    RecLaenge: Word;             // Record Länge  // Komplett 16/ normal 8 
    BIFFVersion: Word;           // $ 600 BiffVersions-Nummer:8 
    Bereich: Word;               // $10 = Workssheet 
    ExcelVersion: Word;          // muss nicht angegeben werden 2719=Excel 2000 
    ExcelDatum: Word;            // muss nicht angegeben werden 
  end; 

  TXLS_LABELRec= packed record    // String-Record von Excel 
    RecCode: Word;                // $204 Bei Biff 8 
    RecLaenge: Word;              // Record Länge // muss zuvor berechnet werden 
    Row: Word;                    // Zeilen-Nr. beginnt bei 0 
    Col: Word;                    // Spalten-Nr. beginnt bei 0 
    IndexXFRec: Word;             // noch nicht ganz verstanden // erstmal=0 
    ZellenStLeange: Word;         // Nur die ZellenString-Länge 
  end; 

  TXLS_EOFRec= packed record      // Ende des Datenblockes 
    RecCode: Word;                // $A0 
    RecLaenge: Word;              // 00  hat immer die Länge = 0 
  end;

type
  TXLS_DateiClass= Class(TObject)
  private
    FXLSDateiName: TFileName; 
    FXLSDataSet: TDataSet;        
    FBOF: TXLS_BOFRec;
    FEOF: TXLS_EOFRec;
    FLABEL: TXLS_LABELRec;    
    procedure XLS_BOFRecDatenFuellen; 
    procedure XLS_EOFRecDatenFuellen;  
    procedure XLS_LABELRecDatenFuellen(const Zeile, Spalte: Word;
                                       aWert: String);                                                
    procedure getFXLSDateiName(const Value: TFileName);
    function setFXLSDateiName: TFileName;
    procedure getFXLSDataSet(const Value: TDataSet);
    function setFXLSDataSet: TDataSet;          
  public
    Constructor Create();
    destructor Destroy; override;
    property XLSDateiName: TFileName read setFXLSDateiName
                                          write getFXLSDateiName; 
    property XLSDataSet: TDataSet read setFXLSDataSet write getFXLSDataSet;
    procedure XLS_DateiErstellen;                                        
  End;  
  
implementation

{ XLS_DateiClass }

constructor TXLS_DateiClass.Create();
begin
  inherited Create;
  XLS_BOFRecDatenFuellen;  // XLS-Datei Anfang schreiben
  XLS_EOFRecDatenFuellen;  // XLS-Datein Ende schreiben
end;

destructor TXLS_DateiClass.Destroy;
begin
  inherited Destroy;
end;

procedure TXLS_DateiClass.getFXLSDataSet(const Value: TDataSet);
begin
  if Value<>FXLSDataSet then
  begin
    FXLSDataSet:= Value;
  end;
end;

procedure TXLS_DateiClass.getFXLSDateiName(const Value: TFileName);
begin
  if Value<> FXLSDateiName then
  begin
    FXLSDateiName:= Value;
  end;
end;

function TXLS_DateiClass.setFXLSDataSet: TDataSet;
begin
  result:= FXLSDataSet;
end;

function TXLS_DateiClass.setFXLSDateiName: TFileName;
begin
  Result:= XLSDateiName;
end;

procedure TXLS_DateiClass.XLS_BOFRecDatenFuellen;
begin
  with FBOF do 
  begin 
    RecCode:= XLS_BOF ; 
    RecLaenge:= 8; 
    BIFFVersion:= 1;   // Kann auch 1 sein // später XLS_BIFFVER   = $600; 
    Bereich:= XLS_WORKSSHEET; 
    ExcelVersion:= 1; 
    ExcelDatum:= 0; 
  end; 
end;

procedure TXLS_DateiClass.XLS_DateiErstellen;
var
  XLSFileStream: TFileStream;
  I, x: Integer;
  TempStr: String;
begin
  if ((not (FXLSDateiName = '')) and (not (FXLSDataSet = NIL)))then
  begin
    XLSFileStream:= TFileStream.Create(FXLSDateiName, fmCreate);
    try
      // XLS-File Anfang schreiben
      XLSFileStream.WriteBuffer(FBOF, sizeOf(FBOF));
      // Feldernamen setzen
      for I := 0 to FXLSDataSet.FieldCount-1 do
      begin
        TempStr:= VarToStr(FXLSDataSet.Fields[i].FieldName);
        XLS_LABELRecDatenFuellen(0, i, TempStr);   
        XLSFileStream.WriteBuffer(FLABEL, sizeOf(FLABEL)); 
        XLSFileStream.WriteBuffer(TempStr[1], Length(TempStr));
      end;
      // Daten in XLS-File schreiben
      x:= 1;
      while not FXLSDataSet.EOF do
      begin
        for I := 0 to FXLSDataSet.FieldCount-1 do
        begin
          TempStr:= VarToStr(FXLSDataSet.Fields[i].Value); 
          XLS_LABELRecDatenFuellen(x, i, TempStr);   
          XLSFileStream.WriteBuffer(FLABEL, sizeOf(FLABEL)); 
          XLSFileStream.WriteBuffer(TempStr[1], Length(TempStr));
        end;
        inc(x);
        FXLSDataSet.Next;   
      end;         
      // XLS-File Ende schreiben
      XLSFileStream.WriteBuffer(FEOF, sizeOf(FEOF)); 
    finally
      XLSFileStream.Free;
    end;
  end else
  begin
    ShowMessage('Fehlende Angaben bei der XLS-File Erstellung!');
  end;
end;

procedure TXLS_DateiClass.XLS_EOFRecDatenFuellen;
begin 
  with FEOF do 
  begin 
    RecCode:= $A; 
    RecLaenge:= 0; 
  end;
end; 

procedure TXLS_DateiClass.XLS_LABELRecDatenFuellen(const Zeile, Spalte: Word;
  aWert: String);
begin
  with FLABEL do
  begin
    RecCode:= XLS_LABEL;
    RecLaenge:= 8 + Length(aWert); 
    Row:= Zeile; 
    Col:= Spalte; 
    IndexXFRec:= 0; 
    ZellenStLeange:= Length(aWert);           // Länge vom String eintragen 
  end; 
end;

end.

Demo-Procedure:

Delphi-Quellcode:

procedure TfrmFIBPlusDemo.Button1Click(Sender: TObject);
var 
  XLS: TXLS_DateiClass;
begin
  pFIBDataSet1.Close;
  pFIBDataSet1.SelectSQL.Text:= Memo1.Text;
  pFIBDataSet1.GenerateSQLs;
  pFIBDataSet1.Open;
  XLS:= TXLS_DateiClass.Create;
  try
    XLS.XLSDateiName:= 'D:\Eigene Dateien von Internet\DB1.XLS';
    XLS.XLSDataSet:= pFIBDataSet1;
    XLS.XLS_DateiErstellen
  finally
    XLS.Free;
  end;
end;

**********EDIT*****************

in der Class: TXLS_DateiClass wird mit TDataSet gearbeitet. Es sollten also alle DataSets funktionieren. Das gleiche gilt für TClientDataSet.

Delphi-Quellcode:

type
  TDM = class(TDataModule)
    KundeClientDataSet: TClientDataSet;
    BestellungClientDataSet: TClientDataSet;
    ......
    ......
  end;

var
  DM: TDM;

Delphi-Quellcode:

procedure TfrmHauptFormular.btExcelExportClick(Sender: TObject);
var
  XLS: TXLS_DateiClass;
begin
  XLS:= TXLS_DateiClass.Create;
  try
    xls.XLSDateiName:= 'D:\Eigene Dateien von Internet\KUNDEDB1.XLS';
    XLS.XLSDataSet:= DM.KundeClientDataSet;  // 
    XLS.XLS_DateiErstellen;
    DM.KundeClientDataSet.First; 
  finally
    XLS.Free;
  end;
end;

Bis bald Chemiker