graphic.pas

画图程序 通过DEPHI 实现画图板的功能

   myCircle:
     begin
     drawCircle(origin,movePt);
     movePt:=Point(x,y);
     drawCircle(origin,movePt);
     end;

 end;
 end;

if movingLine then
  begin
  movePt:=Point(x,y);
  realMoveLine(movePt);
  end;

if movingRect then
begin
  movePt:=Point(x,y);
  realMoveRect(movePt);
end;

if movingEllips then
begin
  movePt:=Point(x,y);
  realMoveEllips(movePt);
end;

if movingCircle then
begin
  movePt:=Point(x,y);
  realMoveCircle(movePt);
end;

end;


procedure TForm1.ColorBox1Change(Sender: TObject);
begin
  image1.Canvas.Pen.Color :=colorbox1.Selected;
end;

procedure TForm1.BitBtn_fillClick(Sender: TObject);
begin
  filling:=true;
  moving:=false;
  deling:=false;

  edit1.Text :='用所选颜色填充图形（请选择图形的轮廓线）';
end;

procedure TForm1.BitBtn_moveClick(Sender: TObject);
begin
  moving:=true;
  filling:=false;
  deling:=false;

  edit1.Text :='移动图形（请选择图形的轮廓线）';
end;

procedure TForm1.BitBtn_delClick(Sender: TObject);
begin
  deling:=true;
  filling:=false;
  moving:=false;

  edit1.Text :='删除图形（请选择图形的轮廓线）';
end;

procedure TForm1.realClear;
begin
  itsLine:=firstLine^.next ;
  while itsLine<>nil do
  begin
    image1.Canvas.Pen.Color :=itsLine^.lineColor ;
    drawLine(itsLine^.originP ,itsLine^.finalP );
    firstLine^.next :=itsLine^.next ;
    dispose(itsLine);
    itsLine:=firstLine^.next ;
  end;
  lastLine:=firstLine;
  itsLine:=firstLine;

  itsRect:=firstRect^.next ;
  while itsRect<>nil do
  begin
    image1.Canvas.Pen.Color :=itsRect^.rectColor ;
    image1.Canvas.Brush.Color :=itsRect^.fillColor ;
    drawRect(itsRect^.originP ,itsRect^.finalP );
    firstRect^.next :=itsRect^.next ;
    dispose(itsRect);
    itsRect:=firstRect^.next ;
  end;
  lastRect:=firstRect;
  itsRect:=firstRect;

  itsEllips:=firstEllips^.next ;
  while itsEllips<>nil do
  begin
    image1.Canvas.Pen.Color :=itsEllips^.ellipsColor ;
    image1.Canvas.Brush.Color :=itsEllips^.fillColor ;
    drawEllips(itsEllips^.originP ,itsEllips^.finalP );
    firstEllips^.next :=itsEllips^.next ;
    dispose(itsEllips);
    itsEllips:=firstEllips^.next ;
  end;
  lastEllips:=firstEllips;
  itsEllips:=firstEllips;

  itsCircle:=firstCircle^.next ;
  while itsCircle<>nil do
  begin
    image1.Canvas.Pen.Color :=itsCircle^.CircleColor ;
    image1.Canvas.Brush.Color :=itsCircle^.fillColor ;
    drawCircle(itsCircle^.centreP ,itsCircle^.edgeP );
    firstCircle^.next :=itsCircle^.next ;
    dispose(itsCircle);
    itsCircle:=firstCircle^.next ;
  end;
  lastCircle:=firstCircle;
  itsCircle:=firstCircle;

  //myDrawStart:=null;
  myDrawStart:=null;
  filling:=false;
  moving:=false;
  deling:=false;
end;

procedure TForm1.BitBtn_clearClick(Sender: TObject);
begin
  edit1.Text :='清除所有图形';

  if MessageBox(Form1.Handle ,'您确认删除所有图形？','清除确认',MB_YESNOCANCEL)=IDYES then
  begin
    realClear;
  end;
  myDrawStart:=null;
  filling:=false;
  moving:=false;
  deling:=false;
end;

//-----------------------------------------------------
//--------------------------------------------------

procedure TForm1.drawLine(topLeft: TPoint; bottomRight: TPoint);
begin
  with image1.canvas do
  begin
    MoveTo(topLeft.x,topLeft.y);
    lineto(bottomRight.x,bottomRight.y);
  end;
end;

procedure TForm1.drawRect(topLeft,bottomRight: TPoint);
begin
  with image1.Canvas do
  begin
    Rectangle(topLeft.X,topLeft.y,bottomRight.X ,bottomRight.y);
  end;
end;

procedure TForm1.drawEllips(topLeft,bottomRight:TPoint);
begin
  image1.Canvas.Ellipse(topLeft.X,topLeft.Y,bottomRight.X,bottomRight.Y );
end;

procedure TForm1.drawCircle(centreP,edgeP:TPoint);
var
  radius,angle:real;
  lengthX,lengthY:integer;
  x1,y1:integer;
  i,j:integer;
  arrayCircle: array[1..100] of TPoint;
begin
  lengthX:=abs(centreP.X-edgeP.X );
  lengthY:=abs(centreP.Y-edgeP.Y );
  lengthX:=sqr(lengthX);
  lengthY:=sqr(lengthY);
  radius:=sqrt(lengthX+lengthY);
  i:=100;
  angle:=2*3.1416/i;
  //x0:=centreP.X;
  //y0:=centreP.Y;

  with image1.Canvas do
  begin
    x1:=centreP.X+round(radius); //也可以用trunc
    y1:=centreP.Y;

    //moveto(x1,y1 );
    for j:=0 to i-1 do
    begin
      x1:=centreP.X+round(radius*cos(angle*j));
      y1:=centreP.Y+round(radius*sin(angle*j));
      //lineto(x1,y1);
      arrayCircle[j+1]:=Point(x1,y1);
    end;
    Polygon(arrayCircle);
  end;
end;

{
procedure TForm1.drawCircle(centreP,edgeP:TPoint);
var
  radius,angle:real;
  lengthX,lengthY:integer;
  x1,y1:integer;
  i,j:integer;
begin
  lengthX:=abs(centreP.X-edgeP.X );
  lengthY:=abs(centreP.Y-edgeP.Y );
  lengthX:=sqr(lengthX);
  lengthY:=sqr(lengthY);
  radius:=sqrt(lengthX+lengthY);
  i:=100;
  angle:=2*3.1416/i;
  //x0:=centreP.X;
  //y0:=centreP.Y;

  with image1.Canvas do
  begin
    x1:=centreP.X+round(radius); //也可以用trunc
    y1:=centreP.Y;

    moveto(x1,y1 );
    for j:=1 to i do
    begin
      x1:=centreP.X+round(radius*cos(angle*j));
      y1:=centreP.Y+round(radius*sin(angle*j));
      lineto(x1,y1);
    end;
    //lineto(x10,y10);
  end;
end;
}

function TForm1.prepare(myPoint,firstPoint,secondPoint:TPoint):boolean;
var
  lengthA,lengthB,lengthC:real;
  lengthX,lengthY:real; //integer;
begin
  lengthX:=abs(myPoint.X-firstPoint.X );
  lengthY:=abs(myPoint.Y-firstPoint.Y );
  lengthX:=sqr(lengthX);
  lengthY:=sqr(lengthY);
  lengthA:=sqrt(lengthX+lengthY);

  lengthX:=abs(myPoint.X-secondPoint.X );
  lengthY:=abs(myPoint.Y-secondPoint.Y );
  lengthX:=sqr(lengthX);
  lengthY:=sqr(lengthY);
  lengthB:=sqrt(lengthX+lengthY);

  lengthX:=abs(secondPoint.X-firstPoint.X );
  lengthY:=abs(secondPoint.Y-firstPoint.Y );
  lengthX:=sqr(lengthX);
  lengthY:=sqr(lengthY);
  lengthC:=sqrt(lengthX+lengthY);

  if lengthA+lengthB<lengthC+1 then
    result:=true
  else
    result:=false;
end;

function TForm1.prepareRect(myPoint,firstPoint,secondPoint:TPoint):boolean;
var
  bigX,smallX,bigY,smallY:integer;
begin
  if firstPoint.X >secondPoint.X then
  begin
     bigX:=firstPoint.X ;
     smallX:=secondPoint.X ;
  end
  else
  begin
     bigX:=secondPoint.X ;
     smallX:=firstPoint.X ;
  end;

  if firstPoint.Y >secondPoint.Y then
  begin
    bigY:=firstPoint.Y ;
    smallY:=secondPoint.Y;
  end
  else
  begin
    bigY:=secondPoint.Y ;
    smallY:=firstPoint.Y ;
  end;

  if (myPoint.X>smallX-5) and (myPoint.X<smallX+10) and (myPoint.Y>smallY-5) and (myPoint.Y<bigY+5) then
     result:=true
  else if (myPoint.X>smallX-5) and (myPoint.X<bigX+5) and (myPoint.Y>bigY-10) and (myPoint.Y<bigY+5) then
          result:=true
  else if (myPoint.X>bigX-10) and (myPoint.X<bigX+5) and (myPoint.Y>smallY-5) and (myPoint.Y<bigY+5) then
          result:=true
  else if (myPoint.X>smallX-5) and (myPoint.X<bigX+5) and (myPoint.Y>smallY-5) and (myPoint.Y<smallY+10) then
          result:=true
  else
     result:=false;
end;

function TForm1.prepareEllips(myPoint,firstPoint,secondPoint:TPoint):boolean;
var
  length2A,lengthA2,lengthB2,lengthC:real;
  lengthX,lengthY:real;  //
  deltaX2,deltaY2:real;
  myLength1,myLength2:real;
begin
  lengthX:=abs(secondPoint.X-firstPoint.X )/2;
  lengthY:=abs(secondPoint.Y-firstPoint.Y )/2;

  if lengthX>lengthY then
  begin
    lengthA2:=sqr(lengthX);
    lengthB2:=sqr(lengthY);
    lengthC:=sqrt(lengthA2-lengthB2);
    length2A:=2*lengthX ;
    deltaX2:=sqr((firstPoint.X+secondPoint.X)/2-lengthC-myPoint.X);
    deltaY2:=sqr((firstPoint.Y+secondPoint.Y)/2-myPoint.Y);
    myLength1:=sqrt(deltaX2+deltaY2);
    deltaX2:=sqr((firstPoint.X+secondPoint.X)/2+lengthC-myPoint.X);
    myLength2:=sqrt(deltaX2+deltaY2);
  end
  else
  begin
    lengthA2:=sqr(lengthY);
    lengthB2:=sqr(lengthX);
    lengthC:=sqrt(lengthA2-lengthB2);
    length2A:=2*lengthY;
    deltaX2:=sqr((firstPoint.x+secondPoint.x)/2-myPoint.x);
    deltaY2:=sqr((firstPoint.Y +secondPoint.Y )/2+lengthC-myPoint.Y );
    myLength1:=sqrt(deltaX2+deltaY2);
    deltaY2:=sqr((firstPoint.Y +secondPoint.Y )/2-lengthC-myPoint.Y );
    myLength2:=sqrt(deltaX2+deltaY2);
  end;

  if (myLength1+myLength2<length2A+5)and (myLength1+myLength2>length2A-8)then
     result:=true
  else
     result:=false;
end;

function TForm1.prepareCircle(myPoint,centrePoint,edgePoint:TPoint):boolean;
var
  radius,lengthP:real;
  lengthX,lengthY:real;
begin
  lengthX:=abs(centrePoint.X -edgePoint.X );
  lengthY:=abs(centrePoint.Y -edgePoint.Y );
  lengthX:=sqr(lengthX);
  lengthY:=sqr(lengthY);
  radius:=sqrt(lengthX+lengthY);

  lengthX:=abs(myPoint.X-centrePoint.X );
  lengthY:=abs(myPoint.Y-centrePoint.Y );
  lengthX:=sqr(lengthX);
  lengthY:=sqr(lengthY);
  lengthP:=sqrt(lengthX+lengthY);

  if (lengthP<radius+6) and (lengthP>radius-8) then
     result:=true
  else
     result:=false;
end;


procedure TForm1.preMove(myPoint:TPoint);
var
  ctrlRect:boolean;
  ctrlEllips:boolean;
  ctrlCircle:boolean;
begin
  ctrlRect:=true;
  ctrlEllips:=true;
  ctrlCircle:=true;

  itsLine:=firstLine^.next ;
  while itsLine<>nil do
  begin
    {with image1.canvas do
     MoveTo(myPoint.X ,myPoint.Y );  //<<<<<<<<<<<<<<<
    }
    if prepare(myPoint,itsLine^.originP,itsLine^.finalP) then
    begin
      edit1.Text :='拾取移动终止点：按住左键并且移动鼠标至终止点再松开';
      realMoveLine(myPoint);
      movingLine:=True;
      ctrlRect:=false;
      ctrlEllips:=false;
      ctrlCircle:=false;
      exit;//<<<<<<<<<<<<<<<  Bug !!! <<<<<<<<<<
    end;
    itsLine:=itsLine^.next ;
  end;
  if itsLine=nil then
     itsLine:=lastLine;   //<<<<<< Bug! <<

  if ctrlRect then
  begin
    itsRect:=firstRect^.next ;
    while itsRect<>nil do
    begin
      if prepareRect(myPoint,itsRect^.originP,itsRect^.finalP) then
      begin
        edit1.Text :='拾取移动终止点：按住左键并且移动鼠标至终止点再松开';
        realMoveRect(myPoint);
        movingRect:=true;
        ctrlEllips:=false;
        ctrlCircle:=false;
        exit;//<--------- !!!
      end;
      itsRect:=itsRect^.next ;
    end;
    if itsRect=nil then
       itsRect:=lastRect;  //<<<<<< Bug! <<<<<<<<
  end;

  if ctrlEllips then
  begin
    itsEllips:=firstEllips^.next ;
    while itsEllips<>nil do
    begin
      if prepareEllips(myPoint,itsEllips^.originP ,itsEllips^.finalP) then
      begin
        edit1.Text :='拾取移动终止点：按住左键并且移动鼠标至终止点再松开';
        realMoveEllips(myPoint);
        movingEllips:=true;
        ctrlCircle:=false;
        exit;
      end;
      itsEllips:=itsEllips^.next ;
    end;
    if itsEllips=nil then
       itsEllips:=lastEllips;
  end;

  if ctrlCircle then
  begin
    itsCircle:=firstCircle^.next ;
    while itsCircle<>nil do
    begin
      if prepareCircle(myPoint,itsCircle^.centreP ,itsCircle^.edgeP )then
      begin
        edit1.Text :='拾取移动终止点：按住左键并且移动鼠标至终止点再松开';
        realMoveCircle(myPoint);
        movingCircle:=true;
        exit;
      end;
      itsCircle:=itsCircle^.next ;
    end;
    if itsCircle=nil then
       itsCircle:=lastCircle;
  end;

end;

procedure TForm1.realMoveLine(myPoint:TPoint);
var
  deltaX,deltaY:integer;
  firstPoint,secondPoint:TPoint;
begin
  image1.Canvas.Pen.Color :=itsLine^.lineColor ;
  drawLine(itsLine^.originP,itsLine^.finalP);
  deltaX:=-origin.X+myPoint.X;
  deltaY:=-origin.Y+myPoint.Y;
  firstPoint:=Point(itsLine^.originP.X+deltaX,itsLine^.originP.Y+deltaY);
  secondPoint:=Point(itsLine^.finalP.X+deltaX,itsLine^.finalP.Y+deltaY);
  drawLine(firstPoint,secondPoint);
  origin:=myPoint;
  itsLine^.originP:=firstPoint;
  itsLine^.finalP:=secondPoint;
end;

procedure TForm1.realMoveRect(myPoint:TPoint);
var
  deltaX,deltaY:integer;
  firstPoint,secondPoint:TPoint;
begin
  image1.Canvas.Pen.Color :=itsRect^.rectColor;
  image1.Canvas.Brush.Color :=itsRect^.fillColor;
  drawRect(itsRect^.originP ,itsRect^.finalP);
  deltaX:=-origin.X+myPoint.X;
  deltaY:=-origin.Y+myPoint.Y;
  firstPoint:=Point(itsRect^.originP.X+deltaX,itsRect^.originP.Y+deltaY);
  secondPoint:=Point(itsRect^.finalP.X+deltaX,itsRect^.finalP.Y+deltaY);
  drawRect(firstPoint,secondPoint);
  origin:=myPoint;
  itsRect^.originP:=firstPoint;
  itsRect^.finalP:=secondPoint;
end;

procedure TForm1.realMoveEllips(myPoint:TPoint);
var
  deltaX,deltaY:integer;
  firstPoint,secondPoint:TPoint;
begin
  image1.Canvas.Pen.Color :=itsEllips^.ellipsColor ;
  image1.Canvas.Brush.Color :=itsEllips^.fillColor ;
  drawEllips(itsEllips^.originP ,itsEllips^.finalP);
  deltaX:=-origin.X+myPoint.X;
  deltaY:=-origin.Y+myPoint.Y;
  firstPoint:=Point(itsEllips^.originP.X+deltaX,itsEllips^.originP.Y+deltaY);
  secondPoint:=Point(itsEllips^.finalP.X+deltaX,itsEllips^.finalP.Y+deltaY);
  drawEllips(firstPoint,secondPoint);
  origin:=myPoint;
  itsEllips^.originP:=firstPoint;
  itsEllips^.finalP:=secondPoint;
end;

procedure TForm1.realMoveCircle(myPoint:TPoint);
var
  deltaX,deltaY:integer;
  centrePoint,edgePoint:TPoint;
begin
  image1.Canvas.Pen.Color :=itsCircle^.circleColor ;
  image1.Canvas.Brush.Color :=itsCircle^.fillColor ;
  drawCircle(itsCircle^.centreP ,itsCircle^.edgeP );
  deltaX:=-origin.X+myPoint.X;
  deltaY:=-origin.Y+myPoint.Y;
  centrePoint:=Point(itsCircle^.centreP.X+deltaX,itsCircle^.centreP.Y+deltaY);
  edgePoint:=Point(itsCircle^.edgeP.X+deltaX,itsCircle^.edgeP.Y+deltaY);
  image1.Canvas.Pen.Color :=itsCircle^.circleColor ;
  drawCircle(centrePoint,edgePoint);
  origin:=myPoint;
  itsCircle^.centreP:=centrePoint;
  itsCircle^.edgeP:=edgePoint;
end;

//~~~~~~~~~~~~~~~ Del ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

procedure TForm1.preDel(myPoint:TPoint);
var
  ctrlRect:boolean;
  ctrlEllips:boolean;
  ctrlCircle:boolean;
begin
  ctrlRect:=true;
  ctrlEllips:=true;
  ctrlCircle:=true;

  dLine:=firstLine;
  itsLine:=firstLine^.next ;
  while itsLine<>nil do
  begin
    if prepare(myPoint,itsLine^.originP,itsLine^.finalP) then
    begin
      edit1.Text :='继续刚才的操作类型，或者重新选择操作类型';