janshapeeditor.pas

更好用的 shape 控件 delphi 3.0, 4.0, 5.0, 6.0, 7.0 適用

unit janShapeEditor;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, ExtCtrls, Buttons, Menus, janShape;

type
  TShapeEditorForm = class(TForm)
    box: TScrollBox;
    polyimage: TImage;
    addPoint: TSpeedButton;
    SpeedButton1: TSpeedButton;
    btntop: TSpeedButton;
    btnright: TSpeedButton;
    SpeedButton5: TSpeedButton;
    SpeedButton7: TSpeedButton;
    btnleft: TSpeedButton;
    SpeedButton2: TSpeedButton;
    SpeedButton4: TSpeedButton;
    SpeedButton8: TSpeedButton;
    SpeedButton9: TSpeedButton;
    btnalignhor: TSpeedButton;
    btnalignver: TSpeedButton;
    Insert1: TSpeedButton;
    btnload: TSpeedButton;
    btnsave: TSpeedButton;
    OpenDialog1: TOpenDialog;
    SaveDialog1: TSaveDialog;
    btnnew: TSpeedButton;
    btnall: TSpeedButton;
    GroupBox1: TGroupBox;
    SpeedButton3: TSpeedButton;
    SpeedButton6: TSpeedButton;
    SpeedButton10: TSpeedButton;
    UserList: TListBox;
    username: TEdit;
    Label1: TLabel;
    SpeedButton11: TSpeedButton;
    SpeedButton12: TSpeedButton;
    janShape1: TjanShape;
    btnsymver: TSpeedButton;
    SpeedButton13: TSpeedButton;
    btnctrver: TSpeedButton;
    btnctrhor: TSpeedButton;
    ckPolyLine: TCheckBox;
    procedure FormCreate(Sender: TObject);
    procedure preview;
    procedure Shape1MouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure Shape1MouseUp(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure Shape1MouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
    procedure FormDestroy(Sender: TObject);
    procedure polyimageMouseUp(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure Insert1Click(Sender: TObject);
    procedure SpeedButton1Click(Sender: TObject);
    procedure btntopClick(Sender: TObject);
    procedure btnleftClick(Sender: TObject);
    procedure btnrightClick(Sender: TObject);
    procedure SpeedButton7Click(Sender: TObject);
    procedure SpeedButton5Click(Sender: TObject);
    procedure SpeedButton4Click(Sender: TObject);
    procedure SpeedButton2Click(Sender: TObject);
    procedure SpeedButton9Click(Sender: TObject);
    procedure SpeedButton8Click(Sender: TObject);
    procedure btnalignverClick(Sender: TObject);
    procedure btnalignhorClick(Sender: TObject);
    procedure UserListDrawItem(Control: TWinControl; Index: Integer;
      Rect: TRect; State: TOwnerDrawState);
    procedure SpeedButton3Click(Sender: TObject);
    procedure UserListDblClick(Sender: TObject);
    procedure SpeedButton6Click(Sender: TObject);
    procedure SpeedButton10Click(Sender: TObject);
    procedure btnloadClick(Sender: TObject);
    procedure btnsaveClick(Sender: TObject);
    procedure btnnewClick(Sender: TObject);
    procedure btnallClick(Sender: TObject);
    procedure polyimageMouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure polyimageMouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
    procedure SpeedButton11Click(Sender: TObject);
    procedure SpeedButton12Click(Sender: TObject);
    procedure btnsymverClick(Sender: TObject);
    procedure SpeedButton13Click(Sender: TObject);
    procedure btnctrverClick(Sender: TObject);
    procedure btnctrhorClick(Sender: TObject);
    procedure ckPolyLineClick(Sender: TObject);
  private
    procedure DrawPoints;
    procedure DeselectAll;
    procedure strtoPoints(Avector: string);
    { Private declarations }
  public
    { Public declarations }
  end;

var
  ShapeEditorForm: TShapeEditorForm;

implementation

{$R *.DFM}
var
  SelObj:TShape;
  ObjXX,ObjYY:integer;
  pointList:Tlist;
  SelPoints:Tlist;
  FrameX0,FrameY0:integer;
  FrameXold,FrameYold:integer;
  
procedure TShapeEditorForm.FormCreate(Sender: TObject);
begin
  with polyimage.picture.Bitmap do
  begin
    width:=polyimage.width;
    height:=polyimage.height;
    canvas.brush.color:=clwhite;
    canvas.fillrect(rect(0,0,width,height));
  end;
  pointlist:=TList.Create;
  SelPoints:=Tlist.create;
end;

procedure TShapeEditorForm.preview;
type TFloatpoint=record
      x:extended;
      y:extended;
      end;

var s:string;
    p,sc,pts,i,j,w,h:integer;
    alist:tstringlist;
    xscale,yscale:extended;
    px,py:extended;
begin
  pts:=pointlist.count;
  if pts<3 then exit;
  w:=polyimage.width;
  h:=polyimage.height;
  xscale:=1/w;
  yscale:=1/h;
  alist:=tstringlist.create;
  for i:=0 to pts-1 do
  begin
     px:=(TShape(pointlist[i]).left-5)*xscale;
     if px>1 then px:=1;
     py:=(TShape(pointlist[i]).top-5)*yscale;
     if py>1 then py:=1;
     alist.append(floattostr(px));
     alist.append(floattostr(py));
  end;
  s:='Jan='+alist.commatext;
  alist.free;
  janshape1.UserVectorString :=s;
end;

procedure TShapeEditorForm.Shape1MouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
var
  p:tpoint;
  index:integer;
begin
  selObj:=TShape(sender);
  if (ssshift in shift) and (button=mbleft) then
  begin
    if selPoints.Count =0 then
    begin
      selObj.brush.color:=clred;
      SelPoints.Add (selObj);
      selObj.tag:=1;
    end
    else
    begin
      index:=selPoints.IndexOf (selObj);
      if index=-1 then
      begin
        selObj.brush.color:=clred;
        SelPoints.Add (selObj);
        selObj.tag:=1;
      end
      else
      begin
        selObj.brush.color:=clwhite;
        selObj.tag:=0;
        SelPoints.Delete (index);
      end;
    end;
    exit;
  end;
  if button=mbleft then
  begin
    if selpoints.count<2 then
     DeselectAll;
    if selpoints.count=0 then
      selPoints.Add (selObj)
    else if selpoints.indexof(selObj)=-1 then
      selPoints.Add (selObj);
    selObj.brush.color:=clred;
    SelObj.tag:=1;
    ObjXX:=x;
    ObjYY:=y;
  end;
end;

procedure TShapeEditorForm.DeselectAll;
var
  i:integer;
begin
   selPoints.Clear ;
   if pointlist.Count >0 then
    for i:=0 to Pointlist.count-1 do
      TShape(pointlist[i]).brush.color:=clwhite;
end;

procedure TShapeEditorForm.Shape1MouseUp(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  Tshape(sender).tag:=0;
end;

procedure TShapeEditorForm.Shape1MouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
var
 pt:TPoint;
 xo,yo,i:integer;
begin
  if Tshape(sender).tag=1 then
  begin
    xo:=x-ObjXX;
    yo:=y-ObjYY;
    if selpoints.count>0 then
    for i:=0 to selpoints.count-1 do
    begin
      Tshape(selpoints[i]).left:=Tshape(selpoints[i]).left+xo;
      Tshape(selpoints[i]).top:=Tshape(selpoints[i]).top+yo;
    end;
    drawpoints;
  end;
end;

procedure TShapeEditorForm.DrawPoints;
var w,h,i:integer;
    poly:array of Tpoint;
begin
  w:=polyimage.width;
  h:=polyimage.height;
  with polyimage.picture.bitmap do
  begin
    canvas.brush.Color :=clwhite;
    canvas.FillRect (rect(0,0,w,h));
    if pointlist.count>2 then
    begin
      setlength(poly,pointlist.count);
      for i:=0 to pointlist.count-1 do
      begin
        poly[i].x:=TShape(pointlist[i]).left-5;
        poly[i].y:=TShape(pointlist[i]).top-5;
      end;
      canvas.Polygon (poly);
    end;
  end;
  preview;
end;

procedure TShapeEditorForm.FormDestroy(Sender: TObject);
begin
  pointlist.free;
  selPoints.free;
end;

procedure TShapeEditorForm.polyimageMouseUp(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
var sh:Tshape;
    i,xr,yr:integer;
begin
  polyimage.tag:=0;
  polyimage.canvas.DrawFocusRect(rect(FrameX0,FrameY0,x,y));
  if addpoint.down then
  begin
    sh:=Tshape.Create (self);
    sh.parent:=box;
    sh.Width :=10;
    sh.height:=10;
    sh.left:=x+10;
    sh.top:=y+10;
    sh.OnMouseDown :=shape1mousedown;
    sh.OnMouseMove:=shape1mousemove;
    sh.OnMouseUp:=shape1mouseup;
    pointlist.Add (sh);
    drawpoints;
  end
  else  // select points
  begin
    if pointlist.count=0 then exit;
    for i:=0 to pointlist.count-1 do
    begin
      sh:=TShape(pointlist[i]);
      xr:=sh.Left -5;
      yr:=sh.top-5;
      if (xr>=FrameX0) and (xr<=X) and (yr>=FrameY0) and (yr<=Y) then
      begin
        sh.brush.color:=clred;
        selpoints.Add (sh);
      end;
    end;
  end;
end;

procedure TShapeEditorForm.Insert1Click(Sender: TObject);
var sh:Tshape;
    index:integer;
begin
    if selpoints.Count <>1 then exit;
    sh:=Tshape.Create (self);
    sh.parent:=box;
    sh.Width :=10;
    sh.height:=10;
    sh.left:=selObj.left+10;
    sh.top:=selObj.top+10;
    sh.OnMouseDown :=shape1mousedown;
    sh.OnMouseMove:=shape1mousemove;
    sh.OnMouseUp:=shape1mouseup;
    index:=pointlist.IndexOf (Tshape(selpoints[0]));
    if index<>-1 then
     pointlist.Insert(index,sh)
    else
     sh.free;
    drawpoints;
end;

procedure TShapeEditorForm.SpeedButton1Click(Sender: TObject);
var sh:Tshape;
    index,i:integer;
    soc:integer;
begin
  soc:=selpoints.count;
  if soc=0 then exit;
  for i:=soc-1 downto 0 do begin
    sh:= TShape(selpoints[i]);
    index:=pointlist.IndexOf (sh);
    pointlist.Delete (index);
    sh.free;
  end;
  selpoints.Clear ;
  drawpoints;
end;

procedure TShapeEditorForm.btntopClick(Sender: TObject);
var i:integer;
begin
  if selpoints.count<>0 then
    for i:=0 to selpoints.count-1 do
     Tshape(selpoints[i]).top:=5;
  drawpoints;
end;

procedure TShapeEditorForm.btnleftClick(Sender: TObject);
var i:integer;
begin
  if selpoints.count<>0 then
    for i:=0 to selpoints.count-1 do