From c0dbb072017fa398b0bee8996507be0a58838986 Mon Sep 17 00:00:00 2001 From: wp_xxyyzz Date: Wed, 6 Aug 2014 15:49:04 +0000 Subject: [PATCH] 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 | 147 ++++++++++++- components/fpspreadsheet/fpsxmlcommon.pas | 5 +- .../fpspreadsheet/tests/spreadtestgui.lpi | 6 - components/fpspreadsheet/xlsxooxml.pas | 193 ++++++++++++++---- 4 files changed, 305 insertions(+), 46 deletions(-) diff --git a/components/fpspreadsheet/fpsutils.pas b/components/fpspreadsheet/fpsutils.pas index b82245163..fa757d486 100644 --- a/components/fpspreadsheet/fpsutils.pas +++ b/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); diff --git a/components/fpspreadsheet/fpsxmlcommon.pas b/components/fpspreadsheet/fpsxmlcommon.pas index 5a3e6b314..09368ce60 100644 --- a/components/fpspreadsheet/fpsxmlcommon.pas +++ b/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; diff --git a/components/fpspreadsheet/tests/spreadtestgui.lpi b/components/fpspreadsheet/tests/spreadtestgui.lpi index e3a5d330a..9ab1b5d1d 100644 --- a/components/fpspreadsheet/tests/spreadtestgui.lpi +++ b/components/fpspreadsheet/tests/spreadtestgui.lpi @@ -83,12 +83,10 @@ - - @@ -98,7 +96,6 @@ - @@ -133,9 +130,6 @@ - - - diff --git a/components/fpspreadsheet/xlsxooxml.pas b/components/fpspreadsheet/xlsxooxml.pas index 9dbe66616..0d45686f8 100755 --- a/components/fpspreadsheet/xlsxooxml.pas +++ b/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_HEADER = ''; { 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_RELS = '_rels/'; - OOXML_PATH_RELS_RELS = '_rels/.rels'; - OOXML_PATH_XL = 'xl/'; - OOXML_PATH_XL_RELS = 'xl/_rels/'; - OOXML_PATH_XL_RELS_RELS = 'xl/_rels/workbook.xml.rels'; - OOXML_PATH_XL_WORKBOOK = 'xl/workbook.xml'; - OOXML_PATH_XL_STYLES = 'xl/styles.xml'; - OOXML_PATH_XL_STRINGS = 'xl/sharedStrings.xml'; + OOXML_PATH_TYPES = '[Content_Types].xml'; + OOXML_PATH_RELS = '_rels/'; + OOXML_PATH_RELS_RELS = '_rels/.rels'; + OOXML_PATH_XL = 'xl/'; + OOXML_PATH_XL_RELS = 'xl/_rels/'; + OOXML_PATH_XL_RELS_RELS = 'xl/_rels/workbook.xml.rels'; + OOXML_PATH_XL_WORKBOOK = 'xl/workbook.xml'; + OOXML_PATH_XL_STYLES = 'xl/styles.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 - s := GetAttrValue(node, 'rgb'); - 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; + if nodename = 'color' then + fntColor := ReadColor(node); node := node.NextSibling; end; @@ -1031,18 +1075,6 @@ begin if ANode = nil then exit; - -{ -'' + - ''+ - '' + - '' + - '' + - '' + - '' + -'', [ -} - 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);