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

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

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(
       '<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

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;
 

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
+  else if AValue >= TsWorkbook(FWorkbook).GetWorksheetCount then
-  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

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
 -------------------------------------------------------------------------------}

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;

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 := '<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>');

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

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;