1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148
|
unit uStef;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls;
type
TForm1 = class(TForm)
Label1: TLabel;
procedure FormShow(Sender: TObject);
procedure FormMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure FormMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
procedure FormMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
private
{ Déclarations privées }
public
{ Déclarations publiques }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
type Tcercle= record
visibe : boolean;
color : tcolor;
x0,y0,Rayon : integer; //+ le Rayon
end;
Cercles =array of Tcercle; // <<
var mesCercles : cercles; // <<
pm :tpenmode;
cercleselect:integer;
dedans :boolean;
XMP,YMP :integer;
procedure tracecercle(c:Tcanvas;cercle:Tcercle;mode:Tpenmode);
begin with c do
begin pen.mode:=mode;
pen.Color:=cercle.color;
ellipse(cercle.x0,cercle.y0,cercle.x0+cercle.Rayon,cercle.y0+cercle.Rayon); //<<
end;
end;
function detectecercle(xs,ys:integer;cercle:Tcercle):boolean ;
begin
with Cercle do if (xs>x0) and (xs<x0+Rayon) and (ys>y0) and (ys<y0+Rayon) //<<
then result:=true
else result:=false;
end;
function newcercle(p:Tpoint; iRayon : integer; coul:tcolor):integer; //<<
var cont,j:integer;
begin
cont:=length(mesCercles); //<<
inc(cont);
setlength(mesCercles,cont); //<<
j:=cont-1;
with mesCercles[j]do //<<
begin
Rayon:=iRayon; //<<
color:=coul; //<<
x0:=p.x;
y0:=p.y;
end;
traceCercle(form1.canvas,mesCercles[j],pm);
mesCercles[j].visibe:=true;
result:=j;
end;
procedure TForm1.FormShow(Sender: TObject);
begin color:=clwhite;
pm:=pmnotxor;
setlength(mesCercles,0);
cercleselect:=-1;
end;
procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
var j:integer; p1:Tpoint;
begin
j:=-1;
cercleselect:=-1;
dedans:=false;
if length(mesCercles)>0 then //il y a déjà des cercles
begin
repeat inc(j) ;
if mesCercles[j].visibe then
dedans:= detecteCercle(x,y,mesCercles[j]);
until (dedans=true )or (j=High(mesCercles)) ;
if dedans=true and mesCercles[j].visibe then
begin
cercleSelect :=j;
screen.Cursor:=crhandPoint;
end;
{if cercleselect <0 then
begin p1.x:=x;p1.y:=y;
cercleselect:=newcercle(p1,clred); : peut pas marcher ici
XMP:=X;YMP:=y;
end; }
end;
if ssCtrl in Shift then //Création cercle
begin p1.x:=x;p1.y:=y;
cercleselect:=newcercle(p1,50,clred);
XMP:=X;YMP:=y;
end;
end;
procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
var j,dxs,dys:integer;
begin
j:= cercleselect;
if j>=0then
begin
screen.Cursor:=crhandpoint;
dxs:=X-XMP;dys:=Y-YMP;
with mesCercles[j] do
begin
if dedans= true then
begin
tracecercle(form1.canvas,mesCercles[j],pm); //<Ajouté car il faut effacer avant de re-tracer dans la nouvelle position
x0:=x+dxs;y0:=y+dys;
end;
tracecercle(form1.canvas,mesCercles[j],pm);
end;
end;
XMP:=X;YMP:=Y;
end;
procedure TForm1.FormMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin cercleselect :=-1;
screen.Cursor:=crdefault;
end;
end. |
Partager