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

33
components/fpspreadsheet/fpolebasic.pas
View File

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

17
components/fpspreadsheet/fpsnumformatparser.pas
View File

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

325
components/fpspreadsheet/fpsopendocument.pas
View File

@ -149,6 +149,7 @@ type
private private
FColumnStyleList: TFPList; FColumnStyleList: TFPList;
FRowStyleList: TFPList; FRowStyleList: TFPList;
FRichTextFontList: TStringList;
FHeaderFooterFontList: TObjectList; FHeaderFooterFontList: TObjectList;
// Routines to write parts of files // Routines to write parts of files
@ -163,6 +164,7 @@ type
procedure WriteRowsAndCells(AStream: TStream; ASheet: TsWorksheet); procedure WriteRowsAndCells(AStream: TStream; ASheet: TsWorksheet);
procedure WriteTableSettings(AStream: TStream); procedure WriteTableSettings(AStream: TStream);
procedure WriteTableStyles(AStream: TStream); procedure WriteTableStyles(AStream: TStream);
procedure WriteTextStyles(AStream: TStream);
procedure WriteVirtualCells(AStream: TStream; ASheet: TsWorksheet); procedure WriteVirtualCells(AStream: TStream; ASheet: TsWorksheet);
function WriteBackgroundColorStyleXMLAsString(const AFormat: TsCellFormat): String; function WriteBackgroundColorStyleXMLAsString(const AFormat: TsCellFormat): String;
@ -232,7 +234,7 @@ type
implementation implementation
uses uses
StrUtils, Variants, LazFileUtils, URIParser, StrUtils, Variants, LazFileUtils, URIParser, LazUTF8,
{$IFDEF FPS_VARISBOOL} {$IFDEF FPS_VARISBOOL}
fpsPatches, fpsPatches,
{$ENDIF} {$ENDIF}
@ -958,7 +960,7 @@ end;
The function result is false if a style with the given name could not be found } The function result is false if a style with the given name could not be found }
function TsSpreadOpenDocReader.ApplyStyleToCell(ACell: PCell; AStyleName: String): Boolean; function TsSpreadOpenDocReader.ApplyStyleToCell(ACell: PCell; AStyleName: String): Boolean;
var var
fmt: PsCellFormat; fmt: TsCellFormat;
styleIndex: Integer; styleIndex: Integer;
i: Integer; i: Integer;
begin begin
@ -980,8 +982,14 @@ begin
exit; exit;
styleIndex := TColumnData(FColumnList[i]).DefaultCellStyleIndex; styleIndex := TColumnData(FColumnList[i]).DefaultCellStyleIndex;
end; end;
fmt := FCellFormatList.Items[styleIndex]; fmt := FCellFormatList.Items[styleIndex]^;
ACell^.FormatIndex := FWorkbook.AddCellFormat(fmt^); 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; Result := true;
end; end;
@ -1660,7 +1668,9 @@ var
fntSize: Single; fntSize: Single;
fntStyles: TsFontStyles; fntStyles: TsFontStyles;
fntColor: TsColor; fntColor: TsColor;
fntPosition: TsFontPosition;
s: String; s: String;
p: Integer;
begin begin
if ANode = nil then if ANode = nil then
begin begin
@ -1687,9 +1697,20 @@ begin
if not ((s = '') or (s = 'none')) then if not ((s = '') or (s = 'none')) then
Include(fntStyles, fssUnderline); Include(fntStyles, fssUnderline);
s := GetAttrValue(ANode, 'style:text-line-through-style'); 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 if not ((s = '') or (s = 'none')) then
Include(fntStyles, fssStrikeout); 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'); s := GetAttrValue(ANode, 'fo:color');
if s <> '' then if s <> '' then
fntColor := HTMLColorStrToColor(s) fntColor := HTMLColorStrToColor(s)
@ -1703,13 +1724,13 @@ begin
end else end else
if (APreferredIndex > -1) then if (APreferredIndex > -1) then
begin begin
FWorkbook.ReplaceFont(APreferredIndex, fntName, fntSize, fntStyles, fntColor); FWorkbook.ReplaceFont(APreferredIndex, fntName, fntSize, fntStyles, fntColor, fntPosition);
Result := APreferredIndex; Result := APreferredIndex;
end else end else
begin begin
Result := FWorkbook.FindFont(fntName, fntSize, fntStyles, fntColor); Result := FWorkbook.FindFont(fntName, fntSize, fntStyles, fntColor, fntPosition);
if Result = -1 then if Result = -1 then
Result := FWorkbook.AddFont(fntName, fntSize, fntStyles, fntColor); Result := FWorkbook.AddFont(fntName, fntSize, fntStyles, fntColor, fntPosition);
end; end;
end; end;
@ -1825,6 +1846,10 @@ begin
Workbook.OnReadCellData(Workbook, ARow, ACol, cell); Workbook.OnReadCellData(Workbook, ARow, ACol, cell);
end; 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); procedure TsSpreadOpenDocReader.ReadFromFile(AFileName: string);
var var
Doc : TXMLDocument; Doc : TXMLDocument;
@ -1935,12 +1960,132 @@ begin
end; end;
procedure TsSpreadOpenDocReader.ReadFromStream(AStream: TStream); 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 begin
Unused(AStream); Unused(AStream);
raise Exception.Create('[TsSpreadOpenDocReader.ReadFromStream] '+ raise Exception.Create('[TsSpreadOpenDocReader.ReadFromStream] '+
'Method not implemented. Use "ReadFromFile" instead.'); 'Method not implemented. Use "ReadFromFile" instead.');
end; end;
}
procedure TsSpreadOpenDocReader.ReadHeaderFooterFont(ANode: TDOMNode; procedure TsSpreadOpenDocReader.ReadHeaderFooterFont(ANode: TDOMNode;
var AFontName: String; var AFontSize: Double; var AFontName: String; var AFontSize: Double;
var AFontStyle: TsHeaderFooterFontStyles; var AFontColor: TsColor); var AFontStyle: TsHeaderFooterFontStyles; var AFontColor: TsColor);
@ -1998,13 +2143,16 @@ end;
procedure TsSpreadOpenDocReader.ReadLabel(ARow, ACol: Cardinal; procedure TsSpreadOpenDocReader.ReadLabel(ARow, ACol: Cardinal;
ACellNode: TDOMNode); ACellNode: TDOMNode);
var var
cellText: String; cellText, spanText: String;
styleName: String; styleName: String;
childnode: TDOMNode; childnode: TDOMNode;
subnode: TDOMNode; subnode: TDOMNode;
nodeName: String; nodeName: String;
cell: PCell; cell: PCell;
hyperlink: string; hyperlink: string;
fmt: TsCellFormat;
rtParams: TsRichTextParams;
idx: Integer;
procedure AddToCellText(AText: String); procedure AddToCellText(AText: String);
begin begin
@ -2020,6 +2168,7 @@ begin
like below is much better: } like below is much better: }
cellText := ''; cellText := '';
hyperlink := ''; hyperlink := '';
SetLength(rtParams, 0);
childnode := ACellNode.FirstChild; childnode := ACellNode.FirstChild;
while Assigned(childnode) do while Assigned(childnode) do
begin begin
@ -2041,7 +2190,21 @@ begin
AddToCellText(subnode.TextContent); AddToCellText(subnode.TextContent);
end; end;
'text:span': '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; end;
subnode := subnode.NextSibling; subnode := subnode.NextSibling;
end; end;
@ -2056,7 +2219,7 @@ begin
end else end else
cell := FWorksheet.AddCell(ARow, ACol); cell := FWorksheet.AddCell(ARow, ACol);
FWorkSheet.WriteUTF8Text(cell, cellText); FWorkSheet.WriteUTF8Text(cell, cellText, rtParams);
if hyperlink <> '' then if hyperlink <> '' then
begin begin
// ODS sees relative paths relative to the internal own file structure // ODS sees relative paths relative to the internal own file structure
@ -2917,6 +3080,7 @@ var
nodeName: String; nodeName: String;
family: String; family: String;
styleName: String; styleName: String;
parentstyle: String;
fmt: TsCellFormat; fmt: TsCellFormat;
numFmtIndexDefault: Integer; numFmtIndexDefault: Integer;
numFmtName: String; numFmtName: String;
@ -2925,6 +3089,7 @@ var
numFmtParams: TsNumFormatParams; numFmtParams: TsNumFormatParams;
clr: TsColor; clr: TsColor;
s: String; s: String;
idx: Integer;
procedure SetBorderStyle(ABorder: TsCellBorder; AStyleValue: String); procedure SetBorderStyle(ABorder: TsCellBorder; AStyleValue: String);
const const
@ -3013,6 +3178,7 @@ begin
if nodeName = 'style:style' then if nodeName = 'style:style' then
begin begin
family := GetAttrValue(styleNode, 'style:family'); family := GetAttrValue(styleNode, 'style:family');
parentstyle := GetAttrValue(stylenode, 'style:parent-style-name');
// Column styles // Column styles
if family = 'table-column' then if family = 'table-column' then
@ -3028,6 +3194,13 @@ begin
styleName := GetAttrValue(styleNode, 'style:name'); styleName := GetAttrValue(styleNode, 'style:name');
InitFormatRecord(fmt); InitFormatRecord(fmt);
if parentstyle <> '' then
begin
idx := FCellFormatList.FindIndexOfName(parentstyle);
if idx > -1 then
fmt := FCellFormatList[idx]^;
end;
fmt.Name := styleName; fmt.Name := styleName;
numFmtIndex := -1; numFmtIndex := -1;
@ -3173,8 +3346,28 @@ begin
end; end;
styleChildNode := styleChildNode.NextSibling; styleChildNode := styleChildNode.NextSibling;
end; end;
FCellFormatList.Add(fmt); 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;
end; end;
styleNode := styleNode.NextSibling; styleNode := styleNode.NextSibling;
@ -3410,6 +3603,9 @@ begin
FSMetaInfManifest.Position := 0; FSMetaInfManifest.Position := 0;
end; 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); procedure TsSpreadOpenDocWriter.WriteAutomaticStyles(AStream: TStream);
var var
i: Integer; i: Integer;
@ -3640,11 +3836,12 @@ begin
AppendToStream(FSContent, AppendToStream(FSContent,
'<office:automatic-styles>'); '<office:automatic-styles>');
WriteNumFormats(FSContent); WriteNumFormats(FSContent); // "N1" ...
WriteColStyles(FSContent); WriteColStyles(FSContent); // "co1" ...
WriteRowStyles(FSContent); WriteRowStyles(FSContent); // "ro1" ...
WriteTableStyles(FSContent); WriteTableStyles(FSContent); // "ta1" ...
WriteCellStyles(FSContent); WriteCellStyles(FSContent); // "ce1" ...
WriteTextStyles(FSContent); // "T1" ...
AppendToStream(FSContent, AppendToStream(FSContent,
'</office:automatic-styles>'); '</office:automatic-styles>');
@ -4221,6 +4418,7 @@ begin
FColumnStyleList := TFPList.Create; FColumnStyleList := TFPList.Create;
FRowStyleList := TFPList.Create; FRowStyleList := TFPList.Create;
FRichTextFontList := TStringList.Create;
FHeaderFooterFontList := TObjectList.Create; FHeaderFooterFontList := TObjectList.Create;
FPointSeparatorSettings := SysUtils.DefaultFormatSettings; FPointSeparatorSettings := SysUtils.DefaultFormatSettings;
@ -4242,6 +4440,7 @@ begin
for j:=FRowStyleList.Count-1 downto 0 do TObject(FRowStyleList[j]).Free; for j:=FRowStyleList.Count-1 downto 0 do TObject(FRowStyleList[j]).Free;
FRowStyleList.Free; FRowStyleList.Free;
FRichTextFontList.Free; // Do not destroy fonts, they are owned by Workbook
FHeaderFooterFontList.Free; FHeaderFooterFontList.Free;
inherited Destroy; inherited Destroy;
@ -4614,6 +4813,12 @@ begin
if fssStrikeout in AFont.Style then if fssStrikeout in AFont.Style then
Result := Result + 'style:text-line-through-style="solid" '; 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 if AFont.Color <> defFnt.Color then
Result := Result + Format('fo:color="%s" ', [ColorToHTMLColorStr(AFont.Color)]); Result := Result + Format('fo:color="%s" ', [ColorToHTMLColorStr(AFont.Color)]);
end; end;
@ -4879,9 +5084,44 @@ begin
end; end;
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. written file from the textrotation setting in the format cell.
Is called from WriteStyles (via WriteStylesXMLAsString). Is called from WriteStyles (via WriteStylesXMLAsString).
-------------------------------------------------------------------------------} -------------------------------------------------------------------------------}
@ -5196,8 +5436,11 @@ var
txt: ansistring; txt: ansistring;
textp, target, bookmark, comment: String; textp, target, bookmark, comment: String;
fmt: TsCellFormat; fmt: TsCellFormat;
fnt: TsFont;
hyperlink: PsHyperlink; hyperlink: PsHyperlink;
u: TUri; u: TUri;
i, idx, n, len: Integer;
rtParam: TsRichTextParam;
begin begin
Unused(ARow, ACol); Unused(ARow, ACol);
@ -5254,8 +5497,52 @@ begin
'</text:p>', [target, txt]); '</text:p>', [target, txt]);
end else end else
begin
// No hyperlink, normal text only // 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 ... // Write it ...
AppendToStream(AStream, Format( AppendToStream(AStream, Format(

74
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 Unit fpspreadsheet implements <b>spreadsheet documents</b> and their
properties and methods. properties and methods.
@ -31,6 +42,18 @@ type
TsBasicSpreadReader = class; TsBasicSpreadReader = class;
TsBasicSpreadWriter = 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: {@@ The record TRow contains information about a spreadsheet row:
@param Row The index of the row (beginning with 0) @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) @param Height The height of the row (expressed as lines count of the default font)
@ -239,9 +262,10 @@ type
procedure WriteRPNFormula(ACell: PCell; procedure WriteRPNFormula(ACell: PCell;
AFormula: TsRPNFormula); overload; AFormula: TsRPNFormula); overload;
function WriteUTF8Text(ARow, ACol: Cardinal; AText: ansistring): PCell; overload; function WriteUTF8Text(ARow, ACol: Cardinal; AText: ansistring;
// procedure WriteUTF8Text(ACell: PCell; AText: ansistring); overload; ARichTextParams: TsRichTextParams = nil): PCell; overload;
procedure WriteUTF8Text(ACell: PCell; AText: String; ARichTextparams: TsRichTextParams = nil); overload; procedure WriteUTF8Text(ACell: PCell; AText: String;
ARichTextparams: TsRichTextParams = nil); overload;
{ Writing of cell attributes } { Writing of cell attributes }
function WriteBackground(ARow, ACol: Cardinal; AStyle: TsFillStyle; function WriteBackground(ARow, ACol: Cardinal; AStyle: TsFillStyle;
@ -890,9 +914,9 @@ begin
end; end;
{******************************************************************************* {------------------------------------------------------------------------------}
* TsWorksheet * { TsWorksheet }
*******************************************************************************} {------------------------------------------------------------------------------}
{@@ ---------------------------------------------------------------------------- {@@ ----------------------------------------------------------------------------
Constructor of the TsWorksheet class. Constructor of the TsWorksheet class.
@ -3464,12 +3488,19 @@ end;
@param ARow The row of the cell @param ARow The row of the cell
@param ACol The column of the cell @param ACol The column of the cell
@param AText The text to be written encoded in utf-8 @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 @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 begin
Result := GetCell(ARow, ACol); Result := GetCell(ARow, ACol);
WriteUTF8Text(Result, AText); WriteUTF8Text(Result, AText, ARichTextParams);
end; end;
{@@ ---------------------------------------------------------------------------- {@@ ----------------------------------------------------------------------------
@ -3480,6 +3511,11 @@ end;
@param ACell Pointer to the cell @param ACell Pointer to the cell
@param AText The text to be written encoded in utf-8 @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; procedure TsWorksheet.WriteUTF8Text(ACell: PCell; AText: String;
ARichTextParams: TsRichTextParams = nil); ARichTextParams: TsRichTextParams = nil);
@ -3537,6 +3573,7 @@ end;
@param ARow Cell row index @param ARow Cell row index
@param ACol Cell column index @param ACol Cell column index
@param ANumber Number to be written @param ANumber Number to be written
@return Pointer to cell created or used @return Pointer to cell created or used
-------------------------------------------------------------------------------} -------------------------------------------------------------------------------}
function TsWorksheet.WriteNumber(ARow, ACol: Cardinal; ANumber: double): PCell; function TsWorksheet.WriteNumber(ARow, ACol: Cardinal; ANumber: double): PCell;
@ -6032,9 +6069,9 @@ begin
end; end;
{******************************************************************************* {------------------------------------------------------------------------------}
* TsWorkbook * { TsWorkbook }
*******************************************************************************} {------------------------------------------------------------------------------}
{@@ ---------------------------------------------------------------------------- {@@ ----------------------------------------------------------------------------
Helper method called before reading the workbook. Clears the error log. Helper method called before reading the workbook. Clears the error log.
@ -7664,9 +7701,9 @@ begin
end; end;
*) *)
{******************************************************************************* {------------------------------------------------------------------------------}
* TsBasicSpreadReaderWriter * { TsBasicSpreadReaderWriter }
*******************************************************************************} {------------------------------------------------------------------------------}
{@@ ---------------------------------------------------------------------------- {@@ ----------------------------------------------------------------------------
Constructor of the reader/writer. Has the workbook to be read/written as a Constructor of the reader/writer. Has the workbook to be read/written as a
@ -7696,9 +7733,9 @@ begin
end; end;
{******************************************************************************* {------------------------------------------------------------------------------}
* TsBasicSpreadWriter * { TsBasicSpreadWriter }
*******************************************************************************} {------------------------------------------------------------------------------}
{@@ ---------------------------------------------------------------------------- {@@ ----------------------------------------------------------------------------
Checks limitations of the writer, e.g max row/column count Checks limitations of the writer, e.g max row/column count
@ -7724,5 +7761,4 @@ initialization
finalization finalization
SetLength(GsSpreadFormats, 0); 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; fpCanvas, fpsStrings, fpsUtils, fpsVisualUtils, fpsNumFormat;
const 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 number of columns prepared for a new empty worksheet }
DEFAULT_COL_COUNT = 26; DEFAULT_COL_COUNT = 26;
{@@ Default number of rows prepared for a new empty worksheet } {@@ Default number of rows prepared for a new empty worksheet }
@ -2100,7 +2089,7 @@ var
txtRot: TsTextRotation; txtRot: TsTextRotation;
fntIndex: Integer; fntIndex: Integer;
lCell: PCell; lCell: PCell;
justif: Byte; // justif: Byte;
fmt: PsCellFormat; fmt: PsCellFormat;
begin begin
if (Worksheet = nil) then if (Worksheet = nil) then
@ -2169,7 +2158,7 @@ begin
txt := GetCellText(GetGridRow(lCell^.Col), GetGridCol(lCell^.Row)); txt := GetCellText(GetGridRow(lCell^.Col), GetGridCol(lCell^.Row));
if txt = '' then if txt = '' then
exit; exit;
{
case txtRot of case txtRot of
trHorizontal: trHorizontal:
case horAlign of case horAlign of
@ -2190,7 +2179,7 @@ begin
vaCenter: justif := 1; vaCenter: justif := 1;
vaBottom: justif := 0; vaBottom: justif := 0;
end; end;
end; end; }
InternalDrawTextInCell(txt, ARect, horAlign, vertAlign, txtRot, wrapped, InternalDrawTextInCell(txt, ARect, horAlign, vertAlign, txtRot, wrapped,
fntIndex, lCell^.RichTextParams); fntIndex, lCell^.RichTextParams);
{ {

4
components/fpspreadsheet/fpstypes.pas
View File

@ -404,7 +404,7 @@ type
TsFontStyles = set of TsFontStyle; TsFontStyles = set of TsFontStyle;
{@@ Font position (subscript or superscript) } {@@ 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 {@@ Font record used in fpspreadsheet. Contains the font name, the font size
(in points), the font style, and the font color. } (in points), the font style, and the font color. }
@ -432,7 +432,7 @@ type
TsRichTextParams = array of TsRichTextParam; TsRichTextParams = array of TsRichTextParam;
{@@ Excel rich-text formatting run } {@@ Excel rich-text formatting run }
TsRichTextFormattingRun = record TsRichTextFormattingRun = packed record
FirstIndex: Integer; FirstIndex: Integer;
FontIndex: Integer; FontIndex: Integer;
end; end;

22
components/fpspreadsheet/fpsvisualutils.pas
View File

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

118
components/fpspreadsheet/fpsxmlcommon.pas
View File

@ -16,12 +16,15 @@ type
TsSpreadXMLReader = class(TsCustomSpreadReader) TsSpreadXMLReader = class(TsCustomSpreadReader)
protected protected
procedure ReadXMLFile(out ADoc: TXMLDocument; AFileName: String); procedure ReadXMLFile(out ADoc: TXMLDocument; AFileName: String);
procedure ReadXMLStream(out ADoc: TXMLDocument; AStream: TStream);
end; end;
function GetAttrValue(ANode : TDOMNode; AAttrName : string) : string; function GetAttrValue(ANode : TDOMNode; AAttrName : string) : string;
function GetNodeValue(ANode: TDOMNode): 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 implementation
@ -33,9 +36,13 @@ uses
{$ENDIF} {$ENDIF}
fpsStreams; fpsStreams;
{ Gets value for the specified attribute. Returns empty string if attribute {------------------------------------------------------------------------------}
not found. } { Utilities }
function {TsSpreadXMLReader.}GetAttrValue(ANode : TDOMNode; AAttrName : string) : string; {------------------------------------------------------------------------------}
{ 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 var
i: LongWord; i: LongWord;
Found: Boolean; Found: Boolean;
@ -58,7 +65,7 @@ end;
{ Returns the text value of a node. Normally it would be sufficient to call { 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 "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. } (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 var
child: TDOMNode; child: TDOMNode;
begin begin
@ -68,25 +75,99 @@ begin
Result := child.NodeValue; Result := child.NodeValue;
end; 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) { 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. 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. } As a side-effect we have to skip leading spaces by ourselves. }
procedure TsSpreadXMLReader.ReadXMLFile(out ADoc: TXMLDocument; AFileName: String); procedure TsSpreadXMLReader.ReadXMLFile(out ADoc: TXMLDocument; AFileName: String);
var var
parser: TDOMParser;
src: TXMLInputSource;
stream: TStream; stream: TStream;
begin begin
if (boBufStream in Workbook.Options) then if (boBufStream in Workbook.Options) then
stream := TBufStream.Create(AFileName, fmOpenRead + fmShareDenyWrite) stream := TBufStream.Create(AFilename, fmOpenRead + fmShareDenyWrite)
else else
stream := TFileStream.Create(AFileName, fmOpenRead + fmShareDenyWrite); stream := TFileStream.Create(AFileName, fmOpenRead + fmShareDenyWrite);
try try
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; parser := TDOMParser.Create;
try try
parser.Options.PreserveWhiteSpace := true; // This preserves spaces! parser.Options.PreserveWhiteSpace := true; // This preserves spaces!
src := TXMLInputSource.Create(stream); src := TXMLInputSource.Create(AStream);
try try
parser.Parse(src, ADoc); parser.Parse(src, ADoc);
finally finally
@ -95,9 +176,6 @@ begin
finally finally
parser.Free; parser.Free;
end; end;
finally
stream.Free;
end;
end; end;
procedure UnzipFile(AZipFileName, AZippedFile, ADestFolder: String); procedure UnzipFile(AZipFileName, AZippedFile, ADestFolder: String);
@ -121,5 +199,21 @@ begin
end; 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. end.

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

@ -101,6 +101,7 @@ type
procedure ShowRefreshAll; procedure ShowRefreshAll;
procedure ShowRightMargin; procedure ShowRightMargin;
procedure ShowRK; procedure ShowRK;
procedure ShowRString;
procedure ShowRow; procedure ShowRow;
procedure ShowSelection; procedure ShowSelection;
procedure ShowSharedFormula; procedure ShowSharedFormula;
@ -132,7 +133,12 @@ type
ACharCount: Integer; out AString: String; out ANumbytes: Integer); overload; ACharCount: Integer; out AString: String; out ANumbytes: Integer); overload;
procedure ExtractString(ABufIndex: Integer; ALenBytes: Byte; AUnicode: Boolean; procedure ExtractString(ABufIndex: Integer; ALenBytes: Byte; AUnicode: Boolean;
out AString: String; out ANumBytes: Integer; out AString: String; out ANumBytes: Integer;
out ARichTextRuns: TsRichTextFormattingRuns;
out ABufIndexOfFirstRichTextRun: LongWord;
IgnoreCompressedFlag: Boolean = false); overload; 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 PopulateGrid;
procedure ShowInRow(var ARow: Integer; var AOffs: LongWord; ASize: Word; procedure ShowInRow(var ARow: Integer; var AOffs: LongWord; ASize: Word;
AValue,ADescr: String; ADescrOnly: Boolean = false); 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 The string is assumed to be a UTF16 string if AUnicode=true, otherwise it is
an ansi string. } an ansi string. }
procedure TBIFFGrid.ExtractString(ABufIndex: Integer; AUnicode: Boolean; procedure TBIFFGrid.ExtractString(ABufIndex: Integer; AUnicode: Boolean;
ACharCount: Integer;out AString: String; out ANumbytes: Integer); ACharCount: Integer; out AString: String; out ANumbytes: Integer);
var var
sa: AnsiString; sa: AnsiString;
sw: WideString; sw: WideString;
@ -265,7 +271,21 @@ begin
end; end;
procedure TBIFFGrid.ExtractString(ABufIndex: Integer; ALenBytes: Byte; AUnicode: Boolean; 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 var
ls: Integer; // Character count of string ls: Integer; // Character count of string
w: Word; w: Word;
@ -273,9 +293,14 @@ var
optn: Byte; optn: Byte;
n: Integer; // Byte count in string character array n: Integer; // Byte count in string character array
asianPhoneticBytes: DWord; asianPhoneticBytes: DWord;
richRuns: Word; numRichRuns: Word;
offs: Integer; offs: Integer;
rtfBufIndex: Int64;
rtfIndex: Integer;
begin begin
ABufIndexOfFirstRichTextRun := LongWord(-1);
SetLength(ARichTextRuns, 0);
if Length(FBuffer) = 0 then begin if Length(FBuffer) = 0 then begin
AString := ''; AString := '';
ANumBytes := 0; ANumBytes := 0;
@ -291,13 +316,16 @@ begin
offs := ALenBytes; offs := ALenBytes;
optn := FBuffer[ABufIndex + ALenBytes]; optn := FBuffer[ABufIndex + ALenBytes];
inc(offs, 1); inc(offs, 1);
if optn and $08 <> 0 then // rich text if optn and $08 <> 0 then // rich text
begin begin
Move(FBuffer[ABufIndex + offs], w, 2); Move(FBuffer[ABufIndex + offs], w, 2);
richRuns := WordLEToN(w); numRichRuns := WordLEToN(w);
inc(offs, 2); inc(offs, 2);
end else end else
richRuns := 0; numRichRuns := 0;
SetLength(ARichTextRuns, numRichRuns);
if optn and $04 <> 0 then // Asian phonetic if optn and $04 <> 0 then // Asian phonetic
begin begin
Move(FBuffer[ABufIndex + offs], dw, 4); Move(FBuffer[ABufIndex + offs], dw, 4);
@ -305,16 +333,31 @@ begin
inc(offs, 4); inc(offs, 4);
end else end else
asianPhoneticBytes := 0; asianPhoneticBytes := 0;
if (optn and $01 = 0) and (not IgnoreCompressedFlag) then if (optn and $01 = 0) and (not IgnoreCompressedFlag) then
// compressed --> 1 byte per character // compressed --> 1 byte per character
ExtractString(ABufIndex + offs, false, ls, AString, n) ExtractString(ABufIndex + offs, false, ls, AString, n)
else else
// non-compressed unicode // non-compressed unicode
ExtractString(ABufIndex + offs, true, ls, AString, n); 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 end else
begin begin
// ansi string // ansi string
SetLength(ARichTextRuns, 0); // no rich text formatting for ansi strings
ExtractString(ABufIndex + ALenBytes, false, ls, AString, n); ExtractString(ABufIndex + ALenBytes, false, ls, AString, n);
ANumbytes := ALenBytes + n; ANumbytes := ALenBytes + n;
end; end;
@ -471,6 +514,8 @@ begin
ShowMulBlank; ShowMulBlank;
$00BD: $00BD:
ShowMulRK; ShowMulRK;
$00D6:
ShowRString;
$00D7: $00D7:
ShowDBCell; ShowDBCell;
$00DA: $00DA:
@ -1235,12 +1280,14 @@ var
sa: ansistring; sa: ansistring;
sw: widestring; sw: widestring;
ls: Integer; ls: Integer;
i: Integer; i, j: Integer;
w: Word; w: Word;
n: Integer; n: Integer;
run: Integer; run: Integer;
total2: Integer; total2: Integer;
optn: Byte; optn: Byte;
rtfRuns: TsRichTextFormattingRuns;
rtfBufferIndex: LongWord;
begin begin
case FInfo of case FInfo of
BIFFNODE_TXO_CONTINUE1: BIFFNODE_TXO_CONTINUE1:
@ -1345,9 +1392,20 @@ begin
for i:=FCounterSST+1 to FTotalSST do for i:=FCounterSST+1 to FTotalSST do
begin begin
FCounterSST := i; 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])); ShowInRow(FCurrRow, FBufferIndex, numBytes, s, Format('Shared string #%d', [i]));
inc(n); 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 if FPendingCharCount > 0 then
begin begin
FInfo := BIFFNODE_SST_CONTINUE; FInfo := BIFFNODE_SST_CONTINUE;
@ -1838,6 +1896,7 @@ var
ansiStr: AnsiString; ansiStr: AnsiString;
s: String; s: String;
i, n: Integer; i, n: Integer;
rtfRuns: TsRichTextFormattingRuns;
begin begin
BeginUpdate; BeginUpdate;
RowCount := FixedRows + 1000; RowCount := FixedRows + 1000;
@ -2112,7 +2171,7 @@ begin
numBytes := 2; numBytes := 2;
Move(FBuffer[FBufferIndex], w, numBytes); Move(FBuffer[FBufferIndex], w, numBytes);
w := WordLEToN(w); w := WordLEToN(w);
ShowInRow(FCurrRow, FBufferIndex, numBytes, IntToStr(2), 'Color index'); ShowInRow(FCurrRow, FBufferIndex, numBytes, IntToStr(w), 'Color index');
numBytes := 2; numBytes := 2;
Move(FBuffer[FBufferIndex], w, numBytes); Move(FBuffer[FBufferIndex], w, numBytes);
@ -3309,6 +3368,7 @@ begin
'Index to XF record'); 'Index to XF record');
end; end;
// Called for LABEL
procedure TBIFFGrid.ShowLabelCell; procedure TBIFFGrid.ShowLabelCell;
var var
numBytes: Integer; numBytes: Integer;
@ -4997,6 +5057,72 @@ begin
end; 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; procedure TBIFFGrid.ShowSelection;
var var
numBytes: Integer; numBytes: Integer;
@ -5195,7 +5321,10 @@ var
numBytes: Integer; numBytes: Integer;
s: String; s: String;
total1, total2: DWord; total1, total2: DWord;
i, n: Integer; i, j, n: Integer;
rtfRuns: TsRichTextFormattingRuns;
rtfIndex: LongWord;
w: Word;
begin begin
numBytes := 4; numBytes := 4;
Move(FBuffer[FBufferIndex], total1, numBytes); Move(FBuffer[FBufferIndex], total1, numBytes);
@ -5204,7 +5333,7 @@ begin
total2 := DWordLEToN(total2); total2 := DWordLEToN(total2);
FTotalSST := total2; FTotalSST := total2;
RowCount := FixedRows + 2 + total2; RowCount := FixedRows + 1000;
ShowInRow(FCurrRow, FBufferIndex, numBytes, IntToStr(total1), ShowInRow(FCurrRow, FBufferIndex, numBytes, IntToStr(total1),
'Total number of shared strings in the workbook'); 'Total number of shared strings in the workbook');
@ -5215,10 +5344,22 @@ begin
n := 0; n := 0;
for i:=1 to FTotalSST do begin for i:=1 to FTotalSST do begin
FCounterSST := i; 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); inc(n);
if FPendingCharCount = 0 then if FPendingCharCount = 0 then begin
ShowInRow(FCurrRow, FBufferIndex, numBytes, s, Format('Shared string #%d', [i])) 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 else
begin begin
ShowInRow(FCurrRow, FBufferIndex, numbytes, s, Format('Shared string #%d - partial (--> CONTINUE)', [i])); 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 }
TsSpreadBIFF5Reader = class(TsSpreadBIFFReader) TsSpreadBIFF5Reader = class(TsSpreadBIFFReader)
private
FWorksheetNames: TStringList;
FCurrentWorksheet: Integer;
protected protected
procedure PopulatePalette; override; procedure PopulatePalette; override;
{ Record writing methods } { Record writing methods }
@ -83,15 +80,15 @@ type
procedure ReadFONT(const AStream: TStream); procedure ReadFONT(const AStream: TStream);
procedure ReadFORMAT(AStream: TStream); override; procedure ReadFORMAT(AStream: TStream); override;
procedure ReadLABEL(AStream: TStream); override; procedure ReadLABEL(AStream: TStream); override;
procedure ReadWorkbookGlobals(AStream: TStream); procedure ReadRSTRING(AStream: TStream);
procedure ReadWorksheet(AStream: TStream);
procedure ReadRichString(AStream: TStream);
procedure ReadStandardWidth(AStream: TStream; ASheet: TsWorksheet); procedure ReadStandardWidth(AStream: TStream; ASheet: TsWorksheet);
procedure ReadStringRecord(AStream: TStream); override; procedure ReadStringRecord(AStream: TStream); override;
procedure ReadWorkbookGlobals(AStream: TStream); override;
procedure ReadWorksheet(AStream: TStream); override;
procedure ReadXF(AStream: TStream); procedure ReadXF(AStream: TStream);
public public
{ General reading methods } { General reading methods }
procedure ReadFromFile(AFileName: string); override; // procedure ReadFromFile(AFileName: string); override;
procedure ReadFromStream(AStream: TStream); override; procedure ReadFromStream(AStream: TStream); override;
end; end;
@ -323,6 +320,13 @@ type
TextLen: Word; TextLen: Word;
end; end;
TBiff5_RichTextFormattingRun = packed record
FirstIndex: Byte;
FontIndex: Byte;
end;
TBiff5_RichTextFormattingRuns = array of TBiff5_RichTextFormattingRun;
TBIFF5_XFRecord = packed record TBIFF5_XFRecord = packed record
RecordID: Word; RecordID: Word;
RecordSize: Word; RecordSize: Word;
@ -426,7 +430,7 @@ begin
INT_EXCEL_ID_RIGHTMARGIN : ReadMargin(AStream, 1); 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_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_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_SHAREDFMLA : ReadSharedFormula(AStream);
INT_EXCEL_ID_SHEETPR : ReadSHEETPR(AStream); INT_EXCEL_ID_SHEETPR : ReadSHEETPR(AStream);
INT_EXCEL_ID_STANDARDWIDTH : ReadStandardWidth(AStream, FWorksheet); INT_EXCEL_ID_STANDARDWIDTH : ReadStandardWidth(AStream, FWorksheet);
@ -508,12 +512,11 @@ begin
SetLength(s, Len); SetLength(s, Len);
AStream.ReadBuffer(s[1], Len*SizeOf(AnsiChar)); AStream.ReadBuffer(s[1], Len*SizeOf(AnsiChar));
// sheetName := AnsiToUTF8(s);
sheetName := ConvertEncoding(s, FCodePage, EncodingUTF8); sheetName := ConvertEncoding(s, FCodePage, EncodingUTF8);
FWorksheetNames.Add(sheetName); FWorksheetNames.Add(sheetName);
end; end;
procedure TsSpreadBIFF5Reader.ReadRichString(AStream: TStream); procedure TsSpreadBIFF5Reader.ReadRSTRING(AStream: TStream);
var var
L: Word; L: Word;
B, F: Byte; B, F: Byte;
@ -593,6 +596,7 @@ begin
FIncompleteCell := nil; FIncompleteCell := nil;
end; end;
(*
procedure TsSpreadBIFF5Reader.ReadFromFile(AFileName: string); procedure TsSpreadBIFF5Reader.ReadFromFile(AFileName: string);
var var
MemStream: TMemoryStream; MemStream: TMemoryStream;
@ -620,7 +624,7 @@ begin
OLEStorage.Free; OLEStorage.Free;
end; end;
end; end;
*)
procedure TsSpreadBIFF5Reader.ReadXF(AStream: TStream); procedure TsSpreadBIFF5Reader.ReadXF(AStream: TStream);
var var
rec: TBIFF5_XFRecord; rec: TBIFF5_XFRecord;
@ -642,15 +646,7 @@ begin
AStream.ReadBuffer(rec.FontIndex, SizeOf(rec) - 2*SizeOf(Word)); AStream.ReadBuffer(rec.FontIndex, SizeOf(rec) - 2*SizeOf(Word));
// Font index // Font index
i := WordLEToN(rec.FontIndex); fmt.FontIndex := FixFontIndex(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);
}
if fmt.FontIndex > 1 then if fmt.FontIndex > 1 then
Include(fmt.UsedFormattingFields, uffFont); Include(fmt.UsedFormattingFields, uffFont);
@ -780,9 +776,94 @@ begin
FCellFormatList.Add(fmt); FCellFormatList.Add(fmt);
end; 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); procedure TsSpreadBIFF5Reader.ReadFromStream(AStream: TStream);
var var
BIFF5EOF: Boolean; 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 begin
{ Initializations } { Initializations }
@ -815,6 +896,7 @@ begin
{ Finalization } { Finalization }
FWorksheetNames.Free; FWorksheetNames.Free;
end; end;
*)
procedure TsSpreadBIFF5Reader.ReadFont(const AStream: TStream); procedure TsSpreadBIFF5Reader.ReadFont(const AStream: TStream);
var var
@ -1253,7 +1335,7 @@ begin
AStream.WriteWord(WordToLE(INT_FONT_WEIGHT_NORMAL)); AStream.WriteWord(WordToLE(INT_FONT_WEIGHT_NORMAL));
{ Escapement type } { Escapement type }
AStream.WriteWord(0); AStream.WriteWord(WordToLE(ord(AFont.Position)));
{ Underline type } { Underline type }
if fssUnderline in AFont.Style then if fssUnderline in AFont.Style then
@ -1369,12 +1451,16 @@ end;
procedure TsSpreadBIFF5Writer.WriteLabel(AStream: TStream; const ARow, procedure TsSpreadBIFF5Writer.WriteLabel(AStream: TStream; const ARow,
ACol: Cardinal; const AValue: string; ACell: PCell); ACol: Cardinal; const AValue: string; ACell: PCell);
const const
MAXBYTES = 255; //limit for this format MAXBYTES = 255; // Limit for this BIFF5
var var
L: Word; L: Word;
AnsiValue: ansistring; AnsiValue: ansistring;
rec: TBIFF5_LabelRecord; rec: TBIFF5_LabelRecord;
buf: array of byte; buf: array of byte;
useRTF: Boolean;
fmt: PsCellFormat;
run, j: Integer;
rtfRuns: TBiff5_RichTextformattingRuns;
begin begin
if (ARow >= FLimitations.MaxRowCount) or (ACol >= FLimitations.MaxColCount) then if (ARow >= FLimitations.MaxRowCount) or (ACol >= FLimitations.MaxColCount) then
exit; exit;
@ -1401,9 +1487,40 @@ begin
end; end;
L := Length(AnsiValue); L := Length(AnsiValue);
useRTF := (Length(ACell^.RichTextParams) > 0);
{ BIFF record header } { BIFF record header }
rec.RecordID := WordToLE(INT_EXCEL_ID_LABEL); rec.RecordID := WordToLE(IfThen(useRTF, INT_EXCEL_ID_RSTRING, INT_EXCEL_ID_LABEL));
rec.RecordSize := WordToLE(8 + L); 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 } { BIFF record data }
rec.Row := WordToLE(ARow); rec.Row := WordToLE(ARow);
@ -1416,15 +1533,25 @@ begin
rec.TextLen := WordToLE(L); rec.TextLen := WordToLE(L);
{ Copy the text characters into a buffer immediately after rec } { 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(rec, buf[0], SizeOf(rec));
Move(AnsiValue[1], buf[SizeOf(rec)], L*SizeOf(ansiChar)); Move(AnsiValue[1], buf[SizeOf(rec)], L);
{ Write out } { Write out buffer }
AStream.WriteBuffer(buf[0], SizeOf(Rec) + SizeOf(ansiChar)*L); 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 } { Clean up }
SetLength(buf, 0); SetLength(buf, 0);
SetLength(rtfRuns, 0);
end; 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; FIncompleteNoteLength: Word;
FFirstNumFormatIndexInFile: Integer; FFirstNumFormatIndexInFile: Integer;
FPalette: TsPalette; FPalette: TsPalette;
FWorksheetNames: TStrings;
FCurrentWorksheet: Integer;
procedure AddBuiltinNumFormats; override; procedure AddBuiltinNumFormats; override;
procedure ApplyCellFormatting(ACell: PCell; XFIndex: Word); virtual; procedure ApplyCellFormatting(ACell: PCell; XFIndex: Word); virtual;
@ -437,6 +439,10 @@ type
procedure ReadVCENTER(AStream: TStream); procedure ReadVCENTER(AStream: TStream);
// Read WINDOW2 record (gridlines, sheet headers) // Read WINDOW2 record (gridlines, sheet headers)
procedure ReadWindow2(AStream: TStream); virtual; procedure ReadWindow2(AStream: TStream); virtual;
procedure ReadWorkbookGlobals(AStream: TStream); virtual;
procedure ReadWorksheet(AStream: TStream); virtual;
procedure InternalReadFromStream(AStream: TStream);
public public
constructor Create(AWorkbook: TsWorkbook); override; constructor Create(AWorkbook: TsWorkbook); override;
@ -946,10 +952,6 @@ end;
everything is known. everything is known.
-------------------------------------------------------------------------------} -------------------------------------------------------------------------------}
procedure TsSpreadBIFFReader.FixColors; procedure TsSpreadBIFFReader.FixColors;
var
i: Integer;
fnt: TsFont;
fmt: PsCellFormat;
procedure FixColor(var AColor: TsColor); procedure FixColor(var AColor: TsColor);
begin begin
@ -957,7 +959,17 @@ var
AColor := FPalette[AColor and $00FFFFFF]; AColor := FPalette[AColor and $00FFFFFF];
end; end;
var
i: Integer;
fnt: TsFont;
fmt: PsCellFormat;
begin 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 for i:=0 to FWorkbook.GetFontCount - 1 do
begin begin
fnt := FWorkbook.GetFont(i); fnt := FWorkbook.GetFont(i);
@ -2254,6 +2266,17 @@ begin
FWorksheet.Options := FWorksheet.Options - [soHasFrozenPanes]; FWorksheet.Options := FWorksheet.Options - [soHasFrozenPanes];
end; 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 Populates the reader's palette by default colors. Will be overwritten if the
file contains a palette on its own file contains a palette on its own
@ -2263,6 +2286,64 @@ begin
FPalette.AddBuiltinColors; FPalette.AddBuiltinColors;
end; 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 } { TsSpreadBIFFWriter }

304
components/fpspreadsheet/xlsxooxml.pas
View File

@ -130,7 +130,7 @@ type
procedure WriteComments(AWorksheet: TsWorksheet); procedure WriteComments(AWorksheet: TsWorksheet);
procedure WriteDimension(AStream: TStream; AWorksheet: TsWorksheet); procedure WriteDimension(AStream: TStream; AWorksheet: TsWorksheet);
procedure WriteFillList(AStream: TStream); 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 WriteFontList(AStream: TStream);
procedure WriteHeaderFooter(AStream: TStream; AWorksheet: TsWorksheet); procedure WriteHeaderFooter(AStream: TStream; AWorksheet: TsWorksheet);
procedure WriteHyperlinks(AStream: TStream; AWorksheet: TsWorksheet); procedure WriteHyperlinks(AStream: TStream; AWorksheet: TsWorksheet);
@ -749,9 +749,9 @@ begin
if (s1 <> '') and (s2 <> '0') then if (s1 <> '') and (s2 <> '0') then
begin begin
fnt := TsFont(FFontList.Items[StrToInt(s1)]); 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 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 if fmt.FontIndex > 0 then
Include(fmt.UsedFormattingFields, uffFont); Include(fmt.UsedFormattingFields, uffFont);
end; end;
@ -1065,9 +1065,8 @@ begin
end; end;
end; end;
{ Reads the font described by the specified node. If the node is already { Reads the font described by the specified node and stores it in the reader's
contained in the font list the font's index is returned; otherwise the FontList. }
new font is added to the list and its index is returned. }
function TsSpreadOOXMLReader.ReadFont(ANode: TDOMNode): Integer; function TsSpreadOOXMLReader.ReadFont(ANode: TDOMNode): Integer;
var var
node: TDOMNode; node: TDOMNode;
@ -1079,6 +1078,7 @@ var
fntPos: TsFontPosition; fntPos: TsFontPosition;
nodename: String; nodename: String;
s: String; s: String;
acceptDuplicates: Boolean;
begin begin
fnt := Workbook.GetDefaultFont; fnt := Workbook.GetDefaultFont;
if fnt <> nil then if fnt <> nil then
@ -1097,6 +1097,7 @@ begin
fntPos := fpNormal; fntPos := fpNormal;
end; end;
acceptDuplicates := true;
node := ANode.FirstChild; node := ANode.FirstChild;
while node <> nil do while node <> nil do
begin begin
@ -1105,6 +1106,7 @@ begin
begin begin
s := GetAttrValue(node, 'val'); s := GetAttrValue(node, 'val');
if s <> '' then fntName := s; if s <> '' then fntName := s;
if nodename = 'rFont' then acceptDuplicates := false;
end end
else else
if nodename = 'sz' then if nodename = 'sz' then
@ -1115,26 +1117,26 @@ begin
else else
if nodename = 'b' then if nodename = 'b' then
begin begin
if GetAttrValue(node, 'val') <> 'false' if GetAttrValue(node, 'val') <> 'false' then
then fntStyles := fntStyles + [fssBold]; fntStyles := fntStyles + [fssBold];
end end
else else
if nodename = 'i' then if nodename = 'i' then
begin begin
if GetAttrValue(node, 'val') <> 'false' if GetAttrValue(node, 'val') <> 'false' then
then fntStyles := fntStyles + [fssItalic]; fntStyles := fntStyles + [fssItalic];
end end
else else
if nodename = 'u' then if nodename = 'u' then
begin begin
if GetAttrValue(node, 'val') <> 'false' if GetAttrValue(node, 'val') <> 'false' then
then fntStyles := fntStyles+ [fssUnderline] fntStyles := fntStyles+ [fssUnderline]
end end
else else
if nodename = 'strike' then if nodename = 'strike' then
begin begin
if GetAttrValue(node, 'val') <> 'false' if GetAttrValue(node, 'val') <> 'false' then
then fntStyles := fntStyles + [fssStrikeout]; fntStyles := fntStyles + [fssStrikeout];
end end
else else
if nodename = 'vertAlign' then if nodename = 'vertAlign' then
@ -1154,11 +1156,14 @@ begin
node := node.NextSibling; node := node.NextSibling;
end; end;
// Check whether font is already contained in font list // 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 for Result := 0 to FFontList.Count-1 do
begin begin
fnt := TsFont(FFontList[Result]); fnt := TsFont(FFontList[Result]);
if (fnt.FontName = fntName) and if SameText(fnt.FontName, fntName) and
(fnt.Size = fntSize) and (fnt.Size = fntSize) and
(fnt.Style = fntStyles) and (fnt.Style = fntStyles) and
(fnt.Color = fntColor) and (fnt.Color = fntColor) and
@ -1167,7 +1172,10 @@ begin
exit; exit;
end; 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 := TsFont.Create;
fnt.FontName := fntName; fnt.FontName := fntName;
fnt.Size := fntSize; fnt.Size := fntSize;
@ -1812,9 +1820,13 @@ begin
FixRows(AWorksheet); FixRows(AWorksheet);
end; 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 var
Doc : TXMLDocument; Doc : TXMLDocument;
RelsNode: TDOMNode;
FilePath : string; FilePath : string;
UnZip : TUnZipper; UnZip : TUnZipper;
FileList : TStringList; FileList : TStringList;
@ -1822,6 +1834,7 @@ var
i: Integer; i: Integer;
fn: String; fn: String;
fn_comments: String; fn_comments: String;
XMLStream: TStream;
begin begin
//unzip "content.xml" of "AFileName" to folder "FilePath" //unzip "content.xml" of "AFileName" to folder "FilePath"
FilePath := GetTempDir(false); FilePath := GetTempDir(false);
@ -1927,6 +1940,7 @@ begin
else else
// this sheet does not have any cell comments // this sheet does not have any cell comments
continue; continue;
// Extract texts from the comments file found and apply to worksheet. // Extract texts from the comments file found and apply to worksheet.
if fn_comments <> '' then if fn_comments <> '' then
begin begin
@ -1939,6 +1953,7 @@ begin
FreeAndNil(Doc); FreeAndNil(Doc);
end; end;
end; end;
// Add hyperlinks to cells
ApplyHyperlinks(FWorksheet); ApplyHyperlinks(FWorksheet);
end; // for end; // for
@ -1948,13 +1963,173 @@ begin
end; end;
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); procedure TsSpreadOOXMLReader.ReadFromStream(AStream: TStream);
begin begin
Unused(AStream); Unused(AStream);
raise Exception.Create('[TsSpreadOOXMLReader.ReadFromStream] '+ raise Exception.Create('[TsSpreadOOXMLReader.ReadFromStream] '+
'Method not implemented. Use "ReadFromFile" instead.'); 'Method not implemented. Use "ReadFromFile" instead.');
end; end;
*)
{------------------------------------------------------------------------------} {------------------------------------------------------------------------------}
{ TsSpreadOOXMLWriter } { TsSpreadOOXMLWriter }
@ -2331,15 +2506,19 @@ end;
{ Writes font parameters to the stream. { Writes font parameters to the stream.
ATag is "font" for the entry in "styles.xml", or "rPr" for the entry for 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; 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 var
s: String; s: String;
begin begin
s := ''; s := '';
s := s + Format('<sz val="%g" />', [AFont.Size], FPointSeparatorSettings); 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 if (fssBold in AFont.Style) then
s := s + '<b />'; s := s + '<b />';
if (fssItalic in AFont.Style) then if (fssItalic in AFont.Style) then
@ -2355,7 +2534,7 @@ begin
fpSuperscript: s := s + '<vertAlign val="superscript" />'; fpSuperscript: s := s + '<vertAlign val="superscript" />';
end; end;
AppendToStream(AStream, Format( AppendToStream(AStream, Format(
'<%s>%s</%s>', [ATag, s, ATag])); '<%s>%s</%s>', [TAG[UseInStyleNode], s, TAG[UseInStyleNode]]));
end; end;
{ Writes the fontlist of the workbook to the stream. } { Writes the fontlist of the workbook to the stream. }
@ -2368,7 +2547,7 @@ begin
'<fonts count="%d">', [Workbook.GetFontCount])); '<fonts count="%d">', [Workbook.GetFontCount]));
for i:=0 to Workbook.GetFontCount-1 do begin for i:=0 to Workbook.GetFontCount-1 do begin
font := Workbook.GetFont(i); font := Workbook.GetFont(i);
WriteFont(AStream, font, 'font'); WriteFont(AStream, font, true);
end; end;
AppendToStream(AStream, AppendToStream(AStream,
'</fonts>'); '</fonts>');
@ -3601,13 +3780,19 @@ end;
procedure TsSpreadOOXMLWriter.WriteLabel(AStream: TStream; const ARow, procedure TsSpreadOOXMLWriter.WriteLabel(AStream: TStream; const ARow,
ACol: Cardinal; const AValue: string; ACell: PCell); ACol: Cardinal; const AValue: string; ACell: PCell);
const const
MAXBYTES = 32767; //limit for this format MAXBYTES = 32767; // limit for this format
var var
CellPosText: string; CellPosText: string;
lStyleIndex: Cardinal; lStyleIndex: Cardinal;
ResultingValue: string; ResultingValue: string;
fnt: TsFont;
n: Integer;
i: Integer;
L: Integer;
rtParam: TsRichTextParam;
txt: String;
begin 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 if Length(AValue) > MAXBYTES then
begin begin
ResultingValue := Copy(AValue, 1, MAXBYTES); //may chop off multicodepoint UTF8 characters but well... ResultingValue := Copy(AValue, 1, MAXBYTES); //may chop off multicodepoint UTF8 characters but well...
@ -3618,16 +3803,79 @@ begin
else else
ResultingValue := AValue; ResultingValue := AValue;
if not ValidXMLText(ResultingValue) then txt := ResultingValue;
if not ValidXMLText(txt) then
Workbook.AddErrorMsg( Workbook.AddErrorMsg(
rsInvalidCharacterInCell, [ rsInvalidCharacterInCell, [
GetCellString(ARow, ACol) GetCellString(ARow, ACol)
]); ]);
{ Write string to SharedString table }
if Length(ACell^.RichTextParams) = 0 then
// unformatted string
AppendToStream(FSSharedStrings, AppendToStream(FSSharedStrings,
'<si>' + '<si>' +
'<t>' + ResultingValue + '</t>' + '<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>'); '</si>');
end;
{ Write shared string index to cell record }
CellPosText := TsWorksheet.CellPosToText(ARow, ACol); CellPosText := TsWorksheet.CellPosToText(ARow, ACol);
lStyleIndex := GetStyleIndex(ACell); lStyleIndex := GetStyleIndex(ACell);