lazarus-ccr/components/fpspreadsheet/source/common/fpspreadsheet_hyperlinks.inc

{ Included by fpspreadsheet.pas }

{ Contains code for hyperlinks }

{@@ ----------------------------------------------------------------------------
  Checks whether the specified cell contains a hyperlink and returns a pointer
  to the hyperlink data.

  @param  ACell  Pointer to the cell
  @return Pointer to the TsHyperlink record, or NIL if the cell does not contain
          a hyperlink.
-------------------------------------------------------------------------------}
function TsWorksheet.FindHyperlink(ACell: PCell): PsHyperlink;
begin
  if HasHyperlink(ACell) then
    Result := PsHyperlink(FHyperlinks.FindByRowCol(ACell^.Row, ACell^.Col))
  else
    Result := nil;
end;


{@@ ----------------------------------------------------------------------------
  Reads the hyperlink information of a specified cell.

  @param   ACell         Pointer to the cell considered
  @returns Record with the hyperlink data assigned to the cell.
           If the cell is not a hyperlink the result field Kind is hkNone.
-------------------------------------------------------------------------------}
function TsWorksheet.ReadHyperlink(ACell: PCell): TsHyperlink;
var
  hyperlink: PsHyperlink;
begin
  hyperlink := FindHyperlink(ACell);
  if hyperlink <> nil then
    Result := hyperlink^
  else
  begin
    Result.Row := ACell^.Row;
    Result.Col := ACell^.Col;
    Result.Target := '';
    Result.Tooltip := '';
  end;
end;


{@@ ----------------------------------------------------------------------------
  Removes a hyperlink from the specified cell. Releaes memory occupied by
  the associated TsHyperlink record. Cell content type is converted to
  cctUTF8String.
-------------------------------------------------------------------------------}
procedure TsWorksheet.RemoveHyperlink(ACell: PCell);
begin
  if HasHyperlink(ACell) then
  begin
    FHyperlinks.DeleteHyperlink(ACell^.Row, ACell^.Col);
    Exclude(ACell^.Flags, cfHyperlink);
  end;
end;


{@@ ----------------------------------------------------------------------------
  Checks whether the passed string represents a valid hyperlink target

  @param   AValue  String to be checked. Must be either a fully qualified URI,
                   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
  u: TUri;
  sheet: TsWorksheet;
  r, c: Cardinal;
begin
  Result := false;
  AErrMsg := '';
  if AValue = '' then
  begin
    AErrMsg := rsEmptyHyperlink;
    exit;
  end else
  if (AValue[1] = '#') then
  begin
    Delete(AValue, 1, 1);
    if not FWorkbook.TryStrToCell(AValue, sheet, r, c) then
    begin
      AErrMsg := Format(rsNoValidHyperlinkInternal, ['#'+AValue]);
      exit;
    end;
  end else
  begin
    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;
    end;
  end;
end;


{@@ ----------------------------------------------------------------------------
  Assigns a hyperlink to the cell at the specified row and column
  Cell content is not affected by the presence of a hyperlink.

  @param  ARow          Row index of the cell considered
  @param  ACol          Column index of 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.
  @param  ATooltip      Text for popup tooltip hint used by Excel
  @returns Pointer to the cell with the hyperlink
-------------------------------------------------------------------------------}
function TsWorksheet.WriteHyperlink(ARow, ACol: Cardinal; ATarget: String;
  ATooltip: String = ''): PCell;
begin
  Result := GetCell(ARow, ACol);
  WriteHyperlink(Result, ATarget, ATooltip);
end;


{@@ ----------------------------------------------------------------------------
  Assigns a hyperlink to the specified cell.

  @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. 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;
  ATooltip: String = '');

  function GetDisplayText(ATarget: String): String;
  var
    target, bm: String;
  begin
    SplitHyperlink(ATarget, target, bm);
    if pos('file:', lowercase(ATarget))=1 then
    begin
      URIToFilename(target, Result);
      ForcePathDelims(Result);
      if bm <> '' then Result := Result + '#' + bm;
    end else
    if target = '' then
      Result := bm
    else
      Result := ATarget;
  end;

var
  fmt: TsCellFormat;
  noCellText: Boolean = false;
begin
  if ACell = nil then
    exit;

  fmt := ReadCellFormat(ACell);

  // Empty target string removes the hyperlink. Resets the font from hyperlink
  // to default font.
  if ATarget = '' then begin
    RemoveHyperlink(ACell);
    if fmt.FontIndex = HYPERLINK_FONTINDEX then
      WriteFont(ACell, DEFAULT_FONTINDEX);
    exit;
  end;

  // Detect whether the cell already has a hyperlink, but has no other content.
  if HasHyperlink(ACell) then
    noCellText := (ACell^.ContentType = cctUTF8String) and
      (GetDisplayText(ReadHyperlink(ACell).Target) = ReadAsText(ACell));

  // Attach the hyperlink to the cell
  FHyperlinks.AddHyperlink(ACell^.Row, ACell^.Col, ATarget, ATooltip);
  Include(ACell^.Flags, cfHyperlink);

  // If there is no other cell content use the target as cell label string.
  if (ACell^.ContentType = cctEmpty) or noCellText then
  begin
    ACell^.ContentType := cctUTF8String;
    ACell^.UTF8StringValue := GetDisplayText(ATarget);
  end;

  // Select the hyperlink font.
  if fmt.FontIndex = DEFAULT_FONTINDEX then
  begin
    fmt.FontIndex := HYPERLINK_FONTINDEX;
    Include(fmt.UsedFormattingFields, uffFont);
    ACell^.FormatIndex := FWorkbook.AddCellFormat(fmt);
  end;

  ChangedCell(ACell^.Row, ACell^.Col);
end;


{==============================================================================}
{  TsWorkbook code for hyperlinls                                              }
{==============================================================================}

{@@ ----------------------------------------------------------------------------
  Returns the hypertext font. This is font with index 6 in the font list
-------------------------------------------------------------------------------}
function TsWorkbook.GetHyperlinkFont: TsFont;
begin
  Result := GetFont(HYPERLINK_FONTINDEX);
end;