diff --git a/components/fpspreadsheet/source/common/fpsopendocument.pas b/components/fpspreadsheet/source/common/fpsopendocument.pas
index 2213ec6ad..e958ed36f 100644
--- a/components/fpspreadsheet/source/common/fpsopendocument.pas
+++ b/components/fpspreadsheet/source/common/fpsopendocument.pas
@@ -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(
'' +
- '' +
+ '' +
'', [
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
diff --git a/components/fpspreadsheet/source/common/fpspalette.pas b/components/fpspreadsheet/source/common/fpspalette.pas
index 9c348d89d..b041cd609 100644
--- a/components/fpspreadsheet/source/common/fpspalette.pas
+++ b/components/fpspreadsheet/source/common/fpspalette.pas
@@ -255,6 +255,8 @@ begin
AddUniqueColor(fmt.BorderStyles[cb].Color);
end;
end;
+ if sheet.TabColor <> scNotDefined then
+ AddUniqueColor(sheet.TabColor);
end;
end;
diff --git a/components/fpspreadsheet/source/common/fpspreadsheet.pas b/components/fpspreadsheet/source/common/fpspreadsheet.pas
index 1fc762d78..62c645b82 100644
--- a/components/fpspreadsheet/source/common/fpspreadsheet.pas
+++ b/components/fpspreadsheet/source/common/fpspreadsheet.pas
@@ -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
diff --git a/components/fpspreadsheet/source/common/xlsbiff8.pas b/components/fpspreadsheet/source/common/xlsbiff8.pas
index cb812f95f..ed1bac89f 100644
--- a/components/fpspreadsheet/source/common/xlsbiff8.pas
+++ b/components/fpspreadsheet/source/common/xlsbiff8.pas
@@ -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
-------------------------------------------------------------------------------}
diff --git a/components/fpspreadsheet/source/common/xlscommon.pas b/components/fpspreadsheet/source/common/xlscommon.pas
index ee4061d0a..f3ea7779e 100644
--- a/components/fpspreadsheet/source/common/xlscommon.pas
+++ b/components/fpspreadsheet/source/common/xlscommon.pas
@@ -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;
diff --git a/components/fpspreadsheet/source/common/xlsxooxml.pas b/components/fpspreadsheet/source/common/xlsxooxml.pas
index 0f4994064..b733df144 100644
--- a/components/fpspreadsheet/source/common/xlsxooxml.pas
+++ b/components/fpspreadsheet/source/common/xlsxooxml.pas
@@ -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 := '';
+ if sheet.TabColor <> scNotDefined then
+ s := s + Format('', [Copy(ColorToHTMLColorStr(sheet.TabColor), 2, MaxInt)]);
+
if s <> '' then
AppendToStream(AStream,
'' + s + '');
diff --git a/components/fpspreadsheet/source/visual/fpspreadsheetctrls.pas b/components/fpspreadsheet/source/visual/fpspreadsheetctrls.pas
index 47b41b2b8..90702c9bd 100644
--- a/components/fpspreadsheet/source/visual/fpspreadsheetctrls.pas
+++ b/components/fpspreadsheet/source/visual/fpspreadsheetctrls.pas
@@ -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
diff --git a/components/fpspreadsheet/tests/colortests.pas b/components/fpspreadsheet/tests/colortests.pas
index 3b23d0189..9c3d894b4 100644
--- a/components/fpspreadsheet/tests/colortests.pas
+++ b/components/fpspreadsheet/tests/colortests.pas
@@ -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;