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

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;

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 := MyWorksheet.GetCell(5, 3);
-  lCell^.BackgroundColor := scPURPLE;
+  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);

components/fpspreadsheet/fpspreadsheet.pas

@@ -131,8 +131,10 @@ type
 
   {@@ List of possible formatting fields }
 
-  TsUsedFormattingField = (uffTextRotation, uffBold, uffBorder, uffBackgroundColor,
+  TsUsedFormattingField = (uffTextRotation, uffFont, uffBold, uffBorder,
-    uffNumberFormat, uffWordWrap, uffHorAlign, uffVertAlign);
+    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])
+  if (integer(AIndex) < FWorksheets.Count) and (integer(AIndex)>=0) then
-  else Result := nil;
+    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;

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;

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);
+  WriteCellFormatting(AStream, ACell, xf);
-  AStream.WriteByte($0);
-  AStream.WriteByte($0);
 
   { 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);
+  WriteCellFormatting(AStream, ACell, xf);
-  AStream.WriteByte($0);
-  AStream.WriteByte($0);
 
   { 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);

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
+  // The first style was already added
-  for i := 4 to Length(FFormattingStyles) - 1 do
+  for i := 1 to Length(FFormattingStyles) - 1 do begin
-  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;
+  WriteFonts(AStream, AData);
-  try
-    FontData.Name := 'Arial';
 
-    // 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
+  // XF Records
-  WriteXF(AStream, 0, 0, MASK_XF_TYPE_PROT_STYLE_XF, XF_ROTATION_HORIZONTAL, []);
+  WriteXFRecords(AStream, AData);
-  // 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);
-
   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))
+  optn := 0;
-  else AStream.WriteWord(WordToLE(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))
+  if fssBold in AFont.Style then
-  else AStream.WriteWord(WordToLE(INT_FONT_WEIGHT_NORMAL));
+    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: Row, Column, XF Index }
-{ 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 }
   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);

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;