{ fpsPalette }
{@@ ----------------------------------------------------------------------------
Palette support for fpspreadsheet file formats
AUTHORS: Werner Pamler, Felipe Monteiro de Carvalho, Reinier Olislagers
LICENSE: See the file COPYING.modifiedLGPL.txt, included in the Lazarus
distribution, for details about the license.
-------------------------------------------------------------------------------}
unit fpsPalette;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, fpstypes;
type
{ TsPalette }
TsPalette = class
private
FColors: array of TsColor;
function GetColor(AIndex: Integer): TsColor;
procedure SetColor(AIndex: Integer; AColor: TsColor);
public
constructor Create;
procedure AddBuiltinColors(EditableSet: Boolean = false); virtual;
function AddColor(AColor: TsColor; ABigEndian: Boolean = false): Integer;
procedure AddExcelColors;
function AddUniqueColor(AColor: TsColor; ABigEndian: Boolean = false): Integer;
procedure Clear;
procedure CollectFromWorkbook(AWorkbook: TsBasicWorkbook);
function ColorUsedInWorkbook(APaletteIndex: Integer; AWorkbook: TsBasicWorkbook): Boolean;
function FindClosestColorIndex(AColor: TsColor; AMaxPaletteCount: Integer = -1): Integer;
function FindColor(AColor: TsColor; AMaxPaletteCount: Integer = -1;
AStartIndex: Integer = 0): Integer;
function Count: Integer;
procedure Trim(AMaxSize: Integer);
procedure UseColors(const AColors: array of TsColor; ABigEndian: Boolean = false);
property Colors[AIndex: Integer]: TsColor read GetColor write SetColor; default;
end;
procedure MakeLEPalette(var AColors: array of TsColor);
implementation
uses
fpsutils, fpspreadsheet;
{@@ ----------------------------------------------------------------------------
If a palette is coded as big-endian (e.g. by copying the rgb values from
the OpenOffice documentation) the palette values can be converted by means
of this procedure to little-endian which is required by fpspreadsheet.
@param AColors Color array to be converted.
After conversion, its color values are replaced.
-------------------------------------------------------------------------------}
procedure MakeLEPalette(var AColors: array of TsColor);
var
i: Integer;
begin
for i := 0 to High(AColors) do
AColors[i] := LongRGBToExcelPhysical(AColors[i])
end;
{@@ ----------------------------------------------------------------------------
Constructor of the palette: initializes the color array
-------------------------------------------------------------------------------}
constructor TsPalette.Create;
begin
inherited;
SetLength(FColors, 0);
end;
{@@ ----------------------------------------------------------------------------
Adds an rgb color value to the palette and returns the palette index
of the new color.
Existing colors are not checked.
If ABigEndian is TRUE then the rgb values are assumed to be in big endian
order (r = high byte).
By default, rgb is in little-endian order (r = low byte)
-------------------------------------------------------------------------------}
function TsPalette.AddColor(AColor: TsColor; ABigEndian: Boolean = false): Integer;
begin
if ABigEndian then
AColor := LongRGBToExcelPhysical(AColor);
SetLength(FColors, Length(FColors) + 1);
FColors[High(FColors)] := AColor;
Result := High(FColors);
end;
{@@ ----------------------------------------------------------------------------
Adds the built-in colors
NOTE: These colors cannot be edited by Excel.
-------------------------------------------------------------------------------}
procedure TsPalette.AddBuiltinColors(EditableSet: Boolean = false);
begin
AddColor(scBlack); // 0
AddColor(scWhite); // 1
AddColor(scRed); // 2
AddColor(scGreen); // 3
AddColor(scBlue); // 4
AddColor(scYellow); // 5
AddColor(scMagenta); // 6
AddColor(scCyan); // 7
if EditableSet then
begin
AddColor($000000, true); // $08: EGA black
AddColor($FFFFFF, true); // $09: EGA white
AddColor($FF0000, true); // $0A: EGA red
AddColor($00FF00, true); // $0B: EGA green
AddColor($0000FF, true); // $0C: EGA blue
AddColor($FFFF00, true); // $0D: EGA yellow
AddColor($FF00FF, true); // $0E: EGA magenta
AddColor($00FFFF, true); // $0F: EGA cyan
end;
end;
{@@ ----------------------------------------------------------------------------
Adds the standard palette of Excel 8
NOTE: To get the full Excel8 palette call this after AddBuiltinColors
-------------------------------------------------------------------------------}
procedure TsPalette.AddExcelColors;
begin
AddColor($000000, true); // $08: EGA black
AddColor($FFFFFF, true); // $09: EGA white
AddColor($FF0000, true); // $0A: EGA red
AddColor($00FF00, true); // $0B: EGA green
AddColor($0000FF, true); // $0C: EGA blue
AddColor($FFFF00, true); // $0D: EGA yellow
AddColor($FF00FF, true); // $0E: EGA magenta
AddColor($00FFFF, true); // $0F: EGA cyan
AddColor($800000, true); // $10: EGA dark red
AddColor($008000, true); // $11: EGA dark green
AddColor($000080, true); // $12: EGA dark blue
AddColor($808000, true); // $13: EGA olive
AddColor($800080, true); // $14: EGA purple
AddColor($008080, true); // $15: EGA teal
AddColor($C0C0C0, true); // $16: EGA silver
AddColor($808080, true); // $17: EGA gray
AddColor($9999FF, true); // $18:
AddColor($993366, true); // $19:
AddColor($FFFFCC, true); // $1A:
AddColor($CCFFFF, true); // $1B:
AddColor($660066, true); // $1C:
AddColor($FF8080, true); // $1D:
AddColor($0066CC, true); // $1E:
AddColor($CCCCFF, true); // $1F:
AddColor($000080, true); // $20:
AddColor($FF00FF, true); // $21:
AddColor($FFFF00, true); // $22:
AddColor($00FFFF, true); // $23:
AddColor($800080, true); // $24:
AddColor($800000, true); // $25:
AddColor($008080, true); // $26:
AddColor($0000FF, true); // $27:
AddColor($00CCFF, true); // $28:
AddColor($CCFFFF, true); // $29:
AddColor($CCFFCC, true); // $2A:
AddColor($FFFF99, true); // $2B:
AddColor($99CCFF, true); // $2C:
AddColor($FF99CC, true); // $2D:
AddColor($CC99FF, true); // $2E:
AddColor($FFCC99, true); // $2F:
AddColor($3366FF, true); // $30:
AddColor($33CCCC, true); // $31:
AddColor($99CC00, true); // $32:
AddColor($FFCC00, true); // $33:
AddColor($FF9900, true); // $34:
AddColor($FF6600, true); // $35:
AddColor($666699, true); // $36:
AddColor($969696, true); // $37:
AddColor($003366, true); // $38:
AddColor($339966, true); // $39:
AddColor($003300, true); // $3A:
AddColor($333300, true); // $3B:
AddColor($993300, true); // $3C:
AddColor($993366, true); // $3D:
AddColor($333399, true); // $3E:
AddColor($333333, true); // $3F:
end;
{@@ ----------------------------------------------------------------------------
Adds the specified color to the palette if it does not yet exist.
Returns the palette index of the new or existing color
-------------------------------------------------------------------------------}
function TsPalette.AddUniqueColor(AColor: TsColor;
ABigEndian: Boolean = false): Integer;
begin
if ABigEndian then
AColor := LongRGBToExcelPhysical(AColor);
Result := FindColor(AColor);
if Result = -1 then result := AddColor(AColor);
end;
{@@ ----------------------------------------------------------------------------
Clears the palette
-------------------------------------------------------------------------------}
procedure TsPalette.Clear;
begin
SetLength(FColors, 0);
end;
{@@ ----------------------------------------------------------------------------
Collects the colors used in the specified workbook
-------------------------------------------------------------------------------}
procedure TsPalette.CollectFromWorkbook(AWorkbook: TsBasicWorkbook);
var
i: Integer;
book: TsWorkbook absolute AWorkbook;
sheet: TsWorksheet;
cell: PCell;
fmt: TsCellFormat;
fnt: TsFont;
cb: TsCellBorder;
begin
for i:=0 to book.GetWorksheetCount-1 do
begin
sheet := book.GetWorksheetByIndex(i);
for cell in sheet.Cells do begin
fmt := sheet.ReadCellFormat(cell);
if (uffBackground in fmt.UsedFormattingFields) then
begin
AddUniqueColor(fmt.Background.BgColor);
AddUniqueColor(fmt.Background.FgColor);
end;
if (uffFont in fmt.UsedFormattingFields) then
begin
fnt := book.GetFont(fmt.FontIndex);
AddUniqueColor(fnt.Color);
end;
if (uffBorder in fmt.UsedFormattingFields) then
begin
for cb in TsCellBorder do
if (cb in fmt.Border) then
AddUniqueColor(fmt.BorderStyles[cb].Color);
end;
end;
if sheet.TabColor <> scNotDefined then
AddUniqueColor(sheet.TabColor);
end;
end;
{@@ ----------------------------------------------------------------------------
Checks whether a given color is used somewhere within the entire workbook
@param APaletteIndex Palette index of the color
@result True if the color is used by at least one cell, false if not.
-------------------------------------------------------------------------------}
function TsPalette.ColorUsedInWorkbook(APaletteIndex: Integer;
AWorkbook: TsBasicWorkbook): Boolean;
var
book: TsWorkbook absolute AWorkbook;
sheet: TsWorksheet;
cell: PCell;
i: Integer;
fnt: TsFont;
b: TsCellBorder;
fmt: PsCellFormat;
color: TsColor;
begin
color := GetColor(APaletteIndex);
if (color = scNotDefined) or (AWorkbook = nil) then
exit(false);
Result := true;
for i:=0 to book.GetWorksheetCount-1 do
begin
sheet := book.GetWorksheetByIndex(i);
for cell in sheet.Cells do
begin
fmt := book.GetPointerToCellFormat(cell^.FormatIndex);
if (uffBackground in fmt^.UsedFormattingFields) then
begin
if fmt^.Background.BgColor = color then exit;
if fmt^.Background.FgColor = color then exit;
end;
if (uffBorder in fmt^.UsedFormattingFields) then
for b in TsCellBorders do
if (b in fmt^.Border) and (fmt^.BorderStyles[b].Color = color) then
exit;
if (uffFont in fmt^.UsedFormattingFields) then
begin
fnt := book.GetFont(fmt^.FontIndex);
if fnt.Color = color then
exit;
end;
end;
end;
Result := false;
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 AColor Rgb color value to be considered
@param AMaxPaletteCount Number of palette entries considered. Example:
BIFF5/BIFF8 can write only 64 colors, i.e
AMaxPaletteCount = 64
@return Palette index of the color closest to AColor
-------------------------------------------------------------------------------}
function TsPalette.FindClosestColorIndex(AColor: TsColor;
AMaxPaletteCount: Integer = -1): Integer;
type
TRGBA = record r,g,b,a: Byte end;
var
rgb: TRGBA;
rgb0: TRGBA absolute AColor;
dist: Double;
minDist: Double;
i: Integer;
n: Integer;
begin
Result := -1;
minDist := 1E108;
n := Length(FColors);
if AMaxPaletteCount > n then n := AMaxPaletteCount;
for i := 0 to n - 1 do
begin
rgb := TRGBA(GetColor(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;
{@@ ----------------------------------------------------------------------------
Finds the palette color index which belongs to the specified color.
Returns -1 if the color is not contained in the palette.
@param AColor Rgb color value to be considered
@param AMaxPaletteCount Number of palette entries considered. Example:
BIFF5/BIFF8 can write only 64 colors, i.e
AMaxPaletteCount = 64
@return Palette index of AColor
-------------------------------------------------------------------------------}
function TsPalette.FindColor(AColor: TsColor;
AMaxPaletteCount: Integer = -1; AStartIndex: Integer = 0): Integer;
var
n: Integer;
begin
n := Length(FColors);
if AMaxPaletteCount > n then n := AMaxPaletteCount;
for Result := AStartIndex to n - 1 do
if GetColor(Result) = AColor then
exit;
Result := -1;
end;
{@@ ----------------------------------------------------------------------------
Reads the rgb color for the given index from the palette.
Can be type-cast to TColor for usage in GUI applications.
@param AIndex Index of the color considered
@return A number containing the rgb components in little-endian notation.
-------------------------------------------------------------------------------}
function TsPalette.GetColor(AIndex: Integer): TsColor;
begin
if (AIndex >= 0) and (AIndex < Length(FColors)) then
Result := FColors[AIndex]
else
Result := scNotDefined;
end;
{@@ ----------------------------------------------------------------------------
Returns the number of palette colors
-------------------------------------------------------------------------------}
function TsPalette.Count: Integer;
begin
Result := Length(FColors);
end;
{@@ ----------------------------------------------------------------------------
Replaces a color value of the palette by a new value.
The color must be given in little-endian notation (ABGR, with A=0).
@param AIndex Palette index of the color to be replaced
@param AColor Number containing the rgb components of the new color
-------------------------------------------------------------------------------}
procedure TsPalette.SetColor(AIndex: Integer; AColor: TsColor);
begin
if (AIndex >= 0) and (AIndex < Length(FColors)) then
FColors[AIndex] := AColor;
end;
{@@ ----------------------------------------------------------------------------
Trims the size of the palette
-------------------------------------------------------------------------------}
procedure TsPalette.Trim(AMaxSize: Integer);
begin
if Length(FColors) > AMaxSize then
SetLength(FColors, AMaxSize);
end;
{@@ ----------------------------------------------------------------------------
Uses the color array to with "APalette" points in the palette.
If ABigEndian is true it is assumed that the input colors are specified in
big-endian notation, i.e. "blue" in the low-value byte.
-------------------------------------------------------------------------------}
procedure TsPalette.UseColors(const AColors: array of TsColor; ABigEndian: Boolean = false);
var
i: Integer;
begin
SetLength(FColors, High(AColors)+1);
if ABigEndian then
for i:=0 to High(AColors) do FColors[i] := LongRGBToExcelPhysical(AColors[i])
else
for i:=0 to High(AColors) do FColors[i] := AColors[i];
end;
end.