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

[mkinzler]

Vielleicht sollte man das Demoprogramm noch etwas allgemeiner gestalten. Nicht Jeder arbeitet mit FIBPlus.

[Chemiker]

Hallo mkinzler;

habe den Demo-Aufruf ergänzt.

Bis bald Chemiker

[khh]

ich danke euch

[kamel08]

Hallo Chemiker;

toller Beitrag, danke.
Ich habe das Problem bisher anders, aber mit mehr Aufwand gelöst
und möchte nun gerne Deinen Code nutzen,
der eigentlich auch einwandfrei funktioniert.
Beim Testen trat aber ein rätselhafter Fehler auf:
Wenn ich mir mit 'ShowMessage(xls.XLSDateiName)' den Dateinamen anzeigen lassen möchte,
hängt sich die IDE auf.
Woran liegt das

Delphi-Quellcode:

procedure TForm1.VergleichsmusterExportButtonClick(Sender: TObject);
var XLS: TXLS_DateiClass;
begin
     XLS:= TXLS_DateiClass.Create;
     try
        xls.XLSDateiName:= 'Musternahme.XLS';
        XLS.XLSDataSet:= Musternahme; // Musternahme ist ein TClientDataSet
        XLS.XLS_DateiErstellen;
        Musternahme.First;
     finally
        ShowMessage(xls.XLSDateiName); // << Hier entsteht der Fehler, Delphi hängt sich auf 
        XLS.Free;
     end;
end;

[himitsu]

Eigentlich sollte es an dieser Stelle keine Probleme geben.

Sicher daß das ShowMessage nicht selber ein Problem hat oder daß der Fehler an anderer Stelle seine Ursache hat?
Übergib da mal testweise einen String oder direkt einen Text/Konstante an diese Prozedur.
Und passiert dieses Hängenbleiben auch außerhalb der IDE, bzw. ohne Debugger?

Außerdem gehört sowas noch vor das Finally und nicht da rein ... falls, wie hier zu sehen, darin ein Problem auftritt.


Und dann noch was an den Chemiker:

Delphi-Quellcode:

procedure getFXLSDateiName(const Value: TFileName);
function setFXLSDateiName: TFileName;
procedure getFXLSDataSet(const Value: TDataSet);
function setFXLSDataSet: TDataSet;

Die Bezeichnungen der Getter und Setter sind vertauscht, bzw. falsch benannt ... ich dachte erst ich versteh nichts mehr, als ich mir den Getter vom Dateinamen ansehn wollte.

[kamel08]

Hallo Himitsu;
danke für die schnelle Antwort.

Ich hab' den Code nochmals etwas abgeändert:

Delphi-Quellcode:

Procedure TForm1.SaveCDS2XLS(CDS:TClientDataSet);
var XLS: TXLS_DateiClass;
var s:String;
begin
     SaveDialog1.DefaultExt := 'xls';
     SaveDialog1.FileName := '*.xls';
     SaveDialog1.Filter := 'Microsoft Office Excel-Datei(*.xls)|*.xls';
     SaveDialog1.Title := 'Microsoft Office Excel-Datei (*.xls) speichern';
     SaveDialog1.HistoryList.Clear;
     If SaveDialog1.Execute then
     begin
          s := SaveDialog1.FileName;
          XLS:= TXLS_DateiClass.Create;
          try
             xls.XLSDateiName:= s;
             // ShowMessage ist aus Dialogs
             ShowMessage(xls.XLSDateiName); // << funktioniert nicht
             //ShowMessage(s); // << funktioniert
             XLS.XLSDataSet:= CDS;
             XLS.XLS_DateiErstellen;
             CDS.First;
          finally
             XLS.Free;
          end;
end;
end;

Und passiert dieses Hängenbleiben auch außerhalb der IDE, bzw. ohne Debugger?

JA! Auch außerhalb der IDE stürzt das Programm ab,
und...mir fiel ebenfalls auf, dass set und get vertauscht sind,
vielleicht besteht darin das Problem, denn der lesezugriff ruft folglich nicht get sondern set-oder?

muss weg, komme später wieder rein cu

Gruß
kamel

[himitsu]

Nee, da nur die Bezeichner vertauscht sind, aber nicht die Funktion, kann dadurch erstmal kein Fehler entstehen.
(nach dem Kompilieren sind diese Bezeichner sowieso weg)

.XLSDateiName ist nur eine Umleitung auf .FXLSDateiName,
womit also nur das Feld beschrieben und wieder ausgelesen wird.

Zitat:

Delphi-Quellcode:

xls.XLSDateiName := 'Musternahme.XLS';
...
ShowMessage(xls.XLSDateiName):

im Prinzip entspricht das also Diesem:

Delphi-Quellcode:

S := 'Musternahme.XLS';
...
ShowMessage(S);

Einzige Möglichkeit da einen Fehler zu verursachen wäre die Variable xls, das darin enthaltene Objekt (TXLS_DateiClass) oder die Stringdaten von FXLSDateiName zu zerstören.
> z.B. durch einen Bufferoverrun oder eine "verlaufene" Schreiboperation, zwischen diesen beiden Befehlen.

[Chemiker]

Hallo himitsu,

Zitat:

Die Bezeichnungen der Getter und Setter sind vertauscht, bzw. falsch benannt ... ich dachte erst ich versteh nichts mehr, als ich mir den Getter vom Dateinamen ansehn wollte.

*Oops* das ist mir überhaupt nicht aufgefallen. Habe jetzt mal nachgesehen, dass liegt an den selbstgeschrieben property-Template. Das wird aber jetzt in vielen Klassen stehen und jedes Mal überlesen. MIST!

Es sollte aber kein Zusammenhang mit dem Fehler von kamel08 bestehen.

Ich werde mal die ältere Version zusammenkopieren für BDS 2006), diese ist tagtäglich seit einigen Jahren im Einsatz und hat bisher keine Fehler produziert.

Bis bald Chemiker

[kamel08]

Vielen Dank nochmals für Eure Antworten.
Ihr seid echt gut und von Euch kann man viel lernen.

Hier bin ich wieder - mit der Lösung:

Delphi-Quellcode:

function TXLS_DateiClass.getFXLSDateiName: TFileName;
begin
//  Result:= XLSDateiName;
  Result:= FXLSDateiName; // so muß es sein ;-)
end;

schönen Tag noch