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

fpspreadsheet: Unit tests for hyperlinks. Some issues left.

Browse Source 
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@4002 8e941d3f-bd1b-0410-a28a-d453659cc2b4
This commit is contained in:
wp_xxyyzz
2015-03-08 00:50:10 +00:00
parent 6d2e993c22
commit 2d76afb541
11 changed files with 218 additions and 131 deletions
Download Patch File Download Diff File Expand all files Collapse all files

95
components/fpspreadsheet/fpsopendocument.pas
View File

@ -23,7 +23,7 @@ AUTHORS: Felipe Monteiro de Carvalho / Jose Luis Jurado Rincon
unit fpsopendocument;
{$ifdef fpc}
{$mode delphi}{$H+}
{$mode objfpc}{$H+}
{$endif}
{.$define FPSPREADDEBUG} //used to be XLSDEBUG
@ -205,7 +205,7 @@ type
implementation
uses
StrUtils, Variants, URIParser,
StrUtils, Variants, LazFileUtils, URIParser,
fpsPatches, fpsStrings, fpsStreams, fpsExprParser;
const
@ -383,7 +383,7 @@ function TsSpreadOpenDocNumFormatParser.BuildDateTimeXMLAsString(ASection: Integ
var
el: Integer;
s: String;
prevToken: TsNumFormatToken;
prevTok: TsNumFormatToken;
begin
Result := '';
AIsTimeOnly := true;
@ -396,7 +396,7 @@ begin
case Elements[el].Token of
nftYear:
begin
prevToken := Elements[el].Token;
prevTok := Elements[el].Token;
AIsTimeOnly := false;
s := IfThen(Elements[el].IntValue > 2, 'number:style="long" ', '');
Result := Result +
@ -405,7 +405,7 @@ begin
nftMonth:
begin
prevToken := Elements[el].Token;
prevTok := Elements[el].Token;
AIsTimeOnly := false;
case Elements[el].IntValue of
1: s := '';
@ -419,7 +419,7 @@ begin
nftDay:
begin
prevToken := Elements[el].Token;
prevTok := Elements[el].Token;
AIsTimeOnly := false;
case Elements[el].IntValue of
1: s := 'day ';
@ -433,7 +433,7 @@ begin
nftHour, nftMinute, nftSecond:
begin
prevToken := Elements[el].Token;
prevTok := Elements[el].Token;
case Elements[el].Token of
nftHour : s := 'hours ';
nftMinute: s := 'minutes ';
@ -460,7 +460,7 @@ begin
s := Elements[el].TextValue;
if (s = '/') then
begin
if prevToken in [nftYear, nftMonth, nftDay] then
if prevTok in [nftYear, nftMonth, nftDay] then
s := FWorkbook.FormatSettings.DateSeparator
else
s := FWorkbook.FormatSettings.TimeSeparator;
@ -1461,52 +1461,51 @@ var
styleName: String;
childnode: TDOMNode;
subnode: TDOMNode;
spanNode: TDOMNode;
nodeName: String;
s: String;
cell: PCell;
hyperlink: string;
procedure AddToCellText(AText: String);
begin
if cellText = ''
then cellText := AText
else cellText := cellText + AText;
end;
begin
{ We were forced to activate PreserveWhiteSpace in the DOMParser in order to
catch the spaces inserted in formatting texts. However, this adds lots of
garbage into the cellText if is is read by means of above statement. Done
like below is much better: }
cellText := '';
hyperlink := '';
childnode := ACellNode.FirstChild;
while Assigned(childnode) do
begin
nodeName := childNode.NodeName;
hyperlink := '';
if nodeName = 'text:p' then begin
// Each 'text:p' node is a paragraph --> we insert a line break after the first paragraph
if cellText <> '' then
cellText := cellText + LineEnding;
subnode := childnode.FirstChild;
while Assigned(subnode) do
begin
nodename := subnode.NodeName;
if nodename = 'text:a' then begin
s := GetAttrValue(subnode, 'xlink:type');
if s = 'simple' then
hyperlink := GetAttrValue(subnode, 'xlink:href');
case nodename of
'#text' :
AddToCellText(subnode.TextContent);
'text:a': // "hyperlink anchor"
begin
hyperlink := GetAttrValue(subnode, 'xlink:href');
AddToCellText(subnode.TextContent);
end;
'text:span':
AddToCellText(subnode.TextContent);
end;
subnode := subnode.NextSibling;
end;
s := childNode.TextContent;
if s <> '' then
begin
if cellText = '' then cellText := s else cellText := cellText + LineEnding + s;
end;
spanNode := childNode.FirstChild;
while spanNode <> nil do begin
nodeName := spanNode.NodeName;
if nodeName = 'text:span' then
begin
s := spanNode.TextContent;
if cellText = '' then cellText := s else cellText := cellText + ' ' + s;
end;
spanNode := spanNode.NextSibling;
end;
end;
childnode := childnode.NextSibling;
end;
@ -1519,7 +1518,14 @@ begin
FWorkSheet.WriteUTF8Text(cell, cellText);
if hyperlink <> '' then
begin
// ODS sees relative paths relative to the internal own file structure
// --> we must remove 1 level-up to be at the same level where fps expects
// the file.
if pos('../', hyperlink) = 1 then
Delete(hyperlink, 1, Length('../'));
FWorksheet.WriteHyperlink(cell, hyperlink);
end;
styleName := GetAttrValue(ACellNode, 'table:style-name');
ApplyStyleToCell(cell, stylename);
@ -4153,7 +4159,7 @@ var
spannedStr: String;
r1,c1,r2,c2: Cardinal;
txt: ansistring;
textp, target, comment: String;
textp, target, bookmark, comment: String;
fmt: TsCellFormat;
hyperlink: PsHyperlink;
u: TUri;
@ -4191,6 +4197,30 @@ begin
if FWorksheet.HasHyperlink(ACell) then
begin
hyperlink := FWorksheet.FindHyperlink(ACell);
SplitHyperlink(hyperlink^.Target, target, bookmark);
if (target = '') and (bookmark <> '') then
target := '#' + bookmark
else
if (pos('file:', target) = 0) then
begin
u := ParseURI(target);
if u.Protocol = '' then
target := '../' + target;
end;
{
u := ParseURI(hyperlink^.Target);
if u.Protocol = '' then // relative file name, or internal link
begin
if target <> '' then target := '../' + target;
if bookmark <> '' then target := target + '#' + bookmark;
end else
target := hyperlink^.Target;
}
ValidXMLText(target);
{
target := hyperlink^.Target;
if target[1] <> '#' then
begin
@ -4202,6 +4232,7 @@ begin
// if not IsAbsoluteURI(target) then target := '..\' + target;
end;
end;
}
textp := Format(
'<text:p>'+
'<text:a xlink:href="%s" xlink:type="simple">%s</text:a>'+

70
components/fpspreadsheet/fpspreadsheet.pas
View File

@ -593,8 +593,6 @@ type
class function GetFormatFromFileHeader(const AFileName: TFileName;
out SheetType: TsSpreadsheetFormat): Boolean;
class function GetFormatFromFileName(const AFileName: TFileName;
out SheetType: TsSpreadsheetFormat): Boolean;
function CreateSpreadReader(AFormat: TsSpreadsheetFormat): TsBasicSpreadReader;
function CreateSpreadWriter(AFormat: TsSpreadsheetFormat): TsBasicSpreadWriter;
procedure ReadFromFile(AFileName: string; AFormat: TsSpreadsheetFormat); overload;
@ -781,7 +779,7 @@ procedure DumpFontsToFile(AWorkbook: TsWorkbook; AFileName: String);
implementation
uses
Math, StrUtils, TypInfo, lazutf8, URIParser,
Math, StrUtils, TypInfo, lazutf8, lazFileUtils, URIParser,
fpsPatches, fpsStrings, uvirtuallayer_ole,
fpsUtils, fpsreaderwriter, fpsCurrency, fpsExprParser,
fpsNumFormat, fpsNumFormatParser;
@ -1464,13 +1462,14 @@ end;
Checks whether the passed string represents a valid hyperlink target
@param AValue String to be checked. Must be either a fully qualified URI,
or a # followed by a cell address in the current workbook
a local relative (!) file name, or a # followed by a cell
address in the current workbook
@param AErrMsg Error message in case that the string is not correct.
@returns TRUE if the string is correct, FALSE otherwise
-------------------------------------------------------------------------------}
function TsWorksheet.ValidHyperlink(AValue: String; out AErrMsg: String): Boolean;
var
uri: TUri;
u: TUri;
sheet: TsWorksheet;
r, c: Cardinal;
begin
@ -1491,12 +1490,24 @@ begin
end;
end else
begin
uri := ParseURI(AValue);
if SameText(uri.Protocol, 'mailto') then
u := ParseURI(AValue);
if SameText(u.Protocol, 'mailto') then
begin
Result := true; // To do: Check email address here...
exit;
end else
if SameText(u.Protocol, 'file') then
begin
if FilenameIsAbsolute(u.Path + u.Document) then
begin
Result := true;
exit;
end else
begin
AErrMsg := Format(rsLocalfileHyperlinkAbs, [AValue]);
exit;
end;
end else
begin
Result := true;
exit;
@ -1530,8 +1541,9 @@ end;
@param ACell Pointer to the cell considered
@param ATarget Hyperlink address given as a fully qualitifed URI for
external links, or as a # followed by a cell address
for internal links. An existing hyperlink is removed if
ATarget is empty.
for internal links. Local files can be specified also
by their name relative to the workbook.
An existing hyperlink is removed if ATarget is empty.
@param ATooltip Text for popup tooltip hint used by Excel
-------------------------------------------------------------------------------}
procedure TsWorksheet.WriteHyperlink(ACell: PCell; ATarget: String;
@ -1539,7 +1551,7 @@ procedure TsWorksheet.WriteHyperlink(ACell: PCell; ATarget: String;
var
hyperlink: PsHyperlink;
fmt: TsCellFormat;
fn: String;
target, bm, fn, displayTxt: String;
begin
if ACell = nil then
exit;
@ -1554,11 +1566,15 @@ begin
if ACell^.ContentType = cctEmpty then
begin
SplitHyperlink(ATarget, target, bm);
displayTxt := ATarget;
if pos('file:', lowercase(displayTxt))=1 then
begin
Delete(displayTxt, 1, Length('file:///'));
if bm <> '' then displayTxt := fn + '#' + bm;
end;
ACell^.ContentType := cctUTF8String;
if (hyperlink^.Target[1] <> '#') and UriToFileName(hyperlink^.Target, fn) then
ACell^.UTF8StringValue := fn
else
ACell^.UTF8StringValue := hyperlink^.Target;
ACell^.UTF8StringValue := displayTxt;
end;
fmt := ReadCellFormat(ACell);
@ -3622,6 +3638,8 @@ begin
begin
hyperlink := ReadHyperlink(ACell);
AText := hyperlink.Target;
if pos('file:', hyperlink.Target)=1 then
Delete(AText, 1, Length('file:///'));
end;
if (AText = '') then
@ -6238,30 +6256,6 @@ begin
end;
end;
{@@ ----------------------------------------------------------------------------
Helper method for determining the spreadsheet type from the file type extension
@param AFileName Name of the file to be considered
@param SheetType File format found from analysis of the extension (output)
@return True if the file matches any of the known formats, false otherwise
-------------------------------------------------------------------------------}
class function TsWorkbook.GetFormatFromFileName(const AFileName: TFileName;
out SheetType: TsSpreadsheetFormat): Boolean;
var
suffix: String;
begin
Result := True;
suffix := Lowercase(ExtractFileExt(AFileName));
if suffix = STR_EXCEL_EXTENSION then SheetType := sfExcel8
else if suffix = STR_OOXML_EXCEL_EXTENSION then SheetType := sfOOXML
else if suffix = STR_OPENDOCUMENT_CALC_EXTENSION then SheetType := sfOpenDocument
else if suffix = STR_COMMA_SEPARATED_EXTENSION then SheetType := sfCSV
else if suffix = STR_WIKITABLE_PIPES then SheetType := sfWikiTable_Pipes
else if suffix = STR_WIKITABLE_WIKIMEDIA then SheetType := sfWikiTable_WikiMedia
else Result := False;
end;
{@@ ----------------------------------------------------------------------------
Convenience method which creates the correct reader object for a given
spreadsheet format.

9
components/fpspreadsheet/fpsreaderwriter.pas
View File

@ -123,15 +123,8 @@ type
public
constructor Create(AWorkbook: TsWorkbook); override;
destructor Destroy; override;
{ General writing methods }
{
procedure IterateThroughCells(AStream: TStream; ACells: TsCells;
ACallback: TCellsCallback);
procedure IterateThroughComments(AStream: TStream; AComments: TsComments;
ACallback: TCommentsCallback);
procedure IterateThroughHyperlinks(AStream: TStream; AHyperlinks: TsHyperlinks;
ACallback: THyperlinksCallback);
}
procedure WriteToFile(const AFileName: string;
const AOverwriteExisting: Boolean = False); override;
procedure WriteToStream(AStream: TStream); override;

4
components/fpspreadsheet/fpsstrings.pas
View File

@ -51,13 +51,15 @@ resourcestring
rsInvalidCharacterInCell = 'Invalid character(s) in cell %s.';
rsInvalidCharacterInCellComment = 'Invalid character(s) in cell comment "%s".';
rsUTF8TextExpectedButANSIFoundInCell = 'Expected UTF8 text but probably ANSI '+
'text found in cell %s.';
'text found in cell %s.';
rsIndexInSSTOutOfRange = 'Index %d in SST out of range (0-%d).';
rsAmbiguousDecThouSeparator = 'Assuming usage of decimal separator in "%s".';
rsCodePageNotSupported = 'Code page "%s" is not supported. Using "cp1252" (Latin 1) instead.';
rsNoValidHyperlinkInternal = 'The hyperlink "%s" is not a valid cell address.';
rsNoValidHyperlinkURI = 'The hyperlink "%s" is not a valid URI.';
rsLocalFileHyperlinkAbs = 'The hyperlink "%s" points to a local file. ' +
'In case of an absolute path the protocol "file:" must be specified.';
rsEmptyHyperlink = 'The hyperlink is not specified.';
rsODSHyperlinksOfTextCellsOnly = 'Cell %s: OpenDocument supports hyperlinks for text cells only.';
rsStdHyperlinkTooltip = 'Press the left mouse button a bit longer to activate the hyperlink.';

4
components/fpspreadsheet/fpstypes.pas
View File

@ -29,9 +29,9 @@ const
{@@ Default extension of <b>comma-separated-values</b> file }
STR_COMMA_SEPARATED_EXTENSION = '.csv';
{@@ Default extension of <b>wikitable files</b> in <b>pipes</b> format}
STR_WIKITABLE_PIPES = '.wikitable_pipes';
STR_WIKITABLE_PIPES_EXTENSION = '.wikitable_pipes';
{@@ Default extension of <b>wikitable files</b> in <b>wikimedia</b> format }
STR_WIKITABLE_WIKIMEDIA = '.wikitable_wikimedia';
STR_WIKITABLE_WIKIMEDIA_EXTENSION = '.wikitable_wikimedia';
{@@ Maximum count of worksheet columns}
MAX_COL_COUNT = 65535;

49
components/fpspreadsheet/fpsutils.pas
View File

@ -88,6 +88,9 @@ function GetCellRangeString(ARange: TsCellRange;
function GetErrorValueStr(AErrorValue: TsErrorValue): String;
function GetFileFormatName(AFormat: TsSpreadsheetFormat): string;
function GetFileFormatExt(AFormat: TsSpreadsheetFormat): String;
function GetFormatFromFileName(const AFileName: TFileName;
out SheetType: TsSpreadsheetFormat): Boolean;
function IfThen(ACondition: Boolean; AValue1,AValue2: TsNumberFormat): TsNumberFormat; overload;
@ -866,6 +869,52 @@ begin
end;
end;
{@@ ----------------------------------------------------------------------------
Returns the default extension of each spreadsheet file format
@param AFormat Identifier of the file format
@retur File extension
-------------------------------------------------------------------------------}
function GetFileFormatExt(AFormat: TsSpreadsheetFormat): String;
begin
case AFormat of
sfExcel2,
sfExcel5,
sfExcel8 : Result := STR_EXCEL_EXTENSION;
sfOOXML : Result := STR_OOXML_EXCEL_EXTENSION;
sfOpenDocument : Result := STR_OPENDOCUMENT_CALC_EXTENSION;
sfCSV : Result := STR_COMMA_SEPARATED_EXTENSION;
sfWikiTable_Pipes : Result := STR_WIKITABLE_PIPES_EXTENSION;
sfWikiTable_WikiMedia : Result := STR_WIKITABLE_WIKIMEDIA_EXTENSION;
else raise Exception.Create(rsUnknownSpreadsheetFormat);
end;
end;
{@@ ----------------------------------------------------------------------------
Determines the spreadsheet type from the file type extension
@param AFileName Name of the file to be considered
@param SheetType File format found from analysis of the extension (output)
@return True if the file matches any of the known formats, false otherwise
-------------------------------------------------------------------------------}
function GetFormatFromFileName(const AFileName: TFileName;
out SheetType: TsSpreadsheetFormat): Boolean;
var
suffix: String;
begin
Result := true;
suffix := Lowercase(ExtractFileExt(AFileName));
case suffix of
STR_EXCEL_EXTENSION : SheetType := sfExcel8;
STR_OOXML_EXCEL_EXTENSION : SheetType := sfOOXML;
STR_OPENDOCUMENT_CALC_EXTENSION : SheetType := sfOpenDocument;
STR_COMMA_SEPARATED_EXTENSION : SheetType := sfCSV;
STR_WIKITABLE_PIPES_EXTENSION : SheetType := sfWikiTable_Pipes;
STR_WIKITABLE_WIKIMEDIA_EXTENSION : SheetType := sfWikiTable_WikiMedia;
else Result := False;
end;
end;
{@@ ----------------------------------------------------------------------------
Helper function to reduce typing: "if a conditions is true return the first
number format, otherwise return the second format"

7
components/fpspreadsheet/tests/commenttests.pas
View File

@ -1,11 +1,12 @@
{ Comment tests
These unit tests are writing out to and reading back from file.
}
unit commenttests;
{$mode objfpc}{$H+}
interface
{ Color tests
This unit tests writing out to and reading back from files.
}
uses
// Not using Lazarus package as the user may be working with multiple versions

7
components/fpspreadsheet/tests/spreadtestgui.lpi
View File

@ -40,7 +40,7 @@
<PackageName Value="FCL"/>
</Item4>
</RequiredPackages>
<Units Count="23">
<Units Count="24">
<Unit0>
<Filename Value="spreadtestgui.lpr"/>
<IsPartOfProject Value="True"/>
@ -140,6 +140,11 @@
<IsPartOfProject Value="True"/>
<UnitName Value="enumeratortests"/>
</Unit22>
<Unit23>
<Filename Value="hyperlinktests.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="hyperlinktests"/>
</Unit23>
</Units>
</ProjectOptions>
<CompilerOptions>

3
components/fpspreadsheet/tests/spreadtestgui.lpr
View File

@ -12,7 +12,8 @@ uses
manualtests, testsutility, internaltests, formattests, colortests, fonttests,
optiontests, numformatparsertests, formulatests, rpnFormulaUnit,
emptycelltests, errortests, virtualmodetests, insertdeletetests,
celltypetests, sortingtests, copytests, commenttests, enumeratortests;
celltypetests, sortingtests, copytests, commenttests, enumeratortests,
hyperlinktests;
begin
{$IFDEF HEAPTRC}

78
components/fpspreadsheet/xlsbiff8.pas
View File

@ -119,9 +119,6 @@ type
{ TsSpreadBIFF8Writer }
TsSpreadBIFF8Writer = class(TsSpreadBIFFWriter)
private
procedure WriteHyperlinksCallback(AHyperlink: PsHyperlink; AStream: TStream);
protected
{ Record writing methods }
procedure WriteBOF(AStream: TStream; ADataType: Word);
@ -261,7 +258,7 @@ var
implementation
uses
Math, lconvencoding, URIParser,
Math, lconvencoding, LazFileUtils, URIParser,
fpsStrings, fpsStreams, fpsReaderWriter, fpsExprParser, xlsEscher;
const
@ -1496,12 +1493,12 @@ begin
SetLength(ansiStr, len);
AStream.ReadBuffer(ansiStr[1], len*SizeOf(ansiChar));
SetLength(ansistr, len-1); // Remove trailing zero
linkDos := AnsiToUTF8(ansiStr);
while dirUpCount > 0 do
begin
linkDos := '..\' + linkDos;
ansistr := '..' + PathDelim + ansistr;
dec(dirUpCount);
end;
linkDos := AnsiToUTF8(ansiStr);
// 6 unknown DWord values
AStream.ReadDWord;
AStream.ReadDWord;
@ -1523,11 +1520,13 @@ begin
// no Unicode string header, always 16-bit characters, not zero-terminated
SetLength(wideStr, len);
AStream.ReadBuffer(wideStr[1], size);
SetLength(link, size);
len := System.UnicodeToUTF8(PChar(link), PWideChar(widestr), size);
SetLength(link, len);
link := UTF8Encode(wideStr);
end else
link := linkDos;
// An absolute path must be a fully qualified URI to be compatible with fps
if flags and MASK_HLINK_ABSOLUTE <> 0 then
link := 'file:///' + link;
end;
end;
@ -2395,8 +2394,10 @@ var
flags: DWord;
size: Integer;
cell: PCell;
isInternal: Boolean;
target, bookmark: String;
u: TUri;
isInternal: Boolean;
dirUpCounter: Integer;
begin
cell := AWorksheet.FindCell(AHyperlink^.Row, AHyperlink^.Col);
if (cell = nil) or (AHyperlink^.Target='') then
@ -2404,7 +2405,17 @@ begin
descr := AWorksheet.ReadAsUTF8Text(cell); // Hyperlink description
SplitHyperlink(AHyperlink^.Target, target, bookmark);
isInternal := (target = '');
u := ParseURI(AHyperlink^.Target);
isInternal := (target = '') and (bookmark <> '');
fn := ''; // Name of local file
if target <> '' then
begin
if (u.Protocol='') then
fn := target
else
UriToFileName(target, fn);
ForcePathDelims(fn);
end;
// Since the length of the record is not known in the first place we write
// the data to a temporary stream at first.
@ -2428,7 +2439,9 @@ begin
if isInternal then
flags := MASK_HLINK_TEXTMARK or MASK_HLINK_DESCRIPTION
else
flags := MASK_HLINK_LINK or MASK_HLINK_ABSOLUTE;
flags := MASK_HLINK_LINK;
if SameText(u.Protocol, 'file') then
flags := flags or MASK_HLINK_ABSOLUTE;
if descr <> AHyperlink^.Target then
flags := flags or MASK_HLINK_DESCRIPTION; // has description
if bookmark <> '' then
@ -2447,16 +2460,22 @@ begin
if target <> '' then
begin
if URIToFilename(target, fn) then // URI is a local file
if (fn <> '') then // URI is a local file
begin
{ GUID of file moniker }
guid := StringToGuid('{00000303-0000-0000-C000-000000000046}');
temp.WriteBuffer(guid, SizeOf(guid));
{ Directory-up level counter - we only use absolute paths. }
temp.WriteWord(WordToLE(0));
{ Convert to DOS 8.3 format }
ansistr := UTF8ToAnsi(fn); // Don't use FCodePage here - this is utf8 in case of BIFF8, but we need at true ansi string
//GetShortName(ansistr);
{ Convert to ansi - should be DOS 8.3, but this is not necessary }
ansistr := UTF8ToAnsi(fn);
{ Directory-up level counter }
dirUpCounter := 0;
if not FileNameIsAbsolute(ansistr) then
while (pos ('..' + PathDelim, ansistr) = 1) do
begin
inc(dirUpCounter);
Delete(ansistr, 1, Length('..'+PathDelim));
end;
temp.WriteWord(WordToLE(dirUpCounter));
{ Character count of file name incl trailing zero }
temp.WriteDWord(DWordToLe(Length(ansistr)+1));
{ Character array of file name (8-bit characters), plus trailing zero }
@ -2525,24 +2544,13 @@ procedure TsSpreadBIFF8Writer.WriteHyperlinks(AStream: TStream;
var
hyperlink: PsHyperlink;
begin
for hyperlink in AWorksheet.Hyperlinks do
for hyperlink in AWorksheet.Hyperlinks do begin
{ Write HYPERLINK record }
WriteHyperlink(AStream, hyperlink, AWorksheet);
// IterateThroughHyperlinks(AStream, AWorksheet.Hyperlinks, WriteHyperlinksCallback);
end;
{@@ ----------------------------------------------------------------------------
Callback procedure called for each hyperlink of the current worksheet when
all hyperlinks are written out
-------------------------------------------------------------------------------}
procedure TsSpreadBIFF8Writer.WriteHyperlinksCallback(AHyperlink: PsHyperlink;
AStream: TStream);
begin
{ Write HYPERLINK record }
WriteHyperlink(AStream, AHyperlink, FWorksheet);
{ Write HYPERLINK TOOLTIP record }
if AHyperlink^.Tooltip <> '' then
WriteHyperlinkTooltip(AStream, AHyperlink^.Row, AHyperlink^.Col, AHyperlink^.Tooltip);
{ Write HYPERLINK TOOLTIP record }
if hyperlink^.Tooltip <> '' then
WriteHyperlinkTooltip(AStream, hyperlink^.Row, hyperlink^.Col, hyperlink^.Tooltip);
end;
end;
{@@ ----------------------------------------------------------------------------

23
components/fpspreadsheet/xlsxooxml.pas
View File

@ -109,10 +109,6 @@ type
TsSpreadOOXMLWriter = class(TsCustomSpreadWriter)
private
FNext_rId: Integer;
{
procedure WriteCommentsCallback(AComment: PsComment;
ACommentIndex: Integer; AStream: TStream);
}
procedure WriteVmlDrawingsCallback(AComment: PsComment;
ACommentIndex: Integer; AStream: TStream);
@ -209,7 +205,7 @@ var
implementation
uses
variants, fileutil, strutils, math, lazutf8,
variants, fileutil, strutils, math, lazutf8, uriparser,
{%H-}fpsPatches, fpsStrings, fpsStreams, fpsNumFormatParser;
const
@ -2281,13 +2277,16 @@ begin
s := Format('%s r:id="rId%d"', [s, FNext_rId]);
inc(FNext_rId);
end;
if target = '' then
if bookmark <> '' then //target = '' then
s := Format('%s location="%s"', [s, bookmark]);
txt := AWorksheet.ReadAsUTF8Text(hyperlink^.Row, hyperlink^.Col);
if (txt <> '') and (txt <> hyperlink^.Target) then
s := Format('%s display="%s"', [s, txt]);
if hyperlink^.ToolTip <> '' then
s := Format('%s tooltip="%s"', [s, hyperlink^.Tooltip]);
if hyperlink^.ToolTip <> '' then begin
txt := hyperlink^.Tooltip;
ValidXMLText(txt);
s := Format('%s tooltip="%s"', [s, txt]);
end;
AppendToStream(AStream,
'<hyperlink ' + s + ' />');
AVLNode := AWorksheet.Hyperlinks.FindSuccessor(AVLNode);
@ -2767,6 +2766,7 @@ var
AVLNode: TAVLTreeNode;
hyperlink: PsHyperlink;
s: String;
target, bookmark: String;
begin
// Extend stream array
SetLength(FSSheetRels, FCurSheetNum + 1);
@ -2808,10 +2808,13 @@ begin
while Assigned(AVLNode) do
begin
hyperlink := PsHyperlink(AVLNode.Data);
if hyperlink^.Target <> '' then
SplitHyperlink(hyperlink^.Target, target, bookmark);
if target <> '' then
begin
if (pos('file:', target) = 0) and FileNameIsAbsolute(target) then
target := 'file:///' + target;
s := Format('Id="rId%d" Type="%s" Target="%s" TargetMode="External"',
[FNext_rId, SCHEMAS_HYPERLINKS, hyperlink^.Target]);
[FNext_rId, SCHEMAS_HYPERLINKS, target]);
AppendToStream(FSSheetRels[FCurSheetNum],
'<Relationship ' + s + ' />');
inc(FNext_rId);