1 {****************************************************} 2 { } 3 { FastReport v2.3 } 4 { PDF export filter Ver 1.0 } 5 { } 6 { By : Ricardo Cardona Ramirez } 7 { } 8 { PowerPDF } 9 { http://www.est.hi-ho.ne.jp/takeshi_kanno/powerpdf/ } 10 { ZLib Units Delphi 5-6 } 11 { http://www.base2ti.com/zlib.htm } 12 { } 13 {****************************************************} 14 {* 15 * 2020.10.23 added export of annotation links for TfrMemoView.URLInfo. 16 * (<setfan[at]smartsoftware[dot]com>) 17 * The URI put into URLInfo is supposed to be a valid uri 18 * (http://..., ftp://..., etc.) with all special characters already 19 * escaped. You could use for example the functions EncodeURL and 20 * EncodeURLElement from the Synapse project, unit synacode. 21 *} 22 23 unit lr_e_pdf; 24 25 {$mode objfpc}{$H+} 26 27 interface 28 29 uses 30 SysUtils, Classes, Graphics, Forms, StdCtrls, lr_class, lr_BarC, 31 lr_shape, PdfDoc, PdfTypes, PdfFonts, PRJpegImage, PReport, Dialogs, 32 Controls, lr_rrect; 33 34 type 35 TShapeData = record 36 ShapeType: TfrShapeType; 37 FillColor: TColor; 38 FrameStyle: TfrFrameStyle; 39 FrameWidth: Double; 40 FrameColor: TColor; 41 Radius: Single; 42 Corners: TCornerSet; 43 GradientColor: TColor; 44 GradientDirection: TGradientDirection; 45 end; 46 47 TfrTNPDFExport = class(TComponent) // fake component 48 end; 49 50 { TfrTNPDFExportFilter } 51 52 TfrTNPDFExportFilter = class(TfrExportFilter) 53 private 54 NewPage: Boolean; 55 PDF: TPReport; 56 PPage: TPRPage; 57 PRPanel: TPRPanel; 58 FOutline: TPROutLineEntry; 59 FPageNo : Integer; 60 DummyControl: TForm; 61 procedure AddShape(Data: TShapeData; x, y, h, w: integer); 62 procedure DefaultShowView(View: TfrView; nx, ny, ndy, ndx: Integer); 63 public 64 constructor Create(AStream: TStream); override; 65 destructor Destroy; override; 66 procedure OnBeginPage; override; 67 procedure OnEndDoc; override; 68 procedure OnEndPage; override; 69 procedure ShowBackGround(View: TfrView; x, y, h, w: integer); 70 procedure Frame(View: TfrView; x, y, h, w: integer); 71 procedure ShowFrame(View: TfrView; x, y, h, w: integer); 72 procedure ShowBarCode(View: TfrCustomBarCodeView; x, y, h, w: integer); 73 procedure ShowPicture(View: TfrPictureView; x, y, h, w: integer); 74 procedure ShowRoundRect(View: TfrRoundRectView; x, y, h, w: integer); 75 procedure ShowShape(View: TfrShapeView; x, y, h, w: integer); 76 procedure OnText(X, Y: Integer; const Text: string; View: TfrView); 77 override; 78 procedure OnData(x, y: Integer; View: TfrView); override; 79 end; 80 81 implementation 82 83 uses lr_Const, PRAnnotation; 84 85 type 86 TfrMemoView_ = class(TfrMemoView); 87 TPRText_ = class(TPRText); 88 89 const 90 PDFEscx = 0.792553191; 91 PDFEscy = 0.785447761; 92 93 procedure TfrTNPDFExportFilter.AddShape(Data: TShapeData; x, y, h, w: integer); 94 CreateShapenull95 function CreateShape(ShapeClass: TPRShapeClass): TPRShape; 96 begin 97 result := ShapeClass.Create(PRPanel); 98 result.Parent := PRPanel; 99 result.FillColor := Data.FillColor; 100 result.Left := x; 101 result.Top := y; 102 result.Height := h; 103 result.Width := w; 104 result.LineStyle := TPenStyle(Data.FrameStyle); 105 result.LineWidth := Data.FrameWidth - 0.5; 106 result.LineColor := Data.FrameColor; 107 end; 108 109 begin 110 case Data.ShapeType of 111 frstRectangle: 112 CreateShape(TPRRect); 113 114 frstEllipse: 115 CreateShape(TPREllipse); 116 117 frstRoundRect: 118 with TPRRect(CreateShape(TPRRect)) do begin 119 Radius := Data.Radius; 120 SquaredCorners := TPdfCorners(Data.Corners); 121 GradientColor := Data.GradientColor; 122 GradientDirection := Data.GradientDirection; 123 end; 124 125 frstTriangle: 126 with TPRPolygon(CreateShape(TPRPolygon)) do begin 127 SetLength(Points, 3); 128 Points[0] := PRPoint(x+w, y+h); 129 Points[1] := PRPoint(x, y+h); 130 Points[2] := PRPoint(x+w/2, y); 131 end; 132 133 frstDiagonal1: 134 with TPRPolygon(CreateShape(TPRPolygon)) do begin 135 SetLength(Points, 2); 136 Points[0] := PRPoint(x,y); 137 Points[1] := PRPoint(x+w,y+h); 138 end; 139 140 frstDiagonal2: 141 with TPRPolygon(CreateShape(TPRPolygon)) do begin 142 SetLength(Points, 2); 143 Points[0] := PRPoint(x,y+h); 144 Points[1] := PRPoint(x+w,y); 145 end; 146 end; 147 end; 148 149 procedure TfrTNPDFExportFilter.DefaultShowView(View: TfrView; 150 nx, ny, ndy, ndx: Integer); 151 begin 152 if (View.FillColor <> clNone) 153 and not (View is TfrCustomBarCodeView) 154 and not (View is TfrPictureView) 155 then 156 ShowBackGround(View, nx, ny, ndy, ndx); 157 158 if View is TfrCustomBarCodeView then 159 ShowBarCode(TfrCustomBarCodeView(View), nx, ny, ndy, ndx) 160 else if View is TfrPictureView then 161 ShowPicture(TfrPictureView(View), nx, ny, ndy, ndx); 162 163 if (View.Frames<>[]) and not (View is TfrCustomBarCodeView) then 164 ShowFrame(View, nx, ny, ndy, ndx); 165 end; 166 167 constructor TfrTNPDFExportFilter.Create(AStream: TStream); 168 begin 169 inherited; 170 PDF := TPReport.Create(nil); 171 PDF.CompressionMethod := cmFlateDecode; 172 PDF.UseOutlines := True; 173 PDF.PageLayout := plOneColumn; 174 PDF.BeginDoc; 175 {$IFNDEF LCLNOGUI} 176 DummyControl := TForm.Create(nil); 177 {$ENDIF} 178 NewPage := False; 179 FPageNo := 0; 180 end; 181 182 destructor TfrTNPDFExportFilter.Destroy; 183 begin 184 PDF.Free; 185 DummyControl.Free; 186 inherited; 187 end; 188 189 procedure TfrTNPDFExportFilter.OnBeginPage; 190 begin 191 {Add New Page} 192 Inc(FPageNo); 193 194 PPage := TPRPage.Create(PDF); 195 PPage.Parent := DummyControl; 196 PPage.MarginBottom := 0; 197 PPage.MarginTop := 0; 198 PPage.MarginLeft := 0; 199 PPage.MarginRight := 0; 200 201 PPage.Height := trunc(CurReport.EMFPages[FPageNo - 1]^.PrnInfo.Pgh*PDFEscy + 0.5); 202 PPage.Width := trunc(CurReport.EMFPages[FPageNo - 1]^.PrnInfo.Pgw*PDFEscx + 0.5); 203 204 PRPanel := TPRPanel.Create(PPage); 205 PRPanel.Parent := PPage; 206 PRPanel.Left := 0; 207 PRPanel.Top := 0; 208 PRPanel.Width := PPage.Width; 209 PRPanel.Height := PPage.Height; 210 end; 211 212 procedure TfrTNPDFExportFilter.OnEndDoc; 213 begin 214 PDF.GetPdfDoc.SaveToStream(Stream); 215 end; 216 217 procedure TfrTNPDFExportFilter.OnEndPage; 218 begin 219 PDF.Print(PPage); 220 221 FOutline := PDF.OutlineRoot.AddChild; 222 FOutline.Dest := PDF.CreateDestination; 223 FOutline.Dest.Top := 0; 224 FOutline.Title := 'Page ' + IntToStr(FPageNo); 225 226 FreeAndNil(PPage); 227 end; 228 229 procedure TfrTNPDFExportFilter.ShowBackGround(View: TfrView; x, y, h, w: 230 integer); 231 var 232 PRRect: TPRRect; 233 begin 234 PRRect := TPRRect.Create(PRPanel); 235 PRRect.Parent := PRPanel; 236 PRRect.FillColor := ColorToRGB(View.FillColor); 237 PRRect.LineColor := clNone; 238 PRRect.LineStyle := psSolid; 239 PRRect.Left := x; 240 PRRect.Top := y; 241 PRRect.Height := h; 242 PRRect.Width := w; 243 end; 244 245 procedure TfrTNPDFExportFilter.Frame(View: TfrView; x, y, h, w: integer); 246 var 247 PRRect: TPRRect; 248 begin 249 PRRect := TPRRect.Create(PRPanel); 250 PRRect.Parent := PRPanel; 251 PRRect.FillColor := clNone; 252 253 PRRect.Left := x; 254 PRRect.Top := y; 255 PRRect.Height := h; 256 PRRect.Width := w; 257 258 PRRect.LineStyle := TPenStyle(View.FrameStyle); 259 PRRect.LineWidth := View.FrameWidth - 0.5; 260 PRRect.LineColor := View.FrameColor; 261 end; 262 263 procedure TfrTNPDFExportFilter.ShowFrame(View: TfrView; x, y, h, w: integer); 264 begin 265 266 if ([frbLeft,frbTop,frbRight,frbBottom]-View.Frames=[]) and 267 (View.FrameStyle = frsSolid) then 268 begin 269 Frame(View, x, y, h, w); 270 end 271 else 272 begin 273 if frbRight in View.Frames then 274 Frame(View, x + w - 1, y, h, 0); //Right 275 if frbLeft in View.Frames then 276 Frame(View, x, y, h, 0); //Left 277 if frbBottom in View.Frames then 278 Frame(View, x, y + h - 1, 0, w); //Botton 279 if frbTop in View.Frames then 280 Frame(View, x, y, 0, w); //Top 281 end; 282 end; 283 284 procedure TfrTNPDFExportFilter.ShowBarCode(View: TfrCustomBarCodeView; x, y, h, w: 285 integer); 286 var 287 Bitmap: TLazreportBitmap; 288 PRImage: TPRImage; 289 oldX, oldY: Integer; 290 {$IFDEF LCLNOGUI} 291 bmpStream: TMemoryStream; 292 {$ENDIF} 293 begin 294 oldX := View.x; 295 oldy := View.y; 296 View.x := 0; 297 View.y := 0; 298 299 Bitmap := TfrCustomBarCodeView(View).GenerateBitmap; 300 try 301 w := trunc(Bitmap.Width * PDFEscx + 1.5) ; 302 h := trunc(Bitmap.Height * PDFEscy + 1.5) ; 303 304 PRImage := TPRImage.Create(PRPanel); 305 PRImage.Parent := PRPanel; 306 PRImage.Stretch := True; 307 PRImage.SharedImage := False; 308 PRImage.Left := x; 309 PRImage.Top := y; 310 PRImage.Height := h; 311 PRImage.Width := w; 312 313 {$IFDEF LCLNOGUI} 314 bmpStream := Bitmap.Stream; 315 PRImage.Picture.LoadFromStream(bmpStream); 316 bmpStream.Free; 317 {$ELSE} 318 PRImage.Picture.Bitmap := Bitmap; 319 {$ENDIF} 320 finally 321 FreeAndNil(Bitmap); 322 end; 323 324 View.x := oldX; 325 View.y := oldY; 326 end; 327 328 procedure TfrTNPDFExportFilter.ShowPicture(View: TfrPictureView; x, y, h, 329 w: integer); 330 var 331 PRImage: TPRImage; 332 r: Double; 333 L: Integer; 334 pw, ph: Integer; 335 Picture: TPicture; 336 begin 337 Picture := View.Picture; 338 339 if Picture.Graphic is TJpegImage then 340 PRImage := TPRJpegImage.Create(PRPanel) 341 else 342 PRImage := TPRImage.Create(PRPanel); 343 344 PRImage.Parent := PRPanel; 345 346 ph := h; 347 pw := w; 348 349 if view.Stretched then 350 begin 351 if (View.Flags and flPictRatio<>0) and 352 (Picture.Width>0) and (Picture.Height>0) then 353 begin 354 r := Picture.Width/Picture.Height; 355 if (w/h) < r then 356 begin 357 L := h; 358 ph := trunc(w/r + 0.5); 359 if (View.Flags and flPictCenter<>0) then 360 y := y + (L-ph) div 2; 361 end 362 else 363 begin 364 L := w; 365 pw := trunc(h*r + 0.5); 366 if (View.Flags and flPictCenter<>0) then 367 x := x + (L-pw) div 2; 368 end; 369 end; 370 end 371 else begin 372 PRImage.ScaleX := PDFEscX; 373 PRImage.ScaleY := PDFEscY; 374 if (View.Flags and flPictCenter<>0) then begin 375 pw := trunc(Picture.Width * PDFEscX + 1.5); 376 ph := trunc(Picture.Height * PDFEscY + 1.5); 377 x := x + (w - pw) div 2 - 1; 378 y := y + (h - ph) div 2 - 1; 379 end; 380 end; 381 382 PRImage.Stretch := View.Stretched; 383 PRImage.SharedName := View.SharedName; 384 PRImage.SharedImage := (View.SharedName<>''); 385 386 PRImage.Left := x; 387 PRImage.Top := y; 388 PRImage.Height := ph; 389 PRImage.Width := pw; 390 391 PRImage.Picture.Graphic := Picture.Graphic; 392 end; 393 394 procedure TfrTNPDFExportFilter.ShowRoundRect(View: TfrRoundRectView; x, y, h, 395 w: integer); 396 var 397 Data: TShapeData; 398 SWidth: Integer; 399 begin 400 401 if view.ShowGradian and (View.GradianStyle in [gsElliptic, gsHorizCenter, gsVertCenter, gsRectangle]) then 402 // not supported yet 403 DefaultShowView(View, x, y, h, w) 404 405 else 406 begin 407 408 SWidth := trunc((View.RoundRectCurve/2) * PDFEscx + 0.5); 409 if View.RoundRect then 410 Data.Radius := SWidth 411 else 412 Data.Radius := 0.0; 413 Data.Corners:=View.SquaredCorners; 414 415 // draw shadow 416 if View.ShowGradian then 417 begin 418 Data.GradientColor := View.ShadowColor; 419 case View.GradianStyle of 420 gsVertical: Data.GradientDirection := gdVertical; 421 gsHorizontal: Data.GradientDirection := gdHorizontal; 422 end; 423 end else 424 begin 425 Data.GradientColor := clNone; 426 Data.ShapeType := frstRoundRect; 427 Data.FillColor := View.ShadowColor; 428 Data.FrameColor := clNone; 429 Data.FrameWidth := 0; 430 Data.FrameStyle := frsSolid; 431 SWidth := trunc(View.ShadowWidth * PDFEscx + 0.5); 432 if View.ShadowWidth>0 then 433 AddShape(Data, x + SWidth, y + SWidth, h - SWidth, w - SWidth); 434 end; 435 436 // draw roundrect 437 Data.ShapeType := frstRoundRect; 438 if View.FillColor=clNone then begin 439 if not View.ShowGradian and (View.ShadowWidth>0) then 440 Data.FillColor := clWhite 441 else 442 Data.FillColor := clNone 443 end 444 else 445 Data.FillColor := ColorToRGB(View.FillColor); 446 if View.Frames=[] then 447 Data.FrameColor := clNone 448 else 449 Data.FrameColor := View.FrameColor; 450 Data.FrameWidth := View.FrameWidth; 451 Data.FrameStyle := View.FrameStyle; 452 AddShape(Data, x, y, h - SWidth, w - SWidth); 453 end; 454 end; 455 456 procedure TfrTNPDFExportFilter.ShowShape(View: TfrShapeView; x, y, h, w: integer); 457 var 458 Data: TShapeData; 459 begin 460 Data.ShapeType := View.ShapeType; 461 Data.FillColor := View.FillColor; 462 Data.FrameColor := View.FrameColor; 463 Data.FrameStyle := View.FrameStyle; 464 Data.FrameWidth := View.FrameWidth; 465 Data.Radius := -1.0; 466 Data.Corners := []; 467 AddShape(Data, x, y, h, w); 468 end; 469 470 procedure TfrTNPDFExportFilter.OnData(x, y: Integer; View: TfrView); 471 var 472 nx, ny, ndx, ndy: Integer; 473 begin 474 nx := trunc(x * PDFEscx + 0.5); 475 ny := trunc(y * PDFEscy + 0.5); 476 ndx := trunc((View.dx) * PDFEscx + 1.5) ; 477 ndy := trunc((View.dy) * PDFEscy + 1.5) ; 478 479 if View is TfrShapeView then begin 480 481 ShowShape(TfrShapeView(View), nx, ny, ndy, ndx); 482 483 end else 484 if View is TfrRoundRectView then begin 485 486 ShowRoundRect(TfrRoundRectView(View), nx, ny, ndy, ndx); 487 488 end else 489 DefaultShowView(View, nx, ny, ndy, ndx); 490 end; 491 492 procedure TfrTNPDFExportFilter.OnText(X, Y: Integer; const Text: string; 493 View: TfrView); 494 var 495 PRTLabel: TPRLabel; 496 PRTAnno: TPRAnnotation; 497 nx, ny, ndx, ndy: Integer; 498 gapx, gapy: integer; 499 memo: TfrMemoView; 500 begin 501 gapx := trunc(View.FrameWidth / 2 + 0.5) + 2; 502 gapy := trunc(View.FrameWidth / 4 + 0.5) + 1; 503 nx := trunc((x+gapx) * PDFEscx + 0.5); 504 ny := trunc((y+gapy) * PDFEscy + 0.5); 505 ndx := trunc((View.dx-gapx) * PDFEscx + 1.5); 506 ndy := trunc((View.dy-gapy) * PDFEscy + 1.5); 507 508 PRTLabel := TPRLabel.Create(PRPanel); 509 PRTLabel.Parent := PRPanel; 510 PRTLabel.Clipping := true; 511 try 512 PRTLabel.Caption := Text; 513 PRTLabel.Left := nx; 514 PRTLabel.Top := ny; 515 PRTLabel.Width := ndx; 516 PRTLabel.Height := ndy; 517 if View is TfrMemoView then 518 begin 519 memo := View as TfrMemoView; 520 PRTLabel.Alignment := memo.Alignment; 521 if Pos('Arial', memo.Font.Name) > 0 then 522 PRTLabel.FontName := fnArial 523 else if Pos('Courier', memo.Font.Name) > 0 then 524 PRTLabel.FontName := fnFixedWidth 525 else if Pos('Times', memo.Font.Name) > 0 then 526 PRTLabel.FontName := fnTimesRoman; 527 PRTLabel.FontSize := memo.Font.Size; 528 PRTLabel.FontBold := fsBold in memo.Font.Style; 529 PRTLabel.FontItalic := fsItalic in memo.Font.Style; 530 PRTLabel.FontColor := ColorToRGB(memo.Font.Color); 531 PRTLabel.FontUnderline := fsUnderline in memo.Font.Style; 532 PRTLabel.Angle:= memo.Angle; 533 PRTLabel.AlignJustified := memo.Justify and not memo.LastLine; 534 // suppose that URLInfo always contains a valid URI 535 if Trim(memo.URLInfo) <> '' then begin 536 // create link annotation 537 PRTAnno := TPRAnnotation.Create(PRPanel); 538 PRTAnno.Parent := PRPanel; 539 PRTAnno.SubType := asLink; 540 PRTAnno.Action.URI := memo.URLInfo; 541 PRTAnno.Left := PRTLabel.Left; 542 PRTAnno.Top := PRTLabel.Top; 543 PRTAnno.Width := PRTLabel.Width; 544 PRTAnno.Height := PRTLabel.Height; 545 end; 546 end; 547 finally 548 end; 549 end; 550 551 552 553 initialization 554 frRegisterExportFilter(TfrTNPDFExportFilter, 'Adobe Acrobat PDF ' + ' (*.pdf)', 555 '*.pdf'); 556 557 end. 558 559