fpspreadsheet: OOXML reader supports background color now. Test cases passed.

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

components/fpspreadsheet/fpspreadsheet.pas

@@ -819,6 +819,7 @@ type
 
     { Color handling }
     function AddColorToPalette(AColorValue: TsColorValue): TsColor;
+    function FindClosestColor(AColorValue: TsColorValue): TsColor;
     function FPSColorToHexString(AColor: TsColor; ARGBColor: TFPColor): String;
     function GetColorName(AColorIndex: TsColor): string;
     function GetPaletteColor(AColorIndex: TsColor): TsColorValue;
@@ -4890,6 +4891,35 @@ begin
   FPalette[Result] := AColorValue;
 end;
 
+{@@
+  Finds the palette color index which points to a color that is closest to a
+  given color. "Close" means here smallest length of the rgb-difference vector.
+
+  @param   AColorValue   Rgb color value to be considered
+  @return  Palette index of the color closest to AColorValue
+}
+function TsWorkbook.FindClosestColor(AColorValue: TsColorValue): TsColor;
+type
+  TRGBA = record r,g,b, a: Byte end;
+var
+  rgb: TRGBA;
+  rgb0: TRGBA absolute AColorValue;
+  dist: Double;
+  mindist: Double;
+  i: Integer;
+begin
+  Result := scNotDefined;
+  mindist := 1E108;
+  for i:=0 to Length(FPalette)-1 do begin
+    rgb := TRGBA(GetPaletteColor(i));
+    dist := sqr(rgb.r - rgb0.r) + sqr(rgb.g - rgb0.g) + sqr(rgb.b - rgb0.b);
+    if dist < mindist then begin
+      Result := i;
+      mindist := dist;
+    end;
+  end;
+end;
+
 {@@
   Converts a fpspreadsheet color into into a string RRGGBB.
   Note that colors are written to xls files as ABGR (where A is 0).

components/fpspreadsheet/tests/colortests.pas

@@ -67,14 +67,12 @@ type
     procedure TestWriteRead_ODS_Font_Biff8Pal;             // official biff8 palette in BIFF8 file format
     procedure TestWriteRead_ODS_Font_RandomPal;            // palette 64, top 56 entries random
 
-    { OpenDocument file format tests }
+    { OOXML file format tests }
     // Background colors...
-    (*
     procedure TestWriteRead_OOXML_Background_InternalPal;  // internal palette
     procedure TestWriteRead_OOXML_Background_Biff5Pal;     // official biff5 palette
     procedure TestWriteRead_OOXML_Background_Biff8Pal;     // official biff8 palette
     procedure TestWriteRead_OOXML_Background_RandomPal;    // palette 64, top 56 entries random
-    *)
     // Font colors...
     procedure TestWriteRead_OOXML_Font_InternalPal;        // internal palette for BIFF8 file format
     procedure TestWriteRead_OOXML_Font_Biff5Pal;           // official biff5 palette in BIFF8 file format
@@ -402,7 +400,6 @@ begin
 end;
 
 { Tests for OOXML file format }
-(*
 procedure TSpreadWriteReadColorTests.TestWriteRead_OOXML_Background_InternalPal;
 begin
   TestWriteReadBackgroundColors(sfOOXML, 0);
@@ -422,7 +419,7 @@ procedure TSpreadWriteReadColorTests.TestWriteRead_OOXML_Background_RandomPal;
 begin
   TestWriteReadBackgroundColors(sfOOXML, 999);
 end;
-  *)
+
 procedure TSpreadWriteReadColorTests.TestWriteRead_OOXML_Font_InternalPal;
 begin
   TestWriteReadFontColors(sfOOXML, 0);

components/fpspreadsheet/xlsxooxml.pas

@@ -69,6 +69,7 @@ type
     procedure ReadCellXfs(ANode: TDOMNode);
     procedure ReadDateMode(ANode: TDOMNode);
     procedure ReadFileVersion(ANode: TDOMNode);
+    procedure ReadFills(ANode: TDOMNode);
     procedure ReadFont(ANode: TDOMNode);
     procedure ReadFonts(ANode: TDOMNode);
     procedure ReadNumFormats(ANode: TDOMNode);
@@ -190,6 +191,12 @@ const
   MIME_STRINGS         = MIME_SPREADML + '.sharedStrings+xml';
 
 type
+  TFillListData = class
+    PatternType: String;
+    FgColor: TsColor;
+    BgColor: Tscolor;
+  end;
+
   TXFListData = class
     NumFmtIndex: Integer;
     FontIndex: Integer;
@@ -313,6 +320,7 @@ procedure TsSpreadOOXMLReader.ApplyCellFormatting(ACell: PCell; XfIndex: Integer
 var
   xf: TXfListData;
   numFmtData: TsNumFormatData;
+  fillData: TFillListData;
   j: Integer;
 begin
   if Assigned(ACell) then begin
@@ -350,14 +358,15 @@ begin
       ACell^.Border := xf.Borders;
     end else
       Exclude(ACell^.UsedFormattingFields, uffBorder);
+      *)
 
     // Background color
-    if xf.BackgroundColor <> scTransparent then begin
+    fillData := FFillList[xf.FillIndex];
+    if (fillData <> nil) and (fillData.PatternType <> 'none') then begin
       Include(ACell^.UsedFormattingFields, uffBackgroundColor);
-      ACell^.BackgroundColor := xf.BackgroundColor;
+      ACell^.BackgroundColor := fillData.FgColor;
     end else
       Exclude(ACell^.UsedFormattingFields, uffBackgroundColor);
-      *)
 
     if xf.NumFmtIndex > 0 then begin
       j := NumFormatList.FindByIndex(xf.NumFmtIndex);
@@ -526,6 +535,104 @@ begin
   FWrittenByFPS := GetAttrValue(ANode, 'appName') = 'fpspreadsheet';
 end;
 
+procedure TsSpreadOOXMLReader.ReadFills(ANode: TDOMNode);
+var
+  fillNode, patternNode, colorNode: TDOMNode;
+  nodeName: String;
+  filldata: TFillListData;
+  s: String;
+  patt: String;
+  fgclr: TsColor;
+  bgclr: TsColor;
+  ci: TsColor;
+begin
+  if ANode = nil then
+    exit;
+
+  fillNode := ANode.FirstChild;
+  while Assigned(fillNode) do begin
+    nodename := fillNode.NodeName;
+    patternNode := fillNode.FirstChild;
+    while Assigned(patternNode) do begin
+      nodename := patternNode.NodeName;
+      if nodename = 'patternFill' then begin
+        patt := GetAttrValue(patternNode, 'patternType');
+        fgclr := scWhite;
+        bgclr := scBlack;
+        colorNode := patternNode.FirstChild;
+        while Assigned(colorNode) do begin
+          nodeName := colorNode.NodeName;
+          if nodeName = 'fgColor' then begin
+            s := GetAttrValue(colorNode, 'rgb');
+            if s <> '' then
+              fgclr := FWorkbook.AddColorToPalette(HTMLColorStrToColor('#' + s))
+            else begin
+              s := GetAttrValue(colorNode, 'indexed');
+              if s <> '' then
+                fgclr := StrToInt(s);
+            end;
+          end
+          else
+          if nodeName = 'bgColor' then begin
+            s := GetAttrValue(colorNode, 'rgb');
+            if s <> '' then
+              bgclr := FWorkbook.AddColorToPalette(HTMLColorStrToColor('#' + s))
+            else begin
+              s := GetAttrValue(colorNode, 'indexed');
+              if s <> '' then
+                bgclr := StrToInt(s);
+            end;
+          end;
+          colorNode := colorNode.NextSibling;
+        end;
+
+        // Store in FFillList
+        fillData := TFillListData.Create;
+        fillData.PatternType := patt;
+        fillData.FgColor := fgclr;
+        fillData.BgColor := bgclr;
+        FFillList.Add(fillData);
+      end;
+      patternNode := patternNode.NextSibling;
+    end;
+    fillNode := fillNode.NextSibling;
+  end;
+end;
+
+(*
+AppendToStream(AStream, Format(
+  '<fills count="%d">', [Length(FFillList)]));
+
+// index 0 -- built-in empty fill
+AppendToStream(AStream,
+    '<fill>',
+      '<patternFill patternType="none" />',
+    '</fill>');
+
+// index 1 -- built-in gray125 pattern
+AppendToStream(AStream,
+    '<fill>',
+      '<patternFill patternType="gray125" />',
+    '</fill>');
+
+// user-defined fills
+for i:=2 to High(FFillList) do begin
+  styleCell := FFillList[i];
+  rgb := Workbook.GetPaletteColor(styleCell^.BackgroundColor);
+  AppendToStream(AStream,
+    '<fill>',
+      '<patternFill patternType="solid">');
+  AppendToStream(AStream, Format(
+        '<fgColor rgb="%s" />', [Copy(ColorToHTMLColorStr(rgb), 2, 255)]),
+        '<bgColor indexed="64" />');
+  AppendToStream(AStream,
+      '</patternFill>',
+    '</fill>');
+end;
+
+AppendToStream(FSStyles,
+  '</fills>');
+*)
 procedure TsSpreadOOXMLReader.ReadFont(ANode: TDOMNode);
 var
   node: TDOMNode;
@@ -610,7 +717,6 @@ end;
 procedure TsSpreadOOXMLReader.ReadFonts(ANode: TDOMNode);
 var
   node: TDOMNode;
-  n: Integer;
 begin
   // Clear existing fonts. They will be replaced by those from the file.
   FWorkbook.RemoveAllFonts;
@@ -621,8 +727,6 @@ begin
     node := node.NextSibling;
   end;
 
-  n := FWorkbook.GetFontCount;
-
   { A problem is caused by the font #4 which is missing in BIFF file versions.
     FPSpreadsheet writes a nil value to this position in order to keep compatibility
     with other file formats. Other applications, however, have a valid font at
@@ -630,9 +734,6 @@ begin
     by FPSpreadsheet. }
   if not FWrittenByFPS then
     FWorkbook.DeleteFont(4);
-
-  n := FWorkbook.GetFontCount;
-
 end;
 
 procedure TsSpreadOOXMLReader.ReadNumFormats(ANode: TDOMNode);
@@ -801,6 +902,7 @@ begin
       DeleteFile(FilePath + OOXML_PATH_XL_STYLES);
       ReadPalette(Doc.DocumentElement.FindNode('colors'));
       ReadFonts(Doc.DocumentElement.FindNode('fonts'));
+      ReadFills(Doc.DocumentElement.FindNode('fills'));
       ReadNumFormats(Doc.DocumentElement.FindNode('numFmts'));
       ReadCellXfs(Doc.DocumentElement.FindNode('cellXfs'));
       FreeAndNil(Doc);