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

fpspreadsheet: Add printranges and repeated header cols/rows (for printing) to worksheet. Implement writing to xlsx and ods. (Request from the forum http://forum.lazarus.freepascal.org/index.php/topic,31496.0.html).

Browse Source 
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@4496 8e941d3f-bd1b-0410-a28a-d453659cc2b4
This commit is contained in:
wp_xxyyzz
2016-02-13 17:45:36 +00:00
parent 8a0351fde3
commit 22c42622a2
5 changed files with 385 additions and 17 deletions
Download Patch File Download Diff File Expand all files Collapse all files

205
components/fpspreadsheet/fpsopendocument.pas
View File

@ -165,6 +165,7 @@ type
procedure WriteColumns(AStream: TStream; ASheet: TsWorksheet);
procedure WriteFontNames(AStream: TStream);
procedure WriteMasterStyles(AStream: TStream);
procedure WriteNamedExpressions(AStream: TStream; ASheet: TsWorksheet);
procedure WriteNumFormats(AStream: TStream);
procedure WriteRowStyles(AStream: TStream);
procedure WriteRowsAndCells(AStream: TStream; ASheet: TsWorksheet);
@ -183,6 +184,7 @@ type
function WriteHeaderFooterFontXMLAsString(AFont: TsHeaderFooterFont): String;
function WriteHorAlignmentStyleXMLAsString(const AFormat: TsCellFormat): String;
function WritePageLayoutAsXMLString(AStyleName: String; const APageLayout: TsPageLayout): String;
function WritePrintRangesAsXMLString(ASheet: TsWorksheet): String;
function WriteTextRotationStyleXMLAsString(const AFormat: TsCellFormat): String;
function WriteVertAlignmentStyleXMLAsString(const AFormat: TsCellFormat): String;
function WriteWordwrapStyleXMLAsString(const AFormat: TsCellFormat): String;
@ -4286,8 +4288,8 @@ begin
// Header
AppendToStream(AStream, Format(
'<table:table table:name="%s" table:style-name="ta%d">', [
FWorkSheet.Name, ASheetIndex+1
'<table:table table:name="%s" table:style-name="ta%d" %s>', [
FWorkSheet.Name, ASheetIndex+1, WritePrintRangesAsXMLString(FWorksheet)
]));
// columns
@ -4302,6 +4304,9 @@ begin
end else
WriteRowsAndCells(AStream, FWorksheet);
// named expressions, i.e. print range, repeated cols/rows
WriteNamedExpressions(AStream, FWorksheet);
// Footer
AppendToStream(AStream,
'</table:table>');
@ -4412,23 +4417,38 @@ procedure TsSpreadOpenDocWriter.WriteColumns(AStream: TStream;
ASheet: TsWorksheet);
var
lastCol: Integer;
j, k: Integer;
c, k: Integer;
w, w_mm: Double;
widthMultiplier: Double;
styleName: String;
colsRepeated: Integer;
colsRepeatedStr: String;
firstRepeatedPrintCol, lastRepeatedPrintCol: Cardinal;
headerCols: Boolean;
begin
widthMultiplier := Workbook.GetFont(0).Size / 2;
lastCol := ASheet.GetLastColIndex;
firstRepeatedPrintCol := ASheet.PageLayout.RepeatedCols.FirstIndex;
lastRepeatedPrintCol := ASheet.PageLayout.RepeatedCols.LastIndex;
if (firstRepeatedPrintCol <> UNASSIGNED_ROW_COL_INDEX) and
(lastRepeatedPrintCol = UNASSIGNED_ROW_COL_INDEX)
then
lastRepeatedPrintCol := firstRepeatedPrintCol;
j := 0;
while (j <= lastCol) do
headerCols := false;
c := 0;
while (c <= lastCol) do
begin
w := ASheet.GetColWidth(j);
w := ASheet.GetColWidth(c);
// Convert to mm
w_mm := PtsToMM(w * widthMultiplier);
if (c = firstRepeatedPrintCol) then
begin
headerCols := true;
AppendToStream(AStream, '<table:table-header-columns>');
end;
// Find width in ColumnStyleList to retrieve corresponding style name
styleName := '';
for k := 0 to FColumnStyleList.Count-1 do
@ -4441,22 +4461,38 @@ begin
// Determine value for "number-columns-repeated"
colsRepeated := 1;
k := j+1;
while (k <= lastCol) do
begin
if ASheet.GetColWidth(k) = w then
inc(colsRepeated)
else
break;
inc(k);
end;
k := c+1;
if headerCols then
while (k <= lastCol) and (k <= lastRepeatedPrintCol) do
begin
if ASheet.GetColWidth(k) = w then
inc(colsRepeated)
else
break;
inc(k);
end
else
while (k <= lastCol) do
begin
if ASheet.GetColWidth(k) = w then
inc(colsRepeated)
else
break;
inc(k);
end;
colsRepeatedStr := IfThen(colsRepeated = 1, '', Format(' table:number-columns-repeated="%d"', [colsRepeated]));
AppendToStream(AStream, Format(
'<table:table-column table:style-name="%s"%s table:default-cell-style-name="Default" />',
[styleName, colsRepeatedStr]));
j := j + colsRepeated;
if headerCols and (k-1 = lastRepeatedPrintCol) then
begin
AppendToStream(AStream, '</table:table-header-columns>');
headerCols := false;
end;
c := c + colsRepeated;
end;
end;
@ -4617,6 +4653,84 @@ begin
defFnt.Free;
end;
{<table:named-expressions>
<table:named-expression table:name="_xlnm.Print_Area" table:base-cell-address="$Sheet1.$A$1" table:expression="[$Sheet1.$A$2:.$F$6];[$Sheet1.$A$11:.$K$21]" />
<table:named-expression table:name="_xlnm.Print_Titles" table:base-cell-address="$Sheet1.$A$1" table:expression="[$Sheet1.$A$1:.$D$1048576];[$Sheet1.$A$1:.$AMJ$2]" />
</table:named-expressions>}
procedure TsSpreadOpenDocWriter.WriteNamedExpressions(AStream: TStream;
ASheet: TsWorksheet);
var
stotal, srng: String;
j: Integer;
prng: TsCellRange;
begin
stotal := '';
// Cell block of print range
srng := '';
for j := 0 to ASheet.NumPrintRanges - 1 do
begin
prng := ASheet.GetPrintRange(j);
srng := srng + ';' + Format('[$%s.%s]', [
ASheet.Name, GetCellRangeString(prng.Row1, prng.Col1, prng.Row2, prng.Col2, [])
]);
end;
if srng <> '' then
begin
Delete(srng, 1, 1);
stotal := stotal + Format(
'<table:named-expression table:name="_xlnm.Print_Area" table:base-cell-address="$%s.$A$1" table:expression="%s" />',
[ASheet.Name, srng]
);
end;
// Next commented part appears only in files converted from Excel
{
// repeated columns ...
srng := '';
if ASheet.PageLayout.RepeatedCols.FirstIndex <> UNASSIGNED_ROW_COL_INDEX then
begin
if ASheet.PageLayout.RepeatedCols.LastIndex = UNASSIGNED_ROW_COL_INDEX then
srng := srng + ';' + Format('[$%s.$%s]',
[ASheet.Name, GetColString(ASheet.pageLayout.RepeatedCols.FirstIndex)]
)
else
srng := srng + ';' + Format('[$%s.$%s1:.$%s1048576]', [ // [$Sheet1.$A$1:.$D$1048576]
ASheet.Name,
GetColString(ASheet.Pagelayout.RepeatedCols.FirstIndex),
GetColString(ASheet.PageLayout.RepeatedCols.LastIndex)
]);
end;
// ... and repeated rows
if ASheet.PageLayout.RepeatedRows.FirstIndex <> UNASSIGNED_ROW_COL_INDEX then
begin
if ASheet.PageLayout.RepeatedRows.LastIndex = UNASSIGNED_ROW_COL_INDEX then
srng := srng + ';' + Format('[$%s.$%d]',
[ASheet.Name, ASheet.pageLayout.RepeatedRows.FirstIndex]
)
else
srng := srng + ';' + Format('[$%s.$A$%d:.$AMJ$%d]', [ // [$Sheet1.$A$1:.$AMJ$2]"
ASheet.Name,
ASheet.Pagelayout.RepeatedRows.FirstIndex+1,
ASheet.PageLayout.RepeatedRows.LastIndex+1
]);
end;
if srng <> '' then begin
Delete(srng, 1,1);
stotal := stotal + Format(
'<table:named-expression table:name="_xlnm.Print_Titles" table:bases-cell-address="$%s.$A$1" table:expression="%s" />',
[ASheet.Name, srng]
);
end;
}
// Write to stream if any defined names exist
if stotal <> '' then
AppendtoStream(AStream,
'<table:named-expressions>' + stotal + '</table:named-expressions>');
end;
procedure TsSpreadOpenDocWriter.WriteNumFormats(AStream: TStream);
var
i, p: Integer;
@ -4657,20 +4771,38 @@ var
colsRepeatedStr: String;
rowsRepeatedStr: String;
firstCol, firstRow, lastCol, lastRow: Cardinal;
firstRepeatedPrintRow, lastRepeatedPrintRow: Cardinal;
rowStyleData: TRowStyleData;
defFontSize: Single;
emptyRowsAbove: Boolean;
headerRows: Boolean;
begin
// some abbreviations...
defFontSize := Workbook.GetFont(0).Size;
GetSheetDimensions(ASheet, firstRow, lastRow, firstCol, lastCol);
emptyRowsAbove := firstRow > 0;
headerRows := false;
firstRepeatedPrintRow := ASheet.PageLayout.RepeatedRows.FirstIndex;
lastRepeatedPrintRow := ASheet.PageLayout.RepeatedRows.LastIndex;
if (firstRepeatedPrintRow <> UNASSIGNED_ROW_COL_INDEX) and
(lastRepeatedPrintRow = UNASSIGNED_ROW_COL_INDEX)
then
lastRepeatedPrintRow := firstRepeatedPrintRow;
// Now loop through all rows
r := firstRow;
while (r <= lastRow) do
begin
rowsRepeated := 1;
// Header rows need a special tag
if (r = firstRepeatedPrintRow) then
begin
AppendToStream(AStream, '<table:table-header-rows>');
headerRows := true;
end;
// Look for the row style of the current row (r)
row := ASheet.FindRow(r);
if row = nil then
@ -4738,6 +4870,14 @@ begin
[styleName, rowsRepeatedStr, colsRepeatedStr]));
r := rr;
// Header rows need a special tag
if headerRows and (r-1 = lastRepeatedPrintRow) then
begin
AppendToStream(AStream, '</table:table-header-rows>');
headerRows := false;
end;
continue;
end;
@ -4788,6 +4928,13 @@ begin
AppendToStream(AStream,
'</table:table-row>');
// Header rows need a special tag
if headerRows and (r = lastRepeatedPrintRow) then
begin
AppendToStream(AStream, '</table:table-header-rows>');
headerRows := false;
end;
// Next row
inc(r, rowsRepeated);
end;
@ -5453,6 +5600,32 @@ begin
'</style:page-layout>';
end;
function TsSpreadOpenDocWriter.WritePrintRangesAsXMLString(ASheet: TsWorksheet): String;
var
i: Integer;
rng: TsCellRange;
srng: String;
begin
if ASheet.NumPrintRanges > 0 then
begin
srng := '';
for i := 0 to ASheet.NumPrintRanges - 1 do
begin
rng := ASheet.GetPrintRange(i);
Result := Result + ' ' + Format('%s.%s:%s.%s', [
ASheet.Name, GetCellString(rng.Row1,rng.Col1),
ASheet.Name, GetCellString(rng.Row2,rng.Col2)
]);
end;
if Result <> '' then
begin
Delete(Result, 1, 1);
Result := 'table:print-ranges="' + Result + '"';
end;
end else
Result := '';
end;
procedure TsSpreadOpenDocWriter.WriteTableSettings(AStream: TStream);
var
i: Integer;

96
components/fpspreadsheet/fpspreadsheet.pas
View File

@ -127,6 +127,7 @@ type
FDefaultRowHeight: Single; // in "character heights", i.e. line count
FSortParams: TsSortParams; // Parameters of the current sorting operation
FBiDiMode: TsBiDiMode;
FPrintRanges: TsCellRangeArray;
FOnChangeCell: TsCellEvent;
FOnChangeFont: TsCellEvent;
FOnCompareCells: TsCellCompareEvent;
@ -488,6 +489,16 @@ type
procedure UnmergeCells(ARow, ACol: Cardinal); overload;
procedure UnmergeCells(ARange: String); overload;
// Print ranges
function AddPrintRange(ARow1, ACol1, ARow2, ACol2: Cardinal): Integer; overload;
function AddPrintRange(const ARange: TsCellRange): Integer; overload;
function GetPrintRange(AIndex: Integer): TsCellRange;
function NumPrintRanges: Integer;
procedure RemovePrintRange(AIndex: Integer);
procedure SetRepeatedPrintCols(AFirstCol: Cardinal; ALastCol: Cardinal = UNASSIGNED_ROW_COL_INDEX);
procedure SetRepeatedPrintRows(AFirstRow: Cardinal; ALastRow: Cardinal = UNASSIGNED_ROW_COL_INDEX);
// Notification of changed cells
procedure ChangedCell(ARow, ACol: Cardinal);
procedure ChangedFont(ARow, ACol: Cardinal);
@ -3278,6 +3289,91 @@ begin
Result := (ACell <> nil) and (cfMerged in ACell^.Flags);
end;
{@@ ----------------------------------------------------------------------------
Adds a print range defined by the row/column indexes of its corner cells.
-------------------------------------------------------------------------------}
function TsWorksheet.AddPrintRange(ARow1, ACol1, ARow2, ACol2: Cardinal): Integer;
begin
Result := Length(FPrintRanges);
SetLength(FPrintRanges, Result + 1);
with FPrintRanges[Result] do
begin
Row1 := ARow1;
Col1 := ACol1;
Row2 := ARow2;
Col2 := ACol2;
end;
end;
{@@ ----------------------------------------------------------------------------
Adds a print range defined by a TsCellRange record
-------------------------------------------------------------------------------}
function TsWorksheet.AddPrintRange(const ARange: TsCellRange): Integer;
begin
Result := AddPrintRange(ARange.Row1, ARange.Col1, ARange.Row2, ARange.Col2);
end;
{@@ ----------------------------------------------------------------------------
Returns the TsCellRange record of the print range with the specified index.
-------------------------------------------------------------------------------}
function TsWorksheet.GetPrintRange(AIndex: Integer): TsCellRange;
begin
Result := FPrintRanges[AIndex];
end;
{@@ ----------------------------------------------------------------------------
Returns the count of print ranges defined for this worksheet
-------------------------------------------------------------------------------}
function TsWorksheet.NumPrintRanges: Integer;
begin
Result := Length(FPrintRanges);
end;
{@@ ----------------------------------------------------------------------------
Removes the print range specified by the index
-------------------------------------------------------------------------------}
procedure TsWorksheet.RemovePrintRange(AIndex: Integer);
var
i: Integer;
begin
if not InRange(AIndex, 0, High(FPrintRanges)) then exit;
for i := AIndex + 1 to High(FPrintRanges) do
FPrintRanges[i - 1] := FPrintRanges[i];
SetLength(FPrintRanges, Length(FPrintRanges)-1);
end;
{@@ ----------------------------------------------------------------------------
Defines a range of header columns for printing repeated on every page
-------------------------------------------------------------------------------}
procedure TsWorksheet.SetRepeatedPrintCols(AFirstCol, ALastCol: Cardinal);
begin
if AFirstCol < ALastCol then
begin
PageLayout.RepeatedCols.FirstIndex := AFirstCol;
PageLayout.RepeatedCols.LastIndex := ALastCol;
end else
begin
PageLayout.RepeatedCols.FirstIndex := ALastCol;
PageLayout.RepeatedCols.LastIndex := AFirstCol;
end;
end;
{@@ ----------------------------------------------------------------------------
Defines a range of header rows for printing repeated on every page
-------------------------------------------------------------------------------}
procedure TsWorksheet.SetRepeatedPrintRows(AFirstRow, ALastRow: Cardinal);
begin
if AFirstRow < ALastRow then
begin
PageLayout.RepeatedRows.FirstIndex := AFirstRow;
PageLayout.RepeatedRows.LastIndex := ALastRow;
end else
begin
PageLayout.RepeatedRows.FirstIndex := ALastRow;
PageLayout.RepeatedRows.LastIndex := AFirstRow;
end;
end;
{@@ ----------------------------------------------------------------------------
Removes the comment from a cell and releases the memory occupied by the node.
-------------------------------------------------------------------------------}

9
components/fpspreadsheet/fpstypes.pas
View File

@ -560,7 +560,7 @@ type
Row, Col: Cardinal;
end;
{@@ Record combining row and column cornder indexes of a range of cells }
{@@ Record combining row and column corner indexes of a range of cells }
TsCellRange = record
Row1, Col1, Row2, Col2: Cardinal;
end;
@ -569,6 +569,11 @@ type
{@@ Array with cell ranges }
TsCellRangeArray = array of TsCellRange;
{@@ Record containing limiting indexes of column or row range }
TsRowColRange = record
FirstIndex, LastIndex: Cardinal;
end;
{@@ Options for sorting }
TsSortOption = (ssoDescending, ssoCaseInsensitive);
{@@ Set of options for sorting }
@ -705,6 +710,8 @@ type
Array index 1 contains the strings if these options are not used. }
Headers: array[0..2] of string;
Footers: array[0..2] of string;
RepeatedCols: TsRowColRange;
RepeatedRows: TsRowColRange;
end;
{@@ Pointer to a page layout record }

15
components/fpspreadsheet/fpsutils.pas
View File

@ -172,6 +172,8 @@ function SameFont(AFont1, AFont2: TsFont): Boolean; overload;
function SameFont(AFont: TsFont; AFontName: String; AFontSize: Single;
AStyle: TsFontStyles; AColor: TsColor; APos: TsFontPosition): Boolean; overload;
function Range(ARow1, ACol1, ARow2, ACol2: Cardinal): TsCellRange;
//function GetUniqueTempDir(Global: Boolean): String;
procedure AppendToStream(AStream: TStream; const AString: String); inline; overload;
@ -2127,6 +2129,10 @@ begin
Options := [];
for i:=0 to 2 do Headers[i] := '';
for i:=0 to 2 do Footers[i] := '';
RepeatedRows.FirstIndex := UNASSIGNED_ROW_COL_INDEX;
RepeatedRows.LastIndex := UNASSIGNED_ROW_COL_INDEX;
RepeatedCols.FirstIndex := UNASSIGNED_ROW_COL_INDEX;
RepeatedCols.LastIndex := UNASSIGNED_ROW_COL_INDEX;
end;
end;
@ -2238,6 +2244,15 @@ begin
(AFont.Color = AColor) and
(AFont.Position = APos);
end;
function Range(ARow1, ACol1, ARow2, ACol2: Cardinal): TsCellRange;
begin
Result.Row1 := ARow1;
Result.Col1 := ACol1;
Result.Row2 := ARow2;
Result.Col2 := ACol2;
end;
(*
{@@ ----------------------------------------------------------------------------
Constructs a string of length "Len" containing random uppercase characters

77
components/fpspreadsheet/xlsxooxml.pas
View File

@ -128,6 +128,7 @@ type
procedure WriteBorderList(AStream: TStream);
procedure WriteCols(AStream: TStream; AWorksheet: TsWorksheet);
procedure WriteComments(AWorksheet: TsWorksheet);
procedure WriteDefinedNames(AStream: TStream);
procedure WriteDimension(AStream: TStream; AWorksheet: TsWorksheet);
procedure WriteFillList(AStream: TStream);
procedure WriteFont(AStream: TStream; AFont: TsFont; UseInStyleNode: Boolean);
@ -251,6 +252,7 @@ const
{%H-}MIME_XML = 'application/xml';
MIME_RELS = 'application/vnd.openxmlformats-package.relationships+xml';
MIME_OFFICEDOCUMENT = 'application/vnd.openxmlformats-officedocument';
MIME_CORE = 'application/vnd.openxmlformats-package.core-properties+xml';
MIME_SPREADML = MIME_OFFICEDOCUMENT + '.spreadsheetml';
MIME_SHEET = MIME_SPREADML + '.sheet.main+xml';
MIME_WORKSHEET = MIME_SPREADML + '.worksheet+xml';
@ -3349,6 +3351,7 @@ begin
'<bookViews>' +
'<workbookView xWindow="480" yWindow="90" windowWidth="15195" windowHeight="12525" ' + actTab + '/>' +
'</bookViews>');
AppendToStream(FSWorkbook,
'<sheets>');
for counter:=1 to Workbook.GetWorksheetCount do
@ -3357,6 +3360,9 @@ begin
[Workbook.GetWorksheetByIndex(counter-1).Name, counter, counter]));
AppendToStream(FSWorkbook,
'</sheets>');
WriteDefinedNames(FSWorkbook);
AppendToStream(FSWorkbook,
'<calcPr calcId="114210" />');
AppendToStream(FSWorkbook,
@ -3421,10 +3427,81 @@ begin
'<Override PartName="/xl/styles.xml" ContentType="' + MIME_STYLES + '" />');
AppendToStream(FSContentTypes,
'<Override PartName="/xl/sharedStrings.xml" ContentType="' + MIME_STRINGS + '" />');
{
AppendToStream(FSContentTypes,
'<Override PartName="/docProps/core.xml" ContentType="' + MIME_CORE + '" />');
}
AppendToStream(FSContentTypes,
'</Types>');
end;
procedure TsSpreadOOXMLWriter.WriteDefinedNames(AStream: TStream);
var
sheet: TsWorksheet;
stotal, srng: String;
i, j: Integer;
prng: TsCellRange;
firstIndex, lastIndex: Integer;
begin
stotal := '';
// Write print ranges and repeatedly printed rows and columns
for i := 0 to Workbook.GetWorksheetCount-1 do
begin
sheet := Workbook.GetWorksheetByIndex(i);
// Cell block of print range
srng := '';
for j := 0 to sheet.numPrintRanges - 1 do
begin
prng := sheet.GetPrintRange(j);
// prng.Col2 := Min(prng.Col2, sheet.GetLastColIndex);
// prng.Row2 := Min(prng.Row2, sheet.GetLastColIndex);
srng := srng + ',' + Format('%s!%s', [
sheet.Name, GetCellRangeString(prng.Row1, prng.Col1, prng.Row2, prng.Col2, [])
]);
end;
if srng <> '' then
begin
Delete(srng, 1, 1);
stotal := stotal + Format(
'<definedName name="_xlnm.Print_Area" localSheetId="%d">%s</definedName>',
[i, srng]
);
end;
// repeated columns ...
srng := '';
if sheet.PageLayout.RepeatedCols.FirstIndex <> UNASSIGNED_ROW_COL_INDEX then
begin
firstindex := sheet.PageLayout.RepeatedCols.FirstIndex;
lastindex := IfThen(sheet.PageLayout.RepeatedCols.LastIndex = UNASSIGNED_ROW_COL_INDEX,
firstindex, sheet.PageLayout.RepeatedCols.LastIndex);
srng := srng + ',' + Format('%s!$%s:$%s', [sheet.Name, GetColString(firstindex), GetColString(lastindex)]);
end;
// ... and repeated rows
if sheet.PageLayout.RepeatedRows.FirstIndex <> UNASSIGNED_ROW_COL_INDEX then
begin
firstindex := sheet.PageLayout.RepeatedRows.FirstIndex;
lastindex := IfThen(sheet.PageLayout.RepeatedRows.LastIndex = UNASSIGNED_ROW_COL_INDEX,
firstindex, sheet.PageLayout.RepeatedRows.LastIndex);
srng := srng + ',' + Format('%s!$%d:$%d', [sheet.Name, firstindex+1, lastindex+1]);
end;
if srng <> '' then begin
Delete(srng, 1,1);
stotal := stotal + Format(
'<definedName name="_xlnm.Print_Titles" localSheetId="%d">%s</definedName>',
[i, srng]
);
end;
end;
// Write to stream if any defined names exist
if stotal <> '' then
AppendtoStream(FSWorkbook,
'<definedNames>' + stotal + '</definedNames>');
end;
procedure TsSpreadOOXMLWriter.WriteWorksheet(AWorksheet: TsWorksheet);
begin
FCurSheetNum := Length(FSSheets);