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

fpspreadsheet: Write hyperlinks to xlsx files. Some restructuring of the hyperlink record.

Browse Source 
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@3961 8e941d3f-bd1b-0410-a28a-d453659cc2b4
This commit is contained in:
wp_xxyyzz
2015-02-24 16:57:36 +00:00
parent 88d00ecb4d
commit 5d939e5821
3 changed files with 158 additions and 51 deletions
Download Patch File Download Diff File Expand all files Collapse all files

40
components/fpspreadsheet/fpspreadsheet.pas
View File

@ -968,21 +968,31 @@ type
{@@ Abstract method for writing a boolean cell. Must be overridden by descendent classes. }
procedure WriteBool(AStream: TStream; const ARow, ACol: Cardinal;
const AValue: Boolean; ACell: PCell); virtual; abstract;
{@@ (Pseudo-)abstract method for writing a cell comment. Must be overridden by descendent classes }
{@@ (Pseudo-)abstract method for writing a cell comment.
Must be overridden by descendent classes }
procedure WriteComment(AStream: TStream; ACell: PCell); virtual;
{@@ Abstract method for writing a date/time value to a cell. Must be overridden by descendent classes. }
{@@ Abstract method for writing a date/time value to a cell.
Must be overridden by descendent classes. }
procedure WriteDateTime(AStream: TStream; const ARow, ACol: Cardinal;
const AValue: TDateTime; ACell: PCell); virtual; abstract;
{@@ Abstract method for writing an Excel error value to a cell. Must be overridden by descendent classes. }
{@@ Abstract method for writing an Excel error value to a cell.
Must be overridden by descendent classes. }
procedure WriteError(AStream: TStream; const ARow, ACol: Cardinal;
const AValue: TsErrorValue; ACell: PCell); virtual; abstract;
{@@ Abstract method for writing a formula to a cell. Must be overridden by descendent classes. }
{@@ (Pseudo-) abstract method for writing a formula to a cell.
Must be overridden by descendent classes. }
procedure WriteFormula(AStream: TStream; const ARow, ACol: Cardinal;
ACell: PCell); virtual;
{@@ Abstract method for writing a string to a cell. Must be overridden by descendent classes. }
{@@ (Pseudo-)abstract method for writing a hyperlink to a cell.
Must be overridden by descendent classes. }
procedure WriteHyperlink(AStream: TStream; const ARow, ACol: Cardinal;
ACell: PCell); virtual;
{@@ Abstract method for writing a string to a cell.
Must be overridden by descendent classes. }
procedure WriteLabel(AStream: TStream; const ARow, ACol: Cardinal;
const AValue: string; ACell: PCell); virtual; abstract;
{@@ Abstract method for writing a number value to a cell. Must be overridden by descendent classes. }
{@@ Abstract method for writing a number value to a cell.
Must be overridden by descendent classes. }
procedure WriteNumber(AStream: TStream; const ARow, ACol: Cardinal;
const AValue: double; ACell: PCell); virtual; abstract;
@ -1941,6 +1951,7 @@ var
hyperlink: PsHyperlink;
addNew: Boolean;
row, col: Cardinal;
fmt: TsCellFormat;
begin
if ACell = nil then
exit;
@ -1968,6 +1979,14 @@ begin
ACell^.UTF8StringValue := ADisplayText
else
ACell^.UTF8StringValue := ATarget;
fmt := ReadCellFormat(ACell);
if fmt.FontIndex = DEFAULT_FONTINDEX then
begin
fmt.FontIndex := HYPERLINK_FONTINDEX;
Include(fmt.UsedFormattingFields, uffFont);
ACell^.FormatIndex := FWorkbook.AddCellFormat(fmt);
end;
end;
ChangedCell(row, col);
@ -9547,6 +9566,8 @@ begin
WriteNumber(AStream, ACell^.Row, ACell^.Col, ACell^.NumberValue, ACell);
cctUTF8String:
WriteLabel(AStream, ACell^.Row, ACell^.Col, ACell^.UTF8StringValue, ACell);
cctHyperlink:
WriteHyperlink(AStream, ACell^.Row, ACell^.Col, ACell);
end;
//if ACell^.Comment <> '' then
if FWorksheet.ReadComment(ACell) <> '' then
@ -9711,6 +9732,13 @@ begin
Unused(ARow, ACol, ACell);
end;
procedure TsCustomSpreadWriter.WriteHyperlink(AStream: TStream;
const ARow, ACol: Cardinal; ACell: PCell);
begin
Unused(AStream);
Unused(ARow, ACol, ACell);
end;
initialization
// Default palette

6
components/fpspreadsheet/fpstypes.pas
View File

@ -145,15 +145,15 @@ type
PsComment = ^TsComment;
{@@ Specifies whether a hyperlink refers to a cell address within the current
workbook, an external file, or a URL }
TsHyperlinkKind = (hkNone, hkCell, hkFile, hkURL);
workbook, or a URI }
TsHyperlinkKind = (hkNone, hkCell, hkURI);
{@@ The record TsHyperlink contains info on a hyperlink in a cell
@param Row Row index of the cell containing the hyperlink
@param Col Column index of the cell containing the hyperlink
@param Kind Specifies whether clicking on the hyperlink results in
jumping the a cell address within the current workbook,
opens a file, or opens a URL
or opens a URL
@param Target Target of hyperlink (cell address, filename, URL)
@param Note Text displayed as a popup hint by Excel }
TsHyperlink = record

163
components/fpspreadsheet/xlsxooxml.pas
View File

@ -107,6 +107,7 @@ type
TsSpreadOOXMLWriter = class(TsCustomSpreadWriter)
private
FNext_rId: Integer;
procedure WriteCommentsCallback(AComment: PsComment;
ACommentIndex: Integer; AStream: TStream);
procedure WriteVmlDrawingsCallback(AComment: PsComment;
@ -136,6 +137,7 @@ type
procedure WriteDimension(AStream: TStream; AWorksheet: TsWorksheet);
procedure WriteFillList(AStream: TStream);
procedure WriteFontList(AStream: TStream);
procedure WriteHyperlinks(AStream: TStream; AWorksheet: TsWorksheet);
procedure WriteMergedCells(AStream: TStream; AWorksheet: TsWorksheet);
procedure WriteNumFormatList(AStream: TStream);
procedure WritePalette(AStream: TStream);
@ -171,16 +173,18 @@ type
ACell: PCell); override;
procedure WriteBool(AStream: TStream; const ARow, ACol: Cardinal;
const AValue: Boolean; ACell: PCell); override;
procedure WriteDateTime(AStream: TStream; const ARow, ACol: Cardinal;
const AValue: TDateTime; ACell: PCell); override;
procedure WriteError(AStream: TStream; const ARow, ACol: Cardinal;
const AValue: TsErrorValue; ACell: PCell); override;
procedure WriteFormula(AStream: TStream; const ARow, ACol: Cardinal;
ACell: PCell); override;
procedure WriteHyperlink(AStream: TStream; const ARow, ACol: Cardinal;
ACell: PCell); override;
procedure WriteLabel(AStream: TStream; const ARow, ACol: Cardinal;
const AValue: string; ACell: PCell); override;
procedure WriteNumber(AStream: TStream; const ARow, ACol: Cardinal;
const AValue: double; ACell: PCell); override;
procedure WriteDateTime(AStream: TStream; const ARow, ACol: Cardinal;
const AValue: TDateTime; ACell: PCell); override;
public
constructor Create(AWorkbook: TsWorkbook); override;
@ -1290,16 +1294,7 @@ begin
if s <> '' then hyperlinkData.Location := s;
s := GetAttrValue(node, 'TargetMode');
if s = 'External' then
begin
if (pos('http:', hyperlinkdata.Location) = 1) or
(pos('mailto:', hyperlinkData.Location) = 1) or
(pos('file:', hyperlinkData.Location) = 1) or
(pos('ftp:', hyperlinkdata.Location) = 1)
then
hyperlinkData.Kind := hkURL
else
hyperlinkData.Kind := hkFile;
end;
hyperlinkData.Kind := hkURI
end;
end;
end;
@ -2007,6 +2002,9 @@ end;
procedure TsSpreadOOXMLWriter.WriteComments(AWorksheet: TsWorksheet);
begin
if AWorksheet.Comments.Count = 0 then
exit;
// Create the comments stream
SetLength(FSComments, FCurSheetNum + 1);
if (boBufStream in Workbook.Options) then
@ -2170,6 +2168,49 @@ begin
'</fonts>');
end;
procedure TsSpreadOOXMLWriter.WriteHyperlinks(AStream: TStream;
AWorksheet: TsWorksheet);
var
i: Integer;
hyperlink: PsHyperlink;
s: String;
txt: String;
AVLNode: TAVLTreeNode;
begin
if AWorksheet.Hyperlinks.Count = 0 then
exit;
AppendToStream(AStream,
'<hyperlinks>');
// Keep in sync with WriteWorksheetRels !
FNext_rID := IfThen(AWorksheet.Comments.Count = 0, 1, 3);
AVLNode := AWorksheet.Hyperlinks.FindLowest;
while AVLNode <> nil do begin
hyperlink := PsHyperlink(AVLNode.Data);
s := Format('ref="%s"', [GetCellString(hyperlink^.Row, hyperlink^.Col)]);
if hyperlink^.Kind <> hkCell then
begin
s := Format('%s r:id="rId%d"', [s, FNext_rId]);
inc(FNext_rId);
end;
if hyperlink^.Kind = hkCell then
s := Format('%s location="%s"', [s, hyperlink^.Target]);
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]);
AppendToStream(AStream,
'<hyperlink ' + s + ' />');
AVLNode := AWorksheet.Hyperlinks.FindSuccessor(AVLNode);
end;
AppendToStream(AStream,
'</hyperlinks>');
end;
procedure TsSpreadOOXMLWriter.WriteMergedCells(AStream: TStream;
AWorksheet: TsWorksheet);
var
@ -2338,10 +2379,6 @@ begin
AVLNode := AWorksheet.Cells.Find(@lCell);
if Assigned(AVLNode) then begin
WriteCellCallback(PCell(AVLNode.Data), AStream);
{
if (cfHasComment in PCell(AVLNode.Data)^.Flags) then
inc(FNumCommentsOnSheet);
}
end;
end;
AppendToStream(AStream,
@ -2532,6 +2569,9 @@ end;
procedure TsSpreadOOXMLWriter.WriteVmlDrawings(AWorksheet: TsWorksheet);
begin
if AWorksheet.Comments.Count = 0 then
exit;
SetLength(FSVmlDrawings, FCurSheetNum + 1);
if (boBufStream in Workbook.Options) then
FSVmlDrawings[FCurSheetNum] := TBufStream.Create(GetTempFileName('', Format('fpsVMLD%d', [FCurSheetNum])))
@ -2559,7 +2599,6 @@ begin
// Write vmlDrawings for each comment (formatting and position of comment box)
IterateThroughComments(FSVmlDrawings[FCurSheetNum], AWorksheet.Comments, WriteVmlDrawingsCallback);
// IterateThroughCells(FSVmlDrawings[FCurSheetNum], AWorksheet.Cells, WriteVmlDrawingsCallback);
// Footer
AppendToStream(FSVmlDrawings[FCurSheetNum],
@ -2602,11 +2641,20 @@ begin
end;
procedure TsSpreadOOXMLWriter.WriteWorksheetRels(AWorksheet: TsWorksheet);
var
i: Integer;
AVLNode: TAVLTreeNode;
hyperlink: PsHyperlink;
s: String;
begin
Unused(AWorksheet);
// Extend stream array
SetLength(FSSheetRels, FCurSheetNum + 1);
// Anything to write?
if (AWorksheet.Comments.Count = 0) and (AWorksheet.Hyperlinks.Count = 0) then
exit;
// Create stream
SetLength(FSSheetRels, FCurSheetNum + 1);
if (boBufStream in Workbook.Options) then
FSSheetRels[FCurSheetNum] := TBufStream.Create(GetTempFileName('', Format('fpsWSR%d', [FCurSheetNum])))
else
@ -2617,13 +2665,41 @@ begin
XML_HEADER);
AppendToStream(FSSheetRels[FCurSheetNum], Format(
'<Relationships xmlns="%s">', [SCHEMAS_RELS]));
// Relationships
AppendToStream(FSSheetRels[FCurSheetNum], Format(
'<Relationship Id="rId2" Type="%s" Target="../comments%d.xml" />',
[SCHEMAS_COMMENTS, FCurSheetNum+1]));
AppendToStream(FSSheetRels[FCurSheetNum], Format(
FNext_rId := 1;
// Relationships for comments
if AWorksheet.Comments.Count > 0 then
begin
AppendToStream(FSSheetRels[FCurSheetNum], Format(
'<Relationship Id="rId1" Type="%s" Target="../drawings/vmlDrawing%d.vml" />',
[SCHEMAS_DRAWINGS, FCurSheetNum+1]));
AppendToStream(FSSheetRels[FCurSheetNum], Format(
'<Relationship Id="rId2" Type="%s" Target="../comments%d.xml" />',
[SCHEMAS_COMMENTS, FCurSheetNum+1]));
FNext_rId := 3;
end;
// Relationships for hyperlinks
if AWorksheet.Hyperlinks.Count > 0 then
begin
AVLNode := AWorksheet.Hyperlinks.FindLowest;
while Assigned(AVLNode) do
begin
hyperlink := PsHyperlink(AVLNode.Data);
if hyperlink^.Kind <> hkCell then
begin
s := Format('Id="rId%d" Type="%s" Target="%s"',
[FNext_rId, SCHEMAS_HYPERLINKS, hyperlink^.Target]);
if hyperlink^.Kind <> hkCell then
s := s + ' TargetMode="External"';
AppendToStream(FSSheetRels[FCurSheetNum],
'<Relationship ' + s + ' />');
inc(FNext_rId);
end;
AVLNode := AWorksheet.Hyperlinks.FindSuccessor(AVLNode);
end;
end;
// Footer
AppendToStream(FSSheetRels[FCurSheetNum],
@ -2749,16 +2825,14 @@ begin
// Write all worksheets which fills also the shared strings.
// Also: write comments and related files
FNext_rId := 1;
for i := 0 to Workbook.GetWorksheetCount - 1 do
begin
FWorksheet := Workbook.GetWorksheetByIndex(i);
WriteWorksheet(FWorksheet);
if FWorksheet.Comments.Count > 0 then
begin
WriteComments(FWorksheet);
WriteVmlDrawings(FWorksheet);
WriteWorksheetRels(FWorksheet);
end;
WriteComments(FWorksheet);
WriteVmlDrawings(FWorksheet);
WriteWorksheetRels(FWorksheet);
end;
// Finalization of the shared strings document
@ -2835,6 +2909,7 @@ begin
WriteSheetViews(FSSheets[FCurSheetNum], AWorksheet);
WriteCols(FSSheets[FCurSheetNum], AWorksheet);
WriteSheetData(FSSheets[FCurSheetNum], AWorksheet);
WriteHyperlinks(FSSheets[FCurSheetNum], AWorksheet);
WriteMergedCells(FSSheets[FCurSheetNum], AWorksheet);
// Footer
@ -3026,19 +3101,19 @@ begin
end;
for i:=0 to High(FSComments) do begin
if FSComments[i] = nil then continue;
if (FSComments[i] = nil) or (FSComments[i].Size = 0) then continue;
FSComments[i].Position := 0;
FZip.Entries.AddFileEntry(FSComments[i], OOXML_PATH_XL + Format('comments%d.xml', [i+1]));
end;
for i:=0 to High(FSSheetRels) do begin
if FSSheetRels[i] = nil then continue;
if (FSSheetRels[i] = nil) or (FSSheetRels[i].Size = 0) then continue;
FSSheetRels[i].Position := 0;
FZip.Entries.AddFileEntry(FSSheetRels[i], OOXML_PATH_XL_WORKSHEETS_RELS + Format('sheet%d.xml.rels', [i+1]));
end;
for i:=0 to High(FSVmlDrawings) do begin
if FSVmlDrawings[i] = nil then continue;
if (FSVmlDrawings[i] = nil) or (FSVmlDrawings[i].Size = 0) then continue;
FSVmlDrawings[i].Position := 0;
FZip.Entries.AddFileEntry(FSVmlDrawings[i], OOXML_PATH_XL_DRAWINGS + Format('vmlDrawing%d.vml', [i+1]));
end;
@ -3206,15 +3281,19 @@ begin
end;
end;
{*******************************************************************
* TsSpreadOOXMLWriter.WriteLabel ()
*
* DESCRIPTION: Writes a string to the sheet
* If the string length exceeds 32767 bytes, the string
* will be truncated and an exception will be raised as
* a warning.
*
*******************************************************************}
procedure TsSpreadOOXMLWriter.WriteHyperlink(AStream: TStream;
const ARow, ACol: Cardinal; ACell: PCell);
begin
if FWorksheet.IsHyperlink(ACell) then
WriteLabel(AStream, ARow, ACol, FWorksheet.ReadAsUTF8Text(ACell), ACell);
end;
{@@ ----------------------------------------------------------------------------
Writes a string to the stream
If the string length exceeds 32767 bytes, the string will be truncated and a
warning will be written to the workbook's log.
-------------------------------------------------------------------------------}
procedure TsSpreadOOXMLWriter.WriteLabel(AStream: TStream; const ARow,
ACol: Cardinal; const AValue: string; ACell: PCell);
const