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

fpspreadsheet: Prepare infrastructure for cell hyperlinks

Browse Source 
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@3955 8e941d3f-bd1b-0410-a28a-d453659cc2b4
This commit is contained in:
wp_xxyyzz
2015-02-22 23:38:28 +00:00
parent eddf623803
commit 4f6184f243
10 changed files with 476 additions and 81 deletions
Download Patch File Download Diff File Expand all files Collapse all files

7
components/fpspreadsheet/examples/fpsctrls/main.lfm
View File

@ -46,6 +46,7 @@ object MainForm: TMainForm
TitleFont.Height = -13
TitleFont.Name = 'Arial'
TitleStyle = tsNative
OnClickHyperlink = WorksheetGridClickHyperlink
end
end
object InspectorTabControl: TTabControl
@ -529,6 +530,12 @@ object MainForm: TMainForm
Caption = 'ToolButton52'
Style = tbsDivider
end
object ToolButton4: TToolButton
Left = 427
Top = 0
Caption = 'ToolButton4'
OnClick = ToolButton4Click
end
end
object ToolBar3: TToolBar
Left = 0

15
components/fpspreadsheet/examples/fpsctrls/main.pas
View File

@ -262,6 +262,7 @@ type
ToolButton38: TToolButton;
ToolButton39: TToolButton;
TbCommentAdd: TToolButton;
ToolButton4: TToolButton;
ToolButton40: TToolButton;
ToolButton41: TToolButton;
ToolButton42: TToolButton;
@ -291,6 +292,9 @@ type
procedure AcRowDeleteExecute(Sender: TObject);
procedure AcViewInspectorExecute(Sender: TObject);
procedure InspectorTabControlChange(Sender: TObject);
procedure ToolButton4Click(Sender: TObject);
procedure WorksheetGridClickHyperlink(Sender: TObject;
const AHyperlink: TsHyperlink);
private
{ private declarations }
procedure UpdateCaption;
@ -395,6 +399,17 @@ begin
Inspector.Mode := TsInspectorMode(InspectorTabControl.TabIndex);
end;
procedure TMainForm.ToolButton4Click(Sender: TObject);
begin
WorkbookSource.Worksheet.WriteHyperlink(0, 0, hkURL, 'http://www.chip.de', 'Link to chip.de', 'chip.de');
end;
procedure TMainForm.WorksheetGridClickHyperlink(Sender: TObject;
const AHyperlink: TsHyperlink);
begin
ShowMessage('Hyperlink ' + AHyperlink.Destination + ' clicked');
end;
procedure TMainForm.UpdateCaption;
begin
if WorkbookSource = nil then

4
components/fpspreadsheet/examples/fpsgrid/mainform.lfm
View File

@ -1,7 +1,7 @@
object Form1: TForm1
Left = 409
Left = 344
Height = 649
Top = 248
Top = 127
Width = 894
Caption = 'fpsGrid'
ClientHeight = 649

4
components/fpspreadsheet/fps.inc
View File

@ -16,9 +16,7 @@
methods can only be used to change cell formatting then. }
{.$DEFINE FPS_NO_RECORD_HELPERS}
{ In new versions of fpc, records can contain private fields. Activate the
define FPS_NO_PRIVATE_FIELDS_IN_RECORDS if this is not supported. }
{.$DEFINE FPS_NO_PRIVATE_FIELDS_IN_RECORDS}
{------------------------------------------------------------------------------}
{ The next defines activate code duplicated from new compiler versions in case
an old compiler is used. }

16
components/fpspreadsheet/fpscell.pas
View File

@ -20,6 +20,7 @@ type
function GetFont: TsFont;
function GetFontIndex: integer;
function GetHorAlignment: TsHorAlignment;
function GetHyperlink: TsHyperlink;
function GetNumberFormat: TsNumberFormat;
function GetNumberFormatStr: String;
function GetTextRotation: TsTextRotation;
@ -34,6 +35,7 @@ type
procedure SetComment(const AValue: String);
procedure SetFontIndex(const AValue: Integer);
procedure SetHorAlignment(const AValue: TsHorAlignment);
procedure SetHyperlink(const AValue: TsHyperlink);
procedure SetNumberFormat(const AValue: TsNumberFormat);
procedure SetNumberFormatStr(const AValue: String);
procedure SetTextRotation(const AValue: TsTextRotation);
@ -54,11 +56,15 @@ type
read GetBorderStyles write SetBorderStyles;
property CellFormat: TsCellFormat
read GetCellFormat write SetCellFormat;
property Comment: String
read GetComment write Comment;
property Font: TsFont read GetFont;
property FontIndex: Integer
read GetFontIndex write SetFontIndex;
property HorAlignment: TsHorAlignment
read GetHorAlignment write SetHorAlignment;
property Hyperlink: TsHyperlink
read GetHyperlink write SetHyperlink;
property NumberFormat: TsNumberFormat
read GetNumberFormat write SetNumberFormat;
property NumberFormatStr: String
@ -124,6 +130,11 @@ begin
Result := Worksheet.ReadHorAlignment(@Self);
end;
function TCellHelper.GetHyperlink: TsHyperlink;
begin
Result := Worksheet.ReadHyperlink(@self);
end;
function TCellHelper.GetNumberFormat: TsNumberFormat;
var
fmt: PsCellFormat;
@ -206,6 +217,11 @@ begin
Worksheet.WriteHorAlignment(@self, AValue);
end;
procedure TCellHelper.SetHyperlink(const AValue: TsHyperlink);
begin
Worksheet.WriteHyperlink(@self, AValue);
end;
procedure TCellHelper.SetNumberFormat(const AValue: TsNumberFormat);
var
fmt: TsCellFormat;

331
components/fpspreadsheet/fpspreadsheet.pas
View File

@ -46,24 +46,16 @@ type
@see ReadAsUTF8Text }
TCell = record
{$IFNDEF NO_PRIVATE_FIELDS_IN_RECORDS}
private
{$ENDIF}
{ Status flags }
Flags: TsCellFlags;
{$IFNDEF NO_PRIVATE_FIELDS_IN_RECORDS}
public
{$ENDIF}
{ Location of the cell }
Worksheet: TsWorksheet;
Col: Cardinal; // zero-based
Row: Cardinal; // zero-based
{ Index of format record }
{ Status flags }
Flags: TsCellFlags;
{ Index of format record in the workbook's FCellFormatList }
FormatIndex: Integer;
{ Special information }
SharedFormulaBase: PCell; // Cell containing the shared formula
// MergeBase: PCell; // Upper left cell of a merged range
{ Cell content }
UTF8StringValue: String; // Strings cannot be part of a variant record
FormulaValue: String;
@ -102,18 +94,6 @@ type
{@@ Pointer to a TCol record }
PCol = ^TCol;
{@@ The record TsComment contains a comment attached to a cell.
@param Row (0-based) index of the row with the cell
@param Col (0-based) index of the column with the cell
@param Text Comment text }
TsComment = record
Row, Col: Cardinal;
Text: String;
end;
{@@ Pointer to a TsComment record }
PsComment = ^TsComment;
{@@ Worksheet user interface options:
@param soShowGridLines Show or hide the grid lines in the spreadsheet
@param soShowHeaders Show or hide the column or row headers of the spreadsheet
@ -147,7 +127,8 @@ type
FCells: TAvlTree; // Items are TCell
FComments: TAvlTree; // Items are TsComment
FMergedCells: TAvlTree; // Items are TsCellRange
FCurrentNode: TAVLTreeNode; // For GetFirstCell and GetNextCell
FHyperlinks: TAvlTree; // Items are TsHyperlink
FCurrentNode: TAVLTreeNode; // for GetFirstCell and GetNextCell
FRows, FCols: TIndexedAVLTree; // This lists contain only rows or cols with styles different from default
FActiveCellRow: Cardinal;
FActiveCellCol: Cardinal;
@ -181,6 +162,7 @@ type
procedure RemoveCellRangesCallback(data, arg: pointer);
procedure RemoveCellsCallback(data, arg: pointer);
procedure RemoveCommentsCallback(data, arg: pointer);
procedure RemoveHyperlinksCallback(data, arg: pointer);
protected
function CellUsedInFormula(ARow, ACol: Cardinal): Boolean;
@ -190,10 +172,17 @@ type
function RemoveCell(ARow, ACol: Cardinal): PCell;
procedure RemoveAndFreeCell(ARow, ACol: Cardinal);
// Hyperlinks
procedure RemoveAllHyperlinks;
// Comments
procedure RemoveAllComments;
// Merged cells
function CellIsInMergedRange(ARow, ACol: Cardinal; ARange: PsCellRange): Boolean;
function FindMergedRangeForBase(ABaseRow, ABaseCol: Cardinal): PsCellRange;
function FindMergedRangeForCell(ARow, ACol: Cardinal): PsCellRange;
procedure RemoveAllMergedRanges;
procedure RemoveMergedRange(ABaseRow, ABaseCol: Cardinal);
// Sorting
@ -225,7 +214,6 @@ type
function ReadAsDateTime(ACell: PCell; out AResult: TDateTime): Boolean; overload;
function ReadFormulaAsString(ACell: PCell; ALocalized: Boolean = false): String;
function ReadNumericValue(ACell: PCell; out AValue: Double): Boolean;
// function ReadComment(ACell: PCell): String;
{ Reading of cell attributes }
function GetDisplayedDecimals(ACell: PCell): Byte;
@ -247,19 +235,6 @@ type
function ReadVertAlignment(ACell: PCell): TsVertAlignment;
function ReadWordwrap(ACell: PCell): boolean;
{ Merged cells }
procedure MergeCells(ARow1, ACol1, ARow2, ACol2: Cardinal); overload;
procedure MergeCells(ARange: String); overload;
procedure UnmergeCells(ARow, ACol: Cardinal); overload;
procedure UnmergeCells(ARange: String); overload;
function FindMergeBase(ACell: PCell): PCell;
function FindMergedRange(ACell: PCell; out ARow1, ACol1, ARow2, ACol2: Cardinal): Boolean;
procedure GetMergedCellRanges(out AList: TsCellRangeArray);
function InSameMergedRange(ACell1, ACell2: PCell): Boolean;
function IsMergeBase(ACell: PCell): Boolean;
function IsMerged(ACell: PCell): Boolean;
procedure RemoveAllMergedCells;
{ Writing of values }
function WriteBlank(ARow, ACol: Cardinal): PCell; overload;
procedure WriteBlank(ACell: PCell); overload;
@ -502,11 +477,34 @@ type
function HasComment(ACell: PCell): Boolean;
function ReadComment(ARow, ACol: Cardinal): String; overload;
function ReadComment(ACell: PCell): string; overload;
procedure RemoveAllComments;
procedure RemoveComment(ACell: PCell);
function WriteComment(ARow, ACol: Cardinal; AText: String): PCell; overload;
procedure WriteComment(ACell: PCell; AText: String); overload;
// Hyperlinks
function FindHyperlink(ARow, ACol: Cardinal): PsHyperlink; overload;
function FindHyperlink(ACell: PCell): PsHyperlink; overload;
function IsHyperlink(ACell: PCell): Boolean;
function ReadHyperlink(ARow, ACol: Cardinal): TsHyperlink; overload;
function ReadHyperlink(ACell: PCell): TsHyperlink;
procedure RemoveHyperlink(ACell: PCell; AKeepText: Boolean);
function WriteHyperlink(ARow, ACol: Cardinal; AKind: TsHyperlinkKind;
ADestination: String; ADisplayText: String = ''; ANote: String = ''): PCell; overload;
procedure WriteHyperlink(ACell: PCell; AKind: TsHyperlinkKind;
ADestination: String; ADisplayText: String = ''; ANote: String = ''); overload;
{ Merged cells }
procedure MergeCells(ARow1, ACol1, ARow2, ACol2: Cardinal); overload;
procedure MergeCells(ARange: String); overload;
procedure UnmergeCells(ARow, ACol: Cardinal); overload;
procedure UnmergeCells(ARange: String); overload;
function FindMergeBase(ACell: PCell): PCell;
function FindMergedRange(ACell: PCell; out ARow1, ACol1, ARow2, ACol2: Cardinal): Boolean;
procedure GetMergedCellRanges(out AList: TsCellRangeArray);
function InSameMergedRange(ACell1, ACell2: PCell): Boolean;
function IsMergeBase(ACell: PCell): Boolean;
function IsMerged(ACell: PCell): Boolean;
// Notification of changed cells content and format
procedure ChangedCell(ARow, ACol: Cardinal);
procedure ChangedFont(ARow, ACol: Cardinal);
@ -522,6 +520,8 @@ type
property Comments: TAVLTree read FComments;
{@@ List of merged cells (contains TsCellRange records) }
property MergedCells: TAVLTree read FMergedCells;
{@@ List of hyperlink information records }
property Hyperlinks: TAVLTree read FHyperlinks;
{@@ FormatSettings for localization of some formatting strings }
property FormatSettings: TFormatSettings read GetFormatSettings;
{@@ Name of the sheet. In the popular spreadsheet applications this is
@ -726,6 +726,7 @@ type
function GetFont(AIndex: Integer): TsFont;
function GetFontAsString(AIndex: Integer): String;
function GetFontCount: Integer;
function GetHyperlinkFont: TsFont;
procedure InitFonts;
procedure RemoveAllFonts;
procedure SetDefaultFont(const AFontName: String; ASize: Single);
@ -766,6 +767,7 @@ type
property VirtualColCount: cardinal read FVirtualColCount write SetVirtualColCount;
property VirtualRowCount: cardinal read FVirtualRowCount write SetVirtualRowCount;
property Options: TsWorkbookOptions read FOptions write FOptions;
{@@ This event fires whenever a new worksheet is added }
property OnAddWorksheet: TsWorksheetEvent read FOnAddWorksheet write FOnAddWorksheet;
{@@ This event fires whenever the workbook palette changes. }
@ -1329,6 +1331,13 @@ begin
Result := LongInt(PsCellRange(Item1)^.Col1) - PsCellRange(Item2)^.Col1;
end;
function CompareHyperlinks(Item1, Item2: Pointer): Integer;
begin
Result := LongInt(PsHyperlink(Item1)^.Row) - PsHyperlink(Item2)^.Row;
if Result = 0 then
Result := LongInt(PsHyperlink(Item1)^.Col) - PsHyperlink(Item2)^.Col;
end;
{@@ ----------------------------------------------------------------------------
Write the fonts stored for a given workbook to a file.
@ -1381,6 +1390,7 @@ begin
FCols := TIndexedAVLTree.Create(@CompareCols);
FComments := TAVLTree.Create(@CompareCommentCells);
FMergedCells := TAVLTree.Create(@CompareMergedCells);
FHyperlinks := TAVLTree.Create(@CompareHyperlinks);
FDefaultColWidth := 12;
FDefaultRowHeight := 1;
@ -1408,7 +1418,8 @@ begin
RemoveAllRows;
RemoveAllCols;
RemoveAllComments;
RemoveAllMergedCells;
RemoveAllMergedRanges;
RemoveAllHyperlinks;
FCells.Free;
FRows.Free;
@ -1737,8 +1748,8 @@ end;
{@@ ----------------------------------------------------------------------------
Adds a comment to a specific cell
@param ARow (0-based) index to the row
@param ACol (0-based) index to the column
@param ARow (0-based) row index of the cell
@param ACol (0-based) column index of the cell
@param AText Comment text
@return Pointer to the cell containing the comment
-------------------------------------------------------------------------------}
@ -1757,6 +1768,7 @@ end;
procedure TsWorksheet.WriteComment(ACell: PCell; AText: String);
var
comment: PsComment;
addNew: Boolean;
begin
if ACell = nil then
exit;
@ -1771,16 +1783,196 @@ begin
end;
end else
begin
New(comment);
comment.Row := ACell^.Row;
comment.Col := ACell^.Col;
comment.Text := AText;
comment := FindComment(ACell); // Is there already a comment at this cell?
addNew := (comment = nil);
if addNew then
New(comment); // No: create a new one; yes: update existing one
comment^.Row := ACell^.Row;
comment^.Col := ACell^.Col;
comment^.Text := AText;
if addNew then
FComments.Add(comment);
ACell^.Flags := ACell^.Flags + [cfHasComment];
end;
end;
{ Hyperlinks }
{@@ ----------------------------------------------------------------------------
Checks whether the cell at a specified row/column contains a hyperlink and
returns a pointer to the hyperlink data.
@param ARow (0-based) row index of the cell
@param ACol (0-based) column index of the cell
@return Pointer to the TsHyperlink record (nil, if the cell does not contain
a hyperlink).
-------------------------------------------------------------------------------}
function TsWorksheet.FindHyperlink(ARow, ACol: Cardinal): PsHyperlink;
begin
Result := FindHyperlink(FindCell(ARow, ACol));
end;
{@@ ----------------------------------------------------------------------------
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;
var
hyperlink: TsHyperlink;
AVLNode: TAVLTreeNode;
begin
Result := nil;
if not IsHyperlink(ACell) or (FHyperlinks.Count = 0) then
exit;
hyperlink.Row := ACell^.Row;
hyperlink.Col := ACell^.Col;
AVLNode := FHyperlinks.Find(@hyperlink);
if Assigned(AVLNode) then
result := PsHyperlink(AVLNode.Data);
end;
{@@ ----------------------------------------------------------------------------
Checks whether the specified cell contains a hyperlink
-------------------------------------------------------------------------------}
function TsWorksheet.IsHyperlink(ACell: PCell): Boolean;
begin
Result := (ACell <> nil) and (ACell^.ContentType = cctHyperlink);
end;
{@@ ----------------------------------------------------------------------------
Reads the hyperlink information of a specified cell.
@param ARow Row index of the cell considered
@param ACol Column index of 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(ARow, ACol: Cardinal): TsHyperlink;
begin
Result := ReadHyperlink(FindCell(ARow, ACol));
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.Kind := hkNone;
Result.Destination := '';
Result.Note := '';
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; AKeepText: Boolean);
var
hyperlink: TsHyperlink;
AVLNode: TAvlTreeNode;
begin
if not IsHyperlink(ACell) then
exit;
hyperlink.Row := ACell^.Row;
hyperlink.Col := ACell^.Col;
AVLNode := FHyperlinks.Find(@hyperlink);
if AVLNode <> nil then begin
Dispose(PsHyperlink(AVLNode.Data));
FHyperlinks.Delete(AVLNode);
if AKeepText then
ACell^.ContentType := cctUTF8String
else
ACell^.ContentType := cctEmpty;
end;
end;
{@@ ----------------------------------------------------------------------------
Assigns a hyperlink to the cell at the specified row and column
@param ARow Row index of the cell considered
@param ACol Column index of the cell considered
@param AKind Hyperlink type (to cell, external file, URL)
@param ADestination Depending on AKind: cell address, filename, or URL
if empty the hyperlink is removed from the cell.
@param ADisplayText Text shown in cell. If empty the destination is shown
@param ANote Text for popup hint used by Excel
@return Pointer to the cell with the hyperlink
-------------------------------------------------------------------------------}
function TsWorksheet.WriteHyperlink(ARow, ACol: Cardinal; AKind: TsHyperlinkKind;
ADestination: String; ADisplayText: String = ''; ANote: String = ''): PCell;
begin
Result := GetCell(ARow, ACol);
WriteHyperlink(Result, AKind, ADestination, ADisplayText, ANote);
end;
{@@ ----------------------------------------------------------------------------
Assigns a hyperlink to the specified cell.
@param ACell Pointer to the cell considered
@param AKind Hyperlink type (to cell, external file, URL)
@param ADestination Depending on AKind: cell address, filename, or URL
if empty the hyperlink is removed from the cell.
@param ADisplayText Text shown in cell. If empty the destination is shown
@param ANote Text for popup hint used by Excel
-------------------------------------------------------------------------------}
procedure TsWorksheet.WriteHyperlink(ACell: PCell; AKind: TsHyperlinkKind;
ADestination: String; ADisplayText: String = ''; ANote: String = '');
var
hyperlink: PsHyperlink;
addNew: Boolean;
row, col: Cardinal;
begin
if ACell = nil then
exit;
row := ACell^.Row;
col := ACell^.Col;
// Remove the hyperlink if an empty destination is passed
if ADestination = '' then
RemoveHyperlink(ACell, false)
else
begin
hyperlink := FindHyperlink(ACell);
addNew := (hyperlink = nil);
if addNew then New(hyperlink);
hyperlink^.Row := row;
hyperlink^.Col := col;
hyperlink^.Kind := AKind;
hyperlink^.Destination := ADestination;
hyperlink^.Note := ANote;
if addNew then FHyperlinks.Add(hyperlink);
ACell^.ContentType := cctHyperlink;
if ADisplayText <> '' then
ACell^.UTF8StringValue := ADisplayText
else
ACell^.UTF8StringValue := ADestination;
end;
ChangedCell(row, col);
end;
{@@ ----------------------------------------------------------------------------
Is called whenever a cell value or formatting has changed. Fires an event
"OnChangeCell". This is handled by TsWorksheetGrid to update the grid cell.
@ -2770,7 +2962,8 @@ begin
case ContentType of
cctNumber:
Result := FloatToStrNoNaN(NumberValue, fmt^.NumberFormat, fmt^.NumberFormatStr);
cctUTF8String:
cctUTF8String,
cctHyperlink:
Result := UTF8StringValue;
cctDateTime:
Result := DateTimeToStrNoNaN(DateTimeValue, fmt^.NumberFormat, fmt^.NumberFormatStr);
@ -3724,6 +3917,15 @@ begin
Dispose(PsComment(data));
end;
{@@ ----------------------------------------------------------------------------
Helper method for clearing the hyperlink information
-------------------------------------------------------------------------------}
procedure TsWorksheet.RemoveHyperlinksCallback(data, arg: pointer);
begin
Unused(arg);
Dispose(PsHyperlink(data));
end;
{@@ ----------------------------------------------------------------------------
Clears the list of cells and releases their memory.
-------------------------------------------------------------------------------}
@ -3741,10 +3943,19 @@ begin
end;
{@@ ----------------------------------------------------------------------------
Empties the list of merged cell ranges.
Is called from the destructor of the worksheet
Clears the list of hyperlinks and releases their memory
-------------------------------------------------------------------------------}
procedure TsWorksheet.RemoveAllMergedCells;
procedure TsWorksheet.RemoveAllHyperlinks;
begin
RemoveAllAvlTreeNodes(FHyperlinks, RemoveHyperlinksCallback);
end;
{@@ ----------------------------------------------------------------------------
Empties the list of merged cell ranges.
Is called from the destructor of the worksheet.
NOTE: The cells are left intact. They are still marked as merged!!!
-------------------------------------------------------------------------------}
procedure TsWorksheet.RemoveAllMergedRanges;
begin
RemoveAllAvlTreeNodes(FMergedCells, RemoveCellRangesCallback);
end;
@ -4600,6 +4811,12 @@ begin
exit;
end;
if IsHyperlink(ACell) then
begin
// Preserve hyperlinks. Modify only the display test.
WriteUTF8Text(ACell, AValue);
ACell^.ContentType := cctHyperlink;
end else
WriteUTF8Text(ACell, AValue);
end;
(*
@ -5635,6 +5852,7 @@ begin
ChangedCell(ACell^.Row, ACell^.Col);
end;
{@@ ----------------------------------------------------------------------------
Defines a background pattern for a cell
@ -8010,7 +8228,7 @@ begin
end;
{@@ ----------------------------------------------------------------------------
Initializes the font list. In case of BIFF format, adds 5 fonts:
Initializes the font list by adding 5 fonts:
0: default font
1: like default font, but bold
@ -8018,6 +8236,7 @@ end;
3: like default font, but underlined
4: empty (due to a restriction of Excel)
5: like default font, but bold and italic
6: like default font, but blue and underlined (for hyperlinks)
-------------------------------------------------------------------------------}
procedure TsWorkbook.InitFonts;
var
@ -8042,6 +8261,7 @@ begin
AddFont(fntName, fntSize, [fssUnderline], scBlack); // FONT3 (fUnderline)
// FONT4 which does not exist in BIFF is added automatically with nil as place-holder
AddFont(fntName, fntSize, [fssBold, fssItalic], scBlack); // FONT5 (bold & italic)
AddFont(fntName, fntSize, [fssUnderline], scBlue); // FONT6 (blue & underlined)
FBuiltinFontCount := FFontList.Count;
end;
@ -8143,6 +8363,15 @@ begin
Result := FFontList.Count;
end;
{@@ ----------------------------------------------------------------------------
Returns the hypertext font. This is font with index 6 in the font list
-------------------------------------------------------------------------------}
function TsWorkbook.GetHyperlinkFont: TsFont;
begin
Result := GetFont(HYPERLINK_FONTINDEX);
end;
{@@ ----------------------------------------------------------------------------
Adds a color to the palette and returns its palette index, but only if the
color does not already exist - in this case, it returns the index of the

22
components/fpspreadsheet/fpspreadsheetctrls.pas
View File

@ -2649,6 +2649,9 @@ end;
@param AStrings Stringlist receiving the name-value pairs.
-------------------------------------------------------------------------------}
procedure TsSpreadsheetInspector.UpdateCellValue(ACell: PCell; AStrings: TStrings);
var
hyperlink: PsHyperlink;
s: String;
begin
if ACell = nil then
begin
@ -2666,6 +2669,9 @@ begin
begin
AStrings.Add(Format('Row=%d', [ACell^.Row]));
AStrings.Add(Format('Col=%d', [ACell^.Col]));
AStrings.Add(Format('Flags=[%s]', [
SetToString(PTypeInfo(TypeInfo(TsCellflags)), integer(ACell^.Flags), false)
]));
AStrings.Add(Format('ContentType=%s', [
GetEnumName(TypeInfo(TCellContentType), ord(ACell^.ContentType))
]));
@ -2677,6 +2683,22 @@ begin
AStrings.Add(Format('UTF8StringValue=%s', [ACell^.UTF8StringValue]));
if ACell^.ContentType = cctBool then
AStrings.Add(Format('BoolValue=%s', [BoolToStr(ACell^.BoolValue)]));
if ACell^.ContentType = cctHyperlink then
begin
AStrings.Add(Format('UTF8StringValue=%s', [ACell^.UTF8StringValue]));
hyperlink := Worksheet.FindHyperlink(ACell);
if hyperlink <> nil then begin
s := hyperlink^.Destination;
case hyperlink^.Kind of
hkNone: s := s + ' <error>';
hkCell: s := s + ' (internal cell reference)';
hkFile: s := s + ' (external file)';
hkURL : s := s + ' (URL)';
end;
end else
s := '<error>';
AStrings.Add(Format('Hyperlink=%s', [s]));
end;
if ACell^.ContentType = cctError then
AStrings.Add(Format('ErrorValue=%s', [GetEnumName(TypeInfo(TsErrorValue), ord(ACell^.ErrorValue))]));
AStrings.Add(Format('FormulaValue=%s', [Worksheet.ReadFormulaAsString(ACell, true)]));

77
components/fpspreadsheet/fpspreadsheetgrid.pas
View File

@ -38,6 +38,9 @@ type
{ TsCustomWorksheetGrid }
TsHyperlinkClickEvent = procedure(Sender: TObject;
const AHyperlink: TsHyperlink) of object;
{@@ TsCustomWorksheetGrid is the ancestor of TsWorksheetGrid and is able to
display spreadsheet data along with their formatting. }
TsCustomWorksheetGrid = class(TCustomDrawGrid, IsSpreadsheetControl)
@ -63,6 +66,7 @@ type
FDrawingCell: PCell;
FTextOverflowing: Boolean;
FEnhEditMode: Boolean;
FOnClickHyperlink: TsHyperlinkClickEvent;
function CalcAutoRowHeight(ARow: Integer): Integer;
function CalcColWidth(AWidth: Single): Integer;
function CalcRowHeight(AHeight: Single): Integer;
@ -199,6 +203,8 @@ type
property ShowHeaders: Boolean read GetShowHeaders write SetShowHeaders default true;
{@@ Activates text overflow (cells reaching into neighbors) }
property TextOverflow: Boolean read FTextOverflow write FTextOverflow default false;
{@@ Event called when an external hyperlink is clicked }
property OnClickHyperlink: TsHyperlinkClickEvent read FOnClickHyperlink write FOnClickHyperlink;
public
{ public methods }
@ -481,6 +487,8 @@ type
property OnChangeBounds;
{@@ inherited from ancestors}
property OnClick;
{@@ inherited from TCustomWorksheetGrid}
property OnClickHyperlink;
{@@ inherited from ancestors}
property OnColRowDeleted;
{@@ inherited from ancestors}
@ -998,7 +1006,7 @@ begin
cell := FDrawingCell;
// Nothing to do in these cases (like in Excel):
if (cell = nil) or (cell^.ContentType <> cctUTF8String) then // ... non-label cells
if (cell = nil) or not (cell^.ContentType in [cctUTF8String, cctHyperlink]) then // ... non-label cells
exit;
fmt := Workbook.GetPointerToCellFormat(cell^.FormatIndex);
@ -1384,12 +1392,17 @@ begin
end;
// Font
if Worksheet.IsHyperlink(lCell) then
fnt := Workbook.GetHyperlinkFont
else
fnt := Workbook.GetDefaultFont;
if (uffFont in fmt^.UsedFormattingFields) then
begin
fnt := Workbook.GetFont(fmt^.FontIndex);
if fnt <> nil then
begin
Canvas.Font.Name := fnt.FontName;
Canvas.Font.Size := round(fnt.Size);
Canvas.Font.Color := Workbook.GetPaletteColor(fnt.Color);
style := [];
if fssBold in fnt.Style then Include(style, fsBold);
@ -1397,8 +1410,6 @@ begin
if fssUnderline in fnt.Style then Include(style, fsUnderline);
if fssStrikeout in fnt.Style then Include(style, fsStrikeout);
Canvas.Font.Style := style;
Canvas.Font.Size := round(fnt.Size);
end;
end;
if (fmt^.NumberFormat = nfCurrencyRed) and
not IsNaN(lCell^.NumberValue) and (lCell^.NumberValue < 0)
@ -1811,12 +1822,13 @@ begin
cell := Worksheet.FindCell(sr, GetWorksheetCol(gc));
// Empty cell --> proceed with next cell to the left
if (cell = nil) or (cell^.ContentType = cctEmpty) or
((cell^.ContentType = cctUTF8String) and (cell^.UTF8StringValue = ''))
((cell^.ContentType in [cctUTF8String, cctHyperLink]) and (cell^.UTF8StringValue = ''))
then
Continue;
// Overflow possible from non-merged, non-right-aligned, horizontal label cells
fmt := Workbook.GetPointerToCellFormat(cell^.FormatIndex);
if (not Worksheet.IsMerged(cell)) and (cell^.ContentType = cctUTF8String) and
if (not Worksheet.IsMerged(cell)) and
(cell^.ContentType in [cctUTF8String, cctHyperlink]) and
not (uffTextRotation in fmt^.UsedFormattingFields) and
(uffHorAlign in fmt^.UsedFormattingFields) and (fmt^.HorAlignment <> haRight)
then
@ -1837,12 +1849,13 @@ begin
cell := Worksheet.FindCell(sr, GetWorksheetCol(gcLast));
// Empty cell --> proceed with next cell to the right
if (cell = nil) or (cell^.ContentType = cctEmpty) or
((cell^.ContentType = cctUTF8String) and (cell^.UTF8StringValue = ''))
((cell^.ContentType in [cctUTF8String, cctHyperlink]) and (cell^.UTF8StringValue = ''))
then
continue;
// Overflow possible from non-merged, horizontal, non-left-aligned label cells
fmt := Workbook.GetPointerToCellFormat(cell^.FormatIndex);
if (not Worksheet.IsMerged(cell)) and (cell^.ContentType = cctUTF8String) and
if (not Worksheet.IsMerged(cell)) and
(cell^.ContentType in [cctUTF8String, cctHyperlink]) and
not (uffTextRotation in fmt^.UsedFormattingFields) and
(uffHorAlign in fmt^.UsedFormattingFields) and (fmt^.HorAlignment <> haLeft)
then
@ -2607,7 +2620,7 @@ begin
exit;
if (ARow = 0) then
begin
Result := GetColString(ACol-FHeaderCount);
Result := GetColString(ACol - FHeaderCount);
exit;
end
else
@ -3320,13 +3333,53 @@ begin
end;
{@@ ----------------------------------------------------------------------------
Standard mouse down handler. Is overridden here to enter "enhanced edit mode"
which removes formatting from the values and presents formulas for editing.
Standard mouse down handler. Is overridden here to handle hyperlinks and to
enter "enhanced edit mode" which removes formatting from the values and
presents formulas for editing.
-------------------------------------------------------------------------------}
procedure TsCustomWorksheetGrid.MouseDown(Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
{todo: extend such the hyperlink is handled only when the text is clicked }
var
hyperlink: TsHyperlink;
sheetname: String;
sheet: TsWorksheet;
r, c: Cardinal;
mouseCell: TPoint;
cell: PCell;
begin
inherited;
if (ssLeft in Shift) and ([ssCtrl, ssSuper] * Shift <> []) then
begin
mouseCell := MouseToCell(Point(X, Y));
r := GetWorksheetRow(mouseCell.Y);
c := GetWorksheetCol(mouseCell.X);
cell := Worksheet.FindCell(r, c);
if Worksheet.IsHyperlink(cell) then
begin
hyperlink := Worksheet.ReadHyperlink(cell);
case hyperlink.Kind of
hkNone:
; // nothing to do
hkCell:
if ParseSheetCellString(hyperlink.Destination, sheetname, r, c) then
begin
sheet := Workbook.GetWorksheetByName(sheetname);
Workbook.SelectWorksheet(sheet);
Worksheet.SelectCell(r, c);
end else
raise Exception.CreateFmt('"%s" is not a valid cell string.', [hyperlink.Destination]);
else
if Assigned(FOnClickHyperlink) then FOnClickHyperlink(self, hyperlink);
end;
exit;
end;
end;
//inherited;
FEnhEditMode := true;
end;
@ -3641,7 +3694,7 @@ var
fmt: PsCellFormat;
begin
Result := Worksheet.ReadAsUTF8Text(ACell);
if (Result = '') or ((ACell <> nil) and (ACell^.ContentType = cctUTF8String))
if (Result = '') or ((ACell <> nil) and (ACell^.ContentType in [cctUTF8String, cctHyperlink]))
then
exit;

40
components/fpspreadsheet/fpstypes.pas
View File

@ -40,6 +40,10 @@ const
DEFAULT_FONTNAME = 'Arial';
{@@ Size of the default font}
DEFAULT_FONTSIZE = 10;
{@@ Index of the default font in workbook's font list }
DEFAULT_FONTINDEX = 0;
{@@ Index of the hyperlink font in workbook's font list }
HYPERLINK_FONTINDEX = 6;
{@@ Takes account of effect of cell margins on row height by adding this
value to the nominal row height. Note that this is an empirical value
@ -126,7 +130,41 @@ type
{@@ Describes the <b>type of content</b> in a cell of a TsWorksheet }
TCellContentType = (cctEmpty, cctFormula, cctNumber, cctUTF8String,
cctDateTime, cctBool, cctError);
cctDateTime, cctBool, cctError, cctHyperlink);
{@@ The record TsComment describes a comment attached to a cell.
@param Row (0-based) row index of the cell
@param Col (0-based) column index of the cell
@param Text Comment text }
TsComment = record
Row, Col: Cardinal;
Text: String;
end;
{@@ Pointer to a TsComment record }
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);
{@@ 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
@param Destination Hyperlink (cell address, filename, URL)
@param Note Text displayed as a popup hint by Excel }
TsHyperlink = record
Row, Col: Cardinal;
Kind: TsHyperlinkKind;
Destination: String;
Note: String;
end;
{@@ Pointer to a TsHyperlink record }
PsHyperlink = ^TsHyperlink;
{@@ Callback function, e.g. for iterating the internal AVL trees of the workbook/sheet}
TsCallback = procedure (data, arg: Pointer) of object;

17
components/fpspreadsheet/fpsutils.pas
View File

@ -70,6 +70,8 @@ function ParseCellString(const AStr: string;
out ACellRow, ACellCol: Cardinal; out AFlags: TsRelFlags): Boolean; overload;
function ParseCellString(const AStr: string;
out ACellRow, ACellCol: Cardinal): Boolean; overload;
function ParseSheetCellString(const AStr: String;
out ASheetName: String; out ACellRow, ACellCol: Cardinal): Boolean;
function ParseCellRowString(const AStr: string;
out AResult: Cardinal): Boolean;
function ParseCellColString(const AStr: string;
@ -640,6 +642,21 @@ begin
Result := ParseCellString(AStr, ACellRow, ACellCol, flags);
end;
function ParseSheetCellString(const AStr: String; out ASheetName: String;
out ACellRow, ACellCol: Cardinal): Boolean;
var
p: Integer;
begin
p := UTF8Pos('!', AStr);
if p = 0 then begin
Result := ParseCellString(AStr, ACellRow, ACellCol);
ASheetName := '';
end else begin
ASheetName := UTF8Copy(AStr, 1, p-1);
Result := ParseCellString(UTF8Copy(AStr, p+1, UTF8Length(AStr)), ACellRow, ACellCol);
end;
end;
{@@ ----------------------------------------------------------------------------
Parses a cell row string to a zero-based row number.