teepdfcanvas.pas

来自「Delphi TeeChartPro.6.01的源代码」· PAS 代码 · 共 1,268 行 · 第 1/3 页

{********************************************}
{ TeeChart Pro PDF Canvas and Exporting      }
{ Copyright (c) 2002-2003 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,
     {$ENDIF}
     TeCanvas, TeeProcs, TeeExport, Math;

type
  {$IFDEF LINUX}
  TOutlineTextMetric=packed record
  end;
  {$ENDIF}

  PFontEntry = ^TFontEntry;
  TFontEntry = record
    UniqueName: String;
    Name: String;
    ObjPos: Integer;
    FontData: TOutlineTextMetric;
    Font: TFont;
    end;

type
  TPDFCanvas = class(TTeeCanvas3D)
  private
    { Private declarations }
     FBackColor : TColor;
     FBackMode : TCanvasBackMode;
     IWidth, IHeight: Integer;
     IObjCount: Integer;
     ObjectOffset : Integer;
     IStartSize,IEndSize: Integer;
     tStream, sStream, PDF: TMemoryStream;
     fStream: TMemoryStream;
     ObjectOffsetList: TStringList;
     FontList: TList;
     FontEntry: PFontEntry;
     FX,FY: double;
     IParentNum, ICatalogNum,
     IResourceNum, IOutlineNum: Integer;
     IClipCalled: boolean;
     tmpSt: String;
     procedure InternalDrawArc(X1, Y1, X2, Y2, X3, Y3, X4, Y4: Integer; MoveTo0: boolean; DrawPie: boolean);
     Function InternalBezCurve(ax1,ay1,ax2,ay2,ax3,ay3: double): String;
     Procedure AddString(var Stream: TMemoryStream; S:String);
     Procedure AddToOffset(Offset: Integer);
     Procedure InternalRect(Const Rect:TRect; UsePen,IsRound:Boolean);
     Function PointToStr(X, Y: double):String;
     Function TheBounds:String;
     Function SetPenStyle(PenStyle: TPenStyle): String;
     Procedure TranslateVertCoord(var Y: double);
     Function PenProperties(Pen: TPen): String;
     Function BrushProperties(Brush: TBrush): String;
     Function FontProperties(Font: TTeeFont; var FontIndex: Integer): String;
     Procedure DefineArray;
     Procedure DefineHeader;
     Procedure DefineCatalog;
     Procedure DefineXRef;
     Procedure DefineOutline;
     Procedure DefinePages;
     Procedure DefinePage;
     Procedure StartStream;
     Procedure EndStream;
     function SelectFont(Font: TFont): Integer;
     procedure WriteTrueTypeFonts;
     function ConstructFontName(Font: TFont): String;
     function TextToPDFText(AText: String): String;
  protected
    { Protected declarations }
     Procedure PolygonFour; override;
  public

    { Public declarations }
    Constructor Create(APDF: TMemoryStream);
    Destructor Destroy; override;

    Function InitWindow( DestCanvas:TCanvas;
                         A3DOptions:TView3DOptions;
                         ABackColor:TColor;
                         Is3D:Boolean;
                         Const UserRect:TRect):TRect; override;
    { 2d }
    Function TextWidth(Const St:String):Integer; override;
    Function TextHeight(Const St:String):Integer; override;
    procedure SetPixel(X, Y: Integer; Value: TColor); override;

    { 3d }
    procedure SetPixel3D(X,Y,Z:Integer; Value: TColor); override;
    Procedure SetBackMode(Mode:TCanvasBackMode); override;
    Function GetMonochrome:Boolean; override;
    Procedure SetMonochrome(Value:Boolean); override;
    Procedure SetBackColor(Color:TColor); override;
    Function GetBackMode:TCanvasBackMode; override;
    Function GetBackColor:TColor; override;
    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 Frame3D( var Rect: TRect; TopColor,BottomColor: TColor;
                       Width: Integer); 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:Integer); override;
    procedure RotateLabel3D(x,y,z:Integer;
                            Const St:String; RotDegree:Integer); 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;
  end;

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


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




implementation

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

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

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

{ TPDFCanvas }
Constructor TPDFCanvas.Create(APDF:TMemoryStream);
begin
  inherited Create;
  FBackMode := cbmTransparent;
  UseBuffer:=False;
  tStream:=TMemoryStream.Create;
  sStream:=TMemoryStream.Create;
  fStream:=TMemoryStream.Create;
  PDF := APDF;
  ObjectOffsetList := TStringList.Create;
  FontList := TList.Create;
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';
end;


Procedure TPDFCanvas.ShowImage(DestCanvas,DefaultCanvas:TCanvas; Const UserRect:TRect);
begin
  EndStream;
  WriteTrueTypeFonts;
  DefineOutline;
  DefinePages;
  DefineArray;
  DefinePage;
  DefineCatalog;
  DefineXRef;
  { ... that's about it }
  AddString(PDF,'%%EOF');
end;

Procedure TPDFCanvas.AddString(var Stream: TMemoryStream; S:String);
begin
  S := S+ #13 + #10;
  Stream.Write(S[1],Length(S));
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
  AddString(sStream,PenProperties(Pen));
  AddString(sStream,PointToStr(FX,FY)+' m');
  AddString(sStream,PointToStr(X,Y)+' l S');
  FX := X;
  FY := Y;
end;

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

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

procedure TPDFCanvas.UnClipRectangle;
begin
  if IClipCalled then
  begin
    AddString(sStream,'Q');
    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;
begin
  result:=False;
end;

Procedure TPDFCanvas.SetMonochrome(Value:Boolean);
begin
  { Not implemented }
end;

procedure TPDFCanvas.StretchDraw(const Rect: TRect; Graphic: TGraphic);
begin
  { Not implemented }
end;

procedure TPDFCanvas.Draw(X, Y: Integer; Graphic: TGraphic);
begin
  { Not implemented }
end;

Function TPDFCanvas.TheBounds:String;
begin
  IWidth := Bounds.Right - Bounds.Left;
  IHeight := Bounds.Bottom - Bounds.Top;
end;

Function TPDFCanvas.PointToStr(X,Y:double):String;
begin
  TranslateVertCoord(Y);
  tmpSt := FormatFloat('0.000',X)+' '+FormatFloat('0.000',Y);
  FixSeparator(tmpSt);
  Result := tmpSt;
end;

Procedure TPDFCanvas.GradientFill( Const Rect:TRect;
                                  StartColor,EndColor:TColor;
                                  Direction:TGradientDirection;
                                  Balance:Integer=50);
begin
  { Not implemented }
end;

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

Procedure TPDFCanvas.InternalRect(Const Rect:TRect; UsePen, IsRound:Boolean);
var tmpB,tmpT: double;
begin
  if (Brush.Style<>bsClear) or (UsePen and (Pen.Style<>psClear)) then
  begin
    AddString(sStream,PenProperties(Pen));
    AddString(sStream,BrushProperties(Brush));
    tmpB := Rect.Bottom;
    tmpT := Rect.Top;
    TranslateVertCoord(tmpB);
    TranslateVertCoord(tmpT);
    tmpSt := FormatFloat('0.000',Rect.Left)+' '+ FormatFloat('0.000',tmpB)+ ' ' +
            FormatFloat('0.000',Rect.Right-Rect.Left)+' ' + FormatFloat('0.000',tmpT-tmpB)+' re';
    FixSeparator(tmpSt);
    AddString(sStream,tmpSt);

    if (Brush.Style<>bsClear) then
    begin
      if (Pen.Style<>psClear) then AddString(sStream,'B')
      else AddString(sStream,'f');
    end else AddString(sStream,'S');
  end;
end;

procedure TPDFCanvas.Frame3D( var Rect: TRect; TopColor, BottomColor: TColor;
                             Width: Integer);
begin
  Brush.Style:=bsClear;
  {$IFDEF D5}
  Rectangle(Rect);
  {$ELSE}
  with Rect do Rectangle(Left,Top,Right,Bottom);
  {$ENDIF}
  InflateRect(Rect,-Width,-Width);
end;

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

procedure TPDFCanvas.EllipseWithZ(X1, Y1, X2, Y2, Z: Integer);
var ra,rb,xc,yc: double;
    St: String;
const Bez = 0.552;
begin
  if (Brush.Style<>bsClear) or (Pen.Style<>psClear) then
  begin
    AddString(sStream,BrushProperties(Brush));
    AddString(sStream,PenProperties(Pen));
    Calc3DPos(X1,Y1,Z);
    Calc3DPos(X2,Y2,Z);
    ra := (X2 - X1)*0.5;
    rb := (Y2 - Y1)*0.5;
    xc := (X2 + X1)*0.5;
    yc := (Y2 + Y1)*0.5;
    TranslateVertCoord(yc);
    St := FormatFloat('0.000',xc+ra)+ ' ' + FormatFloat('0.000',yc)+ ' m'+#13+#10;
    { 4-arc version of drawing circle/ellipse }
    { Q1, Q2, Q3 and Q4 cp}
    St := St + InternalBezCurve(xc+ra, yc+Bez*rb, xc+Bez*ra, yc+rb, xc, yc+rb)+#13+#10;
    St := St + InternalBezCurve(xc-Bez*ra, yc+rb, xc-ra, yc+Bez*rb, xc-ra, yc)+#13+#10;
    St := St + InternalBezCurve(xc-ra, yc-Bez*rb, xc-Bez*ra, yc-rb, xc, yc-rb)+#13+#10;
    St := St + InternalBezCurve(xc+Bez*ra, yc-rb, xc+ra, yc-Bez*rb, xc+ra, yc)+#13+#10;
    FixSeparator(St);
    AddString(sStream,St);