paweld/lazarus-ccr
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

fpspreadsheet: Add Worksheet.TabColor support. Update biff8/ooxml/ods readers/writers for it. Add test case for it.

Browse Source 
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@7326 8e941d3f-bd1b-0410-a28a-d453659cc2b4
This commit is contained in:
wp_xxyyzz 2020-02-10 15:23:30 +00:00
parent ab3f832e62
commit fa4f0c306e
8 changed files with 194 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

23
components/fpspreadsheet/source/common/fpsopendocument.pas
View File

@ -385,6 +385,7 @@ type
Name: String;
BiDiMode: TsBiDiMode;
Hidden: boolean;
TabColor: TsColor;
end;
{ Column style items stored in ColStyleList of the reader }
@ -1286,6 +1287,7 @@ begin
sheet.BiDiMode := tableStyle.BiDiMode;
if tableStyle.Hidden then
sheet.Options := sheet.Options + [soHidden];
sheet.TabColor := tableStyle.TabColor;
Result := true;
end;
@ -4657,7 +4659,8 @@ var
styleChildNode: TDOMNode;
bidi: String;
tablestyle: TTableStyleData;
display: String;
display: String = '';
tabColor: String = '';
begin
// nodeName := GetAttrValue(AStyleNode, 'style:name');
stylename := GetAttrValue(AStyleNode, 'style:name');
@ -4671,6 +4674,7 @@ begin
// stylename := GetAttrValue(styleChildNode, 'style:name');
bidi := GetAttrValue(styleChildNode, 'style:writing-mode');
display := GetAttrValue(styleChildNode, 'table:display');
tabcolor := GetAttrValue(styleChildNode, 'tableooo:tab-color');
end;
styleChildNode := styleChildNode.NextSibling;
end;
@ -4678,9 +4682,14 @@ begin
tablestyle := TTableStyleData.Create;
tablestyle.Name := styleName;
if bidi = 'rl-tb' then
tablestyle.BiDiMode := bdRTL else
tablestyle.BiDiMode := bdRTL
else
tablestyle.BiDiMode := bdLTR;
tablestyle.Hidden := display = 'false';
if tabcolor = '' then
tablestyle.TabColor := scNotDefined
else
tablestyle.TabColor := HTMLColorStrToColor(tabcolor);
FTableStyleList.Add(tablestyle);
end;
@ -7593,7 +7602,7 @@ procedure TsSpreadOpenDocWriter.WriteTableStyles(AStream: TStream);
var
i: Integer;
sheet: TsWorksheet;
sheetname, bidi: String;
sheetname, bidi, tabColor: String;
begin
for i:=0 to (FWorkbook as TsWorkbook).GetWorksheetCount-1 do
begin
@ -7604,12 +7613,16 @@ begin
bdLTR : bidi := 'style:writing-mode="lr-tb" ';
bdRTL : bidi := 'style:writing-mode="rl-tb" ';
end;
if sheet.TabColor = scNotDefined then
tabColor := ''
else
tabColor := 'tableooo:tab-color="' + ColorToHTMLColorStr(sheet.TabColor) + '" ';
AppendToStream(AStream, Format(
'<style:style style:name="ta%d" style:family="table" style:master-page-name="PageStyle_5f_%s">' +
'<style:table-properties table:display="%s" %s/>' +
'<style:table-properties table:display="%s" %s %s/>' +
'</style:style>', [
i+1, UTF8TextToXMLText(sheetname),
FALSE_TRUE[not (soHidden in sheet.Options)], bidi
FALSE_TRUE[not (soHidden in sheet.Options)], bidi, tabColor
]));
if sheet.GetImageCount > 0 then
begin

2
components/fpspreadsheet/source/common/fpspalette.pas
View File

@ -255,6 +255,8 @@ begin
AddUniqueColor(fmt.BorderStyles[cb].Color);
end;
end;
if sheet.TabColor <> scNotDefined then
AddUniqueColor(sheet.TabColor);
end;
end;

14
components/fpspreadsheet/source/common/fpspreadsheet.pas
View File

@ -97,6 +97,7 @@ type
FVirtualColCount: Cardinal;
FVirtualRowCount: Cardinal;
FZoomFactor: Double;
FTabColor: TsColor;
FOnChangeCell: TsCellEvent;
FOnChangeFont: TsCellEvent;
FOnChangeCol: TsColEvent;
@ -116,6 +117,7 @@ type
procedure SetDefaultColWidth(AValue: Single);
procedure SetDefaultRowHeight(AValue: Single);
procedure SetIndex(AValue: Integer);
procedure SetTabColor(AValue: TsColor);
procedure SetVirtualColCount(AValue: Cardinal);
procedure SetVirtualRowCount(AValue: Cardinal);
procedure SetZoomFactor(AValue: Double);
@ -622,6 +624,8 @@ type
property PageLayout: TsPageLayout read FPageLayout write FPageLayout;
{@@ List of all row records of the worksheet having a non-standard row height }
property Rows: TIndexedAVLTree read FRows;
{@@ Color of the tab in the visual control - currently ignored }
property TabColor: TsColor read FTabColor write SetTabColor default scNotDefined;
{@@ Workbook to which the worksheet belongs }
property Workbook: TsWorkbook read FWorkbook;
{@@ The default column width given in "character units" (width of the
@ -1181,6 +1185,7 @@ begin
FDefaultColWidth := ptsToMM(72); // Excel: about 72 pts
FDefaultRowHeight := ptsToMM(15); // Excel: 15pts
FZoomFactor := 1.0;
FTabColor := scNotDefined;
FFirstRowIndex := UNASSIGNED_ROW_COL_INDEX;
FFirstColIndex := UNASSIGNED_ROW_COL_INDEX;
@ -7341,14 +7346,19 @@ var
begin
if AValue < 0 then
AValue := 0
else
if AValue >= TsWorkbook(FWorkbook).GetWorksheetCount then
else if AValue >= TsWorkbook(FWorkbook).GetWorksheetCount then
AValue := TsWorkbook(FWorkbook).GetWorksheetCount - 1;
oldIndex := GetIndex;
if oldIndex <> AValue then
TsWorkbook(FWorkbook).MoveSheet(oldIndex, Avalue);
end;
procedure TsWorksheet.SetTabColor(AValue: TsColor);
begin
if AValue = FTabColor then exit;
FTabColor := AValue;
TsWorkbook(FWorkbook).ChangedWorksheet(self);
end;
{@@ ----------------------------------------------------------------------------
Calculates the optimum height of a given row. Depends on the font size

61
components/fpspreadsheet/source/common/xlsbiff8.pas
View File

@ -168,6 +168,7 @@ type
procedure ReadRPNSheetIndex(AStream: TStream; out ADocumentURL: String;
out ASheet1, ASheet2: Integer); override;
procedure ReadRSTRING(AStream: TStream);
procedure ReadSheetLayout(const AStream: TStream);
procedure ReadSST(const AStream: TStream);
function ReadString_8bitLen(AStream: TStream): String; override;
procedure ReadStringRecord(AStream: TStream); override;
@ -256,6 +257,7 @@ type
function WriteRPNSheetIndex(AStream: TStream; ADocumentURL: String;
ASheet1, ASheet2: Integer): Word; override;
// procedure WriteSelectionRange(AStream: TStream; ARange: TsCellRange); override;
procedure WriteSheetLayout(AStream: TStream);
procedure WriteSST(AStream: TStream);
function WriteString_8bitLen(AStream: TStream; AString: String): Integer; override;
procedure WriteSTRINGRecord(AStream: TStream; AString: string); override;
@ -381,6 +383,7 @@ const
INT_EXCEL_ID_TXO = $01B6; // BIFF8 only
INT_EXCEL_ID_HYPERLINK = $01B8; // BIFF8 only
INT_EXCEL_ID_HLINKTOOLTIP = $0800; // BIFF8 only
INT_EXCEL_ID_SHEETLAYOUT = $0862; // BIFF8 only
{%H-}INT_EXCEL_ID_FORCEFULLCALCULATION = $08A3;
{ Excel OBJ subrecord IDs }
@ -1254,6 +1257,7 @@ begin
INT_EXCEL_ID_SCL : ReadSCLRecord(AStream);
INT_EXCEL_ID_SELECTION : ReadSELECTION(AStream);
INT_EXCEL_ID_SHAREDFMLA : ReadSharedFormula(AStream);
INT_EXCEL_ID_SHEETLAYOUT : ReadSheetLayout(AStream);
INT_EXCEL_ID_SHEETPR : ReadSHEETPR(AStream);
INT_EXCEL_ID_STRING : ReadStringRecord(AStream);
INT_EXCEL_ID_TOPMARGIN : ReadMargin(AStream, 2);
@ -1747,6 +1751,20 @@ begin
book.OnReadCellData(book, ARow, ACol, cell);
end;
procedure TsSpreadBIFF8Reader.ReadSheetLayout(const AStream: TStream);
var
iclr: word;
i: Integer;
begin
if WordLEToN(AStream.ReadWord) <> INT_EXCEL_ID_SHEETLAYOUT then
exit;
for i := 1 to 7 do
AStream.ReadWord; // not used, unknown data
iclr := WordLEToN(AStream.ReadWord); // index of tab color
TsWorksheet(FWorksheet).TabColor := FPalette[iclr];
end;
procedure TsSpreadBIFF8Reader.ReadSST(const AStream: TStream);
var
Items: DWORD;
@ -2815,6 +2833,7 @@ begin
WriteMargin(AStream, 2); // 2 = top margin
WriteMargin(AStream, 3); // 3 = bottom margin
WritePageSetup(AStream);
WriteSheetLayout(AStream);
// Protection
if FWorksheet.IsProtected then begin
@ -4339,6 +4358,48 @@ begin
AStream.WriteWord(WordToLE(Byte(ARange.Col2)));
end; *)
{@@ ----------------------------------------------------------------------------
Writes a SHEETLAYOUT record which contains the color of the worksheet's tab
offset size data
0 2 0862H (repeated record identifier)
2 10 Not used
12 4 Unknown data: 14H 00H 00H 00H
16 2 Colour index (➜5.74) for sheet name tab
18 2 Not used
-------------------------------------------------------------------------------}
procedure TsSpreadBIFF8Writer.WriteSheetLayout(AStream: TStream);
var
i: Integer;
iclr: Integer;
sheet: TsWorksheet;
begin
sheet := TsWorksheet(FWorksheet);
if sheet.TabColor = scNotDefined then
exit;
// Biff header
WriteBIFFHeader(AStream, INT_EXCEL_ID_SHEETLAYOUT, 20);
// repeated record identifier
AStream.WriteWord(WordToLE(INT_EXCEL_ID_SHEETLAYOUT));
// not used
for i:=1 to 5 do AStream.WriteWord(0);
// Unknown data
AStream.WriteByte($14);
AStream.WriteByte(0);
AStream.WriteByte(0);
AStream.WriteByte(0);
// palette index of tab color
iclr := PaletteIndex(sheet.TabColor);
AStream.WriteWord(WordToLE(iclr));
// not used
AStream.WriteWord(0);
end;
{@@ ----------------------------------------------------------------------------
Writes the SharedStringTable (SST) to the stream
-------------------------------------------------------------------------------}

2
components/fpspreadsheet/source/common/xlscommon.pas
View File

@ -3916,7 +3916,7 @@ end;
data to be written immediately afterwards.
@param ARecID ID of the record - see the INT_EXCEL_ID_XXXX constants
@param ARedSize Size (in bytes) of the data which follow immediately
@param ARecSize Size (in bytes) of the data which follow immediately
afterwards
-------------------------------------------------------------------------------}
procedure TsSpreadBIFFWriter.WriteBIFFHeader(AStream: TStream;

32
components/fpspreadsheet/source/common/xlsxooxml.pas
View File

@ -93,6 +93,7 @@ type
procedure ReadSharedStrings(ANode: TDOMNode);
procedure ReadSheetFormatPr(ANode: TDOMNode; AWorksheet: TsBasicWorksheet);
procedure ReadSheetList(ANode: TDOMNode);
procedure ReadSheetPr(ANode: TDOMNode; AWorksheet: TsBasicWorksheet);
procedure ReadSheetProtection(ANode: TDOMNode; AWorksheet: TsBasicWorksheet);
procedure ReadSheetViews(ANode: TDOMNode; AWorksheet: TsBasicWorksheet);
procedure ReadThemeElements(ANode: TDOMNode);
@ -1112,6 +1113,7 @@ var
n, i: Integer;
nodename: String;
begin
Result := scNotDefined;
Assert(ANode <> nil);
s := Lowercase(GetAttrValue(ANode, 'auto'));
@ -2203,6 +2205,26 @@ begin
end;
end;
procedure TsSpreadOOXMLReader.ReadSheetPR(ANode: TDOMNode;
AWorksheet: TsBasicWorksheet);
var
node: TDOMNode;
nodename: String;
begin
if ANode = nil then
exit;
node := ANode.FirstChild;
while node <> nil do begin
nodeName := node.NodeName;
if nodeName = 'tabColor' then
begin
TsWorksheet(AWorksheet).TabColor := ReadColor(node);
end;
node := node.NextSibling;
end;
end;
procedure TsSpreadOOXMLReader.ReadSheetProtection(ANode: TDOMNode;
AWorksheet: TsBasicWorksheet);
var
@ -2731,6 +2753,7 @@ begin
FSharedFormulaBaseList.Clear;
// Sheet data, formats, etc.
ReadSheetPr(Doc_FindNode('sheetPr'), FWorksheet);
ReadDimension(Doc_FindNode('dimension'), FWorksheet);
ReadSheetViews(Doc_FindNode('sheetViews'), FWorksheet);
ReadSheetFormatPr(Doc_FindNode('sheetFormatPr'), FWorksheet);
@ -3740,13 +3763,18 @@ procedure TsSpreadOOXMLWriter.WriteSheetPr(AStream: TStream;
AWorksheet: TsBasicWorksheet);
var
s: String;
sheet: TsWorksheet absolute AWorksheet;
begin
s := '';
if ((AWorksheet as TsWorksheet).PageLayout.FitWidthToPages > 0) or
((AWorksheet as TsWorksheet).PageLayout.FitHeightToPages > 0) then
if (sheet.PageLayout.FitWidthToPages > 0) or
(sheet.PageLayout.FitHeightToPages > 0) then
s := s + ' fitToPage="1"';
if s <> '' then s := '<pageSetUpPr' + s + ' />';
if sheet.TabColor <> scNotDefined then
s := s + Format('<tabColor rgb="%s" />', [Copy(ColorToHTMLColorStr(sheet.TabColor), 2, MaxInt)]);
if s <> '' then
AppendToStream(AStream,
'<sheetPr>' + s + '</sheetPr>');

2
components/fpspreadsheet/source/visual/fpspreadsheetctrls.pas
View File

@ -4018,6 +4018,7 @@ begin
AStrings.Add('Page layout=');
AStrings.Add('Options=');
AStrings.Add('Protection=');
AStrings.Add('TabColor=');
end else
begin
AStrings.Add(Format('Name=%s', [ASheet.Name]));
@ -4039,6 +4040,7 @@ begin
AStrings.Add(Format('Comments=%d items', [ASheet.Comments.Count]));
AStrings.Add(Format('Hyperlinks=%d items', [ASheet.Hyperlinks.Count]));
AStrings.Add(Format('MergedCells=%d items', [ASheet.MergedCells.Count]));
AStrings.Add(Format('TabColor=$%.8x (%s)', [ASheet.TabColor, GetColorName(ASheet.TabColor)]));
if ienPageLayout in FExpanded then
begin

68
components/fpspreadsheet/tests/colortests.pas
View File

@ -27,6 +27,7 @@ type
procedure TearDown; override;
procedure TestWriteReadBackgroundColors(AFormat: TsSpreadsheetFormat; WhichPalette: Integer);
procedure TestWriteReadFontColors(AFormat: TsSpreadsheetFormat; WhichPalette: Integer);
procedure TestWriteReadTabColor(AFormat: TsSpreadsheetFormat; ATabColor: TsColor);
published
// Writes out colors & reads back.
@ -56,6 +57,8 @@ type
procedure TestWriteRead_BIFF8_Font_Biff5Pal; // official biff5 palette in BIFF8 file format
procedure TestWriteRead_BIFF8_Font_Biff8Pal; // official biff8 palette in BIFF8 file format
procedure TestWriteRead_BIFF8_Font_RandomPal; // palette 64, top 56 entries random
// Tab color
procedure TestWriteRead_BIFF8_TabColor;
{ OpenDocument file format tests }
// Background colors...
@ -68,6 +71,8 @@ type
procedure TestWriteRead_ODS_Font_Biff5Pal; // official biff5 palette in BIFF8 file format
procedure TestWriteRead_ODS_Font_Biff8Pal; // official biff8 palette in BIFF8 file format
procedure TestWriteRead_ODS_Font_RandomPal; // palette 64, top 56 entries random
// Tab color
procedure TestWriteRead_ODS_TabColor;
{ OOXML file format tests }
// Background colors...
@ -80,6 +85,8 @@ type
procedure TestWriteRead_OOXML_Font_Biff5Pal; // official biff5 palette in BIFF8 file format
procedure TestWriteRead_OOXML_Font_Biff8Pal; // official biff8 palette in BIFF8 file format
procedure TestWriteRead_OOXML_Font_RandomPal; // palette 64, top 56 entries random
// Tab color
procedure TestWriteRead_OOXML_TabColor;
{ Excel 2003/XML file format tests }
// Background colors...
@ -299,6 +306,53 @@ begin
end;
end;
procedure TSpreadWriteReadColorTests.TestWriteReadTabColor(
AFormat: TsSpreadsheetFormat; ATabColor: TsColor);
const
CELLTEXT = 'Color test';
var
MyWorksheet: TsWorksheet;
MyWorkbook: TsWorkbook;
row, col: Integer;
MyCell: PCell;
TempFile: string; //write xls/xml to this file and read back from it
expectedRGB: DWord;
currentRGB: DWord;
i: Integer;
begin
if not (AFormat in [sfOOXML, sfExcel8, sfOpenDocument]) then
exit;
TempFile:=GetTempFileName;
MyWorkbook := TsWorkbook.Create;
try
MyWorkSheet:= MyWorkBook.AddWorksheet(ColorsSheet);
MyWorkSheet.TabColor := scRed;
currentRGB := MyWorksheet.TabColor;
expectedRGB := ATabColor;
CheckEquals(expectedRGB, currentRGB, 'Test unsaved tab color');
MyWorkBook.WriteToFile(TempFile, AFormat, true);
finally
MyWorkbook.Free;
end;
// Open the spreadsheet
MyWorkbook := TsWorkbook.Create;
try
MyWorkbook.ReadFromFile(TempFile, AFormat);
MyWorksheet := GetWorksheetByName(MyWorkBook, ColorsSheet);
if MyWorksheet=nil then
fail('Error in test code. Failed to get named worksheet');
currentRGB := MyWorksheet.TabColor;
expectedRGB := ATabColor;
CheckEquals(expectedRGB, currentRGB, 'Test saved tab color');
finally
MyWorkbook.Free;
DeleteFile(TempFile);
end;
end;
{ Tests for BIFF2 file format }
{ BIFF2 supports only a fixed palette, and no background color --> test only
internal palette for font color }
@ -389,6 +443,11 @@ begin
TestWriteReadFontColors(sfExcel8, 999);
end;
procedure TSpreadWriteReadColorTests.TestWriteRead_BIFF8_TabColor;
begin
TestWriteReadTabColor(sfExcel8, scRed);
end;
{ Tests for Open Document file format }
procedure TSpreadWriteReadColorTests.TestWriteRead_ODS_Background_InternalPal;
begin
@ -430,6 +489,11 @@ begin
TestWriteReadFontColors(sfOpenDocument, 999);
end;
procedure TSpreadWriteReadColorTests.TestWriteRead_ODS_TabColor;
begin
TestWriteReadTabColor(sfOpenDocument, scRed);
end;
{ Tests for OOXML file format }
procedure TSpreadWriteReadColorTests.TestWriteRead_OOXML_Background_InternalPal;
begin
@ -471,6 +535,10 @@ begin
TestWriteReadFontColors(sfOOXML, 999);
end;
procedure TSpreadWriteReadColorTests.TestWriteRead_OOXML_TabColor;
begin
TestWriteReadTabColor(sfOOXML, scRed);
end;
{ Tests for Excel 2003/XML file format }
procedure TSpreadWriteReadColorTests.TestWriteRead_XML_Background_InternalPal;