paweld/lazarus-ccr
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

fpspreadsheet: Support reading of font from xlsx files. Add unit tests, 3 fails related to font color.

Browse Source 
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@3387 8e941d3f-bd1b-0410-a28a-d453659cc2b4
This commit is contained in:
wp_xxyyzz 2014-07-27 22:44:17 +00:00
parent 3ef1b5b331
commit 8c687533cf
7 changed files with 195 additions and 54 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
components/fpspreadsheet/fpsopendocument.pas
View File

@ -114,6 +114,7 @@ type
procedure ReadFormula(ARow, ACol: Word; ACellNode: TDOMNode); reintroduce;
procedure ReadLabel(ARow, ACol: Word; ACellNode: TDOMNode); reintroduce;
procedure ReadNumber(ARow, ACol: Word; ACellNode: TDOMNode); reintroduce;
public
{ General reading methods }
constructor Create(AWorkbook: TsWorkbook); override;
@ -1199,12 +1200,12 @@ begin
//unzip files into AFileName path
FilePath := GetTempDir(false);
UnZip := TUnZipper.Create;
UnZip.OutputPath := FilePath;
FileList := TStringList.Create;
try
FileList.Add('styles.xml');
FileList.Add('content.xml');
FileList.Add('settings.xml');
try
UnZip.OutputPath := FilePath;
Unzip.UnZipFiles(AFileName,FileList);
finally
FreeAndNil(FileList);

21
components/fpspreadsheet/fpspreadsheet.pas
View File

@ -806,6 +806,7 @@ type
AStyle: TsFontStyles; AColor: TsColor): Integer; overload;
function AddFont(const AFont: TsFont): Integer; overload;
procedure CopyFontList(ASource: TFPList);
procedure DeleteFont(AFontIndex: Integer);
function FindFont(const AFontName: String; ASize: Single;
AStyle: TsFontStyles; AColor: TsColor): Integer;
function GetDefaultFont: TsFont;
@ -4366,7 +4367,7 @@ end;
{@@
Reads the document from a file. This method will try to guess the format from
the extension. In the case of the ambiguous xls extension, it will simply
assume that it is BIFF8. Note that it could be BIFF2, 3, 4 or 5 too.
assume that it is BIFF8. Note that it could be BIFF2 or 5 as well.
}
procedure TsWorkbook.ReadFromFile(AFileName: string); overload;
var
@ -4711,6 +4712,23 @@ begin
end;
end;
{@@
Deletes a font.
Use with caution because this will screw up the font assignment to cells.
The only legal reason to call this method is from a reader of a file format
in which the missing font #4 of BIFF does exist.
}
procedure TsWorkbook.DeleteFont(AFontIndex: Integer);
var
fnt: TsFont;
begin
if AFontIndex < FFontList.Count then begin
fnt := TsFont(FFontList.Items[AFontIndex]);
if fnt <> nil then fnt.Free;
FFontList.Delete(AFontIndex);
end;
end;
{@@
Checks whether the font with the given specification is already contained in
the font list. Returns the index, or -1 if not found.
@ -4788,6 +4806,7 @@ begin
fnt.Free;
FFontList.Delete(i);
end;
FBuiltinFontCount := 0;
end;
{@@

5
components/fpspreadsheet/laz_fpspreadsheet.lpk
View File

@ -16,6 +16,11 @@
<UseAnsiStrings Value="False"/>
</SyntaxOptions>
</Parsing>
<Linking>
<Debugging>
<UseExternalDbgSyms Value="True"/>
</Debugging>
</Linking>
<Other>
<CustomOptions Value="$(IDEBuildOptions)"/>
</Other>

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

@ -67,6 +67,19 @@ 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 }
// 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
procedure TestWriteRead_OOXML_Font_Biff8Pal; // official biff8 palette in BIFF8 file format
procedure TestWriteRead_OOXML_Font_RandomPal; // palette 64, top 56 entries random
end;
implementation
@ -388,6 +401,48 @@ begin
TestWriteReadFontColors(sfOpenDocument, 999);
end;
{ Tests for OOXML file format }
(*
procedure TSpreadWriteReadColorTests.TestWriteRead_OOXML_Background_InternalPal;
begin
TestWriteReadBackgroundColors(sfOOXML, 0);
end;
procedure TSpreadWriteReadColorTests.TestWriteRead_OOXML_Background_Biff5Pal;
begin
TestWriteReadBackgroundColors(sfOOXML, 5);
end;
procedure TSpreadWriteReadColorTests.TestWriteRead_OOXML_Background_Biff8Pal;
begin
TestWriteReadBackgroundColors(sfOOXML, 8);
end;
procedure TSpreadWriteReadColorTests.TestWriteRead_OOXML_Background_RandomPal;
begin
TestWriteReadBackgroundColors(sfOOXML, 999);
end;
*)
procedure TSpreadWriteReadColorTests.TestWriteRead_OOXML_Font_InternalPal;
begin
TestWriteReadFontColors(sfOOXML, 0);
end;
procedure TSpreadWriteReadColorTests.TestWriteRead_OOXML_Font_Biff5Pal;
begin
TestWriteReadFontColors(sfOOXML, 5);
end;
procedure TSpreadWriteReadColorTests.TestWriteRead_OOXML_Font_Biff8Pal;
begin
TestWriteReadFontColors(sfOOXML, 8);
end;
procedure TSpreadWriteReadColorTests.TestWriteRead_OOXML_Font_RandomPal;
begin
TestWriteReadFontColors(sfOOXML, 999);
end;
initialization
RegisterTest(TSpreadWriteReadColorTests);

75
components/fpspreadsheet/tests/fonttests.pas
View File

@ -60,6 +60,12 @@ type
procedure TestWriteRead_ODS_Font_Arial;
procedure TestWriteRead_ODS_Font_TimesNewRoman;
procedure TestWriteRead_ODS_Font_CourierNew;
// OOXML test cases
procedure TestWriteRead_OOXML_Bold;
procedure TestWriteRead_OOXML_Font_Arial;
procedure TestWriteRead_OOXML_Font_TimesNewRoman;
procedure TestWriteRead_OOXML_Font_CourierNew;
end;
implementation
@ -139,7 +145,7 @@ begin
MyWorkbook := TsWorkbook.Create;
MyWorkSheet:= MyWorkBook.AddWorksheet(FontSheet);
// Write out a cell without "bold"formatting style
// Write out a cell without "bold" formatting style
row := 0;
col := 0;
MyWorksheet.WriteUTF8Text(row, col, 'not bold');
@ -149,7 +155,7 @@ begin
CheckEquals(uffBold in MyCell^.UsedFormattingFields, false,
'Test unsaved bold attribute, cell '+CellNotation(MyWorksheet,Row,Col));
// Write out a cell with "bold"formatting style
// Write out a cell with "bold" formatting style
inc(row);
MyWorksheet.WriteUTF8Text(row, col, 'bold');
MyWorksheet.WriteUsedFormatting(row, col, [uffBold]);
@ -163,7 +169,7 @@ begin
MyWorkBook.WriteToFile(TempFile, AFormat, true);
MyWorkbook.Free;
// Open the spreadsheet, as biff8
// Open the spreadsheet
MyWorkbook := TsWorkbook.Create;
MyWorkbook.ReadFromFile(TempFile, AFormat);
if AFormat = sfExcel2 then
@ -194,26 +200,6 @@ begin
DeleteFile(TempFile);
end;
procedure TSpreadWriteReadFontTests.TestWriteRead_BIFF2_Bold;
begin
TestWriteReadBold(sfExcel2);
end;
procedure TSpreadWriteReadFontTests.TestWriteRead_BIFF5_Bold;
begin
TestWriteReadBold(sfExcel5);
end;
procedure TSpreadWriteReadFontTests.TestWriteRead_BIFF8_Bold;
begin
TestWriteReadBold(sfExcel8);
end;
procedure TSpreadWriteReadFontTests.TestWriteRead_ODS_Bold;
begin
TestWriteReadBold(sfOpenDocument);
end;
procedure TSpreadWriteReadFontTests.TestWriteReadFont(AFormat: TsSpreadsheetFormat;
AFontName: String);
var
@ -261,7 +247,7 @@ begin
MyWorkBook.WriteToFile(TempFile, AFormat, true);
MyWorkbook.Free;
// Open the spreadsheet, as biff8
// Open the spreadsheet
MyWorkbook := TsWorkbook.Create;
MyWorkbook.ReadFromFile(TempFile, AFormat);
if AFormat = sfExcel2 then
@ -295,6 +281,12 @@ begin
end;
{ BIFF2 }
procedure TSpreadWriteReadFontTests.TestWriteRead_BIFF2_Bold;
begin
TestWriteReadBold(sfExcel2);
end;
procedure TSpreadWriteReadFontTests.TestWriteRead_BIFF2_Font_Arial;
begin
TestWriteReadFont(sfExcel2, 'Arial');
@ -311,6 +303,11 @@ begin
end;
{ BIFF5 }
procedure TSpreadWriteReadFontTests.TestWriteRead_BIFF5_Bold;
begin
TestWriteReadBold(sfExcel5);
end;
procedure TSpreadWriteReadFontTests.TestWriteRead_BIFF5_Font_Arial;
begin
TestWriteReadFont(sfExcel5, 'Arial');
@ -327,6 +324,11 @@ begin
end;
{ BIFF8 }
procedure TSpreadWriteReadFontTests.TestWriteRead_BIFF8_Bold;
begin
TestWriteReadBold(sfExcel8);
end;
procedure TSpreadWriteReadFontTests.TestWriteRead_BIFF8_Font_Arial;
begin
TestWriteReadFont(sfExcel8, 'Arial');
@ -343,6 +345,11 @@ begin
end;
{ ODS }
procedure TSpreadWriteReadFontTests.TestWriteRead_ODS_Bold;
begin
TestWriteReadBold(sfOpenDocument);
end;
procedure TSpreadWriteReadFontTests.TestWriteRead_ODS_Font_Arial;
begin
TestWriteReadFont(sfOpenDocument, 'Arial');
@ -358,6 +365,26 @@ begin
TestWriteReadFont(sfOpenDocument, 'Courier New');
end;
{ OOXML }
procedure TSpreadWriteReadFontTests.TestWriteRead_OOXML_Bold;
begin
TestWriteReadBold(sfOOXML);
end;
procedure TSpreadWriteReadFontTests.TestWriteRead_OOXML_Font_Arial;
begin
TestWriteReadFont(sfOOXML, 'Arial');
end;
procedure TSpreadWriteReadFontTests.TestWriteRead_OOXML_Font_TimesNewRoman;
begin
TestWriteReadFont(sfOOXML, 'Times New Roman');
end;
procedure TSpreadWriteReadFontTests.TestWriteRead_OOXML_Font_CourierNew;
begin
TestWriteReadFont(sfOOXML, 'Courier New');
end;
initialization
RegisterTest(TSpreadWriteReadFontTests);

2
components/fpspreadsheet/tests/spreadtestgui.lpi
View File

@ -112,10 +112,12 @@
<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"/>

66
components/fpspreadsheet/xlsxooxml.pas
View File

@ -64,9 +64,11 @@ type
FXfList: TFPList;
FFillList: TFPList;
FBorderList: TFPList;
FWrittenByFPS: Boolean;
procedure ReadCell(ANode: TDOMNode; AWorksheet: TsWorksheet);
procedure ReadCellXfs(ANode: TDOMNode);
procedure ReadDateMode(ANode: TDOMNode);
procedure ReadFileVersion(ANode: TDOMNode);
procedure ReadFont(ANode: TDOMNode);
procedure ReadFonts(ANode: TDOMNode);
procedure ReadNumFormats(ANode: TDOMNode);
@ -517,6 +519,11 @@ begin
end;
end;
procedure TsSpreadOOXMLReader.ReadFileVersion(ANode: TDOMNode);
begin
FWrittenByFPS := GetAttrValue(ANode, 'appName') = 'fpspreadsheet';
end;
procedure TsSpreadOOXMLReader.ReadFont(ANode: TDOMNode);
var
node: TDOMNode;
@ -530,16 +537,23 @@ var
s: String;
begin
fnt := Workbook.GetDefaultFont;
if fnt <> nil then begin
fntName := fnt.FontName;
fntSize := fnt.Size;
fntStyles := [];
fntStyles := fnt.Style;
fntColor := fnt.Color;
end else begin
fntName := 'Arial';
fntSize := 10;
fntStyles := [];
fntColor := scBlack;
end;
node := ANode.FirstChild;
while node <> nil do begin
nodename := node.NodeName;
if nodename = 'name' then begin
s := GetAttrValue(ANode, 'val');
s := GetAttrValue(node, 'val');
if s <> '' then fntName := s;
end
else
@ -549,27 +563,27 @@ begin
end
else
if nodename = 'b' then begin
if GetAttrValue(ANode, 'val') <> 'false'
if GetAttrValue(node, 'val') <> 'false'
then fntStyles := fntStyles + [fssBold];
end
else
if nodename = 'i' then begin
if GetAttrValue(ANode, 'val') <> 'false'
if GetAttrValue(node, 'val') <> 'false'
then fntStyles := fntStyles + [fssItalic];
end
else
if nodename = 'u' then begin
if GetAttrValue(ANode, 'val') <> 'false'
if GetAttrValue(node, 'val') <> 'false'
then fntStyles := fntStyles+ [fssUnderline]
end
else
if nodename = 'strike' then begin
if GetAttrValue(ANode, 'val') <> 'false'
if GetAttrValue(node, 'val') <> 'false'
then fntStyles := fntStyles + [fssStrikeout];
end
else
if nodename = 'color' then begin
s := GetAttrValue(ANode, 'rgb');
s := GetAttrValue(node, 'rgb');
if s <> '' then
fntColor := FWorkbook.AddColorToPalette(HTMLColorStrToColor('#' + s));
end;
@ -583,12 +597,29 @@ 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;
node := ANode.FirstChild;
while node <> nil do begin
ReadFont(node);
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
this index. Therefore, we delete the font #4 if the file was not written
by FPSpreadsheet. }
if not FWrittenByFPS then
FWorkbook.DeleteFont(4);
n := FWorkbook.GetFontCount;
end;
procedure TsSpreadOOXMLReader.ReadNumFormats(ANode: TDOMNode);
@ -703,6 +734,16 @@ begin
FreeAndNil(Doc);
end;
// process the workbook.xml file
if not FileExists(FilePath + OOXML_PATH_XL_WORKBOOK) then
raise Exception.Create('Defective internal structure of xlsx file');
ReadXMLFile(Doc, FilePath + OOXML_PATH_XL_WORKBOOK);
DeleteFile(FilePath + OOXML_PATH_XL_WORKBOOK);
ReadFileVersion(Doc.DocumentElement.FindNode('fileVersion'));
ReadDateMode(Doc.DocumentElement.FindNode('workbookPr'));
ReadSheetList(Doc.DocumentElement.FindNode('sheets'), SheetList);
FreeAndNil(Doc);
// process the styles.xml file
if FileExists(FilePath + OOXML_PATH_XL_STYLES) then begin // should always exist, just to make sure...
ReadXMLFile(Doc, FilePath + OOXML_PATH_XL_STYLES);
@ -713,14 +754,6 @@ begin
FreeAndNil(Doc);
end;
// process the workbook.xml file
ReadXMLFile(Doc, FilePath + OOXML_PATH_XL_WORKBOOK);
DeleteFile(FilePath + OOXML_PATH_XL_WORKBOOK);
ReadDateMode(Doc.DocumentElement.FindNode('workbookPr'));
ReadSheetList(Doc.DocumentElement.FindNode('sheets'), SheetList);
FreeAndNil(Doc);
// read worksheets
for i:=0 to SheetList.Count-1 do begin
@ -1377,7 +1410,6 @@ begin
for i:=1 to Workbook.GetWorksheetCount do
AppendToStream(FSWorkbook, Format(
'<sheet name="%s" sheetId="%d" r:id="rId%d" />', [Workbook.GetWorksheetByIndex(i-1).Name, i, i+2]));
// '<sheet name="Sheet%d" sheetId="%d" r:id="rId%d" />', [i, i, i+2]));
AppendToStream(FSWorkbook,
'</sheets>');
AppendToStream(FSWorkbook,
@ -1566,7 +1598,7 @@ begin
// Footer
AppendToStream(FSSheets[FCurSheetNum],
'</sheetData>',
'</sheetData>' +
'</worksheet>');
end;