Comment redimensionner un TShape à la souris pendant l'exécution du programme ?

**[ZiP]** · 12/10/2011, 23h05

Bonjour,

J'ai un TShape de forme rectangle avec pour contour un pointillé rouge et un fond transparent.

J'arrive à le déplacer en cours d'exécution avec le code suivant :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
 
procedure TMain.Shape1MouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
     if ssLeft in Shift then
     begin
          PosX := X;
          PosY := Y;
     end;
end;
 
procedure TMain.Shape1MouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
begin
     if ssLeft in Shift then
     begin
          Shape1.Left := Shape1.Left + X - PosX;
          Shape1.Top := Shape1.Top + Y - PosY;
     end;
end;

Je voudrais pouvoir également le redimensionner (affichage des flèches de redimensionnement sur la bordure) pendant l'exécution mais je ne sais pas comment m'y prendre.

Avez-vous une méthode pour faire ce genre de chose ?

Merci,
ZiP

**mick605** · 12/10/2011, 23h14

Salut

Il n'existe pas de méthode toute simple pour faire ce que tu veux, je pense. Tu dois tester, lors d'un MouseDown sur ton composant, si le clic est sur une bordure, et dans ce cas, faire varier les Height et Width. En gros, tu dois modifier tes deux procedures MouseMove et MouseDown.

Pour afficher les fleches de redimensionnement, tu as juste a changer le curseur quand a souris passe sur un bord du composant (MouseMove), et remettre le curseur par défaut quand tu quitte le composant (MouseLeave).

Bonne chance

**[ZiP]** · 13/10/2011, 02h43

Bonsoir mick605,

J'ai commencé à ajouter cette fonctionnalité :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
 
procedure TMain.Shape1MouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
begin
     // Coin haut gauche
     if (X < 5) and (Y < 5) then Shape1.Cursor := crSizeNWSE
     // Millieu gauche
     else if (X < 5) and (Y > 5) and (Y < Shape1.Height - 5) then Shape1.Cursor := crSizeWE
     // Coin bas gauche
     else if (X < 5) and (Y > Shape1.Height - 5) then Shape1.Cursor := crSizeNESW
     // Millieu bas
     else if (X > 5) and (X < Shape1.Width - 5) and (Y > Shape1.Height - 5) then Shape1.Cursor := crSizeNS
     // Coin bas droit
     else if (X > Shape1.Width - 5) and (Y > Shape1.Height - 5) then Shape1.Cursor := crSizeNWSE
     // Millieu droit
     else if (X > Shape1.Width - 5) and (Y < Shape1.Height - 5) and (Y > 5) then Shape1.Cursor := crSizeWE
     // Coin haut droit
     else if (X > Shape1.Width - 5) and (Y < 5) then Shape1.Cursor := crSizeNESW
     // Millieu haut
     else if (X > 5) and (X < Shape1.Width - 5) and (Y < 5) then Shape1.Cursor := crSizeNS
     // Tous les autres cas
     else Shape1.Cursor := crSize;
 
     if ssLeft in Shift then
     begin
          // Coin haut gauche
          if (X < 5) and (Y < 5) then
          begin
               //Shape1.Left := Shape1.Left + X - PosX;
               //Shape1.Width := Shape1.Width + X - PosX;
               //Shape1.Top := Shape1.Top + Y - PosY;
               //Shape1.Height := Shape1.Height + Y - PosY ;
          end
          // Millieu gauche
          else if (X < 5) and (Y > 5) and (Y < Shape1.Height - 5) then
          begin
               Shape1.Left := Shape1.Left + X - PosX;
               Shape1.Width := Shape1.Width + X - PosX;
          end
          // Tous les autres cas
          else if (X > 5) and (X < Shape1.Width - 5) and (Y > 5) and (Y < Shape1.Height - 5) then
          begin
               if ((Shape1.Left + X - PosX) >= 8) and ((Shape1.Left + X - PosX + Shape1.Width) <= 648) and ((Shape1.Top + Y - PosY) >= 54) and ((Shape1.Top + Y - PosY + Shape1.Height) <= 534) then
               begin
                    Shape1.Left := Shape1.Left + X - PosX;
                    Shape1.Top := Shape1.Top + Y - PosY;
               end;
          end;
     end;
end;

Par contre, je n'arrive pas à gérer cette partie là :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
 
          // Millieu gauche
          else if (X < 5) and (Y > 5) and (Y < Shape1.Height - 5) then
          begin
               Shape1.Left := Shape1.Left + X - PosX;
               Shape1.Width := Shape1.Width + X - PosX;
          end

Je voudrais pouvoir agrandir par la gauche sans que la partie de droite ne bouge... mais je n'y arrive pas

Merci,
ZiP

**Whiler** · 13/10/2011, 03h45

Salut,

Un bout de code... pour te donner des idées...

Il faut que tu joues avec la position de la souris dans son ensemble... à savoir ton Shape mais également son conteneur... Typiquement, pour ton resize de gauche... (enfin, moi, j'ferai comme ça en tout cas

) (et je plug les event du mousedown/move/up sur le shape et son parent)

Je te mets également la fonction contains... qui te permettra éventuellement de gérer tes zones différemment...

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
const
  BORDER = 5;
var
  inside  : TRect;
  posShape: Tpoint;
  posForm : Tpoint;
begin
  inside := Rect(BORDER, BORDER, Shape1.Width - (BORDER*2), Shape1.Height - (BORDER*2));
 
  GetCursorPos(posShape);
  posForm  := Self.ScreenToClient(posShape);  // Mettre le Parent de l'objet shape à la place de Self...
  posShape := Shape1.ScreenToClient(posShape);
 
  if inside.Contains(posShape) then
    Caption := 'in'
  else
    Caption := 'border';

**Whiler** · 13/10/2011, 11h54

Dans le genre... (ça peut s'optimiser... mais je trouve ça assez lisible comme ça...

)

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
unit main;
 
interface
 
uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.ExtCtrls, Vcl.StdCtrls, System.Math;
 
type
  TZone = (zN, zS, zW, zE, zNW, zNE, zSE, zSW, zInside, zOutside);
  TfrmMain = class(TForm)
    Shape1: TShape;
    img1: TImage;
    gbDetection: TGroupBox;
    procedure MouseDowns(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
    procedure FormCreate(Sender: TObject);
    procedure MouseUps(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
    procedure MouseMoves(Sender: TObject; Shift: TShiftState; X, Y: Integer);
  private
    { Private declarations }
    pInitialShape : TPoint;
    pInitialParent: TPoint;
    bResizing     : Boolean;
    bMoving       : Boolean;
    sCurrent      : TShape;
    zCurrent      : TZone;
 
    function  getZone(shape: TShape; var pShape, pParent: TPoint): TZone;
    procedure getMousePositions(shape: TShape; var pShape, pParent: TPoint);
  public
    { Public declarations }
  end;
 
var
  frmMain: TfrmMain;
 
implementation
 
{$R *.dfm}
 
procedure TfrmMain.getMousePositions(shape: TShape; var pShape, pParent: TPoint);
begin
  GetCursorPos(pShape);
  pParent := shape.Parent.ScreenToClient(pShape);
  pShape  := shape.ScreenToClient(pShape);
end;
 
function TfrmMain.getZone(shape: TShape; var pShape, pParent: TPoint): TZone;
const
  BORDER = 5;
begin
  getMousePositions(shape, pShape, pParent);
 
  if Rect(shape.Left, shape.Top, shape.Left + shape.Width, shape.Top + shape.Height).Contains(pParent) then
  begin
    // Pointeur sur la forme
    if Rect(0, 0, BORDER, BORDER).Contains(pShape) then
    begin
      shape.Cursor := crSizeNWSE;
      Exit(TZone.zNW);
    end
    else if Rect(BORDER, 0, shape.Width - (BORDER * 2), BORDER).Contains(pShape) then
    begin
      shape.Cursor := crSizeNS;
      Exit(TZone.zN);
    end
    else if Rect(shape.Width - BORDER, 0, shape.Width, BORDER).Contains(pShape) then
    begin
      shape.Cursor := crSizeNESW;
      Exit(TZone.zNE);
    end
    else if Rect(shape.Width - BORDER, BORDER, shape.Width, shape.Height - (BORDER * 2)).Contains(pShape) then
    begin
      shape.Cursor := crSizeWE;
      Exit(TZone.zE);
    end
    else if Rect(shape.Width - BORDER, shape.Height - BORDER, shape.Width, shape.Height).Contains(pShape) then
    begin
      shape.Cursor := crSizeNWSE;
      Exit(TZone.zSE);
    end
    else if Rect(BORDER, shape.Height - BORDER, shape.Width - (BORDER * 2), shape.Height).Contains(pShape) then
    begin
      shape.Cursor := crSizeNS;
      Exit(TZone.zS);
    end
    else if Rect(0, shape.Height - BORDER, BORDER, shape.Height).Contains(pShape) then
    begin
      shape.Cursor := crSizeNESW;
      Exit(TZone.zSW);
    end
    else if Rect(0, BORDER, BORDER, shape.Height - (BORDER * 2)).Contains(pShape) then
    begin
      shape.Cursor := crSizeWE;
      Exit(TZone.zW);
    end
    else
    begin
      shape.Cursor := crSize;
      Exit(TZone.zInside);
    end;
  end
  else
  begin
    Exit(TZone.zOutside);
  end;
end;
 
procedure TfrmMain.FormCreate(Sender: TObject);
begin
  bMoving   := False;
  bResizing := False;
  sCurrent  := nil;
end;
 
procedure TfrmMain.MouseDowns(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
  if Button = mbLeft then
  begin
    if Sender is TShape then
    begin
      sCurrent := Sender as TShape; // comme ça, il sera possible de définir plusieurs zones de détection...
      sCurrent.BringToFront;
      zCurrent := getZone(sCurrent, pInitialShape, pInitialParent);
      case zCurrent of
        zInside :
          begin
            bMoving   := True;
            bResizing := False;
          end;
        zOutside:
          begin
            bMoving   := False;
            bResizing := False;
          end;
        else
          begin
            bMoving   := False;
            bResizing := True;
          end;
      end;
    end
    else
    begin
      bMoving   := False;
      bResizing := False;
    end;
  end;
end;
 
procedure TfrmMain.MouseMoves(Sender: TObject; Shift: TShiftState; X, Y: Integer);
var
  pShapeCurrent : TPoint;
  pParentCurrent: TPoint;
  iXDelta       : Integer;
  iYDelta       : Integer;
begin
  if (Sender is TShape) and (sCurrent = nil) and not bResizing then
  begin
    sCurrent := Sender as TShape;
  end;
 
  if sCurrent <> nil then
  begin
    if bMoving then
    begin
      getMousePositions(sCurrent, pShapeCurrent, pParentCurrent);
      sCurrent.Left := sCurrent.Left + pShapeCurrent.X - pInitialShape.X;
      sCurrent.Top  := sCurrent.Top  + pShapeCurrent.Y - pInitialShape.Y;
    end
    else if bResizing then
    begin
      getMousePositions(sCurrent, pShapeCurrent, pParentCurrent);
      case zCurrent of
        zN:
        begin
          iYDelta          := pParentCurrent.Y - pInitialParent.Y;
          sCurrent.Top     := sCurrent.Top    + iYDelta;
          sCurrent.Height  := sCurrent.Height - iYDelta;
          pInitialParent.Y := pParentCurrent.Y;
        end;
        zS:
        begin
          iYDelta          := pParentCurrent.Y - pInitialParent.Y;
          sCurrent.Height  := sCurrent.Height  + iYDelta;
          pInitialParent.Y := pParentCurrent.Y;
        end;
        zW:
        begin
          iXDelta          := pParentCurrent.X - pInitialParent.X;
          sCurrent.Left    := sCurrent.Left  + iXDelta;
          sCurrent.Width   := sCurrent.Width - iXDelta;
          pInitialParent.X := pParentCurrent.X;
        end;
        zE:
        begin
          iXDelta          := pParentCurrent.X - pInitialParent.X;
          sCurrent.Width   := sCurrent.Width + iXDelta;
          pInitialParent.X := pParentCurrent.X;
        end;
        zNW:
        begin
          iXDelta          := pParentCurrent.X - pInitialParent.X;
          sCurrent.Left    := sCurrent.Left  + iXDelta;
          sCurrent.Width   := sCurrent.Width - iXDelta;
          pInitialParent.X := pParentCurrent.X;
          iYDelta          := pParentCurrent.Y - pInitialParent.Y;
          sCurrent.Top     := sCurrent.Top    + iYDelta;
          sCurrent.Height  := sCurrent.Height - iYDelta;
          pInitialParent.Y := pParentCurrent.Y;
        end;
        zNE:
        begin
          iXDelta          := pParentCurrent.X - pInitialParent.X;
          sCurrent.Width   := sCurrent.Width + iXDelta;
          pInitialParent.X := pParentCurrent.X;
          iYDelta          := pParentCurrent.Y - pInitialParent.Y;
          sCurrent.Top     := sCurrent.Top    + iYDelta;
          sCurrent.Height  := sCurrent.Height - iYDelta;
          pInitialParent.Y := pParentCurrent.Y;
        end;
        zSE:
        begin
          iXDelta          := pParentCurrent.X - pInitialParent.X;
          sCurrent.Width   := sCurrent.Width + iXDelta;
          pInitialParent.X := pParentCurrent.X;
          iYDelta          := pParentCurrent.Y - pInitialParent.Y;
          sCurrent.Height  := sCurrent.Height  + iYDelta;
          pInitialParent.Y := pParentCurrent.Y;
        end;
        zSW:
        begin
          iXDelta          := pParentCurrent.X - pInitialParent.X;
          sCurrent.Left    := sCurrent.Left  + iXDelta;
          sCurrent.Width   := sCurrent.Width - iXDelta;
          pInitialParent.X := pParentCurrent.X;
          iYDelta          := pParentCurrent.Y - pInitialParent.Y;
          sCurrent.Height  := sCurrent.Height  + iYDelta;
          pInitialParent.Y := pParentCurrent.Y;
        end;
      end;
    end
    else
    begin
      zCurrent := getZone(sCurrent, pShapeCurrent, pParentCurrent);
    end;
  end;
end;
 
procedure TfrmMain.MouseUps(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
  if bResizing and (sCurrent <> nil) then
  begin
    // On vérifie que la forme n'a pas été inversée...
    if sCurrent.Width < 0 then
    begin
      sCurrent.Left  := sCurrent.Left + sCurrent.Width;
      sCurrent.Width := Abs(sCurrent.Width);
    end;
    if sCurrent.Height < 0 then
    begin
      sCurrent.Top    := sCurrent.Top + sCurrent.Height;
      sCurrent.Height := Abs(sCurrent.Height);
    end;
  end;
 
  bMoving   := False;
  bResizing := False;
  sCurrent  := nil;
end;
 
end.

j'ai utilisé XE2... donc faire le ménage dans les uses, ...

**Whiler** · 13/10/2011, 13h01

Source :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
unit main;
 
interface
 
uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.ExtCtrls, Vcl.StdCtrls, System.Math;
 
type
  TZone = (zN, zS, zW, zE, zNW, zNE, zSE, zSW, zInside, zOutside);
  TfrmMain = class(TForm)
    img1: TImage;
    gbDetection: TGroupBox;
    pnlControls: TPanel;
    btnAdd: TButton;
    procedure MouseDowns(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
    procedure FormCreate(Sender: TObject);
    procedure MouseUps(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
    procedure MouseMoves(Sender: TObject; Shift: TShiftState; X, Y: Integer);
    procedure btnAddClick(Sender: TObject);
  private
    { Private declarations }
    pInitialShape : TPoint;
    pInitialParent: TPoint;
    bResizing     : Boolean;
    bMoving       : Boolean;
    sCurrent      : TShape;
    zCurrent      : TZone;
 
    function  getZone(shape: TShape; var pShape, pParent: TPoint): TZone;
    procedure getMousePositions(shape: TShape; var pShape, pParent: TPoint);
  public
    { Public declarations }
  end;
 
var
  frmMain: TfrmMain;
 
implementation
 
{$R *.dfm}
 
procedure TfrmMain.getMousePositions(shape: TShape; var pShape, pParent: TPoint);
begin
  GetCursorPos(pShape);
  pParent := shape.Parent.ScreenToClient(pShape);
  pShape  := shape.ScreenToClient(pShape);
end;
 
function TfrmMain.getZone(shape: TShape; var pShape, pParent: TPoint): TZone;
const
  BORDER = 5;
begin
  getMousePositions(shape, pShape, pParent);
 
  if Rect(shape.Left, shape.Top, shape.Left + shape.Width, shape.Top + shape.Height).Contains(pParent) then
  begin
    // Pointeur sur la forme
    if Rect(0, 0, BORDER, BORDER).Contains(pShape) then
    begin
      shape.Cursor := crSizeNWSE;
      Exit(TZone.zNW);
    end
    else if Rect(BORDER, 0, shape.Width - (BORDER * 2), BORDER).Contains(pShape) then
    begin
      shape.Cursor := crSizeNS;
      Exit(TZone.zN);
    end
    else if Rect(shape.Width - BORDER, 0, shape.Width, BORDER).Contains(pShape) then
    begin
      shape.Cursor := crSizeNESW;
      Exit(TZone.zNE);
    end
    else if Rect(shape.Width - BORDER, BORDER, shape.Width, shape.Height - (BORDER * 2)).Contains(pShape) then
    begin
      shape.Cursor := crSizeWE;
      Exit(TZone.zE);
    end
    else if Rect(shape.Width - BORDER, shape.Height - BORDER, shape.Width, shape.Height).Contains(pShape) then
    begin
      shape.Cursor := crSizeNWSE;
      Exit(TZone.zSE);
    end
    else if Rect(BORDER, shape.Height - BORDER, shape.Width - (BORDER * 2), shape.Height).Contains(pShape) then
    begin
      shape.Cursor := crSizeNS;
      Exit(TZone.zS);
    end
    else if Rect(0, shape.Height - BORDER, BORDER, shape.Height).Contains(pShape) then
    begin
      shape.Cursor := crSizeNESW;
      Exit(TZone.zSW);
    end
    else if Rect(0, BORDER, BORDER, shape.Height - (BORDER * 2)).Contains(pShape) then
    begin
      shape.Cursor := crSizeWE;
      Exit(TZone.zW);
    end
    else
    begin
      shape.Cursor := crSize;
      Exit(TZone.zInside);
    end;
  end
  else
  begin
    Exit(TZone.zOutside);
  end;
end;
 
procedure TfrmMain.btnAddClick(Sender: TObject);
const
  DEFAULT_SIZE = 50;
var
  oneShape: TShape;
begin
  oneShape             := TShape.Create(Self);
  oneShape.Parent      := gbDetection;
  oneShape.Width       := DEFAULT_SIZE;
  oneShape.Height      := DEFAULT_SIZE;
  oneShape.Left        := (gbDetection.Width  - DEFAULT_SIZE) div 2;
  oneShape.Top         := (gbDetection.Height - DEFAULT_SIZE) div 2;
  oneShape.Brush.Color := RandomRange(0, 2147483647);
  oneShape.OnMouseDown := MouseDowns;
  oneShape.OnMouseMove := MouseMoves;
  oneShape.OnMouseUp   := MouseUps;
end;
 
procedure TfrmMain.FormCreate(Sender: TObject);
begin
  bMoving   := False;
  bResizing := False;
  sCurrent  := nil;
end;
 
procedure TfrmMain.MouseDowns(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
  if Button = mbLeft then
  begin
    if Sender is TShape then
    begin
      sCurrent := Sender as TShape; // comme ça, il sera possible de définir plusieurs zones de détection...
      sCurrent.BringToFront;
      zCurrent := getZone(sCurrent, pInitialShape, pInitialParent);
      case zCurrent of
        zInside :
          begin
            bMoving   := True;
            bResizing := False;
          end;
        zOutside:
          begin
            bMoving   := False;
            bResizing := False;
          end;
        else
          begin
            bMoving   := False;
            bResizing := True;
          end;
      end;
    end
    else
    begin
      bMoving   := False;
      bResizing := False;
    end;
  end;
end;
 
procedure TfrmMain.MouseMoves(Sender: TObject; Shift: TShiftState; X, Y: Integer);
var
  pShapeCurrent : TPoint;
  pParentCurrent: TPoint;
  iXDelta       : Integer;
  iYDelta       : Integer;
begin
  if (Sender is TShape) and (sCurrent = nil) and not bResizing then
  begin
    sCurrent := Sender as TShape;
  end;
 
  if sCurrent <> nil then
  begin
    if bMoving then
    begin
      getMousePositions(sCurrent, pShapeCurrent, pParentCurrent);
      sCurrent.Left := sCurrent.Left + pShapeCurrent.X - pInitialShape.X;
      sCurrent.Top  := sCurrent.Top  + pShapeCurrent.Y - pInitialShape.Y;
    end
    else if bResizing then
    begin
      getMousePositions(sCurrent, pShapeCurrent, pParentCurrent);
      case zCurrent of
        zN:
        begin
          iYDelta          := pParentCurrent.Y - pInitialParent.Y;
          sCurrent.Top     := sCurrent.Top    + iYDelta;
          sCurrent.Height  := sCurrent.Height - iYDelta;
          pInitialParent.Y := pParentCurrent.Y;
        end;
        zS:
        begin
          iYDelta          := pParentCurrent.Y - pInitialParent.Y;
          sCurrent.Height  := sCurrent.Height  + iYDelta;
          pInitialParent.Y := pParentCurrent.Y;
        end;
        zW:
        begin
          iXDelta          := pParentCurrent.X - pInitialParent.X;
          sCurrent.Left    := sCurrent.Left  + iXDelta;
          sCurrent.Width   := sCurrent.Width - iXDelta;
          pInitialParent.X := pParentCurrent.X;
        end;
        zE:
        begin
          iXDelta          := pParentCurrent.X - pInitialParent.X;
          sCurrent.Width   := sCurrent.Width + iXDelta;
          pInitialParent.X := pParentCurrent.X;
        end;
        zNW:
        begin
          iXDelta          := pParentCurrent.X - pInitialParent.X;
          sCurrent.Left    := sCurrent.Left  + iXDelta;
          sCurrent.Width   := sCurrent.Width - iXDelta;
          pInitialParent.X := pParentCurrent.X;
          iYDelta          := pParentCurrent.Y - pInitialParent.Y;
          sCurrent.Top     := sCurrent.Top    + iYDelta;
          sCurrent.Height  := sCurrent.Height - iYDelta;
          pInitialParent.Y := pParentCurrent.Y;
        end;
        zNE:
        begin
          iXDelta          := pParentCurrent.X - pInitialParent.X;
          sCurrent.Width   := sCurrent.Width + iXDelta;
          pInitialParent.X := pParentCurrent.X;
          iYDelta          := pParentCurrent.Y - pInitialParent.Y;
          sCurrent.Top     := sCurrent.Top    + iYDelta;
          sCurrent.Height  := sCurrent.Height - iYDelta;
          pInitialParent.Y := pParentCurrent.Y;
        end;
        zSE:
        begin
          iXDelta          := pParentCurrent.X - pInitialParent.X;
          sCurrent.Width   := sCurrent.Width + iXDelta;
          pInitialParent.X := pParentCurrent.X;
          iYDelta          := pParentCurrent.Y - pInitialParent.Y;
          sCurrent.Height  := sCurrent.Height  + iYDelta;
          pInitialParent.Y := pParentCurrent.Y;
        end;
        zSW:
        begin
          iXDelta          := pParentCurrent.X - pInitialParent.X;
          sCurrent.Left    := sCurrent.Left  + iXDelta;
          sCurrent.Width   := sCurrent.Width - iXDelta;
          pInitialParent.X := pParentCurrent.X;
          iYDelta          := pParentCurrent.Y - pInitialParent.Y;
          sCurrent.Height  := sCurrent.Height  + iYDelta;
          pInitialParent.Y := pParentCurrent.Y;
        end;
      end;
    end
    else
    begin
      zCurrent := getZone(sCurrent, pShapeCurrent, pParentCurrent);
    end;
  end;
end;
 
procedure TfrmMain.MouseUps(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
  if bResizing and (sCurrent <> nil) then
  begin
    // On vérifie que la forme n'a pas été inversée...
    if sCurrent.Width < 0 then
    begin
      sCurrent.Left  := sCurrent.Left + sCurrent.Width;
      sCurrent.Width := Abs(sCurrent.Width);
    end;
    if sCurrent.Height < 0 then
    begin
      sCurrent.Top    := sCurrent.Top + sCurrent.Height;
      sCurrent.Height := Abs(sCurrent.Height);
    end;
  end;
 
  bMoving   := False;
  bResizing := False;
  sCurrent  := nil;
end;
 
end.

DFM :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
object frmMain: TfrmMain
  Left = 0
  Top = 0
  Caption = 'frmMain'
  ClientHeight = 511
  ClientWidth = 775
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'Tahoma'
  Font.Style = []
  OldCreateOrder = False
  OnCreate = FormCreate
  OnMouseMove = MouseMoves
  OnMouseUp = MouseUps
  PixelsPerInch = 96
  TextHeight = 13
  object gbDetection: TGroupBox
    Left = 0
    Top = 0
    Width = 775
    Height = 470
    Align = alClient
    Caption = 'gbDetection'
    TabOrder = 0
    OnMouseDown = MouseDowns
    OnMouseMove = MouseMoves
    OnMouseUp = MouseUps
    ExplicitLeft = 24
    ExplicitTop = 32
    ExplicitWidth = 185
    ExplicitHeight = 105
    object img1: TImage
      Left = 2
      Top = 15
      Width = 771
      Height = 453
      Align = alClient
      OnMouseDown = MouseDowns
      OnMouseMove = MouseMoves
      OnMouseUp = MouseUps
      ExplicitLeft = 40
      ExplicitTop = 16
      ExplicitWidth = 529
      ExplicitHeight = 297
    end
  end
  object pnlControls: TPanel
    Left = 0
    Top = 470
    Width = 775
    Height = 41
    Align = alBottom
    ShowCaption = False
    TabOrder = 1
    ExplicitLeft = 232
    ExplicitTop = 168
    ExplicitWidth = 185
    DesignSize = (
      775
      41)
    object btnAdd: TButton
      Left = 343
      Top = 8
      Width = 89
      Height = 25
      Anchors = [akBottom]
      Caption = 'Ajouter zone'
      TabOrder = 0
      OnClick = btnAddClick
    end
  end
end

**[ZiP]** · 13/10/2011, 16h13

Bonjour Whiler,

Je n'arrive pas à faire fonctionner votre code sous Delphi XE, il me met une erreur au niveau de "Contains".

Je vais par contre m'inspirer de votre méthode.

Pouvez-vous me commenter un petit peu celui-ci car je suis un petit peu perdu ?

Merci,
ZiP