fpspreadsheet: Add support for reading background colors in biff8 and fpspreadsheetgrid.

Add automatic test case for colors (fails since some colors are not yet written correctly, fails also for blank cells which are not yet read).

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

components/fpspreadsheet/fpspreadsheet.pas

@@ -1938,7 +1938,7 @@ end;
   Opens the file and calls WriteToStream
 
   @param  AFileName The output file name.
-                   If the file already exists it will be replaced.
+                    If the file already exists it will be replaced.
   @param  AData     The Workbook to be saved.
 
   @see    TsWorkbook

components/fpspreadsheet/fpspreadsheetgrid.pas

@@ -149,6 +149,8 @@ type
     property OnContextPopup;
   end;
 
+function FPSColorToColor(FPSColor: TsColor): TColor;
+
 procedure Register;
 
 implementation
@@ -156,6 +158,37 @@ implementation
 uses
   fpsUtils;
 
+function FPSColorToColor(FPSColor: TsColor): TColor;
+begin
+  case FPSColor of
+    scBlack    : Result := clBlack;
+    scWhite    : Result := clWhite;
+    scRed      : Result := clRed;
+    scGreen    : Result := clLime;
+    scBlue     : Result := clBlue;
+    scYellow   : Result := clYellow;
+    scMagenta  : Result := clFuchsia;
+    scCyan     : Result := clAqua;
+    scDarkRed  : Result := clMaroon;
+    scDarkGreen: Result := clGreen;
+    scDarkBlue : Result := clNavy;
+    scOlive    : Result := clOlive;
+    scPurple   : Result := clPurple;
+    scTeal     : Result := clTeal;
+    scSilver   : Result := clSilver;
+    scGrey     : Result := clGray;
+    //
+    scGrey10pct: Result := TColor($00E6E6E6);
+    scGrey20pct: Result := TColor($00CCCCCC);
+    scOrange   : Result := TColor($0000A4FF); // FFA500
+    scDarkBrown: Result := TColor($002D53A0); // A0522D
+    scBrown    : Result := TColor($003F85CD); // CD853F
+    scBeige    : Result := TColor($00DCF5F5); // F5F5DC
+    scWheat    : Result := TColor($00B3DEF5); // F5DEB3
+    else         Result := clWhite;
+  end;
+end;
+
 procedure Register;
 begin
   RegisterComponents('Additional',[TsWorksheetGrid]);
@@ -217,6 +250,7 @@ begin
     c := ACol - FixedCols;
     lCell := FWorksheet.FindCell(r, c);
     if lCell <> nil then begin
+      // Horizontal alignment
       case lCell^.HorAlignment of
         haDefault: if lCell^.ContentType = cctNumber then
                      ts.Alignment := taRightJustify
@@ -226,17 +260,26 @@ begin
         haCenter : ts.Alignment := taCenter;
         haRight  : ts.Alignment := taRightJustify;
       end;
+      // Vertical alignment
       case lCell^.VertAlignment of
         vaDefault: ts.Layout := tlBottom;
         vaTop    : ts.Layout := tlTop;
         vaCenter : ts.Layout := tlCenter;
         vaBottom : ts.layout := tlBottom;
       end;
-      // Word wrap?
+      // Word wrap
       if (uffWordWrap in lCell^.UsedFormattingFields) then begin
         ts.Wordbreak := true;
         ts.SingleLine := false;
       end;
+      // Background color
+      if (uffBackgroundColor in lCell^.UsedFormattingFields) then begin
+        Canvas.Brush.Style := bsSolid;
+        Canvas.Brush.Color := FPSColorToColor(lCell^.BackgroundColor);
+      end else begin
+        Canvas.Brush.Style := bsSolid;
+        Canvas.Brush.Color := Color;
+      end;
     end;
   end;
   Canvas.TextStyle := ts;

components/fpspreadsheet/tests/formattests.pas

@@ -53,6 +53,8 @@ type
     procedure TestWriteReadWordWrap;
     // Test alignments
     procedure TestWriteReadAlignments;
+    // Test background colors
+    procedure TestWriteReadBackgroundColors;
   end;
 
 implementation
@@ -362,9 +364,9 @@ begin
       if MyCell = nil then
         fail('Error in test code. Failed to get cell.');
       CheckEquals(vertAlign = MyCell^.VertAlignment, true,
-        'Test unsaved word vertical alignment, cell ' + CellNotation(MyWorksheet,0,0));
+        'Test unsaved vertical alignment, cell ' + CellNotation(MyWorksheet,0,0));
       CheckEquals(horAlign = MyCell^.HorAlignment, true,
-        'Test unsaved word horizontal alignment, cell ' + CellNotation(MyWorksheet,0,0));
+        'Test unsaved horizontal alignment, cell ' + CellNotation(MyWorksheet,0,0));
       inc(col);
     end;
     inc(row);
@@ -396,6 +398,62 @@ begin
   DeleteFile(TempFile);
 end;
 
+procedure TSpreadWriteReadFormatTests.TestWriteReadBackgroundColors;
+// see also "manualtests".
+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
+  color: TsColor;
+begin
+  TempFile:=GetTempFileName;
+  {// Not needed: use workbook.writetofile with overwrite=true
+  if fileexists(TempFile) then
+    DeleteFile(TempFile);
+  }
+  // Write out all colors
+  MyWorkbook := TsWorkbook.Create;
+  MyWorkSheet:= MyWorkBook.AddWorksheet(FmtNumbersSheet);
+
+  row := 0;
+  col := 0;
+  for color := Low(TsColor) to scGrey20pct do begin  // !!! other colors not working yet!
+//  for color in TsColor do begin            // this is the full test - failing!
+    MyWorksheet.WriteUTF8Text(row, col, CELLTEXT);
+    MyWorksheet.WriteBackgroundColor(row, col, color);
+    MyCell := MyWorksheet.FindCell(row, col);
+    if MyCell = nil then
+      fail('Error in test code. Failed to get cell.');
+    CheckEquals(color = MyCell^.BackgroundColor, true,
+      'Test unsaved background color, cell ' + CellNotation(MyWorksheet,0,0));
+    inc(row);
+  end;
+  MyWorkBook.WriteToFile(TempFile,sfExcel8,true);
+  MyWorkbook.Free;
+
+  // Open the spreadsheet, as biff8
+  MyWorkbook := TsWorkbook.Create;
+  MyWorkbook.ReadFromFile(TempFile, sfExcel8);
+  MyWorksheet:=GetWorksheetByName(MyWorkBook, FmtNumbersSheet);
+  if MyWorksheet=nil then
+    fail('Error in test code. Failed to get named worksheet');
+  for row := 0 to MyWorksheet.GetLastRowNumber do begin
+    MyCell := MyWorksheet.FindCell(row, col);
+    if MyCell = nil then
+      fail('Error in test code. Failed to get cell.');
+    color := TsColor(row);
+    CheckEquals(color = MyCell^.BackgroundColor, true,
+      'Test saved background color, cell '+CellNotation(MyWorksheet,Row,Col));
+  end;
+  MyWorkbook.Free;
+
+  DeleteFile(TempFile);
+end;
+
 
 initialization
   RegisterTest(TSpreadWriteReadFormatTests);

components/fpspreadsheet/xlsbiff8.pas

@@ -70,6 +70,7 @@ type
     VertAlignment: TsVertAlignment;
     WordWrap: Boolean;
     Borders: TsCellBorders;
+    BackgroundColor: TsColor;
     {
     FontIndex: Integer;
     Border: TsBorder;
@@ -1627,9 +1628,12 @@ begin
   // Add a background, if desired
   if AddBackground then XFBorderDWord2 := XFBorderDWord2 or $4000000;
   AStream.WriteDWord(DWordToLE(XFBorderDWord2));
+
   // Background Pattern Color, always zeroed
-  if AddBackground then AStream.WriteWord(WordToLE(FPSColorToEXCELPalette(ABackgroundColor)))
+  if AddBackground then
-  else AStream.WriteWord(0);
+    AStream.WriteWord(WordToLE(FPSColorToEXCELPalette(ABackgroundColor)))
+  else
+    AStream.WriteWord(0);
 end;
 
 { TsSpreadBIFF8Reader }
@@ -2110,6 +2114,10 @@ begin
       lCell^.Border := XFData.Borders;
     end else
       Exclude(lCell^.UsedFormattingFields, uffBorder);
+
+    // Background color
+    Include(lCell^.UsedFormattingFields, uffBackgroundColor);
+    lCell^.BackgroundColor := XFData.BackgroundColor;
   end;
 end;
 
@@ -2475,6 +2483,10 @@ begin
   if xf.Border_Background_1 and MASK_XF_BORDER_BOTTOM <> 0 then
     Include(lData.Borders, cbSouth);
 
+  // Background color;
+  xf.Border_Background_3 := WordLEToN(xf.Border_Background_3);
+  lData.BackgroundColor := ExcelPaletteToFPSColor(xf.Border_Background_3 AND $007F);
+
   // Add the XF to the list
   FXFList.Add(lData);
 end;

components/fpspreadsheet/xlscommon.pas

@@ -284,6 +284,8 @@ type
     FCodepage: string; // in a format prepared for lconvencoding.ConvertEncoding
     FDateMode: TDateMode;
     constructor Create; override;
+    // converts an Excel color index to a color value.
+    function ExcelPaletteToFPSColor(AIndex: Word): TsColor;
     // Here we can add reading of records which didn't change across BIFF2-8 versions
     // Workbook Globals records
     procedure ReadCodePage(AStream: TStream);
@@ -386,6 +388,31 @@ begin
   FDateMode := dm1900;
 end;
 
+function TsSpreadBIFFReader.ExcelPaletteToFPSColor(AIndex: Word): TsColor;
+begin
+  case AIndex of
+    BUILT_IN_COLOR_PALLETE_BLACK : Result := scBlack;
+    BUILT_IN_COLOR_PALLETE_WHITE: Result := scWhite;
+    BUILT_IN_COLOR_PALLETE_RED: Result := scRed;
+    BUILT_IN_COLOR_PALLETE_GREEN: Result := scGreen;
+    BUILT_IN_COLOR_PALLETE_BLUE: Result := scBlue;
+    BUILT_IN_COLOR_PALLETE_YELLOW: Result := scYellow;
+    BUILT_IN_COLOR_PALLETE_MAGENTA: Result := scMagenta;
+    BUILT_IN_COLOR_PALLETE_CYAN: Result := scCyan;
+    BUILT_IN_COLOR_PALLETE_DARK_RED: Result := scDarkRed;
+    BUILT_IN_COLOR_PALLETE_DARK_GREEN: Result := scDarkGreen;
+    BUILT_IN_COLOR_PALLETE_DARK_BLUE: Result := scDarkBlue;
+    BUILT_IN_COLOR_PALLETE_OLIVE: Result := scOlive;
+    BUILT_IN_COLOR_PALLETE_PURPLE: Result := scPurple;
+    BUILT_IN_COLOR_PALLETE_TEAL: Result := scTeal;
+    BUILT_IN_COLOR_PALLETE_SILVER: Result := scSilver;
+    BUILT_IN_COLOR_PALLETE_GREY: Result := scGrey;
+    //
+    EXTRA_COLOR_PALETTE_GREY10PCT: Result := scGrey10pct;
+    EXTRA_COLOR_PALETTE_GREY20PCT: Result := scGrey20pct;
+  end;
+end;
+
 // In BIFF 8 it seams to always use the UTF-16 codepage
 procedure TsSpreadBIFFReader.ReadCodePage(AStream: TStream);
 var