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

fpspreadsheet: A bunch of updates have run up...

Browse Source 
- Activate ReadFromStream from xls5/8, xlsx, and ods readers (issue #0028389)
- Fix ods using correct hyperlink font
- Rich text formatting runs for xls5/8, xlsx, ods (both reading and writing)
- BIFFExplorer: show details of rich-text formatting runs for SST and RSTRING records

git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@4211 8e941d3f-bd1b-0410-a28a-d453659cc2b4
This commit is contained in:
wp_xxyyzz
2015-07-26 12:40:51 +00:00
parent 41b65aae4f
commit a838fe2707
13 changed files with 1978 additions and 637 deletions
Download Patch File Download Diff File Expand all files Collapse all files

35
components/fpspreadsheet/fpolebasic.pas
View File

@ -35,6 +35,7 @@ type
public
procedure WriteOLEFile(AFileName: string; AOLEDocument: TOLEDocument; const AOverwriteExisting: Boolean = False; const AStreamName: UTF8String='Book');
procedure ReadOLEFile(AFileName: string; AOLEDocument: TOLEDocument; const AStreamName: UTF8String='Book');
procedure ReadOLEStream(AStream: TStream; AOLEDocument: TOLEDocument; const AStreamName: UTF8String='Book');
procedure FreeOLEDocumentData(AOLEDocument: TOLEDocument);
end;
@ -88,12 +89,31 @@ procedure TOLEStorage.ReadOLEFile(AFileName: string;
AOLEDocument: TOLEDocument; const AStreamName: UTF8String);
var
RealFile: TFileStream;
begin
RealFile:=TFileStream.Create(AFileName, fmOpenRead or fmShareDenyNone);
try
ReadOLEStream(RealFile, AOLEDocument, AStreamName);
finally
RealFile.Free;
end;
end;
procedure TOLEStorage.ReadOLEStream(AStream: TStream; AOLEDocument: TOLEDocument;
const AStreamName: UTF8String = 'Book');
var
fsOLE: TVirtualLayer_OLE;
OLEStream: TStream;
VLAbsolutePath: UTF8String;
begin
VLAbsolutePath:='/'+AStreamName; //Virtual layer always use absolute paths.
fsOLE := TVirtualLayer_OLE.Create(AStream);
try
fsOLE.Initialize(); //Initialize the OLE container.
OLEStream := fsOLE.CreateStream(VLAbsolutePath, fmOpenRead);
try
{
RealFile:=nil;
RealFile:=TFileStream.Create(AFileName, fmOpenRead or fmShareDenyNone);
try
@ -114,12 +134,25 @@ begin
finally
OLEStream.Free;
end;
}
if Assigned(OLEStream) then begin
if not AssigneD(AOLEDocument.Stream) then
AOLEDocument.Stream := TMemoryStream.Create
else
(AOLEDocument.Stream as TMemoryStream).Clear;
AOLEDocument.Stream.CopyFrom(OLEStream, OLEStream.Size);
end;
finally
fsOLE.Free;
OLEStream.Free;
end;
finally
fsOLE.Free;
end;
{
finally
RealFile.Free;
end;
}
end;
{@@

21
components/fpspreadsheet/fpsnumformatparser.pas
View File

@ -1253,6 +1253,9 @@ end;
procedure TsNumFormatParser.ScanFormat;
var
done: Boolean;
s: String;
n: Integer;
uch: Cardinal;
begin
done := false;
while (FCurrent < FEnd) and (FStatus = psOK) and (not done) do begin
@ -1270,7 +1273,15 @@ begin
'_': // Excel: Leave width of next character empty
begin
FToken := NextToken;
AddElement(nftEmptyCharWidth, FToken);
uch := UTF8CharacterToUnicode(FCurrent, n);
if n > 1 then
begin
AddElement(nftEmptyCharWidth, UnicodeToUTF8(uch));
inc(FCurrent, n-1);
FToken := NextToken;
Continue;
end else
AddElement(nftEmptyCharWidth, FToken);
end;
'@': // Excel: Indicates text format
begin
@ -1301,7 +1312,13 @@ begin
Exit;
end;
else
AddElement(nftText, FToken);
uch := UTF8CharacterToUnicode(FCurrent, n);
if n > 1 then
begin
AddElement(nftText, UnicodeToUTF8(uch));
inc(FCurrent, n-1);
end else
AddElement(nftText, FToken);
end;
FToken := NextToken;
end;

325
components/fpspreadsheet/fpsopendocument.pas
View File

@ -149,6 +149,7 @@ type
private
FColumnStyleList: TFPList;
FRowStyleList: TFPList;
FRichTextFontList: TStringList;
FHeaderFooterFontList: TObjectList;
// Routines to write parts of files
@ -163,6 +164,7 @@ type
procedure WriteRowsAndCells(AStream: TStream; ASheet: TsWorksheet);
procedure WriteTableSettings(AStream: TStream);
procedure WriteTableStyles(AStream: TStream);
procedure WriteTextStyles(AStream: TStream);
procedure WriteVirtualCells(AStream: TStream; ASheet: TsWorksheet);
function WriteBackgroundColorStyleXMLAsString(const AFormat: TsCellFormat): String;
@ -232,7 +234,7 @@ type
implementation
uses
StrUtils, Variants, LazFileUtils, URIParser,
StrUtils, Variants, LazFileUtils, URIParser, LazUTF8,
{$IFDEF FPS_VARISBOOL}
fpsPatches,
{$ENDIF}
@ -958,7 +960,7 @@ end;
The function result is false if a style with the given name could not be found }
function TsSpreadOpenDocReader.ApplyStyleToCell(ACell: PCell; AStyleName: String): Boolean;
var
fmt: PsCellFormat;
fmt: TsCellFormat;
styleIndex: Integer;
i: Integer;
begin
@ -980,8 +982,14 @@ begin
exit;
styleIndex := TColumnData(FColumnList[i]).DefaultCellStyleIndex;
end;
fmt := FCellFormatList.Items[styleIndex];
ACell^.FormatIndex := FWorkbook.AddCellFormat(fmt^);
fmt := FCellFormatList.Items[styleIndex]^;
if (styleIndex = 0) and FWorksheet.HasHyperlink(ACell) then
begin
// Make sure to use hyperlink font for hyperlink cells in case of default cell style
fmt.FontIndex := HYPERLINK_FONTINDEX;
Include(fmt.UsedFormattingFields, uffFont);
end;
ACell^.FormatIndex := FWorkbook.AddCellFormat(fmt);
Result := true;
end;
@ -1660,7 +1668,9 @@ var
fntSize: Single;
fntStyles: TsFontStyles;
fntColor: TsColor;
fntPosition: TsFontPosition;
s: String;
p: Integer;
begin
if ANode = nil then
begin
@ -1687,9 +1697,20 @@ begin
if not ((s = '') or (s = 'none')) then
Include(fntStyles, fssUnderline);
s := GetAttrValue(ANode, 'style:text-line-through-style');
if s = '' then s := GetAttrValue(ANode, 'style:text-line-through-type');
if not ((s = '') or (s = 'none')) then
Include(fntStyles, fssStrikeout);
fntPosition := fpNormal;
s := GetAttrValue(ANode, 'style:text-position');
if Length(s) >= 3 then
begin
if (s[3] = 'b') or (s[1] = '-') then
fntPosition := fpSubscript
else
fntPosition := fpSuperscript;
end;
s := GetAttrValue(ANode, 'fo:color');
if s <> '' then
fntColor := HTMLColorStrToColor(s)
@ -1703,13 +1724,13 @@ begin
end else
if (APreferredIndex > -1) then
begin
FWorkbook.ReplaceFont(APreferredIndex, fntName, fntSize, fntStyles, fntColor);
FWorkbook.ReplaceFont(APreferredIndex, fntName, fntSize, fntStyles, fntColor, fntPosition);
Result := APreferredIndex;
end else
begin
Result := FWorkbook.FindFont(fntName, fntSize, fntStyles, fntColor);
Result := FWorkbook.FindFont(fntName, fntSize, fntStyles, fntColor, fntPosition);
if Result = -1 then
Result := FWorkbook.AddFont(fntName, fntSize, fntStyles, fntColor);
Result := FWorkbook.AddFont(fntName, fntSize, fntStyles, fntColor, fntPosition);
end;
end;
@ -1825,6 +1846,10 @@ begin
Workbook.OnReadCellData(Workbook, ARow, ACol, cell);
end;
{ In principle, this method could be simplified by calling ReadFromStream which
is essentially a duplication of ReadFromFile. But ReadFromStream leads to
worse memory usage. --> KEEP READFROMFILE INTACT
See fpspeedtest, ods 20k x 100 cells --> out of mem in Win7-32 bit, 4 GB}
procedure TsSpreadOpenDocReader.ReadFromFile(AFileName: string);
var
Doc : TXMLDocument;
@ -1935,12 +1960,132 @@ begin
end;
procedure TsSpreadOpenDocReader.ReadFromStream(AStream: TStream);
var
Doc : TXMLDocument;
// FilePath : string;
// UnZip : TUnZipper;
// FileList : TStringList;
BodyNode, SpreadSheetNode, TableNode: TDOMNode;
StylesNode: TDOMNode;
OfficeSettingsNode: TDOMNode;
nodename: String;
pageLayout: PsPageLayout;
XMLStream: TStream;
begin
{
//unzip files into AFileName path
FilePath := GetTempDir(false);
UnZip := TUnZipper.Create;
FileList := TStringList.Create;
try
FileList.Add('styles.xml');
FileList.Add('content.xml');
FileList.Add('settings.xml');
UnZip.OutputPath := FilePath;
Unzip.UnZipFiles(AFileName,FileList);
finally
FreeAndNil(FileList);
FreeAndNil(UnZip);
end; //try
}
Doc := nil;
try
// process the styles.xml file
XMLStream := TMemoryStream.Create;
try
if UnzipToStream(AStream, 'styles.xml', XMLStream) then
ReadXMLStream(Doc, XMLStream);
finally
XMLStream.Free;
end;
StylesNode := Doc.DocumentElement.FindNode('office:styles');
ReadNumFormats(StylesNode);
ReadStyles(StylesNode);
ReadAutomaticStyles(Doc.DocumentElement.FindNode('office:automatic-styles'));
ReadMasterStyles(Doc.DocumentElement.FindNode('office:master-styles'));
FreeAndNil(Doc);
//process the content.xml file
XMLStream := TMemoryStream.Create;
try
if UnzipToStream(AStream, 'content.xml', XMLStream) then
ReadXMLStream(Doc, XMLStream);
finally
XMLStream.Free;
end;
StylesNode := Doc.DocumentElement.FindNode('office:automatic-styles');
ReadNumFormats(StylesNode);
ReadStyles(StylesNode);
BodyNode := Doc.DocumentElement.FindNode('office:body');
if not Assigned(BodyNode) then
raise Exception.Create('[TsSpreadOpenDocReader.ReadFromStream] Node "office:body" not found.');
SpreadSheetNode := BodyNode.FindNode('office:spreadsheet');
if not Assigned(SpreadSheetNode) then
raise Exception.Create('[TsSpreadOpenDocReader.ReadFromStream] Node "office:spreadsheet" not found.');
ReadDateMode(SpreadSheetNode);
//process each table (sheet)
TableNode := SpreadSheetNode.FindNode('table:table');
while Assigned(TableNode) do
begin
nodename := TableNode.Nodename;
// These nodes occur due to leading spaces which are not skipped
// automatically any more due to PreserveWhiteSpace option applied
// to ReadXMLFile
if nodeName <> 'table:table' then
begin
TableNode := TableNode.NextSibling;
continue;
end;
FWorkSheet := FWorkbook.AddWorksheet(GetAttrValue(TableNode, 'table:name'), true);
// Collect column styles used
ReadColumns(TableNode);
// Process each row inside the sheet and process each cell of the row
ReadRowsAndCells(TableNode);
// Read page layout
pageLayout := ReadPageLayout(StylesNode, GetAttrValue(TableNode, 'table:style-name'));
if pageLayout <> nil then
FWorksheet.PageLayout := pagelayout^;
// Handle columns and rows
ApplyColWidths;
// Page layout
FixCols(FWorksheet);
FixRows(FWorksheet);
// Continue with next table
TableNode := TableNode.NextSibling;
end; //while Assigned(TableNode)
FreeAndNil(Doc);
// process the settings.xml file (Note: it does not always exist!)
XMLStream := TMemoryStream.Create;
try
if UnzipToStream(AStream, 'settings.xml', XMLStream) then
begin
ReadXMLStream(Doc, XMLStream);
OfficeSettingsNode := Doc.DocumentElement.FindNode('office:settings');
ReadSettings(OfficeSettingsNode);
end;
finally
XMLStream.Free;
end;
finally
FreeAndNil(Doc);
end;
end;
{
begin
Unused(AStream);
raise Exception.Create('[TsSpreadOpenDocReader.ReadFromStream] '+
'Method not implemented. Use "ReadFromFile" instead.');
end;
}
procedure TsSpreadOpenDocReader.ReadHeaderFooterFont(ANode: TDOMNode;
var AFontName: String; var AFontSize: Double;
var AFontStyle: TsHeaderFooterFontStyles; var AFontColor: TsColor);
@ -1998,13 +2143,16 @@ end;
procedure TsSpreadOpenDocReader.ReadLabel(ARow, ACol: Cardinal;
ACellNode: TDOMNode);
var
cellText: String;
cellText, spanText: String;
styleName: String;
childnode: TDOMNode;
subnode: TDOMNode;
nodeName: String;
cell: PCell;
hyperlink: string;
fmt: TsCellFormat;
rtParams: TsRichTextParams;
idx: Integer;
procedure AddToCellText(AText: String);
begin
@ -2020,6 +2168,7 @@ begin
like below is much better: }
cellText := '';
hyperlink := '';
SetLength(rtParams, 0);
childnode := ACellNode.FirstChild;
while Assigned(childnode) do
begin
@ -2041,7 +2190,21 @@ begin
AddToCellText(subnode.TextContent);
end;
'text:span':
AddToCellText(subnode.TextContent);
begin
spanText := subnode.TextContent;
stylename := GetAttrValue(subnode, 'text:style-name');
if stylename <> '' then begin
idx := FCellFormatList.FindIndexOfName(stylename);
if idx > -1 then
begin
SetLength(rtParams, Length(rtParams)+1);
rtParams[High(rtParams)].FontIndex := FCellFormatList[idx]^.FontIndex;
rtParams[High(rtParams)].StartIndex := Length(cellText);
rtParams[High(rtParams)].EndIndex := Length(cellText + spanText);
end;
end;
AddToCelLText(spanText);
end;
end;
subnode := subnode.NextSibling;
end;
@ -2056,7 +2219,7 @@ begin
end else
cell := FWorksheet.AddCell(ARow, ACol);
FWorkSheet.WriteUTF8Text(cell, cellText);
FWorkSheet.WriteUTF8Text(cell, cellText, rtParams);
if hyperlink <> '' then
begin
// ODS sees relative paths relative to the internal own file structure
@ -2917,6 +3080,7 @@ var
nodeName: String;
family: String;
styleName: String;
parentstyle: String;
fmt: TsCellFormat;
numFmtIndexDefault: Integer;
numFmtName: String;
@ -2925,6 +3089,7 @@ var
numFmtParams: TsNumFormatParams;
clr: TsColor;
s: String;
idx: Integer;
procedure SetBorderStyle(ABorder: TsCellBorder; AStyleValue: String);
const
@ -3013,6 +3178,7 @@ begin
if nodeName = 'style:style' then
begin
family := GetAttrValue(styleNode, 'style:family');
parentstyle := GetAttrValue(stylenode, 'style:parent-style-name');
// Column styles
if family = 'table-column' then
@ -3028,6 +3194,13 @@ begin
styleName := GetAttrValue(styleNode, 'style:name');
InitFormatRecord(fmt);
if parentstyle <> '' then
begin
idx := FCellFormatList.FindIndexOfName(parentstyle);
if idx > -1 then
fmt := FCellFormatList[idx]^;
end;
fmt.Name := styleName;
numFmtIndex := -1;
@ -3173,8 +3346,28 @@ begin
end;
styleChildNode := styleChildNode.NextSibling;
end;
FCellFormatList.Add(fmt);
end
else
if family = 'text' then
begin
// "Rich-text formatting run" style
styleName := GetAttrValue(styleNode, 'style:name');
styleChildNode := styleNode.FirstChild;
while Assigned(styleChildNode) do
begin
nodeName := styleChildNode.NodeName;
if nodeName = 'style:text-properties' then
begin
InitFormatRecord(fmt);
fmt.Name := styleName;
fmt.FontIndex := ReadFont(styleChildNode);
if fmt.FontIndex > 0 then
Include(fmt.UsedFormattingFields, uffFont);
FCellFormatList.Add(fmt);
end;
styleChildNode := stylechildNode.NextSibling;
end;
end;
end;
styleNode := styleNode.NextSibling;
@ -3410,6 +3603,9 @@ begin
FSMetaInfManifest.Position := 0;
end;
{ Writes the node "office:automatic-styles". Although this node occurs in both
"contents.xml" and "styles.xml" files, this method is called only for writing
to "styles.xml". }
procedure TsSpreadOpenDocWriter.WriteAutomaticStyles(AStream: TStream);
var
i: Integer;
@ -3640,11 +3836,12 @@ begin
AppendToStream(FSContent,
'<office:automatic-styles>');
WriteNumFormats(FSContent);
WriteColStyles(FSContent);
WriteRowStyles(FSContent);
WriteTableStyles(FSContent);
WriteCellStyles(FSContent);
WriteNumFormats(FSContent); // "N1" ...
WriteColStyles(FSContent); // "co1" ...
WriteRowStyles(FSContent); // "ro1" ...
WriteTableStyles(FSContent); // "ta1" ...
WriteCellStyles(FSContent); // "ce1" ...
WriteTextStyles(FSContent); // "T1" ...
AppendToStream(FSContent,
'</office:automatic-styles>');
@ -4221,6 +4418,7 @@ begin
FColumnStyleList := TFPList.Create;
FRowStyleList := TFPList.Create;
FRichTextFontList := TStringList.Create;
FHeaderFooterFontList := TObjectList.Create;
FPointSeparatorSettings := SysUtils.DefaultFormatSettings;
@ -4242,6 +4440,7 @@ begin
for j:=FRowStyleList.Count-1 downto 0 do TObject(FRowStyleList[j]).Free;
FRowStyleList.Free;
FRichTextFontList.Free; // Do not destroy fonts, they are owned by Workbook
FHeaderFooterFontList.Free;
inherited Destroy;
@ -4614,6 +4813,12 @@ begin
if fssStrikeout in AFont.Style then
Result := Result + 'style:text-line-through-style="solid" ';
if AFont.Position = fpSubscript then
Result := Result + 'style:text-position="sub 58%" ';
if AFont.Position = fpSuperscript then
Result := Result + 'style:text-position="super 58%" ';
if AFont.Color <> defFnt.Color then
Result := Result + Format('fo:color="%s" ', [ColorToHTMLColorStr(AFont.Color)]);
end;
@ -4879,9 +5084,44 @@ begin
end;
end;
procedure TsSpreadOpenDocWriter.WriteTextStyles(AStream: TStream);
var
cell: PCell;
rtp: TsRichTextParam;
styleCounter: Integer;
fnt: TsFont;
fntStr: String;
styleName: String;
sheet: TsWorksheet;
i: Integer;
begin
styleCounter := 0;
for i := 0 to FWorkbook.GetWorksheetCount-1 do
begin
sheet := FWorkbook.GetWorksheetByIndex(i);
for cell in sheet.Cells do
begin
if Length(cell^.RichTextParams) = 0 then
Continue;
for rtp in cell^.RichTextParams do
begin
inc(styleCounter);
stylename := Format('T%d', [stylecounter]);
fnt := FWorkbook.GetFont(rtp.FontIndex);
FRichTextFontList.AddObject(stylename, fnt);
fntStr := WriteFontStyleXMLAsString(fnt);
AppendToStream(AStream,
'<style:style style:name="' + stylename + '" style:family="text">' +
'<style:text-properties ' + fntStr + '/>' +
'</style:style>');
end;
end;
end;
end;
{@@ ----------------------------------------------------------------------------
Creates an XML string for inclusion of the textrotation style option into the
Creates an XML string for inclusion of the text rotation style option into the
written file from the textrotation setting in the format cell.
Is called from WriteStyles (via WriteStylesXMLAsString).
-------------------------------------------------------------------------------}
@ -5196,8 +5436,11 @@ var
txt: ansistring;
textp, target, bookmark, comment: String;
fmt: TsCellFormat;
fnt: TsFont;
hyperlink: PsHyperlink;
u: TUri;
i, idx, n, len: Integer;
rtParam: TsRichTextParam;
begin
Unused(ARow, ACol);
@ -5254,8 +5497,52 @@ begin
'</text:p>', [target, txt]);
end else
begin
// No hyperlink, normal text only
textp := '<text:p>' + txt + '</text:p>';
if Length(ACell^.RichTextParams) = 0 then
// Standard text formatting
textp := '<text:p>' + txt + '</text:p>'
else
begin
// "Rich-text" formatting
len := UTF8Length(AValue);
textp := '<text:p>';
rtParam := ACell^.RichTextParams[0];
if rtParam.StartIndex > 0 then
begin
txt := UTF8Copy(AValue, 1, rtParam.StartIndex);
ValidXMLText(txt);
textp := textp + txt;
end;
for i := 0 to High(ACell^.RichTextParams) do
begin
rtParam := ACell^.RichTextParams[i];
fnt := FWorkbook.GetFont(rtParam.FontIndex);
idx := FRichTextFontList.IndexOfObject(fnt);
n := rtParam.EndIndex - rtParam.StartIndex;
txt := UTF8Copy(AValue, rtParam.StartIndex+1, n);
ValidXMLText(txt);
textp := textp +
'<text:span text:style-name="' + FRichTextFontList[idx] + '">' +
txt +
'</text:span>';
if (rtParam.EndIndex < len) and (i = High(ACell^.RichTextParams)) then
begin
txt := UTF8Copy(AValue, rtParam.EndIndex+1, MaxInt);
ValidXMLText(txt);
textp := textp + txt;
end else
if (i < High(ACell^.RichTextParams)) and (rtParam.EndIndex < ACell^.RichTextParams[i+1].StartIndex)
then begin
n := ACell^.RichTextParams[i+1].StartIndex - rtParam.EndIndex;
txt := UTF8Copy(AValue, rtParam.EndIndex+1, n);
ValidXMLText(txt);
textp := textp + txt;
end;
end;
textp := textp + '</text:p>';
end;
end;
// Write it ...
AppendToStream(AStream, Format(

84
components/fpspreadsheet/fpspreadsheet.pas
View File

@ -1,3 +1,14 @@
{**
Unit: fpspreadsheet
implements **spreadsheet documents** and their properties and methods.
AUTHORS: Felipe Monteiro de Carvalho, Reinier Olislagers, Werner Pamler
LICENSE: See the file COPYING.modifiedLGPL.txt, included in the Lazarus
distribution, for details about the license.
}
{@@ ----------------------------------------------------------------------------
Unit fpspreadsheet implements <b>spreadsheet documents</b> and their
properties and methods.
@ -31,6 +42,18 @@ type
TsBasicSpreadReader = class;
TsBasicSpreadWriter = class;
{**
Type: TRow -- record containing information about a spreadsheet row
Members:
- Row -- The index of the row (beginning with 0)
- Height -- The height of the row (expressed as line count of the default font)
Notes:
- Only rows with heights that cannot be derived from the font height have
a row record.
}
{@@ The record TRow contains information about a spreadsheet row:
@param Row The index of the row (beginning with 0)
@param Height The height of the row (expressed as lines count of the default font)
@ -239,9 +262,10 @@ type
procedure WriteRPNFormula(ACell: PCell;
AFormula: TsRPNFormula); overload;
function WriteUTF8Text(ARow, ACol: Cardinal; AText: ansistring): PCell; overload;
// procedure WriteUTF8Text(ACell: PCell; AText: ansistring); overload;
procedure WriteUTF8Text(ACell: PCell; AText: String; ARichTextparams: TsRichTextParams = nil); overload;
function WriteUTF8Text(ARow, ACol: Cardinal; AText: ansistring;
ARichTextParams: TsRichTextParams = nil): PCell; overload;
procedure WriteUTF8Text(ACell: PCell; AText: String;
ARichTextparams: TsRichTextParams = nil); overload;
{ Writing of cell attributes }
function WriteBackground(ARow, ACol: Cardinal; AStyle: TsFillStyle;
@ -890,9 +914,9 @@ begin
end;
{*******************************************************************************
* TsWorksheet *
*******************************************************************************}
{------------------------------------------------------------------------------}
{ TsWorksheet }
{------------------------------------------------------------------------------}
{@@ ----------------------------------------------------------------------------
Constructor of the TsWorksheet class.
@ -3461,15 +3485,22 @@ end;
On formats that don't support unicode, the text will be converted
to ISO Latin 1.
@param ARow The row of the cell
@param ACol The column of the cell
@param AText The text to be written encoded in utf-8
@param ARow The row of the cell
@param ACol The column of the cell
@param AText The text to be written encoded in utf-8
@param ARichTextParams Array of formatting instructions for characters or
groups of characters (see TsRichTextParam).
@return Pointer to cell created or used
@see TsRichTextParams
@see TsRichTextParam
-------------------------------------------------------------------------------}
function TsWorksheet.WriteUTF8Text(ARow, ACol: Cardinal; AText: ansistring): PCell;
function TsWorksheet.WriteUTF8Text(ARow, ACol: Cardinal; AText: ansistring;
ARichTextParams: TsRichTextParams = nil): PCell;
begin
Result := GetCell(ARow, ACol);
WriteUTF8Text(Result, AText);
WriteUTF8Text(Result, AText, ARichTextParams);
end;
{@@ ----------------------------------------------------------------------------
@ -3478,8 +3509,13 @@ end;
On formats that don't support unicode, the text will be converted
to ISO Latin 1.
@param ACell Pointer to the cell
@param AText The text to be written encoded in utf-8
@param ACell Pointer to the cell
@param AText The text to be written encoded in utf-8
@param ARichTextParams Array of formatting instructions for characters or
groups of characters (see TsRichTextParam).
@see TsRichTextParams
@see TsRichTextParam
-------------------------------------------------------------------------------}
procedure TsWorksheet.WriteUTF8Text(ACell: PCell; AText: String;
ARichTextParams: TsRichTextParams = nil);
@ -3537,6 +3573,7 @@ end;
@param ARow Cell row index
@param ACol Cell column index
@param ANumber Number to be written
@return Pointer to cell created or used
-------------------------------------------------------------------------------}
function TsWorksheet.WriteNumber(ARow, ACol: Cardinal; ANumber: double): PCell;
@ -6032,9 +6069,9 @@ begin
end;
{*******************************************************************************
* TsWorkbook *
*******************************************************************************}
{------------------------------------------------------------------------------}
{ TsWorkbook }
{------------------------------------------------------------------------------}
{@@ ----------------------------------------------------------------------------
Helper method called before reading the workbook. Clears the error log.
@ -7664,9 +7701,9 @@ begin
end;
*)
{*******************************************************************************
* TsBasicSpreadReaderWriter *
*******************************************************************************}
{------------------------------------------------------------------------------}
{ TsBasicSpreadReaderWriter }
{------------------------------------------------------------------------------}
{@@ ----------------------------------------------------------------------------
Constructor of the reader/writer. Has the workbook to be read/written as a
@ -7696,9 +7733,9 @@ begin
end;
{*******************************************************************************
* TsBasicSpreadWriter *
*******************************************************************************}
{------------------------------------------------------------------------------}
{ TsBasicSpreadWriter }
{------------------------------------------------------------------------------}
{@@ ----------------------------------------------------------------------------
Checks limitations of the writer, e.g max row/column count
@ -7724,5 +7761,4 @@ initialization
finalization
SetLength(GsSpreadFormats, 0);
end.
end. {** End Unit: fpspreadsheet }

17
components/fpspreadsheet/fpspreadsheetgrid.pas
View File

@ -598,17 +598,6 @@ uses
fpCanvas, fpsStrings, fpsUtils, fpsVisualUtils, fpsNumFormat;
const
{@@ Translation of the fpspreadsheet type of horizontal text alignment to that
used in the graphics unit. }
HOR_ALIGNMENTS: array[haLeft..haRight] of TAlignment = (
taLeftJustify, taCenter, taRightJustify
);
{@@ Translation of the fpspreadsheet type of vertical text alignment to that
used in the graphics unit. }
VERT_ALIGNMENTS: array[TsVertAlignment] of TTextLayout = (
tlBottom, tlTop, tlCenter, tlBottom
);
{@@ Default number of columns prepared for a new empty worksheet }
DEFAULT_COL_COUNT = 26;
{@@ Default number of rows prepared for a new empty worksheet }
@ -2100,7 +2089,7 @@ var
txtRot: TsTextRotation;
fntIndex: Integer;
lCell: PCell;
justif: Byte;
// justif: Byte;
fmt: PsCellFormat;
begin
if (Worksheet = nil) then
@ -2169,7 +2158,7 @@ begin
txt := GetCellText(GetGridRow(lCell^.Col), GetGridCol(lCell^.Row));
if txt = '' then
exit;
{
case txtRot of
trHorizontal:
case horAlign of
@ -2190,7 +2179,7 @@ begin
vaCenter: justif := 1;
vaBottom: justif := 0;
end;
end;
end; }
InternalDrawTextInCell(txt, ARect, horAlign, vertAlign, txtRot, wrapped,
fntIndex, lCell^.RichTextParams);
{

4
components/fpspreadsheet/fpstypes.pas
View File

@ -404,7 +404,7 @@ type
TsFontStyles = set of TsFontStyle;
{@@ Font position (subscript or superscript) }
TsFontPosition = (fpNormal, fpSubscript, fpSuperscript);
TsFontPosition = (fpNormal, fpSuperscript, fpSubscript); // Keep order for compatibility with xls!
{@@ Font record used in fpspreadsheet. Contains the font name, the font size
(in points), the font style, and the font color. }
@ -432,7 +432,7 @@ type
TsRichTextParams = array of TsRichTextParam;
{@@ Excel rich-text formatting run }
TsRichTextFormattingRun = record
TsRichTextFormattingRun = packed record
FirstIndex: Integer;
FontIndex: Integer;
end;

20
components/fpspreadsheet/fpsvisualutils.pas
View File

@ -196,7 +196,7 @@ var
totalHeight, linelen, stackPeriod: Integer;
procedure InitFont(P: PChar; out rtState: TRtState;
PendingRtpIndex: Integer; out AHeight: Integer);
PendingRtpIndex: Integer; out AHeight: Integer; out AFontPos: TsFontPosition);
var
fnt: TsFont;
hasRtp: Boolean;
@ -216,12 +216,13 @@ var
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);
ACanvas.Font.Size := round(fnt.Size * SUBSCRIPT_SUPERSCRIPT_FACTOR);
AFontPos := fnt.Position;
end;
procedure UpdateFont(P:PChar; var rtState: TRtState;
var PendingRtpIndex: Integer; var AHeight: Integer;
out AFontPos: TsFontPosition);
var AFontPos: TsFontPosition);
var
hasRtp: Boolean;
rtp: TsRichTextParam;
@ -238,7 +239,8 @@ var
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);
ACanvas.Font.Size := round(fnt.Size * SUBSCRIPT_SUPERSCRIPT_FACTOR);
AFontPos := fnt.Position;
rtState := rtEnter;
end else
if (p - pStartText >= rtp.EndIndex) and (rtState = rtEnter) then
@ -264,10 +266,10 @@ var
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);
ACanvas.Font.Size := round(fnt.Size * SUBSCRIPT_SUPERSCRIPT_FACTOR);
AFontPos := fnt.Position;
end;
end;
AFontPos := fnt.Position;
end;
procedure ScanLine(var P: PChar; var NumSpaces: Integer;
@ -287,7 +289,7 @@ var
begin
NumSpaces := 0;
InitFont(p, rtState, PendingRtpIndex, h);
InitFont(p, rtState, PendingRtpIndex, h, fntpos);
height := h;
pEOL := p;
@ -365,12 +367,12 @@ var
p: PChar;
rtState: TRtState;
h, w: Integer;
fntpos: TsFontPosition;
fntpos: TsFontPosition = fpNormal;
s: utf8String;
charLen: Integer;
begin
p := pStart;
InitFont(p, rtState, PendingRtpIndex, h);
InitFont(p, rtState, PendingRtpIndex, h, fntpos);
while p^ <> #0 do begin
s := UnicodeToUTF8(UTF8CharacterToUnicode(p, charLen));
UpdateFont(p, rtState, PendingRtpIndex, h, fntpos);

134
components/fpspreadsheet/fpsxmlcommon.pas
View File

@ -16,12 +16,15 @@ type
TsSpreadXMLReader = class(TsCustomSpreadReader)
protected
procedure ReadXMLFile(out ADoc: TXMLDocument; AFileName: String);
procedure ReadXMLStream(out ADoc: TXMLDocument; AStream: TStream);
end;
function GetAttrValue(ANode : TDOMNode; AAttrName : string) : string;
function GetNodeValue(ANode: TDOMNode): String;
procedure UnzipFile(AZipFileName, AZippedFile, ADestFolder: String);
procedure UnzipFile(AZipFileName, AZippedFile, ADestFolder: String);
function UnzipToStream(AZipStream: TStream; const AZippedFile: String;
ADestStream: TStream): Boolean;
implementation
@ -33,9 +36,13 @@ uses
{$ENDIF}
fpsStreams;
{ Gets value for the specified attribute. Returns empty string if attribute
not found. }
function {TsSpreadXMLReader.}GetAttrValue(ANode : TDOMNode; AAttrName : string) : string;
{------------------------------------------------------------------------------}
{ Utilities }
{------------------------------------------------------------------------------}
{ Gets value for the specified attribute of the given node.
Returns empty string if attribute is not found. }
function GetAttrValue(ANode : TDOMNode; AAttrName : string) : string;
var
i: LongWord;
Found: Boolean;
@ -58,7 +65,7 @@ end;
{ Returns the text value of a node. Normally it would be sufficient to call
"ANode.NodeValue", but since the DOMParser needs to preserve white space
(for the spaces in date/time formats), we have to go more into detail. }
function {TsSpreadXMLReader.}GetNodeValue(ANode: TDOMNode): String;
function GetNodeValue(ANode: TDOMNode): String;
var
child: TDOMNode;
begin
@ -68,38 +75,109 @@ begin
Result := child.NodeValue;
end;
{------------------------------------------------------------------------------}
{ Unzipping }
{------------------------------------------------------------------------------}
type
TStreamUnzipper = class(TUnzipper)
private
FInputStream: TStream;
FOutputStream: TStream;
FSuccess: Boolean;
procedure CloseInputStream(Sender: TObject; var AStream: TStream);
procedure CreateStream(Sender: TObject; var AStream: TStream;
AItem: TFullZipFileEntry);
procedure DoneStream(Sender: TObject; var AStream: TStream;
AItem: TFullZipFileEntry);
procedure OpenInputStream(Sender: TObject; var AStream: TStream);
public
constructor Create(AInputStream: TStream);
function UnzipFile(const AZippedFile: string; ADestStream: TStream): Boolean;
end;
constructor TStreamUnzipper.Create(AInputStream: TStream);
begin
inherited Create;
OnCloseInputStream := @CloseInputStream;
OnCreateStream := @CreateStream;
OnDoneStream := @DoneStream;
OnOpenInputStream := @OpenInputStream;
FInputStream := AInputStream
end;
procedure TStreamUnzipper.CloseInputStream(Sender: TObject; var AStream: TStream);
begin
AStream := nil;
end;
procedure TStreamUnzipper.CreateStream(Sender: TObject; var AStream: TStream;
AItem: TFullZipFileEntry);
begin
FSuccess := True;
AStream := FOutputStream;
end;
procedure TStreamUnzipper.DoneStream(Sender: TObject; var AStream: TStream;
AItem: TFullZipFileEntry);
begin
AStream := nil;
end;
procedure TStreamUnzipper.OpenInputStream(Sender: TObject; var AStream: TStream);
begin
AStream := FInputStream;
end;
function TStreamUnzipper.UnzipFile(const AZippedFile: string;
ADestStream: TStream): Boolean;
begin
FOutputStream := ADestStream;
FSuccess := False;
Files.Clear;
Files.Add(AZippedFile);
UnZipAllFiles;
Result := FSuccess;
end;
{ We have to use our own ReadXMLFile procedure (there is one in xmlread)
because we have to preserve spaces in element text for date/time separator.
As a side-effect we have to skip leading spaces by ourselves. }
procedure TsSpreadXMLReader.ReadXMLFile(out ADoc: TXMLDocument; AFileName: String);
var
parser: TDOMParser;
src: TXMLInputSource;
stream: TStream;
begin
if (boBufStream in Workbook.Options) then
stream := TBufStream.Create(AFileName, fmOpenRead + fmShareDenyWrite)
stream := TBufStream.Create(AFilename, fmOpenRead + fmShareDenyWrite)
else
stream := TFileStream.Create(AFileName, fmOpenRead + fmShareDenyWrite);
try
parser := TDOMParser.Create;
try
parser.Options.PreserveWhiteSpace := true; // This preserves spaces!
src := TXMLInputSource.Create(stream);
try
parser.Parse(src, ADoc);
finally
src.Free;
end;
finally
parser.Free;
end;
ReadXMLStream(ADoc, stream);
finally
stream.Free;
end;
end;
procedure TsSpreadXMLReader.ReadXMLStream(out ADoc: TXMLDocument; AStream: TStream);
var
parser: TDOMParser;
src: TXMLInputSource;
begin
parser := TDOMParser.Create;
try
parser.Options.PreserveWhiteSpace := true; // This preserves spaces!
src := TXMLInputSource.Create(AStream);
try
parser.Parse(src, ADoc);
finally
src.Free;
end;
finally
parser.Free;
end;
end;
procedure UnzipFile(AZipFileName, AZippedFile, ADestFolder: String);
var
list: TStringList;
@ -121,5 +199,21 @@ begin
end;
function UnzipToStream(AZipStream: TStream; const AZippedFile: String;
ADestStream: TStream): Boolean;
var
unzip: TStreamUnzipper;
p: Int64;
begin
p := ADestStream.Position;
unzip := TStreamUnzipper.Create(AZipStream);
try
Result := unzip.UnzipFile(AZippedFile, ADestStream);
ADestStream.Position := p;
finally
unzip.Free;
end;
end;
end.

171
components/fpspreadsheet/reference/BIFFExplorer/bebiffgrid.pas
View File

@ -101,6 +101,7 @@ type
procedure ShowRefreshAll;
procedure ShowRightMargin;
procedure ShowRK;
procedure ShowRString;
procedure ShowRow;
procedure ShowSelection;
procedure ShowSharedFormula;
@ -132,7 +133,12 @@ type
ACharCount: Integer; out AString: String; out ANumbytes: Integer); overload;
procedure ExtractString(ABufIndex: Integer; ALenBytes: Byte; AUnicode: Boolean;
out AString: String; out ANumBytes: Integer;
out ARichTextRuns: TsRichTextFormattingRuns;
out ABufIndexOfFirstRichTextRun: LongWord;
IgnoreCompressedFlag: Boolean = false); overload;
procedure ExtractString(ABufIndex: Integer; ALenbytes: Byte; AUnicode: Boolean;
out AString: String; out ANumBytes: Integer;
IgnoreCompressedFlag: Boolean=False); overload;
procedure PopulateGrid;
procedure ShowInRow(var ARow: Integer; var AOffs: LongWord; ASize: Word;
AValue,ADescr: String; ADescrOnly: Boolean = false);
@ -225,7 +231,7 @@ end;
The string is assumed to be a UTF16 string if AUnicode=true, otherwise it is
an ansi string. }
procedure TBIFFGrid.ExtractString(ABufIndex: Integer; AUnicode: Boolean;
ACharCount: Integer;out AString: String; out ANumbytes: Integer);
ACharCount: Integer; out AString: String; out ANumbytes: Integer);
var
sa: AnsiString;
sw: WideString;
@ -265,7 +271,21 @@ begin
end;
procedure TBIFFGrid.ExtractString(ABufIndex: Integer; ALenBytes: Byte; AUnicode: Boolean;
out AString: String; out ANumBytes: Integer; IgnoreCompressedFlag: Boolean = false);
out AString: String; out ANumBytes: Integer;
IgnoreCompressedFlag: Boolean = false);
var
rtfRuns: TsRichTextFormattingRuns;
rtfIndex: LongWord;
begin
ExtractString(ABufIndex, ALenbytes, AUnicode, AString, ANumBytes,
rtfRuns, rtfIndex, IgnoreCompressedFlag);
end;
procedure TBIFFGrid.ExtractString(ABufIndex: Integer; ALenBytes: Byte; AUnicode: Boolean;
out AString: String; out ANumBytes: Integer;
out ARichTextRuns: TsRichTextFormattingRuns;
out ABufIndexOfFirstRichTextRun: LongWord;
IgnoreCompressedFlag: Boolean = false);
var
ls: Integer; // Character count of string
w: Word;
@ -273,12 +293,17 @@ var
optn: Byte;
n: Integer; // Byte count in string character array
asianPhoneticBytes: DWord;
richRuns: Word;
numRichRuns: Word;
offs: Integer;
rtfBufIndex: Int64;
rtfIndex: Integer;
begin
ABufIndexOfFirstRichTextRun := LongWord(-1);
SetLength(ARichTextRuns, 0);
if Length(FBuffer) = 0 then begin
AString := '';
ANumBytes := 0;
ANumBytes := 0;
exit;
end;
if ALenBytes = 1 then
@ -291,13 +316,16 @@ begin
offs := ALenBytes;
optn := FBuffer[ABufIndex + ALenBytes];
inc(offs, 1);
if optn and $08 <> 0 then // rich text
begin
Move(FBuffer[ABufIndex + offs], w, 2);
richRuns := WordLEToN(w);
numRichRuns := WordLEToN(w);
inc(offs, 2);
end else
richRuns := 0;
numRichRuns := 0;
SetLength(ARichTextRuns, numRichRuns);
if optn and $04 <> 0 then // Asian phonetic
begin
Move(FBuffer[ABufIndex + offs], dw, 4);
@ -305,16 +333,31 @@ begin
inc(offs, 4);
end else
asianPhoneticBytes := 0;
if (optn and $01 = 0) and (not IgnoreCompressedFlag) then
// compressed --> 1 byte per character
ExtractString(ABufIndex + offs, false, ls, AString, n)
else
// non-compressed unicode
ExtractString(ABufIndex + offs, true, ls, AString, n);
ANumBytes := offs + n + richRuns * 4 + asianPhoneticBytes;
ANumBytes := offs + n + numRichRuns * 4 + asianPhoneticBytes;
rtfIndex := 0;
rtfBufIndex := ABufIndex + offs + n;
ABufIndexOfFirstRichTextRun := rtfBufIndex;
while rtfIndex < numRichRuns do begin
Move(FBuffer[rtfBufIndex], w, 2);
ARichTextRuns[rtfIndex].FirstIndex := WordLEToN(w);
Move(FBuffer[rtfBufIndex+2], w, 2);
ARichTextRuns[rtfIndex].FontIndex := WordLEToN(w);
inc(rtfIndex);
inc(rtfBufIndex, 4);
end;
end else
begin
// ansi string
SetLength(ARichTextRuns, 0); // no rich text formatting for ansi strings
ExtractString(ABufIndex + ALenBytes, false, ls, AString, n);
ANumbytes := ALenBytes + n;
end;
@ -471,6 +514,8 @@ begin
ShowMulBlank;
$00BD:
ShowMulRK;
$00D6:
ShowRString;
$00D7:
ShowDBCell;
$00DA:
@ -1235,12 +1280,14 @@ var
sa: ansistring;
sw: widestring;
ls: Integer;
i: Integer;
i, j: Integer;
w: Word;
n: Integer;
run: Integer;
total2: Integer;
optn: Byte;
rtfRuns: TsRichTextFormattingRuns;
rtfBufferIndex: LongWord;
begin
case FInfo of
BIFFNODE_TXO_CONTINUE1:
@ -1345,9 +1392,20 @@ begin
for i:=FCounterSST+1 to FTotalSST do
begin
FCounterSST := i;
ExtractString(FBufferIndex, 2, true, s, numBytes);
ExtractString(FBufferIndex, 2, true, s, numBytes, rtfRuns, rtfBufferIndex);
ShowInRow(FCurrRow, FBufferIndex, numBytes, s, Format('Shared string #%d', [i]));
inc(n);
if Length(rtfRuns) > 0 then begin
numBytes := 2;
for j:=0 to High(rtfRuns) do
begin
ShowInRow(FCurrRow, rtfBufferIndex, 2, IntToStr(rtfRuns[j].FirstIndex),
Format('Rich-Text formatting run #%d, index of first character', [j]));
ShowInRow(FCurrRow, rtfBufferIndex, 2, IntToStr(rtfRuns[j].FontIndex),
Format('Rich-Text formatting run #%d, font index', [j]));
inc(n, 2);
end;
end;
if FPendingCharCount > 0 then
begin
FInfo := BIFFNODE_SST_CONTINUE;
@ -1838,6 +1896,7 @@ var
ansiStr: AnsiString;
s: String;
i, n: Integer;
rtfRuns: TsRichTextFormattingRuns;
begin
BeginUpdate;
RowCount := FixedRows + 1000;
@ -2112,7 +2171,7 @@ begin
numBytes := 2;
Move(FBuffer[FBufferIndex], w, numBytes);
w := WordLEToN(w);
ShowInRow(FCurrRow, FBufferIndex, numBytes, IntToStr(2), 'Color index');
ShowInRow(FCurrRow, FBufferIndex, numBytes, IntToStr(w), 'Color index');
numBytes := 2;
Move(FBuffer[FBufferIndex], w, numBytes);
@ -3309,6 +3368,7 @@ begin
'Index to XF record');
end;
// Called for LABEL
procedure TBIFFGrid.ShowLabelCell;
var
numBytes: Integer;
@ -4997,6 +5057,72 @@ begin
end;
procedure TBIFFGrid.ShowRString;
var
numBytes: Integer;
b: Byte;
w: Word;
s: String;
len: Integer;
j: Integer;
wideStr: wideString;
ansiStr: ansiString;
begin
if FFormat < sfExcel5 then
exit;
RowCount := FixedRows + 5;
ShowRowColData(FBufferIndex);
numBytes := 2;
Move(FBuffer[FBufferIndex], w, numBytes);
w := WordLEToN(w);
ShowInRow(FCurrRow, FBufferIndex, numBytes, Format('%d ($%.4x)', [w, w]),
'Index of XF record');
// String length
Move(FBuffer[FBufferIndex], w, 2);
len := WordLEToN(w);
if FFormat = sfExcel8 then
begin
SetLength(widestr, len);
Move(FBuffer[FBufferIndex+3], widestr[1], len*2);
s := UTF8Encode(WideStringLEToN(widestr));
numbytes := 3 + len*2;
end else
begin
SetLength(ansistr, len);
Move(FBuffer[FBufferIndex+2], ansistr[1], len);
s := AnsiToUTF8(ansistr);
numbytes := 2 + len;
end;
ShowInRow(FCurrRow, FBufferIndex, numbytes, s,
Format('%s string, 16-bit string length', [GetStringType]));
// Number of rich-text formatting runs
numbytes := IfThen(FFormat = sfExcel8, 2, 1);
Move(FBuffer[FBufferIndex], w, numbytes);
len := WordLEToN(w);
ShowInRow(FCurrRow, FBufferIndex, numbytes, IntToStr(len),
'Count of rich-text formatting runs');
// Formatting run data
RowCount := RowCount + 2*len;
for j:=0 to len-1 do
begin
Move(FBuffer[FBufferIndex], w, numbytes);
ShowInRow(FCurrRow, FBufferIndex, numbytes, IntToStr(WordLEToN(w)),
Format('Rich-Text formatting run #%d, index of first character', [j]));
Move(FBuffer[FBufferIndex], w, numbytes);
ShowInRow(FCurrRow, FBufferIndex, numbytes, IntToStr(WordLEToN(w)),
Format('Rich-Text formatting run #%d, font index', [j]));
end;
end;
procedure TBIFFGrid.ShowSelection;
var
numBytes: Integer;
@ -5195,7 +5321,10 @@ var
numBytes: Integer;
s: String;
total1, total2: DWord;
i, n: Integer;
i, j, n: Integer;
rtfRuns: TsRichTextFormattingRuns;
rtfIndex: LongWord;
w: Word;
begin
numBytes := 4;
Move(FBuffer[FBufferIndex], total1, numBytes);
@ -5204,7 +5333,7 @@ begin
total2 := DWordLEToN(total2);
FTotalSST := total2;
RowCount := FixedRows + 2 + total2;
RowCount := FixedRows + 1000;
ShowInRow(FCurrRow, FBufferIndex, numBytes, IntToStr(total1),
'Total number of shared strings in the workbook');
@ -5215,10 +5344,22 @@ begin
n := 0;
for i:=1 to FTotalSST do begin
FCounterSST := i;
ExtractString(FBufferIndex, 2, true, s, numBytes); // BIFF8 only --> 2 length bytes
ExtractString(FBufferIndex, 2, true, s, numBytes, rtfRuns, rtfIndex); // BIFF8 only --> 2 length bytes
inc(n);
if FPendingCharCount = 0 then
ShowInRow(FCurrRow, FBufferIndex, numBytes, s, Format('Shared string #%d', [i]))
if FPendingCharCount = 0 then begin
ShowInRow(FCurrRow, FBufferIndex, numbytes, s, IfThen(Length(rtfRuns) > 0,
Format('Shared string #%d (Count of Rich-Text formatting runs: %d)', [i, Length(rtfRuns)]),
Format('Shared string #%d', [i])));
// ShowInRow(FCurrRow, FBufferIndex, numBytes, s, Format('Shared string #%d', [i]));
for j:=0 to High(rtfRuns) do
begin
ShowInRow(FCurrRow, rtfIndex, 2, IntToStr(rtfRuns[j].FirstIndex),
Format(' Rich-Text formatting run #%d, index of first character', [j]));
ShowInRow(FCurrRow, rtfIndex, 2, IntToStr(rtfRuns[j].FontIndex),
Format(' Rich-Text formatting run #%d, font index', [j]));
inc(n, 2);
end;
end
else
begin
ShowInRow(FCurrRow, FBufferIndex, numbytes, s, Format('Shared string #%d - partial (--> CONTINUE)', [i]));

183
components/fpspreadsheet/xlsbiff5.pas
View File

@ -73,9 +73,6 @@ type
{ TsSpreadBIFF5Reader }
TsSpreadBIFF5Reader = class(TsSpreadBIFFReader)
private
FWorksheetNames: TStringList;
FCurrentWorksheet: Integer;
protected
procedure PopulatePalette; override;
{ Record writing methods }
@ -83,15 +80,15 @@ type
procedure ReadFONT(const AStream: TStream);
procedure ReadFORMAT(AStream: TStream); override;
procedure ReadLABEL(AStream: TStream); override;
procedure ReadWorkbookGlobals(AStream: TStream);
procedure ReadWorksheet(AStream: TStream);
procedure ReadRichString(AStream: TStream);
procedure ReadRSTRING(AStream: TStream);
procedure ReadStandardWidth(AStream: TStream; ASheet: TsWorksheet);
procedure ReadStringRecord(AStream: TStream); override;
procedure ReadWorkbookGlobals(AStream: TStream); override;
procedure ReadWorksheet(AStream: TStream); override;
procedure ReadXF(AStream: TStream);
public
{ General reading methods }
procedure ReadFromFile(AFileName: string); override;
// procedure ReadFromFile(AFileName: string); override;
procedure ReadFromStream(AStream: TStream); override;
end;
@ -323,6 +320,13 @@ type
TextLen: Word;
end;
TBiff5_RichTextFormattingRun = packed record
FirstIndex: Byte;
FontIndex: Byte;
end;
TBiff5_RichTextFormattingRuns = array of TBiff5_RichTextFormattingRun;
TBIFF5_XFRecord = packed record
RecordID: Word;
RecordSize: Word;
@ -426,7 +430,7 @@ begin
INT_EXCEL_ID_RIGHTMARGIN : ReadMargin(AStream, 1);
INT_EXCEL_ID_RK : ReadRKValue(AStream); //(RK) This record represents a cell that contains an RK value (encoded integer or floating-point value). If a floating-point value cannot be encoded to an RK value, a NUMBER record will be written. This record replaces the record INTEGER written in BIFF2.
INT_EXCEL_ID_ROW : ReadRowInfo(AStream);
INT_EXCEL_ID_RSTRING : ReadRichString(AStream); //(RSTRING) This record stores a formatted text cell (Rich-Text). In BIFF8 it is usually replaced by the LABELSST record. Excel still uses this record, if it copies formatted text cells to the clipboard.
INT_EXCEL_ID_RSTRING : ReadRString(AStream); //(RSTRING) This record stores a formatted text cell (Rich-Text). In BIFF8 it is usually replaced by the LABELSST record. Excel still uses this record, if it copies formatted text cells to the clipboard.
INT_EXCEL_ID_SHAREDFMLA : ReadSharedFormula(AStream);
INT_EXCEL_ID_SHEETPR : ReadSHEETPR(AStream);
INT_EXCEL_ID_STANDARDWIDTH : ReadStandardWidth(AStream, FWorksheet);
@ -508,12 +512,11 @@ begin
SetLength(s, Len);
AStream.ReadBuffer(s[1], Len*SizeOf(AnsiChar));
// sheetName := AnsiToUTF8(s);
sheetName := ConvertEncoding(s, FCodePage, EncodingUTF8);
FWorksheetNames.Add(sheetName);
end;
procedure TsSpreadBIFF5Reader.ReadRichString(AStream: TStream);
procedure TsSpreadBIFF5Reader.ReadRSTRING(AStream: TStream);
var
L: Word;
B, F: Byte;
@ -593,6 +596,7 @@ begin
FIncompleteCell := nil;
end;
(*
procedure TsSpreadBIFF5Reader.ReadFromFile(AFileName: string);
var
MemStream: TMemoryStream;
@ -620,7 +624,7 @@ begin
OLEStorage.Free;
end;
end;
*)
procedure TsSpreadBIFF5Reader.ReadXF(AStream: TStream);
var
rec: TBIFF5_XFRecord;
@ -642,15 +646,7 @@ begin
AStream.ReadBuffer(rec.FontIndex, SizeOf(rec) - 2*SizeOf(Word));
// Font index
i := WordLEToN(rec.FontIndex);
// if i > 4 then dec(i); // Watch out for the nasty missing font #4...
fmt.FontIndex := FixFontIndex(i);
{
fnt := TsFont(FFontList[i]);
fmt.FontIndex := Workbook.FindFont(fnt.FontName, fnt.Size, fnt.Style, fnt.Color);
if fmt.FontIndex = -1 then
fmt.FontIndex := Workbook.AddFont(fnt.FontName, fnt.Size, fnt.Style, fnt.Color);
}
fmt.FontIndex := FixFontIndex(WordLEToN(rec.FontIndex));
if fmt.FontIndex > 1 then
Include(fmt.UsedFormattingFields, uffFont);
@ -780,9 +776,94 @@ begin
FCellFormatList.Add(fmt);
end;
procedure TsSpreadBIFF5Reader.ReadFromStream(AStream: TStream);
var
OLEStream: TMemoryStream;
OLEStorage: TOLEStorage;
OLEDocument: TOLEDocument;
begin
OLEStream := TMemoryStream.Create;
try
OLEStorage := TOLEStorage.Create;
try
// Only one stream is necessary for any number of worksheets
OLEDocument.Stream := OLEStream;
OLEStorage.ReadOLEStream(AStream, OLEDocument, 'Book');
finally
OLEStorage.Free;
end;
InternalReadFromStream(OLEStream);
finally
OLEStream.Free;
end;
end;
(*
procedure TsSpreadBIFF5Reader.ReadFromStream(AStream: TStream);
var
BIFF5EOF: Boolean;
OLEStream: TMemoryStream;
OLEStorage: TOLEStorage;
OLEDocument: TOLEDocument;
begin
OLEStream := TMemoryStream.Create;
try
OLEStorage := TOLEStorage.Create;
try
// Only one stream is necessary for any number of worksheets
OLEDocument.Stream := OLEStream;
OLEStorage.ReadOLEStream(AStream, OLEDocument);
finally
OLEStorage.Free;
end;
// Check if the operation succeeded
if OLEStream.Size = 0 then
raise Exception.Create('[TsSpreadBIFF5Reader.ReadFromFile] Reading of OLE document failed');
// Rewind the stream and read from it
OLEStream.Position := 0;
{Initializations }
FWorksheetNames := TStringList.Create;
try
FCurrentWirksheet := 0;
BIFF5EOF := false;
{ Read workbook globals }
ReadWorkbookGlobals(OLEStream);
{ Check for the end of the file }
if OLEStream.Position >= AStream.Size then
BIFF5EOF := true;
{ Now read all worksheets }
while not BIFF5EOF do
begin
ReadWorksheet(OLEStream);
// Check for the end of the fild
if OLEStream.Position >= OLEStream.Size then
BIFF5EOF := true;
// Final preparations
inc(FCurrentWorksheet);
// It can happen in files written by Office97 that the OLE directory is
// at the end of the file.
if FCurrentWorksheet = FWorksheetNames.Count then
BIFF5EOF := true;
end;
finally
{ Finalization }
FreeAndNil(FWorksheetNames);
end;
finally
OLEStream.Free;
end;
end;
*)
(*
begin
{ Initializations }
@ -815,6 +896,7 @@ begin
{ Finalization }
FWorksheetNames.Free;
end;
*)
procedure TsSpreadBIFF5Reader.ReadFont(const AStream: TStream);
var
@ -1253,7 +1335,7 @@ begin
AStream.WriteWord(WordToLE(INT_FONT_WEIGHT_NORMAL));
{ Escapement type }
AStream.WriteWord(0);
AStream.WriteWord(WordToLE(ord(AFont.Position)));
{ Underline type }
if fssUnderline in AFont.Style then
@ -1369,12 +1451,16 @@ end;
procedure TsSpreadBIFF5Writer.WriteLabel(AStream: TStream; const ARow,
ACol: Cardinal; const AValue: string; ACell: PCell);
const
MAXBYTES = 255; //limit for this format
MAXBYTES = 255; // Limit for this BIFF5
var
L: Word;
AnsiValue: ansistring;
rec: TBIFF5_LabelRecord;
buf: array of byte;
useRTF: Boolean;
fmt: PsCellFormat;
run, j: Integer;
rtfRuns: TBiff5_RichTextformattingRuns;
begin
if (ARow >= FLimitations.MaxRowCount) or (ACol >= FLimitations.MaxColCount) then
exit;
@ -1401,9 +1487,40 @@ begin
end;
L := Length(AnsiValue);
useRTF := (Length(ACell^.RichTextParams) > 0);
{ BIFF record header }
rec.RecordID := WordToLE(INT_EXCEL_ID_LABEL);
rec.RecordSize := WordToLE(8 + L);
rec.RecordID := WordToLE(IfThen(useRTF, INT_EXCEL_ID_RSTRING, INT_EXCEL_ID_LABEL));
rec.RecordSize := WordToLE(SizeOf(rec) - SizeOf(TsBIFFHeader) + L);
{ Prepare rich-text formatting runs }
if useRTF then
begin
fmt := FWorkbook.GetPointerToCellFormat(ACell^.FormatIndex);
run := 0;
for j:=0 to High(ACell^.RichTextParams) do
begin
SetLength(rtfRuns, run + 1);
rtfRuns[run].FirstIndex := ACell^.RichTextParams[j].StartIndex;
rtfRuns[run].FontIndex := ACell^.RichTextParams[j].FontIndex;
if rtfRuns[run].FontIndex >= 4 then
inc(rtfRuns[run].FontIndex); // Font #4 does not exist in BIFF
inc(run);
if (ACell^.RichTextParams[j].EndIndex < L) and
(ACell^.RichTextParams[j].EndIndex <> ACell^.RichTextParams[j+1].StartIndex) // wp: j+1 needs to be checked!
then begin
SetLength(rtfRuns, run+1);
rtfRuns[run].FirstIndex := ACell^.RichTextParams[j].EndIndex;
rtfRuns[run].FontIndex := fmt^.FontIndex;
if rtfRuns[run].FontIndex >= 4 then
inc(rtfRuns[run].FontIndex);
inc(run);
end;
end;
// Adjust BIFF record size for appended formatting runs
inc(rec.RecordSize, SizeOf(byte) + run * SizeOf(TBiff5_RichTextFormattingRun));
end;
{ BIFF record data }
rec.Row := WordToLE(ARow);
@ -1416,15 +1533,25 @@ begin
rec.TextLen := WordToLE(L);
{ Copy the text characters into a buffer immediately after rec }
SetLength(buf, SizeOf(rec) + SizeOf(ansiChar)*L);
SetLength(buf, SizeOf(rec) + L);
Move(rec, buf[0], SizeOf(rec));
Move(AnsiValue[1], buf[SizeOf(rec)], L*SizeOf(ansiChar));
Move(AnsiValue[1], buf[SizeOf(rec)], L);
{ Write out }
AStream.WriteBuffer(buf[0], SizeOf(Rec) + SizeOf(ansiChar)*L);
{ Write out buffer }
AStream.WriteBuffer(buf[0], SizeOf(Rec) + L);
{ Write rich-text information in case of RSTRING record }
if useRTF then
begin
{ Write number of rich-text formatting runs }
AStream.WriteByte(run);
{ Write rich-text formatting runs }
AStream.WriteBuffer(rtfRuns[0], run * SizeOf(TBiff5_RichTextFormattingRun));
end;
{ Clean up }
SetLength(buf, 0);
SetLength(rtfRuns, 0);
end;
{@@ ----------------------------------------------------------------------------

1204
components/fpspreadsheet/xlsbiff8.pas
View File

File diff suppressed because it is too large Load Diff

89
components/fpspreadsheet/xlscommon.pas
View File

@ -353,6 +353,8 @@ type
FIncompleteNoteLength: Word;
FFirstNumFormatIndexInFile: Integer;
FPalette: TsPalette;
FWorksheetNames: TStrings;
FCurrentWorksheet: Integer;
procedure AddBuiltinNumFormats; override;
procedure ApplyCellFormatting(ACell: PCell; XFIndex: Word); virtual;
@ -437,6 +439,10 @@ type
procedure ReadVCENTER(AStream: TStream);
// Read WINDOW2 record (gridlines, sheet headers)
procedure ReadWindow2(AStream: TStream); virtual;
procedure ReadWorkbookGlobals(AStream: TStream); virtual;
procedure ReadWorksheet(AStream: TStream); virtual;
procedure InternalReadFromStream(AStream: TStream);
public
constructor Create(AWorkbook: TsWorkbook); override;
@ -946,10 +952,6 @@ end;
everything is known.
-------------------------------------------------------------------------------}
procedure TsSpreadBIFFReader.FixColors;
var
i: Integer;
fnt: TsFont;
fmt: PsCellFormat;
procedure FixColor(var AColor: TsColor);
begin
@ -957,7 +959,17 @@ var
AColor := FPalette[AColor and $00FFFFFF];
end;
var
i: Integer;
fnt: TsFont;
fmt: PsCellFormat;
begin
for i:=0 to FFontList.Count-1 do
begin
fnt := TsFont(FFontList[i]);
if fnt <> nil then FixColor(fnt.Color);
end;
for i:=0 to FWorkbook.GetFontCount - 1 do
begin
fnt := FWorkbook.GetFont(i);
@ -2254,6 +2266,17 @@ begin
FWorksheet.Options := FWorksheet.Options - [soHasFrozenPanes];
end;
{ Reads the workbook globals. }
procedure TsSpreadBIFFReader.ReadWorkbookGlobals(AStream: TStream);
begin
// To be overridden by BIFF5 and BIFF8
end;
procedure TsSpreadBIFFReader.ReadWorksheet(AStream: TStream);
begin
// To be overridden by BIFF5 and BIFF8
end;
{@@ ----------------------------------------------------------------------------
Populates the reader's palette by default colors. Will be overwritten if the
file contains a palette on its own
@ -2263,6 +2286,64 @@ begin
FPalette.AddBuiltinColors;
end;
procedure TsSpreadBIFFReader.InternalReadFromStream(AStream: TStream);
var
BIFFEOF: Boolean;
begin
{ OLEStream := TMemoryStream.Create;
try
OLEStorage := TOLEStorage.Create;
try
// Only one stream is necessary for any number of worksheets
OLEDocument.Stream := AStream; //OLEStream;
OLEStorage.ReadOLEStream(AStream, OLEDocument, AStreamName);
finally
OLEStorage.Free;
end;
}
// Check if the operation succeeded
if AStream.Size = 0 then
raise Exception.Create('[TsSpreadBIFFReader.InternalReadFromStream] Reading of OLE document failed');
// Rewind the stream and read from it
AStream.Position := 0;
{Initializations }
FWorksheetNames := TStringList.Create;
try
FCurrentWorksheet := 0;
BIFFEOF := false;
{ Read workbook globals }
ReadWorkbookGlobals(AStream);
{ Check for the end of the file }
if AStream.Position >= AStream.Size then
BIFFEOF := true;
{ Now read all worksheets }
while not BIFFEOF do
begin
ReadWorksheet(AStream);
// Check for the end of the file
if AStream.Position >= AStream.Size then
BIFFEOF := true;
// Final preparations
inc(FCurrentWorksheet);
// It can happen in files written by Office97 that the OLE directory is
// at the end of the file.
if FCurrentWorksheet = FWorksheetNames.Count then
BIFFEOF := true;
end;
finally
{ Finalization }
FreeAndNil(FWorksheetNames);
end;
end;
{------------------------------------------------------------------------------}
{ TsSpreadBIFFWriter }

328
components/fpspreadsheet/xlsxooxml.pas
View File

@ -130,7 +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 WriteFont(AStream: TStream; AFont: TsFont; UseInStyleNode: Boolean);
procedure WriteFontList(AStream: TStream);
procedure WriteHeaderFooter(AStream: TStream; AWorksheet: TsWorksheet);
procedure WriteHyperlinks(AStream: TStream; AWorksheet: TsWorksheet);
@ -749,9 +749,9 @@ begin
if (s1 <> '') and (s2 <> '0') then
begin
fnt := TsFont(FFontList.Items[StrToInt(s1)]);
fmt.FontIndex := Workbook.FindFont(fnt.FontName, fnt.Size, fnt.Style, fnt.Color);
fmt.FontIndex := Workbook.FindFont(fnt.FontName, fnt.Size, fnt.Style, fnt.Color, fnt.Position);
if fmt.FontIndex = -1 then
fmt.FontIndex := Workbook.AddFont(fnt.FontName, fnt.Size, fnt.Style, fnt.Color);
fmt.FontIndex := Workbook.AddFont(fnt.FontName, fnt.Size, fnt.Style, fnt.Color, fnt.Position);
if fmt.FontIndex > 0 then
Include(fmt.UsedFormattingFields, uffFont);
end;
@ -1065,9 +1065,8 @@ begin
end;
end;
{ 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. }
{ Reads the font described by the specified node and stores it in the reader's
FontList. }
function TsSpreadOOXMLReader.ReadFont(ANode: TDOMNode): Integer;
var
node: TDOMNode;
@ -1079,6 +1078,7 @@ var
fntPos: TsFontPosition;
nodename: String;
s: String;
acceptDuplicates: Boolean;
begin
fnt := Workbook.GetDefaultFont;
if fnt <> nil then
@ -1097,6 +1097,7 @@ begin
fntPos := fpNormal;
end;
acceptDuplicates := true;
node := ANode.FirstChild;
while node <> nil do
begin
@ -1105,6 +1106,7 @@ begin
begin
s := GetAttrValue(node, 'val');
if s <> '' then fntName := s;
if nodename = 'rFont' then acceptDuplicates := false;
end
else
if nodename = 'sz' then
@ -1115,26 +1117,26 @@ begin
else
if nodename = 'b' then
begin
if GetAttrValue(node, 'val') <> 'false'
then fntStyles := fntStyles + [fssBold];
if GetAttrValue(node, 'val') <> 'false' then
fntStyles := fntStyles + [fssBold];
end
else
if nodename = 'i' then
begin
if GetAttrValue(node, 'val') <> 'false'
then fntStyles := fntStyles + [fssItalic];
if GetAttrValue(node, 'val') <> 'false' then
fntStyles := fntStyles + [fssItalic];
end
else
if nodename = 'u' then
begin
if GetAttrValue(node, 'val') <> 'false'
then fntStyles := fntStyles+ [fssUnderline]
if GetAttrValue(node, 'val') <> 'false' then
fntStyles := fntStyles+ [fssUnderline]
end
else
if nodename = 'strike' then
begin
if GetAttrValue(node, 'val') <> 'false'
then fntStyles := fntStyles + [fssStrikeout];
if GetAttrValue(node, 'val') <> 'false' then
fntStyles := fntStyles + [fssStrikeout];
end
else
if nodename = 'vertAlign' then
@ -1154,20 +1156,26 @@ begin
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;
// If this method is called when reading the sharedstrings.xml duplicate
// fonts should not be added to the reader's fontList.
// As a function result we return the index of the already existing font.
if not acceptDuplicates then
for Result := 0 to FFontList.Count-1 do
begin
fnt := TsFont(FFontList[Result]);
if SameText(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
// Create a font record and store it in the reader's fontlist.
// In case of fonts in styles.xml (nodename = "name"), do no look for
// duplicates because this will screw up the font index
// used in the xf records
fnt := TsFont.Create;
fnt.FontName := fntName;
fnt.Size := fntSize;
@ -1812,9 +1820,13 @@ begin
FixRows(AWorksheet);
end;
procedure TsSpreadOOXMLReader.ReadFromFile(AFileName: string);
{ In principle, this method could be simplified by calling ReadFromStream which
is essentially a duplication of ReadFromFile. But ReadFromStream leads to
worse memory usage. --> KEEP READFROMFILE INTACT }
procedure TsSpreadOOXMLReader.ReadFromFile(AFilename: String);
var
Doc : TXMLDocument;
RelsNode: TDOMNode;
FilePath : string;
UnZip : TUnZipper;
FileList : TStringList;
@ -1822,6 +1834,7 @@ var
i: Integer;
fn: String;
fn_comments: String;
XMLStream: TStream;
begin
//unzip "content.xml" of "AFileName" to folder "FilePath"
FilePath := GetTempDir(false);
@ -1927,6 +1940,7 @@ begin
else
// this sheet does not have any cell comments
continue;
// Extract texts from the comments file found and apply to worksheet.
if fn_comments <> '' then
begin
@ -1939,6 +1953,7 @@ begin
FreeAndNil(Doc);
end;
end;
// Add hyperlinks to cells
ApplyHyperlinks(FWorksheet);
end; // for
@ -1948,13 +1963,173 @@ begin
end;
end;
procedure TsSpreadOOXMLReader.ReadFromStream(AStream: TStream);
var
Doc : TXMLDocument;
RelsNode: TDOMNode;
SheetList: TStringList;
i: Integer;
fn: String;
fn_comments: String;
XMLStream: TStream;
begin
Doc := nil;
SheetList := TStringList.Create;
try
// Retrieve theme colors
XMLStream := TMemoryStream.Create;
try
if UnzipToStream(AStream, OOXML_PATH_XL_THEME, XMLStream) then
begin
ReadXMLStream(Doc, XMLStream);
ReadThemeElements(Doc.DocumentElement.FindNode('a:themeElements'));
FreeAndNil(Doc);
end;
finally
XMLStream.Free;
end;
// process the workbook.xml file
XMLStream := TMemoryStream.Create;
try
if not UnzipToStream(AStream, OOXML_PATH_XL_WORKBOOK, XMLStream) then
raise Exception.CreateFmt(rsDefectiveInternalStructure, ['xlsx']);
ReadXMLStream(Doc, XMLStream);
ReadFileVersion(Doc.DocumentElement.FindNode('fileVersion'));
ReadDateMode(Doc.DocumentElement.FindNode('workbookPr'));
ReadSheetList(Doc.DocumentElement.FindNode('sheets'), SheetList);
FreeAndNil(Doc);
finally
XMLStream.Free;
end;
// process the styles.xml file
XMLStream := TMemoryStream.Create;
try
// Should always exist, just to make sure...
if UnzipToStream(AStream, OOXML_PATH_XL_STYLES, XMLStream) then
begin
ReadXMLStream(Doc, XMLStream);
ReadPalette(Doc.DocumentElement.FindNode('colors'));
ReadFonts(Doc.DocumentElement.FindNode('fonts'));
ReadFills(Doc.DocumentElement.FindNode('fills'));
ReadBorders(Doc.DocumentElement.FindNode('borders'));
ReadNumFormats(Doc.DocumentElement.FindNode('numFmts'));
ReadCellXfs(Doc.DocumentElement.FindNode('cellXfs'));
FreeAndNil(Doc);
end;
finally
XMLStream.Free;
end;
// process the sharedstrings.xml file
// To do: Use buffered stream instead since shared strings may be large
XMLStream := TMemoryStream.Create;
try
if UnzipToStream(AStream, OOXML_PATH_XL_STRINGS, XMLStream) then
begin
ReadXMLStream(Doc, XMLStream);
ReadSharedStrings(Doc.DocumentElement.FindNode('si'));
FreeAndNil(Doc);
end;
finally
XMLStream.Free;
end;
// read worksheets
for i:=0 to SheetList.Count-1 do begin
// Create worksheet
FWorksheet := FWorkbook.AddWorksheet(SheetList[i], true);
// unzip sheet file
XMLStream := TMemoryStream.Create;
try
fn := OOXML_PATH_XL_WORKSHEETS + Format('sheet%d.xml', [i+1]);
if not UnzipToStream(AStream, fn, XMLStream) then
Continue;
ReadXMLStream(Doc, XMLStream);
finally
XMLStream.Free;
end;
// Sheet data, formats, etc.
ReadSheetViews(Doc.DocumentElement.FindNode('sheetViews'), FWorksheet);
ReadSheetFormatPr(Doc.DocumentElement.FindNode('sheetFormatPr'), FWorksheet);
ReadCols(Doc.DocumentElement.FindNode('cols'), FWorksheet);
ReadWorksheet(Doc.DocumentElement.FindNode('sheetData'), FWorksheet);
ReadMergedCells(Doc.DocumentElement.FindNode('mergeCells'), FWorksheet);
ReadHyperlinks(Doc.DocumentElement.FindNode('hyperlinks'));
ReadPrintOptions(Doc.DocumentElement.FindNode('printOptions'), FWorksheet);
ReadPageMargins(Doc.DocumentElement.FindNode('pageMargins'), FWorksheet);
ReadPageSetup(Doc.DocumentElement.FindNode('pageSetup'), FWorksheet);
ReadHeaderFooter(Doc.DocumentElement.FindNode('headerFooter'), FWorksheet);
FreeAndNil(Doc);
{ Comments:
The comments are stored in separate "comments<n>.xml" files (n = 1, 2, ...)
The relationship which comment belongs to which sheet file must be
retrieved from the "sheet<n>.xml.rels" file (n = 1, 2, ...).
The rels file contains also the second part of the hyperlink data. }
fn := OOXML_PATH_XL_WORKSHEETS_RELS + Format('sheet%d.xml.rels', [i+1]);
XMLStream := TMemoryStream.Create;
try
if UnzipToStream(AStream, fn, XMLStream) then
begin
// Find exact name of comments<n>.xml file
ReadXMLStream(Doc, XMLStream);
RelsNode := Doc.DocumentElement.FindNode('Relationship');
fn_comments := FindCommentsFileName(RelsNode);
// Get hyperlink data
ReadHyperlinks(RelsNode);
FreeAndNil(Doc);
end else
if (SheetList.Count = 1) then
// If the workbook has only one sheet then the sheet.xml.rels file
// is missing
fn_comments := 'comments1.xml'
else
// This sheet does not have any cell comments at all
continue;
finally
XMLStream.Free;
end;
// Extract texts from the comments file found and apply to worksheet.
if fn_comments <> '' then
begin
fn := OOXML_PATH_XL + fn_comments;
XMLStream := TMemoryStream.Create;
try
if UnzipToStream(AStream, fn, XMLStream) then
begin
ReadXMLStream(Doc, XMLStream);
ReadComments(Doc.DocumentElement.FindNode('commentList'), FWorksheet);
FreeAndNil(Doc);
end;
finally
XMLStream.Free;
end;
end;
// Add hyperlinks to cells
ApplyHyperlinks(FWorksheet);
end; // for
finally
SheetList.Free;
FreeAndNil(Doc);
end;
end;
(*
procedure TsSpreadOOXMLReader.ReadFromStream(AStream: TStream);
begin
Unused(AStream);
raise Exception.Create('[TsSpreadOOXMLReader.ReadFromStream] '+
'Method not implemented. Use "ReadFromFile" instead.');
end;
*)
{------------------------------------------------------------------------------}
{ TsSpreadOOXMLWriter }
@ -2331,15 +2506,19 @@ end;
{ 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. }
richtext parameters in the shared string list.
ANameTag is "name" for the entry in "styles.xml", or "rFont" for the entry}
procedure TsSpreadOOXMLWriter.WriteFont(AStream: TStream; AFont: TsFont;
ATag: String);
UseInStyleNode: Boolean);
const
TAG: Array[boolean] of string = ('rPr', 'font');
NAME_TAG: Array[boolean] of String = ('rFont', 'name');
var
s: String;
begin
s := '';
s := s + Format('<sz val="%g" />', [AFont.Size], FPointSeparatorSettings);
s := s + Format('<name val="%s" />', [AFont.FontName]);
s := s + Format('<%s val="%s" />', [NAME_TAG[UseInStyleNode], AFont.FontName]);
if (fssBold in AFont.Style) then
s := s + '<b />';
if (fssItalic in AFont.Style) then
@ -2355,7 +2534,7 @@ begin
fpSuperscript: s := s + '<vertAlign val="superscript" />';
end;
AppendToStream(AStream, Format(
'<%s>%s</%s>', [ATag, s, ATag]));
'<%s>%s</%s>', [TAG[UseInStyleNode], s, TAG[UseInStyleNode]]));
end;
{ Writes the fontlist of the workbook to the stream. }
@ -2368,7 +2547,7 @@ begin
'<fonts count="%d">', [Workbook.GetFontCount]));
for i:=0 to Workbook.GetFontCount-1 do begin
font := Workbook.GetFont(i);
WriteFont(AStream, font, 'font');
WriteFont(AStream, font, true);
end;
AppendToStream(AStream,
'</fonts>');
@ -3601,13 +3780,19 @@ end;
procedure TsSpreadOOXMLWriter.WriteLabel(AStream: TStream; const ARow,
ACol: Cardinal; const AValue: string; ACell: PCell);
const
MAXBYTES = 32767; //limit for this format
MAXBYTES = 32767; // limit for this format
var
CellPosText: string;
lStyleIndex: Cardinal;
ResultingValue: string;
fnt: TsFont;
n: Integer;
i: Integer;
L: Integer;
rtParam: TsRichTextParam;
txt: String;
begin
// Office 2007-2010 (at least) support no more characters in a cell;
// Office 2007-2010 (at least) supports no more characters in a cell;
if Length(AValue) > MAXBYTES then
begin
ResultingValue := Copy(AValue, 1, MAXBYTES); //may chop off multicodepoint UTF8 characters but well...
@ -3618,16 +3803,79 @@ begin
else
ResultingValue := AValue;
if not ValidXMLText(ResultingValue) then
txt := ResultingValue;
if not ValidXMLText(txt) then
Workbook.AddErrorMsg(
rsInvalidCharacterInCell, [
GetCellString(ARow, ACol)
]);
AppendToStream(FSSharedStrings,
'<si>' +
'<t>' + ResultingValue + '</t>' +
'</si>');
{ Write string to SharedString table }
if Length(ACell^.RichTextParams) = 0 then
// unformatted string
AppendToStream(FSSharedStrings,
'<si>' +
'<t>' + txt + '</t>' +
'</si>')
else
begin
// rich-text formatted string
L := UTF8Length(Resultingvalue);
AppendToStream(FSSharedStrings,
'<si>');
rtParam := ACell^.RichTextParams[0];
if rtParam.StartIndex > 0 then
begin
txt := UTF8Copy(ResultingValue, 1, rtParam.StartIndex);
ValidXMLText(txt);
AppendToStream(FSSharedStrings,
'<r>' +
'<t>' + txt + '</t>' +
'</r>'
);
end;
for i := 0 to High(ACell^.RichTextParams) do
begin
rtParam := ACell^.RichTextParams[i];
fnt := FWorkbook.GetFont(rtParam.FontIndex);
n := rtParam.EndIndex - rtParam.StartIndex;
txt := UTF8Copy(Resultingvalue, rtParam.StartIndex+1, n);
ValidXMLText(txt);
AppendToStream(FSSharedStrings,
'<r>');
WriteFont(FSSharedStrings, fnt, false); // <rPr> ... font data ... </rPr>
AppendToStream(FSSharedStrings,
'<t>' + txt + '</t>' +
'</r>'
);
if (rtParam.EndIndex < L) and (i = High(ACell^.RichTextParams)) then
begin
txt := UTF8Copy(ResultingValue, rtParam.EndIndex+1, MaxInt);
ValidXMLText(txt);
AppendToStream(FSSharedStrings,
'<r>' +
'<t>' + txt + '</t>' +
'</r>'
)
end else
if (i < High(ACell^.RichTextParams)) and (rtParam.EndIndex < ACell^.RichTextParams[i+1].StartIndex)
then begin
n := ACell^.RichTextParams[i+1].StartIndex - rtParam.EndIndex;
txt := UTF8Copy(Resultingvalue, rtParam.EndIndex+1, n);
ValidXMLText(txt);
AppendToStream(FSSharedStrings,
'<r>' +
'<t>' + txt + '</t>' +
'</r>'
);
end;
end;
AppendToStream(FSSharedStrings,
'</si>');
end;
{ Write shared string index to cell record }
CellPosText := TsWorksheet.CellPosToText(ARow, ACol);
lStyleIndex := GetStyleIndex(ACell);