From c61e4418b7c58b82d15a17dbdfd1f1b76c83373e Mon Sep 17 00:00:00 2001 From: wp_xxyyzz Date: Tue, 22 Apr 2014 23:10:32 +0000 Subject: [PATCH] fpspreadsheet: Add reading and writing of font support to biff8, biff2, and fpspreadsheetgrid. Font colors in biff2 not yet working. No test cases yet. git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@2959 8e941d3f-bd1b-0410-a28a-d453659cc2b4 --- .../examples/excel2demo/excel2write.lpr | 11 + .../examples/excel8demo/excel8write.lpr | 18 +- components/fpspreadsheet/fpspreadsheet.pas | 257 +++++++++++- .../fpspreadsheet/fpspreadsheetgrid.pas | 25 +- components/fpspreadsheet/xlsbiff2.pas | 367 +++++++++++++++++- components/fpspreadsheet/xlsbiff8.pas | 260 +++++++------ components/fpspreadsheet/xlscommon.pas | 1 + 7 files changed, 789 insertions(+), 150 deletions(-) diff --git a/components/fpspreadsheet/examples/excel2demo/excel2write.lpr b/components/fpspreadsheet/examples/excel2demo/excel2write.lpr index 01ac74202..9b924ce83 100644 --- a/components/fpspreadsheet/examples/excel2demo/excel2write.lpr +++ b/components/fpspreadsheet/examples/excel2demo/excel2write.lpr @@ -51,6 +51,7 @@ begin // Write some string cells MyWorksheet.WriteUTF8Text(1, 0, 'First'); + MyWorksheet.WriteFont(1, 0, 'Arial', 12, [fssBold, fssItalic, fssUnderline], scRed); MyWorksheet.WriteUTF8Text(1, 1, 'Second'); MyWorksheet.WriteUTF8Text(1, 2, 'Third'); MyWorksheet.WriteUTF8Text(1, 3, 'Fourth'); @@ -79,6 +80,16 @@ begin MyWorksheet.WriteHorAlignment(5, 1, haCenter); MyWorksheet.WriteHorAlignment(5, 2, haRight); + // Red font, italic + MyWorksheet.WriteNumber(6, 0, 2014); + MyWorksheet.WriteFont(6, 0, 'Calibri', 15, [fssItalic], scRed); + MyWorksheet.WriteNumber(6, 1, 2015); + MyWorksheet.WriteFont(6, 1, 'Times New Roman', 9, [fssUnderline], scBlue); + MyWorksheet.WriteNumber(6, 2, 2016); + MyWorksheet.WriteFont(6, 2, 'Courier New', 8, [], scBlue); + MyWorksheet.WriteNumber(6, 3, 2017); + MyWorksheet.WriteFont(6, 3, 'Arial', 18, [fssBold], scBlue); + // Save the spreadsheet to a file MyWorkbook.WriteToFile(MyDir + 'test' + STR_EXCEL_EXTENSION, sfExcel2, true); MyWorkbook.Free; diff --git a/components/fpspreadsheet/examples/excel8demo/excel8write.lpr b/components/fpspreadsheet/examples/excel8demo/excel8write.lpr index 2df9a3fd9..65ccfee30 100644 --- a/components/fpspreadsheet/examples/excel8demo/excel8write.lpr +++ b/components/fpspreadsheet/examples/excel8demo/excel8write.lpr @@ -36,6 +36,8 @@ begin // Create the spreadsheet MyWorkbook := TsWorkbook.Create; + MyWorkbook.SetDefaultFont('Calibri', 9); + MyWorksheet := MyWorkbook.AddWorksheet(Str_Worksheet1); // Write some cells @@ -48,9 +50,10 @@ begin // D6 number with background color MyWorksheet.WriteNumber(5, 3, 10); - lCell := MyWorksheet.GetCell(5,3); - lCell^.BackgroundColor := scPURPLE; + lCell := MyWorksheet.GetCell(5, 3); + lCell^.BackgroundColor := scPurple; lCell^.UsedFormattingFields := [uffBackgroundColor]; + // or: MyWorksheet.WriteBackgroundColor(5, 3, scPurple); // E6 empty cell, only background color MyWorksheet.WriteBackgroundColor(5, 4, scYellow); @@ -60,7 +63,15 @@ begin // Word-wrapped long text in D7 MyWorksheet.WriteUTF8Text(6, 3, 'This is a very, very, very, very long 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.'); + Myworksheet.WriteFont(7, 3, 'Times New Roman', 16, [fssBold, fssItalic], scRed); + + // 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); { Uncomment this to test large XLS files for i := 2 to 20 do @@ -82,6 +93,7 @@ begin MyRPNFormula[1].Row := 0; MyRPNFormula[2].ElementKind := fekAdd; MyWorksheet.WriteRPNFormula(0, 4, MyRPNFormula); + MyWorksheet.WriteFont(0, 4, 'Arial', 10, [fssUnderline], scBlack); // Write the formula F1 = ABS(A1) SetLength(MyRPNFormula, 2); diff --git a/components/fpspreadsheet/fpspreadsheet.pas b/components/fpspreadsheet/fpspreadsheet.pas index 6a1d71cea..98b4c2315 100755 --- a/components/fpspreadsheet/fpspreadsheet.pas +++ b/components/fpspreadsheet/fpspreadsheet.pas @@ -131,8 +131,10 @@ type {@@ List of possible formatting fields } - TsUsedFormattingField = (uffTextRotation, uffBold, uffBorder, uffBackgroundColor, - uffNumberFormat, uffWordWrap, uffHorAlign, uffVertAlign); + TsUsedFormattingField = (uffTextRotation, uffFont, uffBold, uffBorder, + uffBackgroundColor, uffNumberFormat, uffWordWrap, + uffHorAlign, uffVertAlign + ); {@@ Describes which formatting fields are active } @@ -210,6 +212,20 @@ type scRGBCOLOR // Defined via TFPColor ); + {@@ 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" + Style: TsFontStyles; + Color: TsColor; + end; + {@@ Cell structure for TsWorksheet Never suppose that all *Value fields are valid, @@ -231,6 +247,7 @@ type DateTimeValue: TDateTime; { Formatting fields } UsedFormattingFields: TsUsedFormattingFields; + FontIndex: Integer; TextRotation: TsTextRotation; HorAlignment: TsHorAlignment; VertAlignment: TsVertAlignment; @@ -262,11 +279,13 @@ type TsCustomSpreadReader = class; TsCustomSpreadWriter = class; + TsWorkbook = class; { TsWorksheet } TsWorksheet = class private + FWorkbook: TsWorkbook; FCells: TAvlTree; // Items are TCell FCurrentNode: TAVLTreeNode; // For GetFirstCell and GetNextCell FRows, FCols: TIndexedAVLTree; // This lists contain only rows or cols with styles different from the standard @@ -302,6 +321,9 @@ type procedure WriteFormula(ARow, ACol: Cardinal; AFormula: TsFormula); procedure WriteNumberFormat(ARow, ACol: Cardinal; ANumberFormat: TsNumberFormat); procedure WriteRPNFormula(ARow, ACol: Cardinal; AFormula: TsRPNFormula); + function WriteFont(ARow, ACol: Cardinal; const AFontName: String; + AFontSize: Single; AFontStyle: TsFontStyles; AFontColor: TsColor): Integer; overload; + procedure WriteFont(ARow, ACol: Cardinal; AFontIndex: Integer); overload; procedure WriteTextRotation(ARow, ACol: Cardinal; ARotation: TsTextRotation); procedure WriteUsedFormatting(ARow, ACol: Cardinal; AUsedFormatting: TsUsedFormattingFields); procedure WriteBackgroundColor(ARow, ACol: Cardinal; AColor: TsColor); @@ -321,6 +343,7 @@ type property Cells: TAVLTree read FCells; property Cols: TIndexedAVLTree read FCols; property Rows: TIndexedAVLTree read FRows; + property Workbook: TsWorkbook read FWorkbook; end; { TsWorkbook } @@ -331,8 +354,10 @@ type FWorksheets: TFPList; FEncoding: TsEncoding; FFormat: TsSpreadsheetFormat; + FFontList: TFPList; + FBuiltinFontCount: Integer; { Internal methods } - procedure RemoveCallback(data, arg: pointer); + procedure RemoveWorksheetsCallback(data, arg: pointer); public { Base methods } constructor Create; @@ -356,6 +381,18 @@ type function GetWorksheetByName(AName: String): TsWorksheet; function GetWorksheetCount: Cardinal; procedure RemoveAllWorksheets; + { Font handling } + function AddFont(const AFontName: String; ASize: Single; + AStyle: TsFontStyles; AColor: TsColor): Integer; overload; + function AddFont(const AFont: TsFont): Integer; overload; + procedure CopyFontList(ASource: TFPList); + function FindFont(const AFontName: String; ASize: Single; + AStyle: TsFontStyles; AColor: TsColor): Integer; + function GetFont(AIndex: Integer): TsFont; + function GetFontCount: Integer; + procedure InitFonts; + procedure RemoveAllFonts; + procedure SetDefaultFont(const AFontName: String; ASize: Single); {@@ 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; @@ -383,6 +420,7 @@ type 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; end; {@@ TsSpreadWriter class reference type } @@ -394,6 +432,7 @@ type { TsCustomSpreadWriter } TsCustomSpreadWriter = class + private protected { Helper routines } procedure AddDefaultFormats(); virtual; @@ -508,8 +547,9 @@ uses resourcestring lpUnsupportedReadFormat = 'Tried to read a spreadsheet using an unsupported format'; lpUnsupportedWriteFormat = 'Tried to write a spreadsheet using an unsupported format'; - lpNoValidSpreadsheetFile = '"%s" is not a valid spreadsheet file.'; + lpNoValidSpreadsheetFile = '"%s" is not a valid spreadsheet file'; lpUnknownSpreadsheetFormat = 'unknown format'; + lpInvalidFontIndex = 'Invalid font index'; {@@ @@ -1209,6 +1249,45 @@ begin ACell^.RPNFormulaValue := AFormula; end; +{@@ + Adds font specification to the formatting of a cell + + @param ARow The row of the cell + @param ACol The column of the cell + @param AFontName Name of the font + @param AFontSize Size of the font, in points + @param AFontStyle Set with font style attributes + (don't use those of unit "graphics" !) + + @result Index of font in font list +} +function TsWorksheet.WriteFont(ARow, ACol: Cardinal; const AFontName: String; + AFontSize: Single; AFontStyle: TsFontStyles; AFontColor: TsColor): Integer; +var + lCell: PCell; +begin + lCell := GetCell(ARow, ACol); + Include(lCell^.UsedFormattingFields, uffFont); + Result := FWorkbook.FindFont(AFontName, AFontSize, AFontStyle, AFontColor); + if Result = -1 then + result := FWorkbook.AddFont(AFontName, AFontSize, AFontStyle, AFontColor); + lCell^.FontIndex := Result; +end; + +procedure TsWorksheet.WriteFont(ARow, ACol: Cardinal; AFontIndex: Integer); +var + lCell: PCell; +begin + if (AFontIndex >= 0) and (AFontIndex < Workbook.GetFontCount) and (AFontIndex <> 4) + // note: Font index 4 is not defined in BIFF + then begin + lCell := GetCell(ARow, ACol); + Include(lCell^.UsedFormattingFields, uffFont); + lCell^.FontIndex := AFontIndex; + end else + raise Exception.Create(lpInvalidFontIndex); +end; + {@@ Adds text rotation to the formatting of a cell @@ -1377,7 +1456,7 @@ end; {@@ Helper method for clearing the spreadsheet list. } -procedure TsWorkbook.RemoveCallback(data, arg: pointer); +procedure TsWorkbook.RemoveWorksheetsCallback(data, arg: pointer); begin TsWorksheet(data).Free; end; @@ -1389,6 +1468,9 @@ constructor TsWorkbook.Create; begin inherited Create; FWorksheets := TFPList.Create; + FFontList := TFPList.Create; + SetDefaultFont('Arial', 10.0); + InitFonts; end; {@@ @@ -1397,8 +1479,10 @@ end; destructor TsWorkbook.Destroy; begin RemoveAllWorksheets; + RemoveAllFonts; FWorksheets.Free; + FFontList.Free; inherited Destroy; end; @@ -1438,7 +1522,7 @@ begin if GsSpreadFormats[i].Format = AFormat then begin Result := GsSpreadFormats[i].ReaderClass.Create; - + Result.FWorkbook := self; Break; end; @@ -1459,7 +1543,6 @@ begin if GsSpreadFormats[i].Format = AFormat then begin Result := GsSpreadFormats[i].WriterClass.Create; - Break; end; @@ -1629,6 +1712,7 @@ begin Result := TsWorksheet.Create; Result.Name := AName; + Result.FWorkbook := Self; FWorksheets.Add(Pointer(Result)); end; @@ -1665,8 +1749,10 @@ end; } function TsWorkbook.GetWorksheetByIndex(AIndex: Cardinal): TsWorksheet; begin - if (integer(AIndex) < FWorksheets.Count) and (integer(AIndex)>=0) then Result := TsWorksheet(FWorksheets.Items[AIndex]) - else Result := nil; + if (integer(AIndex) < FWorksheets.Count) and (integer(AIndex)>=0) then + Result := TsWorksheet(FWorksheets.Items[AIndex]) + else + Result := nil; end; {@@ @@ -1711,7 +1797,155 @@ end; } procedure TsWorkbook.RemoveAllWorksheets; begin - FWorksheets.ForEachCall(RemoveCallback, nil); + FWorksheets.ForEachCall(RemoveWorksheetsCallback, nil); +end; + + +{ Font handling } + +{@@ + Adds a font to the font list. Returns the index in the font list. +} +function TsWorkbook.AddFont(const AFontName: String; ASize: Single; + AStyle: TsFontStyles; AColor: TsColor): Integer; +var + fnt: TsFont; +begin + fnt := TsFont.Create; + fnt.FontName := AFontName; + fnt.Size := ASize; + fnt.Style := AStyle; + fnt.Color := AColor; + Result := AddFont(fnt); +end; + +function TsWorkbook.AddFont(const AFont: TsFont): Integer; +begin + // Font index 4 does not exist in BIFF. Avoid that a real font gets this index. + if FFontList.Count = 4 then + FFontList.Add(nil); + result := FFontList.Add(AFont); +end; + +{@@ + Copies the font list "ASource" to the workbook's font list +} +procedure TsWorkbook.CopyFontList(ASource: TFPList); +var + fnt: TsFont; + i: Integer; +begin + RemoveAllFonts; + for i:=0 to ASource.Count-1 do begin + fnt := TsFont(ASource.Items[i]); + AddFont(fnt.FontName, fnt.Size, fnt.Style, fnt.Color); + end; +end; + +{@@ + Checks whether the font with the given specification is already contained in + the font list. Returns the index, or -1, if not found. +} +function TsWorkbook.FindFont(const AFontName: String; ASize: Single; + AStyle: TsFontStyles; AColor: TsColor): Integer; +var + fnt: TsFont; +begin + for Result := 0 to FFontList.Count-1 do begin + fnt := TsFont(FFontList.Items[Result]); + if (fnt <> nil) and + SameText(AFontName, fnt.FontName) and + (abs(ASize - fnt.Size) < 0.001) and // careful when comparing floating point numbers + (AStyle = fnt.Style) and + (AColor = fnt.Color) + then + exit; + end; + Result := -1; +end; + +{@@ + Initialized the font list. In case of BIFF format, adds 5 fonts +} +procedure TsWorkbook.InitFonts; +var + fntName: String; + fntSize: Single; +begin + // Memorize old default font + with TsFont(FFontList.Items[0]) do begin + fntName := FontName; + fntSize := Size; + end; + + // Remove current font list + RemoveAllFonts; + + // Build new font list + SetDefaultFont(fntName, fntSize); // Default font (FONT0) + AddFont(fntName, fntSize, [fssBold], scBlack); // FONT1 for uffBold + + AddFont(fntName, fntSize, [fssItalic], scBlack); // FONT2 for uffItalic + AddFont(fntName, fntSize, [fssUnderline], scBlack); // FONT3 for uffUnderline + // FONT4 which does not exist in BIFF is added automatically with nil as place-holder + AddFont(fntName, fntSize, [fssBold, fssItalic], scBlack); // FONT5 for uffBoldItalic + + + FBuiltinFontCount := FFontList.Count; +end; + +{@@ + Clears the list of fonts and releases their memory. +} +procedure TsWorkbook.RemoveAllFonts; +var + i, n: Integer; + fnt: TsFont; +begin + for i:=FFontList.Count-1 downto 0 do begin + fnt := TsFont(FFontList.Items[i]); + fnt.Free; + FFontList.Delete(i); + end; +end; + +{@@ + Defines the default font. This is the font with index 0 in the FontList. + The next built-in fonts will have the same font name and size +} +procedure TsWorkbook.SetDefaultFont(const AFontName: String; ASize: Single); +var + i: Integer; +begin + if FFontList.Count = 0 then + AddFont(AFontName, ASize, [], scBlack) + else + for i:=0 to FBuiltinFontCount-1 do begin + if (i <> 4) and (i < FFontList.Count) then + with TsFont(FFontList[i]) do begin + FontName := AFontName; + Size := ASize; + end; + end; +end; + +{@@ + Returns the font with the given index. +} +function TsWorkbook.GetFont(AIndex: Integer): TsFont; +begin + if (AIndex >= 0) and (AIndex < FFontList.Count) then + Result := FFontList.Items[AIndex] + else + Result := nil; +end; + +{@@ + Returns the count of registered fonts +} +function TsWorkbook.GetFontCount: Integer; +begin + Result := FFontList.Count; end; { TsCustomSpreadReader } @@ -1817,6 +2051,9 @@ begin end; end; + if uffFont in AFormat^.UsedFormattingFields then + if (FFormattingStyles[i].FontIndex <> AFormat^.FontIndex) then Continue; + // If we arrived here it means that the styles match Exit(i); end; diff --git a/components/fpspreadsheet/fpspreadsheetgrid.pas b/components/fpspreadsheet/fpspreadsheetgrid.pas index 3359ea3d6..40968a76e 100644 --- a/components/fpspreadsheet/fpspreadsheetgrid.pas +++ b/components/fpspreadsheet/fpspreadsheetgrid.pas @@ -149,7 +149,7 @@ type property OnContextPopup; end; -function FPSColorToColor(FPSColor: TsColor): TColor; +function FPSColorToColor(FPSColor: TsColor; ADefault: TColor): TColor; procedure Register; @@ -174,7 +174,7 @@ begin end; end; -function FPSColorToColor(FPSColor: TsColor): TColor; +function FPSColorToColor(FPSColor: TsColor; ADefault: TColor): TColor; begin case FPSColor of scBlack : Result := clBlack; @@ -201,7 +201,7 @@ begin scBrown : Result := TColor($003F85CD); // CD853F scBeige : Result := TColor($00DCF5F5); // F5F5DC scWheat : Result := TColor($00B3DEF5); // F5DEB3 - else Result := clWhite; + else Result := ADefault; end; end; @@ -250,6 +250,8 @@ var ts: TTextStyle; lCell: PCell; r, c: Integer; + fnt: TsFont; + style: TFontStyles; begin Canvas.Brush.Bitmap := nil; ts := Canvas.TextStyle; @@ -300,12 +302,27 @@ begin Canvas.Brush.Bitmap := FillPattern_BIFF2; end else begin Canvas.Brush.Style := bsSolid; - Canvas.Brush.Color := FPSColorToColor(lCell^.BackgroundColor); + Canvas.Brush.Color := FPSColorToColor(lCell^.BackgroundColor, Color); end; end else begin Canvas.Brush.Style := bsSolid; Canvas.Brush.Color := Color; end; + // Font + if (uffFont in lCell^.UsedFormattingFields) then begin + fnt := FWorkbook.GetFont(lCell^.FontIndex); + if fnt <> nil then begin + Canvas.Font.Name := fnt.FontName; + Canvas.Font.Color := FPSColorToColor(fnt.Color, clBlack); + style := []; + if fssBold in fnt.Style then Include(style, fsBold); + if fssItalic in fnt.Style then Include(style, fsItalic); + if fssUnderline in fnt.Style then Include(style, fsUnderline); + if fssStrikeout in fnt.Style then Include(style, fsStrikeout); + Canvas.Font.Style := style; + Canvas.Font.Size := round(fnt.Size); + end; + end; end; end; Canvas.TextStyle := ts; diff --git a/components/fpspreadsheet/xlsbiff2.pas b/components/fpspreadsheet/xlsbiff2.pas index bd052b96e..0a9d85e44 100755 --- a/components/fpspreadsheet/xlsbiff2.pas +++ b/components/fpspreadsheet/xlsbiff2.pas @@ -52,6 +52,7 @@ type out XF, AFormat, AFont, AStyle: byte); { Record writing methods } procedure ReadBlank(AStream: TStream); override; + procedure ReadFont(AStream: TStream); procedure ReadFormula(AStream: TStream); override; procedure ReadLabel(AStream: TStream); override; procedure ReadNumber(AStream: TStream); override; @@ -65,11 +66,22 @@ type TsSpreadBIFF2Writer = class(TsSpreadBIFFWriter) private - procedure WriteCellFormatting(AStream: TStream; ACell: PCell); + function FindXFIndex(ACell: PCell): Word; { Record writing methods } - procedure WriteBlank(AStream: TStream; const ARow, ACol: Cardinal; ACell: PCell); override; 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 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); + protected + procedure AddDefaultFormats(); override; + procedure WriteBlank(AStream: TStream; const ARow, ACol: Cardinal; ACell: PCell); override; procedure WriteRPNFormula(AStream: TStream; const ARow, ACol: Cardinal; const AFormula: TsRPNFormula; ACell: PCell); override; procedure WriteLabel(AStream: TStream; const ARow, ACol: Cardinal; const AValue: string; ACell: PCell); override; procedure WriteNumber(AStream: TStream; const ARow, ACol: Cardinal; const AValue: double; ACell: PCell); override; @@ -91,6 +103,9 @@ const INT_EXCEL_ID_ROWINFO = $0008; INT_EXCEL_ID_BOF = $0009; INT_EXCEL_ID_EOF = $000A; + INT_EXCEL_ID_XF = $0043; + INT_EXCEL_ID_IXFE = $0044; + INT_EXCEL_ID_FONTCOLOR = $0045; { Cell Addresses constants } MASK_EXCEL_ROW = $3FFF; @@ -104,9 +119,46 @@ const { TsSpreadBIFF2Writer } -procedure TsSpreadBIFF2Writer.WriteCellFormatting(AStream: TStream; ACell: PCell); +procedure TsSpreadBIFF2Writer.AddDefaultFormats(); +begin + NextXFIndex := 16; //21; + + SetLength(FFormattingStyles, 1); + + // XF0..XF14: Normal style, Row Outline level 1..7, + // Column Outline level 1..7. + + // XF15 - Default cell format, no formatting (4.6.2) + FFormattingStyles[0].UsedFormattingFields := []; + FFormattingStyles[0].Row := 15; +end; + +function TsSpreadBIFF2Writer.FindXFIndex(ACell: PCell): Word; +var + i: Integer; +begin + if ACell^.UsedFormattingFields = [] then + Result := 15 + else begin + // If not, then we need to search in the list of dynamic formats + i := FindFormattingInList(ACell); + // Carefully check the index + if (i < 0) or (i > Length(FFormattingStyles)) then + raise Exception.Create('[TsSpreadBIFF2Writer.WriteXFIndex] Invalid Index, this should not happen!'); + Result := FFormattingStyles[i].Row; + end; +end; + +{ + Attaches cell formatting data for the given cell to the current record. + Is called from all writing methods of cell contents. +} +procedure TsSpreadBIFF2Writer.WriteCellFormatting(AStream: TStream; ACell: PCell; + XFIndex: Word); var b: Byte; + xf: Word; + i: Integer; begin if ACell^.UsedFormattingFields = [] then begin @@ -120,12 +172,13 @@ begin // Mask $3F: Index to XF record // Mask $40: 1 = Cell is locked // Mask $80: 1 = Formula is hidden - AStream.WriteByte($0); + AStream.WriteByte(XFIndex and $3F); // 2nd byte: // Mask $3F: Index to FORMAT record // Mask $C0: Index to FONT record - AStream.WriteByte($0); + b := ACell.FontIndex shl 6; + AStream.WriteByte(b); // 3rd byte // Mask $07: horizontal alignment @@ -148,6 +201,18 @@ begin AStream.WriteByte(b); end; +{ + Writes an Excel 2 IXFE record + This record contains the "real" XF index if it is > 62. +} +procedure TsSpreadBIFF2Writer.WriteIXFE(AStream: TStream; XFIndex: Word); +begin + { BIFF Record header } + AStream.WriteWord(WordToLE(INT_EXCEL_ID_IXFE)); + AStream.WriteWord(WordToLE(2)); + AStream.WriteWord(WordToLE(XFIndex)); +end; + { Writes an Excel 2 file to a stream @@ -158,11 +223,165 @@ procedure TsSpreadBIFF2Writer.WriteToStream(AStream: TStream; AData: TsWorkbook) begin WriteBOF(AStream); + WriteFonts(AStream, AData); + + WriteXFRecords(AStream, AData); + WriteCellsToStream(AStream, AData.GetFirstWorksheet.Cells); WriteEOF(AStream); end; +procedure TsSpreadBIFF2Writer.WriteXF(AStream: TStream; + AFontIndex, AFormatIndex: byte; ABorders: TsCellBorders = []; + AHorAlign: TsHorAlignment = haLeft; AddBackground: Boolean = false); +var + b: Byte; +begin + { BIFF Record header } + AStream.WriteWord(WordToLE(INT_EXCEL_ID_XF)); + AStream.WriteWord(WordToLE(4)); + + { Index to FONT record } + AStream.WriteByte(AFontIndex); + + { not used } + AStream.WriteByte(0); + + { number format and cell flags } + b := AFormatIndex and $3F; + AStream.WriteByte(b); + + { Horizontal alignment, border style, and background } + b := byte(AHorAlign); + if cbWest in ABorders then b := b or $08; + if cbEast in ABorders then b := b or $10; + if cbNorth in ABorders then b := b or $20; + if cbSouth in ABorders then b := b or $40; + if AddBackground then b := b or $80; + AStream.WriteByte(b); +end; + +procedure TsSpreadBIFF2Writer.WriteXFFieldsForFormattingStyles(AStream: TStream); +var + i: Integer; + lFontIndex: Word; + lFormatIndex: Word; //number format + lBorders: TsCellBorders; + lAddBackground: Boolean; + lHorAlign: TsHorAlignment; + fmt: String; +begin + // The first style was already added (see AddDefaultFormats) + for i := 1 to Length(FFormattingStyles) - 1 do begin + // Default styles + lFontIndex := 0; + lFormatIndex := 0; //General format (one of the built-in number formats) + lBorders := []; + lHorAlign := FFormattingStyles[i].HorAlignment; + + // Now apply the modifications. + (* + if uffNumberFormat in FFormattingStyles[i].UsedFormattingFields then + case FFormattingStyles[i].NumberFormat of + nfFixed: + case FFormattingStyles[i].NumberDecimals of + 0: lFormatIndex := FORMAT_FIXED_0_DECIMALS; + 2: lFormatIndex := FORMAT_FIXED_2_DECIMALS; + end; + nfFixedTh: + case FFormattingStyles[i].NumberDecimals of + 0: lFormatIndex := FORMAT_FIXED_THOUSANDS_0_DECIMALS; + 2: lFormatIndex := FORMAT_FIXED_THOUSANDS_2_DECIMALS; + end; + nfExp: + lFormatIndex := FORMAT_EXP_2_DECIMALS; + nfSci: + lFormatIndex := FORMAT_SCI_1_DECIMAL; + nfPercentage: + case FFormattingStyles[i].NumberDecimals of + 0: lFormatIndex := FORMAT_PERCENT_0_DECIMALS; + 2: lFormatIndex := FORMAT_PERCENT_2_DECIMALS; + end; + { + nfCurrency: + case FFormattingStyles[i].NumberDecimals of + 0: lFormatIndex := FORMAT_CURRENCY_0_DECIMALS; + 2: lFormatIndex := FORMAT_CURRENCY_2_DECIMALS; + end; + } + nfShortDate: + lFormatIndex := FORMAT_SHORT_DATE; + nfShortTime: + lFormatIndex := FORMAT_SHORT_TIME; + nfLongTime: + lFormatIndex := FORMAT_LONG_TIME; + nfShortTimeAM: + lFormatIndex := FORMAT_SHORT_TIME_AM; + nfLongTimeAM: + lFormatIndex := FORMAT_LONG_TIME_AM; + nfShortDateTime: + lFormatIndex := FORMAT_SHORT_DATETIME; + nfFmtDateTime: + begin + fmt := lowercase(FFormattingStyles[i].NumberFormatStr); + if (fmt = 'dm') or (fmt = 'd-mmm') or (fmt = 'd mmm') or (fmt = 'd. mmm') or (fmt = 'd/mmm') then + lFormatIndex := FORMAT_DATE_DM + else + if (fmt = 'my') or (fmt = 'mmm-yy') or (fmt = 'mmm yy') or (fmt = 'mmm/yy') then + lFormatIndex := FORMAT_DATE_MY + else + if (fmt = 'ms') or (fmt = 'nn:ss') or (fmt = 'mm:ss') then + lFormatIndex := FORMAT_TIME_MS + else + if (fmt = 'msz') or (fmt = 'nn:ss.zzz') or (fmt = 'mm:ss.zzz') or (fmt = 'mm:ss.0') or (fmt = 'mm:ss.z') or (fmt = 'nn:ss.z') then + lFormatIndex := FORMAT_TIME_MSZ + end; + nfTimeInterval: + lFormatIndex := FORMAT_TIME_INTERVAL; + end; + *) + + if uffBorder in FFormattingStyles[i].UsedFormattingFields then + lBorders := FFormattingStyles[i].Border; + + if uffBold in FFormattingStyles[i].UsedFormattingFields then + lFontIndex := 1; // must be before uffFont which overrides uffBold + + if uffFont in FFormattingStyles[i].UsedFormattingFields then + lFontIndex := FFormattingStyles[i].FontIndex; + + lAddBackground := (uffBackgroundColor in FFormattingStyles[i].UsedFormattingFields); + + // And finally write the style + WriteXF(AStream, lFontIndex, lFormatIndex, lBorders, lHorAlign, lAddBackground); + end; +end; + +procedure TsSpreadBIFF2Writer.WriteXFRecords(AStream: TStream; AData: TsWorkbook); +begin + WriteXF(AStream, 0, 0); // XF0 + WriteXF(AStream, 0, 0); // XF1 + WriteXF(AStream, 0, 0); // XF2 + WriteXF(AStream, 0, 0); // XF3 + WriteXF(AStream, 0, 0); // XF4 + WriteXF(AStream, 0, 0); // XF5 + WriteXF(AStream, 0, 0); // XF6 + WriteXF(AStream, 0, 0); // XF7 + WriteXF(AStream, 0, 0); // XF8 + WriteXF(AStream, 0, 0); // XF9 + WriteXF(AStream, 0, 0); // XF10 + WriteXF(AStream, 0, 0); // XF11 + WriteXF(AStream, 0, 0); // XF12 + WriteXF(AStream, 0, 0); // XF13 + WriteXF(AStream, 0, 0); // XF14 + WriteXF(AStream, 0, 0); // XF15 - Default, no formatting + + // Add all further non-standard/built-in formatting styles + ListAllFormattingStyles(AData); + WriteXFFieldsForFormattingStyles(AStream); +end; + { Writes an Excel 2 BOF record @@ -193,6 +412,67 @@ begin AStream.WriteWord($0000); end; +{ + Writes an Excel 2 font record + The font data is passed as font index. +} +procedure TsSpreadBIFF2Writer.WriteFont(AStream: TStream; AData: TsWorkbook; + AFontIndex: Integer); +var + Len: Byte; + lFontName: AnsiString; + optn: Word; + font: TsFont; +begin + font := AData.GetFont(AFontIndex); + if font = nil then // this happens for FONT4 in case of BIFF + exit; + + if font.FontName = '' then + raise Exception.Create('Font name not specified.'); + if font.Size <= 0.0 then + raise Exception.Create('Font size not specified.'); + + lFontName := font.FontName; + Len := Length(lFontName); + + { BIFF Record header } + AStream.WriteWord(WordToLE(INT_EXCEL_ID_FONT)); + AStream.WriteWord(WordToLE(4 + 1 + Len * Sizeof(AnsiChar))); + + { Height of the font in twips = 1/20 of a point } + AStream.WriteWord(WordToLE(round(font.Size*20))); + + { Option flags } + optn := 0; + if fssBold in font.Style then optn := optn or $0001; + if fssItalic in font.Style then optn := optn or $0002; + if fssUnderline in font.Style then optn := optn or $0004; + if fssStrikeout in font.Style then optn := optn or $0008; + AStream.WriteWord(WordToLE(optn)); + + { Font name: Unicodestring, char count in 1 byte } + AStream.WriteByte(Len); + AStream.WriteBuffer(lFontName[1], Len * Sizeof(AnsiChar)); + + { Font color: goes into next record! } + + { BIFF Record header } + AStream.WriteWord(WordToLE(INT_EXCEL_ID_FONTCOLOR)); + AStream.WriteWord(WordToLE(2)); + + { Font color index, only first 8 palette entries allowed! } + AStream.WriteWord(WordToLE(word(font.Color))); +end; + +procedure TsSpreadBiff2Writer.WriteFonts(AStream: TStream; AData: TsWorkbook); +var + i: Integer; +begin + for i:=0 to AData.GetFontCount-1 do + WriteFont(AStream, AData, i); +end; + { Writes an Excel 2 FORMULA record @@ -220,23 +500,26 @@ var r: Cardinal; len: Integer; s: ansistring; + xf: Word; begin RPNLength := 0; FormulaResult := 0.0; + xf := FindXFIndex(ACell); + if xf >= 63 then + WriteIXFE(AStream, xf); + { BIFF Record header } AStream.WriteWord(WordToLE(INT_EXCEL_ID_FORMULA)); RecordSizePos := AStream.Position; AStream.WriteWord(WordToLE(17 + RPNLength)); - { BIFF Record data } + { Row and column } AStream.WriteWord(WordToLE(ARow)); AStream.WriteWord(WordToLE(ACol)); { BIFF2 Attributes } - AStream.WriteByte($0); - AStream.WriteByte($0); - AStream.WriteByte($0); + WriteCellFormatting(AStream, ACell, xf); { Result of the formula in IEEE 754 floating-point value } AStream.WriteBuffer(FormulaResult, 8); @@ -355,7 +638,13 @@ end; *******************************************************************} procedure TsSpreadBIFF2Writer.WriteBlank(AStream: TStream; const ARow, ACol: Cardinal; ACell: PCell); +var + xf: Word; begin + xf := FindXFIndex(ACell); + if xf >= 63 then + WriteIXFE(AStream, xf); + { BIFF Record header } AStream.WriteWord(WordToLE(INT_EXCEL_ID_BLANK)); AStream.WriteWord(WordToLE(7)); @@ -365,7 +654,7 @@ begin AStream.WriteWord(WordToLE(ACol)); { BIFF2 Attributes } - WriteCellFormatting(AStream, ACell); + WriteCellFormatting(AStream, ACell, xf); end; {******************************************************************* @@ -387,6 +676,8 @@ var L: Byte; AnsiText: ansistring; TextTooLong: boolean=false; +var + xf: Word; begin if AValue = '' then Exit; // Writing an empty text doesn't work @@ -403,6 +694,10 @@ begin end; L := Length(AnsiText); + xf := FindXFIndex(ACell); + if xf >= 63 then + WriteIXFE(AStream, xf); + { BIFF Record header } AStream.WriteWord(WordToLE(INT_EXCEL_ID_LABEL)); AStream.WriteWord(WordToLE(8 + L)); @@ -412,7 +707,7 @@ begin AStream.WriteWord(WordToLE(ACol)); { BIFF2 Attributes } - WriteCellFormatting(AStream, ACell); + WriteCellFormatting(AStream, ACell, xf); { String with 8-bit size } AStream.WriteByte(L); @@ -437,7 +732,13 @@ end; *******************************************************************} procedure TsSpreadBIFF2Writer.WriteNumber(AStream: TStream; const ARow, ACol: Cardinal; const AValue: double; ACell: PCell); +var + xf: Word; begin + xf := FindXFIndex(ACell); + if xf >= 63 then + WriteIXFE(AStream, xf); + { BIFF Record header } AStream.WriteWord(WordToLE(INT_EXCEL_ID_NUMBER)); AStream.WriteWord(WordToLE(15)); @@ -447,9 +748,7 @@ begin AStream.WriteWord(WordToLE(ACol)); { BIFF2 Attributes } - AStream.WriteByte($0); - AStream.WriteByte($0); - AStream.WriteByte($0); + WriteCellFormatting(AStream, ACell, xf); { IEE 754 floating-point value } AStream.WriteBuffer(AValue, 8); @@ -482,6 +781,10 @@ begin lCell := FWorksheet.GetCell(ARow, ACol); if Assigned(lCell) then begin + // Font index + Include(lCell^.UsedFormattingFields, uffFont); + lCell^.FontIndex := AFont; + // Horizontal justification if AStyle and $07 <> 0 then begin Include(lCell^.UsedFormattingFields, uffHorAlign); @@ -516,12 +819,47 @@ begin ApplyCellFormatting(ARow, ACol, XF, AFormat, AFont, AStyle); end; +procedure TsSpreadBIFF2Reader.ReadFont(AStream: TStream); +var + lHeight: Word; + lOptions: Word; + Len: Byte; + lFontName: UTF8String; + font: TsFont; +begin + font := TsFont.Create; + + { Height of the font in twips = 1/20 of a point } + lHeight := WordLEToN(AStream.ReadWord); // WordToLE(200) + font.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); + + { Font name: Unicodestring, char count in 1 byte } + Len := AStream.ReadByte(); + SetLength(lFontName, Len); + AStream.ReadBuffer(lFontName[1], Len); + font.FontName := lFontName; + + { Add font to workbook's font list } + FWorkbook.AddFont(font); +end; + procedure TsSpreadBIFF2Reader.ReadFromStream(AStream: TStream; AData: TsWorkbook); var BIFF2EOF: Boolean; RecordType: Word; CurStreamPos: Int64; begin + // Clear existing fonts. They will be replaced by those from the file. + FWorkbook.RemoveAllFonts; + { Store some data about the workbook that other routines need } WorkBookEncoding := AData.Encoding; @@ -542,6 +880,7 @@ 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); diff --git a/components/fpspreadsheet/xlsbiff8.pas b/components/fpspreadsheet/xlsbiff8.pas index 38303f54d..6741f03ca 100755 --- a/components/fpspreadsheet/xlsbiff8.pas +++ b/components/fpspreadsheet/xlsbiff8.pas @@ -65,6 +65,7 @@ uses type TXFRecordData = class public + FontIndex: Integer; FormatIndex: Integer; HorAlignment: TsHorAlignment; VertAlignment: TsVertAlignment; @@ -172,15 +173,16 @@ type // procedure WriteDateMode in xlscommon; Workbook Globals record procedure WriteDimensions(AStream: TStream; AWorksheet: TsWorksheet); procedure WriteEOF(AStream: TStream); - procedure WriteFont(AStream: TStream; AFont: TFPCustomFont); + procedure WriteFont(AStream: TStream; AFont: TsFont); + procedure WriteFonts(AStream: TStream; AData: TsWorkbook); 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 WritePalette(AStream: TStream); procedure WriteRPNFormula(AStream: TStream; const ARow, ACol: Cardinal; const AFormula: TsRPNFormula; ACell: PCell); override; procedure WriteStyle(AStream: TStream); @@ -191,6 +193,7 @@ type AHorAlignment: TsHorAlignment = haDefault; AVertAlignment: TsVertAlignment = vaDefault; AWordWrap: Boolean = false; AddBackground: Boolean = false; ABackgroundColor: TsColor = scSilver); + procedure WriteXFRecords(AStream: TStream; AData: TsWorkbook); public // constructor Create; // destructor Destroy; override; @@ -211,7 +214,6 @@ const INT_EXCEL_ID_COUNTRY = $008C; INT_EXCEL_ID_EOF = $000A; INT_EXCEL_ID_DIMENSIONS = $0200; - INT_EXCEL_ID_FONT = $0031; INT_EXCEL_ID_FORMULA = $0006; INT_EXCEL_ID_INDEX = $020B; INT_EXCEL_ID_LABEL = $0204; @@ -399,12 +401,6 @@ begin end; } - if ACell^.UsedFormattingFields = [uffBold] then - begin - AStream.WriteWord(WordToLE(18)); //XF_18 - Exit; - end; - // If not, then we need to search in the list of dynamic formats lIndex := FindFormattingInList(ACell); // Carefully check the index @@ -430,9 +426,8 @@ var lWordWrap: Boolean; fmt: String; begin - // The first 4 styles were already added - for i := 4 to Length(FFormattingStyles) - 1 do - begin + // The first style was already added + for i := 1 to Length(FFormattingStyles) - 1 do begin // Default styles lFontIndex := 0; lFormatIndex := 0; //General format (one of the built-in number formats) @@ -515,7 +510,10 @@ begin end; if uffBold in FFormattingStyles[i].UsedFormattingFields then - lFontIndex := 1; + lFontIndex := 1; // must be before uffFont which overrides uffBold + + if uffFont in FFormattingStyles[i].UsedFormattingFields then + lFontIndex := FFormattingStyles[i].FontIndex; lAddBackground := (uffBackgroundColor in FFormattingStyles[i].UsedFormattingFields); lWordwrap := (uffWordwrap in FFormattingStyles[i].UsedFormattingFields); @@ -532,9 +530,9 @@ end; } procedure TsSpreadBIFF8Writer.AddDefaultFormats(); begin - NextXFIndex := 21; + NextXFIndex := 16; - SetLength(FFormattingStyles, 6); + SetLength(FFormattingStyles, 1); // XF0..XF14: Normal style, Row Outline level 1..7, // Column Outline level 1..7. @@ -542,20 +540,6 @@ begin // XF15 - Default cell format, no formatting (4.6.2) FFormattingStyles[0].UsedFormattingFields := []; FFormattingStyles[0].Row := 15; - - // XF16 - Rotated - FFormattingStyles[1].UsedFormattingFields := [uffTextRotation]; - FFormattingStyles[1].Row := 16; - FFormattingStyles[1].TextRotation := rt90DegreeCounterClockwiseRotation; - - // XF17 - Rotated - FFormattingStyles[2].UsedFormattingFields := [uffTextRotation]; - FFormattingStyles[2].Row := 17; - FFormattingStyles[2].TextRotation := rt90DegreeClockwiseRotation; - - // XF18 - Bold - FFormattingStyles[3].UsedFormattingFields := [uffBold]; - FFormattingStyles[3].Row := 18; end; {******************************************************************* @@ -606,7 +590,6 @@ end; *******************************************************************} procedure TsSpreadBIFF8Writer.WriteToStream(AStream: TStream; AData: TsWorkbook); var - FontData: TFPCustomFont; MyData: TMemoryStream; CurrentPos: Int64; Boundsheets: array of Int64; @@ -620,72 +603,13 @@ begin WriteWindow1(AStream); - FontData := TFPCustomFont.Create; - try - FontData.Name := 'Arial'; + WriteFonts(AStream, AData); - // FONT0 - normal - WriteFont(AStream, FontData); - // FONT1 - bold - FontData.Bold := True; - WriteFont(AStream, FontData); - FontData.Bold := False; - // FONT2 - WriteFont(AStream, FontData); - // FONT3 - WriteFont(AStream, FontData); - // FONT5 - WriteFont(AStream, FontData); - finally - FontData.Free; - end; - // PALETTE WritePalette(AStream); - // XF0 - WriteXF(AStream, 0, 0, MASK_XF_TYPE_PROT_STYLE_XF, XF_ROTATION_HORIZONTAL, []); - // XF1 - WriteXF(AStream, 0, 0, MASK_XF_TYPE_PROT_STYLE_XF, XF_ROTATION_HORIZONTAL, []); - // XF2 - WriteXF(AStream, 0, 0, MASK_XF_TYPE_PROT_STYLE_XF, XF_ROTATION_HORIZONTAL, []); - // XF3 - WriteXF(AStream, 0, 0, MASK_XF_TYPE_PROT_STYLE_XF, XF_ROTATION_HORIZONTAL, []); - // XF4 - WriteXF(AStream, 0, 0, MASK_XF_TYPE_PROT_STYLE_XF, XF_ROTATION_HORIZONTAL, []); - // XF5 - WriteXF(AStream, 0, 0, MASK_XF_TYPE_PROT_STYLE_XF, XF_ROTATION_HORIZONTAL, []); - // XF6 - WriteXF(AStream, 0, 0, MASK_XF_TYPE_PROT_STYLE_XF, XF_ROTATION_HORIZONTAL, []); - // XF7 - WriteXF(AStream, 0, 0, MASK_XF_TYPE_PROT_STYLE_XF, XF_ROTATION_HORIZONTAL, []); - // XF8 - WriteXF(AStream, 0, 0, MASK_XF_TYPE_PROT_STYLE_XF, XF_ROTATION_HORIZONTAL, []); - // XF9 - WriteXF(AStream, 0, 0, MASK_XF_TYPE_PROT_STYLE_XF, XF_ROTATION_HORIZONTAL, []); - // XF10 - WriteXF(AStream, 0, 0, MASK_XF_TYPE_PROT_STYLE_XF, XF_ROTATION_HORIZONTAL, []); - // XF11 - WriteXF(AStream, 0, 0, MASK_XF_TYPE_PROT_STYLE_XF, XF_ROTATION_HORIZONTAL, []); - // XF12 - WriteXF(AStream, 0, 0, MASK_XF_TYPE_PROT_STYLE_XF, XF_ROTATION_HORIZONTAL, []); - // XF13 - WriteXF(AStream, 0, 0, MASK_XF_TYPE_PROT_STYLE_XF, XF_ROTATION_HORIZONTAL, []); - // XF14 - WriteXF(AStream, 0, 0, MASK_XF_TYPE_PROT_STYLE_XF, XF_ROTATION_HORIZONTAL, []); - // XF15 - Default, no formatting - WriteXF(AStream, 0, 0, 0, XF_ROTATION_HORIZONTAL, []); - // XF16 - Rotated - WriteXF(AStream, 0, 0, 0, XF_ROTATION_90_DEGREE_COUNTERCLOCKWISE, []); - // XF17 - Rotated - WriteXF(AStream, 0, 0, 0, XF_ROTATION_90_DEGREE_CLOCKWISE, []); - // XF18 - Bold - WriteXF(AStream, 1, 0, 0, XF_ROTATION_HORIZONTAL, []); - - // Add all further non-standard/built-in formatting styles - ListAllFormattingStyles(AData); - WriteXFFieldsForFormattingStyles(AStream); - + // XF Records + WriteXFRecords(AStream, AData); WriteStyle(AStream); // A BOUNDSHEET for each worksheet @@ -937,15 +861,25 @@ end; * * DESCRIPTION: Writes an Excel 8 FONT record * -* The font data is passed in an instance of TFPCustomFont +* The font data is passed in an instance of TsFont * *******************************************************************} -procedure TsSpreadBIFF8Writer.WriteFont(AStream: TStream; AFont: TFPCustomFont); + +procedure TsSpreadBIFF8Writer.WriteFont(AStream: TStream; AFont: TsFont); var Len: Byte; WideFontName: WideString; + optn: Word; begin - WideFontName:=AFont.Name; + if AFont = nil then // this happens for FONT4 in case of BIFF + exit; + + if AFont.FontName = '' then + raise Exception.Create('Font name not specified.'); + if AFont.Size <= 0.0 then + raise Exception.Create('Font size not specified.'); + + WideFontName := AFont.FontName; Len := Length(WideFontName); { BIFF Record header } @@ -953,24 +887,33 @@ begin AStream.WriteWord(WordToLE(14 + 1 + 1 + Len * Sizeof(WideChar))); { Height of the font in twips = 1/20 of a point } - AStream.WriteWord(WordToLE(200)); + AStream.WriteWord(WordToLE(round(AFont.Size*20))); { Option flags } - if AFont.Bold then AStream.WriteWord(WordToLE(1)) - else AStream.WriteWord(WordToLE(0)); + optn := 0; + if fssBold in AFont.Style then optn := optn or $0001; + if fssItalic in AFont.Style then optn := optn or $0002; + if fssUnderline in AFont.Style then optn := optn or $0004; + if fssStrikeout in AFont.Style then optn := optn or $0008; + AStream.WriteWord(WordToLE(optn)); { Colour index } - AStream.WriteWord(WordToLE($7FFF)); + AStream.WriteWord(WordToLE(8 + ord(AFont.Color))); //WordToLE($7FFF)); { Font weight } - if AFont.Bold then AStream.WriteWord(WordToLE(INT_FONT_WEIGHT_BOLD)) - else AStream.WriteWord(WordToLE(INT_FONT_WEIGHT_NORMAL)); + if fssBold in AFont.Style then + AStream.WriteWord(WordToLE(INT_FONT_WEIGHT_BOLD)) + else + AStream.WriteWord(WordToLE(INT_FONT_WEIGHT_NORMAL)); { Escapement type } AStream.WriteWord(WordToLE(0)); { Underline type } - AStream.WriteByte(0); + if fssUnderline in AFont.Style then + AStream.WriteByte(1) + else + AStream.WriteByte(0); { Font family } AStream.WriteByte(0); @@ -988,6 +931,20 @@ begin AStream.WriteBuffer(WideStringToLE(WideFontName)[1], Len * Sizeof(WideChar)); end; +{******************************************************************* +* TsSpreadBIFF8Writer.WriteFonts () +* +* DESCRIPTION: Writes the Excel 8 FONT records neede for the +* used fonts in the workbook. +* +*******************************************************************} +procedure TsSpreadBiff8Writer.WriteFonts(AStream: TStream; AData: TsWorkbook); +var + i: Integer; +begin + for i:=0 to AData.GetFontCount-1 do + WriteFont(AStream, AData.GetFont(i)); +end; {******************************************************************* * TsSpreadBIFF8Writer.WriteFormula () @@ -1364,6 +1321,14 @@ begin AStream.WriteBuffer(AValue, 8); end; + +(******************************************************************* +* TsSpreadBIFF8Writer.WritePalette +* +* DESCRIPTION: Writes Excel PALETTE records +* +*******************************************************************) + procedure TsSpreadBIFF8Writer.WritePalette(AStream: TStream); begin { BIFF Record header } @@ -1667,6 +1632,47 @@ begin AStream.WriteWord(0); end; +procedure TsSpreadBIFF8Writer.WriteXFRecords(AStream: TStream; AData: TsWorkbook); +begin + // XF0 + WriteXF(AStream, 0, 0, MASK_XF_TYPE_PROT_STYLE_XF, XF_ROTATION_HORIZONTAL, []); + // XF1 + WriteXF(AStream, 0, 0, MASK_XF_TYPE_PROT_STYLE_XF, XF_ROTATION_HORIZONTAL, []); + // XF2 + WriteXF(AStream, 0, 0, MASK_XF_TYPE_PROT_STYLE_XF, XF_ROTATION_HORIZONTAL, []); + // XF3 + WriteXF(AStream, 0, 0, MASK_XF_TYPE_PROT_STYLE_XF, XF_ROTATION_HORIZONTAL, []); + // XF4 + WriteXF(AStream, 0, 0, MASK_XF_TYPE_PROT_STYLE_XF, XF_ROTATION_HORIZONTAL, []); + // XF5 + WriteXF(AStream, 0, 0, MASK_XF_TYPE_PROT_STYLE_XF, XF_ROTATION_HORIZONTAL, []); + // XF6 + WriteXF(AStream, 0, 0, MASK_XF_TYPE_PROT_STYLE_XF, XF_ROTATION_HORIZONTAL, []); + // XF7 + WriteXF(AStream, 0, 0, MASK_XF_TYPE_PROT_STYLE_XF, XF_ROTATION_HORIZONTAL, []); + // XF8 + WriteXF(AStream, 0, 0, MASK_XF_TYPE_PROT_STYLE_XF, XF_ROTATION_HORIZONTAL, []); + // XF9 + WriteXF(AStream, 0, 0, MASK_XF_TYPE_PROT_STYLE_XF, XF_ROTATION_HORIZONTAL, []); + // XF10 + WriteXF(AStream, 0, 0, MASK_XF_TYPE_PROT_STYLE_XF, XF_ROTATION_HORIZONTAL, []); + // XF11 + WriteXF(AStream, 0, 0, MASK_XF_TYPE_PROT_STYLE_XF, XF_ROTATION_HORIZONTAL, []); + // XF12 + WriteXF(AStream, 0, 0, MASK_XF_TYPE_PROT_STYLE_XF, XF_ROTATION_HORIZONTAL, []); + // XF13 + WriteXF(AStream, 0, 0, MASK_XF_TYPE_PROT_STYLE_XF, XF_ROTATION_HORIZONTAL, []); + // XF14 + WriteXF(AStream, 0, 0, MASK_XF_TYPE_PROT_STYLE_XF, XF_ROTATION_HORIZONTAL, []); + // XF15 - Default, no formatting + WriteXF(AStream, 0, 0, 0, XF_ROTATION_HORIZONTAL, []); + + // Add all further non-standard/built-in formatting styles + ListAllFormattingStyles(AData); + WriteXFFieldsForFormattingStyles(AStream); +end; + + { TsSpreadBIFF8Reader } function TsSpreadBIFF8Reader.DecodeRKValue(const ARK: DWORD): Double; @@ -1933,6 +1939,9 @@ var RecordType: Word; CurStreamPos: Int64; begin + // Clear existing fonts. They will be replaced by those from the file. + FWorkbook.RemoveAllFonts; + if Assigned(FSharedStringTable) then FreeAndNil(FSharedStringTable); while (not SectionEOF) do begin @@ -2130,6 +2139,10 @@ begin if Assigned(lCell) then begin XFData := TXFRecordData(FXFList.Items[XFIndex]); + // Font + Include(lCell^.UsedFormattingFields, uffFont); + lCell^.FontIndex := XFData.FontIndex; + // Alignment lCell^.HorAlignment := XFData.HorAlignment; lCell^.VertAlignment := XFData.VertAlignment; @@ -2305,17 +2318,7 @@ var WideStrValue: WideString; AnsiStrValue: AnsiString; begin -(* -{ BIFF Record data } - ARow := WordLEToN(AStream.ReadWord); - ACol := WordLEToN(AStream.ReadWord); - - { Index to XF record, not used } - AStream.ReadWord(); -*) - { BIFF Record header } - { BIFF Record data } - { Index to XF Record } + { BIFF Record data: Row, Column, XF Index } ReadRowColXF(AStream,ARow,ACol,XF); { Byte String with 16-bit size } @@ -2491,6 +2494,9 @@ begin lData := TXFRecordData.Create; + // Font index + lData.FontIndex := WordLEToN(xf.FontIndex); + // Format index lData.FormatIndex := WordLEToN(xf.FormatIndex); @@ -2573,26 +2579,39 @@ var lCodePage: Word; lHeight: Word; lOptions: Word; + lColor: Word; + lWeight: Word; Len: Byte; lFontName: UTF8String; + font: TsFont; begin + font := TsFont.Create; + { Height of the font in twips = 1/20 of a point } - lHeight := AStream.ReadWord(); // WordToLE(200) + lHeight := WordLEToN(AStream.ReadWord); // WordToLE(200) + font.Size := lHeight/20; { Option flags } - lOptions := AStream.ReadWord(); + 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); { Colour index } - AStream.ReadWord(); + lColor := WordLEToN(AStream.ReadWord); + font.Color := TsColor(lColor - 8); // Palette colors have an offset 8 { Font weight } - AStream.ReadWord(); + lWeight := WordLEToN(AStream.ReadWord); + if lWeight = 700 then Include(font.Style, fssBold); { Escapement type } AStream.ReadWord(); { Underline type } - AStream.ReadByte(); + if AStream.ReadByte > 0 then Include(font.Style, fssUnderline); { Font family } AStream.ReadByte(); @@ -2608,7 +2627,10 @@ begin { Font name: Unicodestring, char count in 1 byte } Len := AStream.ReadByte(); - lFontName := ReadString(AStream, Len); + font.FontName := ReadString(AStream, Len); + + { Add font to workbook's font list } + FWorkbook.AddFont(font); end; procedure TsSpreadBiff8Reader.ReadColInfo(const AStream: TStream); diff --git a/components/fpspreadsheet/xlscommon.pas b/components/fpspreadsheet/xlscommon.pas index 80b7dd4a6..6b86022fc 100644 --- a/components/fpspreadsheet/xlscommon.pas +++ b/components/fpspreadsheet/xlscommon.pas @@ -16,6 +16,7 @@ uses const { RECORD IDs which didn't change across versions 2-8 } + INT_EXCEL_ID_FONT = $0031; INT_EXCEL_ID_CODEPAGE = $0042; INT_EXCEL_ID_DATEMODE = $0022;