Dessiner un rectangle de sélection sur un composant graphique

Version imprimable

1 pièce(s) jointe(s)

Bonjour,

Il y a une dizaine d'années, j'avais récupéré le code suivant pour sélectionner une partie d'une image dans un programme conçu sous Delphi 5 :
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 procedure MovingDots(X, Y: Integer; ACanvas: TCanvas); stdcall; begin {$R-} Counter := Counter shl 1; // Shift the bit left one {$R+} if Counter = 0 then Counter := 1; // If it shifts off left, reset it if (Counter and 224) > 0 then // Are any of the left 3 bits set? ACanvas.Pixels[X, Y] := clWhite // Erase the pixel else ACanvas.Pixels[X, Y] := clBlack; // Draw the pixel end; procedure TFiche.DrawAntsRect; begin // Determines starting pixel color of Rect Counter := CounterStart; // Dessin des 4 cotés du rectangle de sélection LineDDA(X1, Y1, X2, Y1, @MovingDots, LongInt(targetCanvas)); LineDDA(X2, Y1, X2, Y2, @MovingDots, LongInt(targetCanvas)); LineDDA(X2, Y2, X1, Y2, @MovingDots, LongInt(targetCanvas)); LineDDA(X1, Y2, X1, Y1, @MovingDots, LongInt(targetCanvas)); end;
Ce code me permettait d'obtenir l'effet connu sous le nom de "marching ants", reproduit sur l'image ci-contre : Pièce jointe 435244

La procédure principale DrawAntsRect faisait appel à une autre procédure, LineDDA, dépendante de l'unité Windows.
Aujourd'hui, je voudrais pouvoir reproduire cet effet sans être dépendant du système d'exploitation sous-jacent.
Cela est-il possible, et comment ?
Merci d'avance pour votre aide.

Salut

Il n'y pas de grosse modification : il suffit de réécrire la fonction lineDDA, ce qui devrait te donner un truc du genre :

Code:

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
Type 
  TLINEDDAPROC = Procedure (X, Y: Integer; ACanvas: TCanvas); stdcall;
 
 
Function LineDDA	(nXStart,nYStart,nXEnd,nYEnd : Integer;callback : TLINEDDAPROC;LParam: Longint ) : Boolean
var
   xadd , yadd : Integer;
   err,erradd : Integer;
   cnt : Integer;
   dx, dy : Integer;
begin
  Result := False;
  xadd := 1;
  yadd := 1;
  dx := nXEnd - nXStart;
  dy := nYEnd - nYStart;
 ////////////////
  if (dx < 0) Then 
  begin
    dx   := -dx;
    xadd := -1;
  end;
  ////////////////
  if (dy < 0) Then 
  begin
    dy   := -dy;
    yadd := -1;
  end;
  ////////////////
  if (dx > dy)  (* line is "more horizontal" *)
  begin
    err    := 2*dy - dx;
    erradd := 2*dy - 2*dx;
    for cnt := 0 to dx do 
	begin
      callback(nXStart,nYStart,lParam);
      if (err > 0) Then 
      begin
        nYStart :=  nYStart +yadd;
        err      := err +erradd;
      end 
      else 
	    err := err +2*dy;
      nXStart += xadd;
    end;
  end
  else   (* line is "more vertical" *)
  begin
    err    := 2*dx - dy;
    erradd := 2*dx - 2*dy;
    for cnt := 0 to dy do 
	begin
      callback(nXStart,nYStart,lParam);
      if (err > 0) then
      begin
        nXStart := nXStart +xadd;
        err     := err +erradd;
      end
      else 
	    err := err +2*dx;
      nYStart := nYStart +yadd;
    end;
  end;
  Result := TRUE;
end;

19/12/2018, 18h02
Péhelji

Bonjour anapurna,

Et merci pour ton bout de code qui me dessine bien un rectangle de sélection imitation "marching ants".
Je peux même dire qu'il m'en dessine plusieurs, puisque je le place, comme initiallement, dans l'évènement OnMouseMove du contrôle graphique.
Or, il faudrait que je puisse supprimer les rectangles dessinés lors du déplacement pour ne conserver que le dernier.
T'aurais une idée sur la façon d'y arriver ?

salut

tu faisais comment avant ?

normalement le principe pour faire déplacer un objet il faut redessiner à l'ancienne position pour effacer et ensuite dessiner à la nouvelle

voici la méthode que j'utiliserais

Code:

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
 
     procedure Drawselect(RCT : TRect;CVS : TCanvas);
      var 
	    Old_BS : TBrushStyle;
        Old_PS : TPenStyle;
        Old_PM : TPenMode;
      begin
        ///////////////////////////////
		/// on concerve les options 
        //////////////////////////////		
        Old_BS := CVS.Brush.Style;
        Old_PS := CVS.Pen.Style;
        Old_PM := CVS.Pen.Mode;
        ///////////////////////////////
	/// on efface 
        //////////////////////////////		
        CVS.Brush.Style := bsClear;
        CVS.Pen.Style   := psDot;
        CVS.Pen.Mode    := pmNot;
        CVS.Rectangle(RCT);
        ///////////////////////////////
	/// on remet les options 
        //////////////////////////////		
        CVS.Brush.Style := Old_BS;
        CVS.Pen.Style   := Old_PS;
        CVS.Pen.Mode   := Old_PM;
      end;

Bonsoir anapurna,

En mettant en pratique tes suggestions, je suis bien parvenu à "supprimer les rectangles dessinés lors du déplacement pour ne conserver que le dernier" et je t'en remercie.

Par contre, une fois le dernier tracé finalisé, il n'est pas évident de :

Citation:

Envoyé par anapurna

redessiner à l'ancienne position pour effacer et ensuite dessiner à la nouvelle.

Il faut assurer la persistance des coordonnées dans une variable TRect de portée globale. J'ai essayé et le résultat obtenu, peut-être maladroitement, ne m'a pas convaincu.
Aussi j'ai opté pour l'activation ou non d'un dessin final dans l'évènement OnMouseUp, selon l'utilisation souhaitée de la sélection.

En voici la synthèse :

Code:

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
 
procedure TfrmMap.DessineRectangle(AMode: TPenMode);
begin
  targetCanvas.Pen.Mode := AMode;
  targetCanvas.Frame(X1, Y1, X2, Y2);
end;
 
procedure TfrmMap.bgraMainMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
  oldPM := targetCanvas.Pen.Mode;
  oldPS := targetCanvas.Pen.Style;
 
  if (ssLeft in Shift) and (ssShift in Shift) then
     begin
      // Coordonnées de départ
      X := X + (Sender as TBGRAGraphicControl).Left;
      Y := Y + (Sender as TBGRAGraphicControl).Top;
      X1 := X; Y1 := Y; 
      X2 := X; Y2 := Y;
      zoneSelected := true;
     end;
end;
 
procedure TfrmMap.bgraMainMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
begin
  if zoneSelected and (ssLeft in Shift) and (ssShift in Shift) then
     begin
       targetCanvas.Pen.Style := psDot;
 
       // Effacer la précédente sélection
       DessineRectangle(pmNot);
 
       // Coordonnées lors du déplacement
       X2 := X + (Sender as TBGRAGraphicControl).Left;
       Y2 := Y + (Sender as TBGRAGraphicControl).Top;
 
       // Dessiner la nouvelle sélection
       DessineRectangle(pmNot);
     end;
end;
 
procedure TfrmMap.bgraMainMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
  if zoneSelected then
  begin
    DessineRectangle(pmNot); // Persistance du tracé si désactivé
 
    zoneSelected := false;
    targetCanvas.Pen.Mode := oldPM;
    targetCanvas.Pen.Style := oldPS;
  end;
end;