{********************************************}
{ TeeChart Pro PDF Canvas and Exporting      }
{ Copyright (c) 2002-2020 by Marjan Slatinek }
{   and Steema Software                      }
{       All Rights Reserved                  }
{                                            }
{       Some features taken from             }
{   Nishita's PDF Creation VCL (TNPDF)       }
{         ( with permission )                }
{********************************************}
unit TeePDFCanvas;
{$I TeeDefs.inc}

interface

uses
  {$IFNDEF LINUX}
  {$IFDEF MSWINDOWS}
  Windows,  // <-- Needed in Firemonkey: DefineFontData
  {$ENDIF}
  {$ENDIF}
  Classes,

  {$IFDEF D18}
  System.Generics.Collections,
  {$ENDIF}

  {$IFDEF FMX}
  System.UITypes, FMX.Types, FMX.Controls, FMX.Forms,

  {$IFDEF D19}
  FMX.Graphics,
  {$ENDIF}
  
  {$ELSE}

  {$IFDEF D16}
  System.UITypes,
  {$ENDIF}

  Graphics, Forms,
  {$IFDEF LCL}
  jpeglib,
  {$ELSE}
  Jpeg,
  {$ENDIF}
  {$ENDIF}

  {$IFDEF D9}
  Types,
  {$ENDIF}

  Math,

  {$IFDEF FMX}
  FMXTee.Canvas, FMXTee.Procs, FMXTee.Editor.Export
  {$ELSE}
  TeCanvas, TeeProcs, TeeExport
  {$ENDIF};

type
  // Base pdf object definition (taken from PDF reference )

  PFontData = ^TFontData;
  TFontData = packed record
    FontBBox: TRect;
    FirstChar,
    LastChar: Integer;
    CapHeight: Integer;
    Ascent: Integer;
    Descent: Integer;
    MaxWidth: Integer;
    AvgWidth: Integer;
    ItalicAngle: Single;
    DigAspX,
    DigAspY: Integer;
    CharWidths: Array [0..255] of Integer;
  end;

  TPDFEntry=class
  private
    FObjectNumber: Integer;

    procedure SetObjectNumber(const Value: Integer);
  public
    property ObjectNumber: Integer read FObjectNumber write SetObjectNumber;
  end;

  TImageType = (itJPEG, itBitmap, itUnknown);

  TPDFImageListEntry = class(TPDFEntry)
  private
    FGraphic: TGraphic;
    FHeight: Integer;
    FWidth: Integer;

    procedure DefineImageData;
    function GetDataLength: Integer;
    function GetImageType: TImageType;
  public
    Constructor Create(const AGraphic: TGraphic);
    Destructor Destroy; override;

    procedure WriteDataToStream(const AStream: TStream);

    property DataLength: Integer read GetDataLength;
    property Height: Integer read FHeight;
    property ImageType: TImageType read GetImageType;
    property Width: Integer read FWidth;
  end;

  TPDFImageList = class
  private
    IList: TList{$IFDEF D18}<TPDFImageListEntry>{$ENDIF};

    function EqualImages(const i1,i2: TGraphic): boolean;
    function GetCount: Integer;
    function Get(Index: Integer): TPDFImageListEntry;
  public
    Constructor Create;
    Destructor Destroy; override;

    property Items[Index: Integer]: TPDFImageListEntry read Get; default;
    property Count: Integer read GetCount;

    function Select(const AGraphic: TGraphic): integer;
  end;

  TPDFFontListEntry = class(TPDFEntry)
  private
    FFontData: TFontData;
    FPDFName: String;

    procedure DefineFontData(const AFont: TFont);
  public
    Constructor Create(const AFont: TFont);

    property PDFName: String read FPDFName;
    property FontData: TFontData read FFontData;
  end;

  TPDFFontList = class
  private
    IList: TList{$IFDEF D18}<TPDFFontListEntry>{$ENDIF};

    function Get(Index: Integer): TPDFFontListEntry;
    function GetCount: Integer;
  public
    Constructor Create;
    Destructor Destroy; override;

    property Items[Index: Integer]: TPDFFontListEntry read Get; default;
    property Count: Integer read GetCount;

    function Select(const AFont: TFont): Integer;
  end;

  TPDFPattern = class(TPDFEntry)
  private
    FGradient : TTeeGradient;
    IRect : TRect;

    function PDFRect:String;
    function RadialCoords:String;
  public
    Constructor Create(const AGradient:TTeeGradient; const ARect:TRect);
    Destructor Destroy; override;
  end;

  TPDFPatterns = class
  private
    IList: TList{$IFDEF D18}<TPDFPattern>{$ENDIF};

    function Get(Index: Integer): TPDFPattern;
    function GetCount: Integer;
  public
    Constructor Create;
    Destructor Destroy; override;

    property Items[Index: Integer]: TPDFPattern read Get; default;
    property Count: Integer read GetCount;

    Function Select(const AGradient:TTeeGradient; const ARect:TRect): integer;
  end;

  TPDFPage = class(TMemoryStream)
  public
    procedure SaveTo(const AStream: TStream);
  end;

  TPDFPageSize = (psDefault, psA3, psA4, psA5, psLetter, psLegal, psTabloid, psCustom);

  TPDFPageOrientation = (poPortrait, poLandscape);

  TPDFDocument = class
  private
    FItems: Array of TPDFPage;
    FHeight: Integer;
    FWidth: Integer;
    FOrientation: TPDFPageOrientation;
    FSize: TPDFPageSize;

    FPatterns : TPDFPatterns;
    FFonts: TPDFFontList;
    FImages: TPDFImageList;

    IObjCount,
    CatalogNum,
    ParentNum,
    ResourceNum: Integer;

    OffsetList: TStringList;
    XRefPos: Integer;

    function GetItem(Index:Integer):TPDFPage;
    function NewObject(const AStream: TStream):Integer;
    function SaveFonts:Boolean;

    procedure SetHeight(const Value: Integer);
    procedure SetOrientation(const Value:TPDFPageOrientation);
    procedure SetSize(const Value: TPDFPageSize);
    procedure SetWidth(const Value: Integer);
    procedure WriteHeader(const AStream: TStream);
    procedure WriteInfo(const AStream: TStream);
    procedure WritePatterns(const AStream: TStream);
    procedure WriteTTFonts(const AStream: TStream);
    procedure WriteImages(const AStream: TStream);
    procedure WriteResources(const AStream: TStream);
    procedure WritePages(const AStream: TStream);
    procedure WritePage(const AStream: TStream);
    procedure WriteCatalog(const AStream: TStream);
    procedure WriteXRef(const AStream: TStream);
    procedure WriteTrailer(const AStream: TStream);
  public
    Constructor Create;
    Destructor Destroy; override;

    function NewPage:TPDFPage;
    procedure SaveToStream(const AStream: TStream);

    property Fonts: TPDFFontList read FFonts;
    property Images: TPDFImageList read FImages;
    property Items[Index:Integer]: TPDFPage read GetItem; default;
    property Patterns: TPDFPatterns read FPatterns;

  { published } // <-- Not possible (RTTI $M+ added, unless this is a TPersistent)
    property Orientation: TPDFPageOrientation read FOrientation write SetOrientation default poPortrait;
    property Height: Integer read FHeight write SetHeight;
    property Size: TPDFPageSize read FSize write SetSize default psDefault;
    property Width: Integer read FWidth write SetWidth;
  end;

  TPDFCanvas = class(TTeeNeutralCanvas)
  private
    { Private declarations }

    FX,
    FY: Double;

    FEmbeddedFonts: Boolean;
    FCStream: TStream;
    FContents: TPDFDocument;

    IControl : TBitmap;
    IOwnsReference,
    IOwnsDoc : Boolean;

    IClipStack: Integer;

    Function BrushProperties(const ABrush:TTeeBrush; R:TRect): String; overload;
    Function BrushProperties(R:TRect): String; overload;

    procedure CheckReferenceCanvas;
    procedure EndPenBrush;
    Function FontProperties(const Font: TTeeFont; out FontIndex: Integer): String;
    Function InternalBezCurve(const ax1,ay1,ax2,ay2,ax3,ay3: Double): String;
    procedure InternalDrawArc(X1, Y1, X2, Y2, X3, Y3, X4, Y4: Integer; MoveTo0,DrawPie: Boolean);
    Procedure InternalDrawImage(const sx, sy, tx,ty: Double; ImageIndex: Integer);
    Procedure InternalRect(const Rect:TRect; UsePen:Boolean; RoundX:Integer=0; RoundY:Integer=0);
    Function PenProperties: String; overload;
    Function PenProperties(const APen:TTeePen): String; overload;
    Function PointToStr(const P:TPoint):String; overload;
    Function PointToStr(const X, Y: Double):String; overload;
    procedure SetEmbeddedFonts(const Value: Boolean);
    function TextToPDFText(const AText: String): String;

    function TranslateVertCoord(const Y: Double):Double; overload;
    function TranslateVertCoord(const Y: Integer):Integer; overload;
  protected
    { Protected declarations }

    Function GetIsNoBMPGrid:Boolean; override;
    procedure SetPixel(X, Y: Integer; Value: TColor); override;
    procedure SetPixel3D(X,Y,Z:Integer; Value: TColor); override;
  public
    { Public declarations }

    Constructor Create; override;
    Constructor CreatePage(const ADocument: TPDFDocument; const PageIndex:Integer);
    Destructor Destroy; override;

    Function InitWindow( const DestCanvas:TCanvas;
                         const A3DOptions:TView3DOptions;
                         ABackColor:TColor;
                         Is3D:Boolean;
                         Const UserRect:TRect):TRect; override;

    procedure SaveToFile(const APath:String);
    procedure SaveToStream(const AStream: TStream); // Renamed. Was: WriteToStream

    { 2d }
    Function TextWidth(Const St:String):Integer; override;

    { 3d }
    procedure Arc(const Left, Top, Right, Bottom, StartX, StartY, EndX, EndY: Integer); override;
    procedure Draw(X, Y: Integer; const Graphic: TGraphic); override;
    procedure FillRect(const Rect: TRect); override;
    procedure Ellipse(const X1, Y1, X2, Y2: TCoordinate); override;
    procedure LineTo(const X,Y:TCoordinate); override;
    procedure MoveTo(const X,Y:TCoordinate); override;
    procedure Pie(X1, Y1, X2, Y2, X3, Y3, X4, Y4: Integer); override;
    Procedure Polyline({$IFDEF D6}const{$ENDIF} Points:Array of TPoint); override;
    procedure Rectangle(const X0,Y0,X1,Y1:TCoordinate); override;
    procedure RoundRect(X1, Y1, X2, Y2, X3, Y3: Integer); override;
    procedure StretchDraw(const Rect: TRect; const Graphic: TGraphic); override;
    Procedure TextOut({$IFDEF FMX}const{$ENDIF} X,Y:TCoordinate; const Text:String); override;

    procedure ClipRectangle(Const Rect:TRect); override;
    Procedure ClipRectangle(Const Rect:TRect; RoundX,RoundY:Integer); override;
    procedure UnClipRectangle; override;

    Procedure GradientFill( Const Rect:TRect;
                            StartColor,EndColor:TColor;
                            Direction:TGradientDirection;
                            Balance:Integer=50;
                            RadialX:Integer=0;
                            RadialY:Integer=0); override;

    procedure RotateLabel(x,y:Integer; Const St:String; RotDegree:Double;
                          AllowHTML:Boolean=False); override;
    procedure RotateLabel3D(x,y,z:Integer;
                            const St:String; RotDegree:Double;
                            AllowHTML:Boolean=False); override;
    Procedure Polygon({$IFDEF D6}const{$ENDIF} Points: array of TPoint); override;

    { 3d }
    procedure EllipseWithZ(const X1, Y1, X2, Y2:TCoordinate;
                           const Z:Integer); override;
    Procedure TextOut3D(X,Y,Z:Integer; const Text:String; AllowHTML:Boolean=False); override;

    Procedure ShowImage(const DestCanvas,DefaultCanvas:TCanvas; Const UserRect:TRect); override;

    function NewPage:TPDFPage;

    property Document:TPDFDocument read FContents;
    property EmbeddedFonts: Boolean read FEmbeddedFonts write SetEmbeddedFonts default False;
  end;

  //TPDFChartObject = class(TPDFItemObject); deprecated 'use TPDFItemObject'

  TPDFPosition=(ppCenter, ppStretch, ppFit, ppCustom);

  TPDFExportFormat=class(TTeeExportFormat)
  private
    FBounds : TRect;
    FOrientation : TPDFPageOrientation;
    FPageSize : TPDFPageSize;
    FPosition : TPDFPosition;
    FDocument : TPDFDocument;

    FProperties: TForm;
    Procedure CheckProperties;
    function GetDocument: TPDFDocument;
    procedure DrawTo(const APage:TPDFDocument; const ARect:TRect; const ACanvas:TPDFCanvas=nil);
  protected
    Procedure DoCopyToClipboard; override;
  public
    Constructor Create; override;

    //function ChartObject: TPDFChartObject;

    class function CalcRectangle(const APanel:TCustomTeePanel;
                                  const ADocument:TPDFDocument;
                                  const APosition:TPDFPosition;
                                  const ABounds:TRect):TRect;
    function Description:String; override;
    class procedure Draw(const ACanvas:TPDFCanvas; const APanel:TCustomTeePanel; ARect:TRect);

    {$IFDEF FMX}
    function Editor(AOwner:TComponent):TForm; override;
    {$ELSE}
    Function Options(Check:Boolean=True):TForm; override;
    {$ENDIF}

    function FileExtension:String; override;
    class function FileFilter:String; override;
    Procedure SaveToStream(Stream:TStream); override;
    procedure AddPanel(APanel:TCustomTeePanel;AWidth:Integer=0;AHeight:Integer=0);

    property Bounds:TRect read FBounds write FBounds;
    property Orientation:TPDFPageOrientation read FOrientation write FOrientation;
    property PageSize:TPDFPageSize read FPageSize write FPageSize default psCustom;
    property Position:TPDFPosition read FPosition write FPosition default ppCenter;
    property Document: TPDFDocument read GetDocument;
  end;

procedure WriteStringToStream(const Stream: TStream; const S:String);

procedure TeeSaveToPDFFile( const APanel:TCustomTeePanel;
                            const FileName: {$IFDEF D16}String{$ELSE}WideString{$ENDIF};
                            AWidth:Integer=0;
                            AHeight: Integer=0);

implementation

uses {$IFDEF FMX}
     FMX.Platform,

     {$IFDEF OSX}
     Macapi.CoreGraphics, Macapi.CoreText, Macapi.CocoaTypes, Macapi.CoreFoundation,
     {$ENDIF}

     {$ELSE}
     Clipbrd,
     {$ENDIF}

     {$IFDEF FMX}
     FMXTee.Constants,
     {$ELSE}
     TeeConst,
     {$ENDIF}
     SysUtils;

const
  CRLF = #13+#10;

function FormatIntToString(Value,Len: Integer): string;
var i : Integer;
begin
  if Value < 0 then result := '0'
               else result := TeeStr(Value);

  for i := 1 to Len - Length(result) do
      result := '0' + result;
end;

procedure WriteStringToStream(const Stream: TStream; const S:String);
{$IFDEF D12}
var
  LBytes: TBytes;
{$ENDIF}
begin
  {$IFDEF D12}
  LBytes := TEncoding.Default.GetBytes(S);
  {$IFDEF D17}
    {$IFDEF D21}
    Stream.Write(LBytes, Length(LBytes));
    {$ELSE}
    Stream.Write(LBytes, 0, Length(LBytes));
    {$ENDIF}
  {$ELSE}
  Stream.Write(LBytes[0], Length(LBytes));
  {$ENDIF}

  {$ELSE}
  Stream.Write(S[1],Length(S));
  {$ENDIF}
end;

function PDFFontName(const AFont: TFont): String;
begin
  result:=StringReplace(AFont.{$IFDEF FMX}Family{$ELSE}Name{$ENDIF},' ','',[rfReplaceAll]);

  if {$IFDEF FMX}TFontStyle.{$ENDIF}fsBold in AFont.Style then
     result:=result+',Bold';
  if {$IFDEF FMX}TFontStyle.{$ENDIF}fsItalic in AFont.Style then
     result:=result+',Italic';
end;

// See initialization:
{$IFDEF D7}
var
  PDFFormatSettings:TFormatSettings;
{$ENDIF}

function ToFloat(const Value:Single):String;
begin
  result:=FormatFloat('0.###',Value{$IFDEF D7},PDFFormatSettings{$ENDIF});
end;

// PDF 1.4 spec about Alpha (/CA Constant Opacity) cannot be done here.
// Drawing code should maybe be wrapped with a new enclosing object <</CA 0.3  ....>>

function PDFColor(const AColor:TColor):String;
const tmp=1/255.0;
begin
  result:= ToFloat({$IFDEF FMX}TAlphaColorRec(AColor).R{$ELSE}GetRValue(AColor){$ENDIF}*tmp) + ' ' +
           ToFloat({$IFDEF FMX}TAlphaColorRec(AColor).G{$ELSE}GetGValue(AColor){$ENDIF}*tmp) + ' ' +
           ToFloat({$IFDEF FMX}TAlphaColorRec(AColor).B{$ELSE}GetBValue(AColor){$ENDIF}*tmp);
end;

procedure EndObject(const AStream:TStream);
begin
  WriteStringToStream(AStream,'endobj'+CRLF);
end;

{ TPDFCanvas }

Constructor TPDFCanvas.Create;
begin
  CreatePage(TPDFDocument.Create,0);
  IOwnsDoc:=True;
end;

Constructor TPDFCanvas.CreatePage(const ADocument:TPDFDocument; const PageIndex:Integer);
begin
  inherited Create;

  Gradient.Changed:=nil;
  Brush.OnChange:=nil;
  Pen.OnChange:=nil;

  UseBuffer:=False;

  FContents:=ADocument;
  FCStream:=FContents[PageIndex];

  // Ensure FCanvas is valid to support AssignFont changes
  CheckReferenceCanvas;
end;

Destructor TPDFCanvas.Destroy;
begin
  if IOwnsReference then
     IControl.Free;

  if IOwnsDoc then
     FContents.Free;

  inherited;
end;

function TPDFCanvas.NewPage:TPDFPage;
begin
  result:=FContents.NewPage;
  FCStream:=result;
end;

Function TPDFCanvas.InternalBezCurve(const ax1,ay1,ax2,ay2,ax3,ay3: Double): String;
begin
  Result := ToFloat(ax1)+ ' ' + ToFloat(ay1) + ' ' +
            ToFloat(ax2)+ ' ' + ToFloat(ay2) + ' ' +
            ToFloat(ax3)+ ' ' + ToFloat(ay3) + ' c'+CRLF;
end;

Procedure TPDFCanvas.ShowImage(const DestCanvas,DefaultCanvas:TCanvas; Const UserRect:TRect);
begin
  UnClipRectangle;
  Pen.OnChange:=nil;
end;

procedure TPDFCanvas.Rectangle(const X0,Y0,X1,Y1:TCoordinate);
begin
  InternalRect(TeeRect(X0,Y0,X1,Y1),True);
end;

procedure TPDFCanvas.MoveTo(const X, Y: TCoordinate);
begin
  FX := X;
  FY := Y;
end;

procedure TPDFCanvas.LineTo(const X, Y: TCoordinate);
begin
  WriteStringToStream(FCStream, PenProperties + ' ' + PointToStr(FX,FY)+' m ' + PointToStr(X,Y)+' l S'+CRLF);
  FX := X;
  FY := Y;
end;

procedure TPDFCanvas.ClipRectangle(Const Rect:TRect);
var tmpB, tmpT: Double;
begin
  Inc(IClipStack);

  tmpB := TranslateVertCoord(Rect.Bottom);
  tmpT := TranslateVertCoord(Rect.Top);

  WriteStringToStream(FCStream, 'q'+CRLF+
                                ToFloat(Rect.Left)+' '+ ToFloat(tmpB)+ ' ' +
                                ToFloat(Rect.Right-Rect.Left-1)+' ' +
                                ToFloat(tmpT-tmpB-1)+' re W n'+CRLF);
end;

{ Vertical Y coordinates are reversed in PDF }
function TPDFCanvas.TranslateVertCoord(const Y: Double):Double;
begin
  result:=FContents.FHeight - Y;
end;

{ Vertical Y coordinates are reversed in PDF }
function TPDFCanvas.TranslateVertCoord(const Y: Integer):Integer;
begin
  result:=FContents.FHeight - Y;
end;

function ToStr(const Value:Single):String; overload;
begin
  result:=ToFloat(Value);
end;

function ToStr(const Value:Integer):String; overload;
begin
  result:=TeeStr(Value);
end;

function TPDFCanvas.PenProperties: String;
begin
  result:=PenProperties(Pen);
end;

function TPDFCanvas.PenProperties(const APen:TTeePen): String;

  function PDFPenStyle(const PenStyle: TPenStyle): String;
  begin
    if APen.SmallDots then
       Result := '[1] 0 d'
    else
    case PenStyle of
      psDash    : Result := '[3] 0 d';
      psDot     : Result := '[2] 1 d';
      psDashDot : Result := '[3 2] 2 d';
   psDashDotDot : Result := '[3 1 1] 1 d';
    else
      Result := '[] 0 d';
    end;
  end;

begin
  Result := PDFColor(APen.Color)+ ' RG ' +
            ToStr(APen.Width)+' w ' +
            PDFPenStyle(APen.Style)+ ' ';

  with APen do
  begin
    case EndStyle of
      esRound: Result := Result +' 1 J ';
      esSquare: Result := Result +' 2 J ';
    else
      Result := Result + ' 0 J '; // Butt
    end;

    case JoinStyle of
      jsRound: Result := Result +' 1 j ';
      jsBevel: Result := Result +' 2 j ';
    else
       Result := Result +' 0 j '; // Mitter
    end;
  end;
end;

function TPDFCanvas.BrushProperties(const ABrush:TTeeBrush; R:TRect): String;
begin
  if ABrush.Gradient.Visible then
  begin
    R.Top:=TranslateVertCoord(R.Top);
    R.Bottom:=TranslateVertCoord(R.Bottom);

    result:='/Pattern cs /PA'+TeeStr(FContents.FPatterns.Select(ABrush.Gradient,R))+' scn ';
  end
  else
    result:=PDFColor(ABrush.Color)+' rg';
end;

function TPDFCanvas.BrushProperties(R:TRect): String;
begin
  result:=BrushProperties(Brush,R);
end;

function TPDFCanvas.FontProperties(const Font: TTeeFont; out FontIndex: Integer): String;
begin
  FontIndex := FContents.FFonts.Select(Font);

  Result := '/F'+ TeeStr(FontIndex) + ' ' +
            ToFloat(Font.SizeFloat)+ ' Tf '+
            TeeStr(Font.InterCharSize div 2) + ' Tc ';
end;

procedure TPDFCanvas.UnClipRectangle;
begin
  if IClipStack>0 then
  begin
    Dec(IClipStack);
    WriteStringToStream(FCStream,'Q'+CRLF);
  end;
end;

procedure TPDFCanvas.StretchDraw(const Rect: TRect; const Graphic: TGraphic);
begin
  InternalDrawImage( Abs(Rect.Right - Rect.Left),
                     Abs(Rect.Bottom - Rect.Top),
                     Rect.Left,
                     FContents.FHeight-Rect.Bottom,
                     FContents.FImages.Select(Graphic));
end;

procedure TPDFCanvas.Draw(X, Y: Integer; const Graphic: TGraphic);
begin
  InternalDrawImage(Graphic.Width,Graphic.Height,
                    X,TranslateVertCoord(Y+Graphic.Height),
                    FContents.FImages.Select(Graphic));
end;

Function TPDFCanvas.PointToStr(const P:TPoint):String;
begin
  result:=ToFloat(P.X)+' '+ToFloat(TranslateVertCoord(P.Y));
end;

Function TPDFCanvas.PointToStr(const X,Y:Double):String;
begin
  result:=ToFloat(X)+' '+ToFloat(TranslateVertCoord(Y));
end;

Procedure TPDFCanvas.GradientFill( Const Rect:TRect;
                                   StartColor,EndColor:TColor;
                                   Direction:TGradientDirection;
                                   Balance:Integer=50;
                                   RadialX:Integer=0;
                                   RadialY:Integer=0);
begin
  Gradient.Visible:=True;
  Gradient.StartColor:=StartColor;
  Gradient.MidColor:=clNone;
  Gradient.EndColor:=EndColor;
  Gradient.Direction:=Direction;
  Gradient.Balance:=Balance;
  Gradient.RadialX:=RadialX;
  Gradient.RadialY:=RadialY;

  Brush.Style:=bsClear;

  FillRect(Rect);

  Gradient.Visible:=False;
end;

procedure TPDFCanvas.FillRect(const Rect: TRect);
begin
  InternalRect(Rect,False);
end;

procedure TPDFCanvas.EndPenBrush;
var tmp : String;
begin
  if (Brush.Style=bsClear) and (not Brush.Gradient.Visible) then
     tmp:='S'
  else
  if Pen.Style=psClear then
     tmp:='f'
  else
     tmp:='B';

  WriteStringToStream(FCStream,' '+tmp+CRLF)
end;

procedure TPDFCanvas.InternalRect(const Rect:TRect; UsePen:Boolean; RoundX:Integer=0; RoundY:Integer=0);
var tmpB,
    tmpT  : Double;
    left,
    bottom : String;

  function RoundRectangle:String;
  var top,
      right,
      leftX,
      rightX,
      topY,
      bottomY : String;
  begin
    top:=ToFloat(tmpT);
    right:=ToFloat(Rect.Right);

    leftX:=ToFloat(Rect.Left+RoundX);
    rightX:=ToFloat(Rect.Right-RoundX);
    bottomY:=ToFloat(tmpB+RoundY);
    topY:=ToFloat(tmpT-RoundY);

    result:=rightX+ ' ' + top +' m'+CRLF+
            right+' '+top + ' '+right+ ' ' + topY + ' v'+CRLF+
            right+ ' ' + bottomY +' l'+CRLF+
            right+' '+bottom + ' '+rightX+ ' ' + bottom + ' v'+CRLF+
            leftX+ ' ' + bottom +' l'+CRLF+
            left+' '+bottom + ' '+left+ ' ' + bottomY + ' v'+CRLF+
            left+ ' ' + topY +' l'+CRLF+
            left+' '+top + ' '+leftX+ ' ' + top + ' v'+CRLF+
            'h';
  end;

var tmpSt : String;
begin
  if (Brush.Style<>bsClear) or Brush.Gradient.Visible or (UsePen and (Pen.Style<>psClear)) then
  begin
    tmpB:= TranslateVertCoord(Rect.Bottom);
    tmpT:= TranslateVertCoord(Rect.Top);

    tmpSt:=PenProperties + ' ' + BrushProperties(Rect)+ ' ';

    left:=ToFloat(Rect.Left);
    bottom:=ToFloat(tmpB);

    if (RoundX=0) and (RoundY=0) then
       tmpSt:=tmpSt + left+' '+ bottom + ' ' +
                      ToFloat(Rect.Right-Rect.Left-Pen.Width)+' ' +
                      ToFloat(tmpT-tmpB-Pen.Width)+' re'
    else
       tmpSt:=tmpSt + RoundRectangle;

    WriteStringToStream(FCStream, tmpSt);

    if not UsePen then
       WriteStringToStream(FCStream,' f'+CRLF)
    else
       EndPenBrush;
  end;
end;

procedure TPDFCanvas.Ellipse(const X1, Y1, X2, Y2: TCoordinate);
begin
  EllipseWithZ(X1,Y1,X2,Y2,0);
end;

procedure TPDFCanvas.EllipseWithZ(const X1, Y1, X2, Y2: TCoordinate;
                                  const Z: Integer);
const Bez = 0.552;
var ra,rb,
    xc,yc: Double;
    P1, P2 : TPoint;
    tmpSt : String;
begin
  if (Brush.Style<>bsClear) or Brush.Gradient.Visible or (Pen.Style<>psClear) then
  begin
    WriteStringToStream(FCStream, PenProperties + ' ' + BrushProperties(TeeRect(X1,Y1,X2,Y2))+ ' ');

    Calc3DPoint(P1, X1,Y1,Z);
    Calc3DPoint(P2, X2,Y2,Z);

    ra := (P2.X - P1.X)*0.5;
    rb := (P2.Y - P1.Y)*0.5;
    xc := (P2.X + P1.X)*0.5;
    yc := TranslateVertCoord((P2.Y + P1.Y)*0.5);

    { 4-arc version of drawing circle/ellipse }
    { Q1, Q2, Q3 and Q4 cp}

    tmpSt := ToFloat(xc+ra)+ ' ' + ToFloat(yc)+ ' m '+
             InternalBezCurve(xc+ra, yc+Bez*rb, xc+Bez*ra, yc+rb, xc, yc+rb) +
             InternalBezCurve(xc-Bez*ra, yc+rb, xc-ra, yc+Bez*rb, xc-ra, yc) +
             InternalBezCurve(xc-ra, yc-Bez*rb, xc-Bez*ra, yc-rb, xc, yc-rb) +
             InternalBezCurve(xc+Bez*ra, yc-rb, xc+ra, yc-Bez*rb, xc+ra, yc);

    WriteStringToStream(FCStream, tmpSt);
    EndPenBrush;
  end;
end;

procedure TPDFCanvas.SetPixel3D(X,Y,Z:Integer; Value: TColor);
begin
  if Pen.Style<>psClear then
  begin
    Calc3DPos(x,y,z);
    Pen.Color:=Value;
    MoveTo(x,y);
    LineTo(x,y);
  end;
end;

procedure TPDFCanvas.SetPixel(X, Y: Integer; Value: TColor);
begin
  if Pen.Style<>psClear then
  begin
    Pen.Color:=Value;
    MoveTo(x,y);
    LineTo(x,y);
  end;
end;

procedure TPDFCanvas.Arc(const Left, Top, Right, Bottom, StartX, StartY, EndX, EndY: Integer);
begin
  InternalDrawArc(Left,Top,Right,Bottom,StartX,StartY,EndX,EndY,True,False);
end;

procedure TPDFCanvas.Pie(X1, Y1, X2, Y2, X3, Y3, X4, Y4: Integer);
begin
  InternalDrawArc(X1, Y1, X2, Y2, X3, Y3, X4, Y4, False, True);
end;

Procedure TPDFCanvas.Polyline({$IFDEF D6}const{$ENDIF} Points:Array of TPoint);
var L,
    t : Integer;
    tmp : String;
begin
  if Length(Points)>0 then
  begin
    FX:=Points[0].X;
    FY:=Points[0].Y;

    WriteStringToStream(FCStream, PenProperties + ' ' + PointToStr(FX,FY)+' m ' +CRLF);

    tmp:='';

    L:=High(Points);

    for t:=1 to L do
        tmp:=tmp+PointToStr(Points[t])+' l'+CRLF;

    FX:=Points[L].X;
    FY:=Points[L].Y;

    WriteStringToStream(FCStream, tmp+' S'+CRLF);
  end;
end;

procedure TPDFCanvas.RoundRect(X1, Y1, X2, Y2, X3, Y3: Integer);
begin
  InternalRect(TeeRect(X1,Y1,X2,Y2),True,X3,Y3);
end;

Procedure TPDFCanvas.TextOut3D(X,Y,Z:Integer; const Text:String; AllowHTML:Boolean=False);
begin
  RotateLabel3D(X,Y,Z,Text,0,AllowHTML);
end;

Procedure TPDFCanvas.TextOut({$IFDEF FMX}const{$ENDIF} X,Y:TCoordinate; const Text:String);
begin
  RotateLabel({$IFDEF FMX}Round{$ENDIF}(X),
              {$IFDEF FMX}Round{$ENDIF}(Y),Text,0);
end;

procedure TPDFCanvas.RotateLabel3D(x,y,z:Integer; Const St:String; RotDegree:Double;
                                   AllowHTML:Boolean=False);
begin
  if Z<>0 then
     Calc3DPos(X,Y,Z);

  RotateLabel(X,Y,St,RotDegree,AllowHTML);
end;

procedure TPDFCanvas.RotateLabel(x,y:Integer; Const St:String; RotDegree:Double;
                                 AllowHTML:Boolean=False);

const
  PDFFontPixelsPerInch=72;

  procedure DoText(AColor:TColor; const AX, AY:Integer; DoOutLine:Boolean;
                   const ABrush:TTeeBrush=nil);
  var
    XFactor,
    YFactor : Single;

    th: Double;

    function TextBounds:TRect;
    var tmpW : Single;
    begin
      tmpW:=TextWidth(St)*XFactor;

      if (TextAlign and TA_CENTER)=TA_CENTER then
      begin
        result.Left:={$IFNDEF FMX}Round{$ENDIF}(AX-tmpW*0.5);
        result.Right:={$IFNDEF FMX}Round{$ENDIF}(AX+tmpW*0.5);
      end
      else
      if (TextAlign and TA_RIGHT)=TA_RIGHT then
      begin
        result.Left:={$IFNDEF FMX}Round{$ENDIF}(AX-tmpW);
        result.Right:=AX;
      end
      else
      begin
        result.Left:=AX;
        result.Right:={$IFNDEF FMX}Round{$ENDIF}(AX + tmpW);
      end;

      result.Top:=AY;
      result.Bottom:={$IFNDEF FMX}Round{$ENDIF}(AY+th);
    end;

  var vcos, vsin : {$IFDEF D15}Double{$ELSE}Extended{$ENDIF};
      tw,
      xc,yc: Double;
      FontIndex: Integer;
      tmpFont : TPDFFontListEntry;
      tmpOutline,
      tmpSt : String;
      tmpR : TRect;
  begin
    WriteStringToStream(FCStream, FontProperties(Font,FontIndex)+' ');

    {$IFDEF FPCLINUX}
    XFactor:=1;
    YFactor:=1;
    {$ELSE}
    { FIX :
      the system uses 72 Pixelsperinch as a base line figure, most systems are
      96 DPI or if your in large Font Mode then 120 DPI
      So when using the TextWidth/TextHeight of the currently selected font, you get the wrong answer
    }
    tmpFont:=FContents.Fonts.Items[FontIndex];

    XFactor:=PDFFontPixelsPerInch/tmpFont.FontData.DigAspX;
    YFactor:=PDFFontPixelsPerInch/tmpFont.FontData.DigAspY;
    {$ENDIF}

    { Get text width and height }
    th := TextHeight(St)*YFactor; // ??*0.75; // 72/96 ?

    if (TextAlign and TA_CENTER)=TA_CENTER then
       tw := TextWidth(St)*0.5*XFactor
    else
    if (TextAlign and TA_RIGHT)=TA_RIGHT then
       tw := TextWidth(St)*XFactor
    else
       tw := 0 ;

    tmpR:=TextBounds;

    if Assigned(ABrush) and ABrush.Gradient.Visible then
    begin
      tmpR:=TextBounds;
      WriteStringToStream(FCStream, BrushProperties(ABrush,tmpR)+' BT ');
    end
    else
      WriteStringToStream(FCStream, PDFColor(AColor)+' rg BT ');

    if RotDegree<>0 then
    begin
      { rotation elements }
      SinCos(RotDegree*TeePiStep, vsin, vcos);

      { rotated values }
      xc := AX - (tw*vcos-th*vsin) - (self.TextHeight('H') div 2);
      yc := TranslateVertCoord(AY) - (tw*vsin+th*vcos) - (self.TextHeight('H') div 2); //small adj on vertical

      tmpSt := ToFloat(vcos)+ ' ' + ToFloat(vsin)+ ' '+
               ToFloat(-vsin)+ ' ' + ToFloat(vcos)+ ' '+
               ToFloat(xc)+ ' ' + ToFloat(yc)+ ' Tm ';
    end
    else
      tmpSt := ToFloat(AX-tw)+' '+ToFloat(TranslateVertCoord(AY+th))+' Td ';

    if DoOutLine then
    begin
      if Assigned(ABrush) and (ABrush.Style=bsClear) then
         tmpOutline:='1' // stroke only
      else
         tmpOutline:='2'; // stroke and fill

      tmpSt:=tmpSt+CRLF+tmpOutline+' Tr '+PenProperties(Font.OutLine)+CRLF;
    end
    else
      tmpSt:=tmpSt+CRLF+'0 Tr ';

    WriteStringToStream(FCStream, tmpSt + '<'+TextToPDFText(St)+'> Tj ' + 'ET'+CRLF);

    // DEBUG:
    {
      Brush.Style:=bsClear;
      Brush.Gradient.Visible:=False;
      InternalRect(tmpR,True,False);
    }
  end;

  procedure DrawFontShadow(const AShadow:TTeeShadow; AFactor:Integer);
  var tmpX : Integer;
      tmpY : Integer;
  begin
    with AShadow do
    if Visible and (Size<>0) then
    begin
      if HorizSize<0 then
      begin
        tmpX:=X;
        X:=X-AFactor*HorizSize;
      end
      else tmpX:=X+AFactor*HorizSize;

      if VertSize<0 then
      begin
        tmpY:=Y;
        Y:=Y-AFactor*VertSize;
      end
      else tmpY:=Y+AFactor*VertSize;

      DoText(Color,tmpX,tmpY,False);
    end;
  end;

begin
  if (TextAlign and TA_BOTTOM)=TA_BOTTOM then // TV52010657
     Dec(Y,Round(Font.Size*{$IFDEF FMX}96{$ELSE}Screen.PixelsPerInch{$ENDIF}/PDFFontPixelsPerInch));

  DrawFontShadow(Font.Shadow,1);
  DrawFontShadow(Font.Emboss,-1);

  DoText({$IFDEF FMX}{$IFDEF D17}Font.{$ENDIF}Brush{$ELSE}Font{$ENDIF}.Color,X,Y,
         Font.OutLine.Visible,Font.Brush);
end;

procedure TPDFCanvas.ClipRectangle(const Rect: TRect; RoundX,RoundY:Integer);
begin
  ClipRectangle(Rect);
end;

function TPDFCanvas.GetIsNoBMPGrid: Boolean;
begin
  result:=True;
end;

Procedure TPDFCanvas.Polygon({$IFDEF D6}const{$ENDIF} Points: Array of TPoint);
var t : Integer;
    tmpSt : String;
begin
  if (Brush.Style<>bsClear) or Brush.Gradient.Visible or (Pen.Style<>psClear) then
  begin
    WriteStringToStream(FCStream, PenProperties+' '+BrushProperties(PolygonBounds(Points))+' ');

    tmpSt:=PointToStr(Points[0])+' m'+CRLF;

    for t:=1 to High(Points) do
        tmpSt:=tmpSt+PointToStr(Points[t])+' l'+CRLF;

    WriteStringToStream(FCStream,tmpSt+'h ');
    EndPenBrush;
  end;
end;

function TPDFCanvas.InitWindow(const DestCanvas: TCanvas;
  const A3DOptions: TView3DOptions; ABackColor: TColor; Is3D: Boolean;
  const UserRect: TRect): TRect;
begin
  result:=inherited InitWindow(DestCanvas,A3DOptions,ABackColor,Is3D,UserRect);

  IClipStack:=0;

  FContents.FHeight:={$IFDEF FMX}Round{$ENDIF}(Bounds.Bottom-Bounds.Top);

  ClipRectangle(UserRect);
end;

procedure TPDFCanvas.InternalDrawArc(X1, Y1, X2, Y2, X3, Y3, X4, Y4: Integer; MoveTo0,DrawPie: Boolean);

    procedure Rotate(var ax,ay: Double; const Angle: Double);
    var tx,ty: Double;
        vcos, vsin: {$IFDEF D15}Double{$ELSE}Extended{$ENDIF};
    begin
      SinCos(Angle,vsin,vcos);
      tx := ax;
      ty := ay;
      ax := vcos*tx - vsin*ty;
      ay := vsin*tx + vcos*ty;
    end;

var fccwc: Double;

    procedure ArcSegment(const ax, ay:Double; ra, rb:Double; const midtheta, hangle: Double; amt0: Integer);
    var ax1,ay1,
        ax2,ay2,
        ax3,ay3: Double;
        ax0,ay0: Double;
        hTheta: Double;
        vcos, vsin: {$IFDEF D15}Double{$ELSE}Extended{$ENDIF};
        tmpSt : String;
    begin
      if ra < rb then
         SwapDouble(ra,rb);

      htheta := Abs(hangle);
      SinCos(htheta,vsin,vcos);

      ax0 := ra*vcos;
      ay0 := -fccwc*ra*vsin;
      Rotate(ax0,ay0,midtheta);

      if amt0 = 1 then
         tmpSt := ToFloat(ax+ax0)+ ' ' + ToFloat(ay+ay0) + ' m'+CRLF
      else
      if amt0 = 0 then
         tmpSt := ToFloat(ax+ax0)+ ' ' + ToFloat(ay+ay0) + ' l'+CRLF
      else
         tmpSt := '';

      ax1 := ra*(4.0 - vcos)/3.0;
      ax2 := ax1;
      ay1 := ra*fccwc *(1.0 - vcos) * (vcos - 3.0) / (3.0*vsin);
      ay2 := -ay1;
      ax3 := ra*vcos;
      ay3 := fccwc*ra*vsin;

      Rotate(ax1, ay1, midtheta);
      Rotate(ax2, ay2, midtheta);
      Rotate(ax3, ay3, midtheta);

      WriteStringToStream(FCStream, tmpSt+InternalBezCurve(ax+ax1,ay+ay1,ax+ax2,ay+ay2,ax+ax3,ay+ay3) );
    end;

var SegCount,i: Integer;
    CurrAngle,
    Span : Double;
    AngleBump,
    hBump: Double;
    x,y,a,b,
    StartAngle,
    EndAngle: Double;
    rat,tr: Double;
    tmpSt : String;
begin
  if (Brush.Style<>bsClear) or (Pen.Style<>psClear) then
  begin
    WriteStringToStream(FCStream, PenProperties);

    if (Brush.Style<>bsClear) and DrawPie then
       WriteStringToStream(FCStream, ' '+ BrushProperties(TeeRect(X1,Y1,X2,Y2))+CRLF)
    else
       WriteStringToStream(FCStream,' ');

    { center pos + radius }
    x := (X1 + X2)*0.5;
    y := (Y1 + Y2)*0.5;
    a := (X2 - X1)*0.5;
    b := (Y2 - Y1)*0.5;

    { this is only approx. algorithm }
    if a <> b then
    begin
      WriteStringToStream(FCStream,'q'+CRLF);

      if a>b then
      begin
        rat := b/a;
        tr := y*(1.0-rat);
        tmpSt := '1 0 0 ' + ToFloat(rat) + ' 0 '+ ToFloat(tr);
      end
      else
      begin
        rat := a/b;
        tr := x*(1.0-rat);
        tmpSt := ToFloat(rat)+ ' 0 0 1 '+ ToFloat(tr) +  ' 0';
      end;

      WriteStringToStream(FCStream, tmpSt+ ' cm'+CRLF);
    end;

    { StartAngle }
    CurrAngle := Math.ArcTan2(Y-Y3, X3 - X);
    if CurrAngle<0 then
       CurrAngle:=2.0*Pi+CurrAngle;

    StartAngle := CurrAngle;

    { EndAngle }
    Currangle := Math.ArcTan2(Y-Y4, X4 - X);

    if CurrAngle<=0 then
       CurrAngle:=2.0*Pi+CurrAngle;

    EndAngle := CurrAngle;

    if DrawPie then
       WriteStringToStream(FCStream, PointToStr(x,y)+' m'+CRLF);

    y:=TranslateVertCoord(y);

    fccwc := 1.0;
    SegCount := 1;
    Span := EndAngle - StartAngle;

    if EndAngle < StartAngle then
       fccwc := -1.0;

    while Abs(Span)/SegCount > Pi*0.5 do
          Inc(SegCount);

    AngleBump := Span/SegCount;
    hBump := 0.5*AngleBump;
    CurrAngle := StartAngle + hBump;

    for i := 0 to SegCount -1 do
    begin
      if i = 0 then
         ArcSegment(x,y,a,b,CurrAngle,hBump,Integer(MoveTo0))
      else
         ArcSegment(x,y,a,b,CurrAngle,hBump,-1);

      CurrAngle := CurrAngle + AngleBump;
    end;

    if (Brush.Style<>bsClear) and DrawPie then
       if Pen.Style<>psClear then
          tmpSt:='h B'
       else
          tmpSt:='h f'
    else
    if DrawPie then
       tmpSt:='s'
    else
       tmpSt:='S';

    WriteStringToStream(FCStream,' '+tmpSt+CRLF);

    if a<>b then
       WriteStringToStream(FCStream,'Q'+CRLF);
  end;
end;

{ Transform individual chars to double byte hex codes}
function TPDFCanvas.TextToPDFText(const AText: String): String;
var i : Integer;
    {$IFDEF D16}
    LBytes : TBytes;
    {$ENDIF}
begin
  Result := '';

  {$IFDEF D16}
  LBytes := TEncoding.Default.GetBytes(AText);
  for i := 0 to Length(LBytes)-1 do
    Result := Result + IntToHex(LBytes[i], 2);
  {$ELSE}
  for i := 1 to Length(AText) do
    Result := Result + IntToHex(Ord(AText[i]), 2);
  {$ENDIF}
end;

procedure TPDFCanvas.CheckReferenceCanvas;
begin
  if ReferenceCanvas=nil then
  begin
    IControl:=TBitmap.Create{$IFDEF FMX}(1,1){$ENDIF}; // <-- min 1,1 pixels (to avoid Canvas.GPU fail)
    ReferenceCanvas:=IControl.Canvas;

    IOwnsReference:=True;
  end;
end;

function TPDFCanvas.TextWidth(const St: String): Integer;
begin
  {$IFDEF FMX}
  Result := Round(inherited TextWidth(St)*1.25);
  {$ELSE}
  Result := inherited TextWidth(St);
  {$ENDIF}
end;

procedure TPDFCanvas.InternalDrawImage(const sx, sy, tx,ty: Double; ImageIndex: Integer);
begin
  WriteStringToStream(FCStream,'q '+
           ToFloat(sx) + ' 0 0 ' +
           ToFloat(sy) + ' ' +
           ToFloat(tx) + ' ' +
           ToFloat(ty) +
           ' cm /Im'+ TeeStr(ImageIndex)+' Do Q'+CRLF);
end;

procedure TPDFCanvas.SetEmbeddedFonts(const Value: Boolean);
begin
  FEmbeddedFonts := Value;
end;

procedure TPDFCanvas.SaveToFile(const APath:String);
var f : TFileStream;
begin
  f:=TFileStream.Create(APath,fmCreate);
  try
    SaveToStream(f);
  finally
    f.Free;
  end;
end;

procedure TPDFCanvas.SaveToStream(const AStream: TStream);
begin
  FContents.SaveToStream(AStream);
end;

{ TPDFExportFormat }

Constructor TPDFExportFormat.Create;
begin
  inherited;
  FPageSize:=psCustom;
  FPosition:=ppCenter;
end;

function TPDFExportFormat.Description: String;
begin
  result:=TeeMsg_AsPDF;
end;

Procedure TPDFExportFormat.CheckProperties;
begin
  if not Assigned(FProperties) then
     FProperties:=CreateProperties('TPDFOptions');
end;

{$IFDEF FMX}
function TPDFExportFormat.Editor(AOwner:TComponent):TForm;
{$ELSE}
Function TPDFExportFormat.Options(Check:Boolean=True):TForm;
{$ENDIF}
begin
  {$IFNDEF FMX}if Check then{$ENDIF} CheckProperties;
  result:=FProperties;
end;

function TPDFExportFormat.FileExtension: String;
begin
  result:='pdf';
end;

class function TPDFExportFormat.FileFilter: String;
begin
  result:=TeeMsg_PDFFilter;
end;

procedure TPDFExportFormat.DoCopyToClipboard;
var S : TStringStream;
begin
  S:=TStringStream.Create('');
  try
    SaveToStream(S);
    TeeCopyClipboard(S.DataString);
  finally
    S.Free;
  end;
end;

procedure TPDFExportFormat.SaveToStream(Stream: TStream);
begin
  with Document do
  try
    SaveToStream(Stream);
  finally
    Free;
  end;
end;

procedure TPDFExportFormat.AddPanel(APanel:TCustomTeePanel;AWidth:Integer=0;AHeight:Integer=0);
begin
  if Assigned(Panel) then
     Document.NewPage;

  Panel:=APanel;
  Width:=AWidth;
  Height:=AHeight;
  DrawTo(Document,Panel.BoundsRect);
end;


type
  TTeePanelAccess=class(TCustomTeePanel);

procedure TPDFExportFormat.DrawTo(const APage:TPDFDocument; const ARect:TRect; const ACanvas:TPDFCanvas=nil);
var tmp : TCanvas3D;
begin
  Panel.AutoRepaint := False;
  try
    tmp := Panel.Canvas;
    TTeePanelAccess(Panel).InternalCanvas:=nil;

    if Assigned(ACanvas) then
       Panel.Canvas:=ACanvas
    else
       Panel.Canvas:=TPDFCanvas.CreatePage(APage,High(APage.FItems));

    if not Assigned(Panel.Parent) then
       Panel.BufferedDisplay:=True;

    {$IFDEF FMX}
    if not Assigned(Panel.Canvas.ReferenceCanvas) then
       if TControl(Panel).Canvas<>nil then
          Panel.Canvas.ReferenceCanvas:=TControl(Panel).Canvas
       else
       if Assigned(Panel.Parent) then
          if Panel.Parent is TControl then
             Panel.Canvas.ReferenceCanvas:=TControl(Panel.Parent).Canvas
          else
          if Panel.Parent is TCustomForm then
             Panel.Canvas.ReferenceCanvas:=TCustomForm(Panel.Parent).Canvas;
    {$ENDIF}

    try
      Panel.Draw(Panel.Canvas.ReferenceCanvas,ARect);
    finally
      if Assigned(ACanvas) then
         TTeePanelAccess(Panel).InternalCanvas:=nil;

      Panel.Canvas:=tmp;
    end;
  finally
    Panel.AutoRepaint:=True;
  end;
end;

(*
function TPDFExportFormat.ChartObject: TPDFChartObject;
begin { return a panel or chart in PDF format into a StringList }
  CheckSize;

  result:=TPDFChartObject.Create;
  DrawTo(result,Panel.BoundsRect);
end;
*)

function TPDFExportFormat.GetDocument: TPDFDocument;
var Old: Integer;
    R : TRect;
    tmpH : TCoordinate;
begin { returns a PDF Document with a single Page containing the panel or chart in PDF vectorial format }
  if not Assigned(FDocument) then
  begin
    CheckSize;
    CheckProperties;

    if Assigned(FProperties) then
       FProperties.CloseQuery;

    FDocument:=TPDFDocument.Create;

    FDocument.Size:=FPageSize;

    if FPageSize=psCustom then
    begin
      FDocument.Width:=Width;
      FDocument.Height:=Height;
    end;

    FDocument.Width:=FDocument.Width -Round(FDocument.Width * Panel.PrintResolution * 0.01);
    FDocument.Height:=FDocument.Height -Round(FDocument.Height * Panel.PrintResolution * 0.01);

    FDocument.Orientation:=FOrientation;

    Old:=FDocument.FHeight;
    try
      R:=CalcRectangle(Panel,FDocument,Position,FBounds);
      tmpH:=R.Bottom-R.Top;
      R.Top:=R.Top-FDocument.Height+tmpH;
      R.Bottom:=R.Bottom-FDocument.Height+tmpH;

      DrawTo(FDocument,R);
    finally
      FDocument.FHeight:=Old;
    end;
  end;

  result:=FDocument;
end;

class function TPDFExportFormat.CalcRectangle(const APanel:TCustomTeePanel;
                                  const ADocument:TPDFDocument;
                                  const APosition:TPDFPosition;
                                  const ABounds:TRect):TRect;
var R : TRect;
    tmpW,
    tmpH : TCoordinate;
begin
  R:=APanel.GetRectangle;

  tmpW:=R.Right-R.Left;
  tmpH:=R.Bottom-R.Top;

  R.Right:=R.Left+tmpW -Round(tmpW * APanel.PrintResolution * 0.01);
  R.Bottom:=R.Top+tmpH -Round(tmpH * APanel.PrintResolution * 0.01);

  tmpW:=R.Right-R.Left;
  tmpH:=R.Bottom-R.Top;

  case APosition of
    ppCenter: begin
                R.Left:=(ADocument.Width-tmpW) {$IFDEF FMX}*0.5{$ELSE}div 2{$ENDIF};
                R.Top:=(ADocument.Height-tmpH) {$IFDEF FMX}*0.5{$ELSE}div 2{$ENDIF};
                R.Right:=R.Left+tmpW;
                R.Bottom:=R.Top+tmpH;
              end;
   ppStretch: begin
                if APanel.PrintProportional then
                   APanel.PrintMargins:=TTeePanelAccess(APanel).InternalCalcProportionalMargins(
                          {$IFDEF FMX}Round{$ENDIF}(tmpW),
                          {$IFDEF FMX}Round{$ENDIF}(tmpH),
                          {$IFDEF FMX}Round{$ENDIF}(ADocument.Width),
                          {$IFDEF FMX}Round{$ENDIF}(ADocument.Height),
                          ADocument.Width/ADocument.Height);

                R:=TTeePanelAccess(APanel).PrintMarginsRect(
                          {$IFDEF FMX}Round{$ENDIF}(ADocument.Width),
                          {$IFDEF FMX}Round{$ENDIF}(ADocument.Height));
              end;
      ppFit : begin
              end;
   ppCustom : begin
                R.Left:=ABounds.Left;
                R.Top:=ABounds.Top;

                if ABounds.Right=0 then
                   R.Right:=R.Left+tmpW;

                if ABounds.Bottom=0 then
                   R.Bottom:=R.Top+tmpH;
              end;
  end;

  result:=R;
end;

class procedure TPDFExportFormat.Draw(const ACanvas:TPDFCanvas; const APanel:TCustomTeePanel; ARect:TRect);
var tmp : TPDFExportFormat;

    {$IFNDEF FMX}
    tmpH : TCoordinate;
    {$ENDIF}
    
    Old : Integer;
begin
  tmp:=TPDFExportFormat.Create;
  try
    tmp.Panel:=APanel;

    {$IFDEF FMX}
    ARect.Offset(0,-ACanvas.Document.Height+Abs(ARect.Bottom-ARect.Top));
    {$ELSE}
    tmpH:=-ACanvas.Document.Height+Abs(ARect.Bottom-ARect.Top);
    Inc(ARect.Top,tmpH);
    Inc(ARect.Bottom,tmpH);
    {$ENDIF}

    Old:=ACanvas.Document.FHeight;
    try
      tmp.DrawTo(ACanvas.Document,ARect,ACanvas);
    finally
      ACanvas.Document.FHeight:=Old;
    end;
  finally
    tmp.Free;
  end;
end;

procedure TeeSaveToPDFFile( const APanel:TCustomTeePanel;
                            const FileName: {$IFDEF D16}String{$ELSE}WideString{$ENDIF};
                            AWidth:Integer=0;
                            AHeight: Integer=0);
begin { save panel or chart to filename in VML (html) format }
  with TPDFExportFormat.Create do
  try
    Panel:=APanel;
    Height:=AHeight;
    Width:=AWidth;
    SaveToFile(FileName);
  finally
    Free;
  end;
end;

{ TPDFFontListEntry }

Constructor TPDFFontListEntry.Create(const AFont: TFont);
begin
  inherited Create;
  FPDFName := PDFFontName(AFont);
  DefineFontData(AFont);
end;

// 14 PDF Standard Fonts:
(*
Courier Helvetica Times-Roman Symbol
Courier-Bold Helvetica-Bold Times-Bold ZapfDingbats
Courier-Oblique Helvetica-Oblique Times-Italic
Courier-BoldOblique Helvetica-BoldOblique Times-BoldItalic
*)

procedure TPDFFontListEntry.DefineFontData(const AFont: TFont);
{$IFDEF MSWINDOWS}

  procedure FillFontData(var AInfo:TOutlineTextMetric);
  begin
    with FFontData do
    begin
      DigAspX := AInfo.otmTextMetrics.tmDigitizedAspectX;
      DigAspY := AInfo.otmTextMetrics.tmDigitizedAspectY;

      {$IFDEF FMX}
      FontBBox.Left := AInfo.otmrcFontBox.Left;
      FontBBox.Top := AInfo.otmrcFontBox.Top;
      FontBBox.Right := AInfo.otmrcFontBox.Right;
      FontBBox.Bottom := AInfo.otmrcFontBox.Bottom;
      {$ELSE}
      FontBBox := AInfo.otmrcFontBox;
      {$ENDIF}

      FirstChar := Ord(AInfo.otmTextMetrics.tmFirstChar);

      {$IFDEF D12}
      LastChar := 255;  //fix 255 to avoid upper 65532 limit on widestring font
      {$ELSE}
      LastChar := Ord(AInfo.otmTextMetrics.tmLastChar);
      {$ENDIF}

      CapHeight := AInfo.otmsCapEmHeight;
      Ascent := AInfo.otmTextMetrics.tmAscent;
      Descent := -AInfo.otmTextMetrics.tmDescent;
      MaxWidth := AInfo.otmTextMetrics.tmMaxCharWidth;
      AvgWidth := AInfo.otmTextMetrics.tmAveCharWidth;
      ItalicAngle := AInfo.otmItalicAngle;
    end;
  end;

var FontInfo: ^TOutlineTextMetric;
    fnt: HFont;
    m_hdcFont: HDC;
begin
  New(FontInfo);
  try
    fnt := CreateFont(-1000, 0, 0, 0, FW_DONTCARE, 0, 0, 0,
                      DEFAULT_CHARSET,
                      OUT_DEFAULT_PRECIS, CLIP_DEFAULT_PRECIS,
                      DEFAULT_QUALITY, DEFAULT_PITCH or FF_DONTCARE,
                      PChar(AFont.{$IFDEF FMX}Family{$ELSE}Name{$ENDIF}));

    m_hdcFont := GetDC(0);
    try
      SelectObject(m_hdcFont, fnt);
      DeleteObject( fnt );

      GetOutlineTextMetrics(m_hdcFont,SizeOf(TOutlineTextMetric),FontInfo);

      FillFontData(FontInfo^);
      GetCharWidth(m_hdcFont,0,255,FFontData.CharWidths);
    finally
      ReleaseDC(0,m_hdcFont);
    end;
  finally
    Dispose(FontInfo);
  end;
{$ELSE}
{$IFDEF OSX}

   function Normalize(const R:TRect):TRect;
   begin
     result:=R;

     if result.Left>result.Right then
        SwapSingle(result.Left,result.Right);

     if result.Top<result.Bottom then
        SwapSingle(result.Top,result.Bottom);
   end;

   function FromNSRect(const R:NSRect):TRect;
   begin
     result.Left:=R.origin.x;
     result.Top:=R.origin.y;
     result.Right:=R.origin.x+R.size.width;
     result.Bottom:=R.origin.y+R.size.height;
   end;

var tmpFontRef : CTFontRef;
begin
  FFontData.FirstChar:=0;
  FFontData.LastChar:=0;
  FFontData.DigAspX:=96;
  FFontData.DigAspY:=96;

  tmpFontRef:=CTFontCreateWithName(CFSTR(AFont.Family), AFont.Size, nil);
  try
    FFontData.Ascent:=Round(CTFontGetAscent(tmpFontRef));
    FFontData.Descent:=Round(CTFontGetDescent(tmpFontRef));
    FFontData.CapHeight:=Round(CTFontGetCapHeight(tmpFontRef));
    //FFontData.XHeight:=Round(CTFontGetXHeight(tmpFontRef));
    FFontData.ItalicAngle:=CTFontGetSlantAngle(tmpFontRef);
    FFontData.FontBBox:=Normalize(FromNSRect(CTFontGetBoundingBox(tmpFontRef)));
  finally
    CFRelease(tmpFontRef);
  end;

{$ELSE}
begin
  With FFontData do
  begin
    FFontData.FirstChar:=0;
    FFontData.LastChar:=0;
    DigAspX := 96;
    DigAspY := 96;
  end;
{$ENDIF}
{$ENDIF}
end;

{ TPDFFontList }

Constructor TPDFFontList.Create;
begin
  inherited;
  IList := TList{$IFDEF D18}<TPDFFontListEntry>{$ENDIF}.Create;
end;

Destructor TPDFFontList.Destroy;
{$IFNDEF AUTOREFCOUNT}
var i: Integer;
{$ENDIF}
begin
  {$IFNDEF AUTOREFCOUNT}
  for i := 0 to IList.Count - 1 do
      {$IFNDEF D18}TPDFFontListEntry{$ENDIF}(IList.Items[i]).Free;
  {$ENDIF}

  IList.Free;

  inherited Destroy;
end;

function TPDFFontList.Select(const AFont: TFont): Integer;

  function Find:Integer;
  var i: Integer;
      tmpName: String;
  begin
    tmpName := PDFFontName(AFont);

    for i := 0 to IList.Count - 1 do
      if tmpName = {$IFNDEF D18}TPDFFontListEntry{$ENDIF}(IList.Items[i]).PDFName then
      begin
        Result := i;
        Exit;
      end;

    Result := -1;
  end;

begin
  Result := Find;

  if Result = -1 then
     Result := IList.Add(TPDFFontListEntry.Create(AFont));
end;

function TPDFFontList.GetCount: Integer;
begin
  Result := IList.Count;
end;

function TPDFFontList.Get(Index: Integer): TPDFFontListEntry;
begin
  Result := {$IFNDEF D18}TPDFFontListEntry{$ENDIF}(IList.Items[Index]);
end;

{ TPDFPatterns }

Constructor TPDFPatterns.Create;
begin
  inherited;
  IList := TList{$IFDEF D18}<TPDFPattern>{$ENDIF}.Create;
end;

Destructor TPDFPatterns.Destroy;
{$IFNDEF AUTOREFCOUNT}
var i: Integer;
{$ENDIF}
begin
  {$IFNDEF AUTOREFCOUNT}
  for i := 0 to IList.Count - 1 do
      {$IFNDEF D18}TPDFPattern{$ENDIF}(IList.Items[i]).Free;
  {$ENDIF}

  IList.Free;

  inherited Destroy;
end;

function TPDFPatterns.Select(const AGradient:TTeeGradient; const ARect:TRect): Integer;

  // Problem: Gradients cannot be cached (added to /Patterns dictionary) because
  // the /Coords coordinates change every time we use a given gradient to paint a rect
  function Find: Integer;
  //var i: Integer;
  begin
    {
    for i := 0 to Count-1 do
      if EqualGradient(AGradient,Items[i].FGradient) then
      begin
        Result := i;
        Exit;
      end;
    }
    Result := -1;
  end;

begin
  Result := Find;

  if Result = -1 then
     Result := IList.Add(TPDFPattern.Create(AGradient,ARect));
end;

{
function EqualGradient(const A,B:TTeeGradient):Boolean;

  function EqualColors(const AC,BC:TTeeGradientColors):Boolean;
  var t : Integer;
      tmpA,
      tmpB : TTeeGradientColor;
  begin
    if AC=BC then
       result:=True
    else
    begin
      result:=(AC.Count=BC.Count);

      if result then
        for t:=0 to AC.Count-1 do
        begin
          tmpA:=AC[t];
          tmpB:=BC[t];

          if (tmpA.Color<>tmpB.Color) or (tmpA.Offset<>tmpB.Offset) or
             (tmpA.Transparency<>tmpB.Transparency) then
          begin
            result:=False;
            break;
          end;
        end;
    end;
  end;

begin
  result:=(A=B) or
         (
            (A.Direction=B.Direction) and
            EqualColors(A.Colors,B.Colors) and
            (A.Angle=B.Angle) and
            (A.Balance=B.Balance) and
            (A.RadialX=B.RadialX) and
            (A.RadialY=B.RadialY)
         );
end;
}

function TPDFPatterns.GetCount: Integer;
begin
  Result := IList.Count;
end;

function TPDFPatterns.Get(Index: Integer): TPDFPattern;
begin
  Result := {$IFNDEF D18}TPDFPattern{$ENDIF}(IList.Items[Index]);
end;

{ TPDFPage }

procedure TPDFPage.SaveTo(const AStream: TStream);
begin
  WriteStringToStream(AStream, '<< /Length '+TeeStr(Size)+ ' >>'+CRLF);
  WriteStringToStream(AStream,'stream'+CRLF);
  AStream.CopyFrom(Self,0);
  WriteStringToStream(AStream,'endstream'+CRLF);
end;

{ TPDFDocument }

Constructor TPDFDocument.Create;
begin
  inherited Create;

  FFonts := TPDFFontList.Create;
  FImages := TPDFImageList.Create;
  FPatterns := TPDFPatterns.Create;

  OffsetList:=TStringList.Create;

  SetSize(FSize);
  NewPage;
end;

Destructor TPDFDocument.Destroy;
var t : Integer;
begin
  for t:=0 to High(FItems) do
      FItems[t].Free;

  FItems:=nil;

  OffsetList.Free;

  FPatterns.Free;
  FFonts.Free;
  FImages.Free;

  inherited;
end;

function TPDFDocument.NewPage:TPDFPage;
var L : Integer;
begin
  L:=Length(FItems);
  SetLength(FItems,L+1);

  result:=TPDFPage.Create;
  FItems[L]:=result;
end;

procedure TPDFDocument.SetOrientation(const Value:TPDFPageOrientation);
begin
  if FOrientation<>Value then
  begin
    FOrientation:=Value;
    SwapInteger(FWidth,FHeight);
  end;
end;

procedure TPDFDocument.SetSize(const Value:TPDFPageSize);

  procedure Init(const W,H:Single);
  const PixelsPerInch=96;
  begin
    // size in inches * pixels_per_inch
    FWidth:=Round(W*96);
    FHeight:=Round(H*96);
  end;

begin
  FSize:=Value;

  case FSize of
    psA3: Init(11.69,16.5);

    psDefault,
    psA4: Init(8.27,11.69);

    psA5: Init(5.83,8.27);
    psLetter: Init(8.5,11);
    psLegal: Init(8.5,14);
    psTabloid: Init(11,17);
  end;
end;

procedure TPDFDocument.SaveToStream(const AStream: TStream);
var t : Integer;
begin
  WriteHeader(AStream);
  WriteInfo(AStream);

  // write item (chart) canvas code (Contents for this page)

  for t:=0 to High(FItems) do
  if FItems[t].Size>0 then
  begin
    NewObject(AStream);
    FItems[t].SaveTo(AStream);
    EndObject(AStream);
  end;

  // TT fonts
  WriteTTFonts(AStream);

  // Additional images, if they exist
  WriteImages(AStream);

  // Patterns / Gradients
  WritePatterns(AStream);

  // Resources
  WriteResources(AStream);

  // Pages and page
  WritePages(AStream);
  WritePage(AStream);

  WriteCatalog(AStream);
  WriteXRef(AStream);
  WriteStringToStream(AStream,'%%EOF'+CRLF);
end;

function TPDFDocument.SaveFonts:Boolean;
begin
  result:=True;
end;

procedure TPDFDocument.SetHeight(const Value: Integer);
begin
  FHeight:=Value;
end;

procedure TPDFDocument.SetWidth(const Value: Integer);
begin
  FWidth:=Value;
end;

procedure TPDFDocument.WriteCatalog(const AStream: TStream);
begin
  CatalogNum:=NewObject(AStream);

  WriteStringToStream(AStream,'<< /Type /Catalog' + CRLF);
  WriteStringToStream(AStream, '/Pages ' + TeeStr(ParentNum) + ' 0 R'+ CRLF);
  WriteStringToStream(AStream,'>>'+CRLF);
  EndObject(AStream);
end;

procedure TPDFDocument.WriteHeader(const AStream: TStream);
begin
  WriteStringToStream(AStream,'%PDF-1.4'+CRLF);
end;

procedure TPDFDocument.WriteImages(const AStream: TStream);
var i: Integer;
begin
  with FImages do
  begin
    for i := 0 to Count -1 do
    begin
      Items[i].ObjectNumber := NewObject(AStream);

      WriteStringToStream(AStream,'<< /Type /XObject'+CRLF);
      WriteStringToStream(AStream,'/Subtype /Image'+CRLF);
      WriteStringToStream(AStream, '/Name /Im'+TeeStr(i)+CRLF);
      WriteStringToStream(AStream, '/Length '+TeeStr(Items[i].DataLength)+CRLF);
      WriteStringToStream(AStream, '/Width '+TeeStr(Items[i].Width)+CRLF);
      WriteStringToStream(AStream, '/Height '+TeeStr(Items[i].Height)+CRLF);
      WriteStringToStream(AStream,'/ColorSpace /DeviceRGB'+CRLF);
      WriteStringToStream(AStream,'/BitsPerComponent 8'+CRLF);

      if Items[i].ImageType = itJPEG then
         WriteStringToStream(AStream,'/Filter [/DCTDecode]'+CRLF);

      WriteStringToStream(AStream,'>>'+CRLF);
      WriteStringToStream(AStream,'stream'+CRLF);

      Items[i].WriteDataToStream(AStream);

      WriteStringToStream(AStream,'endstream'+CRLF);
      EndObject(AStream);
    end;
  end;
end;

function TPDFDocument.NewObject(const AStream: TStream):Integer;
begin
  Inc(IObjCount);

  OffsetList.Add(FormatIntToString(AStream.Size, 10));

  WriteStringToStream(AStream, TeeStr(IObjCount)+' 0 obj'+CRLF);

  result:=IObjCount;
end;

function TPDFDocument.GetItem(Index:Integer):TPDFPage;
begin
  result:=FItems[Index];
end;

procedure TPDFDocument.WriteInfo(const AStream: TStream);
var tmpSt : String;
begin
  NewObject(AStream);

  tmpSt := '<<'+CRLF+'/Creator (' + TeeMsg_Version +')'+CRLF+'/Producer (' + TeeMsg_Version+')'+CRLF+
    '/CreationDate (D:'+FormatDateTime('yyyymmddhhnnss',Now)+')'+CRLF+'/ModDate ()' + CRLF +
    '/Keywords(TeeChart,Chart,Steema)'+CRLF+'/Title (TeeChart Export)' + CRLF+'>>'+CRLF;

  WriteStringToStream(AStream, tmpSt);
  EndObject(AStream);
end;

procedure TPDFDocument.WritePage(const AStream: TStream);
var t,Num : Integer;
begin
  Num:=2;

  for t:=0 to High(FItems) do
  if FItems[t].Size>0 then
  begin
    NewObject(AStream);

    WriteStringToStream(AStream, '<< /Type /Page' + CRLF + '/Parent '+TeeStr(ParentNum)+ ' 0 R'+CRLF);
    WriteStringToStream(AStream, '/MediaBox [ 0 0 ' + TeeStr(FWidth) + ' ' + TeeStr(FHeight) + ' ]'+CRLF);

    WriteStringToStream(AStream, '/Contents '+IntToStr(Num)+' 0 R'+CRLF);
    Inc(Num);

    WriteStringToStream(AStream, '/Resources ' + TeeStr(ResourceNum)+' 0 R'+CRLF);
    WriteStringToStream(AStream, '>>'+CRLF);
    EndObject(AStream);
  end;
end;

procedure TPDFDocument.WritePages(const AStream: TStream);
var tmpSt : String;
    Num,
    t : Integer;
    PageIDs : String;
begin
  ParentNum := NewObject(AStream);

  PageIDs:='';
  Num:=0;

  for t:=0 to High(FItems) do
    if FItems[t].Size>0 then
    begin
      Inc(Num);
      PageIDs:=PageIDs+TeeStr(IObjCount+Num)+' 0 R'+CRLF;
    end;

  // Must be followed by WritePage call, otherwise object reference will not be correct
  tmpSt := '<< /Type /Pages' + CRLF + '/Kids [' + PageIDs+' ]'+CRLF+
           '/Count '+IntToStr(Num)+CRLF+'>>'+CRLF;

  WriteStringToStream(AStream,tmpSt);
  EndObject(AStream);
end;

procedure TPDFDocument.WriteResources(const AStream: TStream);
var i: Integer;
begin
  ResourceNum:=NewObject(AStream);

  WriteStringToStream(AStream,'<< /ProcSet [/PDF /Text /ImageB /ImageC]'+CRLF);

  if FPatterns.Count>0 then
  begin
    WriteStringToStream(AStream,'/Pattern <<'+CRLF);

    for i:=0 to FPatterns.Count-1 do
        WriteStringToStream(AStream,'/PA'+TeeStr(i) + ' ' +
                            TeeStr(FPatterns[i].ObjectNumber)+' 0 R'+CRLF);

    WriteStringToStream(AStream,'>>'+CRLF);
  end;

  if SaveFonts and (Fonts.Count>0) then
  begin
    WriteStringToStream(AStream,'/Font <<'+CRLF);

    for i := 0 to Fonts.Count -1 do
        WriteStringToStream(AStream,'/F'+TeeStr(i) + ' ' +
                            TeeStr(FFonts[i].ObjectNumber)+' 0 R'+CRLF);

    WriteStringToStream(AStream,'>>'+CRLF);
  end;

  if Images.Count>0 then
  begin
    WriteStringToStream(AStream,'/XObject << '+CRLF);

    for i := 0 to Images.Count -1 do
        WriteStringToStream(AStream,'/Im'+TeeStr(i) + ' ' +
                            TeeStr(Images[i].ObjectNumber)+' 0 R'+CRLF);

    WriteStringToStream(AStream,'>>'+CRLF);
  end;

  WriteStringToStream(AStream,'>>'+CRLF);
  EndObject(AStream);
end;

procedure TPDFDocument.WriteTrailer(const AStream: TStream);
begin
  WriteStringToStream(AStream,'trailer'+CRLF);
  WriteStringToStream(AStream,'<< /Size '+ TeeStr(IObjCount)+CRLF);
  WriteStringToStream(AStream,'/Root '+ TeeStr(CatalogNum)+ ' 0 R'+CRLF);
  WriteStringToStream(AStream,'/Info 1 0 R'+CRLF);
  WriteStringToStream(AStream,'>>'+CRLF);
  WriteStringToStream(AStream,'startxref'+CRLF);
  WriteStringToStream(AStream,TeeStr(XRefPos)+CRLF);
end;

procedure TPDFDocument.WritePatterns(const AStream: TStream);
var i : Integer;
    tmpType,
    tmpCoords,
    tmpSt : String;
    tmp : TPDFPattern;
begin
  for i := 0 to FPatterns.Count-1 do
  begin
    tmp:=FPatterns[i];
    tmp.ObjectNumber := NewObject(AStream);

    tmpSt:='<<'+CRLF+ {'/Matrix [1 0 0 -1 0 842]'+CRLF+} '/Type /Pattern'+CRLF+'/PatternType 2'+CRLF+'/Shading'+CRLF;

    if tmp.FGradient.Direction=gdRadial then
       tmpType:='3'
    else
       tmpType:='2';

    tmpSt:=tmpSt+'<< /ColorSpace /DeviceRGB /ShadingType '+tmpType+' /Extend [true true] /Function'+CRLF;

    // Pending: More than 2 colors, Balance, etc

    tmpSt:=tmpSt+'<< /N 1 /C1 ['+PDFColor(tmp.FGradient.StartColor)+
                 '] /Domain [0 1] /FunctionType 2 /C0 ['+
                                 PDFColor(tmp.FGradient.EndColor)+'] >>'+CRLF;

    if tmp.FGradient.Direction=gdRadial then
       tmpCoords:=tmp.RadialCoords
    else
       tmpCoords:=tmp.PDFRect;

    tmpSt:=tmpSt+ '/Coords ['+tmpCoords+']'+ CRLF+'>>'+CRLF;

    tmpSt:=tmpSt+'>>'+CRLF;

    WriteStringToStream(AStream,tmpSt);
    EndObject(AStream);
  end;
end;

procedure TPDFDocument.WriteTTFonts(const AStream: TStream);
var i : Integer;
    {$IFNDEF OSX}
    j : Integer;
    tmpSt : String;
    {$ENDIF}
begin
  if SaveFonts then
  With FFonts do
  for i := 0 to Count -1 do
  begin
    // font header
    Items[i].ObjectNumber := NewObject(AStream);

    WriteStringToStream(AStream,'<< /Type /Font'+CRLF);
    WriteStringToStream(AStream,'/Subtype /TrueType'+CRLF);
    WriteStringToStream(AStream,'/BaseFont /'+ Items[i].PDFName+CRLF);
    WriteStringToStream(AStream,'/Name /F'+TeeStr(i)+CRLF);

    if Items[i].FontData.LastChar>0 then
    begin
      WriteStringToStream(AStream,'/FirstChar '+ TeeStr(Items[i].FontData.FirstChar)+CRLF);
      WriteStringToStream(AStream,'/LastChar '+ TeeStr(Items[i].FontData.LastChar)+CRLF);
    end;

    WriteStringToStream(AStream,'/Encoding /WinAnsiEncoding'+CRLF);
    WriteStringToStream(AStream,'/FontDescriptor '+ TeeStr(IObjCount+1)+ ' 0 R'+CRLF);

    {$IFNDEF OSX}
    WriteStringToStream(AStream,'/Widths '+ TeeStr(IObjCount+2)+' 0 R'+CRLF);
    {$ENDIF}

    WriteStringToStream(AStream,'>>'+CRLF);
    EndObject(AStream);

    // Font descriptor
    NewObject(AStream);

    WriteStringToStream(AStream,'<< /Type /FontDescriptor'+CRLF);
    WriteStringToStream(AStream,'/FontName /'+ Items[i].PDFName+CRLF);
    WriteStringToStream(AStream,'/Flags 32'+CRLF);

    With Items[i].FontData do
    begin
      WriteStringToStream(AStream,'/FontBBox ['+
        ToStr(FontBBox.Left)+ ' ' +
        ToStr(FontBBox.Bottom)+ ' ' +
        ToStr(FontBBox.Right)+ ' ' +
        ToStr(FontBBox.Top)+ ']' + CRLF);

      WriteStringToStream(AStream,'/CapHeight ' + TeeStr(CapHeight)+CRLF);
      WriteStringToStream(AStream,'/Ascent ' + TeeStr(Ascent)+CRLF);
      WriteStringToStream(AStream,'/Descent ' + TeeStr(Descent)+CRLF);

      if MaxWidth>0 then
         WriteStringToStream(AStream,'/MaxWidth ' + TeeStr(MaxWidth)+CRLF);
         
      if AvgWidth>0 then
         WriteStringToStream(AStream,'/AvgWidth ' + TeeStr(AvgWidth)+CRLF);

      WriteStringToStream(AStream,'/ItalicAngle ' + ToStr(ItalicAngle)+CRLF);
      WriteStringToStream(AStream,'/StemV 0'+CRLF);
    end;

    WriteStringToStream(AStream,'>>'+CRLF);
    EndObject(AStream);

    {$IFNDEF OSX}
    // Font widths
    NewObject(AStream);

    WriteStringToStream(AStream,'['+CRLF);

    tmpSt := '';

    for j := Items[i].FontData.FirstChar to Items[i].FontData.LastChar do
    begin
      tmpSt := tmpSt + TeeStr(Items[i].FontData.CharWidths[j]) + ' ';

      if j mod 15 = 14 then
         tmpSt := tmpSt + CRLF;
    end;

    WriteStringToStream(AStream,tmpSt+CRLF);
    WriteStringToStream(AStream,']'+CRLF);
    EndObject(AStream);
    {$ENDIF}
  end;
end;

procedure TPDFDocument.WriteXRef(const AStream: TStream);
var i: Integer;
begin
  Inc(IObjCount);
  // no need to add xref to xref itself.

  XRefPos := AStream.Size;

  WriteStringToStream(AStream,'xref'+CRLF);
  WriteStringToStream(AStream,'0 '+TeeStr(IObjCount)+CRLF);
  WriteStringToStream(AStream,'0000000000 65535 f'+CRLF);

  for i := 0 to OffSetList.Count - 1  do
      WriteStringToStream(AStream,OffsetList.Strings[i]+' ' + FormatIntToString(0,5)+' n'+ CRLF);

  WriteTrailer(AStream);
end;

{ TPDFEntry }

procedure TPDFEntry.SetObjectNumber(const Value: Integer);
begin
  FObjectNumber:=Value;
end;

{ TPDFPattern }

Constructor TPDFPattern.Create(const AGradient:TTeeGradient; const ARect:TRect);
begin
  inherited Create;
  FGradient:=TTeeGradient.Create(nil);
  FGradient.Assign(AGradient);
  IRect:=ARect;
end;

Destructor TPDFPattern.Destroy;
begin
  FGradient.Free;
  inherited;
end;

function TPDFPattern.RadialCoords:String;
var xc,yc : String;
begin
  xc:=ToStr((IRect.Left+IRect.Right)*0.5);
  yc:=ToStr((IRect.Top+IRect.Bottom)*0.5);

  result:=xc+' '+yc+' 0 '+xc+' '+yc+' '+
          ToFloat(0.5*TeeHypot(IRect.Right-IRect.Left,IRect.Bottom-IRect.Top));
end;

function TPDFPattern.PDFRect:String;
var left,
    right,
    top,
    bottom : String;
begin
  left:=ToStr(IRect.Left);
  top:=ToStr(IRect.Top);
  right:=ToStr(IRect.Right);
  bottom:=ToStr(IRect.Bottom);

  case FGradient.Direction of
      gdLeftRight: result:=left+' '+top+' '+right+' '+top;
      gdRightLeft: result:=right+' '+top+' '+left+' '+top;
      gdBottomTop: result:=left+' '+bottom+' '+left+' '+top;
  gdDiagonalDown,
    gdFromTopLeft: result:=left+' '+top+' '+right+' '+bottom;
    gdDiagonalUp,
 gdFromBottomLeft: result:=left+' '+bottom+' '+right+' '+top;
 else
   result:=left+' '+top+' '+left+' '+bottom; // Top -> Bottom
 end;
end;

{ TPDFImageList }

Constructor TPDFImageList.Create;
begin
  inherited;
  IList := TList{$IFDEF D18}<TPDFImageListEntry>{$ENDIF}.Create;
end;

Destructor TPDFImageList.Destroy;
{$IFNDEF AUTOREFCOUNT}
var i: Integer;
{$ENDIF}
begin
  {$IFNDEF AUTOREFCOUNT}
  for i := 0 to IList.Count - 1 do
      {$IFNDEF D18}TPDFImageListEntry{$ENDIF}(IList.Items[i]).Free;
  {$ENDIF}

  IList.Free;

  inherited Destroy;
end;

function TPDFImageList.Select(const AGraphic: TGraphic): integer;

  function Find: Integer;
  var i: Integer;
  begin
    for i := 0 to Count-1 do
      if EqualImages(AGraphic,Items[i].FGraphic) then
      begin
        Result := i;
        Exit;
      end;

    Result := -1;
  end;

begin
  result := Find;

  if result = -1 then
     result := IList.Add(TPDFImageListEntry.Create(AGraphic));
end;

function TPDFImageList.EqualImages(const i1, i2: TGraphic): Boolean;
var m1,m2 : TMemoryStream;
begin
  if i1=i2 then
  begin
    result:=True;
    Exit;
  end;

  result:=(i1.Width=i2.Width) and (i1.Height=i2.Height) and
          (not i1.{$IFDEF FMX}IsEmpty{$ELSE}Empty{$ENDIF});

  if result then
  begin
    m1:=TMemoryStream.Create;
    try
      i1.SaveToStream(m1);

      m2:=TMemoryStream.Create;
      try
        i2.SaveToStream(m2);

        result:=(m1.Size=m2.Size) and CompareMem(m1.Memory,m2.Memory,m1.Size);
      finally
        m2.Free;
      end;
    finally
      m1.Free;
    end;
  end;
end;

function TPDFImageList.GetCount: Integer;
begin
  Result := IList.Count;
end;

function TPDFImageList.Get(Index: Integer): TPDFImageListEntry;
begin
  Result := TPDFImageListEntry(IList.Items[Index]);
end;

function CloneGraphic(const AGraphic: TGraphic):TGraphic;
begin
  {$IFDEF FMX}
  result:=TGraphic.Create(0,0);
  {$ELSE}
  result:=TGraphicClass(AGraphic.ClassType).Create;
  {$ENDIF}

  result.Assign(AGraphic);
end;

{ TPDFImageListEntry }

Constructor TPDFImageListEntry.Create(const AGraphic: TGraphic);
begin
  inherited Create;

  FGraphic := CloneGraphic(AGraphic);
  DefineImageData;
end;

Destructor TPDFImageListEntry.Destroy;
begin
  FGraphic.Free;
  inherited;
end;

procedure TPDFImageListEntry.DefineImageData;
begin
  FWidth := FGraphic.Width;
  FHeight := FGraphic.Height;
end;

function TPDFImageListEntry.GetDataLength: Integer;
var ms : TMemoryStream;
begin
  ms := TMemoryStream.Create;
  try
    FGraphic.SaveToStream(ms);
    Result := ms.Size;
  finally
    ms.Free;
  end;
end;

function TPDFImageListEntry.GetImageType: TImageType;
begin
  {$IFNDEF FMX}
  if (FGraphic is TJPEGImage) then Result := itJPEG
  else
  {$ENDIF}
  if FGraphic is TBitmap then
     Result := itBitmap
  else
     Result := itUnknown;
end;

procedure TPDFImageListEntry.WriteDataToStream(const AStream: TStream);

  procedure WriteBitmap(const Bitmap:TBitmap);
  var x,y   : Integer;

      {$IFDEF FMX}
      {$IFDEF D17}
      tmpData : TBitmapData;
      {$ENDIF}
      {$ELSE}
      Lines : {$IFDEF FMX}
              TRGBAArray
              {$ELSE}
              {$IFDEF LCL}
              TRGBAArray
              {$ELSE}
              TRGBArray
              {$ENDIF}
              {$ENDIF};
      {$ENDIF}

      // Memory stream used as cache, to speed up writing many one-byte color components.
      mem : TMemoryStream;
  begin
    {$IFDEF FMX}
    {$IFDEF D17}
    if Bitmap.Map(TMapAccess.{$IFDEF D20}Read{$ELSE}maRead{$ENDIF}, tmpData) then
    try
    {$ENDIF}
      mem:=TMemoryStream.Create;
      try
        for y := 0 to Height -1 do
            for x := 0 to Width -1 do
              {$IFDEF D17}
              with TAlphaColorRec(tmpData.GetPixel(x,y)) do
              {$ELSE}
              with TAlphaColorRec(Bitmap.Pixels[x,y]) do
              {$ENDIF}
              begin
                mem.Write(R,1);
                mem.Write(G,1);
                mem.Write(B,1);
              end;

      finally
        mem.Position:=0;
        AStream.CopyFrom(mem,mem.Size);
        mem.Free;
      end;

    {$IFDEF D17}
    finally
      Bitmap.UnMap(tmpData);
    end;
    {$ENDIF}

    {$ELSE}
    TeeCalcLines(Lines,Bitmap);
    try
      mem:=TMemoryStream.Create;
      try
        for y := 0 to Height -1 do
            for x := 0 to Width -1 do
                with Lines[y,x] do
                begin
                  mem.Write(Red,1);
                  mem.Write(Green,1);
                  mem.Write(Blue,1);
                end;
      finally
        mem.Position:=0;
        AStream.CopyFrom(mem,mem.Size);
        mem.Free;
      end;
    finally
      Lines:=nil;
    end;
    {$ENDIF}
  end;

var tmp : TBitmap;
begin
  {$IFNDEF FMX}
  if FGraphic is TJpegImage then
     (FGraphic as TJpegImage).SaveToStream(AStream)
  else
  {$ENDIF}
  if FGraphic is TBitmap then
     WriteBitmap(FGraphic as TBitmap)
  else
  begin
    tmp:=TBitmap.Create{$IFNDEF D19}{$IFDEF FMX}(0,0){$ENDIF}{$ENDIF};
    try
      tmp.Assign(FGraphic);
      WriteBitmap(tmp);
    finally
      tmp.Free;
    end;
  end;

  WriteStringToStream(AStream,CRLF);
end;

initialization
  {$IFNDEF D7}
  DecimalSeparator:='.';
  {$ELSE}

  {$IFDEF D15}
  PDFFormatSettings:=TFormatSettings.Create({$IFDEF D16}TLanguages.UserDefaultLocale{$ELSE}GetThreadLocale{$ENDIF});
  {$ELSE}
  GetLocaleFormatSettings(GetThreadLocale,PDFFormatSettings);
  {$ENDIF}

  PDFFormatSettings.DecimalSeparator:='.';
  {$ENDIF}

  {$IFDEF FMX}
  TTeeExportFormats.RegisterFormat(TPDFExportFormat);
  {$ELSE}
  RegisterTeeExportFormat(TPDFExportFormat);
  {$ENDIF}
finalization
  {$IFDEF FMX}
  TTeeExportFormats.UnRegisterFormat(TPDFExportFormat);
  {$ELSE}
  UnRegisterTeeExportFormat(TPDFExportFormat);
  {$ENDIF}
end.

