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

fpspreadsheet: Add support for reading background colors in biff8 and fpspreadsheetgrid.

Browse Source 
Add automatic test case for colors (fails since some colors are not yet written correctly, fails also for blank cells which are not yet read).

git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@2956 8e941d3f-bd1b-0410-a28a-d453659cc2b4
This commit is contained in:
wp_xxyyzz
2014-04-20 21:51:12 +00:00
parent be497cb19e
commit b8c1cf2961
5 changed files with 146 additions and 6 deletions
Download Patch File Download Diff File Expand all files Collapse all files

2
components/fpspreadsheet/fpspreadsheet.pas
View File

@ -1938,7 +1938,7 @@ end;
Opens the file and calls WriteToStream
@param AFileName The output file name.
If the file already exists it will be replaced.
If the file already exists it will be replaced.
@param AData The Workbook to be saved.
@see TsWorkbook

45
components/fpspreadsheet/fpspreadsheetgrid.pas
View File

@ -149,6 +149,8 @@ type
property OnContextPopup;
end;
function FPSColorToColor(FPSColor: TsColor): TColor;
procedure Register;
implementation
@ -156,6 +158,37 @@ implementation
uses
fpsUtils;
function FPSColorToColor(FPSColor: TsColor): TColor;
begin
case FPSColor of
scBlack : Result := clBlack;
scWhite : Result := clWhite;
scRed : Result := clRed;
scGreen : Result := clLime;
scBlue : Result := clBlue;
scYellow : Result := clYellow;
scMagenta : Result := clFuchsia;
scCyan : Result := clAqua;
scDarkRed : Result := clMaroon;
scDarkGreen: Result := clGreen;
scDarkBlue : Result := clNavy;
scOlive : Result := clOlive;
scPurple : Result := clPurple;
scTeal : Result := clTeal;
scSilver : Result := clSilver;
scGrey : Result := clGray;
//
scGrey10pct: Result := TColor($00E6E6E6);
scGrey20pct: Result := TColor($00CCCCCC);
scOrange : Result := TColor($0000A4FF); // FFA500
scDarkBrown: Result := TColor($002D53A0); // A0522D
scBrown : Result := TColor($003F85CD); // CD853F
scBeige : Result := TColor($00DCF5F5); // F5F5DC
scWheat : Result := TColor($00B3DEF5); // F5DEB3
else Result := clWhite;
end;
end;
procedure Register;
begin
RegisterComponents('Additional',[TsWorksheetGrid]);
@ -217,6 +250,7 @@ begin
c := ACol - FixedCols;
lCell := FWorksheet.FindCell(r, c);
if lCell <> nil then begin
// Horizontal alignment
case lCell^.HorAlignment of
haDefault: if lCell^.ContentType = cctNumber then
ts.Alignment := taRightJustify
@ -226,17 +260,26 @@ begin
haCenter : ts.Alignment := taCenter;
haRight : ts.Alignment := taRightJustify;
end;
// Vertical alignment
case lCell^.VertAlignment of
vaDefault: ts.Layout := tlBottom;
vaTop : ts.Layout := tlTop;
vaCenter : ts.Layout := tlCenter;
vaBottom : ts.layout := tlBottom;
end;
// Word wrap?
// Word wrap
if (uffWordWrap in lCell^.UsedFormattingFields) then begin
ts.Wordbreak := true;
ts.SingleLine := false;
end;
// Background color
if (uffBackgroundColor in lCell^.UsedFormattingFields) then begin
Canvas.Brush.Style := bsSolid;
Canvas.Brush.Color := FPSColorToColor(lCell^.BackgroundColor);
end else begin
Canvas.Brush.Style := bsSolid;
Canvas.Brush.Color := Color;
end;
end;
end;
Canvas.TextStyle := ts;

62
components/fpspreadsheet/tests/formattests.pas
View File

@ -53,6 +53,8 @@ type
procedure TestWriteReadWordWrap;
// Test alignments
procedure TestWriteReadAlignments;
// Test background colors
procedure TestWriteReadBackgroundColors;
end;
implementation
@ -362,9 +364,9 @@ begin
if MyCell = nil then
fail('Error in test code. Failed to get cell.');
CheckEquals(vertAlign = MyCell^.VertAlignment, true,
'Test unsaved word vertical alignment, cell ' + CellNotation(MyWorksheet,0,0));
'Test unsaved vertical alignment, cell ' + CellNotation(MyWorksheet,0,0));
CheckEquals(horAlign = MyCell^.HorAlignment, true,
'Test unsaved word horizontal alignment, cell ' + CellNotation(MyWorksheet,0,0));
'Test unsaved horizontal alignment, cell ' + CellNotation(MyWorksheet,0,0));
inc(col);
end;
inc(row);
@ -396,6 +398,62 @@ begin
DeleteFile(TempFile);
end;
procedure TSpreadWriteReadFormatTests.TestWriteReadBackgroundColors;
// see also "manualtests".
const
CELLTEXT = 'Color test';
var
MyWorksheet: TsWorksheet;
MyWorkbook: TsWorkbook;
row, col: Integer;
MyCell: PCell;
TempFile: string; //write xls/xml to this file and read back from it
color: TsColor;
begin
TempFile:=GetTempFileName;
{// Not needed: use workbook.writetofile with overwrite=true
if fileexists(TempFile) then
DeleteFile(TempFile);
}
// Write out all colors
MyWorkbook := TsWorkbook.Create;
MyWorkSheet:= MyWorkBook.AddWorksheet(FmtNumbersSheet);
row := 0;
col := 0;
for color := Low(TsColor) to scGrey20pct do begin // !!! other colors not working yet!
// for color in TsColor do begin // this is the full test - failing!
MyWorksheet.WriteUTF8Text(row, col, CELLTEXT);
MyWorksheet.WriteBackgroundColor(row, col, color);
MyCell := MyWorksheet.FindCell(row, col);
if MyCell = nil then
fail('Error in test code. Failed to get cell.');
CheckEquals(color = MyCell^.BackgroundColor, true,
'Test unsaved background color, cell ' + CellNotation(MyWorksheet,0,0));
inc(row);
end;
MyWorkBook.WriteToFile(TempFile,sfExcel8,true);
MyWorkbook.Free;
// Open the spreadsheet, as biff8
MyWorkbook := TsWorkbook.Create;
MyWorkbook.ReadFromFile(TempFile, sfExcel8);
MyWorksheet:=GetWorksheetByName(MyWorkBook, FmtNumbersSheet);
if MyWorksheet=nil then
fail('Error in test code. Failed to get named worksheet');
for row := 0 to MyWorksheet.GetLastRowNumber do begin
MyCell := MyWorksheet.FindCell(row, col);
if MyCell = nil then
fail('Error in test code. Failed to get cell.');
color := TsColor(row);
CheckEquals(color = MyCell^.BackgroundColor, true,
'Test saved background color, cell '+CellNotation(MyWorksheet,Row,Col));
end;
MyWorkbook.Free;
DeleteFile(TempFile);
end;
initialization
RegisterTest(TSpreadWriteReadFormatTests);

16
components/fpspreadsheet/xlsbiff8.pas
View File

@ -70,6 +70,7 @@ type
VertAlignment: TsVertAlignment;
WordWrap: Boolean;
Borders: TsCellBorders;
BackgroundColor: TsColor;
{
FontIndex: Integer;
Border: TsBorder;
@ -1627,9 +1628,12 @@ begin
// Add a background, if desired
if AddBackground then XFBorderDWord2 := XFBorderDWord2 or $4000000;
AStream.WriteDWord(DWordToLE(XFBorderDWord2));
// Background Pattern Color, always zeroed
if AddBackground then AStream.WriteWord(WordToLE(FPSColorToEXCELPalette(ABackgroundColor)))
else AStream.WriteWord(0);
if AddBackground then
AStream.WriteWord(WordToLE(FPSColorToEXCELPalette(ABackgroundColor)))
else
AStream.WriteWord(0);
end;
{ TsSpreadBIFF8Reader }
@ -2110,6 +2114,10 @@ begin
lCell^.Border := XFData.Borders;
end else
Exclude(lCell^.UsedFormattingFields, uffBorder);
// Background color
Include(lCell^.UsedFormattingFields, uffBackgroundColor);
lCell^.BackgroundColor := XFData.BackgroundColor;
end;
end;
@ -2475,6 +2483,10 @@ begin
if xf.Border_Background_1 and MASK_XF_BORDER_BOTTOM <> 0 then
Include(lData.Borders, cbSouth);
// Background color;
xf.Border_Background_3 := WordLEToN(xf.Border_Background_3);
lData.BackgroundColor := ExcelPaletteToFPSColor(xf.Border_Background_3 AND $007F);
// Add the XF to the list
FXFList.Add(lData);
end;

27
components/fpspreadsheet/xlscommon.pas
View File

@ -284,6 +284,8 @@ type
FCodepage: string; // in a format prepared for lconvencoding.ConvertEncoding
FDateMode: TDateMode;
constructor Create; override;
// converts an Excel color index to a color value.
function ExcelPaletteToFPSColor(AIndex: Word): TsColor;
// Here we can add reading of records which didn't change across BIFF2-8 versions
// Workbook Globals records
procedure ReadCodePage(AStream: TStream);
@ -386,6 +388,31 @@ begin
FDateMode := dm1900;
end;
function TsSpreadBIFFReader.ExcelPaletteToFPSColor(AIndex: Word): TsColor;
begin
case AIndex of
BUILT_IN_COLOR_PALLETE_BLACK : Result := scBlack;
BUILT_IN_COLOR_PALLETE_WHITE: Result := scWhite;
BUILT_IN_COLOR_PALLETE_RED: Result := scRed;
BUILT_IN_COLOR_PALLETE_GREEN: Result := scGreen;
BUILT_IN_COLOR_PALLETE_BLUE: Result := scBlue;
BUILT_IN_COLOR_PALLETE_YELLOW: Result := scYellow;
BUILT_IN_COLOR_PALLETE_MAGENTA: Result := scMagenta;
BUILT_IN_COLOR_PALLETE_CYAN: Result := scCyan;
BUILT_IN_COLOR_PALLETE_DARK_RED: Result := scDarkRed;
BUILT_IN_COLOR_PALLETE_DARK_GREEN: Result := scDarkGreen;
BUILT_IN_COLOR_PALLETE_DARK_BLUE: Result := scDarkBlue;
BUILT_IN_COLOR_PALLETE_OLIVE: Result := scOlive;
BUILT_IN_COLOR_PALLETE_PURPLE: Result := scPurple;
BUILT_IN_COLOR_PALLETE_TEAL: Result := scTeal;
BUILT_IN_COLOR_PALLETE_SILVER: Result := scSilver;
BUILT_IN_COLOR_PALLETE_GREY: Result := scGrey;
//
EXTRA_COLOR_PALETTE_GREY10PCT: Result := scGrey10pct;
EXTRA_COLOR_PALETTE_GREY20PCT: Result := scGrey20pct;
end;
end;
// In BIFF 8 it seams to always use the UTF-16 codepage
procedure TsSpreadBIFFReader.ReadCodePage(AStream: TStream);
var