fpspreadsheet: Extend fpsExport to allow export of several dataset to multiple worksheets. Update db_import_export demo.

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

components/fpspreadsheet/examples/db_import_export/main.lfm

@@ -14,19 +14,19 @@ object Form1: TForm1
     Height = 302
     Top = 4
     Width = 631
-    ActivePage = TabDataGenerator
+    ActivePage = TabExport
     Align = alClient
     BorderSpacing.Around = 4
-    TabIndex = 0
+    TabIndex = 1
     TabOrder = 0
     OnChange = PageControlChange
     object TabDataGenerator: TTabSheet
       Caption = '1 - Create database'
-      ClientHeight = 276
+      ClientHeight = 269
       ClientWidth = 623
       object Label2: TLabel
         Left = 4
-        Height = 13
+        Height = 20
         Top = 4
         Width = 615
         Align = alTop
@@ -38,25 +38,25 @@ object Form1: TForm1
       end
       object Panel1: TPanel
         Left = 0
-        Height = 255
+        Height = 241
-        Top = 21
+        Top = 28
         Width = 623
         Align = alClient
         BevelOuter = bvNone
-        ClientHeight = 255
+        ClientHeight = 241
         ClientWidth = 623
         TabOrder = 0
         object HeaderLabel1: TLabel
           Left = 8
-          Height = 13
+          Height = 20
           Top = 11
-          Width = 64
+          Width = 88
           Caption = 'Record count'
           ParentColor = False
         end
         object EdRecordCount: TEdit
           Left = 107
-          Height = 21
+          Height = 28
           Top = 8
           Width = 64
           Alignment = taRightJustify
@@ -66,7 +66,7 @@ object Form1: TForm1
         object BtnCreateDbf: TButton
           Left = 515
           Height = 28
-          Top = 222
+          Top = 208
           Width = 99
           Anchors = [akRight, akBottom]
           Caption = 'Run'
@@ -83,8 +83,8 @@ object Form1: TForm1
         end
         object InfoLabel1: TLabel
           Left = 8
-          Height = 13
+          Height = 20
-          Top = 237
+          Top = 216
           Width = 496
           Anchors = [akLeft, akRight, akBottom]
           BorderSpacing.Around = 4
@@ -93,9 +93,9 @@ object Form1: TForm1
         end
         object Label1: TLabel
           Left = 8
-          Height = 13
+          Height = 20
           Top = 40
-          Width = 304
+          Width = 409
           Caption = 'Please note: the binary xls files can handle only 65536 records.'
           ParentColor = False
         end
@@ -103,11 +103,11 @@ object Form1: TForm1
     end
     object TabExport: TTabSheet
       Caption = '2 - Export to spreadsheet'
-      ClientHeight = 276
+      ClientHeight = 269
       ClientWidth = 623
       object HeaderLabel2: TLabel
         Left = 4
-        Height = 13
+        Height = 20
         Top = 4
         Width = 615
         Align = alTop
@@ -120,15 +120,15 @@ object Form1: TForm1
       object Bevel2: TBevel
         Left = 0
         Height = 3
-        Top = 21
+        Top = 28
         Width = 623
         Align = alTop
         Shape = bsTopLine
       end
       object InfoLabel2: TLabel
         Left = 8
-        Height = 13
+        Height = 20
-        Top = 258
+        Top = 244
         Width = 504
         Anchors = [akLeft, akRight, akBottom]
         BorderSpacing.Around = 4
@@ -149,7 +149,7 @@ object Form1: TForm1
         ChildSizing.ShrinkVertical = crsScaleChilds
         ChildSizing.Layout = cclLeftToRightThenTopToBottom
         ChildSizing.ControlsPerLine = 1
-        ClientHeight = 140
+        ClientHeight = 133
         ClientWidth = 228
         ItemIndex = 2
         Items.Strings = (
@@ -164,7 +164,7 @@ object Form1: TForm1
       object BtnExport: TButton
         Left = 515
         Height = 28
-        Top = 243
+        Top = 236
         Width = 99
         Anchors = [akRight, akBottom]
         Caption = 'Run'
@@ -185,12 +185,13 @@ object Form1: TForm1
         ChildSizing.ShrinkVertical = crsScaleChilds
         ChildSizing.Layout = cclLeftToRightThenTopToBottom
         ChildSizing.ControlsPerLine = 1
-        ClientHeight = 140
+        ClientHeight = 133
         ClientWidth = 228
         ItemIndex = 0
         Items.Strings = (
           'Virtual mode (memory saving)'
           'FPSExport'
+          'FPSExport (multiple sheets)'
         )
         TabOrder = 2
       end

components/fpspreadsheet/examples/db_import_export/main.pas

@@ -56,11 +56,14 @@ type
     // Actual export code when using FPSpreadsheet's fpsexport:
     // reads dbf and writes to spreadsheet
     // Expects FExportDataset to be available
-    procedure ExportUsingFPSExport(var DataFileName: string);
+    procedure ExportUsingFPSExport(MultipleSheets: Boolean; var DataFileName: string);
     // Actual export code when using virtual mode:
     // reads dbf and writes to spreadsheet
     // Expects FExportDataset to be available
     procedure ExportUsingVirtualMode(var DataFileName: string);
+    // FPSExport: Get sheet name
+    procedure ExporterGetSheetNameHandler(Sender: TObject; ASheetIndex: Integer;
+      var ASheetName: String);
     // Virtual mode: for reading: all data for the database is generated here out of the spreadsheet file
     procedure ReadCellDataHandler(Sender: TObject; ARow, ACol: Cardinal;
       const ADataCell: PCell);
@@ -81,8 +84,11 @@ implementation
 type
   // Ways to export dbf/dataset. Corresponds to the items
   // of the RgExportMode radiogroup
-  TsExportModes=(seVirtual {manual coding using Virtual Mode},
+  TsExportModes=(
-    seFPSExport {uses FpSpreadsheet's fpsexport - takes more memory});
+    seVirtual,       {manual coding using Virtual Mode}
+    seFPSExport,     {uses FpSpreadsheet's fpsexport - takes more memory}
+    seFPSExportMulti {uses FpSpreadsheetÄs fpsexport to multiple sheets}
+  );
 
 const
   // Parameters for generating dbf file contents
@@ -197,8 +203,12 @@ begin
   try
     InfoLabel1.Caption := ('Starting database export.');
     case TsExportModes(RgExportMode.ItemIndex) of
-      seVirtual: ExportUsingVirtualMode(DataFileName);
+      seVirtual:
-      seFPSExport: ExportUsingFPSExport(DataFileName);
+        ExportUsingVirtualMode(DataFileName);
+      seFPSExport:
+        ExportUsingFPSExport(false, DataFileName);
+      seFPSExportMulti:
+        ExportUsingFPSExport(true, DataFileName);
       else
       begin
         ShowMessageFmt('Unknown export mode number %d. Please correct source code.',[RgExportMode.ItemIndex]);
@@ -298,7 +308,8 @@ begin
   end;
 end;
 
-procedure TForm1.ExportUsingFPSExport(var DataFileName: string);
+procedure TForm1.ExportUsingFPSExport(MultipleSheets: Boolean;
+  var DataFileName: string);
 var
   Exporter: TFPSExport;
   ExportSettings: TFPSExportFormatSettings;
@@ -315,18 +326,21 @@ begin
     ExportSettings.HeaderRow := true;
     case FILE_FORMATS[RgFileFormat.ItemIndex] of
       sfExcel2, sfExcel5:
-      begin
+        begin
-        ShowMessage('Format not supported using this mode.');
+          ShowMessage('Format not supported using this mode.');
-        exit;
+          exit;
-      end;
+        end;
-      sfExcel8: ExportSettings.ExportFormat := efXLS;
+      sfExcel8:
-      sfOOXML: ExportSettings.ExportFormat := efXLSX;
+        ExportSettings.ExportFormat := efXLS;
-      sfOpenDocument: ExportSettings.ExportFormat := efODS;
+      sfOOXML:
+        ExportSettings.ExportFormat := efXLSX;
+      sfOpenDocument:
+        ExportSettings.ExportFormat := efODS;
       else
-      begin
+        begin
-        ShowMessage('Unknown export format. Please correct the source code.');
+          ShowMessage('Unknown export format. Please correct the source code.');
-        exit;
+          exit;
-      end;
+        end;
     end;
     // Actually apply settings
     Exporter.FormatSettings := ExportSettings;
@@ -335,7 +349,32 @@ begin
     Exporter.Dataset := FExportDataset;
     Exporter.FileName := ChangeFileExt(DataFileName, FILE_EXT[
       RgFileFormat.ItemIndex]);
-    Exporter.Execute;
+
+    // Export to multiple sheets
+    if MultipleSheets then
+    begin
+      Exporter.MultipleSheets := true;
+      Exporter.OnGetSheetName := @ExporterGetSheetNameHandler;
+
+      // On the first sheet we want "Last name", "First name" and "City"
+      Exporter.ExportFields.AddField('Last name');
+      Exporter.ExportFields.AddField('First name');
+      Exporter.ExportFields.AddField('City');
+      Exporter.Execute;
+
+      // On the second sheet we want "Last name", "First name" and "Birthday"
+      Exporter.ExportFields.Clear;
+      Exporter.ExportFields.AddField('Last name');
+      Exporter.ExportFields.AddField('First name');
+      Exporter.ExportFields.AddField('Birthday');
+      Exporter.Execute;
+
+      // Export complete --> we can write to file
+      Exporter.WriteExportFile;
+    end
+    // Export of all records to single sheet
+    else
+      Exporter.Execute;
   finally
     Exporter.Free;
     ExportSettings.Free;
@@ -441,6 +480,16 @@ begin
   end;
 end;
 
+{ Determines the sheet name of the export using FPExport }
+procedure TForm1.ExporterGetSheetNameHandler(Sender: TObject; ASheetIndex: Integer;
+  var ASheetName: String);
+begin
+  case ASheetIndex of
+    0: ASheetName := 'Cities';
+    1: ASheetName := 'Birthdays';
+  end;
+end;
+
 { This is the event handler for reading a spreadsheet file in virtual mode.
   ADataCell has just been read from the spreadsheet file, but will not be added
   to the workbook and will be discarded. The event handler, however, can pick

components/fpspreadsheet/fpsexport.pas

@@ -11,7 +11,8 @@ unit fpsexport;
 interface
 
 uses
-  Classes, SysUtils, db, fpsallformats, fpspreadsheet, fpsstrings, fpdbexport;
+  Classes, SysUtils, db,
+  {%H-}fpsallformats, fpspreadsheet, fpsstrings, fpdbexport;
   
 Type
 
@@ -32,17 +33,24 @@ Type
   private
     FExportFormat: TExportFormat;
     FHeaderRow: boolean;
+    FSheetName: String;
   public
     procedure Assign(Source : TPersistent); override;
     procedure InitSettings; override;
   published
     {@@ File format for the export }
     property ExportFormat: TExportFormat read FExportFormat write FExportFormat;
-    {@@ Flag that determines whethe to write the field list to the first
+    {@@ Flag that determines whether to write the field list to the first
         row of the spreadsheet }
     property HeaderRow: boolean read FHeaderRow write FHeaderRow default false;
+    {@@ Sheet name }
+    property SheetName: String read FSheetName write FSheetName;
   end;
 
+  { TGetSheetNameEvent }
+  TsGetSheetNameEvent = procedure (Sender: TObject; ASheetIndex: Integer;
+    var ASheetName: String) of object;
+
   { TCustomFPSExport }
   TCustomFPSExport = Class(TCustomDatasetExporter)
   private
@@ -50,23 +58,36 @@ Type
     FSpreadsheet: TsWorkbook;
     FSheet: TsWorksheet;
     FFileName: string;
+    FMultipleSheets: Boolean;
+    FOnGetSheetName: TsGetSheetNameEvent;
+    function CalcSheetNameMask(const AMask: String): String;
+    function CalcUniqueSheetName(const AMask: String): String;
     function GetSettings: TFPSExportFormatSettings;
+    procedure SaveWorkbook;
     procedure SetSettings(const AValue: TFPSExportFormatSettings);
   protected
-    function CreateFormatSettings: TCustomExportFormatSettings; override;
-
     function CreateExportFields: TExportFields; override;
+    function CreateFormatSettings: TCustomExportFormatSettings; override;
     procedure DoBeforeExecute; override;
     procedure DoAfterExecute; override;
     procedure DoDataHeader; override;
     procedure DoDataRowEnd; override;
+    function  DoGetSheetName: String; virtual;
     procedure ExportField(EF : TExportFieldItem); override;
     property FileName: String read FFileName write FFileName;
     property Workbook: TsWorkbook read FSpreadsheet;
+    property RestorePosition default true;
+    property OnGetSheetName: TsGetSheetNameEvent read FOnGetSheetName write FOnGetSheetName;
   public
+    constructor Create(AOwner: TComponent); override;
+    destructor Destroy; override;
+    procedure WriteExportFile;
     {@@ Settings for the export. Note: a lot of generic settings are preent
         that are not relevant for this export, e.g. decimal point settings }
     property FormatSettings: TFPSExportFormatSettings read GetSettings write SetSettings;
+    {@@ MultipleSheets: export several datasets to multiple sheets in
+        the sasme file. Otherwise a single-sheet workbook is created. }
+    property MultipleSheets: Boolean read FMultipleSheets write FMultipleSheets default false;
   end;
 
   { TFPSExport }
@@ -87,6 +108,8 @@ Type
     property RestorePosition;
     {@@ Procedure to run when exporting a row }
     property OnExportRow;
+    {@@ Determines the name of the worksheet }
+    property OnGetSheetName;
   end;
 
 {@@ Register export format with fpsdbexport so it can be dynamically used }
@@ -103,6 +126,24 @@ implementation
 
 { TCustomFPSExport }
 
+constructor TCustomFPSExport.Create(AOwner: TComponent);
+begin
+  inherited Create(AOwner);
+  RestorePosition := true;
+end;
+
+destructor TCustomFPSExport.Destroy;
+begin
+  // Last chance to save file if calling WriteExportFile has been forgottem
+  // in case of multiple sheets.
+  if FMultipleSheets and (FSpreadsheet <> nil) then
+  begin
+    SaveWorkbook;
+    FreeAndNil(FSpreadsheet);
+  end;
+  inherited;
+end;
+
 function TCustomFPSExport.GetSettings: TFPSExportFormatSettings;
 begin
   result:=TFPSExportFormatSettings(Inherited FormatSettings);
@@ -129,11 +170,17 @@ begin
   Inherited;
   if FFileName='' then
     Raise EDataExporter.Create(rsExportFileIsRequired);
-  FSpreadsheet:=TsWorkbook.Create;
+  if (not RestorePosition) and FMultipleSheets then
-  // For extra performance. Note that virtual mode is not an option
+    Raise EDataExporter.Create(rsMultipleSheetsOnlyWithRestorePosition);
-  // due to the data export determining flow of the program.
+
-  FSpreadsheet.Options:=FSpreadsheet.Options+[boBufStream];
+  if (not FMultipleSheets) or (FSpreadsheet = nil) then
-  FSheet:=FSpreadsheet.AddWorksheet('1');
+  begin
+    FSpreadsheet:=TsWorkbook.Create;
+    FSpreadsheet.Options:=FSpreadsheet.Options+[boBufStream];
+    // For extra performance. Note that virtual mode is not an option
+    // due to the data export determining flow of the program.
+  end;
+  FSheet:=FSpreadsheet.AddWorksheet(DoGetSheetName);
   FRow:=0;
 end;
 
@@ -152,25 +199,34 @@ begin
   inherited DoDataHeader;
 end;
 
-procedure TCustomFPSExport.DoAfterExecute;
+{ Writes the workbook populated during the export process to file }
+procedure TCustomFPSExport.SaveWorkbook;
 begin
   FRow:=0;
   // Overwrite existing file similar to how dbf export does it
   case Formatsettings.ExportFormat of
-    efXLS: FSpreadSheet.WriteToFile(FFileName,sfExcel8,true);
+    efXLS:
-    efXLSX: FSpreadsheet.WriteToFile(FFilename,sfOOXML,true);
+      FSpreadSheet.WriteToFile(FFileName,sfExcel8,true);
-    efODS: FSpreadSheet.WriteToFile(FFileName,sfOpenDocument,true);
+    efXLSX:
-    efWikiTable: FSpreadSheet.WriteToFile(FFileName,sfWikitable_wikimedia,true);
+      FSpreadsheet.WriteToFile(FFilename,sfOOXML,true);
+    efODS:
+      FSpreadSheet.WriteToFile(FFileName,sfOpenDocument,true);
+    efWikiTable:
+      FSpreadSheet.WriteToFile(FFileName,sfWikitable_wikimedia,true);
     else
-      ;// raise error?
+      raise Exception.Create('[TCustomFPSExport.SaveWorkbook] ExportFormat unknown');
   end;
+end;
 
-  // Don't free FSheet; done by FSpreadsheet
+procedure TCustomFPSExport.DoAfterExecute;
-  try
+begin
-    FreeAndNil(FSpreadsheet);
+  if not FMultipleSheets then
-  finally
+  begin
-    Inherited;
+    SaveWorkbook;
+    FreeAndNil(FSpreadsheet);  // Don't free FSheet; done by FSpreadsheet
   end;
+  // Multi-sheet workbooks are written when WriteExportFile is called.
+  inherited;
 end;
 
 procedure TCustomFPSExport.DoDataRowEnd;
@@ -178,6 +234,59 @@ begin
   FRow:=FRow+1;
 end;
 
+function TCustomFPSExport.CalcSheetNameMask(const AMask: String): String;
+begin
+  Result := AMask;
+  // No %d in the mask string
+  if pos('%d', Result) = 0 then
+  begin
+    // If the mask string is already used we'll add a number to the sheet name
+    if not FSpreadsheet.ValidWorksheetName(Result) then
+    begin
+      Result := AMask + '%d';
+      exit;
+    end;
+  end;
+end;
+
+function TCustomFPSExport.CalcUniqueSheetName(const AMask: String): String;
+var
+  i: Integer;
+begin
+  if pos('%d', AMask) > 0 then
+  begin
+    i := 0;
+    repeat
+      inc(i);
+      Result := Format(AMask, [i]);
+    until (FSpreadsheet.GetWorksheetByName(Result) = nil);
+  end else
+    Result := AMask;
+  if not FSpreadsheet.ValidWorksheetName(Result) then
+    Raise EDataExporter.CreateFmt(rsInvalidWorksheetName, [Result]);
+end;
+
+{ Method which provides the name of the worksheet into which the dataset is to
+  be exported. There are several cases:
+  (1) Use the name defined in the FormatSettings.
+  (2) Provide the name in an event handler for OnGetSheetname.
+  The name provided from these sources can contain a %d placeholder which will
+  be replaced by a number such that the sheet name is unique.
+  If it does not contain a %d then a %d may be added if needed to get a unique
+  sheet name. }
+function TCustomFPSExport.DoGetSheetName: String;
+var
+  mask: String;
+begin
+  mask := CalcSheetNameMask(FormatSettings.SheetName);
+  Result := CalcUniqueSheetName(mask);
+  if Assigned(FOnGetSheetName) then
+  begin
+    FOnGetSheetName(Self, FSpreadsheet.GetWorksheetCount, mask);
+    Result := CalcUniqueSheetName(mask);
+  end;
+end;
+
 procedure TCustomFPSExport.ExportField(EF: TExportFieldItem);
 var
   F : TFPSExportFieldItem;
@@ -210,6 +319,16 @@ begin
   end;
 end;
 
+procedure TCustomFPSExport.WriteExportFile;
+begin
+  if FMultipleSheets then begin
+    SaveWorkbook;
+    FreeAndNil(FSpreadsheet);
+    // Don't free FSheet; done by FSpreadsheet
+  end;
+end;
+
+
 procedure RegisterFPSExportFormat;
 begin
   ExportFormats.RegisterExportFormat(SFPSExport,rsFPSExportDescription,SPFSExtension,TFPSExport);
@@ -229,8 +348,9 @@ begin
   If Source is TFPSExportFormatSettings then
   begin
     FS:=Source as TFPSExportFormatSettings;
-    HeaderRow:=FS.HeaderRow;
+    HeaderRow := FS.HeaderRow;
-    ExportFormat:=FS.ExportFormat;
+    ExportFormat := FS.ExportFormat;
+    SheetName := FS.SheetName;
   end;
   inherited Assign(Source);
 end;
@@ -238,7 +358,8 @@ end;
 procedure TFPSExportFormatSettings.InitSettings;
 begin
   inherited InitSettings;
-  FExportFormat:=efXLS; //often used format
+  FExportFormat := efXLS; //often used format
+  FSheetName := 'Sheet';
 end;
 
 end.

components/fpspreadsheet/fpsstrings.pas

@@ -12,6 +12,8 @@ interface
 resourcestring
   rsExportFileIsRequired = 'Export file name is required';
   rsFPSExportDescription = 'Spreadsheet file';
+  rsMultipleSheetsOnlyWithRestorePosition = 'Export to multiple sheets is possible '+
+    'only if position is restored.';
   rsUnsupportedReadFormat = 'Tried to read a spreadsheet using an unsupported format';
   rsUnsupportedWriteFormat = 'Tried to write a spreadsheet using an unsupported format';
   rsNoValidSpreadsheetFile = '"%s" is not a valid spreadsheet file';