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

fpspreadsheet: Add background fill styles for cells. Fully implemented for Biff5, Biff8 and OOXML; ODS writes an interpolated solid fill (like Open/LibreOffice); Biff2 supports only the 50% gray black&white fill.

Browse Source 
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@3949 8e941d3f-bd1b-0410-a28a-d453659cc2b4
This commit is contained in:
wp_xxyyzz
2015-02-17 23:32:00 +00:00
parent 08d24d46a6
commit dd4e66216a
17 changed files with 730 additions and 131 deletions
Download Patch File Download Diff File Expand all files Collapse all files

6
components/fpspreadsheet/examples/fpsctrls/main.lfm
View File

@ -529,6 +529,12 @@ object MainForm: TMainForm
Caption = 'ToolButton52'
Style = tbsDivider
end
object ToolButton4: TToolButton
Left = 427
Top = 0
Caption = 'ToolButton4'
OnClick = ToolButton4Click
end
end
object ToolBar3: TToolBar
Left = 0

7
components/fpspreadsheet/examples/fpsctrls/main.pas
View File

@ -262,6 +262,7 @@ type
ToolButton38: TToolButton;
ToolButton39: TToolButton;
TbCommentAdd: TToolButton;
ToolButton4: TToolButton;
ToolButton40: TToolButton;
ToolButton41: TToolButton;
ToolButton42: TToolButton;
@ -291,6 +292,7 @@ type
procedure AcRowDeleteExecute(Sender: TObject);
procedure AcViewInspectorExecute(Sender: TObject);
procedure InspectorTabControlChange(Sender: TObject);
procedure ToolButton4Click(Sender: TObject);
private
{ private declarations }
procedure UpdateCaption;
@ -395,6 +397,11 @@ begin
Inspector.Mode := TsInspectorMode(InspectorTabControl.TabIndex);
end;
procedure TMainForm.ToolButton4Click(Sender: TObject);
begin
WorksheetGrid.Worksheet.WriteBackgroundColor(0, 0, scRed);
end;
procedure TMainForm.UpdateCaption;
begin
if WorkbookSource = nil then

9
components/fpspreadsheet/fpsactions.pas
View File

@ -1469,8 +1469,13 @@ begin
FBackgroundColor := scNotDefined;
if (ACell <> nil) then begin
fmt := Workbook.GetPointerToCellFormat(ACell^.FormatIndex);
if (uffBackgroundColor in fmt^.UsedFormattingFields) then
FBackgroundColor := fmt^.BackgroundColor;
if (uffBackground in fmt^.UsedFormattingFields) then
begin
if fmt^.Background.Style = fsSolidFill then
FBackgroundColor := fmt^.Background.FgColor
else
FBackgroundColor := fmt^.Background.BgColor;
end;
end;
end;

48
components/fpspreadsheet/fpsopendocument.pas
View File

@ -2364,10 +2364,15 @@ begin
s := GetAttrValue(styleChildNode, 'fo:background-color');
if (s <> '') and (s <> 'transparent') then begin
clr := HTMLColorStrToColor(s);
fmt.BackgroundColor := ifThen(clr = TsColorValue(-1), scNotDefined,
Workbook.AddColorToPalette(clr));
if (fmt.BackgroundColor <> scNotDefined) then
Include(fmt.UsedFormattingFields, uffBackgroundColor);
// ODS does not support background fill patterns!
fmt.Background.FgColor := IfThen(clr = TsColorValue(-1),
scTransparent, Workbook.AddColorToPalette(clr));
fmt.Background.BgColor := fmt.Background.FgColor;
if (fmt.Background.BgColor <> scTransparent) then
begin
fmt.Background.Style := fsSolidFill;
Include(fmt.UsedFormattingFields, uffBackground);
end;
end;
// Borders
s := GetAttrValue(styleChildNode, 'fo:border');
@ -3531,17 +3536,48 @@ end;
Creates an XML string for inclusion of the background color into the
written file from the backgroundcolor setting in the given format record.
Is called from WriteStyles (via WriteStylesXMLAsString).
NOTE: ODS does not support fill patterns. Fill patterns are converted to
solid fills by mixing pattern and background colors in the ratio defined
by the fill pattern. Result agrees with that what LO/OO show for an imported
xls file.
-------------------------------------------------------------------------------}
function TsSpreadOpenDocWriter.WriteBackgroundColorStyleXMLAsString(
const AFormat: TsCellFormat): String;
type
TRgb = record r,g,b,a: byte; end;
const // fraction of pattern color in fill pattern
FRACTION: array[TsFillStyle] of Double = (
0.0, 1.0, 0.75, 0.50, 0.25, 0.125, 0.0625, // fsNoFill..fsGray6
0.5, 0.5, 0.5, 0.5, // fsStripeHor..fsStripeDiagDown
0.25, 0.25, 0.25, 0.25, // fsThinStripeHor..fsThinStripeDiagDown
0.5, 6.0/16, 0.75, 7.0/16); // fsHatchDiag..fsThinHatchHor
var
fc,bc: TsColorValue;
mix: TRgb;
fraction_fc, fraction_bc: Double;
begin
Result := '';
if not (uffBackgroundColor in AFormat.UsedFormattingFields) then
if not (uffBackground in AFormat.UsedFormattingFields) then
exit;
// Foreground and background colors
fc := Workbook.GetPaletteColor(AFormat.Background.FgColor);
if Aformat.Background.BgColor = scTransparent then
bc := Workbook.GetPaletteColor(scWhite)
else
bc := Workbook.GetPaletteColor(AFormat.Background.BgColor);
// Mixing fraction
fraction_fc := FRACTION[AFormat.Background.Style];
fraction_bc := 1.0 - fraction_fc;
// Mixed color
mix.r := Min(round(fraction_fc*TRgb(fc).r + fraction_bc*TRgb(bc).r), 255);
mix.g := Min(round(fraction_fc*TRgb(fc).g + fraction_bc*TRgb(bc).g), 255);
mix.b := Min(round(fraction_fc*TRgb(fc).b + fraction_bc*TRgb(bc).b), 255);
Result := Format('fo:background-color="%s" ', [
Workbook.GetPaletteColorAsHTMLStr(AFormat.BackgroundColor)
ColorToHTMLColorStr(TsColorValue(mix))
]);
end;

136
components/fpspreadsheet/fpspreadsheet.pas
View File

@ -225,6 +225,7 @@ type
out ACurrencySymbol: String): Boolean;
function ReadUsedFormatting(ACell: PCell): TsUsedFormattingFields;
function ReadBackground(ACell: PCell): TsFillPattern;
function ReadBackgroundColor(ACell: PCell): TsColor;
function ReadCellBorders(ACell: PCell): TsCellBorders;
function ReadCellBorderStyle(ACell: PCell; ABorder: TsCellBorder): TsCellBorderStyle;
@ -300,8 +301,10 @@ type
procedure WriteNumber(ACell: PCell; ANumber: Double;
ANumFormat: TsNumberFormat; ANumFormatString: String); overload;
function WriteRPNFormula(ARow, ACol: Cardinal; AFormula: TsRPNFormula): PCell; overload;
procedure WriteRPNFormula(ACell: PCell; AFormula: TsRPNFormula); overload;
function WriteRPNFormula(ARow, ACol: Cardinal;
AFormula: TsRPNFormula): PCell; overload;
procedure WriteRPNFormula(ACell: PCell;
AFormula: TsRPNFormula); overload;
procedure WriteSharedFormula(ARow1, ACol1, ARow2, ACol2: Cardinal;
const AFormula: String); overload;
@ -312,16 +315,25 @@ type
procedure WriteUTF8Text(ACell: PCell; AText: ansistring); overload;
{ Writing of cell attributes }
function WriteBackground(ARow, ACol: Cardinal; AStyle: TsFillStyle;
APatternColor: TsColor = scTransparent;
ABackgroundColor: TsColor = scTransparent): PCell; overload;
procedure WriteBackground(ACell: PCell; AStyle: TsFillStyle;
APatternColor: TsColor = scTransparent;
ABackgroundColor: TsColor = scTransparent); overload;
function WriteBackgroundColor(ARow, ACol: Cardinal; AColor: TsColor): PCell; overload;
procedure WriteBackgroundColor(ACell: PCell; AColor: TsColor); overload;
function WriteBorderColor(ARow, ACol: Cardinal; ABorder: TsCellBorder; AColor: TsColor): PCell; overload;
procedure WriteBorderColor(ACell: PCell; ABorder: TsCellBorder; AColor: TsColor); overload;
function WriteBorderColor(ARow, ACol: Cardinal; ABorder: TsCellBorder;
AColor: TsColor): PCell; overload;
procedure WriteBorderColor(ACell: PCell; ABorder: TsCellBorder;
AColor: TsColor); overload;
function WriteBorderLineStyle(ARow, ACol: Cardinal; ABorder: TsCellBorder;
ALineStyle: TsLineStyle): PCell; overload;
procedure WriteBorderLineStyle(ACell: PCell; ABorder: TsCellBorder;
ALineStyle: TsLineStyle); overload;
function WriteBorders(ARow, ACol: Cardinal; ABorders: TsCellBorders): PCell; overload;
function WriteBorders(ARow, ACol: Cardinal;
ABorders: TsCellBorders): PCell; overload;
procedure WriteBorders(ACell: PCell; ABorders: TsCellBorders); overload;
function WriteBorderStyle(ARow, ACol: Cardinal; ABorder: TsCellBorder;
AStyle: TsCellBorderStyle): PCell; overload;
@ -3033,6 +3045,26 @@ begin
Result := fmt^.UsedFormattingFields;
end;
{@@ ----------------------------------------------------------------------------
Returns the background fill pattern and colors of a cell.
@param ACell Pointer to the cell
@return TsFillPattern record (or EMPTY_FILL, if the cell does not have a
filled background
-------------------------------------------------------------------------------}
function TsWorksheet.ReadBackground(ACell: PCell): TsFillPattern;
var
fmt : PsCellFormat;
begin
Result := EMPTY_FILL;
if ACell <> nil then
begin
fmt := Workbook.GetPointerToCellFormat(ACell^.FormatIndex);
if (uffBackground in fmt^.UsedFormattingFields) then
Result := fmt^.Background;
end;
end;
{@@ ----------------------------------------------------------------------------
Returns the background color of a cell as index into the workbook's color palette.
@ -3047,10 +3079,13 @@ begin
if ACell <> nil then
begin
fmt := Workbook.GetPointerToCellFormat(ACell^.FormatIndex);
if (uffBackgroundColor in fmt^.UsedFormattingFields) then
Result := fmt^.BackgroundColor
if (uffBackground in fmt^.UsedFormattingFields) then
begin
if (fmt^.Background.Style = fsSolidFill) then
Result := fmt^.Background.FgColor
else
Result := scTransparent;
Result := fmt^.Background.BgColor;
end;
end;
end;
@ -5458,7 +5493,62 @@ begin
end;
{@@ ----------------------------------------------------------------------------
Sets the background color of a cell.
Defines a background pattern for a cell
@param ARow Row index of the cell
@param ACol Column index of the cell
@param AFillStyle Fill style to be used - see TsFillStyle
@param APatternColor Palette index of the pattern color
@param ABackgroundColor Palette index of the background color
@return Pointer to cell
@NOTE Is replaced by uniform fill if WriteBackgroundColor is called later.
-------------------------------------------------------------------------------}
function TsWorksheet.WriteBackground(ARow, ACol: Cardinal; AStyle: TsFillStyle;
APatternColor, ABackgroundColor: TsColor): PCell;
begin
Result := GetCell(ARow, ACol);
WriteBackground(Result, AStyle, APatternColor, ABackgroundColor);
end;
{@@ ----------------------------------------------------------------------------
Defines a background pattern for a cell
@param ACell Pointer to the cell
@param AStyle Fill style ("pattern") to be used - see TsFillStyle
@param APatternColor Palette index of the pattern color
@param ABackgroundColor Palette index of the background color
@NOTE Is replaced by uniform fill if WriteBackgroundColor is called later.
-------------------------------------------------------------------------------}
procedure TsWorksheet.WriteBackground(ACell: PCell; AStyle: TsFillStyle;
APatternColor: TsColor = scTransparent; ABackgroundColor: TsColor = scTransparent);
var
fmt: TsCellFormat;
begin
if ACell <> nil then begin
fmt := Workbook.GetCellFormat(ACell^.FormatIndex);
if (AStyle = fsNoFill) or
((APatternColor = scTransparent) and (ABackgroundColor = scTransparent))
then
Exclude(fmt.UsedFormattingFields, uffBackground)
else
begin
Include(fmt.UsedFormattingFields, uffBackground);
fmt.Background.Style := AStyle;
fmt.Background.FgColor := APatternColor;
if (AStyle = fsSolidFill) and (ABackgroundColor = scTransparent) then
fmt.Background.BgColor := APatternColor
else
fmt.Background.BgColor := ABackgroundColor;
end;
ACell^.FormatIndex := Workbook.AddCellFormat(fmt);
ChangedCell(ACell^.Row, ACell^.Col);
end;
end;
{@@ ----------------------------------------------------------------------------
Sets a uniform background color of a cell.
@param ARow Row index of the cell
@param ACol Column index of the cell
@ -5475,7 +5565,7 @@ begin
end;
{@@ ----------------------------------------------------------------------------
Sets the background color of a cell.
Sets a uniform background color of a cell.
@param ACell Pointer to cell
@param AColor Index of the new background color into the workbook's
@ -5483,20 +5573,12 @@ end;
erase an existing background color.
-------------------------------------------------------------------------------}
procedure TsWorksheet.WriteBackgroundColor(ACell: PCell; AColor: TsColor);
var
fmt: TsCellFormat;
begin
if ACell <> nil then begin
fmt := Workbook.GetCellFormat(ACell^.FormatIndex);
if AColor = scTransparent then
Exclude(fmt.UsedFormattingFields, uffBackgroundColor)
WriteBackground(ACell, fsNoFill)
else
begin
Include(fmt.UsedFormattingFields, uffBackgroundColor);
fmt.BackgroundColor := AColor;
end;
ACell^.FormatIndex := Workbook.AddCellFormat(fmt);
ChangedCell(ACell^.Row, ACell^.Col);
WriteBackground(ACell, fsSolidFill, AColor, AColor);
end;
end;
@ -8038,8 +8120,15 @@ end;
-------------------------------------------------------------------------------}
function TsWorkbook.GetColorName(AColorIndex: TsColor): string;
begin
case AColorIndex of
scTransparent:
Result := 'transparent';
scNotDefined:
Result := 'not defined';
else
GetColorName(GetPaletteColor(AColorIndex), Result);
end;
end;
{@@ ----------------------------------------------------------------------------
Returns the name of an rgb color value.
@ -8215,8 +8304,11 @@ begin
begin
cell := PCell(Node.Data);
fmt := GetPointerToCellFormat(cell^.FormatIndex);
if (uffBackgroundColor in fmt^.UsedFormattingFields) then
if fmt^.BackgroundColor = AColorIndex then exit;
if (uffBackground in fmt^.UsedFormattingFields) then
begin
if fmt^.Background.BgColor = AColorIndex then exit;
if fmt^.Background.FgColor = AColorIndex then exit;
end;
if (uffBorder in fmt^.UsedFormattingFields) then
for b in TsCellBorders do
if fmt^.BorderStyles[b].Color = AColorIndex then

22
components/fpspreadsheet/fpspreadsheetctrls.pas
View File

@ -903,8 +903,11 @@ var
j: Integer;
I: IsSpreadsheetControl;
C: TComponent;
cell: PCell;
begin
for j:=0 to FListeners.Count-1 do begin
if Worksheet <> nil then cell := Worksheet.FindCell(0,0);
C := TComponent(FListeners[j]);
if C.GetInterface(GUID_SpreadsheetControl, I) then
I.ListenerNotification(AChangedItems, AData)
@ -2602,11 +2605,20 @@ begin
GetEnumName(TypeInfo(TsLineStyle), ord(fmt.BorderStyles[cbEast].LineStyle)),
Workbook.GetColorName(fmt.BorderStyles[cbEast].Color)]));
if (ACell = nil) or not (uffBackgroundColor in fmt.UsedformattingFields)
then AStrings.Add('BackgroundColor=')
else AStrings.Add(Format('BackgroundColor=%d (%s)', [
fmt.BackgroundColor,
Workbook.GetColorName(fmt.BackgroundColor)]));
if (ACell = nil) or not (uffBackground in fmt.UsedformattingFields) then
begin
AStrings.Add('Style=');
AStrings.Add('PatternColor=');
AStrings.Add('BackgroundColor=');
end else
begin
AStrings.Add(Format('Style=%s', [
GetEnumName(TypeInfo(TsFillStyle), ord(fmt.Background.Style))]));
AStrings.Add(Format('PatternColor=%d (%s)', [
fmt.Background.FgColor, Workbook.GetColorName(fmt.Background.FgColor)]));
AStrings.Add(Format('BackgroundColor=%d (%s)', [
fmt.Background.BgColor, Workbook.GetColorName(fmt.Background.BgColor)]));
end;
if (ACell = nil) or not (uffNumberFormat in fmt.UsedFormattingFields) then
begin

199
components/fpspreadsheet/fpspreadsheetgrid.pas
View File

@ -591,24 +591,162 @@ const
var
{@@ Auxiliary bitmap containing the fill pattern used by biff2 cell backgrounds. }
FillPattern_BIFF2: TBitmap = nil;
{@@ Auxiliary bitmap containing the previously used non-trivial fill pattern }
FillPatternBitmap: TBitmap = nil;
FillPatternStyle: TsFillStyle;
FillPatternFgColor: TColor;
FillPatternBgColor: TColor;
{@@ ----------------------------------------------------------------------------
Helper procedure which creates the fill pattern used by biff2 cell backgrounds.
Helper procedure which creates bitmaps used for fill patterns in cell
backgrounds.
The parameters are buffered in FillPatternXXXX variables to avoid unnecessary
creation of the same bitmaps again and again.
-------------------------------------------------------------------------------}
procedure Create_FillPattern_BIFF2(ABkColor: TColor);
procedure CreateFillPattern(var ABitmap: TBitmap; AStyle: TsFillStyle;
AFgColor, ABgColor: TColor);
procedure SolidFill(AColor: TColor);
begin
FreeAndNil(FillPattern_BIFF2);
FillPattern_BIFF2 := TBitmap.Create;
with FillPattern_BIFF2 do begin
SetSize(4, 4);
Canvas.Brush.Color := ABkColor;
Canvas.FillRect(0, 0, Width, Height);
Canvas.Pixels[0, 0] := clBlack;
Canvas.Pixels[2, 2] := clBlack;
ABitmap.Canvas.Brush.Color := AColor;
ABitmap.Canvas.FillRect(0, 0, ABitmap.Width, ABitmap.Height);
end;
var
x,y: Integer;
begin
if (FillPatternStyle = AStyle) and (FillPatternBgColor = ABgColor) and
(FillPatternFgColor = AFgColor) and (ABitmap <> nil)
then
exit;
FreeAndNil(ABitmap);
ABitmap := TBitmap.Create;
with ABitmap do begin
if AStyle = fsGray6 then SetSize(8, 4) else SetSize(4, 4);
case AStyle of
fsNoFill:
SolidFill(ABgColor);
fsSolidFill:
SolidFill(AFgColor);
fsGray75:
begin
SolidFill(AFgColor);
Canvas.Pixels[0, 0] := ABgColor;
Canvas.Pixels[2, 1] := ABgColor;
Canvas.Pixels[0, 2] := ABgColor;
Canvas.Pixels[2, 3] := ABgColor;
end;
fsGray50:
begin
SolidFill(AFgColor);
for y := 0 to 3 do for
x := 0 to 3 do
if odd(x+y) then Canvas.Pixels[x,y] := ABgColor;
end;
fsGray25:
begin
SolidFill(ABgColor);
Canvas.Pixels[0, 0] := AFgColor;
Canvas.Pixels[2, 1] := AFgColor;
Canvas.Pixels[0, 2] := AFgColor;
Canvas.Pixels[2, 3] := AFgColor;
end;
fsGray12:
begin
SolidFill(ABgColor);
Canvas.Pixels[0, 0] := AFgColor;
Canvas.Pixels[2, 2] := AFgColor;
end;
fsGray6:
begin
SolidFill(ABgColor);
Canvas.Pixels[0, 0] := AFgColor;
Canvas.Pixels[4, 2] := AFgColor;
end;
fsStripeHor:
begin
SolidFill(ABgColor);
for y := 0 to 1 do
for x := 0 to 3 do
Canvas.Pixels[x,y] := AFgColor;
end;
fsStripeVert:
begin
SolidFill(ABgColor);
for y := 0 to 3 do
for x := 0 to 1 do
Canvas.Pixels[x,y] := AFgColor;
end;
fsStripeDiagUp:
begin
SolidFill(ABgColor);
for y := 0 to 3 do
for x := 0 to 1 do
Canvas.Pixels[(x+y) mod 4, 3-y] := AFgColor;
end;
fsStripeDiagDown:
begin
SolidFill(ABgColor);
for y := 0 to 3 do
for x := 0 to 1 do
Canvas.Pixels[(x+y) mod 4, y] := AFgColor;
end;
fsThinStripeHor:
begin
SolidFill(ABgColor);
for x := 0 to 3 do Canvas.Pixels[x, 0] := AFgColor;
end;
fsThinStripeVert:
begin
SolidFill(ABgColor);
for y := 0 to 3 do Canvas.Pixels[0, y] := AFgColor;
end;
fsThinStripeDiagUp:
begin
SolidFill(ABgColor);
for x := 0 to 3 do Canvas.Pixels[3-x, x] := AFgColor;
end;
fsThinStripeDiagDown, fsThinHatchDiag:
begin
SolidFill(ABgColor);
for x := 0 to 3 do Canvas.Pixels[x, x] := AFgColor;
if AStyle = fsThinHatchDiag then begin
Canvas.Pixels[0, 2] := AFgColor;
Canvas.Pixels[2, 0] := AFgColor;
end;
end;
fsHatchDiag:
begin
SolidFill(ABgColor);
for x := 0 to 1 do
for y := 0 to 1 do begin
Canvas.Pixels[x,y] := AFgColor;
Canvas.Pixels[x+2, y+2] := AFgColor;
end;
end;
fsThickHatchDiag:
begin
SolidFill(AFgColor);
for x := 2 to 3 do Canvas.Pixels[x, 0] := ABgColor;
for x := 0 to 1 do Canvas.Pixels[x, 2] := ABgColor;
end;
fsThinHatchHor:
begin
SolidFill(ABgColor);
for x := 0 to 3 do begin
Canvas.Pixels[x, 0] := AFgColor;
Canvas.Pixels[0, x] := AFgColor;
end;
end;
end; // case
end;
FillPatternStyle := AStyle;
FillPatternBgColor := ABgColor;
FillPatternFgColor := AFgColor;
end;
{@@ ----------------------------------------------------------------------------
Helper procedure which draws a densely dotted horizontal line. In Excel
@ -1174,12 +1312,14 @@ var
fnt: TsFont;
style: TFontStyles;
isSelected: Boolean;
fgcolor, bgcolor: TColor;
begin
GetSelectedState(AState, isSelected);
Canvas.Font.Assign(Font);
Canvas.Brush.Bitmap := nil;
Canvas.Brush.Color := Color;
ts := Canvas.TextStyle;
if ShowHeaders then
begin
// Formatting of row and column headers
@ -1196,37 +1336,53 @@ begin
if ShowHeaders and ((ACol = 0) or (ARow = 0)) then
Canvas.Brush.Color := FixedColor
end;
if (Worksheet <> nil) and (ARow >= FHeaderCount) and (ACol >= FHeaderCount) then
begin
r := ARow - FHeaderCount;
c := ACol - FHeaderCount;
//lCell := FDrawingCell;
lCell := Worksheet.FindCell(r, c);
if lCell <> nil then
begin
fmt := Workbook.GetPointerToCellFormat(lCell^.FormatIndex);
// Background color
if (uffBackgroundColor in fmt^.UsedFormattingFields) then
if (uffBackground in fmt^.UsedFormattingFields) then
begin
if Workbook.FileFormat = sfExcel2 then
begin
if (FillPattern_BIFF2 = nil) and (ComponentState = []) then
Create_FillPattern_BIFF2(Color);
CreateFillPattern(FillPatternBitmap, fsGray50, clBlack, Color);
Canvas.Brush.Style := bsImage;
Canvas.Brush.Bitmap := FillPattern_BIFF2;
Canvas.Brush.Bitmap := FillPatternBitmap;
end else
begin
case fmt^.Background.Style of
fsNoFill:
Canvas.Brush.Style := bsClear;
fsSolidFill:
begin
Canvas.Brush.Style := bsSolid;
if fmt^.BackgroundColor < Workbook.GetPaletteSize then
Canvas.Brush.Color := Workbook.GetPaletteColor(fmt^.BackgroundColor)
Canvas.Brush.Color := Workbook.GetPaletteColor(fmt^.Background.FgColor);
end;
else
Canvas.Brush.Color := Color;
if fmt^.Background.BgColor = scTransparent
then bgcolor := Color
else bgcolor := Workbook.GetPaletteColor(fmt^.Background.BgColor);
if fmt^.Background.FgColor = scTransparent
then fgcolor := Color
else fgcolor := Workbook.GetPaletteColor(fmt^.Background.FgColor);
CreateFillPattern(FillPatternBitmap, fmt^.Background.Style, fgColor, bgColor);
Canvas.Brush.Style := bsImage;
Canvas.Brush.Bitmap := FillPatternBitmap;
end;
end;
end else
begin
Canvas.Brush.Style := bsSolid;
Canvas.Brush.Color := Color;
end;
// Font
if (uffFont in fmt^.UsedFormattingFields) then
begin
@ -4347,11 +4503,12 @@ end;
initialization
fpsutils.ScreenPixelsPerInch := Screen.PixelsPerInch;
FillPatternStyle := fsNoFill;
RegisterPropertyToSkip(TsCustomWorksheetGrid, 'ColWidths', 'taken from worksheet', '');
RegisterPropertyToSkip(TsCustomWorksheetGrid, 'RowHeights', 'taken from worksheet', '');
finalization
FreeAndNil(FillPattern_BIFF2);
FreeAndNil(FillPatternBitmap);
end.

42
components/fpspreadsheet/fpstypes.pas
View File

@ -147,9 +147,9 @@ type
{@@ List of possible formatting fields }
TsUsedFormattingField = (uffTextRotation, uffFont, uffBold, uffBorder,
uffBackgroundColor, uffNumberFormat, uffWordWrap,
uffHorAlign, uffVertAlign
uffBackground, uffNumberFormat, uffWordWrap, uffHorAlign, uffVertAlign
);
{ NOTE: "uffBackgroundColor" of older versions replaced by "uffBackground" }
{@@ Describes which formatting fields are active }
TsUsedFormattingFields = set of TsUsedFormattingField;
@ -379,6 +379,28 @@ const
(LineStyle: lsThin; Color: scBlack)
);
type
{@@ Style of fill style for cell backgrounds }
TsFillStyle = (fsNoFill, fsSolidFill,
fsGray75, fsGray50, fsGray25, fsGray12, fsGray6,
fsStripeHor, fsStripeVert, fsStripeDiagUp, fsStripeDiagDown,
fsThinStripeHor, fsThinStripeVert, fsThinStripeDiagUp, fsThinStripeDiagDown,
fsHatchDiag, fsThinHatchDiag, fsThickHatchDiag, fsThinHatchHor);
{@@ Fill pattern record }
TsFillPattern = record
Style: TsFillStyle;
FgColor: TsColor; // pattern color
BgColor: TsColor; // background color
end;
const
EMPTY_FILL: TsFillPattern = (
Style: fsNoFill;
FgColor: scTransparent;
BgColor: scTransparent;
);
type
{@@ Identifier for a compare operation }
TsCompareOperation = (coNotUsed,
@ -445,8 +467,7 @@ type
VertAlignment: TsVertAlignment;
Border: TsCellBorders;
BorderStyles: TsCelLBorderStyles;
BackgroundColor: TsColor;
RGBBackgroundColor: TFPColor; // only valid if BackgroundColor=scRGBCOLOR
Background: TsFillPattern;
NumberFormat: TsNumberFormat;
NumberFormatStr: String;
end;
@ -486,7 +507,7 @@ begin
AValue.NumberFormatStr := '';
FillChar(AValue, SizeOf(AValue), 0);
AValue.BorderStyles := DEFAULT_BORDERSTYLES;
AValue.BackgroundColor := TsColor(-1);
AValue.Background := EMPTY_FILL;
end;
@ -523,8 +544,7 @@ begin
P^.VertAlignment := AItem.VertAlignment;
P^.Border := AItem.Border;
P^.BorderStyles := AItem.BorderStyles;
P^.BackgroundColor := AItem.BackgroundColor;
P^.RGBBackgroundColor := AItem.RGBBackgroundColor;
P^.Background := AItem.Background;
P^.NumberFormat := AItem.NumberFormat;
P^.NumberFormatStr := AItem.NumberFormatStr;
Result := inherited Add(P);
@ -632,10 +652,10 @@ begin
if not equ then continue;
end;
if (uffBackgroundColor in AItem.UsedFormattingFields) then begin
if (P^.BackgroundColor <> AItem.BackgroundColor) then continue;
if (AItem.BackgroundColor = scRGBColor) then
if (P^.RGBBackgroundColor <> AItem.RGBBackgroundColor) then continue;
if (uffBackground in AItem.UsedFormattingFields) then begin
if (P^.Background.Style <> AItem.Background.Style) then continue;
if (P^.Background.BgColor <> AItem.Background.BgColor) then continue;
if (P^.Background.FgColor <> AItem.Background.FgColor) then continue;
end;
if (uffNumberFormat in AItem.UsedFormattingFields) then begin

10
components/fpspreadsheet/tests/copytests.pas
View File

@ -87,7 +87,7 @@ begin
Result.ContentType := cctNumber;
Result.Numbervalue := ANumber;
if (ABkColor <> scTransparent) then begin
Result.UsedFormattingFields := Result.usedFormattingFields + [uffBackgroundColor];
Result.UsedFormattingFields := Result.UsedFormattingFields + [uffBackground];
Result.BackgroundColor := ABkColor;
end;
end;
@ -98,7 +98,7 @@ begin
Result.ContentType := cctUTF8String;
Result.UTF8StringValue := AString;
if (ABkColor <> scTransparent) then begin
Result.UsedFormattingFields := Result.usedFormattingFields + [uffBackgroundColor];
Result.UsedFormattingFields := Result.usedFormattingFields + [uffBackground];
Result.BackgroundColor := ABkColor;
end;
end;
@ -111,7 +111,7 @@ begin
Result.NumberValue := ANumberResult;
Result.ContentType := cctNumber;
if (ABkColor <> scTransparent) then begin
Result.UsedFormattingFields := Result.usedFormattingFields + [uffBackgroundColor];
Result.UsedFormattingFields := Result.usedFormattingFields + [uffBackground];
Result.BackgroundColor := ABkColor;
end;
end;
@ -339,7 +339,7 @@ begin
SourceCells[i+(col-2)].UsedFormattingFields = MyWorksheet.ReadUsedFormatting(cell),
'Used formatting fields mismatch, cell ' + CellNotation(myWorksheet, row, col)
);
if (uffBackgroundColor in SourceCells[i].UsedFormattingFields) then
if (uffBackground in SourceCells[i].UsedFormattingFields) then
CheckEquals(
SourceCells[i+(col-2)].BackgroundColor,
MyWorksheet.ReadBackgroundColor(cell),
@ -361,7 +361,7 @@ begin
SourceCells[i].UsedFormattingFields = MyWorksheet.ReadUsedFormatting(cell),
'Used formatting fields mismatch, cell ' + CellNotation(MyWorksheet, row, col)
);
if (uffBackgroundColor in SourceCells[i].UsedFormattingFields) then
if (uffBackground in SourceCells[i].UsedFormattingFields) then
CheckEquals(
SourceCells[i].BackgroundColor,
MyWorksheet.ReadBackgroundColor(cell),

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

@ -52,6 +52,8 @@ type
// Test alignments
procedure TestWriteRead_Alignment(AFormat: TsSpreadsheetFormat);
// Test background
procedure TestWriteRead_Background(AFormat: TsSpreadsheetFormat);
// Test border
procedure TestWriteRead_Border(AFormat: TsSpreadsheetFormat);
// Test border styles
@ -88,12 +90,14 @@ type
procedure TestWriteRead_BIFF2_NumberFormats;
procedure TestWriteRead_BIFF2_ManyXFRecords;
// These features are not supported by Excel2 --> no test cases required!
// - Background
// - BorderStyle
// - TextRotation
// - Wordwrap
{ BIFF5 Tests }
procedure TestWriteRead_BIFF5_Alignment;
procedure TestWriteRead_BIFF5_Background;
procedure TestWriteRead_BIFF5_Border;
procedure TestWriteRead_BIFF5_BorderStyles;
procedure TestWriteRead_BIFF5_ColWidths;
@ -106,6 +110,7 @@ type
{ BIFF8 Tests }
procedure TestWriteRead_BIFF8_Alignment;
procedure TestWriteRead_BIFF8_Background;
procedure TestWriteRead_BIFF8_Border;
procedure TestWriteRead_BIFF8_BorderStyles;
procedure TestWriteRead_BIFF8_ColWidths;
@ -118,6 +123,7 @@ type
{ ODS Tests }
procedure TestWriteRead_ODS_Alignment;
// no background patterns in ods
procedure TestWriteRead_ODS_Border;
procedure TestWriteRead_ODS_BorderStyles;
procedure TestWriteRead_ODS_ColWidths;
@ -130,6 +136,7 @@ type
{ OOXML Tests }
procedure TestWriteRead_OOXML_Alignment;
procedure TestWriteRead_OOXML_Background;
procedure TestWriteRead_OOXML_Border;
procedure TestWriteRead_OOXML_BorderStyles;
procedure TestWriteRead_OOXML_ColWidths;
@ -156,6 +163,7 @@ const
FmtDateTimesSheet = 'DateTimesFormat';
ColWidthSheet = 'ColWidths';
RowHeightSheet = 'RowHeights';
BackgroundSheet = 'Background';
BordersSheet = 'CellBorders';
AlignmentSheet = 'TextAlignments';
TextRotationSheet = 'TextRotation';
@ -689,6 +697,133 @@ begin
end;
{ This test writes in column A the names of the Background.Styles, in column B
the background fill with a specific pattern and background color, in column C
the same, but with transparent background. }
procedure TSpreadWriteReadFormatTests.TestWriteRead_Background(AFormat: TsSpreadsheetFormat);
const
PATTERN_COLOR = scRed;
BK_COLOR = scYellow;
var
MyWorksheet: TsWorksheet;
MyWorkbook: TsWorkbook;
MyCell: PCell;
col, row: Integer;
style: TsFillStyle;
TempFile: String;
actualstyle: TsFillStyle;
actualcolor: TsColor;
patt: TsFillPattern;
begin
// Write out all test values
MyWorkbook := TsWorkbook.Create;
try
MyWorkbook.UsePalette(@PALETTE_BIFF8, Length(PALETTE_BIFF8));
MyWorkSheet:= MyWorkBook.AddWorksheet(BackgroundSheet);
for style in TsFillStyle do begin
row := ord(style);
MyWorksheet.WriteUTF8Text(row, 0, GetEnumName(TypeInfo(TsFillStyle), ord(style)));
MyWorksheet.WriteBackground(row, 1, style, PATTERN_COLOR, BK_COLOR);
MyWorksheet.WriteBackground(row, 2, style, PATTERN_COLOR, scTransparent);
end;
TempFile:= NewTempFile;
MyWorkBook.WriteToFile(TempFile, AFormat, true);
finally
MyWorkbook.Free;
end;
// Open the spreadsheet
MyWorkbook := TsWorkbook.Create;
try
MyWorkbook.ReadFromFile(TempFile, AFormat);
if AFormat = sfExcel2 then
MyWorksheet := MyWorkbook.GetFirstWorksheet
else
MyWorksheet := GetWorksheetByName(MyWorkBook, BackgroundSheet);
if MyWorksheet=nil then
fail('Error in test code. Failed to get named worksheet');
for style in TsFillStyle do begin
row := ord(style);
// Column B has BK_COLOR as backgroundcolor of the patterns
col := 1;
MyCell := MyWorksheet.FindCell(row, col);
if MyCell = nil then
fail('Error in test code. Failed to get cell ' + CellNotation(MyWorksheet, row, col));
patt := MyWorksheet.ReadBackground(MyCell);
CheckEquals(
GetEnumName(TypeInfo(TsFillStyle), ord(style)),
GetEnumName(TypeInfo(TsFillStyle), ord(patt.Style)),
'Test saved fill style mismatch, cell ' + CellNotation(MyWorksheet, row, col));
if style <> fsNoFill then
begin
if PATTERN_COLOR <> patt.FgColor then
CheckEquals(
MyWorkbook.GetColorName(PATTERN_COLOR),
MyWorkbook.GetColorName(patt.FgColor),
'Test saved fill pattern color mismatch, cell ' + CellNotation(MyWorksheet, row, col));
if BK_COLOR <> patt.BgColor then
CheckEquals(
MyWorkbook.GetColorName(BK_COLOR),
MyWorkbook.GetColorName(patt.BgColor),
'Test saved fill background color mismatch, cell ' + CellNotation(MyWorksheet, row, col));
end;
// Column C has a transparent pattern background.
col := 2;
MyCell := Myworksheet.FindCell(row, col);
if MyCell = nil then
fail('Error in test code. Failed to get cell ' + CellNotation(MyWorksheet, row, col));
patt := MyWorksheet.ReadBackground(MyCell);
CheckEquals(
GetEnumName(TypeInfo(TsFillStyle), ord(style)),
GetEnumName(TypeInfo(TsFillStyle), ord(patt.Style)),
'Test saved fill style mismatch, cell ' + CellNotation(MyWorksheet, row, col));
if style <> fsNoFill then
begin
if PATTERN_COLOR <> patt.FgColor then
CheckEquals(
MyWorkbook.GetColorName(PATTERN_COLOR),
MyWorkbook.GetColorName(patt.FgColor),
'Test saved fill pattern color mismatch, cell ' + CellNotation(MyWorksheet, row, col));
// SolidFill is a special case: here the background color is always equal
// to the pattern color - the cell layout does not know this...
if style = fsSolidFill then
CheckEquals(
MyWorkbook.GetColorName(PATTERN_COLOR),
MyWorkbook.GetColorName(patt.BgColor),
'Test saved fill pattern color mismatch, cell ' + CellNotation(MyWorksheet, row, col))
else
CheckEquals(
MyWorkbook.GetColorName(scTransparent),
MyWorkbook.GetColorName(patt.BgColor),
'Test saved fill background color mismatch, cell ' + CellNotation(MyWorksheet, row, col));
end;
end;
finally
MyWorkbook.Free;
DeleteFile(TempFile);
end;
end;
procedure TSpreadWriteReadFormatTests.TestWriteRead_BIFF5_Background;
begin
TestWriteRead_Background(sfExcel5);
end;
procedure TSpreadWriteReadFormatTests.TestWriteRead_BIFF8_Background;
begin
TestWriteRead_Background(sfExcel8);
end;
procedure TSpreadWriteReadFormatTests.TestWriteRead_OOXML_Background;
begin
TestWriteRead_Background(sfOOXML);
end;
{ --- Border on/off tests --- }
procedure TSpreadWriteReadFormatTests.TestWriteRead_Border(AFormat: TsSpreadsheetFormat);

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

@ -131,6 +131,7 @@
<Unit20>
<Filename Value="copytests.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="copytests"/>
</Unit20>
<Unit21>
<Filename Value="commenttests.pas"/>

2
components/fpspreadsheet/wikitable.pas
View File

@ -492,7 +492,7 @@ begin
lCurStr := '<b>' + lCurStr + '</b>';
// Background color
if uffBackgroundColor in lCurUsedFormatting then
if uffBackground in lCurUsedFormatting then
begin
lCurColor := FWorksheet.ReadBackgroundColor(lCell);
lStyleStr := Format('background-color:%s;color:%s;', [

20
components/fpspreadsheet/xlsbiff2.pas
View File

@ -1015,10 +1015,11 @@ begin
// Background color not supported, only shaded background
if rec.HorAlign_Border_BkGr and $80 <> 0 then
begin
fmt.BackgroundColor := 1; // encodes "shaded background = true"
Include(fmt.UsedFormattingFields, uffBackgroundColor);
end else
fmt.BackgroundColor := 0; // encodes "shaded background = false"
fmt.Background.Style := fsGray50;
fmt.Background.FgColor := scBlack;
fmt.Background.BgColor := scTransparent;
Include(fmt.UsedFormattingFields, uffBackground);
end;
// Add the decoded data to the format list
FCellFormatList.Add(fmt);
@ -1090,7 +1091,7 @@ begin
if cbEast in fmt^.Border then Attrib3 := Attrib3 or $10;
if cbSouth in fmt^.Border then Attrib3 := Attrib3 or $40;
end;
if (uffBackgroundColor in fmt^.UsedFormattingFields) and (fmt^.Backgroundcolor <> scWhite) then
if (uffBackground in fmt^.UsedFormattingFields) then
Attrib3 := Attrib3 or $80;
end;
@ -1161,7 +1162,7 @@ begin
if cbSouth in fmt^.Border then
rec.Align_Border_BkGr := rec.Align_Border_BkGr or $40;
end;
if uffBackgroundColor in fmt^.UsedFormattingFields then
if uffBackground in fmt^.UsedFormattingFields then
rec.Align_Border_BkGr := rec.Align_Border_BkGr or $80;
end;
AStream.WriteBuffer(rec, SizeOf(rec));
@ -1399,7 +1400,6 @@ var
rec: TBIFF2_XFRecord;
b: Byte;
j: Integer;
clr: TsColorvalue;
begin
Unused(XFType_Prot);
@ -1460,13 +1460,9 @@ begin
if cbNorth in AFormatRecord^.Border then b := b or $20;
if cbSouth in AFormatRecord^.Border then b := b or $40;
end;
if (uffBackgroundColor in AFormatRecord^.UsedFormattingFields) then
begin
clr := Workbook.GetPaletteColor(AFormatRecord^.BackgroundColor);
if clr <> $FFFFFF then
if (uffBackground in AFormatRecord^.UsedFormattingFields) then
b := b or $80;
end;
end;
rec.HorAlign_Border_BkGr:= b;
{ Write out }

42
components/fpspreadsheet/xlsbiff5.pas
View File

@ -543,7 +543,6 @@ begin
SetLength(s, Len);
AStream.ReadBuffer(s[1], len);
if (FIncompleteCell <> nil) and (s <> '') then begin
// FIncompleteCell^.UTF8StringValue := AnsiToUTF8(s);
FIncompletecell^.UTF8StringValue := ConvertEncoding(s, FCodePage, encodingUTF8);
FIncompleteCell^.ContentType := cctUTF8String;
if FIsVirtualMode then
@ -591,6 +590,7 @@ var
b: Byte;
dw: DWord;
fill: Word;
fs: TsFillStyle;
begin
InitFormatRecord(fmt);
fmt.ID := FCellFormatList.Count;
@ -696,15 +696,26 @@ begin
fmt.BorderStyles[cbNorth].Color := (rec.Border_BkGr2 and MASK_XF_BORDER_TOP_COLOR) shr 9;
fmt.BorderStyles[cbSouth].Color := (rec.Border_BkGr1 and MASK_XF_BORDER_BOTTOM_COLOR) shr 25;
// Background fill style
// Background
fill := (rec.Border_BkGr1 and MASK_XF_BKGR_FILLPATTERN) shr 16;
// Background color
if fill = 0 then
fmt.BackgroundColor := scTransparent
else begin
fmt.BackgroundColor := rec.Border_BkGr1 and MASK_XF_BKGR_PATTERN_COLOR;
Include(fmt.UsedFormattingFields, uffBackgroundColor);
for fs in TsFillStyle do
begin
if fs = fsNoFill then
Continue;
if fill = MASK_XF_FILL_PATT[fs] then
begin
// Fill style
fmt.Background.Style := fs;
// Pattern color
fmt.Background.FgColor := rec.Border_BkGr1 and MASK_XF_BKGR_PATTERN_COLOR;
if fmt.Background.FgColor = SYS_DEFAULT_FOREGROUND_COLOR then
fmt.Background.FgColor := scBlack;
fmt.Background.BgColor := (rec.Border_BkGr1 and MASK_XF_BKGR_BACKGROUND_COLOR) shr 7;
if fmt.Background.BgColor = SYS_DEFAULT_BACKGROUND_COLOR then
fmt.Background.BgColor := scTransparent;
Include(fmt.UsedFormattingFields, uffBackground);
break;
end;
end;
// Add the XF to the list
@ -1488,11 +1499,16 @@ begin
dw2 := 0;
if (AFormatRecord <> nil) then
begin
if (uffBackgroundColor in AFormatRecord^.UsedFormattingFields) then
// Background fill pattern
if (uffBackground in AFormatRecord^.UsedFormattingFields) then
begin
// Background color
dw1 := dw1 or (FixColor(AFormatRecord^.BackgroundColor) and $0000007F);
dw1 := dw1 or (MASK_XF_FILL_PATT_SOLID shl 16);
if (AFormatRecord^.Background.FgColor = scTransparent)
then dw1 := dw1 or (SYS_DEFAULT_FOREGROUND_COLOR and $0000007F)
else dw1 := dw1 or (FixColor(AFormatRecord^.Background.FgColor) and $0000007F);
if AFormatRecord^.Background.BgColor = scTransparent
then dw1 := dw1 or (SYS_DEFAULT_BACKGROUND_COLOR shl 7)
else dw1 := dw1 or (FixColor(AFormatRecord^.Background.BgColor) shl 7);
dw1 := dw1 or (MASK_XF_FILL_PATT[AFormatRecord^.Background.Style] shl 16);
end;
// Border lines
if (uffBorder in AFormatRecord^.UsedFormattingFields) then

49
components/fpspreadsheet/xlsbiff8.pas
View File

@ -1162,6 +1162,7 @@ var
b: Byte;
dw: DWord;
fill: Integer;
fs: TsFillStyle;
nfidx: Integer;
nfdata: TsNumFormatData;
i: Integer;
@ -1282,16 +1283,28 @@ begin
fmt.BorderStyles[cbDiagUp].Color := (rec.Border_BkGr2 and MASK_XF_BORDER_DIAGONAL_COLOR) shr 14;
fmt.BorderStyles[cbDiagDown].Color := fmt.BorderStyles[cbDiagUp].Color;
// Background fill pattern
// Background fill pattern and color
fill := (rec.Border_BkGr2 and MASK_XF_BACKGROUND_PATTERN) shr 26;
// Background color
if fill <> MASK_XF_FILL_PATT_EMPTY then
begin
for fs in TsFillStyle do
if fill = MASK_XF_FILL_PATT[fs] then
begin
rec.BkGr3 := DWordLEToN(rec.BkGr3);
if fill <> 0 then begin
fmt.BackgroundColor := rec.BkGr3 and $007F;
Include(fmt.UsedFormattingFields, uffBackgroundColor);
end else
fmt.BackgroundColor := scTransparent; // this means "no fill"
// Pattern color
fmt.Background.FgColor := rec.BkGr3 and $007F;
if fmt.Background.FgColor = SYS_DEFAULT_FOREGROUND_COLOR then
fmt.Background.FgColor := scBlack;
// Background color
fmt.Background.BgColor := (rec.BkGr3 and $3F80) shr 7;
if fmt.Background.BgColor = SYS_DEFAULT_BACKGROUND_COLOR then
fmt.Background.BgColor := scTransparent;
// Fill style
fmt.Background.Style := fs;
Include(fmt.UsedFormattingFields, uffBackground);
break;
end;
end;
// Add the XF to the list
FCellFormatList.Add(fmt);
@ -2386,6 +2399,7 @@ var
j: Integer;
b: Byte;
dw1, dw2: DWord;
w3: Word;
begin
{ BIFF record header }
rec.RecordID := WordToLE(INT_EXCEL_ID_XF);
@ -2471,7 +2485,7 @@ begin
dw1 := 0;
dw2 := 0;
rec.BkGr3 := 0;
w3 := 0;
if (AFormatRecord <> nil) and (uffBorder in AFormatRecord^.UsedFormattingFields) then
begin
// Left and right line colors
@ -2503,15 +2517,24 @@ begin
// In BIFF8 both diagonals have the same line style - we use the color of the up-diagonal.
end;
if (AFormatRecord <> nil) and (uffBackgroundColor in AFormatRecord^.UsedFormattingFields) then
{ Background fill }
if (AFormatRecord <> nil) and (uffBackground in AFormatRecord^.UsedFormattingFields) then
begin
dw2 := dw2 or DWORD(MASK_XF_FILL_PATT_SOLID shl 26);
rec.BkGr3 := FixColor(AFormatRecord^.BackgroundColor);
// Fill pattern style
dw2 := dw2 or DWORD(MASK_XF_FILL_PATT[AFormatRecord^.Background.Style] shl 26);
// Pattern color
if AFormatRecord^.Background.FgColor = scTransparent
then w3 := w3 or SYS_DEFAULT_FOREGROUND_COLOR
else w3 := w3 or FixColor(AFormatRecord^.Background.FgColor);
// Background color
if AFormatRecord^.Background.BgColor = scTransparent
then w3 := w3 or SYS_DEFAULT_BACKGROUND_COLOR shl 7
else w3 := w3 or (FixColor(AFormatRecord^.Background.BgColor) shl 7);
end;
rec.Border_BkGr1 := DWordToLE(dw1);
rec.Border_BkGr2 := DWordToLE(dw2);
rec.BkGr3 := WordToLE(rec.BkGr3);
rec.BkGr3 := WordToLE(w3);
{ Write out }
AStream.WriteBuffer(rec, SizeOf(rec));

27
components/fpspreadsheet/xlscommon.pas
View File

@ -163,6 +163,28 @@ const
MASK_XF_FILL_PATT_EMPTY = $00;
MASK_XF_FILL_PATT_SOLID = $01;
MASK_XF_FILL_PATT: array[TsFillStyle] of Byte = (
$00, // fsNoFill
$01, // fsSolidFill
$03, // fsGray75
$02, // fsGray50
$04, // fsGray25
$11, // fsGray12
$12, // fsGray6,
$05, // fsStripeHor
$06, // fsStripeVert
$08, // fsStripeDiagUp
$07, // fsStripeDiagDown
$0B, // fsThinStripeHor
$0C, // fsThinStripeVert
$0E, // fsThinStripeDiagUp
$0D, // fsThinStripeDiagDown
$09, // fsHatchDiag
$10, // fsThinHatchDiag
$0A, // fsThickHatchDiag
$0F // fsThinHatchHor
);
{ Cell Addresses constants, valid for BIFF2-BIFF5 }
MASK_EXCEL_ROW = $3FFF;
MASK_EXCEL_RELATIVE_COL = $4000;
@ -175,6 +197,11 @@ const
MASK_FORMULA_RECALCULATE_ON_OPEN = $0002;
MASK_FORMULA_SHARED_FORMULA = $0008;
{ System colors, for BIFF5-BIFF8 }
SYS_DEFAULT_FOREGROUND_COLOR = $0040;
SYS_DEFAULT_BACKGROUND_COLOR = $0041;
{ Error codes }
ERR_INTERSECTION_EMPTY = $00; // #NULL!
ERR_DIVIDE_BY_ZERO = $07; // #DIV/0!

90
components/fpspreadsheet/xlsxooxml.pas
View File

@ -328,6 +328,31 @@ type
BorderStyles: TsCellBorderStyles;
end;
const
PATTERN_TYPES: array [TsFillStyle] of string = (
'none', // fsNoFill
'solid', // fsSolidFill
'darkGray', // fsGray75
'mediumGray', // fsGray50
'lightGray', // fsGray25
'gray125', // fsGray12
'gray0625', // fsGray6,
'darkHorizontal', // fsStripeHor
'darkVertical', // fsStripeVert
'darkUp', // fsStripeDiagUp
'darkDown', // fsStripeDiagDown
'lightHorizontal', // fsThinStripeHor
'lightVertical', // fsThinStripeVert
'lightUp', // fsThinStripeDiagUp
'lightDown', // fsThinStripeDiagDown
'darkTrellis', // fsHatchDiag
'lightTrellis', // fsHatchThinDiag
'darkTellis', // fsHatchTickDiag
'lightGrid' // fsHatchThinHor
);
{ TsOOXMLNumFormatList }
@ -718,6 +743,7 @@ var
childNode: TDOMNode;
nodeName: String;
fmt: TsCellFormat;
fs: TsFillStyle;
s1, s2: String;
i, numFmtIndex, fillIndex, borderIndex: Integer;
numFmtData: TsNumFormatData;
@ -770,8 +796,15 @@ begin
fillIndex := StrToInt(s1);
fillData := FFillList[fillIndex];
if (fillData <> nil) and (fillData.PatternType <> 'none') then begin
Include(fmt.UsedFormattingFields, uffBackgroundColor);
fmt.BackgroundColor := fillData.FgColor;
fmt.Background.FgColor := fillData.FgColor;
fmt.Background.BgColor := fillData.BgColor;
for fs in TsFillStyle do
if SameText(fillData.PatternType, PATTERN_TYPES[fs]) then
begin
fmt.Background.Style := fs;
Include(fmt.UsedFormattingFields, uffBackground);
break;
end;
end;
end;
@ -859,6 +892,15 @@ var
begin
Assert(ANode <> nil);
s := GetAttrValue(ANode, 'auto');
if s = '1' then begin
if ANode.NodeName = 'fgColor' then
Result := scBlack
else
Result := scTransparent;
exit;
end;
s := GetAttrValue(ANode, 'rgb');
if s <> '' then begin
Result := FWorkbook.AddColorToPalette(HTMLColorStrToColor('#' + s));
@ -1640,13 +1682,28 @@ var
i: Integer;
fmt: PsCellFormat;
begin
if (AFormat = nil) or not (uffBackgroundColor in AFormat^.UsedFormattingFields)
if (AFormat = nil) or not (uffBackground in AFormat^.UsedFormattingFields)
then begin
Result := 0;
exit;
end;
// Index 0 is "no fill" which already has been handled.
for i:=1 to High(FFillList) do begin
fmt := FFillList[i];
if (fmt <> nil) and (uffBackground in fmt^.UsedFormattingFields) then
begin
if (AFormat^.Background.Style = fmt^.Background.Style) and
(AFormat^.Background.BgColor = fmt^.Background.BgColor) and
(AFormat^.Background.FgColor = fmt^.Background.FgColor)
then begin
Result := i;
exit;
end;
end;
end;
{
// Index 1 is also pre-defined (gray 25%)
for i:=2 to High(FFillList) do begin
fmt := FFillList[i];
@ -1657,6 +1714,7 @@ begin
exit;
end;
end;
}
// Not found --> return -1
Result := -1;
@ -1893,7 +1951,7 @@ end;
procedure TsSpreadOOXMLWriter.WriteFillList(AStream: TStream);
var
i: Integer;
rgb: TsColorValue;
pt, bc, fc: string;
begin
AppendToStream(AStream, Format(
'<fills count="%d">', [Length(FFillList)]));
@ -1912,15 +1970,23 @@ begin
// user-defined fills
for i:=2 to High(FFillList) do begin
rgb := Workbook.GetPaletteColor(FFillList[i]^.BackgroundColor);
pt := PATTERN_TYPES[FFillList[i]^.Background.Style];
if FFillList[i]^.Background.FgColor = scTransparent then
fc := 'auto="1"'
else
fc := Format('rgb="%s"', [Copy(Workbook.GetPaletteColorAsHTMLStr(FFillList[i]^.Background.FgColor), 2, 255)]);
if FFillList[i].Background.BgColor = scTransparent then
bc := 'auto="1"'
else
bc := Format('rgb="%s"', [Copy(Workbook.GetPaletteColorAsHTMLStr(FFillList[i]^.Background.BgColor), 2, 255)]);
AppendToStream(AStream,
'<fill>',
'<patternFill patternType="solid">');
'<fill>');
AppendToStream(AStream, Format(
'<fgColor rgb="%s" />', [Copy(ColorToHTMLColorStr(rgb), 2, 255)]),
'<bgColor indexed="64" />');
AppendToStream(AStream,
'</patternFill>',
'<patternFill patternType="%s">', [pt]) + Format(
'<fgColor %s />', [fc]) + Format(
'<bgColor %s />', [bc]) +
// '<bgColor indexed="64" />' +
'</patternFill>' +
'</fill>');
end;
@ -2302,7 +2368,7 @@ begin
sAlign := sAlign + 'wrapText="1" ';
{ Fill }
if (uffBackgroundColor in fmt.UsedFormattingFields) then
if (uffBackground in fmt.UsedFormattingFields) then
begin
fillID := FindFillInList(fmt);
if fillID = -1 then fillID := 0;