fpspreadsheet: Write hyperlinks to xls files (BIFF8 only, feature not supported by others)

git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@3969 8e941d3f-bd1b-0410-a28a-d453659cc2b4

components/fpspreadsheet/fpsreaderwriter.pas

@@ -80,6 +80,10 @@ type
   TCommentsCallback = procedure (AComment: PsComment; ACommentIndex: Integer;
     AStream: TStream) of object;
 
+  {@@ Callback function when iterating hyperlinks while accessing a stream }
+  THyperlinksCallback = procedure (AHyperlink: PsHyperlink;
+    AStream: TStream) of object;
+
   {@@ Custom writer of spreadsheet files. "Custom" means that it provides only
     the basic functionality. The main implementation is done in derived classes
     for each individual file format. }
@@ -126,6 +130,8 @@ type
       ACallback: TCellsCallback);
     procedure IterateThroughComments(AStream: TStream; AComments: TAVLTree;
       ACallback: TCommentsCallback);
+    procedure IterateThroughHyperlinks(AStream: TStream; AHyperlinks: TAVLTree;
+      ACallback: THyperlinksCallback);
     procedure WriteToFile(const AFileName: string;
       const AOverwriteExisting: Boolean = False); override;
     procedure WriteToStream(AStream: TStream); override;
@@ -481,7 +487,7 @@ end;
 
 {@@ ----------------------------------------------------------------------------
   A generic method to iterate through all comments in a worksheet and call a
-  callback routine for each cell.
+  callback routine for each comment.
 
   @param  AStream    The output stream, passed to the callback routine.
   @param  AComments  List of comments to be iterated
@@ -504,6 +510,31 @@ begin
   end;
 end;
 
+{@@ ----------------------------------------------------------------------------
+  A generic method to iterate through all hyperlinks in a worksheet and call a
+  callback routine for each hyperlink.
+
+  @param  AStream      The output stream, passed to the callback routine.
+  @param  AHyperlinks  List of hyperlinks to be iterated
+  @param  ACallback    Callback routine; it requires as arguments a pointer to
+                       the hyperlink record as well as the destination stream.
+-------------------------------------------------------------------------------}
+procedure TsCustomSpreadWriter.IterateThroughHyperlinks(AStream: TStream;
+  AHyperlinks: TAVLTree; ACallback: THyperlinksCallback);
+var
+  AVLNode: TAVLTreeNode;
+  index: Integer;
+begin
+  index := 0;
+  AVLNode := AHyperlinks.FindLowest;
+  while Assigned(AVLNode) do
+  begin
+    ACallback(PsHyperlink(AVLNode.Data), AStream);
+    AVLNode := AHyperlinks.FindSuccessor(AVLNode);
+    inc(index);
+  end;
+end;
+
 {@@ ----------------------------------------------------------------------------
   Iterates through all cells and collects the number formats in
   FNumFormatList (without duplicates).

components/fpspreadsheet/reference/BIFFExplorer/bebiffgrid.pas

@@ -2949,7 +2949,7 @@ begin
       numBytes := 4;
       Move(FBuffer[FBufferIndex], dw, numbytes);
       nchar := DWordToLE(dw);
-      ShowInRow(FCurrRow, FBufferIndex, numbytes, IntToStr(size),
+      ShowInRow(FCurrRow, FBufferIndex, numbytes, IntToStr(nchar),
         'Character count of the shortened file path and name, incl trailing zero byte.');
       inc(n);
 
@@ -2995,7 +2995,7 @@ begin
         SetLength(widestr, nchar);
         Move(FBuffer[FBufferIndex], widestr[1], numbytes);
         s := UTF16ToUTF8(widestr);
-        ShowInRow(FCurrRow, FBufferIndex, numbytes, IntToStr(size),
+        ShowInRow(FCurrRow, FBufferIndex, numbytes, s,
           'Character array of extended file path and array (No unicode string header, always 16-bit characters, NOT zero-terminated)');
         inc(n);
       end;

components/fpspreadsheet/xlsbiff8.pas

@@ -122,6 +122,7 @@ type
       ACommentIndex: Integer; AStream: TStream);
     procedure WriteCommentsNoteCallback(AComment: PsComment;
       ACommentIndex: Integer; AStream: TStream);
+    procedure WriteHyperlinksCallback(AHyperlink: PsHyperlink; AStream: TStream);
 
   protected
     { Record writing methods }
@@ -134,6 +135,13 @@ type
     procedure WriteFont(AStream: TStream; AFont: TsFont);
     procedure WriteFonts(AStream: TStream);
     procedure WriteIndex(AStream: TStream);
+    procedure WriteHyperlink(AStream: TStream; const ARow, ACol: Cardinal;
+      ACell: PCell); override;
+    procedure WriteHYPERLINKRecord(AStream: TStream; AHyperlink: PsHyperlink;
+      AWorksheet: TsWorksheet);
+    procedure WriteHyperlinks(AStream: TStream; AWorksheet: TsWorksheet);
+    procedure WriteHYPERLINKTOOLTIP(AStream: TStream; const ARow, ACol: Cardinal;
+      const ATooltip: String);
     procedure WriteLabel(AStream: TStream; const ARow, ACol: Cardinal;
       const AValue: string; ACell: PCell); override;
     procedure WriteMergedCells(AStream: TStream; AWorksheet: TsWorksheet);
@@ -251,7 +259,7 @@ var
 implementation
 
 uses
-  Math, lconvencoding,
+  Math, lconvencoding, URIParser, DOS,
   fpsStrings, fpsStreams, fpsReaderWriter, fpsExprParser, xlsEscher;
 
 const
@@ -261,6 +269,8 @@ const
      INT_EXCEL_ID_SST                    = $00FC;  // BIFF8 only
      INT_EXCEL_ID_LABELSST               = $00FD;  // BIFF8 only
      INT_EXCEL_ID_TXO                    = $01B6;  // BIFF8 only
+     INT_EXCEL_ID_HYPERLINK              = $01B8;  // BIFF8 only
+     INT_EXCEL_ID_HYPERLINKTOOLTIP       = $0800;  // BIFF8 only
 {%H-}INT_EXCEL_ID_FORCEFULLCALCULATION   = $08A3;
 
    { Excel OBJ subrecord IDs }
@@ -311,6 +321,13 @@ const
      XF_ROTATION_90DEG_CW                = 180;
      XF_ROTATION_STACKED                 = 255;   // Letters stacked top to bottom, but not rotated
 
+     TEXT_ROTATIONS: Array[TsTextRotation] of Byte = (
+       XF_ROTATION_HORIZONTAL,
+       XF_ROTATION_90DEG_CW,
+       XF_ROTATION_90DEG_CCW,
+       XF_ROTATION_STACKED
+     );
+
    { XF CELL BORDER LINE STYLES }
      MASK_XF_BORDER_LEFT                 = $0000000F;
      MASK_XF_BORDER_RIGHT                = $000000F0;
@@ -331,15 +348,17 @@ const
    { XF CELL BACKGROUND PATTERN }
      MASK_XF_BACKGROUND_PATTERN          = $FC000000;
 
-     TEXT_ROTATIONS: Array[TsTextRotation] of Byte = (
+   { HLINK FLAGS }
-       XF_ROTATION_HORIZONTAL,
+     MASK_HLINK_LINK                     = $00000001;
-       XF_ROTATION_90DEG_CW,
+     MASK_HLINK_ABSOLUTE                 = $00000002;
-       XF_ROTATION_90DEG_CCW,
+     MASK_HLINK_DESCRIPTION              = $00000014;
-       XF_ROTATION_STACKED
+     MASK_HLINK_TEXTMARK                 = $00000008;
-     );
+     MASK_HLINK_TARGETFRAME              = $00000080;
+     MASK_HLINK_UNCPATH                  = $00000100;
 
      SHAPEID_BASE = 1024;
 
+
 type
   TBIFF8_DimensionsRecord = packed record
     RecordID: Word;
@@ -1512,6 +1531,7 @@ begin
       WriteWindow2(AStream, FWorksheet);
       WritePane(AStream, FWorksheet, isBIFF8, pane);
       WriteSelection(AStream, FWorksheet, pane);
+      WriteHyperlinks(AStream, FWorksheet);
 
       WriteMergedCells(AStream, FWorksheet);
 
@@ -2151,6 +2171,210 @@ begin
   { OBS: It seems to be no problem just ignoring this part of the record }
 end;
 
+{@@ ----------------------------------------------------------------------------
+  Inherited method for writing a hyperlink
+  Just writes the cell text; the hyperlink is written together with the other
+  hyperlinks later.
+-------------------------------------------------------------------------------}
+procedure TsSpreadBIFF8Writer.WriteHyperlink(AStream: TStream;
+  const ARow, ACol: Cardinal; ACell: PCell);
+begin
+  WriteLabel(AStream, ARow, ACol, FWorksheet.ReadAsUTF8Text(ACell), ACell);
+  ACell^.ContentType := cctHyperlink;
+end;
+
+{@@ ----------------------------------------------------------------------------
+  Writes an Excel 8 HYPERLINK record
+-------------------------------------------------------------------------------}
+procedure TsSpreadBIFF8Writer.WriteHYPERLINKRecord(AStream: TStream;
+  AHyperlink: PsHyperlink; AWorksheet: TsWorksheet);
+var
+  temp: TStream;
+  guid: TGUID;
+  widestr: widestring;
+  ansistr: ansistring;
+  descr: String;
+  fn: String;
+  flags: DWord;
+  markpos: Integer;
+  size: Integer;
+  cell: PCell;
+begin
+  cell := AWorksheet.FindCell(AHyperlink^.Row, AHyperlink^.Col);
+  if (cell = nil) or (AHyperlink^.Kind = hkNone) then
+    exit;
+
+  descr := AWorksheet.ReadAsUTF8Text(cell);      // Hyperlink description
+  markpos := UTF8Pos('#', AHyperlink^.Target);   // Position of # in hyperlink target
+
+  // Since the length of the record is not known in the first place we write
+  // the data to a temporary stream at first.
+  temp := TMemoryStream.Create;
+  try
+    { Cell range using the same hyperlink - we support only single cells }
+    temp.WriteWord(WordToLE(cell^.Row));   // first row
+    temp.WriteWord(WordToLE(cell^.Row));   // last row
+    temp.WriteWord(WordToLE(cell^.Col));   // first column
+    temp.WriteWord(WordToLE(cell^.Col));   // last column
+
+    { GUID of standard link }
+    guid := StringToGuid('{79EAC9D0-BAF9-11CE-8C82-00AA004BA90B}');
+    temp.WriteBuffer(guid, SizeOf(guid));
+
+    { unknown }
+    temp.WriteDWord(DWordToLe($00000002));
+
+    { option flags }
+    flags := 0;
+    case AHyperlink^.Kind of
+      hkCell:
+        flags := MASK_HLINK_TEXTMARK or MASK_HLINK_DESCRIPTION;
+      hkURI:
+        flags := MASK_HLINK_LINK or MASK_HLINK_ABSOLUTE;
+    end;
+    if descr <> AHyperlink^.Target then
+      flags := flags or MASK_HLINK_DESCRIPTION;  // has description
+    if markpos > 0 then                          // has # in target
+      flags := flags or MASK_HLINK_TEXTMARK;
+    temp.WriteDWord(DWordToLE(flags));
+
+    { description }
+    if flags and MASK_HLINK_DESCRIPTION <> 0 then
+    begin
+      widestr := UTF8Decode(descr);
+      { Character count incl trailing zero }
+      temp.WriteDWord(DWordToLE(Length(wideStr) + 1));
+      { Character array (16-bit characters), plus trailing zeros }
+      temp.WriteBuffer(wideStr[1], (Length(wideStr)+1)*SizeOf(widechar));
+    end;
+
+    if AHyperlink^.Kind = hkURI then
+    begin
+      if URIToFilename(AHyperlink^.Target, 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);
+        { 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 }
+        temp.WriteBuffer(ansistr[1], Length(ansistr)+1);
+        { Unknown }
+        temp.WriteDWord(DWordToLE($DEADFFFF));
+        temp.WriteDWord(0);
+        temp.WriteDWord(0);
+        temp.WriteDWord(0);
+        temp.WriteDWord(0);
+        temp.WriteDWord(0);
+        { Size of following file link fields }
+        widestr := UTF8ToUTF16(fn);
+        size := 4 + 2 + Length(wideStr)*SizeOf(widechar);
+        temp.WriteDWord(DWordToLE(size));
+        if size > 0 then
+        begin
+          { Character count of extended file name }
+          temp.WriteDWord(DWordToLE(Length(widestr)*SizeOf(WideChar)));
+          { Unknown }
+          temp.WriteWord(WordToLE($0003));
+          { Character array, 16-bit characters, NOT ZERO-TERMINATED! }
+          temp.WriteBuffer(widestr[1], Length(wideStr)*SizeOf(WideChar));
+        end;
+      end
+      else begin  { Hyperlink target is a URL }
+        widestr := UTF8Decode(AHyperlink^.Target);
+        { GUID of URL Moniker }
+        guid := StringToGUID('{79EAC9E0-BAF9-11CE-8C82-00AA004BA90B}');
+        temp.WriteBuffer(guid, SizeOf(guid));
+        { Character count incl trailing zero }
+        temp.WriteDWord(DWordToLE(Length(wideStr)+1)*SizeOf(wideChar));
+        { Character array plus trailing zero (16-bit characters), plus trailing zeros }
+        temp.WriteBuffer(wideStr[1], (length(wideStr)+1)*SizeOf(wideChar));
+      end;
+    end; // hkURI
+
+    // Hyperlink contains a text mark (#)
+    if flags and MASK_HLINK_TEXTMARK <> 0 then
+    begin
+      // Extract text mark without "#" and convert to 16-bit characters
+      if markpos > 0 then
+        widestr := UTF8Decode(UTF8Copy(AHyperlink^.Target, markpos+1, Length(AHyperlink^.Target)))
+      else if AHyperlink^.Kind = hkCell then
+        widestr := UTF8Decode(AHyperlink^.Target);
+      { Character count of text mark, incl trailing zero }
+      temp.WriteDWord(DWordToLE(Length(wideStr) + 1));
+      { Character array (16-bit characters) plus trailing zeros }
+      temp.WriteBuffer(wideStr[1], (Length(wideStr)+1) * SizeOf(WideChar));
+    end;
+
+    { BIFF record header }
+    WriteBIFFHeader(AStream, INT_EXCEL_ID_HYPERLINK, temp.Size);
+
+    { Record data }
+    temp.Position := 0;
+    AStream.CopyFrom(temp, temp.Size);
+
+  finally
+    temp.Free;
+  end;
+end;
+
+{@@ ----------------------------------------------------------------------------
+  Writes all hyperlinks
+-------------------------------------------------------------------------------}
+procedure TsSpreadBIFF8Writer.WriteHyperlinks(AStream: TStream;
+  AWorksheet: TsWorksheet);
+begin
+  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 }
+  WriteHyperlinkRecord(AStream, AHyperlink, FWorksheet);
+
+  { Write HYPERLINK TOOLTIP record }
+  if AHyperlink^.Tooltip <> '' then
+    WriteHyperlinkTooltip(AStream, AHyperlink^.Row, AHyperlink^.Col, AHyperlink^.Tooltip);
+end;
+
+{@@ ----------------------------------------------------------------------------
+  Writes a HYPERLINK TOOLTIP record
+-------------------------------------------------------------------------------}
+procedure TsSpreadBIFF8Writer.WriteHyperlinkTooltip(AStream: TStream;
+  const ARow, ACol: Cardinal; const ATooltip: String);
+var
+  widestr: widestring;
+begin
+  widestr := UTF8Decode(ATooltip);
+
+  { BIFF record header }
+  WriteBiffHeader(AStream, INT_EXCEL_ID_HYPERLINKTOOLTIP,
+    10 + (Length(wideStr)+1) * SizeOf(widechar));
+
+  { Repeated record ID }
+  AStream.WriteWord(WordToLe(INT_EXCEL_ID_HYPERLINKTOOLTIP));
+
+  { Cell range using the same hyperlink tooltip - we support only single cells }
+  AStream.WriteWord(WordToLE(ARow));   // first row
+  AStream.WriteWord(WordToLE(ARow));   // last row
+  AStream.WriteWord(WordToLE(ACol));   // first column
+  AStream.WriteWord(WordToLE(ACol));   // last column
+
+  { Tooltop characters, no length, but trailing zero }
+  AStream.WriteBuffer(wideStr[1], (Length(widestr)+1)*SizeOf(wideChar));
+end;
+
+
 {@@ ----------------------------------------------------------------------------
   Writes an Excel 8 LABEL record (string cell value)