[D7] Problème de position du pointeur de la souris

**Charly910** · 06/12/2019, 15h42

Bonjour,

je galère depuis un petit moment sur ce problème :

je veux faire un zoom sur un Timage, en traçant un rectangle de sélection à la souris.

Dans la petite appli de test jointe, à la première sélection (bouton gauche) tout se passe bien et ma partie d'image zoomée s'affiche bien.

à la seconde sélection, la souris ne suit pas le coin inférieur droit du rectangle de sélection. Il y a un décalage et au relachement du bouton, le zoom s'affiche mal.

J'ai vu que le problème vient de la fonction RetailleImage. Mais si je l'enlève, le zoom est déformé.

Image3.zip

Si quelqu'un a une idée ...

Merci

A+
Charly

**ALWEBER** · 06/12/2019, 15h54

Peut être :

Code :

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

1
2
3
4
5
6
7
8
 
procedure TF_Image2.FormCreate(Sender: TObject);
begin
  Image1.AutoSize := False ;
  Image1.Stretch := false ;
  FicSelec := ExtractFilePath(Application.ExeName)+'\cc_001833.jpg' ;
  jpg := TJpegImage.Create ;
end;

**Charly910** · 06/12/2019, 16h30

Merci Alweber,

oui, effectivement, cela résout le problème du pointeur de la souris, mais maintenant ce n'est plus la bonne partie d'image qui est recopiée à chaque zoom ...

A+
Charly

**Charly910** · 06/12/2019, 16h42

C'est sûrement Stretch qui change les coordonnées dans l'image et sa taille, mais je n'arrive pas à m'en sortir !

A+
Charly

**ALWEBER** · 06/12/2019, 16h58

Envoyé par Charly910

C'est sûrement Stretch qui change les coordonnées dans l'image et sa taille, mais je n'arrive pas à m'en sortir !

A+
Charly

Chez moi cela se passe bien. Je suis sous XE7

**Andnotor** · 06/12/2019, 17h02

Bien sûr que c'est ces stretch multiples qui posent problème.

CopyRect fait déjà un stretch. A moins d'avoir un rectangle de sélection d'exactement le même rapport largeur/hauteur que l'image, CopyRect va la déformer (en hauteur ou en largeur).
Tu retailles ensuite le TImage (en mode stretch) pour retomber sur tes pieds mais ce n'est que de l'affichage, derrière le bitmap est toujours déformé et un pixel-écran ne correspond plus à un pixel-bitmap. Ton dessin basé sur la position de la souris est dans les choux.

Tu devrais travailler sur un bitmap en mémoire.

**Charly910** · 06/12/2019, 17h19

Ok Andnotor, je vais travailler sur un bitmap en mémoire.

Mais j'ai trouvé une solution boiteuse. Si je fais :

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
{ ========================================================================== }
procedure TF_Image2.Image1MouseUp(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
// Efface le rectangle de sélection et redessine l'image zoomée
Var
  R1 : TRect ;
  R2 : TRect ;
begin
  if (Button = mbLEFT) then
    Begin
      DessineRECT;
      R1 := MakeRect(PtDepart, PtArrivee) ;
      R2 := Retaille(R1, Image1.BoundsRect) ;
      Image1.Stretch := False ;
      RetailleImage(R2) ;
      image1.Canvas.CopyRect(image1.ClientRect, image1.Canvas, R1);
      CentrerImage ;
      FSelecting := False ;
    End ;
end;
{ ========================================================================== }

ça marche impeccable !

je vais essayer toutefois une solution plus propre ...

Merci

A+
Charly

**Charly910** · 06/12/2019, 19h14

J'ai fait ceci. Est ce que c'est correct ?

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
{ ========================================================================== }
procedure TF_Image2.Image1MouseUp(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
// Efface le rectangle de sélection et redessine l'image zoomée
Var
  R1 : TRect ;
  R2 : TRect ;
  Bmp  : TBitMap ;
  Bmp2 : TBitMap ;
begin
  if (Button = mbLeft) then
    Begin
      DessineRECT;
      R1 := MakeRect(PtDepart, PtArrivee) ;
      R2 := Retaille(R1, Image1.BoundsRect) ;
      Bmp := TBitmap.Create;
      Bmp2 := TBitmap.Create;
      Try
        Bmp.Assign(Image1.Picture.Graphic);
        Bmp2.Width := R2.Right - R2.Left ;
        Bmp2.Height := R2.Bottom - R2.Top ;
        Bmp2.Canvas.CopyRect(Bmp2.Canvas.ClipRect, Bmp.Canvas, R1);
        Image1.Picture := Nil ;
        Image1.Height := Bmp2.Height ;
        Image1.Width := Bmp2.Width ;
        Image1.Canvas.Draw(0, 0, Bmp2);
        CentrerImage ;
      Finally
        Bmp.Free;
        Bmp2.Free;
      End ;
 
    End ;
end;
{ ========================================================================== }

Maintenant, il faut que je modifie, car au fur et à mesure des zoom, l'image est de plus en plus petite !

A+
Charly

**Charly910** · 07/12/2019, 18h03

Bonjour,

je suis arrivé à une solution satisfaisante. L'image zoomée conserve la taille de l'image originale et les proportions sont conservées. La nouvelle fonction de calcul due rectangle de sélection RetailleSel et un peu fouillis, mais bon, ça marche.

Voici les fonctions à intégrer dans l'appli des test :

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
procedure TF_Image2.Image1MouseUp(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
// Efface le rectangle de sélection et redessine l'image zoomée
Var
  R1 : TRect ;   //  Rectangle de sélection
  R2 : TRect ;       //  Rectangle de sélection adapté aux dimensions de Image1
  Bmp  : TBitMap ;
  Bmp2 : TBitMap ;
begin
  if (Button = mbLeft) then
    Begin
      DessineRECT;
      R1 := MakeRect(PtDepart, PtArrivee) ;
      PtDepart := R1.TopLeft ;
      PtArrivee := R1.BottomRight ;
      R1 := RetailleSel(R1, Image1.BoundsRect) ;
      R2 := Image1.BoundsRect ;
      Bmp := TBitmap.Create;
      Bmp2 := TBitmap.Create;
      Try
        Bmp.Assign(Image1.Picture.Graphic);
        Bmp2.Width := R2.Right - R2.Left ;
        Bmp2.Height := R2.Bottom - R2.Top ;
        Bmp2.Canvas.CopyRect(Bmp2.Canvas.ClipRect, Bmp.Canvas, R1);
        Image1.Picture := Nil ;
        Image1.Height := Bmp2.Height ;
        Image1.Width := Bmp2.Width ;
        Image1.Canvas.Draw(0, 0, Bmp2);
        CentrerImage ;
        FSelecting := False ;
      Finally
        Bmp.Free;
        Bmp2.Free;
      End ;
    End ;
end;
{ ========================================================================== }
Function TF_Image2.RetailleSel(R1, R2 : TRect): TRect;
// R1 rectangle de sélection  R2 Rectangle de Image1
// Retaille R1 pour être proportionnel à R2 et
//  modifie PtDepart et PtArrivee pour rester dans R2
//  PtDepart et PtArrivee ==> Rect resultat
Var
  W1, H1, W2, H2 : Integer ;
  W, H : Integer ; // Dimensions du nouveau rectangle de sélection R
  Y : Real ;
  R, RP : Real ;
  DX, DY : Integer ;
Begin
  W1 := R1.Right - R1.Left ;
  H1 := R1.Bottom - R1.Top ;
  W2 := R2.Right - R2.Left ;
  H2 := R2.Bottom - R2.Top ;
  R := W2 / W1 ;
  RP := H2 / H1 ;
  W := W1 ;
  H := H1 ;
  If R <= RP Then
    Begin
      // Expansion de R1 dans Image1 suivant W
      H := Round(H2 * W1 / W2) ;
      W := W1 ;
      DY := Round((H - H1) / 2) ;
 
      If (PtDepart.Y -DY) < 0 Then
        Begin
          // Rectangle trop haut
          PtDepart.Y := 0 ;
          PtArrivee.Y := H ;
        End
      Else
        Begin
          If (PtArrivee.Y + DY) > H2 Then
            Begin
              // Rectangle trop bas
              PtArrivee.Y := H2 ;
              PtDepart.Y := H2 - H ;
            End
          Else
            Begin
              // Rectangle contenu dans Image1
              PtDepart.Y := PtDepart.Y - DY ;
              PtArrivee.Y := PtArrivee.Y + DY ;
            End ;
        End ;
    End
  Else
    Begin
      // Expansion de R1 dans Image1 suivant H
      W := Round(W2 * H1 / H2) ;
      H := H1 ;
      DX := Round((W - W1) / 2) ;
      If (PtDepart.X -DX) < 0 Then
        Begin
          // Rectangle trop à gauche
          PtDepart.X := 0 ;
          PtArrivee.X := W ;
        End
      Else
        Begin
          If (PtArrivee.X + DX) > W2 Then
            Begin
              // Rectangle trop à droite
              PtArrivee.X := W2 ;
              PtDepart.X := W2 - W ;
            End
          Else
            Begin
              // Rectangle contenu dans Image1
              PtDepart.X := PtDepart.X - DX ;
              PtArrivee.X := PtArrivee.X + DX ;
            End ;
        End ;
    End ;
  Result := Rect(PtDepart.x,PtDepart.Y, PtArrivee.X,PtArrivee.Y) ;
End ;
{ ========================================================================== }

A+
Charly

[D7] Problème de position du pointeur de la souris

Delphi

Discussions similaires

Partager

Partager