teevmlcanvas.pas

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

{******************************************}
{ TeeChart Pro VML Canvas and Exporting    }
{ VML : Vector Markup Language             }
{ Copyright (c) 2001-2003 by David Berneda }
{       All Rights Reserved                }
{******************************************}
unit TeeVMLCanvas;
{$I TeeDefs.inc}

interface

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

type
  TVMLCanvas = class(TTeeCanvas3D)
  private
    { Private declarations }
     FBackColor   : TColor;
     FBackMode    : TCanvasBackMode;
     FTextAlign   : TCanvasTextAlign;
     FX           : Integer;
     FY           : Integer;
     FStrings     : TStrings;
     Procedure Add(Const S:String);
     Procedure InternalRect(Const Rect:TRect; UsePen,IsRound:Boolean);
     Function PointToStr(X,Y:Integer):String;
     Function PrepareShape:String;
     Function TheBounds:String;
  protected
    { Protected declarations }
     Procedure PolygonFour; override;
  public
    { Public declarations }
    Constructor Create(AStrings:TStrings);

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

    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); reintroduce; 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;
  published
  end;

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

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

implementation

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

{ TVMLCanvas }
Constructor TVMLCanvas.Create(AStrings:TStrings);
begin
  inherited Create;
  FStrings:=AStrings;
  UseBuffer:=False;

  { start }
  Add('<xml:namespace prefix="v"/>');
  Add('<style>v\:* {behavior=url(#default#VML)}</style>');
end;

Procedure TVMLCanvas.ShowImage(DestCanvas,DefaultCanvas:TCanvas; Const UserRect:TRect);
begin { finish }
  Add('</v:group>');
end;

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

Function VMLColor(AColor:TColor):String;
begin
  AColor:=ColorToRGB(AColor);
  result:='"#'+IntToHex(GetRValue(AColor),2)+
               IntToHex(GetGValue(AColor),2)+
               IntToHex(GetBValue(AColor),2)+'"';
  if result='"#000000"' then result:='"#0"';
end;

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

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

procedure TVMLCanvas.LineTo(X, Y: Integer);

  Function IsSmallDots:Boolean;
  begin
    result:=(Pen is TChartPen) and TChartPen(Pen).SmallDots;
  end;

  Function PenStyle:String;
  begin
    if IsSmallDots then
       result:='dot'
    else
    Case Pen.Style of
      psSolid: ;
      psDash: result:='dash';
      psDot: result:='dot';
      psDashDot: result:='dashdot';
      psDashDotDot: result:='longdashdotdot';
    end;
  end;

var tmpSt : String;
begin
  tmpSt:='<v:line from="'+PointToStr(FX,FY)+'" to="'+PointToStr(X,Y)+
         '" strokeweight="'+IntToStr(Pen.Width)+'" strokecolor='+VMLColor(Pen.Color);

  if Pen.Width>1 then
     tmpSt:=tmpSt+' strokeweight="'+IntToStr(Pen.Width)+'"';

  if (Pen.Style<>psSolid) or IsSmallDots then
  begin
    Add(tmpSt+'>');
    Add('<v:stroke dashstyle="'+PenStyle+'"/>');
    Add('</v:line>');
  end
  else
     Add(tmpSt+'/>');

  FX:=X;
  FY:=Y;
end;

procedure TVMLCanvas.ClipRectangle(Const Rect:TRect);
begin
end;

procedure TVMLCanvas.ClipCube(Const Rect:TRect; MinZ,MaxZ:Integer);
begin
end;

procedure TVMLCanvas.UnClipRectangle;
begin
end;

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

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

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

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

Procedure TVMLCanvas.SetMonochrome(Value:Boolean);
begin
end;

procedure TVMLCanvas.StretchDraw(const Rect: TRect; Graphic: TGraphic);
begin
end;

procedure TVMLCanvas.Draw(X, Y: Integer; Graphic: TGraphic);
begin
end;

Function TVMLCanvas.TheBounds:String;
begin
  result:='width:'+IntToStr(Bounds.Right-Bounds.Left)+
          ';height:'+IntToStr(Bounds.Bottom-Bounds.Top);
end;

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

Procedure TVMLCanvas.GradientFill( Const Rect:TRect;
                                  StartColor,EndColor:TColor;
                                  Direction:TGradientDirection;
                                  Balance:Integer=50);
var TheAngle : Integer;
begin
  Case Direction of
     gdTopBottom  : TheAngle:=180;
     gdBottomTop  : TheAngle:=0;
     gdLeftRight  : TheAngle:=270;
     gdRightLeft  : TheAngle:=90;
     gdFromCenter : TheAngle:=0; { to-do }
     gdFromTopLeft: TheAngle:=315;
  else
     TheAngle:=225; { gdFromBottomLeft }
  end;

  Add('<v:shape style="position:absolute;'+TheBounds+';" stroked="f">');

  Add(' <v:path v="M '+PointToStr(Rect.Left,Rect.Top)+' L '+
        PointToStr(Rect.Right,Rect.Top)+' '+
        PointToStr(Rect.Right,Rect.Bottom)+' '+
        PointToStr(Rect.Left,Rect.Bottom)+' X E"/>');

  Add(' <v:fill type="gradient" color='+VMLColor(StartColor)+' color2='+VMLColor(EndColor));
  Add(' method="sigma" angle="'+IntToStr(TheAngle)+'" focus="100%"/>');
  Add('</v:shape>');
end;

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

Procedure TVMLCanvas.InternalRect(Const Rect:TRect; UsePen,IsRound:Boolean);
var tmp : String;
begin
  if (Brush.Style<>bsClear) or (UsePen and (Pen.Style<>psClear)) then
  begin
    tmp:='<v:';
    if IsRound then tmp:=tmp+'roundrect'
               else tmp:=tmp+'rect';
    tmp:=tmp+' style="position:absolute;left:'+
         IntToStr(Rect.Left)+';top:'+IntToStr(Rect.Top)+';width:'+
         IntToStr(Rect.Right-Rect.Left)+';height:'+
         IntToStr(Rect.Bottom-Rect.Top)+'"';

    if Brush.Style<>bsClear then
       tmp:=tmp+' fillcolor='+VMLColor(Brush.Color);
    if UsePen and (Pen.Style<>psClear) then
       tmp:=tmp+' strokecolor='+VMLColor(Pen.Color)
    else
       tmp:=tmp+' stroked="f"';

    Add(tmp+'/>');
  end;
end;

procedure TVMLCanvas.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 TVMLCanvas.Ellipse(X1, Y1, X2, Y2: Integer);
begin
  EllipseWithZ(X1,Y1,X2,Y2,0);
end;

procedure TVMLCanvas.EllipseWithZ(X1, Y1, X2, Y2, Z: Integer);
begin
  Calc3DPos(X1,Y1,Z);