paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-09 06:08:55 +02:00
Code Issues Packages Projects Releases Wiki Activity

* PDF internal link objects, example adapted to show possibility. Fixes issue #40318

Browse Source
This commit is contained in:
Michaël Van Canneyt 2023-06-14 08:30:21 +02:00
parent 87e4931489
commit 90b7c8ace7
2 changed files with 77 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

53
packages/fcl-pdf/examples/testfppdf.lpr
View File

@ -27,6 +27,8 @@ uses
type
{ TPDFTestApp }
TPDFTestApp = class(TCustomApplication)
private
FPage: integer;
@ -42,6 +44,7 @@ type
function SetUpDocument: TPDFDocument;
procedure SaveDocument(D: TPDFDocument);
procedure EmptyPage;
procedure TableOfContents(D: TPDFDocument; APage: integer);
procedure SimpleText(D: TPDFDocument; APage: integer);
procedure SimpleLinesRaw(D: TPDFDocument; APage: integer);
procedure SimpleLines(D: TPDFDocument; APage: integer);
@ -62,7 +65,7 @@ var
Application: TPDFTestApp;
const
cPageCount: integer = 8;
cPageCount: integer = 9;
function TPDFTestApp.SetUpDocument: TPDFDocument;
var
@ -141,6 +144,37 @@ begin
end;
end;
procedure TPDFTestApp.TableOfContents(D: TPDFDocument; APage: integer);
const
pagesarr: array [1..8] of String = ('Sample Text', 'Basic Shapes', 'Advanced Drawing',
'Sample Line Drawing (DrawLineStyle)', 'Sample Line Drawing (DrawLine)', 'Sample Image Support',
'Matrix transform', 'Landscape Page');
var
P : TPDFPage;
FtTitle, FtText, i: integer;
begin
P := D.Pages[APage];
// create the fonts to be used (use one of the 14 Adobe PDF standard fonts)
FtTitle := D.AddFont('Helvetica');
FtText := D.AddFont('Courier');
{ Page title }
P.SetFont(FtTitle, 23);
P.SetColor(clBlack, false);
P.WriteText(25, 20, 'Table of contents');
// -----------------------------------
{ references to document pages }
P.SetFont(FtText, 12);
P.SetColor(clBlack, false);
for i := Low(pagesarr) to High(pagesarr) do
begin
P.WriteText(25, 40 + 10 * i, pagesarr[i] + StringOfChar('.', 60 - Length(pagesarr[i])) + IntToStr(i));
P.AddInternalLink(25, 40 + 10 * i, 160, 5, i, false);
end;
end;
{ all units of measure are in millimeters }
procedure TPDFTestApp.SimpleText(D: TPDFDocument; APage: integer);
var
@ -837,14 +871,15 @@ begin
if FPage = -1 then
begin
SimpleText(FDoc, 0);
SimpleShapes(FDoc, 1);
AdvancedShapes(FDoc, 2);
SimpleLines(FDoc, 3);
SimpleLinesRaw(FDoc, 4);
SimpleImage(FDoc, 5);
SampleMatrixTransform(FDoc, 6);
SampleLandscape(FDoc, 7);
TableOfContents(FDoc, 0);
SimpleText(FDoc, 1);
SimpleShapes(FDoc, 2);
AdvancedShapes(FDoc, 3);
SimpleLines(FDoc, 4);
SimpleLinesRaw(FDoc, 5);
SimpleImage(FDoc, 6);
SampleMatrixTransform(FDoc, 7);
SampleLandscape(FDoc, 8);
end
else
begin

38
packages/fcl-pdf/src/fppdf.pp
View File

@ -785,6 +785,8 @@ type
procedure CubicCurveToY(ACtrl1, ATo: TPDFCoord; const ALineWidth: TPDFFloat; AStroke: Boolean = True); overload;
{ Define a rectangle that becomes a clickable hotspot, referencing the URI argument. }
Procedure AddExternalLink(const APosX, APosY, AWidth, AHeight: TPDFFloat; const AURI: string; ABorder: boolean = false);
{ Define a rectangle that becomes a clickable hotspot, referencing the document page. }
Procedure AddInternalLink(const APosX, APosY, AWidth, AHeight: TPDFFloat; const APageIndex: Integer; ABorder: boolean = false);
{ This returns the paper height, converted to whatever UnitOfMeasure is set too }
function GetPaperHeight: TPDFFloat;
Function HasImages : Boolean;
@ -908,9 +910,11 @@ type
FHeight: TPDFFloat;
FURI: string;
FBorder: boolean;
FExternalLink: Boolean;
public
constructor Create(const ADocument: TPDFDocument); override; overload;
constructor Create(const ADocument: TPDFDocument; const ALeft, ABottom, AWidth, AHeight: TPDFFloat; const AURI: String; const ABorder: Boolean = false); overload;
constructor Create(const ADocument: TPDFDocument; const ALeft, ABottom, AWidth, AHeight: TPDFFloat; const AURI: String; const ABorder: Boolean = false;
const AExternalLink: Boolean = true); overload;
end;
@ -2146,7 +2150,7 @@ begin
end;
constructor TPDFAnnot.Create(const ADocument: TPDFDocument; const ALeft, ABottom, AWidth, AHeight: TPDFFloat;
const AURI: String; const ABorder: Boolean);
const AURI: String; const ABorder: Boolean; const AExternalLink: Boolean);
begin
Create(ADocument);
FLeft := ALeft;
@ -2155,6 +2159,7 @@ begin
FHeight := AHeight;
FURI := AURI;
FBorder := ABorder;
FExternalLink := AExternalLink;
end;
{ TPDFAnnotList }
@ -2806,6 +2811,21 @@ begin
Annots.Add(an);
end;
procedure TPDFPage.AddInternalLink(const APosX, APosY, AWidth, AHeight: TPDFFloat;
const APageIndex: Integer; ABorder: boolean);
var
an: TPDFAnnot;
p1, p2: TPDFCoord;
begin
p1 := Matrix.Transform(APosX, APosY);
DoUnitConversion(p1);
p2.X := AWidth;
p2.Y := AHeight;
DoUnitConversion(p2);
an := TPDFAnnot.Create(Document, p1.X, p1.Y, p2.X, p2.Y, Format('[%d]', [APageIndex]), ABorder, False);
Annots.Add(an);
end;
function TPDFPage.GetPaperHeight: TPDFFloat;
begin
case FUnitOfMeasure of
@ -5635,9 +5655,17 @@ begin
ADict := CreateDictionary;
lDict.AddElement('A', ADict);
ADict.AddName('Type', 'Action');
ADict.AddName('S', 'URI');
ADict.AddString('URI', an.FURI);
if an.FExternalLink then
begin
ADict.AddName('Type', 'Action');
ADict.AddName('S', 'URI');
ADict.AddString('URI', an.FURI);
end
else
begin
ADict.AddName('S', 'GoTo');
ADict.AddName('D' + an.FURI, '');
end;
result := GlobalXRefCount-1;
end;