Discussion :

[Jipété]

Bonsoir,

yes, it's me again.

Quelqu'un en 2011 a posté un truc léger (j'aime !) que j'ai voulu tester, et mal m'en a pris, ça va encore me (nous !) faire perdre un temps considérable, je crois.

Parce que, autant le code est court (9^e post de cette page, auteur gyts) :

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
var
  Form1: TForm1;
  i, r: TRect;
  x, y, xx, yy: integer;
 
implementation
 
procedure TForm1.FormCreate(Sender: TObject);
begin
  {$IFDEF LINUX}
  Image.Picture.LoadFromFile ('/chemin/Programmation/bmp4test.jpg');
  {$ELSE}
  Image.Picture.LoadFromFile ('\\chemin\Programmation\bmp4test.jpg');
  {$ENDIF}
  y := 0;
  x := 0;
  xx := Bckg.Width;
  yy := Bckg.Height;
  r.Top := y; r.Left := x; r.Right := xx; r.Bottom := yy;
  i.Top := 0;
  i.Left := 0;
  i.Right := Image.Width;
  i.Bottom := Image.Height;
  Bckg.Canvas.CopyRect(r, Image.Picture.Bitmap.Canvas, i);
end;
 
procedure TForm1.TBChange(Sender: TObject);
begin
  r.Top    := trunc(y  * TB.Position / 100);
  r.Left   := trunc(x  * TB.Position / 100);
  r.Right  := trunc(xx * TB.Position / 100);
  r.Bottom := trunc(yy * TB.Position / 100);
  Bckg.Canvas.CopyRect(r, Image.Picture.Bitmap.Canvas, i);
end;

autant les résultats sont rocambolesques !

Sous XP, en jouant avec le curseur :


Sous Linux, pas besoin de mettre une image, il n'y a aucun changement de taille en manipulant le curseur.

Est-ce que vous pensez que chez l'OP ce code a fonctionné ?
Si oui, que faire pour qu'il fonctionne en 2017 ?

[Andnotor]

Il n'y a pas de reset du fond, normal que l'ancienne image subsiste. Et si tu minimises/maximises la fiche, elle sera vide !

CopyRect dans OnCreate ne sert à rien, la fiche sera invalidée à l'affichage.

Il faut invalider le PaintBox dans TBChange et ensuite laisser faire la nature (WM_ERASEBKGND, WM_PAINT)

Code :

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

1
2
3
4
5
6
7
8
9
10
11
12
13
14
procedure TForm1.TBChange(Sender: TObject);
begin
  r.Top    := trunc(y  * TB.Position / 100);
  r.Left   := trunc(x  * TB.Position / 100);
  r.Right  := trunc(xx * TB.Position / 100);
  r.Bottom := trunc(yy * TB.Position / 100);
 
  Bckg.Invalidate;
end;
 
procedure TForm1.BckgPaint(Sender: TObject);
begin
  Bckg.Canvas.CopyRect(r, Image.Picture.Bitmap.Canvas, i);
end;

Mais ça entraînera un léger scintillement.
Pour palier à cela, tu peux aussi te charger de l'effacement des zones "mortes" mais dans tous les cas, OnPaint doit subsister (traitement des rafraîchissements demandés par l'OS).

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
procedure TForm1.TBChange(Sender: TObject);
var
  Rx :TRect;
begin
  r.Top    := trunc(y  * TB.Position / 100);
  r.Left   := trunc(x  * TB.Position / 100);
  r.Right  := trunc(xx * TB.Position / 100);
  r.Bottom := trunc(yy * TB.Position / 100);
 
  Bckg.Canvas.CopyRect(r, Image1.Picture.Bitmap.Canvas, i);
 
  Bckg.Canvas.Brush.Color := Color;
 
  Rx := i;
  Rx.Left := r.Right;
  Bckg.Canvas.FillRect(Rx);
 
  Rx := i;
  Rx.Top := r.Bottom;
  Bckg.Canvas.FillRect(Rx);
 
  //Bckg.Invalidate;
end;
 
procedure TForm1.BckgPaint(Sender: TObject);
begin
  Bckg.Canvas.CopyRect(r, Image.Picture.Bitmap.Canvas, i);
end;

[Jipété]

Il n'y a pas de reset du fond, normal que l'ancienne image subsiste. Et si tu minimises/maximises la fiche, elle sera vide !

CopyRect dans OnCreate ne sert à rien, la fiche sera invalidée à l'affichage.

Il faut invalider le PaintBox dans TBChange et ensuite laisser faire la nature (WM_ERASEBKGND, WM_PAINT)

OMG que de corrections et commentaires ! C'est fou que j'ai pu trouver ce post en ligne sans que personne ne s'en plaigne...

Le bon code c'est celui-ci :

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
procedure TForm1.TBChange(Sender: TObject);
var
  Rx :TRect;
begin
  r.Top    := trunc(y  * TB.Position / 100);
  r.Left   := trunc(x  * TB.Position / 100);
  r.Right  := trunc(xx * TB.Position / 100);
  r.Bottom := trunc(yy * TB.Position / 100);
 
  Bckg.Canvas.CopyRect(r, Image1.Picture.Bitmap.Canvas, i);
 
  Bckg.Canvas.Brush.Color := Color;
 
  Rx := i;
  Rx.Left := r.Right;
  Bckg.Canvas.FillRect(Rx);
 
  Rx := i;
  Rx.Top := r.Bottom;
  Bckg.Canvas.FillRect(Rx);
 
  //Bckg.Invalidate;
end;
 
procedure TForm1.BckgPaint(Sender: TObject);
begin
  Bckg.Canvas.CopyRect(r, Image.Picture.Bitmap.Canvas, i);
end;

Bien joué !


Question subsidiaire, relative au code que tu fournis. Si je fais :

Code :

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

1
2
3
4
5
6
7
  Rx := i;
  Rx.Left := r.Right;
//  Bckg.Canvas.FillRect(Rx);
 
//  Rx := i;
  Rx.Top := r.Bottom;
  Bckg.Canvas.FillRect(Rx);

je gagne cette horreur en déplaçant le curseur :


Pourquoi ? Les lignes que j'ai commentées me semblent redondantes en première lecture

[Andnotor]

Ben non, elles ne le sont pas (si ce n'est que le rectangle en bas à droite est rempli deux fois).

Si tu fixes le TopLeft à effacer au BottomRight de l'image, les zones directement à sa droite et en dessous ne sont pas touchées.

Il est possible de faire ça en une passe mais ça implique de travailler avec des régions :

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
procedure TForm1.TBChange(Sender: TObject);
var
  Rgn1, Rgn2 :hRgn;
begin
  r.Top    := trunc(y  * TB.Position / 100);
  r.Left   := trunc(x  * TB.Position / 100);
  r.Right  := trunc(xx * TB.Position / 100);
  r.Bottom := trunc(yy * TB.Position / 100);
 
  Bckg.Canvas.CopyRect(r, Image1.Picture.Bitmap.Canvas, i);
 
  //Région PaintBox complet
  with i do Rgn1 := CreateRectRgn(Left, Top, Right, Bottom);
 
  //Région Image
  with r do Rgn2 := CreateRectRgn(Left, Top, Right, Bottom);
 
  //Supprime la région Image (Rgn2) de celle du PaintBox (Rgn1)
  //Le résultat est placé dans Rgn1. Rgn1 devient un polygone
  CombineRgn(Rgn1, Rgn1, Rgn2, RGN_XOR);
 
  FillRgn(Bckg.Canvas.Handle, Rgn1, Canvas.Brush.Handle);
 
  //Décommente ces deux ligne pour "voir" la région
//  Bckg.Canvas.Brush.Color := clRed;
//  FrameRgn(Bckg.Canvas.Handle, Rgn1, Bckg.Canvas.Brush.Handle, 1, 1);
 
  DeleteObject(Rgn1);
  DeleteObject(Rgn2);
end;

On pourrait aussi créer directement la région polygonale par CreatePolygonRegion.

[Jipété]

Code :

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

1
2
3
  //Décommente ces deux lignes pour "voir" la région
  Bckg.Canvas.Brush.Color := clRed;
  FrameRgn(Bckg.Canvas.Handle, Rgn1, Bckg.Canvas.Brush.Handle, 1, 1);

Ben je verrai rien du tout pour la bonne et simple raison que mon Lazarus ne connaît pas FrameRgn...

Déjà qu'il lui a fallu 2 uses pour avoir droit aux régions : uses LCLIntf, LCLType; // 2 pour Region !...

M'en suis sorti comme ça :

Code :

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

1
2
3
4
  //Décommente ces deux lignes pour "voir" la région
  Bckg.Canvas.Brush.Color := clRed;
//  FrameRgn(Bckg.Canvas.Handle, Rgn1, Bckg.Canvas.Brush.Handle, 1, 1);
  FillRgn(Bckg.Canvas.Handle, Rgn1, Bckg.Canvas.Brush.Handle);

Ça donne ça, c'est bien, on comprend tout ! Y a un peu de flicker mais c'est pas bien grave.

On pourrait aussi créer directement la région polygonale par CreatePolygonRegion.

Compliquons pas les choses, pas sûr que ça soit connu : quand je tape CreatePolygonRegion( l'EDI ne me propose pas la liste des paramètres...

Merci pour ces précisions, merci pour ce dernier bout de code.