pascal/lazarus-ccr
1
0
Fork 0
Code Issues Releases Activity

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

Browse Source 
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@3844 8e941d3f-bd1b-0410-a28a-d453659cc2b4
This commit is contained in:
wp_xxyyzz
2014-12-19 14:47:59 +00:00
parent 98e1c88c1e
commit aabdaed83f
4 changed files with 237 additions and 64 deletions
Download Patch File Download Diff File Expand all files Collapse all files

47
components/fpspreadsheet/examples/db_import_export/main.lfm
View File

@ -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
Top = 21
Height = 241
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
Top = 237
Height = 20
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
Top = 258
Height = 20
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

67
components/fpspreadsheet/examples/db_import_export/main.pas
View File

@ -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},
seFPSExport {uses FpSpreadsheet's fpsexport - takes more memory});
TsExportModes=(
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);
seFPSExport: ExportUsingFPSExport(DataFileName);
seVirtual:
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;
@ -319,9 +330,12 @@ begin
ShowMessage('Format not supported using this mode.');
exit;
end;
sfExcel8: ExportSettings.ExportFormat := efXLS;
sfOOXML: ExportSettings.ExportFormat := efXLSX;
sfOpenDocument: ExportSettings.ExportFormat := efODS;
sfExcel8:
ExportSettings.ExportFormat := efXLS;
sfOOXML:
ExportSettings.ExportFormat := efXLSX;
sfOpenDocument:
ExportSettings.ExportFormat := efODS;
else
begin
ShowMessage('Unknown export format. Please correct the source code.');
@ -335,6 +349,31 @@ begin
Exporter.Dataset := FExportDataset;
Exporter.FileName := ChangeFileExt(DataFileName, FILE_EXT[
RgFileFormat.ItemIndex]);
// 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;
@ -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

161
components/fpspreadsheet/fpsexport.pas
View File

@ -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);
if (not RestorePosition) and FMultipleSheets then
Raise EDataExporter.Create(rsMultipleSheetsOnlyWithRestorePosition);
if (not FMultipleSheets) or (FSpreadsheet = nil) then
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.
FSpreadsheet.Options:=FSpreadsheet.Options+[boBufStream];
FSheet:=FSpreadsheet.AddWorksheet('1');
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);
efXLSX: FSpreadsheet.WriteToFile(FFilename,sfOOXML,true);
efODS: FSpreadSheet.WriteToFile(FFileName,sfOpenDocument,true);
efWikiTable: FSpreadSheet.WriteToFile(FFileName,sfWikitable_wikimedia,true);
efXLS:
FSpreadSheet.WriteToFile(FFileName,sfExcel8,true);
efXLSX:
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
try
FreeAndNil(FSpreadsheet);
finally
Inherited;
procedure TCustomFPSExport.DoAfterExecute;
begin
if not FMultipleSheets then
begin
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;
ExportFormat:=FS.ExportFormat;
HeaderRow := FS.HeaderRow;
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.

2
components/fpspreadsheet/fpsstrings.pas
View File

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