pascal/lazarus-ccr
1
0
Fork 0
Code Issues Releases Activity

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.

Browse Source 
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@4203 8e941d3f-bd1b-0410-a28a-d453659cc2b4
This commit is contained in:
wp_xxyyzz
2015-07-09 11:10:15 +00:00
parent f80c3a9df0
commit 9b89738158
9 changed files with 798 additions and 88 deletions
Download Patch File Download Diff File Expand all files Collapse all files

4
components/fpspreadsheet/fpsactions.pas
View File

@ -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;

87
components/fpspreadsheet/fpspreadsheet.pas
View File

@ -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;
AStyle: TsFontStyles; AColor: TsColor): Integer; overload;
function AddFont(const AFontName: String; ASize: Single; AStyle: TsFontStyles;
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;
AStyle: TsFontStyles; AColor: TsColor): Integer;
function FindFont(const AFontName: String; ASize: Single; AStyle: TsFontStyles;
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
fields of the cell
font if the cell does not exist.
-------------------------------------------------------------------------------}
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;

12
components/fpspreadsheet/fpspreadsheetctrls.pas
View File

@ -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', [

77
components/fpspreadsheet/fpspreadsheetgrid.pas
View File

@ -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;
vertAlign := fmt^.VertAlignment;
if vertAlign = vaDefault then vertAlign := vaBottom;
if fmt^.HorAlignment <> haDefault then
if (uffTextRotation in fmt^.UsedFormattingFields)
then txtRot := fmt^.TextRotation
else txtRot := trHorizontal;
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
# chars filling the cell.
@param AFontIndex Font index to be used for drawing non-rich-text.
@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

18
components/fpspreadsheet/fpstypes.pas
View File

@ -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

454
components/fpspreadsheet/fpsvisualutils.pas
View File

@ -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.

3
components/fpspreadsheet/laz_fpspreadsheet.lpk
View File

@ -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.

2
components/fpspreadsheet/xlscommon.pas
View File

@ -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];

229
components/fpspreadsheet/xlsxooxml.pas
View File

@ -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
records is given by the index of a font in the list. Therefore, we have
to write an empty record for font #4 which is nil due to compatibility with BIFF }
{ Writes font parameters to the stream.
ATag is "font" for the entry in "styles.xml", or "rPr" for the entry for
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(
'<fonts count="%d">', [Workbook.GetFontCount]));
AppendToStream(AStream, Format(
'<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);
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>');
WriteFont(AStream, font, '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;