fpspreadsheet: Extend TsFont for sub-/superscripts. Initial implementation of "rich-text" cell format: display in WorksheetGrid and SpreadsheetInspector, read from xlsx, extend TsWorksheet.WriteUTF8Text() for rich-text formatting runs.

git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@4203 8e941d3f-bd1b-0410-a28a-d453659cc2b4

components/fpspreadsheet/fpsactions.pas

@@ -1525,7 +1525,7 @@ var
   sfnt: TsFont;
 begin
   sfnt := TsFont.Create;
-  Convert_Font_to_sFont(Workbook, GetDialog.Font, sfnt);
+  Convert_Font_to_sFont(GetDialog.Font, sfnt);
   Worksheet.WriteFont(ACell, Workbook.AddFont(sfnt));
 end;
 
@@ -1550,7 +1550,7 @@ begin
       else
         sfnt := Workbook.GetDefaultFont;
     end;
-    Convert_sFont_to_Font(Workbook, sfnt, fnt);
+    Convert_sFont_to_Font(sfnt, fnt);
     GetDialog.Font.Assign(fnt);
   finally
     fnt.Free;

components/fpspreadsheet/fpspreadsheet.pas

@@ -172,6 +172,7 @@ type
     function  ReadCellBorderStyle(ACell: PCell; ABorder: TsCellBorder): TsCellBorderStyle;
     function  ReadCellBorderStyles(ACell: PCell): TsCellBorderStyles;
     function  ReadCellFont(ACell: PCell): TsFont;
+    function  ReadCellFontIndex(ACell: PCell): Integer;
     function  ReadCellFormat(ACell: PCell): TsCellFormat;
     function  ReadHorAlignment(ACell: PCell): TsHorAlignment;
     procedure ReadNumFormat(ACell: PCell; out ANumFormat: TsNumberFormat;
@@ -239,7 +240,8 @@ type
       AFormula: TsRPNFormula); overload;
 
     function WriteUTF8Text(ARow, ACol: Cardinal; AText: ansistring): PCell; overload;
-    procedure WriteUTF8Text(ACell: PCell; AText: ansistring); overload;
+//    procedure WriteUTF8Text(ACell: PCell; AText: ansistring); overload;
+    procedure WriteUTF8Text(ACell: PCell; AText: String; ARichTextparams: TsRichTextParams = nil); overload;
 
     { Writing of cell attributes }
     function WriteBackground(ARow, ACol: Cardinal; AStyle: TsFillStyle;
@@ -286,9 +288,11 @@ type
     procedure WriteDecimals(ACell: PCell; ADecimals: Byte); overload;
 
     function  WriteFont(ARow, ACol: Cardinal; const AFontName: String;
-      AFontSize: Single; AFontStyle: TsFontStyles; AFontColor: TsColor): Integer; overload;
+      AFontSize: Single; AFontStyle: TsFontStyles; AFontColor: TsColor;
+      APosition: TsFontPosition = fpNormal): Integer; overload;
     function  WriteFont(ACell: PCell; const AFontName: String;
-      AFontSize: Single; AFontStyle: TsFontStyles; AFontColor: TsColor): Integer; overload;
+      AFontSize: Single; AFontStyle: TsFontStyles; AFontColor: TsColor;
+      APosition: TsFontPosition = fpNormal): Integer; overload;
     function WriteFont(ARow, ACol: Cardinal; AFontIndex: Integer): PCell; overload;
     procedure WriteFont(ACell: PCell; AFontIndex: Integer); overload;
     function WriteFontColor(ARow, ACol: Cardinal; AFontColor: TsColor): Integer; overload;
@@ -644,12 +648,12 @@ type
     function GetPointerToCellFormat(AIndex: Integer): PsCellFormat;
 
     { Font handling }
-    function AddFont(const AFontName: String; ASize: Single;
+    function AddFont(const AFontName: String; ASize: Single; AStyle: TsFontStyles;
-      AStyle: TsFontStyles; AColor: TsColor): Integer; overload;
+      AColor: TsColor; APosition: TsFontPosition = fpNormal): Integer; overload;
     function AddFont(const AFont: TsFont): Integer; overload;
     procedure DeleteFont(AFontIndex: Integer);
-    function FindFont(const AFontName: String; ASize: Single;
+    function FindFont(const AFontName: String; ASize: Single; AStyle: TsFontStyles;
-      AStyle: TsFontStyles; AColor: TsColor): Integer;
+      AColor: TsColor; APosition: TsFontPosition = fpNormal): Integer;
     function GetBuiltinFontCount: Integer;
     function GetDefaultFont: TsFont;
     function GetDefaultFontSize: Single;
@@ -660,7 +664,8 @@ type
     procedure InitFonts;
     procedure RemoveAllFonts;
     procedure ReplaceFont(AFontIndex: Integer; AFontName: String;
-      ASize: Single; AStyle: TsFontStyles; AColor: TsColor);
+      ASize: Single; AStyle: TsFontStyles; AColor: TsColor;
+      APosition: TsFontPosition = fpNormal);
     procedure SetDefaultFont(const AFontName: String; ASize: Single);
 
     { Number format handling }
@@ -2710,8 +2715,7 @@ end;
 
 {@@ ----------------------------------------------------------------------------
   Determines the font used by a specified cell. Returns the workbook's default
-  font if the cell does not exist. Considers the uffBold and uffFont formatting
+  font if the cell does not exist.
-  fields of the cell
 -------------------------------------------------------------------------------}
 function TsWorksheet.ReadCellFont(ACell: PCell): TsFont;
 var
@@ -2727,6 +2731,23 @@ begin
     Result := Workbook.GetDefaultFont;
 end;
 
+{@@ ----------------------------------------------------------------------------
+  Determines the index of the font used by a specified cell, referring to the
+  workbooks font list. Returns 0 (the default font index) if the cell does not
+  exist.
+-------------------------------------------------------------------------------}
+function TsWorksheet.ReadCellFontIndex(ACell: PCell): Integer;
+var
+  fmt: PsCellFormat;
+begin
+  Result := DEFAULT_FONTINDEX;
+  if ACell <> nil then
+  begin
+    fmt := Workbook.GetPointerToCellFormat(ACell^.FormatIndex);
+    Result := fmt^.FontIndex;
+  end;
+end;
+
 {@@ ----------------------------------------------------------------------------
   Returns the format record that is assigned to a specified cell
 -------------------------------------------------------------------------------}
@@ -3460,9 +3481,11 @@ end;
   @param  ACell     Pointer to the cell
   @param  AText     The text to be written encoded in utf-8
 -------------------------------------------------------------------------------}
-procedure TsWorksheet.WriteUTF8Text(ACell: PCell; AText: ansistring);
+procedure TsWorksheet.WriteUTF8Text(ACell: PCell; AText: String;
+  ARichTextParams: TsRichTextParams = nil);
 var
   r, c: Cardinal;
+  i: Integer;
   hyperlink: TsHyperlink;
 begin
   if ACell = nil then
@@ -3499,6 +3522,12 @@ begin
   ACell^.ContentType := cctUTF8String;
   ACell^.UTF8StringValue := AText;
 
+  if Length(ARichTextParams) > 0 then begin
+    SetLength(ACell^.RichTextParams, Length(ARichTextParams));
+    for i:=0 to High(ARichTextParams) do
+      ACell^.RichTextParams[i] := ARichTextParams[i];
+  end;
+
   ChangedCell(ACell^.Row, ACell^.Col);
 end;
 
@@ -4558,12 +4587,16 @@ end;
   @param  AFontSize   Size of the font, in points
   @param  AFontStyle  Set with font style attributes
                       (don't use those of unit "graphics" !)
+  @param  AFontColor  RGB value of the font's color
+  @param  APosition   Specifies sub- or superscript text
   @return Index of the font in the workbook's font list.
 -------------------------------------------------------------------------------}
 function TsWorksheet.WriteFont(ARow, ACol: Cardinal; const AFontName: String;
-  AFontSize: Single; AFontStyle: TsFontStyles; AFontColor: TsColor): Integer;
+  AFontSize: Single; AFontStyle: TsFontStyles; AFontColor: TsColor;
+  APosition: TsFontPosition = fpNormal): Integer;
 begin
-  Result := WriteFont(GetCell(ARow, ACol), AFontName, AFontSize, AFontStyle, AFontColor);
+  Result := WriteFont(GetCell(ARow, ACol), AFontName, AFontSize, AFontStyle,
+    AFontColor, APosition);
 end;
 
 {@@ ----------------------------------------------------------------------------
@@ -4576,10 +4609,13 @@ end;
   @param  AFontSize   Size of the font, in points
   @param  AFontStyle  Set with font style attributes
                       (don't use those of unit "graphics" !)
+  @param  AFontColor  RGB value of the font's color
+  @param  APosition   Specified subscript or superscript text.
   @return Index of the font in the workbook's font list.
 -------------------------------------------------------------------------------}
 function TsWorksheet.WriteFont(ACell: PCell; const AFontName: String;
-  AFontSize: Single; AFontStyle: TsFontStyles; AFontColor: TsColor): Integer;
+  AFontSize: Single; AFontStyle: TsFontStyles; AFontColor: TsColor;
+  APosition: TsFontPosition = fpNormal): Integer;
 var
   fmt: TsCellFormat;
 begin
@@ -4589,9 +4625,9 @@ begin
     Exit;
   end;
 
-  Result := FWorkbook.FindFont(AFontName, AFontSize, AFontStyle, AFontColor);
+  Result := FWorkbook.FindFont(AFontName, AFontSize, AFontStyle, AFontColor, APosition);
   if Result = -1 then
-    result := FWorkbook.AddFont(AFontName, AFontSize, AFontStyle, AFontColor);
+    result := FWorkbook.AddFont(AFontName, AFontSize, AFontStyle, AFontColor, APosition);
 
   fmt := Workbook.GetCellFormat(ACell^.FormatIndex);
   Include(fmt.UsedFormattingFields, uffFont);
@@ -7036,10 +7072,12 @@ end;
   @param ASize      Size of the font in points
   @param AStyle     Style of the font, a combination of TsFontStyle elements
   @param AColor     RGB valoe of the font color
+  @param APosition  Specifies subscript or superscript text.
   @return           Index of the font in the workbook's font list
 -------------------------------------------------------------------------------}
 function TsWorkbook.AddFont(const AFontName: String; ASize: Single;
-  AStyle: TsFontStyles; AColor: TsColor): Integer;
+  AStyle: TsFontStyles; AColor: TsColor;
+  APosition: TsFontPosition = fpNormal): Integer;
 var
   fnt: TsFont;
 begin
@@ -7048,6 +7086,7 @@ begin
   fnt.Size := ASize;
   fnt.Style := AStyle;
   fnt.Color := AColor;
+  fnt.Position := APosition;
   Result := AddFont(fnt);
 end;
 
@@ -7088,10 +7127,11 @@ end;
   @param ASize      Size of the font in points
   @param AStyle     Style of the font, a combination of TsFontStyle elements
   @param AColor     RGB value of the font color
+  @param APosition  Specified subscript or superscript text.
   @return           Index of the font in the font list, or -1 if not found.
 -------------------------------------------------------------------------------}
 function TsWorkbook.FindFont(const AFontName: String; ASize: Single;
-  AStyle: TsFontStyles; AColor: TsColor): Integer;
+  AStyle: TsFontStyles; AColor: TsColor; APosition: TsFontPosition = fpNormal): Integer;
 const
   EPS = 1e-3;
 var
@@ -7104,7 +7144,8 @@ begin
        SameText(AFontName, fnt.FontName) and
        SameValue(ASize, fnt.Size, EPS) and   // careful when comparing floating point numbers
       (AStyle = fnt.Style) and
-      (AColor = fnt.Color)
+      (AColor = fnt.Color) and
+      (APosition = fnt.Position)
     then
       exit;
   end;
@@ -7164,17 +7205,19 @@ end;
   Replaces the built-in font at a specific index with different font parameters
 -------------------------------------------------------------------------------}
 procedure TsWorkbook.ReplaceFont(AFontIndex: Integer; AFontName: String;
-  ASize: Single; AStyle: TsFontStyles; AColor: TsColor);
+  ASize: Single; AStyle: TsFontStyles; AColor: TsColor;
+  APosition: TsFontPosition = fpNormal);
 var
   fnt: TsFont;
 begin
-  if (AFontIndex < FBuiltinFontCount) and (AFontIndex <> 4) then
+  if (AFontIndex < FBuiltinFontCount) then //and (AFontIndex <> 4) then
   begin
     fnt := TsFont(FFontList[AFontIndex]);
     fnt.FontName := AFontName;
     fnt.Size := ASize;
     fnt.Style := AStyle;
     fnt.Color := AColor;
+    fnt.Position := APosition;
   end;
 end;
 
@@ -7255,6 +7298,8 @@ begin
     if (fssItalic in fnt.Style) then Result := Result + '; italic';
     if (fssUnderline in fnt.Style) then Result := Result + '; underline';
     if (fssStrikeout in fnt.Style) then result := Result + '; strikeout';
+    if fnt.Position = fpSubscript then Result := Result + '; subscript';
+    if fnt.Position = fpSuperscript then Result := Result + '; superscript';
   end else
     Result := '';
 end;

components/fpspreadsheet/fpspreadsheetctrls.pas

@@ -2675,6 +2675,7 @@ var
   r1, r2, c1, c2: Cardinal;
   fmt: TsCellFormat;
   numFmt: TsNumFormatParams;
+  rtp: TsRichTextParam;
 begin
   if (ACell <> nil) then
     fmt := Workbook.GetCellFormat(ACell^.FormatIndex)
@@ -2692,6 +2693,17 @@ begin
            Workbook.GetFontAsString(fmt.FontIndex)
          ]));
 
+  if (ACell <> nil) and (Length(ACell^.RichTextParams) > 0) then
+  begin
+    s := '';
+    for rtp in ACell^.RichTextParams do
+      s := Format('%s; Font #%d @ %d-%d', [s, rtp.FontIndex, rtp.StartIndex, rtp.EndIndex]);
+    Delete(s, 1, 2);
+    if s = '' then s := '(none)';
+    AStrings.Add('Rich-text parameters='+s);
+  end else
+    AStrings.Add('Rich-text parameters=(none)');
+
   if (ACell=nil) or not (uffTextRotation in fmt.UsedFormattingFields)
     then AStrings.Add('TextRotation=(default)')
     else AStrings.Add(Format('TextRotation=%s', [

components/fpspreadsheet/fpspreadsheetgrid.pas

@@ -168,10 +168,16 @@ type
     function GetEditText(ACol, ARow: Integer): String; override;
     function HasBorder(ACell: PCell; ABorder: TsCellBorder): Boolean;
     procedure HeaderSized(IsColumn: Boolean; AIndex: Integer); override;
+    procedure InternalDrawTextInCell(AText: String; ARect: TRect;
+      ACellHorAlign: TsHorAlignment; ACellVertAlign: TsVertAlignment;
+      ATextRot: TsTextRotation; ATextWrap: Boolean; AFontIndex: Integer;
+      ARichTextParams: TsRichTextParams);
+    {
     procedure InternalDrawTextInCell(AText, AMeasureText: String; ARect: TRect;
       AJustification: Byte; ACellHorAlign: TsHorAlignment;
       ACellVertAlign: TsVertAlignment; ATextRot: TsTextRotation;
-      ATextWrap, ReplaceTooLong: Boolean);
+      ATextWrap, ReplaceTooLong: Boolean; ARichTextParams: TsRichTextParams);
+      }
     procedure KeyDown(var Key : Word; Shift : TShiftState); override;
     procedure Loaded; override;
     procedure LoadFromWorksheet(AWorksheet: TsWorksheet);
@@ -1164,7 +1170,7 @@ end;
 -------------------------------------------------------------------------------}
 procedure TsCustomWorksheetGrid.Convert_sFont_to_Font(sFont: TsFont; AFont: TFont);
 begin
-  fpsVisualUtils.Convert_sFont_to_Font(Workbook, sFont, AFont);
+  fpsVisualUtils.Convert_sFont_to_Font(sFont, AFont);
 end;
 
 {@@ ----------------------------------------------------------------------------
@@ -1176,7 +1182,7 @@ end;
 procedure TsCustomWorksheetGrid.Convert_Font_to_sFont(AFont: TFont;
   sFont: TsFont);
 begin
-  fpsVisualUtils.Convert_Font_to_sFont(Workbook, AFont, sFont);
+  fpsVisualUtils.Convert_Font_to_sFont(AFont, sFont);
 end;
 
 {@@ ----------------------------------------------------------------------------
@@ -2081,6 +2087,7 @@ var
   horAlign: TsHorAlignment;
   vertAlign: TsVertAlignment;
   txtRot: TsTextRotation;
+  fntIndex: Integer;
   lCell: PCell;
   justif: Byte;
   fmt: PsCellFormat;
@@ -2110,10 +2117,29 @@ begin
   // Cells
   fmt := Workbook.GetPointerToCellFormat(lCell^.FormatIndex);
   wrapped := (uffWordWrap in fmt^.UsedFormattingFields) or (fmt^.TextRotation = rtStacked);
-  txtRot := fmt^.TextRotation;
+  if (uffTextRotation in fmt^.UsedFormattingFields)
-  vertAlign := fmt^.VertAlignment;
+    then txtRot := fmt^.TextRotation
-  if vertAlign = vaDefault then vertAlign := vaBottom;
+    else txtRot := trHorizontal;
-  if fmt^.HorAlignment <> haDefault then
+  if (uffVertAlign in fmt^.UsedFormattingFields)
+    then vertAlign := fmt^.VertAlignment
+    else vertAlign := vaDefault;
+  if vertAlign = vaDefault then
+    vertAlign := vaBottom;
+  if (uffHorAlign in fmt^.UsedFormattingFields)
+    then horAlign := fmt^.HorAlignment
+    else horAlign := haDefault;
+  if (horAlign = haDefault) then
+  begin
+    if (lCell^.ContentType in [cctNumber, cctDateTime]) then
+      horAlign := haRight
+    else
+    if (lCell^.ContentType in [cctBool]) then
+      horAlign := haCenter
+    else
+      horAlign := haLeft;
+  end;
+        {
+  fmt^.HorAlignment <> haDefault then
     horAlign := fmt^.HorAlignment
   else
   begin
@@ -2121,11 +2147,14 @@ begin
       horAlign := haRight
     else
       horAlign := haLeft;
-  end;
+  end;   }
+
+  if (uffFont in fmt^.UsedFormattingFields)
+    then fntIndex := fmt^.FontIndex
+    else fntIndex := DEFAULT_FONTINDEX;
 
   InflateRect(ARect, -constCellPadding, -constCellPadding);
 
-//  txt := GetCellText(ACol, ARow);
   txt := GetCellText(GetGridRow(lCell^.Col), GetGridCol(lCell^.Row));
   if txt = '' then
     exit;
@@ -2151,8 +2180,12 @@ begin
         vaBottom: justif := 0;
       end;
   end;
+  InternalDrawTextInCell(txt, ARect, horAlign, vertAlign, txtRot, wrapped,
+    fntIndex, lCell^.RichTextParams);
+{
   InternalDrawTextInCell(txt, txt, ARect, justif, horAlign, vertAlign,
-    txtRot, wrapped, false);
+    txtRot, wrapped, false, lCell^.RichTextParams);
+    }
 end;
 
 {@@ ----------------------------------------------------------------------------
@@ -3084,18 +3117,34 @@ end;
   @param ACellVertAlign   Is the VertAlignment property stored in the cell
   @param ATextRot         Determines the rotation angle of the text.
   @param ATextWrap        Determines if the text can wrap into multiple lines
-  @param ReplaceTooLang   If true too-long texts are replaced by a series of
+  @param AFontIndex       Font index to be used for drawing non-rich-text.
-                          # chars filling the cell.
+  @param ARichTextParams  an array of character and font index combinations for
+                          rich-text formatting of text in cell
 
   @Note The reason to separate AJustification from ACellHorAlign and ACelVertAlign is
   the output of nfAccounting formatted numbers where the numbers are always
   right-aligned, and the currency symbol is left-aligned.
   THIS FEATURE IS CURRENTLY NO LONGER SUPPORTED.
 -------------------------------------------------------------------------------}
+procedure TsCustomWorksheetGrid.InternalDrawTextInCell(AText: String;
+  ARect: TRect; ACellHorAlign: TsHorAlignment; ACellVertAlign: TsVertAlignment;
+  ATextRot: TsTextRotation; ATextWrap: Boolean; AFontIndex: Integer;
+  ARichTextParams: TsRichTextParams);
+begin
+  // Since - due to the rich-text mode - characters are drawn individually their
+  // background occasionally overpaints the prev characters (italic). To avoid
+  // this we do not paint the character background - it is not needed anyway.
+  Canvas.Brush.Style := bsClear;
+
+  // Work horse for text drawing, both standard text and rich-text
+  DrawRichText(Canvas, Workbook, ARect, AText, AFontIndex, ARichTextParams,
+    ATextWrap, ACellHorAlign, ACellVertAlign, ATextRot);
+end;
+(*
 procedure TsCustomWorksheetGrid.InternalDrawTextInCell(AText, AMeasureText: String;
   ARect: TRect; AJustification: Byte; ACellHorAlign: TsHorAlignment;
   ACellVertAlign: TsVertAlignment; ATextRot: TsTextRotation;
-  ATextWrap, ReplaceTooLong: Boolean);
+  ATextWrap, ReplaceTooLong: Boolean; ARichTextParams: TsRichTextParams);
 var
   ts: TTextStyle;
   flags: Cardinal;
@@ -3281,7 +3330,7 @@ begin
     end;
   end;
 end;
-
+  *)
 {@@ ----------------------------------------------------------------------------
   Standard key handling method inherited from TCustomGrid. Is overridden to
   catch the ESC key during editing in order to restore the old cell text

components/fpspreadsheet/fpstypes.pas

@@ -403,6 +403,9 @@ type
   {@@ Set of font styles }
   TsFontStyles = set of TsFontStyle;
 
+  {@@ Font position (subscript or superscript) }
+  TsFontPosition = (fpNormal, fpSubscript, fpSuperscript);
+
   {@@ Font record used in fpspreadsheet. Contains the font name, the font size
       (in points), the font style, and the font color. }
   TsFont = class
@@ -414,8 +417,20 @@ type
     Style: TsFontStyles;
     {@@ Text color given as rgb value }
     Color: TsColor;
+    {@@ Text position }
+    Position: TsFontPosition;
   end;
 
+  {@@ Parameter describing formatting of an text range in cell text }
+  TsRichTextParam = record
+    FontIndex: Integer;
+    StartIndex: Integer;  // zero-based
+    EndIndex: Integer;    // zero-based, next character!
+  end;
+
+  {@@ Parameters describing formatting of text ranges in cell text }
+  TsRichTextParams = array of TsRichTextParam;
+
   {@@ Indicates the border for a cell. If included in the CellBorders set the
       corresponding border is drawn in the style defined by the CellBorderStyle. }
   TsCellBorder = (cbNorth, cbWest, cbEast, cbSouth, cbDiagUp, cbDiagDown);
@@ -583,7 +598,8 @@ type
     { Index of format record in the workbook's FCellFormatList }
     FormatIndex: Integer;
     { Cell content }
-    UTF8StringValue: String;   // Strings cannot be part of a variant record
+    UTF8StringValue: String;     // Strings cannot be part of a variant record
+    RichTextParams: TsRichTextParams;  // Formatting of individual text ranges
     FormulaValue: String;
     case ContentType: TCellContentType of  // variant part must be at the end
       cctEmpty      : ();      // has no data at all

components/fpspreadsheet/fpsvisualutils.pas

@@ -16,11 +16,23 @@ procedure Convert_Font_to_sFont(AWorkbook: TsWorkbook; AFont: TFont; sFont: TsFo
 
 function WrapText(ACanvas: TCanvas; const AText: string; AMaxWidth: integer): string;
 
+procedure DrawRichText(ACanvas: TCanvas; AWorkbook: TsWorkbook; const ARect: TRect;
+  const AText: String; AFontIndex: Integer; ARichTextParams: TsRichTextParams;
+  AWordwrap: Boolean; AHorAlignment: TsHorAlignment; AVertAlignment: TsVertAlignment;
+  ARotation: TsTextRotation);
+
+function RichTextWidth(ACanvas: TCanvas; AWorkbook: TsWorkbook; const AText: String;
+  AFontIndex: Integer; ARichTextParams: TsRichTextParams): Integer;
+
 
 implementation
 
 uses
-  Types, LCLType, LCLIntf, fpsUtils;
+  Types, Math, LCLType, LCLIntf, LazUTF8, fpsUtils;
+
+const
+{@@ Font size factor for sub-/superscript characters }
+  SUBSCRIPT_SUPERSCRIPT_FACTOR = 0.6;
 
 {@@ ----------------------------------------------------------------------------
   Converts a spreadsheet font to a font used for painting (TCanvas.Font).
@@ -151,4 +163,444 @@ begin
   end;
 end;
 
+procedure DrawRichText(ACanvas: TCanvas; AWorkbook: TsWorkbook; const ARect: TRect;
+  const AText: String; AFontIndex: Integer; ARichTextParams: TsRichTextParams;
+  AWordwrap: Boolean; AHorAlignment: TsHorAlignment; AVertAlignment: TsVertAlignment;
+  ARotation: TsTextRotation);
+type
+  TLineInfo = record
+    pStart, pEnd: PChar;
+    NumSpaces: Integer;
+    FirstRtpIndex: Integer;
+    NextRtpIndex: Integer;
+    Width: Integer;
+    Height: Integer;
+  end;
+  TRtState = (rtEnter, rtExit);
+var
+  xpos, ypos: Integer;
+  p, pStartText: PChar;
+  iRtp: Integer;
+  lineInfo: TLineInfo;
+  lineInfos: Array of TLineInfo = nil;
+  totalHeight, stackPeriod: Integer;
+
+  procedure InitFont(P: PChar; out rtState: TRtState;
+    PendingRtpIndex: Integer; out AHeight: Integer);
+  var
+    fnt: TsFont;
+    hasRtp: Boolean;
+    rtp: TsRichTextParam;
+  begin
+    fnt := AWorkbook.GetFont(AFontIndex);
+    hasRtp := PendingRtpIndex >= 0;
+    if hasRTP and (PendingRtpIndex < Length(ARichTextParams)) then begin
+      rtp := ARichTextParams[PendingRtpIndex];
+      if p - pStartText >= rtp.StartIndex then
+      begin
+        fnt := AWorkbook.GetFont(rtp.FontIndex);
+        rtState := rtEnter;
+      end else
+        rtState := rtExit;
+    end;
+    Convert_sFont_to_Font(fnt, ACanvas.Font);
+    AHeight := ACanvas.TextHeight('Tg');
+    if (fnt <> nil) and (fnt.Position <> fpNormal) then
+      ACanvas.Font.Size := round(ACanvas.Font.Size * SUBSCRIPT_SUPERSCRIPT_FACTOR);
+  end;
+
+  procedure UpdateFont(P:PChar; var rtState: TRtState;
+    var PendingRtpIndex: Integer; var AHeight: Integer;
+    out AFontPos: TsFontPosition);
+  var
+    hasRtp: Boolean;
+    rtp: TsRichTextParam;
+    fnt: TsFont;
+  begin
+    fnt := AWorkbook.GetFont(AFontIndex);
+    hasRtp := PendingRtpIndex >= 0;
+    if hasRtp and (PendingRtpIndex < Length(ARichTextParams)) then
+    begin
+      rtp := ARichTextParams[PendingRtpIndex];
+      if (p - pStartText >= rtp.StartIndex) and (rtState = rtExit) then
+      begin
+        fnt := AWorkbook.GetFont(rtp.FontIndex);
+        Convert_sFont_to_Font(fnt, ACanvas.Font);
+        AHeight := ACanvas.TextHeight('Tg');
+        if fnt.Position <> fpNormal then
+          ACanvas.Font.Size := round(ACanvas.Font.Size * SUBSCRIPT_SUPERSCRIPT_FACTOR);
+        rtState := rtEnter;
+      end else
+      if (p - pStartText >= rtp.EndIndex) and (rtState = rtEnter) then
+      begin
+        inc(PendingRtpIndex);
+        if PendingRtpIndex = Length(ARichTextparams) then
+        begin
+          fnt := AWorkbook.GetFont(AFontIndex);
+          rtState := rtExit;
+        end else
+        begin
+          rtp := ARichTextParams[PendingRtpIndex];
+          if (p - pStartText < rtp.StartIndex) then
+          begin
+            fnt := AWorkbook.GetFont(AFontIndex);
+            rtState := rtExit;
+          end else
+          begin
+            fnt := AWorkbook.GetFont(rtp.FontIndex);
+            rtState := rtEnter;
+          end;
+        end;
+        Convert_sFont_to_Font(fnt, ACanvas.Font);
+        AHeight := ACanvas.TextHeight('Tg');
+        if fnt.Position <> fpNormal then
+          ACanvas.Font.Size := round(ACanvas.Font.Size * SUBSCRIPT_SUPERSCRIPT_FACTOR);
+      end;
+    end;
+    AFontPos := fnt.Position;
+  end;
+
+  procedure ScanLine(var P: PChar; var NumSpaces: Integer;
+    var PendingRtpIndex: Integer; var width, height: Integer);
+  var
+    ch: Char;
+    pEOL: PChar;
+    savedSpaces: Integer;
+    savedWidth: Integer;
+    savedRtpIndex: Integer;
+    maxWidth: Integer;
+    rtState: TRtState;
+    dw, h: Integer;
+    fntpos: TsFontPosition;
+    spaceFound: Boolean;
+  begin
+    NumSpaces := 0;
+
+    InitFont(p, rtState, PendingRtpIndex, h);
+    height := h;
+
+    pEOL := p;
+    width := 0;
+    savedWidth := 0;
+    savedSpaces := 0;
+    savedRtpIndex := PendingRtpIndex;
+    spaceFound := false;
+    if AWordwrap then
+    begin
+      if ARotation = trHorizontal then
+        maxWidth := ARect.Right - ARect.Left
+      else
+        maxWidth := ARect.Bottom - ARect.Top;
+    end
+    else
+      maxWidth := MaxInt;
+
+    while p^ <> #0 do begin
+      UpdateFont(p, rtState, PendingRtpIndex, h, fntpos);
+      if h > height then height := h;
+
+      ch := p^;
+      case ch of
+        ' ': begin
+               spaceFound := true;
+               pEOL := p;
+               savedWidth := width;
+               savedSpaces := NumSpaces;
+               savedRtpIndex := PendingRtpIndex;
+               dw := Math.IfThen(ARotation = rtStacked, h, ACanvas.TextWidth(ch));
+               if width + dw < MaxWidth then
+               begin
+                 inc(NumSpaces);
+                 width := width + dw;
+               end else
+                 break;
+             end;
+        #13,
+        #10: begin
+               dec(p);
+               width := savedWidth;
+               numSpaces := savedspaces;
+               PendingRtpIndex := savedRtpIndex;
+               exit;
+             end;
+        else begin
+               dw := Math.IfThen(ARotation = rtStacked, h, ACanvas.TextWidth(ch));
+               width := width + dw;
+               if width > maxWidth then
+               begin
+                 if spaceFound then
+                 begin
+                   p := pEOL;
+                   width := savedWidth;
+                   NumSpaces := savedSpaces;
+                   PendingRtpIndex := savedRtpIndex;
+                 end else
+                 begin
+                   width := width - dw;
+                   if width = 0 then
+                     inc(p);
+                 end;
+                 break;
+               end;
+             end;
+      end;
+
+      inc(P, UTF8CharacterLength(p));
+    end;
+  end;
+
+  procedure DrawLine(pStart, pEnd: PChar; x,y, hLine: Integer; PendingRtpIndex: Integer);
+  var
+    ch: Char;
+    p: PChar;
+    rtState: TRtState;
+    h, w: Integer;
+    fntpos: TsFontPosition;
+  begin
+    p := pStart;
+    InitFont(p, rtState, PendingRtpIndex, h);
+    while p^ <> #0 do begin
+      UpdateFont(p, rtState, PendingRtpIndex, h, fntpos);
+      ch := p^;
+      case ARotation of
+        trHorizontal:
+          begin
+            ACanvas.Font.Orientation := 0;
+            case fntpos of
+              fpNormal     : ACanvas.TextOut(x, y, ch);
+              fpSubscript  : ACanvas.TextOut(x, y + hLine div 2, ch);
+              fpSuperscript: ACanvas.TextOut(x, y - hLine div 6, ch);
+            end;
+            inc(x, ACanvas.TextWidth(ch));
+          end;
+        rt90DegreeClockwiseRotation:
+          begin
+            ACanvas.Font.Orientation := -900;
+            case fntpos of
+              fpNormal     : ACanvas.TextOut(x, y, ch);
+              fpSubscript  : ACanvas.TextOut(x - hLine div 2, y, ch);
+              fpSuperscript: ACanvas.TextOut(x + hLine div 6, y, ch);
+            end;
+            inc(y, ACanvas.TextWidth(ch));
+          end;
+        rt90DegreeCounterClockwiseRotation:
+          begin
+            ACanvas.Font.Orientation := +900;
+            case fntpos of
+              fpNormal     : ACanvas.TextOut(x, y, ch);
+              fpSubscript  : ACanvas.TextOut(x + hLine div 2, y, ch);
+              fpSuperscript: ACanvas.TextOut(x - hLine div 6, y, ch);
+            end;
+            dec(y, ACanvas.TextWidth(ch));
+          end;
+        rtStacked:
+          begin
+            ACanvas.Font.Orientation := 0;
+            w := ACanvas.TextWidth(ch);
+            // chars centered around x
+            case fntpos of
+              fpNormal     : ACanvas.TextOut(x - w div 2, y, ch);
+              fpSubscript  : ACanvas.TextOut(x - w div 2, y + hLine div 2, ch);
+              fpSuperscript: ACanvas.TextOut(x - w div 2, y - hLine div 6, ch);
+            end;
+            inc(y, h);
+          end;
+      end;
+
+      inc(P, UTF8CharacterLength(p));
+      if P >= PEnd then break;
+    end;
+  end;
+
+begin
+  if AText = '' then
+    exit;
+
+  p := PChar(AText);
+  pStartText := p;   // first char of text
+
+  if (Length(ARichTextParams) > 0) then
+    iRTP := 0
+  else
+    iRtp := -1;
+  totalHeight := 0;
+
+  if ARotation = rtStacked then
+  begin
+    Convert_sFont_to_Font(AWorkbook.GetFont(AFontIndex), ACanvas.Font);
+    stackPeriod := ACanvas.TextWidth('M') * 2;
+  end;
+
+  // Get layout of lines:
+  // "lineinfos" collect data on where lines start and end, their width and
+  // height, the rich-text parameter index range, and the number of spaces
+  // (for text justification)
+  repeat
+    SetLength(lineInfos, Length(lineInfos)+1);
+    with lineInfos[High(lineInfos)] do begin
+      pStart := p;
+      pEnd := p;
+      FirstRtpIndex := iRtp;
+      NextRtpIndex := iRtp;
+      ScanLine(pEnd, NumSpaces, NextRtpIndex, Width, Height);
+      if ARotation = rtStacked then
+        totalHeight := totalHeight + stackPeriod
+      else
+        totalHeight := totalHeight + Height;
+      iRtp := NextRtpIndex;
+      p := pEnd;
+      case p^ of
+        ' ': while (p^ <> #0) and (p^ = ' ') do inc(p);
+        #13: begin
+               inc(p);
+               if p^ = #10 then inc(p);
+             end;
+        #10: inc(p);
+      end;
+    end;
+  until p^ = #0;
+
+  // Draw lines
+  case ARotation of
+    trHorizontal:
+      case AVertAlignment of
+        vaTop   : ypos := ARect.Top;
+        vaBottom: ypos := ARect.Bottom - totalHeight;
+        vaCenter: ypos := (ARect.Top + ARect.Bottom - totalHeight) div 2;
+      end;
+    rt90DegreeClockwiseRotation:
+      case AHorAlignment of
+        haLeft  : xpos := ARect.Left + totalHeight;
+        haRight : xpos := ARect.Right;
+        haCenter: xpos := (ARect.Left + ARect.Right + totalHeight) div 2;
+      end;
+    rt90DegreeCounterClockwiseRotation:
+      case AHorAlignment of
+        haLeft  : xpos := ARect.Left;
+        haRight : xpos := ARect.Right - totalHeight;
+        haCenter: xpos := (ARect.Left + ARect.Right - totalHeight) div 2;
+      end;
+    rtStacked:
+      begin
+        case AHorAlignment of
+          haLeft  : xpos := ARect.Left + stackPeriod div 2;
+          haRight : xpos := ARect.Right - totalHeight + stackPeriod div 2;
+          haCenter: xpos := (ARect.Left + ARect.Right - totalHeight) div 2;
+        end;
+      end;
+  end;
+
+  for lineInfo in lineInfos do begin
+    with lineInfo do
+    begin
+      p := pStart;
+      case ARotation of
+        trHorizontal:
+          begin
+            case AHorAlignment of
+              haLeft   : xpos := ARect.Left;
+              haRight  : xpos := ARect.Right - Width;
+              haCenter : xpos := (ARect.Left + ARect.Right - Width) div 2;
+            end;
+            DrawLine(pStart, pEnd, xpos, ypos, Height, FirstRtpIndex);
+            inc(ypos, Height);
+          end;
+        rt90DegreeClockwiseRotation:
+          begin
+            case AVertAlignment of
+              vaTop    : ypos := ARect.Top;
+              vaBottom : ypos := ARect.Bottom - Width;
+              vaCenter : ypos := (ARect.Top + ARect.Bottom - Width) div 2;
+            end;
+            DrawLine(pStart, pEnd, xpos, ypos, Height, FirstRtpIndex);
+            dec(xpos, Height);
+          end;
+        rt90DegreeCounterClockwiseRotation:
+          begin
+            case AVertAlignment of
+              vaTop    : ypos := ARect.Top + Width;
+              vaBottom : ypos := ARect.Bottom;
+              vaCenter : ypos := (ARect.Top + ARect.Bottom + Width) div 2;
+            end;
+            DrawLine(pStart, pEnd, xpos, ypos, Height, FirstRtpIndex);
+            inc(xpos, Height);
+          end;
+        rtStacked:
+          begin
+            case AVertAlignment of
+              vaTop    : ypos := ARect.Top;
+              vaBottom : ypos := ARect.Bottom - Width;
+              vaCenter : ypos := (ARect.Top + ARect.Bottom - Width) div 2;
+            end;
+            DrawLine(pStart, pEnd, xpos, ypos, Height, FirstRtpIndex);
+            inc(xpos, stackPeriod);
+          end;
+      end;
+    end;
+  end;
+end;
+
+function RichTextWidth(ACanvas: TCanvas; AWorkbook: TsWorkbook; const AText: String;
+  AFontIndex: Integer; ARichTextParams: TsRichTextParams): Integer;
+var
+  s: String;
+  p: Integer;
+  w, n: Integer;
+  rtp, next_rtp: TsRichTextParam;
+  fnt, fnt0: TsFont;
+begin
+  Result := 0;
+  if (ACanvas=nil) or (AWorkbook=nil) or (AText = '') then exit;
+
+  fnt0 := AWorkbook.GetFont(AFontIndex);
+  Convert_sFont_to_Font(fnt0, ACanvas.Font);
+
+  if Length(ARichTextParams) = 0 then
+  begin
+    Result := ACanvas.TextWidth(AText);
+    if fnt0.Position <> fpNormal then
+      Result := Round(Result * SUBSCRIPT_SUPERSCRIPT_FACTOR);
+    exit;
+  end;
+
+  // Part with normal font before first rich-text parameter element
+  rtp := ARichTextParams[0];
+  if rtp.StartIndex > 0 then begin
+    s := copy(AText, 1, rtp.StartIndex+1);  // StartIndex is 0-based
+    Result := ACanvas.TextWidth(s);
+    if fnt0.Position <> fpNormal then
+      Result := Round(Result * SUBSCRIPT_SUPERSCRIPT_FACTOR);
+  end;
+
+  p := 0;
+  while p < Length(ARichTextParams) do
+  begin
+    // Part with rich-text font
+    rtp := ARichTextParams[p];
+    fnt := AWorkbook.GetFont(rtp.FontIndex);
+    Convert_sFont_to_Font(fnt, ACanvas.Font);
+    s := copy(AText, rtp.StartIndex+1, rtp.EndIndex-rtp.StartIndex);
+    w := ACanvas.TextWidth(s);
+    if fnt.Position <> fpNormal then
+      w := Round(w * SUBSCRIPT_SUPERSCRIPT_FACTOR);
+    Result := Result + w;
+    // Part with normal font
+    if (p < High(ARichTextParams)-1) then
+    begin
+      next_rtp := ARichTextParams[p+1];
+      n := next_rtp.StartIndex - rtp.EndIndex;
+      if n > 0 then
+      begin
+        Convert_sFont_to_Font(fnt0, ACanvas.Font);
+        s := Copy(AText, rtp.EndIndex, n);
+        w := ACanvas.TextWidth(s);
+        if fnt0.Position <> fpNormal then
+          w := Round(w * SUBSCRIPT_SUPERSCRIPT_FACTOR);
+        Result := Result + w;
+      end;
+    end;
+    inc(p);
+  end;
+end;
+
 end.

components/fpspreadsheet/laz_fpspreadsheet.lpk

@@ -20,7 +20,8 @@
         <CompilerMessages>
           <IgnoredMessages idx5028="True" idx4055="True" idx2005="True"/>
         </CompilerMessages>
-        <CustomOptions Value="$(IDEBuildOptions)"/>
+        <CustomOptions Value="$(IDEBuildOptions)
+-dDisableWrapperFunctions"/>
       </Other>
     </CompilerOptions>
     <Description Value="laz_fpspreadsheet is a non-visual component that allows you to use the fpspreadsheet package to read/write spreadsheet files in .xls (BIFF/Excel), .ods OpenDocument (LibreOffice/OpenOffice) and .xlsx Open XML (Excel) formats.

components/fpspreadsheet/xlscommon.pas

@@ -1547,7 +1547,7 @@ var
 begin
   // Paper size
   w := WordLEToN(AStream.ReadWord);
-  if (w >= 0) and (w <= High(PAPER_SIZES)) then
+  if (w <= High(PAPER_SIZES)) then
   begin
     FWorksheet.PageLayout.PageWidth := PAPER_SIZES[w, 0];
     FWorksheet.PageLayout.PageHeight := PAPER_SIZES[w, 1];

components/fpspreadsheet/xlsxooxml.pas

@@ -74,7 +74,7 @@ type
     procedure ReadDateMode(ANode: TDOMNode);
     procedure ReadFileVersion(ANode: TDOMNode);
     procedure ReadFills(ANode: TDOMNode);
-    procedure ReadFont(ANode: TDOMNode);
+    function ReadFont(ANode: TDOMNode): Integer;
     procedure ReadFonts(ANode: TDOMNode);
     procedure ReadHeaderFooter(ANode: TDOMNode; AWorksheet: TsWorksheet);
     procedure ReadHyperlinks(ANode: TDOMNode);
@@ -130,6 +130,7 @@ type
     procedure WriteComments(AWorksheet: TsWorksheet);
     procedure WriteDimension(AStream: TStream; AWorksheet: TsWorksheet);
     procedure WriteFillList(AStream: TStream);
+    procedure WriteFont(AStream: TStream; AFont: TsFont; ATag: String);
     procedure WriteFontList(AStream: TStream);
     procedure WriteHeaderFooter(AStream: TStream; AWorksheet: TsWorksheet);
     procedure WriteHyperlinks(AStream: TStream; AWorksheet: TsWorksheet);
@@ -205,7 +206,7 @@ var
 implementation
 
 uses
-  variants, fileutil, strutils, math, lazutf8, uriparser,
+  variants, strutils, math, lazutf8, LazFileUtils, uriparser,
   {%H-}fpsPatches, fpsStrings, fpsStreams, fpsNumFormatParser, fpsClasses;
 
 const
@@ -339,6 +340,8 @@ begin
   for j := FHyperlinkList.Count-1 downto 0 do TObject(FHyperlinkList[j]).Free;
   FHyperlinkList.Free;
 
+  for j := FSharedStrings.Count-1 downto 0 do
+    if FSharedstrings.Objects[j] <> nil then FSharedStrings.Objects[j].Free;
   FSharedStrings.Free;
   FSharedFormulaBaseList.Free;   // Don't free items, they are worksheet cells
 
@@ -533,6 +536,10 @@ var
   number: Double;
   fmt: TsCellFormat;
   numFmt: TsNumFormatParams = nil;
+  ms: TMemoryStream;
+  n: Integer;
+  rtp: TsRichTextParam;
+  richTextParams: TsRichTextParams;
 begin
   if ANode = nil then
     exit;
@@ -626,7 +633,30 @@ begin
   if s = 's' then begin
     // String from shared strings table
     sstIndex := StrToInt(dataStr);
-    AWorksheet.WriteUTF8Text(cell, FSharedStrings[sstIndex]);
+    // Standard cell, no rich-text parameters
+    if FSharedStrings.Objects[sstIndex] = nil then
+      AWorksheet.WriteUTF8Text(cell, FSharedStrings[sstIndex])
+    else
+    begin
+      // Read rich-text parameters from the stream stored in the Objects of the stringlist
+      ms := TMemoryStream(FSharedStrings.Objects[sstIndex]);
+      ms.Position := 0;
+      n := ms.ReadWord;   // Count of array elements
+      SetLength(richTextParams, 0);
+      while (n > 0) do begin
+        ms.ReadBuffer(rtp, SizeOf(TsRichTextParam));
+        // Consider only those richtext parameters with font different from cell font
+        if rtp.FontIndex <> fmt.FontIndex then begin
+          SetLength(richTextParams, Length(richTextParams)+1);
+          richTextParams[High(richTextParams)] := rtp;
+        end;
+        dec(n);
+      end;
+      AWorksheet.WriteUTF8Text(cell,
+        FSharedStrings[sstIndex],
+        richTextParams
+      );
+    end;
   end else
   if s = 'str' then
     // literal string
@@ -1035,7 +1065,10 @@ begin
   end;
 end;
 
-procedure TsSpreadOOXMLReader.ReadFont(ANode: TDOMNode);
+{ Reads the font described by the specified node. If the node is already
+  contained in the font list the font's index is returned; otherwise the
+  new font is added to the list and its index is returned. }
+function TsSpreadOOXMLReader.ReadFont(ANode: TDOMNode): Integer;
 var
   node: TDOMNode;
   fnt: TsFont;
@@ -1043,67 +1076,106 @@ var
   fntSize: Single;
   fntStyles: TsFontStyles;
   fntColor: TsColor;
+  fntPos: TsFontPosition;
   nodename: String;
   s: String;
 begin
   fnt := Workbook.GetDefaultFont;
-  if fnt <> nil then begin
+  if fnt <> nil then
+  begin
     fntName := fnt.FontName;
     fntSize := fnt.Size;
     fntStyles := fnt.Style;
     fntColor := fnt.Color;
-  end else begin
+    fntPos := fnt.Position;
+  end else
+  begin
     fntName := DEFAULT_FONTNAME;
     fntSize := DEFAULT_FONTSIZE;
     fntStyles := [];
     fntColor := scBlack;
+    fntPos := fpNormal;
   end;
 
   node := ANode.FirstChild;
-  while node <> nil do begin
+  while node <> nil do
+  begin
     nodename := node.NodeName;
-    if nodename = 'name' then begin
+    if (nodename = 'name') or (nodename = 'rFont') then
+    begin
       s := GetAttrValue(node, 'val');
       if s <> '' then fntName := s;
     end
     else
-    if nodename = 'sz' then begin
+    if nodename = 'sz' then
+    begin
       s := GetAttrValue(node, 'val');
       if s <> '' then fntSize := StrToFloat(s);
     end
     else
-    if nodename = 'b' then begin
+    if nodename = 'b' then
+    begin
       if GetAttrValue(node, 'val') <> 'false'
         then fntStyles := fntStyles + [fssBold];
     end
     else
-    if nodename = 'i' then begin
+    if nodename = 'i' then
+    begin
       if GetAttrValue(node, 'val') <> 'false'
         then fntStyles := fntStyles + [fssItalic];
     end
     else
-    if nodename = 'u' then begin
+    if nodename = 'u' then
+    begin
       if GetAttrValue(node, 'val') <> 'false'
         then fntStyles := fntStyles+ [fssUnderline]
     end
     else
-    if nodename = 'strike' then begin
+    if nodename = 'strike' then
+    begin
       if GetAttrValue(node, 'val') <> 'false'
         then fntStyles := fntStyles + [fssStrikeout];
     end
     else
+    if nodename = 'vertAlign' then
+    begin
+      s := GetAttrValue(node, 'val');
+      if s = 'superscript' then
+        fntPos := fpSuperscript
+      else
+      if s = 'subscript' then
+        fntPos := fpSubscript
+      else
+        fntPos := fpNormal;
+    end
+    else
     if nodename = 'color' then
       fntColor := ReadColor(node);
     node := node.NextSibling;
   end;
 
+  // Check whether font is already contained in font list
+  for Result := 0 to FFontList.Count-1 do
+  begin
+    fnt := TsFont(FFontList[Result]);
+    if (fnt.FontName = fntName) and
+       (fnt.Size = fntSize) and
+       (fnt.Style = fntStyles) and
+       (fnt.Color = fntColor) and
+       (fnt.Position = fntPos)
+    then
+      exit;
+  end;
+
+  // Font not yet stored --> create a new font and store it in list
   fnt := TsFont.Create;
   fnt.FontName := fntName;
   fnt.Size := fntSize;
   fnt.Style := fntStyles;
   fnt.Color := fntColor;
+  fnt.Position := fntPos;
 
-  FFontList.Add(fnt);
+  Result := FFontList.Add(fnt);
 end;
 
 procedure TsSpreadOOXMLReader.ReadFonts(ANode: TDOMNode);
@@ -1486,11 +1558,16 @@ var
   valuenode: TDOMNode;
   childnode: TDOMNode;
   nodename: String;
-  s: String;
+  s, sval: String;
+  fntIndex, startIndex, count: Integer;
+  richTextParams: TsRichTextParams;
+  ms: TMemoryStream;
+  fnt: TsFont;
 begin
   while Assigned(ANode) do begin
     if ANode.NodeName = 'si' then begin
       s := '';
+      richTextParams := nil;
       valuenode := ANode.FirstChild;
       while valuenode <> nil do begin
         nodename := valuenode.NodeName;
@@ -1498,15 +1575,56 @@ begin
           s := GetNodeValue(valuenode)
         else
         if nodename = 'r' then begin
+          fntIndex := -1;
+          startIndex := -1;
+          count := -1;
           childnode := valuenode.FirstChild;
           while childnode <> nil do begin
-            s := s + GetNodeValue(childnode);
+            nodename := childnode.NodeName;
+            if nodename = 't' then
+            begin
+              startIndex := Length(s);
+              sval := GetNodevalue(childNode);
+              s := s + sval;
+              count := Length(sval);
+              if fntIndex <> -1 then
+              begin
+                SetLength(richTextParams, Length(richTextParams)+1);
+                richTextParams[Length(richTextParams)-1].StartIndex := startIndex;
+                richTextParams[Length(richTextParams)-1].EndIndex := startIndex + count;
+                richTextParams[Length(richTextParams)-1].FontIndex := fntIndex;
+              end;
+            end
+            else if nodename = 'rPr' then begin
+              fntIndex := ReadFont(childnode);
+              // Here we store the font in the internal font list of the reader.
+              // But this fontindex may be different from the one needed for the
+              // workbook's font list. We fix this here.
+              fnt := TsFont(FFontList[fntIndex]);
+              fntIndex := Workbook.FindFont(fnt.FontName, fnt.Size, fnt.style, fnt.Color, fnt.Position);
+              if fntIndex = -1 then
+                fntIndex := Workbook.AddFont(fnt.FontName, fnt.Size, fnt.Style, fnt.Color, fnt.Position);
+              if startIndex <> -1 then begin
+                SetLength(richTextParams, Length(richTextParams)+1);
+                richTextParams[Length(richTextParams)-1].StartIndex := startIndex;
+                richTextParams[Length(richTextParams)-1].EndIndex := startIndex + count;
+                richTextParams[Length(richTextParams)-1].FontIndex := fntIndex;
+              end;
+            end;
             childnode := childnode.NextSibling;
           end;
         end;
         valuenode := valuenode.NextSibling;
       end;
-      FSharedStrings.Add(s);
+      if Length(richTextParams) = 0 then
+        FSharedStrings.Add(s)
+      else
+      begin
+        ms := TMemoryStream.Create;
+        ms.WriteWord(Length(richTextParams));
+        ms.WriteBuffer(richTextParams[0], SizeOf(TsRichTextParam)*Length(richTextParams));
+        FSharedStrings.AddObject(s, ms);
+      end;
     end;
     ANode := ANode.NextSibling;
   end;
@@ -1732,14 +1850,6 @@ begin
       FreeAndNil(Doc);
     end;
 
-    // process the sharedstrings.xml file
-    if FileExists(FilePath + OOXML_PATH_XL_STRINGS) then begin
-      ReadXMLFile(Doc, FilePath + OOXML_PATH_XL_STRINGS);
-      DeleteFile(FilePath + OOXML_PATH_XL_STRINGS);
-      ReadSharedStrings(Doc.DocumentElement.FindNode('si'));
-      FreeAndNil(Doc);
-    end;
-
     // process the workbook.xml file
     if not FileExists(FilePath + OOXML_PATH_XL_WORKBOOK) then
       raise Exception.CreateFmt(rsDefectiveInternalStructure, ['xlsx']);
@@ -1763,6 +1873,14 @@ begin
       FreeAndNil(Doc);
     end;
 
+    // process the sharedstrings.xml file
+    if FileExists(FilePath + OOXML_PATH_XL_STRINGS) then begin
+      ReadXMLFile(Doc, FilePath + OOXML_PATH_XL_STRINGS);
+      DeleteFile(FilePath + OOXML_PATH_XL_STRINGS);
+      ReadSharedStrings(Doc.DocumentElement.FindNode('si'));
+      FreeAndNil(Doc);
+    end;
+
     // read worksheets
     for i:=0 to SheetList.Count-1 do begin
       // Create worksheet
@@ -2211,35 +2329,49 @@ begin
     '</fills>');
 end;
 
-{ Writes the fontlist of the workbook to the stream. The font id used in xf
+{ Writes font parameters to the stream.
-  records is given by the index of a font in the list. Therefore, we have
+  ATag is "font" for the entry in "styles.xml", or "rPr" for the entry for
-  to write an empty record for font #4 which is nil due to compatibility with BIFF }
+  richtext parameters in the shared string list. }
+procedure TsSpreadOOXMLWriter.WriteFont(AStream: TStream; AFont: TsFont;
+  ATag: String);
+var
+  s: String;
+begin
+  s := '';
+  s := s + Format('<sz val="%g" />', [AFont.Size], FPointSeparatorSettings);
+  s := s + Format('<name val="%s" />', [AFont.FontName]);
+  if (fssBold in AFont.Style) then
+    s := s + '<b />';
+  if (fssItalic in AFont.Style) then
+    s := s + '<i />';
+  if (fssUnderline in AFont.Style) then
+    s := s + '<u />';
+  if (fssStrikeout in AFont.Style) then
+    s := s + '<strike />';
+  if AFont.Color <> scBlack then
+    s := s + Format('<color rgb="%s" />', [Copy(ColorToHTMLColorStr(AFont.Color), 2, MaxInt)]);
+  case AFont.Position of
+    fpSubscript  : s := s + '<vertAlign val="subscript" />';
+    fpSuperscript: s := s + '<vertAlign val="superscript" />';
+  end;
+  AppendToStream(AStream, Format(
+    '<%s>%s</%s>', [ATag, s, ATag]));
+end;
+
+{ Writes the fontlist of the workbook to the stream. }
 procedure TsSpreadOOXMLWriter.WriteFontList(AStream: TStream);
 var
   i: Integer;
   font: TsFont;
-  s: String;
 begin
-  AppendToStream(FSStyles, Format(
+  AppendToStream(AStream, Format(
-      '<fonts count="%d">', [Workbook.GetFontCount]));
+    '<fonts count="%d">', [Workbook.GetFontCount]));
   for i:=0 to Workbook.GetFontCount-1 do begin
     font := Workbook.GetFont(i);
-    s := Format('<sz val="%g" /><name val="%s" />', [font.Size, font.FontName], FPointSeparatorSettings);
+    WriteFont(AStream, font, 'font');
-    if (fssBold in font.Style) then
-      s := s + '<b />';
-    if (fssItalic in font.Style) then
-      s := s + '<i />';
-    if (fssUnderline in font.Style) then
-      s := s + '<u />';
-    if (fssStrikeout in font.Style) then
-      s := s + '<strike />';
-    if font.Color <> scBlack then
-      s := s + Format('<color rgb="%s" />', [Copy(ColorToHTMLColorStr(font.Color), 2, MaxInt)]);
-    AppendToStream(AStream,
-      '<font>', s, '</font>');
   end;
   AppendToStream(AStream,
-      '</fonts>');
+    '</fonts>');
 end;
 
 procedure TsSpreadOOXMLWriter.WriteHeaderFooter(AStream: TStream;
@@ -3500,8 +3632,11 @@ begin
   CellPosText := TsWorksheet.CellPosToText(ARow, ACol);
   lStyleIndex := GetStyleIndex(ACell);
   AppendToStream(AStream, Format(
-    '<c r="%s" s="%d" t="s"><v>%d</v></c>', [CellPosText, lStyleIndex, FSharedStringsCount]));
+    '<c r="%s" s="%d" t="s">'+
-
+      '<v>%d</v>'+
+    '</c>',
+    [CellPosText, lStyleIndex, FSharedStringsCount]
+  ));
   inc(FSharedStringsCount);
 end;