teepdfcanvas.pas

TeeChart7Source 控件

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

interface

uses {$IFNDEF LINUX}
     Windows,
     {$ENDIF}
     Classes,
     {$IFDEF CLX}
     QGraphics, QForms, Types,
     {$ELSE}
     Graphics, Forms,
     {$IFNDEF CLR}
     Jpeg,
     {$ENDIF}
     {$ENDIF}
     TeCanvas, TeeProcs, TeeExport, Math;

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

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

  TImageType = (itJPEG, itBitmap, itUnknown);

  TTeePDFImageListEntry = class(TObject)
  private
    FObjectNumber: Integer;
    FHeight: Integer;
    FWidth: Integer;
    FGraphic: TGraphic;
    procedure DefineImageData;
    procedure SetObjectNumber(const Value: Integer);
    function GetImageType: TImageType;
    function GetDataLength: Integer;
  public
    property ObjectNumber: Integer read FObjectNumber write SetObjectNumber;
    property Width: Integer read FWidth;
    property Height: Integer read FHeight;
    property DataLength: Integer read GetDataLength;
    property ImageType: TImageType read GetImageType;
    procedure WriteDataToStream(AStream: TStream);
    Constructor Create(AGraphic: TGraphic);
  end;

  TTeePDFImageList = class(TObject)
  private
    IImageList: TList;
    function EqualImages(i1,i2: TGraphic): boolean;
    function GetCount: Integer;
    function GetImageEntry(Index: Integer): TTeePDFImageListEntry;
  public
    property Items[Index: Integer]: TTeePDFImageListEntry read GetImageEntry;
    property ItemsCount: Integer read GetCount;
    function AddItem(AGraphic: TGraphic): Integer;
    function Find(AGraphic: TGraphic): Integer;    
    Constructor Create;
    Destructor Destroy; override;
  end;


  TTeePDFFontListEntry = class (TObject)
  private
    FFontData: TFontData;
    FPDFName: String;
    FObjectNumber: Integer;
    procedure DefineFontData(AFont: TFont);
    procedure SetObjectNumber(const Value: Integer);
  public
    property PDFName: String read FPDFName;
    property ObjectNumber: Integer read FObjectNumber write SetObjectNumber;
    property FontData: TFontData read FFontData;
    Constructor Create(AFont: TFont);
  end;

  TTeePDFFontList = class (TObject)
  private
    IFontList: TList;
    function GetFontEntry(Index: Integer): TTeePDFFontListEntry;
    function GetCount: Integer;
  public
    property Items[Index: Integer]: TTeePDFFontListEntry read GetFontEntry;
    property ItemsCount: Integer read GetCount;

    function AddItem(AFont: TFont; AHandle: TTeeCanvasHandle): Integer;
    function Find(AFont: TFont): Integer;
    Constructor Create;
    Destructor Destroy; override;
  end;

  TPDFChartObject = class(TObject)
  private
    FContents: TStream;
    FFontArray: TTeePDFFontList;
    FImageArray: TTeePDFImageList;
    function GetLength: Integer;
  public
    property Contents: TStream read FContents;
    property Length: Integer read GetLength;
    property FontArray: TTeePDFFontList read FFontArray;
    property ImageArray: TTeePDFImageList read FImageArray;
    procedure SaveToStream(AStream: TStream);
    Constructor Create;
    Destructor Destroy; override;
  end;

  TTeePDFPage = class(TObject)
  private
    IObjCount, CatalogNum, ParentNum, ResourceNum: Integer;
    tmpSt: String;
    OffsetList: TStringList;
    FChartObject: TPDFChartObject;
    XRefPos: Integer;
    FPageHeight: Integer;
    FPageWidth: Integer;
    procedure AddToOffset(Offset: Integer);
    procedure WriteHeader(AStream: TStream);
    procedure WriteInfo(AStream: TStream);
    procedure WriteTTFonts(AStream: TStream);
    procedure WriteImages(AStream: TStream);
    procedure WriteResources(AStream: TStream);
    procedure WritePages(AStream: TStream);
    procedure WritePage(AStream: TStream);
    procedure WriteCatalog(AStream: TStream);
    procedure WriteXRef(AStream: TStream);
    procedure WriteTrailer(AStream: TStream);
    procedure SetPageHeight(const Value: Integer);
    procedure SetPageWidth(const Value: Integer);
  public
    property PageWidth: Integer read FPageWidth write SetPageWidth;
    property PageHeight: Integer read FPageHeight write SetPageHeight;
    property ChartObject: TPDFChartObject read FChartObject;
    procedure SaveToStream(AStream: TStream);
    Constructor Create;
    Destructor Destroy; override;
  end;

  TPDFCanvas = class(TTeeCanvas3D)
  private
    { Private declarations }
    FBackColor : TColor;
    FBackMode : TCanvasBackMode;
    IWidth,
    IHeight: Integer;
    FX,
    FY: Double;
    IClipCalled: boolean;
    tmpSt: String;
    FEmbeddedFonts: boolean;
    FCStream: TStream;
    FContents: TPDFChartObject;

    Function BrushProperties(Brush: TBrush): String;
    Function FontProperties(Font: TTeeFont; var FontIndex: Integer): String;
    Function InternalBezCurve(ax1,ay1,ax2,ay2,ax3,ay3: double): String;
    procedure InternalDrawArc(X1, Y1, X2, Y2, X3, Y3, X4, Y4: Integer; MoveTo0: boolean; DrawPie: boolean);
    Procedure InternalDrawImage(sx, sy, tx,ty: double; ImageIndex: Integer);
    Procedure InternalRect(Const Rect:TRect; UsePen,IsRound:Boolean);
    Function PenProperties(Pen: TPen): String;
    Function PointToStr(X, Y: double):String;
    Function SelectFont(Font: TFont): Integer;
    Function SelectImage(Graphic: TGraphic): integer;
    procedure SetEmbeddedFonts(const Value: boolean);
    Function SetPenStyle(PenStyle: TPenStyle): String;
    function TextToPDFText(AText: String): String;
    Function TheBounds:String;
    Procedure TranslateVertCoord(var Y: double);
    Function ValidGraphic(Graphic: TGraphic):Boolean;
  protected
    { Protected declarations }

    Function GetBackColor:TColor; override;
    Function GetBackMode:TCanvasBackMode; override;
    Function GetMonochrome:Boolean; override;
    Procedure PolygonFour; override;
    Procedure SetBackColor(Color:TColor); override;
    Procedure SetBackMode(Mode:TCanvasBackMode); override;
    procedure SetPixel(X, Y: Integer; Value: TColor); override;
    procedure SetPixel3D(X,Y,Z:Integer; Value: TColor); override;
    Procedure SetMonochrome(Value:Boolean); override;
  public
    { Public declarations }

    Constructor Create(AChartObject: TPDFChartObject);
    Destructor Destroy; override;

    Function InitWindow( DestCanvas:TCanvas;
                         A3DOptions:TView3DOptions;
                         ABackColor:TColor;
                         Is3D:Boolean;
                         Const UserRect:TRect):TRect; override;
    procedure WriteToStream(AStream: TStream);

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

    { 3d }
    procedure Arc(X1, Y1, X2, Y2, X3, Y3, X4, Y4: Integer); override;
    procedure Draw(X, Y: Integer; Graphic: TGraphic); override;
    procedure FillRect(const Rect: TRect); override;
    procedure Ellipse(X1, Y1, X2, Y2: Integer); override;
    procedure LineTo(X,Y:Integer); override;
    procedure MoveTo(X,Y:Integer); override;
    procedure Pie(X1, Y1, X2, Y2, X3, Y3, X4, Y4: Integer); override;
    procedure Rectangle(X0,Y0,X1,Y1:Integer); override;
    procedure RoundRect(X1, Y1, X2, Y2, X3, Y3: Integer); override;
    procedure StretchDraw(const Rect: TRect; Graphic: TGraphic); override;
    Procedure TextOut(X,Y:Integer; const Text:String); override;
    Procedure DoHorizLine(X0,X1,Y:Integer); override;
    Procedure DoVertLine(X,Y0,Y1:Integer); override;

    procedure ClipRectangle(Const Rect:TRect); override;
    procedure ClipCube(Const Rect:TRect; MinZ,MaxZ:Integer); override;
    procedure UnClipRectangle; override;

    Procedure GradientFill( Const Rect:TRect;
                            StartColor,EndColor:TColor;
                            Direction:TGradientDirection;
                            Balance:Integer=50); override;
    procedure RotateLabel(x,y:Integer; Const St:String; RotDegree:Double); override;
    procedure RotateLabel3D(x,y,z:Integer;
                            Const St:String; RotDegree:Double); override;
    Procedure Line(X0,Y0,X1,Y1:Integer); override;
    Procedure Polygon(const Points: array of TPoint); override;

    { 3d }
    Procedure ShowImage(DestCanvas,DefaultCanvas:TCanvas; Const UserRect:TRect); override;
    procedure EllipseWithZ(X1, Y1, X2, Y2, Z:Integer); override;
    Procedure HorizLine3D(Left,Right,Y,Z:Integer); override;
    procedure LineTo3D(X,Y,Z:Integer); override;
    Procedure LineWithZ(X0,Y0,X1,Y1,Z:Integer); override;
    procedure MoveTo3D(X,Y,Z:Integer); override;
    Procedure TextOut3D(X,Y,Z:Integer; const Text:String); override;
    Procedure VertLine3D(X,Top,Bottom,Z:Integer); override;
    Procedure ZLine3D(X,Y,Z0,Z1:Integer); override;
    property EmbeddedFonts: boolean read FEmbeddedFonts write SetEmbeddedFonts default False;
  end;

  TPDFExportFormat=class(TTeeExportFormat)
  protected
    Procedure DoCopyToClipboard; override;
  public
    function Description:String; override;
    function FileExtension:String; override;
    function FileFilter:String; override;
    Function PDFPage: TTeePDFPage;
    function ChartObject: TPDFChartObject;
    Function Options(Check:Boolean=True):TForm; override;
    Procedure SaveToStream(Stream:TStream); override;
  end;

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

  procedure TeeSaveToPDFFile( APanel:TCustomTeePanel; const FileName: WideString;
                            AWidth:Integer=0;
                            AHeight: Integer=0);

implementation

Uses {$IFDEF CLX}
     QClipbrd,
     {$ELSE}
     Clipbrd,
     {$ENDIF}
     TeeConst, SysUtils;

Const CRLF = #13+#10;

function FormatIntToString(Value: integer; Len: integer): string;
var S: string;
  i, j: integer;
begin
  Result := '';
  if Value < 0 then S := '0' else S := IntToStr(Value);
  i := Len - Length(S);
  for j := 0 to i - 1 do Result := Result + '0';
  Result := Result + S;
end;

procedure WriteStringToStream(Stream: TStream; S:String);
begin
  Stream.Write(S[1],Length(S));
end;

function PDFFontName(AFont: TFont): String;
var tmpSt: String;
begin
  tmpSt := AFont.Name;
  if (fsBold in AFont.Style) then tmpSt := tmpSt+',Bold';
  if (fsItalic in AFont.Style) then tmpSt := tmpSt+',Italic';
  while Pos(' ', tmpSt) > 0  do
    Delete(tmpSt,Pos(' ',tmpSt),1);
  Result := tmpSt;
end;

{ Convert , to . }
procedure FixSeparator(var St: String);
begin
  while Pos(',', St) > 0 do
    St[Pos(',', St)] := '.';
end;

Function PDFColor(AColor:TColor):String;
const tmp=1/255.0;
begin
  AColor:=ColorToRGB(AColor);
  Result:= FormatFloat('0.00',GetRVAlue(AColor)*tmp) + ' ' +
           FormatFloat('0.00',GetGVAlue(AColor)*tmp) + ' ' +
           FormatFloat('0.00',GetBVAlue(AColor)*tmp);
  FixSeparator(Result);
end;

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

Procedure TPDFCanvas.ShowImage(DestCanvas,DefaultCanvas:TCanvas; Const UserRect:TRect);
begin
  //
end;

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

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

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

procedure TPDFCanvas.ClipRectangle(Const Rect:TRect);
var tmpB, tmpT: double;
begin
  IClipCalled := True;
  WriteStringToStream(FCStream,'q'+CRLF);
  tmpB := Rect.Bottom;
  tmpT := Rect.Top;
  TranslateVertCoord(tmpB);
  TranslateVertCoord(tmpT);
  tmpSt := tmpSt+FormatFloat('0.00',Rect.Left)+' '+ FormatFloat('0.00',tmpB)+ ' ' +
          FormatFloat('0.00',Rect.Right-Rect.Left)+' ' + FormatFloat('0.00',tmpT-tmpB)+' re W n'+CRLF;
  FixSeparator(tmpSt);
  WriteStringToStream(FCStream,tmpSt);
end;

procedure TPDFCanvas.ClipCube(Const Rect:TRect; MinZ,MaxZ:Integer);
begin
  { Not implemented }
end;

procedure TPDFCanvas.UnClipRectangle;
begin
  if IClipCalled then
  begin
    WriteStringToStream(FCStream,'Q'+CRLF);
    IClipCalled := false;
  end;
end;

function TPDFCanvas.GetBackColor:TColor;
begin
  result:=FBackColor;
end;

procedure TPDFCanvas.SetBackColor(Color:TColor);
begin
  FBackColor:=Color;
end;

procedure TPDFCanvas.SetBackMode(Mode:TCanvasBackMode);
begin
  FBackMode:=Mode;
end;

Function TPDFCanvas.GetMonochrome:Boolean;