teevmlcanvas.pas

TeeChart7Source 控件

{******************************************}
{ TeeChart Pro VML Canvas and Exporting    }
{ VML : Vector Markup Language             }
{ Copyright (c) 2001-2004 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;

    // IPenEndStyle : TPenEndStyle;
    IPenStyle    : TPenStyle;
    IPenWidth    : Integer;
    ITransp      : TTeeTransparency;

    Procedure Add(Const S:String);
    procedure ChangedPen(Sender: TObject);
    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;

    { 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;

    Function VmlPen(const Element:String):String;
  public
    { Public declarations }
    Constructor Create(AStrings:TStrings);

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

    procedure AssignVisiblePenColor(APen:TPen; AColor:TColor); override;  // 7.0

    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); 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: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;
    Procedure Polyline(const Points: {$IFDEF D5}Array of TPoint{$ELSE}TPointArray{$ENDIF}); override;

    Function BeginBlending(const R:TRect; Transparency:TTeeTransparency):TTeeBlend; override;
    procedure EndBlending(Blend:TTeeBlend); 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>');
  Pen.OnChange:=nil;
end;

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

Function VMLColorInternal(AColor:TColor):String;
begin
  AColor:=ColorToRGB(AColor);

  case AColor of
    clBlack: result:='black';
    clWhite: result:='white';
    clRed:   result:='red';
    clGreen: result:='green';
    clBlue:  result:='blue';
    clYellow: result:='yellow';
    clGray:  result:='gray';
    clNavy:  result:='navy';
    clOlive: result:='olive';
    clLime:  result:='lime';
    clTeal:  result:='teal';
    clSilver:  result:='silver';
    clPurple:  result:='purple';
    clFuchsia:  result:='fuchsia';
    clMaroon:  result:='maroon';
  else
  begin
    result:='#'+IntToHex(GetRValue(AColor),2)+
                IntToHex(GetGValue(AColor),2)+
                IntToHex(GetBValue(AColor),2);
    if result='#000000' then result:='#0';
  end;
  end;
end;

Function VMLColor(AColor:TColor):String;
begin
  result:='"'+VMLColorInternal(AColor)+'"';
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.AssignVisiblePenColor(APen:TPen; AColor:TColor);
begin
  IPenStyle:=APen.Style;
  IPenWidth:=APen.Width;
  Pen.OnChange:=nil;
  inherited;
  Pen.OnChange:=ChangedPen;
end;

Function TVMLCanvas.VmlPen(const Element:String):String;

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

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

  function PenWidth(const Element:String):String;
  begin
    if IPenWidth>1 then
       result:=' '+Element+'="'+TeeStr(IPenWidth)+'" '
    else
       result:='';
  end;

begin
  result:='" strokecolor='+VMLColor(Pen.Color);

  if (IPenStyle<>psSolid) or IsSmallDots then
     result:=result+'><v:stroke dashstyle="'+PenStyle+'"'+PenWidth('weight')+'/></v:'+Element+'>'
  else
     result:=result+PenWidth('strokeweight')+'/>';
end;

procedure TVMLCanvas.LineTo(X, Y: Integer);
begin
  Add('<v:line from="'+PointToStr(FX,FY)+'" to="'+PointToStr(X,Y)+VmlPen('line'));
  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));

  if ITransp<>0 then Add(' opacity="'+FloatToStr((100-ITransp)*0.01)+'"');

  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;
    tmpElement : String;
    tmpR : TRect;
begin
  if (Brush.Style<>bsClear) or (UsePen and (Pen.Style<>psClear)) then
  begin
    tmp:='<v:';

    if IsRound then tmpElement:='roundrect'
               else tmpElement:='rect';

    tmp:=tmp+tmpElement;

    tmpR:=OrientRectangle(Rect);

    tmp:=tmp+' style="position:absolute;left:'+
         TeeStr(tmpR.Left)+';top:'+TeeStr(tmpR.Top)+';width:'+
         TeeStr(tmpR.Right-tmpR.Left-1)+';height:'+
         TeeStr(tmpR.Bottom-tmpR.Top-1)+'"';

    if Brush.Style<>bsClear then
       tmp:=tmp+' fillcolor='+VMLColor(Brush.Color)
    else
       tmp:=tmp+' filled="false"';

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

    if ITransp<>0 then
       tmp:=tmp+' opacity="'+FloatToStr((100-ITransp)*0.01)+'"';

    Add(tmp+VmlPen(tmpElement));
  end;
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);