fpspreadsheet: Implementing reading of xlsx theme colors which are found in many xlsx files. Not quite correct yet.

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

components/fpspreadsheet/fpsutils.pas

@@ -12,7 +12,8 @@ unit fpsutils;
 interface
 
 uses
-  Classes, SysUtils, StrUtils, fpspreadsheet, fpsNumFormatParser;
+  Classes, SysUtils, StrUtils,
+  fpspreadsheet, fpsNumFormatParser;
 
 // Exported types
 type
@@ -138,6 +139,8 @@ procedure AppendToStream(AStream: TStream; const AString1, AString2, AString3: S
 
 function PosInMemory(AMagic: QWord; ABuffer: PByteArray; ABufSize: Integer): Integer;
 
+function TintedColor(AColor: TsColorValue; tint: Double): TsColorValue;
+
 procedure Unused(const A1);
 procedure Unused(const A1, A2);
 procedure Unused(const A1, A2, A3);
@@ -1987,6 +1990,148 @@ begin
   end;
 end;
 
+{ Modifying colors }
+{ Next function are copies of GraphUtils to avoid a dependence on the Graphics unit. }
+
+const
+  HUE_000 = 0;
+  HUE_060 = 43;
+  HUE_120 = 85;
+  HUE_180 = 128;
+  HUE_240 = 170;
+  HUE_300 = 213;
+
+procedure RGBtoHLS(const R, G, B: Byte; out H, L, S: Byte);
+var
+  cMax, cMin: Byte;             // max and min RGB values
+  Rdelta, Gdelta, Bdelta: Byte; // intermediate value: % of spread from max
+  diff: Byte;
+begin
+  // calculate lightness
+  cMax := MaxIntValue([R, G, B]);
+  cMin := MinIntValue([R, G, B]);
+  L := (integer(cMax) + cMin + 1) div 2;
+  diff := cMax - cMin;
+
+  if diff = 0
+  then begin
+    // r=g=b --> achromatic case
+    S := 0;
+    H := 0;
+  end
+  else begin
+    // chromatic case
+    // saturation
+    if L <= 128
+    then S := integer(diff * 255) div (cMax + cMin)
+    else S := integer(diff * 255) div (510 - cMax - cMin);
+
+    // hue
+    Rdelta := (cMax - R);
+    Gdelta := (cMax - G);
+    Bdelta := (cMax - B);
+
+    if R = cMax
+    then H := (HUE_000 + integer(Bdelta - Gdelta) * HUE_060 div diff) and $ff
+    else if G = cMax
+    then H := HUE_120 + integer(Rdelta - Bdelta) * HUE_060 div diff
+    else H := HUE_240 + integer(Gdelta - Rdelta) * HUE_060 div diff;
+  end;
+end;
+
+
+procedure HLStoRGB(const H, L, S: Byte; out R, G, B: Byte);
+
+  // utility routine for HLStoRGB
+  function HueToRGB(const n1, n2: Byte; Hue: Integer): Byte;
+  begin
+    if Hue > 255
+    then Dec(Hue, 255)
+    else if Hue < 0
+    then Inc(Hue, 255);
+
+    // return r,g, or b value from this tridrant
+    case Hue of
+      HUE_000..HUE_060 - 1: Result := n1 + (n2 - n1) * Hue div HUE_060;
+      HUE_060..HUE_180 - 1: Result := n2;
+      HUE_180..HUE_240 - 1: Result := n1 + (n2 - n1) * (HUE_240 - Hue) div HUE_060;
+    else
+      Result := n1;
+    end;
+  end;
+
+var
+  n1, n2: Byte;
+begin
+  if S = 0
+  then begin
+    // achromatic case
+    R := L;
+    G := L;
+    B := L;
+  end
+  else begin
+    // chromatic case
+    // set up magic numbers
+    if L < 128
+    then begin
+      n2 := L + (L * S) div 255;
+      n1 := 2 * L - n2;
+    end
+    else begin
+      n2 := S + L - (L * S) div 255;
+      n1 := 2 * L - n2 - 1;
+    end;
+
+
+    // get RGB
+    R := HueToRGB(n1, n2, H + HUE_120);
+    G := HueToRGB(n1, n2, H);
+    B := HueToRGB(n1, n2, H - HUE_120);
+  end;
+end;
+
+{ Excel defines theme colors and applies a "tint" factor (-1...+1) to darken
+  or brighten them.
+  The algorithm is described in
+  http://msdn.microsoft.com/en-us/library/documentformat.openxml.spreadsheet.backgroundcolor.aspx
+  (with the exception that max hue is 240, nur 255!)
+}
+function TintedColor(AColor: TsColorValue; tint: Double): TsColorValue;
+type
+  TRGBA = record r, g, b, a: byte end;
+const
+  HLSMAX = 255;
+var
+  r, g, b: byte;
+  h, l, s: Byte;
+  lum: Double;
+begin
+  if tint = 0 then begin
+    Result := AColor;
+    exit;
+  end;
+
+  r := TRGBA(AColor).r;
+  g := TRGBA(AColor).g;
+  b := TRGBA(AColor).b;
+  RGBToHLS(r, g, b, h, l, s);
+
+  lum := l;
+  if tint < 0 then
+    lum := lum * (1.0 + tint)
+  else
+  if tint > 0 then
+    lum := lum * (1.0-tint) + (HLSMAX - HLSMAX * (1.0-tint));
+  l := Min(255, round(lum));
+  HLSToRGB(h, l, s, r, g, b);
+
+  TRGBA(Result).r := r;
+  TRGBA(Result).g := g;
+  TRGBA(Result).b := b;
+  TRGBA(Result).a := 0;
+end;
+
 {$PUSH}{$HINTS OFF}
 {@@ Silence warnings due to an unused parameter }
 procedure Unused(const A1);

components/fpspreadsheet/fpsxmlcommon.pas

@@ -29,9 +29,12 @@ var
   i: integer;
   Found: Boolean;
 begin
+  Result := '';
+  if ANode = nil then
+    exit;
+
   Found := false;
   i := 0;
-  Result := '';
   while not Found and (i < ANode.Attributes.Length) do begin
     if ANode.Attributes.Item[i].NodeName = AAttrName then begin
       Found := true;

components/fpspreadsheet/tests/spreadtestgui.lpi

@@ -83,12 +83,10 @@
       <Unit8>
         <Filename Value="colortests.pas"/>
         <IsPartOfProject Value="True"/>
-        <UnitName Value="colortests"/>
       </Unit8>
       <Unit9>
         <Filename Value="fonttests.pas"/>
         <IsPartOfProject Value="True"/>
-        <UnitName Value="fonttests"/>
       </Unit9>
       <Unit10>
         <Filename Value="optiontests.pas"/>
@@ -98,7 +96,6 @@
       <Unit11>
         <Filename Value="numformatparsertests.pas"/>
         <IsPartOfProject Value="True"/>
-        <UnitName Value="numformatparsertests"/>
       </Unit11>
       <Unit12>
         <Filename Value="rpnformulaunit.pas"/>
@@ -133,9 +130,6 @@
         <DebugInfoType Value="dsDwarf2Set"/>
       </Debugging>
     </Linking>
-    <Other>
-      <CompilerPath Value="$(CompPath)"/>
-    </Other>
   </CompilerOptions>
   <Debugging>
     <Exceptions Count="6">

components/fpspreadsheet/xlsxooxml.pas

@@ -64,10 +64,12 @@ type
     FXfList: TFPList;
     FFillList: TFPList;
     FBorderList: TFPList;
+    FThemeColors: array of TsColorValue;
     FWrittenByFPS: Boolean;
     procedure ReadBorders(ANode: TDOMNode);
     procedure ReadCell(ANode: TDOMNode; AWorksheet: TsWorksheet);
     procedure ReadCellXfs(ANode: TDOMNode);
+    function  ReadColor(ANode: TDOMNode): TsColor;
     procedure ReadCols(ANode: TDOMNode; AWorksheet: TsWorksheet);
     procedure ReadDateMode(ANode: TDOMNode);
     procedure ReadFileVersion(ANode: TDOMNode);
@@ -80,6 +82,8 @@ type
     procedure ReadSharedStrings(ANode: TDOMNode);
     procedure ReadSheetList(ANode: TDOMNode; AList: TStrings);
     procedure ReadSheetViews(ANode: TDOMNode; AWorksheet: TsWorksheet);
+    procedure ReadThemeElements(ANode: TDOMNode);
+    procedure ReadThemeColors(ANode: TDOMNode);
     procedure ReadWorksheet(ANode: TDOMNode; AWorksheet: TsWorksheet);
   protected
     procedure ApplyCellFormatting(ACell: PCell; XfIndex: Integer);
@@ -159,23 +163,24 @@ uses
 
 const
   { OOXML general XML constants }
-  XML_HEADER           = '<?xml version="1.0" encoding="utf-8" ?>';
+  XML_HEADER               = '<?xml version="1.0" encoding="utf-8" ?>';
 
   { OOXML Directory structure constants }
   // Note: directory separators are always / because the .xlsx is a zip file which
   // requires / instead of \, even on Windows; see 
   // http://www.pkware.com/documents/casestudies/APPNOTE.TXT
   // 4.4.17.1 All slashes MUST be forward slashes '/' as opposed to backwards slashes '\'
-  OOXML_PATH_TYPES     = '[Content_Types].xml';
+  OOXML_PATH_TYPES         = '[Content_Types].xml';
-  OOXML_PATH_RELS      = '_rels/';
+  OOXML_PATH_RELS          = '_rels/';
-  OOXML_PATH_RELS_RELS = '_rels/.rels';
+  OOXML_PATH_RELS_RELS     = '_rels/.rels';
-  OOXML_PATH_XL        = 'xl/';
+  OOXML_PATH_XL            = 'xl/';
-  OOXML_PATH_XL_RELS   = 'xl/_rels/';
+  OOXML_PATH_XL_RELS       = 'xl/_rels/';
-  OOXML_PATH_XL_RELS_RELS = 'xl/_rels/workbook.xml.rels';
+  OOXML_PATH_XL_RELS_RELS  = 'xl/_rels/workbook.xml.rels';
-  OOXML_PATH_XL_WORKBOOK = 'xl/workbook.xml';
+  OOXML_PATH_XL_WORKBOOK   = 'xl/workbook.xml';
-  OOXML_PATH_XL_STYLES   = 'xl/styles.xml';
+  OOXML_PATH_XL_STYLES     = 'xl/styles.xml';
-  OOXML_PATH_XL_STRINGS  = 'xl/sharedStrings.xml';
+  OOXML_PATH_XL_STRINGS    = 'xl/sharedStrings.xml';
   OOXML_PATH_XL_WORKSHEETS = 'xl/worksheets/';
+  OOXML_PATH_XL_THEME      = 'xl/theme/theme1.xml';
 
   { OOXML schemas constants }
   SCHEMAS_TYPES        = 'http://schemas.openxmlformats.org/package/2006/content-types';
@@ -440,6 +445,8 @@ procedure TsSpreadOOXMLReader.ReadBorders(ANode: TDOMNode);
     while Assigned(colorNode) do begin
       nodeName := colorNode.NodeName;
       if nodeName = 'color' then begin
+        ABorderStyle.Color := ReadColor(colorNode);
+        {
         s := GetAttrValue(colorNode, 'rgb');
         if s <> '' then
           ABorderStyle.Color := FWorkbook.AddColorToPalette(HTMLColorStrToColor('#' + s))
@@ -448,6 +455,7 @@ procedure TsSpreadOOXMLReader.ReadBorders(ANode: TDOMNode);
           if s <> '' then
             ABorderStyle.Color := StrToInt(s);
         end;
+        }
       end;
       colorNode := colorNode.NextSibling;
     end;
@@ -697,6 +705,50 @@ begin
   end;
 end;
 
+function TsSpreadOOXMLReader.ReadColor(ANode: TDOMNode): TsColor;
+type
+  TRGBA = record r,g,b,a: Byte end;
+var
+  s: String;
+  rgb: TsColorValue;
+  rgba: TRGBA absolute(rgb);  // just for debugging
+  idx: Integer;
+  tint: Double;
+begin
+  Assert(ANode <> nil);
+
+  s := GetAttrValue(ANode, 'rgb');
+  if s <> '' then begin
+    Result := FWorkbook.AddColorToPalette(HTMLColorStrToColor('#' + s));
+    exit;
+  end;
+
+  s := GetAttrValue(ANode, 'indexed');
+  if s <> '' then begin
+    Result := StrToInt(s);
+    if (Result >= FWorkbook.GetPaletteSize) then
+      Result := scBlack;
+    exit;
+  end;
+
+  s := GetAttrValue(ANode, 'theme');
+  if s <> '' then begin
+    idx := StrToInt(s);
+    if idx < Length(FThemeColors) then begin
+      rgb := FThemeColors[StrToInt(s)];
+      s := GetAttrValue(ANode, 'tint');
+      if s <> '' then begin
+        tint := StrToFloat(s, FPointSeparatorSettings);
+        rgb := TintedColor(rgb, tint);
+      end;
+      Result := FWorkBook.AddColorToPalette(rgb);
+      exit;
+    end;
+  end;
+
+  Result := scBlack;
+end;
+
 procedure TsSpreadOOXMLReader.ReadCols(ANode: TDOMNode; AWorksheet: TsWorksheet);
 var
   colNode: TDOMNode;
@@ -769,6 +821,8 @@ begin
         while Assigned(colorNode) do begin
           nodeName := colorNode.NodeName;
           if nodeName = 'fgColor' then begin
+            fgclr := ReadColor(colorNode);
+            {
             s := GetAttrValue(colorNode, 'rgb');
             if s <> '' then
               fgclr := FWorkbook.AddColorToPalette(HTMLColorStrToColor('#' + s))
@@ -777,9 +831,12 @@ begin
               if s <> '' then
                 fgclr := StrToInt(s);
             end;
+            }
           end
           else
           if nodeName = 'bgColor' then begin
+            bgclr := ReadColor(colorNode);
+            {
             s := GetAttrValue(colorNode, 'rgb');
             if s <> '' then
               bgclr := FWorkbook.AddColorToPalette(HTMLColorStrToColor('#' + s))
@@ -788,6 +845,7 @@ begin
               if s <> '' then
                 bgclr := StrToInt(s);
             end;
+            }
           end;
           colorNode := colorNode.NextSibling;
         end;
@@ -863,22 +921,8 @@ begin
         then fntStyles := fntStyles + [fssStrikeout];
     end
     else
-    if nodename = 'color' then begin
+    if nodename = 'color' then
-      s := GetAttrValue(node, 'rgb');
+      fntColor := ReadColor(node);
-      if s <> '' then begin
-        fntColor := FWorkbook.AddColorToPalette(HTMLColorStrToColor('#' + s));
-        node := node.NextSibling;
-        continue;
-      end;
-      s := GetAttrValue(node, 'indexed');
-      if s <> '' then begin
-        fntColor := StrToInt(s);
-        if (fntColor >= FWorkbook.GetPaletteSize) then
-          fntColor := scBlack;
-        node := node.NextSibling;
-        continue;
-      end;
-    end;
     node := node.NextSibling;
   end;
 
@@ -1031,18 +1075,6 @@ begin
   if ANode = nil then
     exit;
 
-
-{
-'<sheetViews>' +
-  '<sheetView workbookViewId="0" %s%s>'+
-    '<pane xSplit="%d" ySplit="%d" topLeftCell="%s" activePane="bottomRight" state="frozen" />' +
-    '<selection pane="topRight" activeCell="%s" sqref="%s" />' +
-    '<selection pane="bottomLeft" activeCell="%s" sqref="%s" />' +
-    '<selection pane="bottomRight" activeCell="%s" sqref="%s" />' +
-  '</sheetView>' +
-'</sheetViews>', [
-}
-
   sheetViewNode := ANode.FirstChild;
   while Assigned(sheetViewNode) do begin
     nodeName := sheetViewNode.NodeName;
@@ -1074,6 +1106,82 @@ begin
   end;
 end;
 
+procedure TsSpreadOOXMLReader.ReadThemeColors(ANode: TDOMNode);
+var
+  clrNode: TDOMNode;
+  nodeName: String;
+
+  procedure AddColor(AColorStr: String);
+  begin
+    if AColorStr <> '' then begin
+      SetLength(FThemeColors, Length(FThemeColors)+1);
+      FThemeColors[Length(FThemeColors)-1] := HTMLColorStrToColor('#' + AColorStr);
+    end;
+  end;
+
+begin
+  if not Assigned(ANode) then
+    exit;
+
+  SetLength(FThemeColors, 0);
+  clrNode := ANode.FirstChild;
+  while Assigned(clrNode) do begin
+    nodeName := clrNode.NodeName;
+    if nodeName = 'a:dk1' then
+      AddColor(GetAttrValue(clrNode.FirstChild, 'lastClr'))
+    else
+    if nodeName = 'a:lt1' then
+      AddColor(GetAttrValue(clrNode.FirstChild, 'lastClr'))
+    else
+    if nodeName = 'a:dk2' then
+      AddColor(GetAttrValue(clrNode.FirstChild, 'val'))
+    else
+    if nodeName = 'a:lt2' then
+      AddColor(GetAttrValue(clrNode.FirstChild, 'val'))
+    else
+    if nodeName = 'a:accent1' then
+      AddColor(GetAttrValue(clrNode.FirstChild, 'val'))
+    else
+    if nodeName = 'a:accent2' then
+      AddColor(GetAttrValue(clrNode.FirstChild, 'val'))
+    else
+    if nodeName = 'a:accent3' then
+      AddColor(GetAttrValue(clrNode.FirstChild, 'val'))
+    else
+    if nodeName = 'a:accent4' then
+      AddColor(GetAttrValue(clrNode.FirstChild, 'val'))
+    else
+    if nodeName = 'a:accent5' then
+      AddColor(GetAttrValue(clrNode.FirstChild, 'val'))
+    else
+    if nodeName = 'a:accent6' then
+      AddColor(GetAttrValue(clrNode.FirstChild, 'val'))
+    else
+    if nodeName = 'a:hlink' then
+      AddColor(GetAttrValue(clrNode.FirstChild, 'val'))
+    else
+    if nodeName = 'a:folHlink' then
+      AddColor(GetAttrValue(clrNode.FirstChild, 'aval'));
+    clrNode := clrNode.NextSibling;
+  end;
+end;
+
+procedure TsSpreadOOXMLReader.ReadThemeElements(ANode: TDOMNode);
+var
+  childNode: TDOMNode;
+  nodeName: String;
+begin
+  if not Assigned(ANode) then
+    exit;
+  childNode := ANode.FirstChild;
+  while Assigned(childNode) do begin
+    nodeName := childNode.NodeName;
+    if nodeName = 'a:clrScheme' then
+      ReadThemeColors(childNode);
+    childNode := childNode.NextSibling;
+  end;
+end;
+
 procedure TsSpreadOOXMLReader.ReadWorksheet(ANode: TDOMNode; AWorksheet: TsWorksheet);
 var
   rownode: TDOMNode;
@@ -1117,6 +1225,7 @@ begin
   FileList.Add(OOXML_PATH_XL_STYLES);   // styles
   FileList.Add(OOXML_PATH_XL_STRINGS);  // sharedstrings
   FileList.Add(OOXML_PATH_XL_WORKBOOK); // workbook
+  FileList.Add(OOXML_PATH_XL_THEME);    // theme
 
   try
     Unzip.UnZipFiles(AFileName,FileList);
@@ -1128,6 +1237,14 @@ begin
   Doc := nil;
   SheetList := TStringList.Create;
   try
+    // Retrieve theme colors
+    if FileExists(FilePath + OOXML_PATH_XL_THEME) then begin
+      ReadXMLFile(Doc, FilePath + OOXML_PATH_XL_THEME);
+      DeleteFile(FilePath + OOXML_PATH_XL_THEME);
+      ReadThemeElements(Doc.DocumentElement.FindNode('a:themeElements'));
+      FreeAndNil(Doc);
+    end;
+
     // process the sharedStrings.xml file
     if FileExists(FilePath + OOXML_PATH_XL_STRINGS) then begin
       ReadXMLFile(Doc, FilePath + OOXML_PATH_XL_STRINGS);