pascal/lazarus-ccr
1
0
Fork 0
Code Issues Releases Activity

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

Browse Source 
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@3397 8e941d3f-bd1b-0410-a28a-d453659cc2b4
This commit is contained in:
wp_xxyyzz
2014-07-29 22:09:29 +00:00
parent f989031cf9
commit 9206a6e753
3 changed files with 143 additions and 14 deletions
Download Patch File Download Diff File Expand all files Collapse all files

30
components/fpspreadsheet/fpspreadsheet.pas
View File

@ -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).

7
components/fpspreadsheet/tests/colortests.pas
View File

@ -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);

120
components/fpspreadsheet/xlsxooxml.pas
View File

@ -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);