diff --git a/components/fpspreadsheet/fpsexport.pas b/components/fpspreadsheet/fpsexport.pas
new file mode 100644
index 000000000..8817914eb
--- /dev/null
+++ b/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.
+
diff --git a/components/fpspreadsheet/tests/dbexporttests.pas b/components/fpspreadsheet/tests/dbexporttests.pas
new file mode 100644
index 000000000..caf7d4d43
--- /dev/null
+++ b/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.
+
diff --git a/components/fpspreadsheet/tests/spreadtestcli.lpi b/components/fpspreadsheet/tests/spreadtestcli.lpi
index 269d51e10..d7c4350d0 100644
--- a/components/fpspreadsheet/tests/spreadtestcli.lpi
+++ b/components/fpspreadsheet/tests/spreadtestcli.lpi
@@ -69,7 +69,7 @@
-
+
@@ -85,6 +85,7 @@
+
@@ -113,17 +114,14 @@
-
-
-
@@ -138,13 +136,16 @@
-
-
+
+
+
+
+
diff --git a/components/fpspreadsheet/tests/spreadtestcli.lpr b/components/fpspreadsheet/tests/spreadtestcli.lpr
index 470885b5a..0fbc18b4b 100644
--- a/components/fpspreadsheet/tests/spreadtestcli.lpr
+++ b/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';