From f69a47c902621ecbea49220b293bbe08742598eb Mon Sep 17 00:00:00 2001 From: wp_xxyyzz Date: Wed, 23 Apr 2014 22:29:32 +0000 Subject: [PATCH] fpspreadsheet: Add/complete color support for biff2 and biff8, reading and writing. Display colors in fpspreadsheetgrid. Remove parameter AData in several methods of the readers/writers and replace it by FWorkbook passed at creation. Add unit tests for font and color support. No issues. git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@2960 8e941d3f-bd1b-0410-a28a-d453659cc2b4 --- .../examples/excel8demo/excel8write.lpi | 5 + .../examples/excel8demo/excel8write.lpr | 9 +- .../examples/fpsgrid/fpsgrid.lpi | 352 ++++++++++++------ components/fpspreadsheet/fpsopendocument.pas | 32 +- components/fpspreadsheet/fpspreadsheet.pas | 273 ++++++++++++-- .../fpspreadsheet/fpspreadsheetgrid.pas | 40 +- components/fpspreadsheet/fpsutils.pas | 20 + components/fpspreadsheet/tests/colortests.pas | 234 ++++++++++++ components/fpspreadsheet/tests/fonttests.pas | 190 ++++++++++ .../fpspreadsheet/tests/formattests.pas | 59 --- .../fpspreadsheet/tests/manualtests.pas | 11 +- .../fpspreadsheet/tests/numberstests.pas | 2 +- .../fpspreadsheet/tests/spreadtestgui.lpi | 18 +- .../fpspreadsheet/tests/spreadtestgui.lpr | 5 +- components/fpspreadsheet/wikitable.pas | 25 +- components/fpspreadsheet/xlsbiff2.pas | 144 +++++-- components/fpspreadsheet/xlsbiff5.pas | 100 ++++- components/fpspreadsheet/xlsbiff8.pas | 250 ++++++------- components/fpspreadsheet/xlscommon.pas | 137 ++++--- components/fpspreadsheet/xlsxooxml.pas | 69 ++-- 20 files changed, 1395 insertions(+), 580 deletions(-) create mode 100644 components/fpspreadsheet/tests/colortests.pas create mode 100644 components/fpspreadsheet/tests/fonttests.pas diff --git a/components/fpspreadsheet/examples/excel8demo/excel8write.lpi b/components/fpspreadsheet/examples/excel8demo/excel8write.lpi index 7584cc24f..7689329c4 100644 --- a/components/fpspreadsheet/examples/excel8demo/excel8write.lpi +++ b/components/fpspreadsheet/examples/excel8demo/excel8write.lpi @@ -55,6 +55,11 @@ + + + + + diff --git a/components/fpspreadsheet/examples/excel8demo/excel8write.lpr b/components/fpspreadsheet/examples/excel8demo/excel8write.lpr index 65ccfee30..6751c9856 100644 --- a/components/fpspreadsheet/examples/excel8demo/excel8write.lpr +++ b/components/fpspreadsheet/examples/excel8demo/excel8write.lpr @@ -37,6 +37,7 @@ begin // Create the spreadsheet MyWorkbook := TsWorkbook.Create; MyWorkbook.SetDefaultFont('Calibri', 9); + MyWorkbook.UsePalette(@PALETTE_BIFF8, 64, true); MyWorksheet := MyWorkbook.AddWorksheet(Str_Worksheet1); @@ -54,6 +55,9 @@ begin lCell^.BackgroundColor := scPurple; lCell^.UsedFormattingFields := [uffBackgroundColor]; // or: MyWorksheet.WriteBackgroundColor(5, 3, scPurple); + MyWorksheet.WriteFontColor(5, 3, scWhite); + MyWorksheet.WriteFontSize(5, 3, 12); + // or: MyWorksheet.WriteFont(5, 3, 'Arial', 12, [], scWhite); // E6 empty cell, only background color MyWorksheet.WriteBackgroundColor(5, 4, scYellow); @@ -62,7 +66,8 @@ begin MyWorksheet.WriteBorders(5, 5, [cbNorth, cbEast, cbSouth, cbWest]); // Word-wrapped long text in D7 - MyWorksheet.WriteUTF8Text(6, 3, 'This is a very, very, very, very long text.'); + MyWorksheet.WriteUTF8Text(6, 3, 'This is a very, very, very, very long wrapped text.'); + MyWorksheet.WriteUsedFormatting(6, 3, [uffWordwrap]); // Cell with changed font in D8 MyWorksheet.WriteUTF8Text(7, 3, 'This is 16pt red bold & italic Times New Roman.'); @@ -71,7 +76,7 @@ begin // Cell with changed font and background in D9 MyWorksheet.WriteUTF8Text(8, 3, 'Colors...'); MyWorksheet.WriteFont(8, 3, 'Courier New', 12, [fssUnderline], scBlue); - // MyWorksheet.WriteBackgroundColor(8, 3, scYellow); + MyWorksheet.WriteBackgroundColor(8, 3, scYellow); { Uncomment this to test large XLS files for i := 2 to 20 do diff --git a/components/fpspreadsheet/examples/fpsgrid/fpsgrid.lpi b/components/fpspreadsheet/examples/fpsgrid/fpsgrid.lpi index 8a87e8e29..d5019c1ec 100644 --- a/components/fpspreadsheet/examples/fpsgrid/fpsgrid.lpi +++ b/components/fpspreadsheet/examples/fpsgrid/fpsgrid.lpi @@ -15,8 +15,79 @@ - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + @@ -37,7 +108,7 @@ - + @@ -46,7 +117,7 @@ - + @@ -58,9 +129,9 @@ - - - + + + @@ -69,19 +140,22 @@ - - - + + + + + + - + - - - + + + @@ -90,7 +164,7 @@ - + @@ -98,7 +172,7 @@ - + @@ -106,7 +180,7 @@ - + @@ -114,14 +188,14 @@ - + - + @@ -129,7 +203,7 @@ - + @@ -137,32 +211,34 @@ - + + - - - + + + + - - - + + + - + - - - + + + @@ -170,37 +246,35 @@ - + - + - - - + + + + - - - + + + + - - + - - - - - - + + + @@ -209,40 +283,43 @@ - + - + - + - - - + + + - + - + + + - - - + + + + @@ -250,129 +327,154 @@ - + + + + + + + + + + + + + + + + + + + + + + + + + + - - + + - - + + - - + + - - + + - - + + - - + + - - + + - - + + - - + + - - + + - - + + - - + + - - + + - - + + - - + + - - + + - - + + - - + + - - + + - - + + - - + + - + - + - - + + - - + + - - + + - - + + - - + + - - + + - - + + @@ -388,6 +490,9 @@ + + + @@ -399,12 +504,15 @@ - + - + + + + - + @@ -414,6 +522,12 @@ + + + + + + diff --git a/components/fpspreadsheet/fpsopendocument.pas b/components/fpspreadsheet/fpsopendocument.pas index 2faf48e03..d644a1ac4 100755 --- a/components/fpspreadsheet/fpsopendocument.pas +++ b/components/fpspreadsheet/fpsopendocument.pas @@ -85,7 +85,7 @@ type procedure WriteMeta; procedure WriteSettings; procedure WriteStyles; - procedure WriteContent(AData: TsWorkbook); + procedure WriteContent; procedure WriteWorksheet(CurSheet: TsWorksheet); // Routines to write parts of those files function WriteStylesXMLAsString: string; @@ -101,12 +101,12 @@ type procedure WriteDateTime(AStream: TStream; const ARow, ACol: Cardinal; const AValue: TDateTime; ACell: PCell); override; public - constructor Create; override; + constructor Create(AWorkbook: TsWorkbook); override; { General writing methods } procedure WriteStringToFile(AString, AFileName: string); - procedure WriteToFile(const AFileName: string; AData: TsWorkbook; + procedure WriteToFile(const AFileName: string; const AOverwriteExisting: Boolean = False); override; - procedure WriteToStream(AStream: TStream; AData: TsWorkbook); override; + procedure WriteToStream(AStream: TStream); override; end; implementation @@ -544,14 +544,14 @@ begin ''; end; -procedure TsSpreadOpenDocWriter.WriteContent(AData: TsWorkbook); +procedure TsSpreadOpenDocWriter.WriteContent; var i: Integer; lStylesCode: string; begin - ListAllFormattingStyles(AData); + ListAllFormattingStyles; - lStylesCode := WriteStylesXMLAsString(); + lStylesCode := WriteStylesXMLAsString; FContent := XML_HEADER + LineEnding + @@ -602,10 +602,8 @@ begin ' ' + LineEnding; // Write all worksheets - for i := 0 to AData.GetWorksheetCount - 1 do - begin - WriteWorksheet(Adata.GetWorksheetByIndex(i)); - end; + for i := 0 to Workbook.GetWorksheetCount - 1 do + WriteWorksheet(Workbook.GetWorksheetByIndex(i)); FContent := FContent + ' ' + LineEnding + @@ -701,7 +699,7 @@ begin if (uffBackgroundColor in FFormattingStyles[i].UsedFormattingFields) then begin Result := Result + 'fo:background-color="#' - + FPSColorToHexString(FFormattingStyles[i].BackgroundColor, FFormattingStyles[i].RGBBackgroundColor) +'" '; + + Workbook.FPSColorToHexString(FFormattingStyles[i].BackgroundColor, FFormattingStyles[i].RGBBackgroundColor) +'" '; end; if (uffWordWrap in FFormattingStyles[i].UsedFormattingFields) then @@ -718,9 +716,9 @@ begin end; end; -constructor TsSpreadOpenDocWriter.Create; +constructor TsSpreadOpenDocWriter.Create(AWorkbook: TsWorkbook); begin - inherited Create; + inherited Create(AWorkbook); FPointSeparatorSettings := SysUtils.DefaultFormatSettings; FPointSeparatorSettings.DecimalSeparator:='.'; @@ -744,7 +742,7 @@ end; Writes an OOXML document to the disc. } procedure TsSpreadOpenDocWriter.WriteToFile(const AFileName: string; - AData: TsWorkbook; const AOverwriteExisting: Boolean); + const AOverwriteExisting: Boolean); var FZip: TZipper; begin @@ -755,7 +753,7 @@ begin WriteMeta(); WriteSettings(); WriteStyles(); - WriteContent(AData); + WriteContent; { Write the data to streams } @@ -792,7 +790,7 @@ begin end; -procedure TsSpreadOpenDocWriter.WriteToStream(AStream: TStream; AData: TsWorkbook); +procedure TsSpreadOpenDocWriter.WriteToStream(AStream: TStream); begin // Not supported at the moment raise Exception.Create('TsSpreadOpenDocWriter.WriteToStream not supported'); diff --git a/components/fpspreadsheet/fpspreadsheet.pas b/components/fpspreadsheet/fpspreadsheet.pas index 98b4c2315..90ed043c7 100755 --- a/components/fpspreadsheet/fpspreadsheet.pas +++ b/components/fpspreadsheet/fpspreadsheet.pas @@ -179,12 +179,63 @@ type TsHorAlignment = (haDefault, haLeft, haCenter, haRight); TsVertAlignment = (vaDefault, vaTop, vaCenter, vaBottom); + {@@ + Colors in fpspreadsheet are given as indices into a palette. + Use the workbook's GetPaletteColor to determine the color rgb value (with + "r" being the low-value byte, in agreement with TColor). + } + TsColor = Word; + +{@@ + These are some constants for color indices into the default palette. + Note, however, that if a different palette is used there may be more colors, + and the names of the color constants may no longer be correct. +} +const + scBlack = $00; + scWhite = $01; + scRed = $02; + scGreen = $03; + scBlue = $04; + scYellow = $05; + scMagenta = $06; + scCyan = $07; + scEGABlack = $08; + scEGAWhite = $09; + scEGARed = $0A; + scEGAGreen = $0B; + scEGABlue = $0C; + scEGAYellow = $0D; + scEGAMagenta = $0E; + scEGACyan = $0F; + scDarkRed = $10; + scDarkGreen = $11; + scDarkBlue = $12; + scOLIVE = $13; + scPURPLE = $14; + scTEAL = $15; + scSilver = $16; + scGrey = $17; + scOrange = $18; + scRGBColor = $FFFF; + { + // + scGrey10pct,// E6E6E6H + scGrey20pct,// CCCCCCH + scOrange, // ffa500H + scDarkBrown,// a0522dH + scBrown, // cd853fH + scBeige, // f5f5dcH + scWheat, // f5deb3H + } + + {@@ Colors in FPSpreadsheet as given by a palette to be compatible with Excel. However, please note that they are physically written to XLS file as ABGR (where A is 0) } - + (* TsColor = ( // R G B color value: - scBlack , // 000000H + scBlack, // 000000H scWhite, // FFFFFFH scRed, // FF0000H scGREEN, // 00FF00H @@ -211,14 +262,18 @@ type // scRGBCOLOR // Defined via TFPColor ); + *) + +type + {@@ Palette of color values } + TsPalette = array[0..0] of DWord; + PsPalette = ^TsPalette; {@@ Font style (redefined to avoid usage of "Graphics" } - TsFontStyle = (fssBold, fssItalic, fssStrikeOut, fssUnderline); TsFontStyles = set of TsFontStyle; {@@ Font } - TsFont = class FontName: String; Size: Single; // in "points" @@ -269,7 +324,7 @@ type PRow = ^TRow; TCol = record - Col: Byte; + Col: Cardinal; Width: Single; // in "characters". Excel uses the with of char "0" in 1st font end; @@ -324,6 +379,8 @@ type function WriteFont(ARow, ACol: Cardinal; const AFontName: String; AFontSize: Single; AFontStyle: TsFontStyles; AFontColor: TsColor): Integer; overload; procedure WriteFont(ARow, ACol: Cardinal; AFontIndex: Integer); overload; + function WriteFontColor(ARow, ACol: Cardinal; AFontColor: TsColor): Integer; + function WriteFontSize(ARow, ACol: Cardinal; ASize: Integer): Integer; procedure WriteTextRotation(ARow, ACol: Cardinal; ARotation: TsTextRotation); procedure WriteUsedFormatting(ARow, ACol: Cardinal; AUsedFormatting: TsUsedFormattingFields); procedure WriteBackgroundColor(ARow, ACol: Cardinal; AColor: TsColor); @@ -356,6 +413,7 @@ type FFormat: TsSpreadsheetFormat; FFontList: TFPList; FBuiltinFontCount: Integer; + FPalette: array of DWord; { Internal methods } procedure RemoveWorksheetsCallback(data, arg: pointer); public @@ -393,6 +451,11 @@ type procedure InitFonts; procedure RemoveAllFonts; procedure SetDefaultFont(const AFontName: String; ASize: Single); + { Color handling } + function FPSColorToHexString(AColor: TsColor; ARGBColor: TFPColor): String; + function GetPaletteColor(AColorIndex: TsColor): DWord; + function GetPaletteSize: Integer; + procedure UsePalette(APalette: PsPalette; APaletteCount: Word; AFlipBytes: Boolean); {@@ This property is only used for formats which don't support unicode and support a single encoding for the whole document, like Excel 2 to 5 } property Encoding: TsEncoding read FEncoding write FEncoding; @@ -415,12 +478,12 @@ type procedure ReadLabel(AStream: TStream); virtual; abstract; procedure ReadNumber(AStream: TStream); virtual; abstract; public - constructor Create; virtual; // To allow descendents to override it + constructor Create(AWorkbook: TsWorkbook); virtual; // To allow descendents to override it { General writing methods } procedure ReadFromFile(AFileName: string; AData: TsWorkbook); virtual; procedure ReadFromStream(AStream: TStream; AData: TsWorkbook); virtual; procedure ReadFromStrings(AStrings: TStrings; AData: TsWorkbook); virtual; - property Wordbook: TsWorkbook read FWorkbook; + property Workbook: TsWorkbook read FWorkbook; end; {@@ TsSpreadWriter class reference type } @@ -433,14 +496,14 @@ type TsCustomSpreadWriter = class private + FWorkbook: TsWorkbook; protected { Helper routines } procedure AddDefaultFormats(); virtual; function ExpandFormula(AFormula: TsFormula): TsExpandedFormula; function FindFormattingInList(AFormat: PCell): Integer; - function FPSColorToHexString(AColor: TsColor; ARGBColor: TFPColor): string; procedure ListAllFormattingStylesCallback(ACell: PCell; AStream: TStream); - procedure ListAllFormattingStyles(AData: TsWorkbook); + procedure ListAllFormattingStyles; { Helpers for writing } procedure WriteCellCallback(ACell: PCell; AStream: TStream); procedure WriteCellsToStream(AStream: TStream; ACells: TAVLTree); @@ -458,13 +521,13 @@ type } FFormattingStyles: array of TCell; NextXFIndex: Integer; // Indicates which should be the next XF (Style) Index when filling the styles list - constructor Create; virtual; // To allow descendents to override it + constructor Create(AWorkbook: TsWorkbook); virtual; // To allow descendents to override it { General writing methods } procedure IterateThroughCells(AStream: TStream; ACells: TAVLTree; ACallback: TCellsCallback); - procedure WriteToFile(const AFileName: string; AData: TsWorkbook; - const AOverwriteExisting: Boolean = False); virtual; - procedure WriteToStream(AStream: TStream; AData: TsWorkbook); virtual; - procedure WriteToStrings(AStrings: TStrings; AData: TsWorkbook); virtual; + procedure WriteToFile(const AFileName: string; const AOverwriteExisting: Boolean = False); virtual; + procedure WriteToStream(AStream: TStream); virtual; + procedure WriteToStrings(AStrings: TStrings); virtual; + property Workbook: TsWorkbook read FWorkbook; end; {@@ List of registered formats } @@ -537,7 +600,6 @@ function GetFileFormatName(AFormat: TsSpreadsheetFormat): String; function SciFloat(AValue: Double; ADecimals: Word): String; function TimeIntervalToString(AValue: TDateTime): String; - implementation uses @@ -551,6 +613,38 @@ resourcestring lpUnknownSpreadsheetFormat = 'unknown format'; lpInvalidFontIndex = 'Invalid font index'; +const + {@@ + Colors in RGB (red at left). Needs to be inverted to get TColor. + The indices into this palette are named as scXXXX color constants. + } + DEFAULT_PALETTE: array[$0..$18] of DWord = ( + $000000, // $00: black + $FFFFFF, // $01: white + $FF0000, // $02: red + $00FF00, // $03: green + $0000FF, // $04: blue + $FFFF00, // $05: yellow + $FF00FF, // $06: magenta + $00FFFF, // $07: cyan + $000000, // $08: EGA black + $FFFFFF, // $09: EGA white + $FF0000, // $0A: EGA red + $00FF00, // $0B: EGA green + $0000FF, // $0C: EGA blue + $FFFF00, // $0D: EGA yellow + $FF00FF, // $0E: EGA magenta + $00FFFF, // $0F: EGA cyan + $800000, // $10: EGA dark red + $008000, // $11: EGA dark green + $000080, // $12: EGA dark blue + $808000, // $13: EGA olive + $800080, // $14: EGA purple + $008080, // $15: EGA teal + $C0C0C0, // $16: EGA silver + $808080, // $17: EGA gray + $FFA500 // $18: orange + ); {@@ Registers a new reader/writer pair for a format @@ -1288,6 +1382,26 @@ begin raise Exception.Create(lpInvalidFontIndex); end; +function TsWorksheet.WriteFontColor(ARow, ACol: Cardinal; AFontColor: TsColor): Integer; +var + lCell: PCell; + fnt: TsFont; +begin + lCell := GetCell(ARow, ACol); + fnt := Workbook.GetFont(lCell^.FontIndex); + Result := WriteFont(ARow, ACol, fnt.FontName, fnt.Size, fnt.Style, AFontColor); +end; + +function TsWorksheet.WriteFontSize(ARow, ACol: Cardinal; ASize: Integer): Integer; +var + lCell: PCell; + fnt: TsFont; +begin + lCell := GetCell(ARow, ACol); + fnt := Workbook.GetFont(lCell^.FontIndex); + Result := WriteFont(ARow, ACol, fnt.FontName, ASize, fnt.Style, fnt.Color); +end; + {@@ Adds text rotation to the formatting of a cell @@ -1521,8 +1635,7 @@ begin for i := 0 to Length(GsSpreadFormats) - 1 do if GsSpreadFormats[i].Format = AFormat then begin - Result := GsSpreadFormats[i].ReaderClass.Create; - Result.FWorkbook := self; + Result := GsSpreadFormats[i].ReaderClass.Create(self); Break; end; @@ -1542,7 +1655,7 @@ begin for i := 0 to Length(GsSpreadFormats) - 1 do if GsSpreadFormats[i].Format = AFormat then begin - Result := GsSpreadFormats[i].WriterClass.Create; + Result := GsSpreadFormats[i].WriterClass.Create(self); Break; end; @@ -1657,9 +1770,8 @@ var AWriter: TsCustomSpreadWriter; begin AWriter := CreateSpreadWriter(AFormat); - try - AWriter.WriteToFile(AFileName, Self, AOverwriteExisting); + AWriter.WriteToFile(AFileName, AOverwriteExisting); finally AWriter.Free; end; @@ -1690,7 +1802,7 @@ begin AWriter := CreateSpreadWriter(AFormat); try - AWriter.WriteToStream(AStream, Self); + AWriter.WriteToStream(AStream); finally AWriter.Free; end; @@ -1948,11 +2060,101 @@ begin Result := FFontList.Count; end; +{@@ + Converts a fpspreadsheet color into into a string RRGGBB. + Note that colors are written to xls files as ABGR (where A is 0). + if the color is scRGBColor the color value is taken from the argument + ARGBColor, otherwise from the palette entry for the color index. +} +function TsWorkbook.FPSColorToHexString(AColor: TsColor; + ARGBColor: TFPColor): string; +type + TRgba = packed record Red, Green, Blue, A: Byte end; +var + color: DWord; + r,g,b: Byte; +begin + if AColor = scRGBColor then begin + r := ARGBColor.Red div $100; + g := ARGBColor.Green div $100; + b := ARGBColor.Blue div $100; + end else begin + color := GetPaletteColor(AColor); + r := TRgba(color).Red; + g := TRgba(color).Green; + b := TRgba(color).Blue; + end; + Result := Format('%x%x%x', [r, g, b]); +end; + + + +{@@ + Reads the rgb color for the given index from the current palette. Can be + type-cast to TColor for usage in GUI applications. +} +function TsWorkbook.GetPaletteColor(AColorIndex: TsColor): DWord; +begin + if (AColorIndex >= 0) and (AColorIndex < GetPaletteSize) then begin + if ((FPalette = nil) or (Length(FPalette) = 0)) then + Result := LongRGBToExcelPhysical(DEFAULT_PALETTE[AColorIndex]) + else + Result := FPalette[AColorIndex]; + end else + Result := $000000; // "black" as default +end; + +{@@ + Returns the size of color palette +} +function TsWorkbook.GetPaletteSize: Integer; +begin + if (FPalette = nil) or (Length(FPalette) = 0) then + Result := High(DEFAULT_PALETTE) + 1 + else + Result := Length(FPalette); +end; + +{@@ + Instructs the Workbook to take colors from the palette pointed to by the parameter + This palette is only used for writing. When reading the palette found in the + file is used. +} +procedure TsWorkbook.UsePalette(APalette: PsPalette; APaletteCount: Word; + AFlipBytes: Boolean); +var + i: Integer; +begin + {$IFOPT R+} + {$DEFINE RNGCHECK} + {$ENDIF} + SetLength(FPalette, APaletteCount); + if AFlipBytes then + for i:=0 to APaletteCount-1 do + {$IFDEF RNGCHECK} + {$R-} + {$ENDIF} + FPalette[i] := LongRGBToExcelPhysical(APalette^[i]) + {$IFDEF RNGCHECK} + {$R+} + {$ENDIF} + else + for i:=0 to APaletteCount-1 do + {$IFDEF RNGCHECK} + {$R-} + {$ENDIF} + FPalette[i] := APalette^[i]; + {$IFDEF RNGCHECK} + {$R+} + {$ENDIF} +end; + { TsCustomSpreadReader } -constructor TsCustomSpreadReader.Create; +constructor TsCustomSpreadReader.Create(AWorkbook: TsWorkbook); begin inherited Create; + FWorkbook := AWorkbook; end; {@@ @@ -2006,9 +2208,10 @@ end; { TsCustomSpreadWriter } -constructor TsCustomSpreadWriter.Create; +constructor TsCustomSpreadWriter.Create(AWorkbook: TsWorkbook); begin inherited Create; + FWorkbook := AWorkbook; end; {@@ @@ -2082,7 +2285,7 @@ begin Inc(NextXFIndex); end; -procedure TsCustomSpreadWriter.ListAllFormattingStyles(AData: TsWorkbook); +procedure TsCustomSpreadWriter.ListAllFormattingStyles; var i: Integer; begin @@ -2090,9 +2293,9 @@ begin AddDefaultFormats(); - for i := 0 to AData.GetWorksheetCount - 1 do + for i := 0 to Workbook.GetWorksheetCount - 1 do begin - IterateThroughCells(nil, AData.GetWorksheetByIndex(i).Cells, ListAllFormattingStylesCallback); + IterateThroughCells(nil, Workbook.GetWorksheetByIndex(i).Cells, ListAllFormattingStylesCallback); end; end; @@ -2139,11 +2342,12 @@ begin Inc(StrPos); end; end; - + (* function TsCustomSpreadWriter.FPSColorToHexString(AColor: TsColor; ARGBColor: TFPColor): string; { We use RGB bytes here, but please note that these are physically written to XLS file as ABGR (where A is 0) } begin + case AColor of scBlack: Result := '000000'; scWhite: Result := 'FFFFFF'; @@ -2173,7 +2377,7 @@ begin scRGBCOLOR: Result := Format('%x%x%x', [ARGBColor.Red div $100, ARGBColor.Green div $100, ARGBColor.Blue div $100]); end; end; - + *) {@@ Helper function for the spreadsheet writers. @@ -2228,15 +2432,15 @@ end; Default file writting method. Opens the file and calls WriteToStream + The workbook written is the one specified in the constructor of the writer. @param AFileName The output file name. If the file already exists it will be replaced. - @param AData The Workbook to be saved. @see TsWorkbook } procedure TsCustomSpreadWriter.WriteToFile(const AFileName: string; - AData: TsWorkbook; const AOverwriteExisting: Boolean = False); + const AOverwriteExisting: Boolean = False); var OutputFile: TFileStream; lMode: Word; @@ -2246,7 +2450,7 @@ begin OutputFile := TFileStream.Create(AFileName, lMode); try - WriteToStream(OutputFile, AData); + WriteToStream(OutputFile); finally OutputFile.Free; end; @@ -2255,21 +2459,20 @@ end; {@@ This routine should be overriden in descendent classes. } -procedure TsCustomSpreadWriter.WriteToStream(AStream: TStream; AData: TsWorkbook); +procedure TsCustomSpreadWriter.WriteToStream(AStream: TStream); var lStringList: TStringList; begin lStringList := TStringList.Create; try - WriteToStrings(lStringList, AData); + WriteToStrings(lStringList); lStringList.SaveToStream(AStream); finally lStringList.Free; end; end; -procedure TsCustomSpreadWriter.WriteToStrings(AStrings: TStrings; - AData: TsWorkbook); +procedure TsCustomSpreadWriter.WriteToStrings(AStrings: TStrings); begin raise Exception.Create(lpUnsupportedWriteFormat); end; diff --git a/components/fpspreadsheet/fpspreadsheetgrid.pas b/components/fpspreadsheet/fpspreadsheetgrid.pas index 40968a76e..4c679fbbc 100644 --- a/components/fpspreadsheet/fpspreadsheetgrid.pas +++ b/components/fpspreadsheet/fpspreadsheetgrid.pas @@ -149,8 +149,6 @@ type property OnContextPopup; end; -function FPSColorToColor(FPSColor: TsColor; ADefault: TColor): TColor; - procedure Register; implementation @@ -174,37 +172,6 @@ begin end; end; -function FPSColorToColor(FPSColor: TsColor; ADefault: TColor): 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($0000A5FF); // FFA500 - scDarkBrown: Result := TColor($002D52A0); // A0522D - scBrown : Result := TColor($003F85CD); // CD853F - scBeige : Result := TColor($00DCF5F5); // F5F5DC - scWheat : Result := TColor($00B3DEF5); // F5DEB3 - else Result := ADefault; - end; -end; - procedure Register; begin RegisterComponents('Additional',[TsWorksheetGrid]); @@ -302,7 +269,10 @@ begin Canvas.Brush.Bitmap := FillPattern_BIFF2; end else begin Canvas.Brush.Style := bsSolid; - Canvas.Brush.Color := FPSColorToColor(lCell^.BackgroundColor, Color); + if lCell^.BackgroundColor < FWorkbook.GetPaletteSize then + Canvas.Brush.Color := FWorkbook.GetPaletteColor(lCell^.BackgroundColor) + else + Canvas.Brush.Color := Color; end; end else begin Canvas.Brush.Style := bsSolid; @@ -313,7 +283,7 @@ begin fnt := FWorkbook.GetFont(lCell^.FontIndex); if fnt <> nil then begin Canvas.Font.Name := fnt.FontName; - Canvas.Font.Color := FPSColorToColor(fnt.Color, clBlack); + Canvas.Font.Color := FWorkbook.GetPaletteColor(fnt.Color); style := []; if fssBold in fnt.Style then Include(style, fsBold); if fssItalic in fnt.Style then Include(style, fsItalic); diff --git a/components/fpspreadsheet/fpsutils.pas b/components/fpspreadsheet/fpsutils.pas index feb3317a8..7cec8c7ad 100644 --- a/components/fpspreadsheet/fpsutils.pas +++ b/components/fpspreadsheet/fpsutils.pas @@ -34,6 +34,8 @@ function WordLEtoN(AValue: Word): Word; function DWordLEtoN(AValue: Cardinal): Cardinal; function WideStringLEToN(const AValue: WideString): WideString; +function LongRGBToExcelPhysical(const RGB: DWord): DWord; + // Other routines function ParseIntervalString(const AStr: string; var AFirstCellRow, AFirstCellCol, ACount: Integer; @@ -155,6 +157,24 @@ begin {$ENDIF} end; +{ Converts RGB part of a LongRGB logical structure to its physical representation + IOW: RGBA (where A is 0 and omitted in the function call) => ABGR + Needed for conversion of palette colors. } +function LongRGBToExcelPhysical(const RGB: DWord): DWord; +begin + {$IFDEF FPC} + {$IFDEF ENDIAN_LITTLE} + result := RGB shl 8; //tags $00 at end for the A byte + result := SwapEndian(result); //flip byte order + {$ELSE} + //Big endian + result := RGB; //leave value as is //todo: verify if this turns out ok + {$ENDIF} + {$ELSE} + // messed up result + {$ENDIF} +end; + {@@ Parses strings like A5:A10 into an selection interval information } diff --git a/components/fpspreadsheet/tests/colortests.pas b/components/fpspreadsheet/tests/colortests.pas new file mode 100644 index 000000000..ff5a79650 --- /dev/null +++ b/components/fpspreadsheet/tests/colortests.pas @@ -0,0 +1,234 @@ +unit colortests; + +{$mode objfpc}{$H+} + +interface +{ Color tests +This unit tests writing out to and reading back from files. +} + +uses + // Not using Lazarus package as the user may be working with multiple versions + // Instead, add .. to unit search path + Classes, SysUtils, fpcunit, testregistry, + fpspreadsheet, xlsbiff5, xlsbiff8 {and a project requirement for lclbase for utf8 handling}, + testsutility; + +type + { TSpreadWriteReadColorTests } + //Write to xls/xml file and read back + TSpreadWriteReadColorTests = class(TTestCase) + private + protected + // Set up expected values: + procedure SetUp; override; + procedure TearDown; override; + procedure TestWriteReadBackgroundColors(WhichPalette: Integer); + procedure TestWriteReadFontColors(WhichPalette: Integer); + published + // Writes out colors & reads back. + // Background colors... + procedure TestWriteRead_Background_Internal; // internal palette + procedure TestWriteRead_Background_Biff5; // official biff5 palette + procedure TestWriteRead_Background_Biff8; // official biff8 palette + // Font colors... + procedure TestWriteRead_Font_Internal; // internal palette + procedure TestWriteRead_Font_Biff5; // official biff5 palette + procedure TestWriteRead_Font_Biff8; // official biff8 palette + end; + +implementation + +const + ColorsSheet = 'Colors'; + +{ TSpreadWriteReadColorTests } + +procedure TSpreadWriteReadColorTests.SetUp; +begin + inherited SetUp; +end; + +procedure TSpreadWriteReadColorTests.TearDown; +begin + inherited TearDown; +end; + +procedure TSpreadWriteReadColorTests.TestWriteReadBackgroundColors(WhichPalette: Integer); +// WhichPalette = 5: BIFF5 palette +// 8: BIFF8 palette +// else internal palette +// 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; + expectedRGB: DWord; + currentRGB: DWord; +begin + TempFile:=GetTempFileName; + {// Not needed: use workbook.writetofile with overwrite=true + if fileexists(TempFile) then + DeleteFile(TempFile); + } + MyWorkbook := TsWorkbook.Create; + MyWorkSheet:= MyWorkBook.AddWorksheet(ColorsSheet); + + // Define palette + case whichPalette of + 5: MyWorkbook.UsePalette(@PALETTE_BIFF5, High(PALETTE_BIFF5)+1, true); + 8: MyWorkbook.UsePalette(@PALETTE_BIFF8, High(PALETTE_BIFF8)+1, true); + // else use default palette + end; + + // Write out all colors + row := 0; + col := 0; + for color := 0 to MyWorkbook.GetPaletteSize-1 do begin + 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.'); + currentRGB := MyWorkbook.GetPaletteColor(MyCell^.BackgroundColor); + expectedRGB := MyWorkbook.GetPaletteColor(color); + CheckEquals(currentRGB, expectedRGB, + '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, ColorsSheet); + 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); + currentRGB := MyWorkbook.GetPaletteColor(MyCell^.BackgroundColor); + expectedRGB := MyWorkbook.GetPaletteColor(color); + CheckEquals(currentRGB, expectedRGB, + 'Test saved background color, cell '+CellNotation(MyWorksheet,Row,Col)); + end; + MyWorkbook.Free; + + DeleteFile(TempFile); +end; + +procedure TSpreadWriteReadColorTests.TestWriteReadFontColors(WhichPalette: Integer); +// WhichPalette = 5: BIFF5 palette +// 8: BIFF8 palette +// else internal palette +// 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, colorInFile: TsColor; + expectedRGB, currentRGB: DWord; +begin + TempFile:=GetTempFileName; + {// Not needed: use workbook.writetofile with overwrite=true + if fileexists(TempFile) then + DeleteFile(TempFile); + } + MyWorkbook := TsWorkbook.Create; + MyWorkSheet:= MyWorkBook.AddWorksheet(ColorsSheet); + + // Define palette + case whichPalette of + 5: MyWorkbook.UsePalette(@PALETTE_BIFF5, High(PALETTE_BIFF5)+1, true); + 8: MyWorkbook.UsePalette(@PALETTE_BIFF8, High(PALETTE_BIFF8)+1, true); + // else use default palette + end; + + // Write out all colors + row := 0; + col := 0; + for color := 0 to MyWorkbook.GetPaletteSize-1 do begin + MyWorksheet.WriteUTF8Text(row, col, CELLTEXT); + MyWorksheet.WriteFontColor(row, col, color); + MyCell := MyWorksheet.FindCell(row, col); + if MyCell = nil then + fail('Error in test code. Failed to get cell.'); + colorInFile := MyWorkbook.GetFont(MyCell^.FontIndex).Color; + currentRGB := MyWorkbook.GetPaletteColor(colorInFile); + expectedRGB := MyWorkbook.GetPaletteColor(color); + CheckEquals(currentRGB, expectedRGB, + 'Test unsaved font 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, ColorsSheet); + 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); + colorInFile := MyWorkbook.GetFont(MyCell^.FontIndex).Color; + currentRGB := MyWorkbook.GetPaletteColor(colorInFile); + expectedRGB := MyWorkbook.GetPaletteColor(color); + CheckEquals(currentRGB, expectedRGB, + 'Test saved font color, cell '+CellNotation(MyWorksheet,Row,Col)); + end; + MyWorkbook.Free; + + DeleteFile(TempFile); +end; + +procedure TSpreadWriteReadColorTests.TestWriteRead_Background_Internal; +begin + TestWriteReadBackgroundColors(0); +end; + +procedure TSpreadWriteReadColorTests.TestWriteRead_Background_Biff5; +begin + TestWriteReadBackgroundColors(5); +end; + +procedure TSpreadWriteReadColorTests.TestWriteRead_Background_Biff8; +begin + TestWriteReadBackgroundColors(8); +end; + +procedure TSpreadWriteReadColorTests.TestWriteRead_Font_Internal; +begin + TestWriteReadFontColors(0); +end; + +procedure TSpreadWriteReadColorTests.TestWriteRead_Font_Biff5; +begin + TestWriteReadFontColors(5); +end; + +procedure TSpreadWriteReadColorTests.TestWriteRead_Font_Biff8; +begin + TestWriteReadFontColors(8); +end; + +initialization + RegisterTest(TSpreadWriteReadColorTests); + +end. + diff --git a/components/fpspreadsheet/tests/fonttests.pas b/components/fpspreadsheet/tests/fonttests.pas new file mode 100644 index 000000000..d5e2c4573 --- /dev/null +++ b/components/fpspreadsheet/tests/fonttests.pas @@ -0,0 +1,190 @@ +unit fonttests; + +{$mode objfpc}{$H+} + +interface +{ Font tests +This unit tests writing out to and reading back from files. +} + +uses + // Not using Lazarus package as the user may be working with multiple versions + // Instead, add .. to unit search path + Classes, SysUtils, fpcunit, testregistry, + fpspreadsheet, xlsbiff8 {and a project requirement for lclbase for utf8 handling}, + testsutility; + +var + // Norm to test against - list of font sizes that should occur in spreadsheet + SollSizes: array[0..12] of single; //"Soll" is a German word in Dutch accountancy jargon meaning "normative value to check against". There ;) + SollStyles: array[0..15] of TsFontStyles; + + // Initializes Soll*/normative variables. + // Useful in test setup procedures to make sure the norm is correct. + procedure InitSollSizes; + procedure InitSollStyles; + +type + { TSpreadWriteReadFontTests } + //Write to xls/xml file and read back + TSpreadWriteReadFontTests = class(TTestCase) + private + protected + // Set up expected values: + procedure SetUp; override; + procedure TearDown; override; + procedure TestWriteReadFont(AFontName: String); + published + procedure TestWriteReadFont_Arial; + procedure TestWriteReadFont_TimesNewRoman; + procedure TestWriteReadFont_CourierNew; + end; + +implementation + +uses + TypInfo; + +const + FontSheet = 'Font'; + +// When adding tests, add values to this array +// and increase array size in variable declaration +procedure InitSollSizes; +begin + // Set up norm - MUST match spreadsheet cells exactly + SollSizes[0]:=8.0; + SollSizes[1]:=9.0; + SollSizes[2]:=10.0; + SollSizes[3]:=11.0; + SollSizes[4]:=12.0; + SollSizes[5]:=13.0; + SollSizes[6]:=14.0; + SollSizes[7]:=16.0; + SollSizes[8]:=18.0; + SollSizes[9]:=20.0; + SollSizes[10]:=24.0; + SollSizes[11]:=32.0; + SollSizes[12]:=48.0; +end; + +procedure InitSollStyles; +begin + SollStyles[0] := []; + SollStyles[1] := [fssBold]; + SolLStyles[2] := [fssItalic]; + SollStyles[3] := [fssBold, fssItalic]; + SollStyles[4] := [fssUnderline]; + SollStyles[5] := [fssUnderline, fssBold]; + SollStyles[6] := [fssUnderline, fssItalic]; + SollStyles[7] := [fssUnderline, fssBold, fssItalic]; + SollStyles[8] := [fssStrikeout]; + SollStyles[9] := [fssStrikeout, fssBold]; + SolLStyles[10] := [fssStrikeout, fssItalic]; + SollStyles[11] := [fssStrikeout, fssBold, fssItalic]; + SollStyles[12] := [fssStrikeout, fssUnderline]; + SollStyles[13] := [fssStrikeout, fssUnderline, fssBold]; + SollStyles[14] := [fssStrikeout, fssUnderline, fssItalic]; + SollStyles[15] := [fssStrikeout, fssUnderline, fssBold, fssItalic]; +end; + +{ TSpreadWriteReadFontTests } + +procedure TSpreadWriteReadFontTests.SetUp; +begin + inherited SetUp; + InitSollSizes; + InitSollStyles; +end; + +procedure TSpreadWriteReadFontTests.TearDown; +begin + inherited TearDown; +end; + +procedure TSpreadWriteReadFontTests.TestWriteReadFont(AFontName: String); +var + MyWorksheet: TsWorksheet; + MyWorkbook: TsWorkbook; + row, col: Integer; + MyCell: PCell; + TempFile: string; //write xls/xml to this file and read back from it + cellText: String; + font: TsFont; + currValue: String; + expectedValue: String; +begin + TempFile:=GetTempFileName; + {// Not needed: use workbook.writetofile with overwrite=true + if fileexists(TempFile) then + DeleteFile(TempFile); + } + MyWorkbook := TsWorkbook.Create; + MyWorkSheet:= MyWorkBook.AddWorksheet(FontSheet); + + // Write out all font styles at various sizes + for row := 0 to High(SollSizes) do begin + for col := 0 to High(SollStyles) do begin + cellText := Format('%s, %.1f-pt', [AFontName, SollSizes[row]]); + MyWorksheet.WriteUTF8Text(row, col, celltext); + MyWorksheet.WriteFont(row, col, AFontName, SollSizes[row], SollStyles[col], scBlack); + + MyCell := MyWorksheet.FindCell(row, col); + if MyCell = nil then + fail('Error in test code. Failed to get cell.'); + font := MyWorkbook.GetFont(MyCell^.FontIndex); + CheckEquals(SollSizes[row], font.Size, + 'Test unsaved font size, cell ' + CellNotation(MyWorksheet,0,0)); + currValue := GetEnumName(TypeInfo(TsFontStyles), byte(font.Style)); + expectedValue := GetEnumName(TypeInfo(TsFontStyles), byte(SollStyles[col])); + CheckEquals(currValue, expectedValue, + 'Test unsaved font style, cell ' + CellNotation(MyWorksheet,0,0)); + end; + end; + MyWorkBook.WriteToFile(TempFile,sfExcel8,true); + MyWorkbook.Free; + + // Open the spreadsheet, as biff8 + MyWorkbook := TsWorkbook.Create; + MyWorkbook.ReadFromFile(TempFile, sfExcel8); + MyWorksheet := GetWorksheetByName(MyWorkBook, FontSheet); + if MyWorksheet=nil then + fail('Error in test code. Failed to get named worksheet'); + for row := 0 to MyWorksheet.GetLastRowNumber do + for col := 0 to MyWorksheet.GetLastColNumber do begin + MyCell := MyWorksheet.FindCell(row, col); + if MyCell = nil then + fail('Error in test code. Failed to get cell.'); + font := MyWorkbook.GetFont(MyCell^.FontIndex); + CheckEquals(SollSizes[row], font.Size, + 'Test saved font size, cell '+CellNotation(MyWorksheet,Row,Col)); + currValue := GetEnumName(TypeInfo(TsFontStyles), byte(font.Style)); + expectedValue := GetEnumName(TypeInfo(TsFontStyles), byte(SollStyles[col])); + CheckEquals(currValue, expectedValue, + 'Test unsaved font style, cell ' + CellNotation(MyWorksheet,0,0)); + end; + MyWorkbook.Free; + + DeleteFile(TempFile); +end; + +procedure TSpreadWriteReadFontTests.TestWriteReadFont_Arial; +begin + TestWriteReadFont('Arial'); +end; + +procedure TSpreadWriteReadFontTests.TestWriteReadFont_TimesNewRoman; +begin + TestWriteReadFont('TimesNewRoman'); +end; + +procedure TSpreadWriteReadFontTests.TestWriteReadFont_CourierNew; +begin + TestWriteReadFont('CourierNew'); +end; + +initialization + RegisterTest(TSpreadWriteReadFontTests); + +end. + diff --git a/components/fpspreadsheet/tests/formattests.pas b/components/fpspreadsheet/tests/formattests.pas index 3734be6ca..669523ccf 100644 --- a/components/fpspreadsheet/tests/formattests.pas +++ b/components/fpspreadsheet/tests/formattests.pas @@ -53,8 +53,6 @@ type procedure TestWriteReadWordWrap; // Test alignments procedure TestWriteReadAlignments; - // Test background colors - procedure TestWriteReadBackgroundColors; end; implementation @@ -398,63 +396,6 @@ 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); InitSollFmtData; diff --git a/components/fpspreadsheet/tests/manualtests.pas b/components/fpspreadsheet/tests/manualtests.pas index 5cb90b0a1..41c54abac 100644 --- a/components/fpspreadsheet/tests/manualtests.pas +++ b/components/fpspreadsheet/tests/manualtests.pas @@ -27,8 +27,8 @@ uses var // Norm to test against - list of dates/times that should occur in spreadsheet - SollColors: array[0..22] of tsColor; //"Soll" is a German word in Dutch accountancy jargon meaning "normative value to check against". There ;) - SollColorNames: array[0..22] of string; //matching names for SollColors + SollColors: array[0..16] of tsColor; //"Soll" is a German word in Dutch accountancy jargon meaning "normative value to check against". There ;) + SollColorNames: array[0..16] of string; //matching names for SollColors // Initializes Soll*/normative variables. // Useful in test setup procedures to make sure the norm is correct. procedure InitSollColors; @@ -101,6 +101,8 @@ begin SollColors[13]:=scTEAL; SollColors[14]:=scSilver; SollColors[15]:=scGrey; + SollColors[16]:=scOrange; + { SollColors[16]:=scGrey10pct; SollColors[17]:=scGrey20pct; SollColors[18]:=scOrange; @@ -108,7 +110,7 @@ begin SollColors[20]:=scBrown; SollColors[21]:=scBeige; SollColors[22]:=scWheat; - + } // Corresponding names for display in cells: SollColorNames[0]:='scBlack'; SollColorNames[1]:='scWhite'; @@ -126,6 +128,8 @@ begin SollColorNames[13]:='scTEAL'; SollColorNames[14]:='scSilver'; SollColorNames[15]:='scGrey'; + SollColorNames[16]:='scOrange'; + { SollColorNames[16]:='scGrey10pct'; SollColorNames[17]:='scGrey20pct'; SollColorNames[18]:='scOrange'; @@ -133,6 +137,7 @@ begin SollColorNames[20]:='scBrown'; SollColorNames[21]:='scBeige'; SollColorNames[22]:='scWheat'; + } end; { TSpreadManualSetup } diff --git a/components/fpspreadsheet/tests/numberstests.pas b/components/fpspreadsheet/tests/numberstests.pas index 68e74a949..9b1af8f25 100644 --- a/components/fpspreadsheet/tests/numberstests.pas +++ b/components/fpspreadsheet/tests/numberstests.pas @@ -217,7 +217,7 @@ begin fail('Error in test code. Failed to get named worksheet'); ActualNumber:=MyWorkSheet.ReadAsNumber(Row, 0); - CheckEquals(SollNumbers[Row],ActualNumber,'Test value mismatch ' + CheckEquals(abs(SollNumbers[Row]-ActualNumber) < 1E-4, true,'Test value mismatch ' +'cell '+CellNotation(MyWorkSheet,Row)); // Finalization diff --git a/components/fpspreadsheet/tests/spreadtestgui.lpi b/components/fpspreadsheet/tests/spreadtestgui.lpi index 84b9f1466..492991859 100644 --- a/components/fpspreadsheet/tests/spreadtestgui.lpi +++ b/components/fpspreadsheet/tests/spreadtestgui.lpi @@ -79,7 +79,7 @@ - + @@ -120,6 +120,16 @@ + + + + + + + + + + @@ -142,7 +152,7 @@ - + @@ -161,6 +171,10 @@ + + + + diff --git a/components/fpspreadsheet/tests/spreadtestgui.lpr b/components/fpspreadsheet/tests/spreadtestgui.lpr index acf3b5dba..d3a39ee6c 100644 --- a/components/fpspreadsheet/tests/spreadtestgui.lpr +++ b/components/fpspreadsheet/tests/spreadtestgui.lpr @@ -3,9 +3,8 @@ program spreadtestgui; {$mode objfpc}{$H+} uses - Interfaces, Forms, GuiTestRunner, - datetests, stringtests, - numberstests, manualtests, testsutility, internaltests, formattests; + Interfaces, Forms, GuiTestRunner, datetests, stringtests, numberstests, + manualtests, testsutility, internaltests, formattests, colortests, fonttests; begin Application.Initialize; diff --git a/components/fpspreadsheet/wikitable.pas b/components/fpspreadsheet/wikitable.pas index 4392cc9ec..2523d96e2 100644 --- a/components/fpspreadsheet/wikitable.pas +++ b/components/fpspreadsheet/wikitable.pas @@ -70,7 +70,7 @@ type TsWikiTable_PipesReader = class(TsWikiTableReader) public - constructor Create; override; + constructor Create(AWorkbook: TsWorkbook); override; end; { TsWikiTableWriter } @@ -81,15 +81,15 @@ type public SubFormat: TsSpreadsheetFormat; { General writing methods } - procedure WriteToStrings(AStrings: TStrings; AData: TsWorkbook); override; - procedure WriteToStrings_WikiMedia(AStrings: TStrings; AData: TsWorkbook); + procedure WriteToStrings(AStrings: TStrings); override; + procedure WriteToStrings_WikiMedia(AStrings: TStrings); end; { TsWikiTable_WikiMediaWriter } TsWikiTable_WikiMediaWriter = class(TsWikiTableWriter) public - constructor Create; override; + constructor Create(AWorkbook: TsWorkbook); override; end; implementation @@ -318,18 +318,18 @@ end; { TsWikiTable_PipesReader } -constructor TsWikiTable_PipesReader.Create; +constructor TsWikiTable_PipesReader.Create(AWorkbook: TsWorkbook); begin - inherited Create; + inherited Create(AWorkbook); SubFormat := sfWikiTable_Pipes; end; { TsWikiTableWriter } -procedure TsWikiTableWriter.WriteToStrings(AStrings: TStrings; AData: TsWorkbook); +procedure TsWikiTableWriter.WriteToStrings(AStrings: TStrings); begin case SubFormat of - sfWikiTable_WikiMedia: WriteToStrings_WikiMedia(AStrings, AData); + sfWikiTable_WikiMedia: WriteToStrings_WikiMedia(AStrings); end; end; @@ -345,8 +345,7 @@ Format mediawiki: ! style="background-color:green;color:white;" | PASS |} *) -procedure TsWikiTableWriter.WriteToStrings_WikiMedia(AStrings: TStrings; - AData: TsWorkbook); +procedure TsWikiTableWriter.WriteToStrings_WikiMedia(AStrings: TStrings); var i, j: Integer; lCurStr: string = ''; @@ -356,7 +355,7 @@ var lColorStr: String; begin AStrings.Add('{| border="1" cellpadding="2" class="wikitable sortable"'); - FWorksheet := AData.GetFirstWorksheet(); + FWorksheet := Workbook.GetFirstWorksheet(); for i := 0 to FWorksheet.GetLastRowNumber() do begin AStrings.Add('|-'); @@ -404,9 +403,9 @@ end; { TsWikiTable_WikiMediaWriter } -constructor TsWikiTable_WikiMediaWriter.Create; +constructor TsWikiTable_WikiMediaWriter.Create(AWorkbook: TsWorkbook); begin - inherited Create; + inherited Create(AWorkbook); SubFormat := sfWikiTable_WikiMedia; end; diff --git a/components/fpspreadsheet/xlsbiff2.pas b/components/fpspreadsheet/xlsbiff2.pas index 0a9d85e44..c817d79fb 100755 --- a/components/fpspreadsheet/xlsbiff2.pas +++ b/components/fpspreadsheet/xlsbiff2.pas @@ -45,6 +45,8 @@ type WorkBookEncoding: TsEncoding; RecordSize: Word; FWorksheet: TsWorksheet; + FXFList: TFPList; + FFont: TsFont; procedure ReadRowInfo(AStream: TStream); protected procedure ApplyCellFormatting(ARow, ACol: Word; XF, AFormat, AFont, AStyle: Byte); @@ -53,12 +55,16 @@ type { Record writing methods } procedure ReadBlank(AStream: TStream); override; procedure ReadFont(AStream: TStream); + procedure ReadFontColor(AStream: TStream); procedure ReadFormula(AStream: TStream); override; procedure ReadLabel(AStream: TStream); override; procedure ReadNumber(AStream: TStream); override; procedure ReadInteger(AStream: TStream); + procedure ReadXF(AStream: TStream); public { General reading methods } + constructor Create(AWorkbook: TsWorkbook); override; + destructor Destroy; override; procedure ReadFromStream(AStream: TStream; AData: TsWorkbook); override; end; @@ -71,14 +77,14 @@ type procedure WriteBOF(AStream: TStream); procedure WriteCellFormatting(AStream: TStream; ACell: PCell; XFIndex: Word); procedure WriteEOF(AStream: TStream); - procedure WriteFont(AStream: TStream; AData: TsWorkbook; AFontIndex: Integer); - procedure WriteFonts(AStream: TStream; AData: TsWorkbook); + procedure WriteFont(AStream: TStream; AFontIndex: Integer); + procedure WriteFonts(AStream: TStream); procedure WriteIXFE(AStream: TStream; XFIndex: Word); procedure WriteXF(AStream: TStream; AFontIndex, AFormatIndex: byte; ABorders: TsCellBorders = []; AHorAlign: TsHorAlignment = haLeft; AddBackground: Boolean = false); procedure WriteXFFieldsForFormattingStyles(AStream: TStream); - procedure WriteXFRecords(AStream: TStream; AData: TsWorkbook); + procedure WriteXFRecords(AStream: TStream); protected procedure AddDefaultFormats(); override; procedure WriteBlank(AStream: TStream; const ARow, ACol: Cardinal; ACell: PCell); override; @@ -88,9 +94,21 @@ type procedure WriteDateTime(AStream: TStream; const ARow, ACol: Cardinal; const AValue: TDateTime; ACell: PCell); override; public { General writing methods } - procedure WriteToStream(AStream: TStream; AData: TsWorkbook); override; + procedure WriteToStream(AStream: TStream); override; end; +const + PALETTE_BIFF2: array[$0..$07] of DWord = ( + $000000, // $00: black + $FFFFFF, // $01: white + $FF0000, // $02: red + $00FF00, // $03: green + $0000FF, // $04: blue + $FFFF00, // $05: yellow + $FF00FF, // $06: magenta + $00FFFF // $07: cyan + ); + implementation const @@ -117,6 +135,11 @@ const INT_EXCEL_CHART = $0020; INT_EXCEL_MACRO_SHEET = $0040; +type + TXFData = class + FontIndex: Integer; + end; + { TsSpreadBIFF2Writer } procedure TsSpreadBIFF2Writer.AddDefaultFormats(); @@ -219,15 +242,13 @@ end; Excel 2.x files support only one Worksheet per Workbook, so only the first will be written. } -procedure TsSpreadBIFF2Writer.WriteToStream(AStream: TStream; AData: TsWorkbook); +procedure TsSpreadBIFF2Writer.WriteToStream(AStream: TStream); begin WriteBOF(AStream); - WriteFonts(AStream, AData); - - WriteXFRecords(AStream, AData); - - WriteCellsToStream(AStream, AData.GetFirstWorksheet.Cells); + WriteFonts(AStream); + WriteXFRecords(AStream); + WriteCellsToStream(AStream, Workbook.GetFirstWorksheet.Cells); WriteEOF(AStream); end; @@ -358,7 +379,7 @@ begin end; end; -procedure TsSpreadBIFF2Writer.WriteXFRecords(AStream: TStream; AData: TsWorkbook); +procedure TsSpreadBIFF2Writer.WriteXFRecords(AStream: TStream); begin WriteXF(AStream, 0, 0); // XF0 WriteXF(AStream, 0, 0); // XF1 @@ -378,7 +399,7 @@ begin WriteXF(AStream, 0, 0); // XF15 - Default, no formatting // Add all further non-standard/built-in formatting styles - ListAllFormattingStyles(AData); + ListAllFormattingStyles; WriteXFFieldsForFormattingStyles(AStream); end; @@ -416,15 +437,14 @@ end; Writes an Excel 2 font record The font data is passed as font index. } -procedure TsSpreadBIFF2Writer.WriteFont(AStream: TStream; AData: TsWorkbook; - AFontIndex: Integer); +procedure TsSpreadBIFF2Writer.WriteFont(AStream: TStream; AFontIndex: Integer); var Len: Byte; lFontName: AnsiString; optn: Word; font: TsFont; begin - font := AData.GetFont(AFontIndex); + font := Workbook.GetFont(AFontIndex); if font = nil then // this happens for FONT4 in case of BIFF exit; @@ -465,12 +485,12 @@ begin AStream.WriteWord(WordToLE(word(font.Color))); end; -procedure TsSpreadBiff2Writer.WriteFonts(AStream: TStream; AData: TsWorkbook); +procedure TsSpreadBiff2Writer.WriteFonts(AStream: TStream); var i: Integer; begin - for i:=0 to AData.GetFontCount-1 do - WriteFont(AStream, AData, i); + for i:=0 to Workbook.GetFontCount-1 do + WriteFont(AStream, i); end; { @@ -773,17 +793,35 @@ end; { TsSpreadBIFF2Reader } +constructor TsSpreadBIFF2Reader.Create(AWorkbook: TsWorkbook); +begin + inherited Create(AWorkbook); + FXFList := TFPList.Create; +end; + +destructor TsSpreadBIFF2Reader.Destroy; +var + j: integer; +begin + for j := FXFList.Count-1 downto 0 do TObject(FXFList[j]).Free; + FXFList.Free; + inherited; +end; + procedure TsSpreadBIFF2Reader.ApplyCellFormatting(ARow, ACol: Word; XF, AFormat, AFont, AStyle: Byte); var lCell: PCell; + xfData: TXFData; begin lCell := FWorksheet.GetCell(ARow, ACol); if Assigned(lCell) then begin + xfData := TXFData(FXFList.items[xf]); + // Font index Include(lCell^.UsedFormattingFields, uffFont); - lCell^.FontIndex := AFont; + lCell^.FontIndex := xfData.FontIndex; //AFont; // Horizontal justification if AStyle and $07 <> 0 then begin @@ -825,30 +863,34 @@ var lOptions: Word; Len: Byte; lFontName: UTF8String; - font: TsFont; begin - font := TsFont.Create; + FFont := TsFont.Create; { Height of the font in twips = 1/20 of a point } lHeight := WordLEToN(AStream.ReadWord); // WordToLE(200) - font.Size := lHeight/20; + FFont.Size := lHeight/20; { Option flags } lOptions := WordLEToN(AStream.ReadWord); - font.Style := []; - if lOptions and $0001 <> 0 then Include(font.Style, fssBold); - if lOptions and $0002 <> 0 then Include(font.Style, fssItalic); - if lOptions and $0004 <> 0 then Include(font.Style, fssUnderline); - if lOptions and $0008 <> 0 then Include(font.Style, fssStrikeout); + FFont.Style := []; + if lOptions and $0001 <> 0 then Include(FFont.Style, fssBold); + if lOptions and $0002 <> 0 then Include(FFont.Style, fssItalic); + if lOptions and $0004 <> 0 then Include(FFont.Style, fssUnderline); + if lOptions and $0008 <> 0 then Include(FFont.Style, fssStrikeout); { Font name: Unicodestring, char count in 1 byte } Len := AStream.ReadByte(); SetLength(lFontName, Len); AStream.ReadBuffer(lFontName[1], Len); - font.FontName := lFontName; + FFont.FontName := lFontName; { Add font to workbook's font list } - FWorkbook.AddFont(font); + FWorkbook.AddFont(FFont); +end; + +procedure TsSpreadBIFF2Reader.ReadFontColor(AStream: TStream); +begin + FFont.Color := WordLEToN(AStream.ReadWord); end; procedure TsSpreadBIFF2Reader.ReadFromStream(AStream: TStream; AData: TsWorkbook); @@ -879,15 +921,17 @@ begin case RecordType of - INT_EXCEL_ID_BLANK: ReadBlank(AStream); - INT_EXCEL_ID_FONT: ReadFont(AStream); - INT_EXCEL_ID_INTEGER: ReadInteger(AStream); - INT_EXCEL_ID_NUMBER: ReadNumber(AStream); - INT_EXCEL_ID_LABEL: ReadLabel(AStream); - INT_EXCEL_ID_FORMULA: ReadFormula(AStream); - INT_EXCEL_ID_ROWINFO: ReadRowInfo(AStream); - INT_EXCEL_ID_BOF: ; - INT_EXCEL_ID_EOF: BIFF2EOF := True; + INT_EXCEL_ID_BLANK : ReadBlank(AStream); + INT_EXCEL_ID_FONT : ReadFont(AStream); + INT_EXCEL_ID_FONTCOLOR : ReadFontColor(AStream); + INT_EXCEL_ID_INTEGER : ReadInteger(AStream); + INT_EXCEL_ID_NUMBER : ReadNumber(AStream); + INT_EXCEL_ID_LABEL : ReadLabel(AStream); + INT_EXCEL_ID_FORMULA : ReadFormula(AStream); + INT_EXCEL_ID_ROWINFO : ReadRowInfo(AStream); + INT_EXCEL_ID_XF : ReadXF(AStream); + INT_EXCEL_ID_BOF : ; + INT_EXCEL_ID_EOF : BIFF2EOF := True; else // nothing @@ -1020,6 +1064,30 @@ begin end; end; +procedure TsSpreadBIFF2Reader.ReadXF(AStream: TStream); +type + TXFRecord = packed record // see p. 224 + FontIndex: byte; // Offset 0, Size 1 + NotUsed: byte; // Offset 1, Size 1 + NumFormat_Flags: byte; // Offset 2, Size 1 + HorAlign_Border_BackGround: Byte; // Offset 3, Size 1 + end; +var + xfData: TXFData; + xf: TXFRecord; + b: Byte; +begin + AStream.ReadBuffer(xf, SizeOf(xf)); + + xfData := TXFData.Create; + + // Font index + xfData.FontIndex := xf.FontIndex; + + // Add the XF to the list + FXFList.Add(xfData); +end; + {******************************************************************* * Initialization section * diff --git a/components/fpspreadsheet/xlsbiff5.pas b/components/fpspreadsheet/xlsbiff5.pas index 2034fe91b..6169f2e8e 100755 --- a/components/fpspreadsheet/xlsbiff5.pas +++ b/components/fpspreadsheet/xlsbiff5.pas @@ -134,11 +134,85 @@ type procedure WriteXF(AStream: TStream; AFontIndex: Word; AXF_TYPE_PROT: Byte); public { General writing methods } - procedure WriteToFile(const AFileName: string; AData: TsWorkbook; + procedure WriteToFile(const AFileName: string; const AOverwriteExisting: Boolean = False); override; - procedure WriteToStream(AStream: TStream; AData: TsWorkbook); override; + procedure WriteToStream(AStream: TStream); override; end; +const + PALETTE_BIFF5: array[$00..$3F] of DWord = ( + $000000, // $00: black + $FFFFFF, // $01: white + $FF0000, // $02: red + $00FF00, // $03: green + $0000FF, // $04: blue + $FFFF00, // $05: yellow + $FF00FF, // $06: magenta + $00FFFF, // $07: cyan + + $000000, // $08: EGA black + $FFFFFF, // $09: EGA white + $FF0000, // $0A: EGA red + $00FF00, // $0B: EGA green + $0000FF, // $0C: EGA blue + $FFFF00, // $0D: EGA yellow + $FF00FF, // $0E: EGA magenta + $00FFFF, // $0F: EGA cyan + + $800000, // $10: EGA dark red + $008000, // $11: EGA dark green + $000080, // $12: EGA dark blue + $808000, // $13: EGA olive + $800080, // $14: EGA purple + $008080, // $15: EGA teal + $C0C0C0, // $16: EGA silver + $808080, // $17: EGA gray + + $8080FF, // $18: + $802060, // $19: + $FFFFC0, // $1A: + $A0E0F0, // $1B: + $600080, // $1C: + $FF8080, // $1D: + $0080C0, // $1E: + $C0C0FF, // $1F: + + $000080, // $20: + $FF00FF, // $21: + $FFFF00, // $22: + $00FFFF, // $23: + $800080, // $24: + $800000, // $25: + $008080, // $26: + $0000FF, // $27: + $00CFFF, // $28: + $69FFFF, // $29: + $E0FFE0, // $2A: + $FFFF80, // $2B: + $A6CAF0, // $2C: + $DD9CB3, // $2D: + $B38FEE, // $2E: + $E3E3E3, // $2F: + + $2A6FF9, // $30: + $3FB8CD, // $31: + $488436, // $32: + $958C41, // $33: + $8E5E42, // $34: + $A0627A, // $35: + $624FAC, // $36: + $969696, // $37: + $1D2FBE, // $38: + $286676, // $39: + $004500, // $3A: + $453E01, // $3B: + $6A2813, // $3C: + $85396A, // $3D: + $4A3285, // $3E: + $424242 // $3F: + ); + + implementation const @@ -285,7 +359,7 @@ const * *******************************************************************} procedure TsSpreadBIFF5Writer.WriteToFile(const AFileName: string; - AData: TsWorkbook; const AOverwriteExisting: Boolean); + const AOverwriteExisting: Boolean); var MemStream: TMemoryStream; OutputStorage: TOLEStorage; @@ -294,7 +368,7 @@ begin MemStream := TMemoryStream.Create; OutputStorage := TOLEStorage.Create; try - WriteToStream(MemStream, AData); + WriteToStream(MemStream); // Only one stream is necessary for any number of worksheets OLEDocument.Stream := MemStream; @@ -315,7 +389,7 @@ end; * part of the document, just the BIFF records * *******************************************************************} -procedure TsSpreadBIFF5Writer.WriteToStream(AStream: TStream; AData: TsWorkbook); +procedure TsSpreadBIFF5Writer.WriteToStream(AStream: TStream); var FontData: TFPCustomFont; MyData: TMemoryStream; @@ -324,14 +398,12 @@ var i, len: Integer; begin { Store some data about the workbook that other routines need } - WorkBookEncoding := AData.Encoding; + WorkBookEncoding := Workbook.Encoding; { Write workbook globals } WriteBOF(AStream, INT_BOF_WORKBOOK_GLOBALS); - WriteCodepage(AStream, WorkBookEncoding); - WriteWindow1(AStream); FontData := TFPCustomFont.Create; @@ -388,18 +460,18 @@ begin WriteStyle(AStream); // A BOUNDSHEET for each worksheet - for i := 0 to AData.GetWorksheetCount - 1 do + for i := 0 to Workbook.GetWorksheetCount - 1 do begin len := Length(Boundsheets); SetLength(Boundsheets, len + 1); - Boundsheets[len] := WriteBoundsheet(AStream, AData.GetWorksheetByIndex(i).Name); + Boundsheets[len] := WriteBoundsheet(AStream, Workbook.GetWorksheetByIndex(i).Name); end; WriteEOF(AStream); { Write each worksheet } - for i := 0 to AData.GetWorksheetCount - 1 do + for i := 0 to Workbook.GetWorksheetCount - 1 do begin { First goes back and writes the position of the BOF of the sheet on the respective BOUNDSHEET record } @@ -411,12 +483,10 @@ begin WriteBOF(AStream, INT_BOF_SHEET); WriteIndex(AStream); - - WriteDimensions(AStream, AData.GetWorksheetByIndex(i)); - + WriteDimensions(AStream, Workbook.GetWorksheetByIndex(i)); WriteWindow2(AStream, True); - WriteCellsToStream(AStream, AData.GetWorksheetByIndex(i).Cells); + WriteCellsToStream(AStream, Workbook.GetWorksheetByIndex(i).Cells); WriteEOF(AStream); end; diff --git a/components/fpspreadsheet/xlsbiff8.pas b/components/fpspreadsheet/xlsbiff8.pas index 6741f03ca..be4cb5566 100755 --- a/components/fpspreadsheet/xlsbiff8.pas +++ b/components/fpspreadsheet/xlsbiff8.pas @@ -143,7 +143,7 @@ type procedure ReadLabel(AStream: TStream); override; procedure ReadNumber(AStream: TStream); override; public - constructor Create; override; + constructor Create(AWorkbook: TsWorkbook); override; destructor Destroy; override; { General reading methods } procedure ReadFromFile(AFileName: string; AData: TsWorkbook); override; @@ -154,8 +154,6 @@ type TsSpreadBIFF8Writer = class(TsSpreadBIFFWriter) private - // Convert our representation of RGB color to physical ARGB in Excel file - function LongRGBToExcelPhysical(const RGB: DWord): DWord; // Writes index to XF record according to cell's formatting procedure WriteXFIndex(AStream: TStream; ACell: PCell); procedure WriteXFFieldsForFormattingStyles(AStream: TStream); @@ -174,13 +172,12 @@ type procedure WriteDimensions(AStream: TStream; AWorksheet: TsWorksheet); procedure WriteEOF(AStream: TStream); procedure WriteFont(AStream: TStream; AFont: TsFont); - procedure WriteFonts(AStream: TStream; AData: TsWorkbook); + procedure WriteFonts(AStream: TStream); procedure WriteFormula(AStream: TStream; const ARow, ACol: Cardinal; const AFormula: TsFormula; ACell: PCell); override; procedure WriteIndex(AStream: TStream); procedure WriteLabel(AStream: TStream; const ARow, ACol: Cardinal; const AValue: string; ACell: PCell); override; - procedure WritePalette(AStream: TStream); procedure WriteNumber(AStream: TStream; const ARow, ACol: Cardinal; const AValue: double; ACell: PCell); override; procedure WriteRPNFormula(AStream: TStream; const ARow, ACol: Cardinal; @@ -193,16 +190,86 @@ type AHorAlignment: TsHorAlignment = haDefault; AVertAlignment: TsVertAlignment = vaDefault; AWordWrap: Boolean = false; AddBackground: Boolean = false; ABackgroundColor: TsColor = scSilver); - procedure WriteXFRecords(AStream: TStream; AData: TsWorkbook); + procedure WriteXFRecords(AStream: TStream); public -// constructor Create; -// destructor Destroy; override; { General writing methods } - procedure WriteToFile(const AFileName: string; AData: TsWorkbook; + procedure WriteToFile(const AFileName: string; const AOverwriteExisting: Boolean = False); override; - procedure WriteToStream(AStream: TStream; AData: TsWorkbook); override; + procedure WriteToStream(AStream: TStream); override; end; +const + PALETTE_BIFF8: array[$00..$3F] of DWord = ( + $000000, // $00: black // 8 built-in default colors + $FFFFFF, // $01: white + $FF0000, // $02: red + $00FF00, // $03: green + $0000FF, // $04: blue + $FFFF00, // $05: yellow + $FF00FF, // $06: magenta + $00FFFF, // $07: cyan + + $000000, // $08: EGA black + $FFFFFF, // $09: EGA white + $FF0000, // $0A: EGA red + $00FF00, // $0B: EGA green + $0000FF, // $0C: EGA blue + $FFFF00, // $0D: EGA yellow + $FF00FF, // $0E: EGA magenta + $00FFFF, // $0F: EGA cyan + + $800000, // $10: EGA dark red + $008000, // $11: EGA dark green + $000080, // $12: EGA dark blue + $808000, // $13: EGA olive + $800080, // $14: EGA purple + $008080, // $15: EGA teal + $C0C0C0, // $16: EGA silver + $808080, // $17: EGA gray + $9999FF, // $18: + $993366, // $19: + $FFFFCC, // $1A: + $CCFFFF, // $1B: + $660066, // $1C: + $FF8080, // $1D: + $0066CC, // $1E: + $CCCCFF, // $1F: + + $000080, // $20: + $FF00FF, // $21: + $FFFF00, // $22: + $00FFFF, // $23: + $800080, // $24: + $800000, // $25: + $008080, // $26: + $0000FF, // $27: + $00CCFF, // $28: + $CCFFFF, // $29: + $CCFFCC, // $2A: + $FFFF99, // $2B: + $99CCFF, // $2C: + $FF99CC, // $2D: + $CC99FF, // $2E: + $FFCC99, // $2F: + + $3366FF, // $30: + $33CCCC, // $31: + $99CC00, // $32: + $FFCC00, // $33: + $FF9900, // $34: + $FF6600, // $35: + $666699, // $36: + $969696, // $37: + $003366, // $38: + $339966, // $39: + $003300, // $3A: + $333300, // $3B: + $993300, // $3C: + $993366, // $3D: + $333399, // $3E: + $333333 // $3F: + ); + implementation const @@ -229,8 +296,6 @@ const INT_EXCEL_ID_SST = $00FC; //BIFF8 only INT_EXCEL_ID_CONTINUE = $003C; INT_EXCEL_ID_LABELSST = $00FD; //BIFF8 only - INT_EXCEL_ID_PALETTE = $0092; - INT_EXCEL_ID_CODEPAGE = $0042; INT_EXCEL_ID_FORMAT = $041E; INT_EXCEL_ID_FORCEFULLCALCULATION = $08A3; @@ -345,24 +410,6 @@ const { TsSpreadBIFF8Writer } -function TsSpreadBIFF8Writer.LongRGBToExcelPhysical(const RGB: DWord): DWord; -// Converts RGB part of a LongRGB logical structure -// to its physical representation -// IOW: RGBA (where A is 0 and omitted in the function call) => ABGR -begin - {$IFDEF FPC} - {$IFDEF ENDIAN_LITTLE} - result:=(RGB shl 8); //tags $00 at end for the A byte - result:=SwapEndian(result); //flip byte order - {$ELSE} - //Big endian - result:=RGB; //leave value as is //todo: verify if this turns out ok - {$ENDIF} - {$ELSE} - // messed up result - {$ENDIF} -end; - { Index to XF record, according to formatting } procedure TsSpreadBIFF8Writer.WriteXFIndex(AStream: TStream; ACell: PCell); var @@ -558,7 +605,7 @@ end; * *******************************************************************} procedure TsSpreadBIFF8Writer.WriteToFile(const AFileName: string; - AData: TsWorkbook; const AOverwriteExisting: Boolean); + const AOverwriteExisting: Boolean); var MemStream: TMemoryStream; OutputStorage: TOLEStorage; @@ -567,7 +614,7 @@ begin MemStream := TMemoryStream.Create; OutputStorage := TOLEStorage.Create; try - WriteToStream(MemStream, AData); + WriteToStream(MemStream); // Only one stream is necessary for any number of worksheets OLEDocument.Stream := MemStream; @@ -588,7 +635,7 @@ end; * part of the document, just the BIFF records * *******************************************************************} -procedure TsSpreadBIFF8Writer.WriteToStream(AStream: TStream; AData: TsWorkbook); +procedure TsSpreadBIFF8Writer.WriteToStream(AStream: TStream); var MyData: TMemoryStream; CurrentPos: Int64; @@ -602,31 +649,26 @@ begin WriteBOF(AStream, INT_BOF_WORKBOOK_GLOBALS); WriteWindow1(AStream); - - WriteFonts(AStream, AData); - - // PALETTE + WriteFonts(AStream); WritePalette(AStream); - - // XF Records - WriteXFRecords(AStream, AData); + WriteXFRecords(AStream); WriteStyle(AStream); // A BOUNDSHEET for each worksheet - for i := 0 to AData.GetWorksheetCount - 1 do + for i := 0 to Workbook.GetWorksheetCount - 1 do begin len := Length(Boundsheets); SetLength(Boundsheets, len + 1); - Boundsheets[len] := WriteBoundsheet(AStream, AData.GetWorksheetByIndex(i).Name); + Boundsheets[len] := WriteBoundsheet(AStream, Workbook.GetWorksheetByIndex(i).Name); end; WriteEOF(AStream); { Write each worksheet } - for i := 0 to AData.GetWorksheetCount - 1 do + for i := 0 to Workbook.GetWorksheetCount - 1 do begin - sheet := AData.GetWorksheetByIndex(i); + sheet := Workbook.GetWorksheetByIndex(i); { First goes back and writes the position of the BOF of the sheet on the respective BOUNDSHEET record } @@ -938,12 +980,12 @@ end; * used fonts in the workbook. * *******************************************************************} -procedure TsSpreadBiff8Writer.WriteFonts(AStream: TStream; AData: TsWorkbook); +procedure TsSpreadBiff8Writer.WriteFonts(AStream: TStream); var i: Integer; begin - for i:=0 to AData.GetFontCount-1 do - WriteFont(AStream, AData.GetFont(i)); + for i:=0 to Workbook.GetFontCount-1 do + WriteFont(AStream, Workbook.GetFont(i)); end; {******************************************************************* @@ -1321,90 +1363,6 @@ begin AStream.WriteBuffer(AValue, 8); end; - -(******************************************************************* -* TsSpreadBIFF8Writer.WritePalette -* -* DESCRIPTION: Writes Excel PALETTE records -* -*******************************************************************) - -procedure TsSpreadBIFF8Writer.WritePalette(AStream: TStream); -begin - { BIFF Record header } - AStream.WriteWord(WordToLE(INT_EXCEL_ID_PALETTE)); - AStream.WriteWord(WordToLE(2+4*56)); - - { Number of colors } - AStream.WriteWord(WordToLE(56)); - - { Now the colors, first the standard 16 from Excel } - AStream.WriteDWord(LongRGBToExcelPhysical($000000)); // $08 - AStream.WriteDWord(LongRGBToExcelPhysical($FFFFFF)); - AStream.WriteDWord(LongRGBToExcelPhysical($FF0000)); - AStream.WriteDWord(LongRGBToExcelPhysical($00FF00)); - AStream.WriteDWord(LongRGBToExcelPhysical($0000FF)); - AStream.WriteDWord(LongRGBToExcelPhysical($FFFF00)); - AStream.WriteDWord(LongRGBToExcelPhysical($FF00FF)); - AStream.WriteDWord(LongRGBToExcelPhysical($00FFFF)); - AStream.WriteDWord(LongRGBToExcelPhysical($800000)); - AStream.WriteDWord(LongRGBToExcelPhysical($008000)); - AStream.WriteDWord(LongRGBToExcelPhysical($000080)); - AStream.WriteDWord(LongRGBToExcelPhysical($808000)); - AStream.WriteDWord(LongRGBToExcelPhysical($800080)); - AStream.WriteDWord(LongRGBToExcelPhysical($008080)); - AStream.WriteDWord(LongRGBToExcelPhysical($C0C0C0)); - AStream.WriteDWord(LongRGBToExcelPhysical($808080)); //$17 - - { Now some colors which we define ourselves } - AStream.WriteDWord(LongRGBToExcelPhysical($E6E6E6)); //$18 //todo: shouldn't we write $18..$3F and add this color later? see 5.74.3 Built-In Default Colour Tables - AStream.WriteDWord(LongRGBToExcelPhysical($CCCCCC)); //$19 //todo: shouldn't we write $18..$3F and add this color later? see 5.74.3 Built-In Default Colour Tables - - { And padding } - AStream.WriteDWord(LongRGBToExcelPhysical($FFFFFF)); - AStream.WriteDWord(LongRGBToExcelPhysical($FFFFFF)); - AStream.WriteDWord(LongRGBToExcelPhysical($FFFFFF)); - AStream.WriteDWord(LongRGBToExcelPhysical($FFFFFF)); - AStream.WriteDWord(LongRGBToExcelPhysical($FFFFFF)); - AStream.WriteDWord(LongRGBToExcelPhysical($FFFFFF)); - - AStream.WriteDWord(LongRGBToExcelPhysical($FFFFFF)); //$20 //todo: is this still correct? - AStream.WriteDWord(LongRGBToExcelPhysical($FFFFFF)); - AStream.WriteDWord(LongRGBToExcelPhysical($FFFFFF)); - AStream.WriteDWord(LongRGBToExcelPhysical($FFFFFF)); - AStream.WriteDWord(LongRGBToExcelPhysical($FFFFFF)); - AStream.WriteDWord(LongRGBToExcelPhysical($FFFFFF)); - AStream.WriteDWord(LongRGBToExcelPhysical($FFFFFF)); - AStream.WriteDWord(LongRGBToExcelPhysical($FFFFFF)); - - AStream.WriteDWord(LongRGBToExcelPhysical($FFFFFF)); - AStream.WriteDWord(LongRGBToExcelPhysical($FFFFFF)); - AStream.WriteDWord(LongRGBToExcelPhysical($FFFFFF)); - AStream.WriteDWord(LongRGBToExcelPhysical($FFFFFF)); - AStream.WriteDWord(LongRGBToExcelPhysical($FFFFFF)); - AStream.WriteDWord(LongRGBToExcelPhysical($FFFFFF)); - AStream.WriteDWord(LongRGBToExcelPhysical($FFFFFF)); - AStream.WriteDWord(LongRGBToExcelPhysical($FFFFFF)); - - AStream.WriteDWord(LongRGBToExcelPhysical($FFFFFF)); //$30 - AStream.WriteDWord(LongRGBToExcelPhysical($FFFFFF)); - AStream.WriteDWord(LongRGBToExcelPhysical($FFFFFF)); - AStream.WriteDWord(LongRGBToExcelPhysical($FFFFFF)); - AStream.WriteDWord(LongRGBToExcelPhysical($FFFFFF)); - AStream.WriteDWord(LongRGBToExcelPhysical($FFFFFF)); - AStream.WriteDWord(LongRGBToExcelPhysical($FFFFFF)); - AStream.WriteDWord(LongRGBToExcelPhysical($FFFFFF)); - - AStream.WriteDWord(LongRGBToExcelPhysical($FFFFFF)); - AStream.WriteDWord(LongRGBToExcelPhysical($FFFFFF)); - AStream.WriteDWord(LongRGBToExcelPhysical($FFFFFF)); - AStream.WriteDWord(LongRGBToExcelPhysical($FFFFFF)); - AStream.WriteDWord(LongRGBToExcelPhysical($FFFFFF)); - AStream.WriteDWord(LongRGBToExcelPhysical($FFFFFF)); - AStream.WriteDWord(LongRGBToExcelPhysical($FFFFFF)); - AStream.WriteDWord(LongRGBToExcelPhysical($FFFFFF)); -end; - {******************************************************************* * TsSpreadBIFF8Writer.WriteStyle () * @@ -1627,12 +1585,12 @@ begin // Background Pattern Color, always zeroed if AddBackground then - AStream.WriteWord(WordToLE(FPSColorToEXCELPalette(ABackgroundColor))) + AStream.WriteWord(WordToLE(ABackgroundColor)) else AStream.WriteWord(0); end; -procedure TsSpreadBIFF8Writer.WriteXFRecords(AStream: TStream; AData: TsWorkbook); +procedure TsSpreadBIFF8Writer.WriteXFRecords(AStream: TStream); begin // XF0 WriteXF(AStream, 0, 0, MASK_XF_TYPE_PROT_STYLE_XF, XF_ROTATION_HORIZONTAL, []); @@ -1668,7 +1626,7 @@ begin WriteXF(AStream, 0, 0, 0, XF_ROTATION_HORIZONTAL, []); // Add all further non-standard/built-in formatting styles - ListAllFormattingStyles(AData); + ListAllFormattingStyles; WriteXFFieldsForFormattingStyles(AStream); end; @@ -1952,7 +1910,7 @@ begin CurStreamPos := AStream.Position; - if RecordType<>INT_EXCEL_ID_CONTINUE then begin + if RecordType <> INT_EXCEL_ID_CONTINUE then begin case RecordType of INT_EXCEL_ID_BOF: ; INT_EXCEL_ID_BOUNDSHEET: ReadBoundSheet(AStream); @@ -1963,6 +1921,7 @@ begin INT_EXCEL_ID_XF: ReadXF(AStream); INT_EXCEL_ID_FORMAT: ReadFormat(AStream); INT_EXCEL_ID_DATEMODE: ReadDateMode(AStream); + INT_EXCEL_ID_PALETTE: ReadPalette(AStream); else // nothing end; @@ -2140,8 +2099,10 @@ begin XFData := TXFRecordData(FXFList.Items[XFIndex]); // Font - Include(lCell^.UsedFormattingFields, uffFont); - lCell^.FontIndex := XFData.FontIndex; + if XFData.FontIndex > 0 then begin + Include(lCell^.UsedFormattingFields, uffFont); + lCell^.FontIndex := XFData.FontIndex; + end; // Alignment lCell^.HorAlignment := XFData.HorAlignment; @@ -2161,8 +2122,10 @@ begin Exclude(lCell^.UsedFormattingFields, uffBorder); // Background color - Include(lCell^.UsedFormattingFields, uffBackgroundColor); - lCell^.BackgroundColor := XFData.BackgroundColor; + if XFData.BackgroundColor <> 0 then begin + Include(lCell^.UsedFormattingFields, uffBackgroundColor); + lCell^.BackgroundColor := XFData.BackgroundColor; + end; end; end; @@ -2172,9 +2135,9 @@ begin Result:=UTF16ToUTF8(ReadWideString(AStream, ALength)); end; -constructor TsSpreadBIFF8Reader.Create; +constructor TsSpreadBIFF8Reader.Create(AWorkbook: TsWorkbook); begin - inherited Create; + inherited Create(AWorkbook); FXFList := TFPList.Create; FFormatList := TFPList.Create; end; @@ -2188,6 +2151,7 @@ begin FXFList.Free; FFormatList.Free; if Assigned(FSharedStringTable) then FSharedStringTable.Free; + inherited; end; procedure TsSpreadBIFF8Reader.ReadFromFile(AFileName: string; AData: TsWorkbook); @@ -2532,8 +2496,8 @@ begin Include(lData.Borders, cbSouth); // Background color; - xf.Border_Background_3 := WordLEToN(xf.Border_Background_3); - lData.BackgroundColor := ExcelPaletteToFPSColor(xf.Border_Background_3 AND $007F); + xf.Border_Background_3 := DWordLEToN(xf.Border_Background_3); + lData.BackgroundColor := xf.Border_Background_3 AND $007F; // Add the XF to the list FXFList.Add(lData); diff --git a/components/fpspreadsheet/xlscommon.pas b/components/fpspreadsheet/xlscommon.pas index 6b86022fc..a40f3ab56 100644 --- a/components/fpspreadsheet/xlscommon.pas +++ b/components/fpspreadsheet/xlscommon.pas @@ -19,6 +19,7 @@ const INT_EXCEL_ID_FONT = $0031; INT_EXCEL_ID_CODEPAGE = $0042; INT_EXCEL_ID_DATEMODE = $0022; + INT_EXCEL_ID_PALETTE = $0092; { Formula constants TokenID values } @@ -285,16 +286,18 @@ type FCodepage: string; // in a format prepared for lconvencoding.ConvertEncoding FDateMode: TDateMode; // converts an Excel color index to a color value. - function ExcelPaletteToFPSColor(AIndex: Word): TsColor; +// 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); // Figures out what the base year for dates is for this file procedure ReadDateMode(AStream: TStream); + // Read palette + procedure ReadPalette(AStream: TStream); // Read row info - procedure ReadRowInfo(const AStream: TStream); virtual; + procedure ReadRowInfo(AStream: TStream); virtual; public - constructor Create; override; + constructor Create(AWorkbook: TsWorkbook); override; end; { TsSpreadBIFFWriter } @@ -304,7 +307,7 @@ type FDateMode: TDateMode; FLastRow: Integer; FLastCol: Word; - function FPSColorToExcelPalette(AColor: TsColor): Word; +// function FPSColorToExcelPalette(AColor: TsColor): Word; procedure GetLastRowCallback(ACell: PCell; AStream: TStream); function GetLastRowIndex(AWorksheet: TsWorksheet): Integer; procedure GetLastColCallback(ACell: PCell; AStream: TStream); @@ -316,8 +319,10 @@ type procedure WriteCodepage(AStream: TStream; AEncoding: TsEncoding); // Writes out DATEMODE record depending on FDateMode procedure WriteDateMode(AStream: TStream); + // Writes out a PALETTE record containing all colors defined in the workbook + procedure WritePalette(AStream: TStream); public - constructor Create; override; + constructor Create(AWorkbook: TsWorkbook); override; end; function IsExpNumberFormat(s: String; out Decimals: Word): Boolean; @@ -383,13 +388,13 @@ end; { TsSpreadBIFFReader } -constructor TsSpreadBIFFReader.Create; +constructor TsSpreadBIFFReader.Create(AWorkbook: TsWorkbook); begin - inherited Create; + inherited Create(AWorkbook); // Initial base date in case it won't be read from file FDateMode := dm1900; end; - + (* function TsSpreadBIFFReader.ExcelPaletteToFPSColor(AIndex: Word): TsColor; begin case AIndex of @@ -414,7 +419,7 @@ begin 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 @@ -492,8 +497,23 @@ begin end; end; +// Read the palette +procedure TsSpreadBIFFReader.ReadPalette(AStream: TStream); +var + i, n: Word; + pal: Array of DWord; +begin + n := WordLEToN(AStream.ReadWord) + 8; + SetLength(pal, n); + for i:=0 to 7 do + pal[i] := Workbook.GetPaletteColor(i); + for i:=8 to n-1 do + pal[i] := DWordLEToN(AStream.ReadDWord); + Workbook.UsePalette(@pal[0], n, false); +end; + // Read the part of the ROW record that is common to all BIFF versions -procedure TsSpreadBIFFReader.ReadRowInfo(const AStream: TStream); +procedure TsSpreadBIFFReader.ReadRowInfo(AStream: TStream); type TRowRecord = packed record RowIndex: Word; @@ -515,53 +535,15 @@ begin end; end; -function TsSpreadBIFFWriter.FPSColorToExcelPalette(AColor: TsColor): Word; -begin - case AColor of - scBlack: Result := BUILT_IN_COLOR_PALLETE_BLACK; - scWhite: Result := BUILT_IN_COLOR_PALLETE_WHITE; - scRed: Result := BUILT_IN_COLOR_PALLETE_RED; - scGREEN: Result := BUILT_IN_COLOR_PALLETE_GREEN; - scBLUE: Result := BUILT_IN_COLOR_PALLETE_BLUE; - scYELLOW: Result := BUILT_IN_COLOR_PALLETE_YELLOW; - scMAGENTA: Result := BUILT_IN_COLOR_PALLETE_MAGENTA; - scCYAN: Result := BUILT_IN_COLOR_PALLETE_CYAN; - scDarkRed: Result := BUILT_IN_COLOR_PALLETE_DARK_RED; - scDarkGreen: Result := BUILT_IN_COLOR_PALLETE_DARK_GREEN; - scDarkBlue: Result := BUILT_IN_COLOR_PALLETE_DARK_BLUE; - scOLIVE: Result := BUILT_IN_COLOR_PALLETE_OLIVE; - scPURPLE: Result := BUILT_IN_COLOR_PALLETE_PURPLE; - scTEAL: Result := BUILT_IN_COLOR_PALLETE_TEAL; - scSilver: Result := BUILT_IN_COLOR_PALLETE_SILVER; - scGrey: Result := BUILT_IN_COLOR_PALLETE_GREY; - // - scGrey10pct: Result := EXTRA_COLOR_PALETTE_GREY10PCT; - scGrey20pct: Result := EXTRA_COLOR_PALETTE_GREY20PCT; - end; -end; -procedure TsSpreadBIFFWriter.GetLastRowCallback(ACell: PCell; AStream: TStream); -begin - if ACell^.Row > FLastRow then FLastRow := ACell^.Row; -end; +{ TsSpreadBIFFWriter } -function TsSpreadBIFFWriter.GetLastRowIndex(AWorksheet: TsWorksheet): Integer; +constructor TsSpreadBIFFWriter.Create(AWorkbook: TsWorkbook); begin - FLastRow := 0; - IterateThroughCells(nil, AWorksheet.Cells, GetLastRowCallback); - Result := FLastRow; -end; - -procedure TsSpreadBIFFWriter.GetLastColCallback(ACell: PCell; AStream: TStream); -begin - if ACell^.Col > FLastCol then FLastCol := ACell^.Col; -end; - -function TsSpreadBIFFWriter.GetLastColIndex(AWorksheet: TsWorksheet): Word; -begin - FLastCol := 0; - IterateThroughCells(nil, AWorksheet.Cells, GetLastColCallback); - Result := FLastCol; + inherited Create(AWorkbook); + // Initial base date in case it won't be set otherwise. + // Use 1900 to get a bit more range between 1900..1904. + FDateMode := dm1900; end; function TsSpreadBIFFWriter.FormulaElementKindToExcelTokenID( @@ -736,6 +718,30 @@ begin end; end; +procedure TsSpreadBIFFWriter.GetLastRowCallback(ACell: PCell; AStream: TStream); +begin + if ACell^.Row > FLastRow then FLastRow := ACell^.Row; +end; + +function TsSpreadBIFFWriter.GetLastRowIndex(AWorksheet: TsWorksheet): Integer; +begin + FLastRow := 0; + IterateThroughCells(nil, AWorksheet.Cells, GetLastRowCallback); + Result := FLastRow; +end; + +procedure TsSpreadBIFFWriter.GetLastColCallback(ACell: PCell; AStream: TStream); +begin + if ACell^.Col > FLastCol then FLastCol := ACell^.Col; +end; + +function TsSpreadBIFFWriter.GetLastColIndex(AWorksheet: TsWorksheet): Word; +begin + FLastCol := 0; + IterateThroughCells(nil, AWorksheet.Cells, GetLastColCallback); + Result := FLastCol; +end; + procedure TsSpreadBIFFWriter.WriteCodepage(AStream: TStream; AEncoding: TsEncoding); var @@ -774,12 +780,25 @@ begin end; end; -constructor TsSpreadBIFFWriter.Create; +procedure TsSpreadBIFFWriter.WritePalette(AStream: TStream); +var + i, n: Integer; begin - inherited Create; - // Initial base date in case it won't be set otherwise. - // Use 1900 to get a bit more range between 1900..1904. - FDateMode := dm1900; + { BIFF Record header } + AStream.WriteWord(WordToLE(INT_EXCEL_ID_PALETTE)); + AStream.WriteWord(WordToLE(2 + 4*56)); + + { Number of colors } + AStream.WriteWord(WordToLE(56)); + + { Take the colors from the palette of the Worksheet } + { Skip the first 8 entries - they are hard-coded into Excel } + n := Workbook.GetPaletteSize; + for i:=8 to 63 do + if i < n then + AStream.WriteDWord(DWordToLE(Workbook.GetPaletteColor(i))) + else + AStream.WriteDWord(DWordToLE($FFFFFF)); end; diff --git a/components/fpspreadsheet/xlsxooxml.pas b/components/fpspreadsheet/xlsxooxml.pas index ba38f1885..b339ef0ac 100755 --- a/components/fpspreadsheet/xlsxooxml.pas +++ b/components/fpspreadsheet/xlsxooxml.pas @@ -49,7 +49,7 @@ type { Strings with the contents of files } FContentTypes: string; FRelsRels: string; - FWorkbook, FWorkbookRels, FStyles, FSharedStrings: string; + FWorkbookString, FWorkbookRelsString, FStylesString, FSharedStrings: string; FSheets: array of string; FSharedStringsCount: Integer; { Streams with the contents of files } @@ -59,8 +59,8 @@ type FSSheets: array of TStringStream; FCurSheetNum: Integer; { Routines to write those files } - procedure WriteGlobalFiles(AData: TsWorkbook); - procedure WriteContent(AData: TsWorkbook); + procedure WriteGlobalFiles; + procedure WriteContent; procedure WriteWorksheet(CurSheet: TsWorksheet); function GetStyleIndex(ACell: PCell): Cardinal; { Record writing methods } @@ -69,13 +69,12 @@ type procedure WriteNumber(AStream: TStream; const ARow, ACol: Cardinal; const AValue: double; ACell: PCell); override; procedure WriteDateTime(AStream: TStream; const ARow, ACol: Cardinal; const AValue: TDateTime; ACell: PCell); override; public - constructor Create; override; + constructor Create(AWorkbook: TsWorkbook); override; destructor Destroy; override; { General writing methods } procedure WriteStringToFile(AFileName, AString: string); - procedure WriteToFile(const AFileName: string; AData: TsWorkbook; - const AOverwriteExisting: Boolean = False); override; - procedure WriteToStream(AStream: TStream; AData: TsWorkbook); override; + procedure WriteToFile(const AFileName: string; const AOverwriteExisting: Boolean = False); override; + procedure WriteToStream(AStream: TStream); override; end; implementation @@ -117,7 +116,7 @@ const { TsSpreadOOXMLWriter } -procedure TsSpreadOOXMLWriter.WriteGlobalFiles(AData: TsWorkbook); +procedure TsSpreadOOXMLWriter.WriteGlobalFiles; var i: Integer; begin @@ -133,7 +132,7 @@ begin // ' ' + LineEnding + ' ' + LineEnding; - for i := 1 to AData.GetWorksheetCount do + for i := 1 to Workbook.GetWorksheetCount do begin FContentTypes := FContentTypes + Format(' ', [i, MIME_WORKSHEET]) + LineEnding; @@ -149,7 +148,7 @@ begin '' + LineEnding + ''; - FStyles := + FStylesString := XML_HEADER + LineEnding + '' + LineEnding + ' ' + LineEnding + @@ -189,28 +188,28 @@ begin ''; end; -procedure TsSpreadOOXMLWriter.WriteContent(AData: TsWorkbook); +procedure TsSpreadOOXMLWriter.WriteContent; var i: Integer; begin { Workbook relations - Mark relation to all sheets } - FWorkbookRels := + FWorkbookRelsString := XML_HEADER + LineEnding + '' + LineEnding + '' + LineEnding + '' + LineEnding; - for i := 1 to AData.GetWorksheetCount do + for i := 1 to Workbook.GetWorksheetCount do begin - FWorkbookRels := FWorkbookRels + + FWorkbookRelsString := FWorkbookRelsString + Format('', [SCHEMAS_WORKSHEET, i, i+2]) + LineEnding; end; - FWorkbookRels := FWorkbookRels + + FWorkbookRelsString := FWorkbookRelsString + ''; // Global workbook data - Mark all sheets - FWorkbook := + FWorkbookString := XML_HEADER + LineEnding + '' + LineEnding + ' ' + LineEnding + // lastEdited="4" lowestEdited="4" rupBuild="4505" @@ -219,13 +218,13 @@ begin ' ' + LineEnding + ' ' + LineEnding; - FWorkbook := FWorkbook + ' ' + LineEnding; - for i := 1 to AData.GetWorksheetCount do - FWorkbook := FWorkbook + + FWorkbookString := FWorkbookString + ' ' + LineEnding; + for i := 1 to Workbook.GetWorksheetCount do + FWorkbookString := FWorkbookString + Format(' ', [i, i, i+2]) + LineEnding; - FWorkbook := FWorkbook + ' ' + LineEnding; + FWorkbookString := FWorkbookString + ' ' + LineEnding; - FWorkbook := FWorkbook + + FWorkbookString := FWorkbookString + ' ' + LineEnding + ''; @@ -236,10 +235,8 @@ begin // Write all worksheets, which fills also FSharedStrings SetLength(FSheets, 0); - for i := 0 to AData.GetWorksheetCount - 1 do - begin - WriteWorksheet(Adata.GetWorksheetByIndex(i)); - end; + for i := 0 to Workbook.GetWorksheetCount - 1 do + WriteWorksheet(Workbook.GetWorksheetByIndex(i)); // Finalization of the shared strings document FSharedStrings := @@ -354,9 +351,9 @@ begin else Result := 0; end; -constructor TsSpreadOOXMLWriter.Create; +constructor TsSpreadOOXMLWriter.Create(AWorkbook: TsWorkbook); begin - inherited Create; + inherited Create(AWorkbook); FPointSeparatorSettings := DefaultFormatSettings; FPointSeparatorSettings.DecimalSeparator := '.'; @@ -388,35 +385,35 @@ end; Writes an OOXML document to the disc } procedure TsSpreadOOXMLWriter.WriteToFile(const AFileName: string; - AData: TsWorkbook; const AOverwriteExisting: Boolean); + const AOverwriteExisting: Boolean); var lStream: TFileStream; begin - lStream:=TFileStream.Create(AFileName,fmCreate); + lStream:=TFileStream.Create(AFileName, fmCreate); try - WriteToStream(lStream, AData); + WriteToStream(lStream); finally FreeAndNil(lStream); end; end; -procedure TsSpreadOOXMLWriter.WriteToStream(AStream: TStream; AData: TsWorkbook); +procedure TsSpreadOOXMLWriter.WriteToStream(AStream: TStream); var FZip: TZipper; i: Integer; begin { Fill the strings with the contents of the files } - WriteGlobalFiles(AData); - WriteContent(AData); + WriteGlobalFiles; + WriteContent; { Write the data to streams } FSContentTypes := TStringStream.Create(FContentTypes); FSRelsRels := TStringStream.Create(FRelsRels); - FSWorkbookRels := TStringStream.Create(FWorkbookRels); - FSWorkbook := TStringStream.Create(FWorkbook); - FSStyles := TStringStream.Create(FStyles); + FSWorkbookRels := TStringStream.Create(FWorkbookRelsString); + FSWorkbook := TStringStream.Create(FWorkbookString); + FSStyles := TStringStream.Create(FStylesString); FSSharedStrings := TStringStream.Create(FSharedStrings); SetLength(FSSheets, Length(FSheets));