janshape.pas

delphi语言开发的矢量图形处理对象

unit janShape;

interface

uses
  Windows, WinProcs,Messages, SysUtils, Classes, Graphics, Controls,
  Forms, Dialogs,math;


type
  TonUserDraw= procedure ( sender : Tobject) of object;
  TShapeMouseMode=(mmfixed,mmMoveObject,mmSizeObject,mmMoveText,mmRotateText);

  TFloatPoint= record
    x:extended;
    y:extended;
    end;

  TjanShapeType = (jstRectangle, jstSquare, jstRoundRect, jstRoundSquare,
    jstEllipse, jstCircle, jstValve,jstValveUp,jstHouse,
    jstTriangleRight,jstTriangleUp,jstTriangleLeft,jstTriangleDown,
    jstArrowRight,jstArrowUp,jstArrowLeft,jstArrowDown,
    jstArrowUpDown,jstArrowLeftRight,
    jstDiamond, jstOctagon,jstHexagon,jstHexagonFlat,
    jstUBarUp,jstUBarLeft,jstUBarDown,jstUBarRight,
    jstChairLeft,jstChairRight,
    jstBowlLeft,jstBowlRight,jstBowlDown,jstBowlUp,
    jstIBar,jstHBar,jst4Point,jstWaggle,
    jstCloudLeft,jstCloudRight,jstDoubleOval,jstDoubleOvalV,
    jstTorus,jstFrame,jstFrameNarrow,
    jstLBarUpLeft,jstLBarUpRight,jstLBarLeft,jstLBarRight,
    jst2HoleHoriz,jst2HoleVert,
    jstCubeUpRight,jstCubeUpLeft,jstCubeDownRight,jstCubeDownLeft,
    jstCubeHalf,jstRoofRight,jstRoofLeft,jstRoofFront,jstRoofBack,
    jstPyramid,jstMoret,jstZ,jstN,jstMatta,
    jstPistacheTop,jstPistacheBottom,jstPistacheLeft,jstPistacheRight,
    jst1Hole,jst1HoleBig,jstflower,
    jstFatArrowUp,jstFatArrowLeft,jstFatArrowDown,jstFatArrowRight,
    jstUser);
  TjanFillDirection = (jgdUp, jgdDown, jgdLeft, jgdRight,
    jgdRectOut,jgdRectIn, jgdHorizCenter, jgdVertCenter,
    jgdCircOut,jgdCircIn,jgdNWSE,jgdNESW,jgdSENW,jgdSWNE,
    jgdUright,jgdULeft,jgdUUp,jgdUDown,
    jgdRCMix,jgdRCModulo,jgdQuatro,jgdDuo,
    jgdLNE,jgdLNW,jgdUpDown,jgdLeftRight);

  TjanShape = class(TGraphicControl)
  private
    UserVector: array of TFloatPoint;
    UserPoints:integer;
    IsMouseDown:boolean;
    selObjXX:integer;
    selObjYY :integer;
    swCanvas:TCanvas;
    swleft:integer;
    swtop:integer;
    swExternal:boolean;
    FPen: TPen;
    FBrush: TBrush;
    FShape: TjanShapeType;
    FFillDirection: TjanFillDirection;
    FGradientColor: Tcolor;
    FGradient: boolean;
    FCaption: String;
    FCaptionAngle: integer;
    FCaptionY: integer;
    FCaptionX: integer;
    FCaptionCentered: boolean;
    FonUserDraw: TonUserDraw;
    FbyUser: boolean;
    FActiveMouse: boolean;
    FMouseMode: TshapeMouseMode;
    FUserVectorString: string;
    FPolyLineMode: boolean;
    FSelected: boolean;
    FGroupName: string;
    FConnectorN: string;
    FConnectorS: string;
    FConnectorW: string;
    FConnectorE: string;
    procedure SetBrush(Value: TBrush);
    procedure SetPen(Value: TPen);
    procedure SetShape(Value: TjanShapeType);
    procedure DrawTriangle;
    procedure FillWithGradient;
    procedure SetPenBrushForGradient;
    procedure SetPenBrushForOutline;
    procedure SetFillDirection(const Value: TjanFillDirection);
    procedure SetGradientColor(const Value: Tcolor);
    procedure SetGradient(const Value: boolean);
    procedure DrawArrow;
    procedure DrawUBar;
    procedure DrawChair;
    procedure DrawOctagon;
    procedure DrawEllipse;
    procedure DrawRectangle;
    procedure DrawRoundRect;
    procedure DrawValve;
    procedure DrawHouse;
    procedure DrawDiamond;
    procedure DoRectangle(fr, fg, fb, dr, dg, db: Integer);
    procedure DoHorizCenter(fr, fg, fb, dr, dg, db: Integer);
    procedure DoVertCenter(fr, fg, fb, dr, dg, db: Integer);
    procedure DrawBowl;
    procedure DrawIBar;
    procedure DrawWaggle;
    procedure DrawCloud;
    procedure DrawTorus;
    procedure DoCircle(fr, fg, fb, dr, dg, db: Integer);
    procedure doGradNWSE(fr, fg, fb, dr, dg, db: Integer);
    procedure doGradNESW(fr, fg, fb, dr, dg, db: Integer);
    procedure doGradSENW(fr, fg, fb, dr, dg, db: Integer);
    procedure doGradSWNE(fr, fg, fb, dr, dg, db: Integer);
    procedure doGradURight(fr, fg, fb, dr, dg, db: Integer);
    procedure doGradULeft(fr, fg, fb, dr, dg, db: Integer);
    procedure doGradUUp(fr, fg, fb, dr, dg, db: Integer);
    procedure doGradUDown(fr, fg, fb, dr, dg, db: Integer);
    procedure doGradRCMix(fr, fg, fb, dr, dg, db: Integer);
    procedure doGradRCModulo(fr, fg, fb, dr, dg, db: Integer);
    procedure doGradQuatro(fr, fg, fb, dr, dg, db: Integer);
    procedure doGradDuo(fr, fg, fb, dr, dg, db: Integer);
    procedure doGradLNE(fr, fg, fb, dr, dg, db: Integer);
    procedure doGradLNW(fr, fg, fb, dr, dg, db: Integer);
    procedure doGradUpDown(fr, fg, fb, dr, dg, db: Integer);
    procedure doGradLeftRight(fr, fg, fb, dr, dg, db: Integer);
    procedure DrawLBar;
    procedure Draw2Hole;
    procedure SetCaption(const Value: String);
    procedure TextRotate(bitmap:tbitmap;x, y, angle: integer; atext: string;
      afont: tfont);
    procedure SetCaptionAngle(const Value: integer);
    procedure DrawText;
    procedure SetCaptionX(const Value: integer);
    procedure SetCaptionY(const Value: integer);
    procedure SetCaptionCentered(const Value: boolean);
    procedure SetonUserDraw(const Value: TonUserDraw);
    procedure DoUserDraw;
    procedure SetbyUser(const Value: boolean);
    procedure DrawHexagon;
    procedure DrawCube;
    procedure DrawRoof;
    procedure DrawPyramid;
    procedure DrawMoret;
    procedure DrawZ;
    procedure DrawMatta;
    procedure DrawPistache;
    procedure Draw1Hole;
    procedure Drawflower;
    procedure DrawFrame;
    procedure SetActiveMouse(const Value: boolean);
    procedure SetMouseMode(const Value: TshapeMouseMode);
    procedure XFillRect(R: Trect);
    procedure XPoly(P: array of TPoint);
    procedure XEllipse(x1, y1, x2, y2: integer);
    procedure XRoundrect(x1, y1, x2, y2, x3, y3: integer);
    procedure XRectangle(x1, y1, x2, y2: integer);
    procedure DrawUser;
    procedure SetUserVectorString(const Value: string);
    procedure SetPolyLineMode(const Value: boolean);
    procedure SetSelected(const Value: boolean);
    procedure SetGroupName(const Value: string);
    procedure SetConnectorN(const Value: string);
    procedure SetConnectorS(const Value: string);
    procedure SetConnectorE(const Value: string);
    procedure SetConnectorW(const Value: string);
  protected
    procedure Paint; override;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);override;
    procedure MouseMove(Shift: TShiftState; X, Y: Integer);override;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure PaintToCanvas(acanvas: TCanvas;Ax0,Ay0:integer;AScaleX,AscaleY:extended);
    property Canvas;

  published
    procedure StyleChanged(Sender: TObject);
    property onUserDraw: TonUserDraw read FonUserDraw write SetonUserDraw;
    property GroupName:string read FGroupName write SetGroupName;
    property ConnectorN:string read FConnectorN write SetConnectorN;
    property ConnectorS:string read FConnectorS write SetConnectorS;
    property ConnectorE:string read FConnectorE write SetConnectorE;
    property ConnectorW:string read FConnectorW write SetConnectorW;
    property UserVectorString:string read FUserVectorString write SetUserVectorString;
    property Align;
    property popupmenu;
    property Anchors;
    property Brush: TBrush read FBrush write SetBrush;
    property GradientColor:Tcolor read FGradientColor write SetGradientColor;
    property Gradient:boolean read FGradient write SetGradient default false;
    property DragCursor;
    property DragKind;
    property DragMode;
    property Enabled;
    property Constraints;
    property ParentShowHint;
    property Pen: TPen read FPen write SetPen;
    property Shape: TjanShapeType read FShape write SetShape default jstRectangle;
    property FillDirection:TjanFillDirection read FFillDirection write SetFillDirection;
    property ShowHint;
    property Font;
    property Caption:String read FCaption write SetCaption;
    property CaptionX:integer read FCaptionX write SetCaptionX default 5;
    property CaptionY:integer read FCaptionY write SetCaptionY default 5;
    property CaptionCentered:boolean read FCaptionCentered write SetCaptionCentered;
    property CaptionAngle:integer read FCaptionAngle write SetCaptionAngle;
    property byUser:boolean read FbyUser write SetbyUser;
    property ActiveMouse:boolean read FActiveMouse write SetActiveMouse;
    property MouseMode:TshapeMouseMode read FMouseMode write SetMouseMode;
    property PolyLineMode:boolean read FPolyLineMode write SetPolyLineMode;
    property Selected:boolean read FSelected write SetSelected;
    property Visible;
    property OnClick;
    property OnDblClick;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDock;
    property OnEndDrag;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property OnStartDock;
    property OnStartDrag;
  end;

procedure Register;

implementation

{ TjanShape }
uses
 janshapecontroller;

var
  X0,Y0,X, Y, W, H, S: Integer;
  w2,w3,w4,w8,w16,h2,h3,h4,h8,h16,xw,yh:integer;
  ScaleX,ScaleY:extended;
  OldLeft,OldTop,OldWidth,OldHeight:integer;

procedure Register;
begin
  RegisterComponents('Jans', [TjanShape]);
end;


constructor TjanShape.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  ControlStyle := ControlStyle + [csReplicatable];
  Width := 65;
  Height := 65;
  FPen := TPen.Create;
  FPen.OnChange := StyleChanged;
  FBrush := TBrush.Create;
  FBrush.OnChange := StyleChanged;
  FCaptionCentered:=true;
  FbyUser:=false;
  swCanvas:=Canvas;
  swExternal:=false;
  FMouseMode:=mmfixed;
  FActiveMouse:=false;
  FPolyLineMode:=false;
  FSelected:=false;
  IsMouseDown:=false;
  ScaleX:=1;
  ScaleY:=1;
  X0:=0;
  Y0:=0;
  FUserVectorString:='usrRectangle=0,0,1,0,1,1,0,1';
  UserPoints:=4;
  SetLength(UserVector,4);
  UserVector[0].x:=0;
  UserVector[0].y:=0;
  UserVector[1].x:=1;
  UserVector[1].y:=0;
  UserVector[2].x:=1;
  UserVector[2].y:=1;
  UserVector[3].x:=0;
  UserVector[3].y:=1;
end;

destructor TjanShape.Destroy;
begin
  FPen.Free;
  FBrush.Free;
  inherited Destroy;
end;

procedure TjanShape.XFillRect(R:Trect);
begin
  R.left:=x0+round(ScaleX*R.left);
  R.Right:=x0+round(ScaleX*R.right);
  R.top:=y0+round(ScaleY*R.top);
  R.bottom:=y0+round(ScaleY*R.bottom);
  swCanvas.FillRect (R);
end;

procedure TjanShape.XPoly(P:array of TPoint);
var i:integer;
begin
  for i:=0 to High(P) do
  begin
    P[i].x:=x0+round(ScaleX*P[i].x);
    P[i].y:=y0+round(ScaleY*P[i].y);
  end;
  swCanvas.Polygon (P);
end;

procedure TjanShape.XEllipse(x1,y1,x2,y2 : integer);
begin
  x1:=x0+round(ScaleX*x1);
  y1:=y0+round(ScaleY*y1);
  x2:=x0+round(ScaleX*x2);
  y2:=y0+round(ScaleY*y2);
  swCanvas.Ellipse (x1,y1,x2,y2);
end;

procedure TjanShape.XRectangle(x1,y1,x2,y2 : integer);
begin
  x1:=x0+round(ScaleX*x1);
  y1:=y0+round(ScaleY*y1);
  x2:=x0+round(ScaleX*x2);
  y2:=y0+round(ScaleY*y2);
  swCanvas.Rectangle (x1,y1,x2,y2);
end;


procedure TjanShape.XRoundrect(x1,y1,x2,y2,x3,y3 : integer);
begin
  x1:=x0+round(ScaleX*x1);
  y1:=y0+round(ScaleY*y1);
  x2:=x0+round(ScaleX*x2);
  y2:=y0+round(ScaleY*y2);
  x3:=round(ScaleX*x3);
  y3:=round(ScaleY*y3);
  swCanvas.roundrect(x1,y1,x2,y2,x3,y3);
end;


procedure TjanShape.Paint;
var
  poly: array[0..12] of TPoint;
begin
  if swExternal then
  begin
    swleft:=0;
    swtop:=0;
  end
  else
  begin
    swleft:=left;
    swtop:=top;
  end;
  with swCanvas do
  begin
    Pen := FPen;
    Brush := FBrush;
    X := Pen.Width div 2;
    Y := X;
    W := Width - Pen.Width + 1;
    H := Height - Pen.Width + 1;
    if Pen.Width = 0 then
    begin
      Dec(W);
      Dec(H);
    end;
// calcalute some often used values
    x:=round(x0+ScaleX*x);
    y:=round(y0+ScaleY*y);
    w:=round(ScaleX*w);
    h:=round(ScaleY*h);


    if W < H then S := W else S := H;
    if FShape in [jstSquare, jstRoundSquare, jstCircle] then
    begin
      Inc(X, (W - S) div 2);
      Inc(Y, (H - S) div 2);
      W := S;
      H := S;
    end;


    w2:=w div 2;
    w3:=w div 3;
    w4:=w div 4;
    w8:=w div 8;
    w16:=w div 16;
    h2:=h div 2;
    h3:=h div 3;
    h4:=h div 4;
    h8:=h div 8;
    h16:=h div 16;
    xw:=x+w-round(ScaleX*1);
    yh:=y+h-round(scaleY*1);
    case FShape of
      jstUser: DrawUser;
      jstRectangle, jstSquare: DrawRectangle;
      jstRoundRect, jstRoundSquare: DrawRoundrect;
      jstCircle, jstEllipse: DrawEllipse;
      jstValve, jstValveUp: DrawValve;
      jstHouse: DrawHouse;
      jstTriangleleft,jstTriangleRight,jstTriangleUp,jstTriangleDown: DrawTriangle;
      jstArrowRight,jstArrowLeft,jstArrowDown,jstArrowUp,jstFatArrowRight,jstFatArrowLeft,jstFatArrowDown,jstFatArrowUp: DrawArrow;
      jstDiamond: DrawDiamond;
      jstOctagon,jst4Point: DrawOctagon;
      jstHexagon,jstHexagonFlat:DrawHexagon;
      jstUBarUp,jstUBarDown,jstUBarRight,jstUBarLeft: DrawUBar;
      jstChairLeft,jstChairRight,jstArrowUpDown,jstArrowleftRight: DrawChair;
      jstBowlLeft,jstBowlRight,jstBowlDown,jstBowlUp: DrawBowl;
      jstIBar,jstHBar: DrawIBar;
      jstWaggle: DrawWaggle;
      jstCloudLeft,jstCloudRight,jstDoubleOval,jstDoubleOvalV: DrawCloud;
      jstTorus: DrawTorus;
      jstFrame,jstFrameNarrow: DrawFrame;
      jstLBarUpLeft,jstLBarUpRight,jstLBarLeft,jstLBarRight: DrawLBar;
      jst2HoleHoriz,jst2HoleVert: Draw2Hole;
      jstCubeUpRight,jstCubeUpLeft,jstCubeDownRight,
      jstCubeDownLeft,jstCubeHalf:DrawCube;
      jstRoofRight,jstRoofLeft,jstRoofFront,jstRoofBack:DrawRoof;
      jstPyramid:DrawPyramid;
      jstMoret:DrawMoret;
      jstZ,jstN:DrawZ;
      jstMatta:DrawMatta;
      jstPistacheTop,jstPistacheBottom,jstPistacheLeft,jstPistacheRight:DrawPistache;
      jst1Hole,jst1HoleBig:Draw1Hole;
      jstflower:drawflower;
    end;
   if FbyUser then
    doUserDraw
    else
    DrawText;
   if FSelected then
   begin
     canvas.Brush.color:=clred;
     canvas.pen.color:=clblack;
     canvas.Rectangle (x+w2-4,y+h2-4,x+w2+4,y+h2+4);
   end;
  end;
end;

procedure TjanShape.DrawUser;
var
   poly:array of TPoint;
   rpoly: array [0..49] of TPoint;
   rgn :Hrgn;
   i:integer;
begin