teepscanvas.pas

TeeChart7Source 控件

{********************************************}
{ TeeChart Pro PS Canvas and Exporting       }
{ Copyright (c) 2002-2004 by Marjan Slatinek }
{ and David Berneda                          }
{ All Rights Reserved                        }
{********************************************}
unit TeePSCanvas;
{$I TeeDefs.inc}

interface

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

type
  TEPSCanvas = class(TTeeCanvas3D)
  private
    { Private declarations }
    tmpStr: String;
    FStrings     : TStrings;
    FBackColor : TColor;
    FBackMode : TCanvasBackMode;
    FTextAlign : TCanvasTextAlign;
    IWidth, IHeight: Integer;
    FX, FY: Integer;

    Procedure Add(Const S:String);
    Function BrushProperties(Brush: TBrush): String;
    Procedure InternalRect(Const Rect:TRect; UsePen,IsRound:Boolean);
    Procedure InternalArc(X1, Y1, X2, Y2, X3, Y3, X4, Y4: Integer; Pie: Boolean);
    Function PenProperties(Pen: TPen): String;
    Function PointToStr(X,Y:Integer):String;
    Function SetPenStyle(PenStyle: TPenStyle): String;
    Function TextToPSText(AText:String): String;
    Function TheBounds:String;
    Procedure TranslateVertCoord(var Y: Integer);
  protected
    { Protected declarations }
    Procedure PolygonFour; override;

    { 2d }
    procedure SetPixel(X, Y: Integer; Value: TColor); override;
    Function GetTextAlign:TCanvasTextAlign; 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 SetTextAlign(Align:TCanvasTextAlign); override;
  public
    { Public declarations }
    Constructor Create(AStrings:TStrings);

    Function InitWindow( DestCanvas:TCanvas;
                         A3DOptions:TView3DOptions;
                         ABackColor:TColor;
                         Is3D:Boolean;
                         Const UserRect:TRect):TRect; 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 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;
  end;

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


procedure TeeSaveToPSFile( 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;

procedure StringToPSString(var St: String);
begin

end;

Function PSColor(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) + ' rgb';
  FixSeparator(Result);
end;

{ TPSCanvas }
Constructor TEPSCanvas.Create(AStrings:TStrings);
begin
  inherited Create;
  FBackMode := cbmTransparent;
  FStrings:=AStrings;
  UseBuffer:=False;
end;

Procedure TEPSCanvas.ShowImage(DestCanvas,DefaultCanvas:TCanvas; Const UserRect:TRect);
begin
  Add('gr');
end;

Procedure TEPSCanvas.Add(Const S:String);
begin
  FStrings.Add(S);
end;


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

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

procedure TEPSCanvas.LineTo(X, Y: Integer);
begin
  tmpStr := 'gs ' + PenProperties(Pen) + ' ' +
            PointToStr(FX,FY)+' m '+
            PointToStr(X,Y)+' l st gr ';
  Add(tmpStr);
  FX := X;
  FY := Y;
end;

procedure TEPSCanvas.ClipRectangle(Const Rect:TRect);
var tmpB: Integer;
begin
  tmpB := Rect.Bottom;
  TranslateVertCoord(tmpB);
  tmpStr :='clipsave ' +
            IntToStr(Rect.Left) + ' ' + IntToStr(tmpB) + ' ' +
            IntToStr(Rect.Right - Rect.Left) + ' ' +
            IntToStr(Rect.Bottom - Rect.Top) + ' rectclip';
  Add(tmpStr);
end;

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

procedure TEPSCanvas.UnClipRectangle;
begin
  Add('cliprestore');
end;

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

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

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

Function TEPSCanvas.GetMonochrome:Boolean;
begin
  result:=False;
end;

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

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

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

Function TEPSCanvas.TheBounds:String;
begin
  IWidth := Bounds.Right - Bounds.Left;
  IHeight := Bounds.Bottom - Bounds.Top;
  Result:='%%BoundingBox: 0 0 ' + IntToStr(IWidth) + ' ' + IntToStr(IHeight);
end;

Function TEPSCanvas.PointToStr(X,Y:Integer):String;
begin
  TranslateVertCoord(Y);
  result:=IntToStr(X)+' '+IntToStr(Y);
end;

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

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

Procedure TEPSCanvas.InternalRect(Const Rect:TRect; UsePen, IsRound:Boolean);
var tmpB: Integer;
begin

  if (Brush.Style<>bsClear) or (UsePen and (Pen.Style<>psClear)) then
  begin
    tmpB := Rect.Bottom;
    TranslateVertCoord(tmpB);

    if Brush.Style<>bsClear then
    begin
      tmpStr := 'gs '+ PsColor(Brush.Color);
      tmpStr := tmpStr + ' ' +IntToStr(Rect.Left) + ' ' + IntToStr(tmpB) + ' ' +
                IntToStr(Rect.Right - Rect.Left) + ' ' + IntToStr(Rect.Bottom - Rect.Top) + ' rectfill gr';
      Add(tmpStr);
    end;

    if UsePen and (Pen.Style<>psClear) then
    begin
      tmpStr := 'gs '+ PenProperties(Pen);
      tmpStr := tmpStr + ' ' + IntToStr(Rect.Left) + ' ' + IntToStr(tmpB) + ' ' +
                IntToStr(Rect.Right - Rect.Left) + ' ' + IntToStr(Rect.Bottom - Rect.Top) + ' rectstroke gr';
      Add(tmpStr);
    end;
  end;
end;

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

procedure TEPSCanvas.EllipseWithZ(X1, Y1, X2, Y2, Z: Integer);
var CenterX, CenterY: Integer;
    Ra,Rb: String;

    procedure DrawEllipse;
    begin
      Add(IntToStr(CenterX) + ' '+IntToStr(CenterY) + ' ' +
          Ra + ' ' + Rb + ' 0 360 ellipse') ;
    end;

begin
  if (Brush.Style<>bsClear) or (Pen.Style<>psClear) then
  begin
    Calc3DPos(X1,Y1,Z);
    Calc3DPos(X2,Y2,Z);
    CenterX := (X1 + X2) div 2;
    CenterY := (Y1 + Y2) div 2;
    TranslateVertCoord(CenterY);
    { radius }
    Ra := FormatFloat('0.00',(X2-X1)*0.5);
    FixSeparator(Ra);
    Rb := FormatFloat('0.00',(Y2-Y1)*0.5);
    FixSeparator(Rb);
    if (Brush.Style<>bsClear) then
    begin
      Add('gs ' + BrushProperties(Brush));
      DrawEllipse;
      Add('fi gr');
    end;

    if (Pen.Style<>psClear) then
    begin
      Add('gs ' + PenProperties(Pen));
      DrawEllipse;
      Add('st gr');
    end;
  end;
end;

procedure TEPSCanvas.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 TEPSCanvas.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 TEPSCanvas.Arc(X1, Y1, X2, Y2, X3, Y3, X4, Y4: Integer);
begin
  InternalArc(X1, Y1, X2, Y2, X3, Y3, X4, Y4, False);
end;

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

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

Procedure TEPSCanvas.TextOut3D(X,Y,Z:Integer; const Text:String);

  Function FontSize:String;
  begin
    result:=IntToStr(Font.Size);
  end;

  Procedure DoText(AX,AY:Integer);
  begin
    Inc(AY,TextHeight(Text) div 2);
    tmpStr := PsColor(Font.Color) +
              ' /' + Font.Name + ' findfont ' + FontSize + ' scalefont setfont';
    Add(tmpStr);
    Add(PointToStR(AX,AY) + ' m');
    if (TextAlign and TA_CENTER)=TA_CENTER then
      Add('(' + TextToPSText(Text) + ') ctext')
    else if (TextAlign and TA_RIGHT)=TA_RIGHT then
      Add('(' + TextToPSText(Text) + ') rtext')
    else Add('(' + TextToPSText(Text) + ') ltext')

  end;