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';