+ fpspreadsheet: dbexport unit and tests. Initial version.

Possible future improvements:
* graphical component in export tab
* using virtual mode in case large datasets are exported



git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@3617 8e941d3f-bd1b-0410-a28a-d453659cc2b4

components/fpspreadsheet/fpsexport.pas

@@ -0,0 +1,231 @@
+unit fpsexport;
+
+{ 
+  Exports dataset to spreadsheet/tabular format 
+  either XLS (Excel), XLSX (Excel), ODS (OpenOffice/LibreOffice)
+  or wikitable
+}
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+  Classes, SysUtils, db, fpsallformats, fpspreadsheet, fpdbexport;
+  
+Type
+
+  { TFPSExportFieldItem }
+
+  TFPSExportFieldItem = Class(TExportFieldItem)
+  private
+    FDestField: TField;
+  protected
+    property DestField : TField read FDestField;
+  end;
+
+  { TFPSExportFormatSettings }
+
+  TExportFormat = (efXLS {BIFF8},efXLSX,efODS,efWikiTable);
+  
+  TFPSExportFormatSettings = class(TExportFormatSettings)
+  private
+    FExportFormat: TExportFormat;
+    FHeaderRow: boolean;
+  public
+    procedure Assign(Source : TPersistent); override;
+    procedure InitSettings; override;
+  published
+    // File format for the export
+    property ExportFormat: TExportFormat read FExportFormat write FExportFormat;
+    // Write the field list to the first row of the spreadsheet or not
+    property HeaderRow: boolean read FHeaderRow write FHeaderRow default false;
+  end;
+
+  { TCustomFPSExport }
+  TCustomFPSExport = Class(TCustomDatasetExporter)
+  private
+    FRow: cardinal; //current row in exported spreadsheet
+    FSpreadsheet: TsWorkbook;
+    FSheet: TsWorksheet;
+    FFileName: string;
+    function GetSettings: TFPSExportFormatSettings;
+    procedure SetSettings(const AValue: TFPSExportFormatSettings);
+  protected
+    function CreateFormatSettings: TCustomExportFormatSettings; override;
+
+    function CreateExportFields: TExportFields; override;
+    procedure DoBeforeExecute; override;
+    procedure DoAfterExecute; override;
+    procedure DoDataHeader; override;
+    procedure DoDataRowEnd; override;
+    procedure ExportField(EF : TExportFieldItem); override;
+    property FileName: String read FFileName write FFileName;
+    property Workbook: TsWorkbook read FSpreadsheet;
+  public
+    property FormatSettings: TFPSExportFormatSettings read GetSettings write SetSettings;
+  end;
+
+  TFPSExport = Class(TCustomFPSExport)
+  published
+    property FileName;
+    property Dataset;
+    property ExportFields;
+    property FromCurrent;
+    property RestorePosition;
+    property FormatSettings;
+    property OnExportRow;
+  end;
+  
+procedure RegisterFPSExportFormat;
+procedure UnRegisterFPSExportFormat;
+
+Const
+  SFPSExport = 'xls';
+  SPFSFilter = '*.xls'; //todo: add others?
+  
+ResourceString
+  SErrFailedToDeleteFile = 'Failed to delete existing file: %s';
+  SFPSDescription = 'Spreadsheet files';
+
+implementation
+
+
+{ TCustomFPSExport }
+
+function TCustomFPSExport.GetSettings: TFPSExportFormatSettings;
+begin
+  result:=TFPSExportFormatSettings(Inherited FormatSettings);
+end;
+
+procedure TCustomFPSExport.SetSettings
+  (const AValue: TFPSExportFormatSettings);
+begin
+  Inherited FormatSettings.Assign(AValue);
+end;
+
+function TCustomFPSExport.CreateFormatSettings: TCustomExportFormatSettings;
+begin
+  result:=TFPSExportFormatSettings.Create(True);
+end;
+
+function TCustomFPSExport.CreateExportFields: TExportFields;
+begin
+  result:=TExportFields.Create(TFPSExportFieldItem);
+end;
+
+procedure TCustomFPSExport.DoBeforeExecute;
+begin
+  Inherited;
+  FSpreadsheet:=TsWorkbook.Create;
+  FSheet:=FSpreadsheet.AddWorksheet('1');
+  FRow:=0;
+end;
+
+procedure TCustomFPSExport.DoDataHeader;
+var
+  i: integer;
+begin
+  if FormatSettings.FHeaderRow then
+  begin
+    for i:=0 to ExportFields.Count-1 do
+    begin
+      FSheet.WriteUTF8Text(FRow,i,ExportFields[i].ExportedName);
+    end;
+    inc(FRow);
+  end;
+  inherited DoDataHeader;
+end;
+
+procedure TCustomFPSExport.DoAfterExecute;
+begin
+  FRow:=0;
+  case Formatsettings.ExportFormat of
+    efXLS: FSpreadSheet.WriteToFile(FFileName,sfExcel8);
+    efXLSX: FSpreadsheet.WriteToFile(FFilename,sfOOXML);
+    efODS: FSpreadSheet.WriteToFile(FFileName,sfOpenDocument);
+    efWikiTable: FSpreadSheet.WriteToFile(FFileName,sfWikitable_wikimedia);
+    else
+      ;// raise error?
+  end;
+
+  // Don't free FSheet; done by FSpreadsheet
+  try
+    FreeAndNil(FSpreadsheet);
+  finally
+    Inherited;
+  end;
+end;
+
+procedure TCustomFPSExport.DoDataRowEnd;
+begin
+  FRow:=FRow+1;
+end;
+
+procedure TCustomFPSExport.ExportField(EF: TExportFieldItem);
+var
+  F : TFPSExportFieldItem;
+begin
+  // todo: look into virtual mode in case large exports are used, maybe also
+  // boBufStream
+  F:=EF as TFPSExportFieldItem;
+  with F do
+  begin
+    // Export depending on field datatype;
+    // Fall back to string if unknown datatype
+    If Field.IsNull then
+      FSheet.WriteUTF8Text(FRow,EF.Index,'')
+    else if Field.Datatype in (IntFieldTypes+[ftAutoInc,ftLargeInt]) then
+      FSheet.WriteNumber(FRow,EF.Index,Field.AsInteger)
+    else if Field.Datatype in [ftBCD,ftCurrency,ftFloat,ftFMTBcd] then
+      FSheet.WriteNumber(FRow,EF.Index,Field.AsFloat)
+    else if Field.DataType in [ftString,ftFixedChar] then
+      FSheet.WriteUTF8Text(FRow,EF.Index,Field.AsString)
+    else if (Field.DataType in ([ftWideMemo,ftWideString,ftFixedWideChar]+BlobFieldTypes)) then
+      FSheet.WriteUTF8Text(FRow,EF.Index,UTF8Encode(Field.AsWideString))
+      { Note: we test for the wide text fields before the MemoFieldTypes, in order to
+      let ftWideMemo end up at the right place }
+    else if Field.DataType in MemoFieldTypes then
+      FSheet.WriteUTF8Text(FRow,EF.Index,Field.AsString)
+    else if Field.DataType=ftBoolean then
+      FSheet.WriteBoolValue(FRow,EF.Index,Field.AsBoolean)
+    else if field.DataType in DateFieldTypes then
+      FSheet.WriteDateTime(FRow,EF.Index,Field.AsDateTime)
+    else //fallback to string
+      FSheet.WriteUTF8Text(FRow,EF.Index,Field.AsString);
+  end;
+end;
+
+procedure RegisterFPSExportFormat;
+begin
+  RegisterExportFormat(SFPSExport,SFPSDescription,SPFSFilter,TFPSExport);
+end;
+
+procedure UnRegisterFPSExportFormat;
+begin
+  UnregisterExportFormat(SFPSExport);
+end;
+
+{ TFPSExportFormatSettings }
+
+procedure TFPSExportFormatSettings.Assign(Source: TPersistent);
+var
+  FS : TFPSExportFormatSettings;
+begin
+  If Source is TFPSExportFormatSettings then
+  begin
+    FS:=Source as TFPSExportFormatSettings;
+    HeaderRow:=FS.HeaderRow;
+    ExportFormat:=FS.ExportFormat;
+  end;
+  inherited Assign(Source);
+end;
+
+procedure TFPSExportFormatSettings.InitSettings;
+begin
+  inherited InitSettings;
+  FExportFormat:=efXLS; //often used
+end;
+
+end.
+

components/fpspreadsheet/tests/dbexporttests.pas

@@ -0,0 +1,169 @@
+unit dbexporttests;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+  // Not using Lazarus package as the user may be working with multiple versions
+  // Instead, add .. to unit search path
+  Classes, SysUtils, fpcunit, testutils, testregistry,
+  fpsallformats, fpspreadsheet,
+  testsutility, db, bufdataset, fpsexport;
+
+type
+  TExportTestData=record
+    id: integer;
+    Name: string;
+    DOB: TDateTime;
+  end;
+
+var
+  ExportTestData: array[0..4] of TExportTestData;
+
+procedure InitExportTestData;
+
+type
+{ TSpreadExportTests }
+
+  TSpreadExportTests = class(TTestCase)
+  private
+    FDataset: TBufDataset;
+  protected
+    // Set up expected values:
+    procedure SetUp; override;
+    procedure TearDown; override;
+  published
+    procedure TestExport;
+  end;
+
+implementation
+
+procedure InitExportTestData;
+begin
+  with ExportTestData[0] do
+  begin
+    id:=1;
+    name:='Elvis Wesley';
+    dob:=encodedate(1912,12,31);
+  end;
+
+  with ExportTestData[1] do
+  begin
+    id:=2;
+    name:='Kingsley Dill';
+    dob:=encodedate(1918,11,11);
+  end;
+
+  with ExportTestData[2] do
+  begin
+    id:=3;
+    name:='Joe Snort';
+    dob:=encodedate(1988,8,4);
+  end;
+
+  with ExportTestData[3] do
+  begin
+    id:=4;
+    name:='Hagen Dit';
+    dob:=encodedate(1944,2,24);
+  end;
+
+  with ExportTestData[4] do
+  begin
+    id:=5;
+    name:='';
+    dob:=encodedate(2112,4,12);
+  end;
+end;
+
+{ TSpreadExportTests }
+
+procedure TSpreadExportTests.SetUp;
+var
+  i:integer;
+begin
+  inherited SetUp;
+  InitExportTestData;
+
+  FDataset:=TBufDataset.Create(nil);
+  with FDataset.FieldDefs do
+  begin
+    Add('id',ftAutoinc);
+    Add('name',ftString,40);
+    Add('dob',ftDateTime);
+  end;
+  FDataset.CreateDataset;
+
+  for i:=low(ExportTestData) to high(ExportTestData) do
+  begin
+    FDataset.Append;
+    //autoinc field should be filled by bufdataset
+    FDataSet.Fields.FieldByName('name').AsString:=ExportTestData[i].Name;
+    FDataSet.Fields.FieldByName('dob').AsDateTime:=ExportTestData[i].dob;
+    FDataSet.Post;
+  end;
+end;
+
+procedure TSpreadExportTests.TearDown;
+begin
+  FDataset.Free;
+  inherited TearDown;
+end;
+
+procedure TSpreadExportTests.TestExport;
+var
+  Exp: TFPSExport;
+  ExpSettings: TFPSExportFormatSettings;
+  MyWorksheet: TsWorksheet;
+  MyWorkbook: TsWorkbook;
+  Row: cardinal;
+  TempFile: string;
+  TheDate: TDateTime;
+begin
+  FDataset.First;
+  Exp := TFPSExport.Create(nil);
+  ExpSettings := TFPSExportFormatSettings.Create(true);
+  try
+    ExpSettings.ExportFormat := efXLS;
+    ExpSettings.HeaderRow := true;
+    Exp.FormatSettings := ExpSettings;
+    Exp.Dataset:=FDataset;
+    TempFile := NewTempFile;
+    Exp.FileName := TempFile;
+    CheckEquals(length(ExportTestData),Exp.Execute,'Number of exported records');
+    CheckTrue(FileExists(TempFile),'Export file must exist');
+
+    // Open the workbook for verification
+    MyWorkbook := TsWorkbook.Create;
+    try
+      // Format must match ExpSettings.ExportFormat above
+      MyWorkbook.ReadFromFile(TempFile, sfExcel8);
+      MyWorksheet := MyWorkbook.GetFirstWorksheet;
+      // ignore header row for now
+      for Row := 1 to length(ExportTestData) do
+      begin
+        // cell 0 is id
+        CheckEquals(ExportTestData[Row-1].id,MyWorkSheet.ReadAsNumber(Row,0),'Cell data: id');
+        CheckEquals(ExportTestData[Row-1].name,MyWorkSheet.ReadAsUTF8Text(Row,1),'Cell data: name');
+        MyWorkSheet.ReadAsDateTime(Row,2,TheDate);
+        CheckEquals(ExportTestData[Row-1].dob,TheDate,'Cell data: dob');
+      end;
+    finally
+      MyWorkBook.Free;
+    end;
+  finally
+    Exp.Free;
+    ExpSettings.Free;
+    DeleteFile(TempFile);
+  end;
+end;
+
+initialization
+  // Register so these tests are included in a full run
+  RegisterTest(TSpreadExportTests);
+  InitExportTestData; //useful to have norm data if other code want to use this unit
+end.
+
+end.
+

components/fpspreadsheet/tests/spreadtestcli.lpi

@@ -69,7 +69,7 @@
         <PackageName Value="LCLBase"/>
       </Item1>
     </RequiredPackages>
-    <Units Count="17">
+    <Units Count="18">
       <Unit0>
         <Filename Value="spreadtestcli.lpr"/>
         <IsPartOfProject Value="True"/>
@@ -85,6 +85,7 @@
       <Unit3>
         <Filename Value="testsutility.pas"/>
         <IsPartOfProject Value="True"/>
+        <UnitName Value="testsutility"/>
       </Unit3>
       <Unit4>
         <Filename Value="manualtests.pas"/>
@@ -113,17 +114,14 @@
       <Unit10>
         <Filename Value="errortests.pas"/>
         <IsPartOfProject Value="True"/>
-        <UnitName Value="errortests"/>
       </Unit10>
       <Unit11>
         <Filename Value="numberstests.pas"/>
         <IsPartOfProject Value="True"/>
-        <UnitName Value="numberstests"/>
       </Unit11>
       <Unit12>
         <Filename Value="fonttests.pas"/>
         <IsPartOfProject Value="True"/>
-        <UnitName Value="fonttests"/>
       </Unit12>
       <Unit13>
         <Filename Value="formulatests.pas"/>
@@ -138,13 +136,16 @@
       <Unit15>
         <Filename Value="optiontests.pas"/>
         <IsPartOfProject Value="True"/>
-        <UnitName Value="optiontests"/>
       </Unit15>
       <Unit16>
         <Filename Value="virtualmodetests.pas"/>
         <IsPartOfProject Value="True"/>
-        <UnitName Value="virtualmodetests"/>
       </Unit16>
+      <Unit17>
+        <Filename Value="dbexporttests.pas"/>
+        <IsPartOfProject Value="True"/>
+        <UnitName Value="dbexporttests"/>
+      </Unit17>
     </Units>
   </ProjectOptions>
   <CompilerOptions>

components/fpspreadsheet/tests/spreadtestcli.lpr

@@ -14,7 +14,7 @@ uses
   datetests, manualtests, stringtests, internaltests, testsutility, testutils,
   formattests, colortests, emptycelltests, insertdeletetests,
   errortests, numberstests, fonttests, formulatests, numformatparsertests,
-  optiontests, virtualmodetests;
+  optiontests, virtualmodetests, dbexporttests;
 
 const
   ShortOpts = 'ac:dhlpr:x';