Comment effacer un TForm ?

**TheFreeBerga** · 03/09/2014, 19h48

Bonjour @ toutes & tous,

Mon problème n'est malheureusement pas aussi simple que le titre pourrait le laisser penser...

Le projet en question n'est qu'un petit outil pour moi-même et uniquement, sans aucune prétention d'aucune sorte et j'ai donc cherché le moyen le plus simple mais pas le plus élégant pour atteindre mon but.
C'est presque réussi à un détail près...
L'idée est la suivante: je veux dessiner un nombre quelconque (inconnu au départ) d'objets qui vont être relié entre eux par un ou plusieurs traits que j'ai nommé "connecteur".
Dans mon fameux souci de simplicité d'écriture, j'ai trouvé la solution suivante: utiliser des objets de type TShape que je crée sur un TForm lui-même embarqué dans le TForm de l'application principale. Le truc c'est que si je dessine un TShape au delà de la surface visible sur le TForm2, celui-ci va se redimensionner automatiquement ! Autre simplicité de la chose, un TShape sait se redessiner tout seul lors d'un déplacement.
Ah oui, j'ai oublié de dire que les TShapes doivent pouvoir être déplacé à la souris.
Tout ça, j'ai réussi à le faire, le seul problème qui me reste, c'est dessiner les connecteurs. Je vous passe mes différentes tentatives infructueuses mais j'ai fini par trouver la solution au travers d'un message utilisateur "poster" après le dessin du TShape concerné par un déplacement.
Le seul problème, et non des moindres, c'est que lors du déplacement d'un TShape, le fond du TForm2 n'est pas effacé ce qui a pour conséquence de laisser une traînée lors du dessin du connecteur.
Je sais, dit comme ça, cela n'a pas l'air clair du tout alors voici le code ( et le projet test complet en PJ ) :

P.J.: Test1.zip

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
 
unit Unit1;
 
{$mode objfpc}{$H+}
 
interface
 
uses
  Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, StdCtrls, ExtCtrls,
  Unit2
  ;
 
type
	{ TForm1 }
  TForm1 = class(TForm)
	  Button1: TButton;
		Button2: TButton;
		GroupBox1: TGroupBox;
		procedure Button1Click(Sender: TObject);
		procedure Button2Click(Sender: TObject);
  private
        { private declarations }
  public
        { public declarations }
  end;
 
 
var
  Form1: TForm1;
 
implementation
 
{$R *.lfm}
 
{ TForm1 }
 
procedure TForm1.Button1Click(Sender: TObject);
begin
  Form2.Parent := Self;
  Form2.Align := alClient;
  Form2.AutoScroll := True;
  Form2.DoubleBuffered := True;
  Form2.Show;
end;
 
 
 
procedure TForm1.Button2Click(Sender: TObject);
begin
  Form2.DrawConnector;
end;
 
end.

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
 
unit Unit2;
 
{$mode objfpc}{$H+}
 
interface
 
uses
  Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, ExtCtrls,
  LMessages, LCLIntf, LCLType
  ;
 
const
  LM_DRAW_CONNECTOR = LM_USER + 1;
 
type
	{ TForm2 }
  TForm2 = class(TForm)
  	Shape1: TShape;
	  Shape2: TShape;
    procedure Shape1MouseDown(Sender: TObject; Button: TMouseButton;Shift: TShiftState; X, Y: Integer);
    procedure Shape1MouseMove(Sender: TObject; Shift: TShiftState; X,Y: Integer);
	  procedure Shape1MouseUp(Sender: TObject; Button: TMouseButton;Shift: TShiftState; X, Y: Integer);
    procedure Shape1Paint(Sender: TObject);
  private
    Sx, Sy  : Integer;
 
    procedure WM_DRAW_CONNECTOR(var Message: TLMessage); message LM_DRAW_CONNECTOR;
 
  public
    procedure DrawConnector;
  end;
 
 
var
      Form2: TForm2;
 
implementation
 
{$R *.lfm}
 
{ TForm2 }
procedure TForm2.Shape1Paint(Sender: TObject);
const KPass: Integer = 0;
begin
  inc(KPass);
  With Shape1.BoundsRect do Shape1.Canvas.TextOut( 5, 10, Format('%d,%d,%d,%d',[Left,Top,Right,Bottom] ));
  With Shape1.ClientRect do Shape1.Canvas.TextOut( 5, 40, Format('%d,%d,%d,%d',[Left,Top,Right,Bottom] ));
  Shape1.Canvas.TextOut( 5, 70, Format('%d',[KPass] ));
  PostMessage( Handle, LM_DRAW_CONNECTOR, 0, 0 );
end;
 
 
 
procedure TForm2.WM_DRAW_CONNECTOR(var Message: TLMessage);
begin
  DrawConnector;
end;
 
 
 
procedure TForm2.Shape1MouseMove( Sender: TObject; Shift: TShiftState; X, Y: Integer );
begin
 
  // Bouton gauche enfonçé ?
  if ( ssLeft in Shift ) then
  begin
    Shape1.Pen.Color := clRed;
    Shape1.Left := Shape1.Left + (X-Sx);
    Shape1.Top := Shape1.Top + (Y-Sy);
	end;
 
end;
 
 
 
procedure TForm2.Shape1MouseUp(Sender: TObject; Button: TMouseButton;Shift: TShiftState; X, Y: Integer);
begin
  Shape1.Pen.Color := clNavy;
end;
 
 
 
procedure TForm2.Shape1MouseDown( Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer );
begin
  if ( Button = mbLeft ) then
  begin
    Sx := X;
    Sy := Y;
	end;
end;
 
 
 
procedure TForm2.DrawConnector;
begin
  Canvas.Line( Shape1.BoundsRect.Right, (Shape1.BoundsRect.Top + ( Shape1.Height div 2)),
               Shape2.BoundsRect.Left, (Shape2.BoundsRect.Top + ( Shape2.Height div 2))
             );
end;
 
 
 
end.

Une idée de comment effacer le fond du TForm2 lors du déplacement d'un TShape ?

**TheFreeBerga** · 03/09/2014, 22h24

Bon, toujours aussi inélégant, j'ai placé un "Refresh" du TForm2 dans le déplacement du TShape et ça fonctionne sans trop scintiller...

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 TForm2.Shape1MouseMove( Sender: TObject; Shift: TShiftState; X, Y: Integer );
begin

  // Bouton gauche enfonçé ?
  if ( ssLeft in Shift ) then
  begin
    Refresh;
    Shape1.Pen.Color := clRed;
    Shape1.Left := Shape1.Left + (X-Sx);
    Shape1.Top := Shape1.Top + (Y-Sy);
  end;

end;

Merci à tous ceux qui avaient commencé à se gratter la tête sur mon problème.

@+ !

**Iwoks** · 03/09/2014, 22h34

Bonjour

Déjà pour résoudre ton problème,

Code :

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

1
2
3
4
5
6
7
8
9
10
11
12
 
procedure TForm2.Shape1Paint(Sender: TObject);
const KPass: Integer = 0;
begin
  inc(KPass);
  With Shape1.BoundsRect do Shape1.Canvas.TextOut( 5, 10, Format('%d,%d,%d,%d',[Left,Top,Right,Bottom] ));
  With Shape1.ClientRect do Shape1.Canvas.TextOut( 5, 40, Format('%d,%d,%d,%d',[Left,Top,Right,Bottom] ));
  Shape1.Canvas.TextOut( 5, 70, Format('%d',[KPass] ));
//  PostMessage( Handle, LM_DRAW_CONNECTOR, 0, 0 );
  DrawConnector;  
  Form2.Repaint;
end;

Ensuite, j'ai une petite modification dans form1
Car j'ai crue comprendre que tu voulais associé Form2 à Form1.

Code :

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

1
2
3
4
5
6
7
 
  Form2 := TForm2.create(self);
  Form2.Parent := nil;
  Form2.Align := alClient;
  Form2.AutoScroll := True;
  Form2.DoubleBuffered := True;
  Form2.Show;

Et j'ai modifié le .lpr

Code :

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

1
2
3
4
5
6
7
8
 
begin
  RequireDerivedFormResource := True;
  Application.Initialize;
  Application.CreateForm(TForm1, Form1);
//  Application.CreateForm(TForm2, Form2);
  Application.Run;
end.

Tout roule.
Cldt.
F.THERET

**TheFreeBerga** · 03/09/2014, 22h46

Merci Iwoks de te pencher sur le sujet,

J'ai déjà tenté la solution que tu préconises...lances le projet avec ton code et tu vas comprendre pourquoi fût un temps, j'ai créé la variable KPass

( et jettes un œil sur la charge cpu

)
Sinon, j'imagine que le fait de créer le TForm2 dynamiquement est purement "cosmétique" ?! Si non, cela change quoi exactement ?

**Iwoks** · 03/09/2014, 23h01

Bien,

Il faut éviter de faire TForm.parent = TForm
Cela produit un loop entre tes 2 Form donc rend instable le programme.
J'ai planté 3 à 4 fois à cause de ça.

Ensuite, effectivement, ta solution est meilleur. J'ai refait le code.
Dans ma modification, j'associe les événements sur les 2 bloques.

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
 
unit Unit2;
 
{$mode objfpc}{$H+}
 
interface
 
uses
  Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, ExtCtrls,
  LMessages, LCLIntf, LCLType
  ;
 
const
  LM_DRAW_CONNECTOR = LM_USER + 1;
 
type
	{ TForm2 }
  TForm2 = class(TForm)
    Shape1: TShape;
    Shape2: TShape;
 
    procedure Shape1MouseDown(Sender: TObject; Button: TMouseButton;Shift: TShiftState; X, Y: Integer);
    procedure Shape1MouseMove(Sender: TObject; Shift: TShiftState; X,Y: Integer);
    procedure Shape1MouseUp(Sender: TObject; Button: TMouseButton;Shift: TShiftState; X, Y: Integer);
    procedure Shape1Paint(Sender: TObject);
 
  private
    Sx, Sy  : Integer;
  public
    procedure DrawConnector;
  end;
 
 
var
      Form2: TForm2;
 
implementation
 
{$R *.lfm}
 
{ TForm2 }
procedure TForm2.Shape1Paint(Sender: TObject);
begin
  With TShape(Sender).BoundsRect do TShape(Sender).Canvas.TextOut( 5, 10, Format('%d,%d,%d,%d',[Left,Top,Right,Bottom] ));
  With TShape(Sender).ClientRect do TShape(Sender).Canvas.TextOut( 5, 40, Format('%d,%d,%d,%d',[Left,Top,Right,Bottom] ));
  DrawConnector;
end;
 
 
procedure TForm2.Shape1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer );
begin
 
  // Bouton gauche enfonçé ?
 if ( ssLeft in Shift ) then
 begin
    Form2.Repaint;
    TShape(Sender).Pen.Color := clRed;
    TShape(Sender).Left := TShape(Sender).Left + (X-Sx);
    TShape(Sender).Top  := TShape(Sender).Top + (Y-Sy);
 end;
 
end;
 
procedure TForm2.Shape1MouseUp(Sender: TObject; Button: TMouseButton;Shift: TShiftState; X, Y: Integer);
begin
  Shape1.Pen.Color := clNavy;
end;
 
procedure TForm2.Shape1MouseDown( Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer );
begin
 if ( Button = mbLeft ) then
  begin
    Sx := X;
    Sy := Y;
 end;
end;
 
procedure TForm2.DrawConnector;
 begin
  Canvas.Line( Shape1.BoundsRect.Right, (Shape1.BoundsRect.Top + ( Shape1.Height div 2)),
               Shape2.BoundsRect.Left, (Shape2.BoundsRect.Top + ( Shape2.Height div 2)));
 end;
end.

Cldt.
Iwoks

**TheFreeBerga** · 04/09/2014, 00h10

Il faut éviter de faire TForm.parent = TForm
Cela produit un loop entre tes 2 Form donc rend instable le programme.

Si la TForm2 n'est pas la fille, alors elle devient une fenêtre indépendante et ce n'est pas le but du jeu.

J'ai planté 3 à 4 fois à cause de ça.

Comment ça "planté" ? Le seul effet de bord que j'ai remarqué c'est l'appel récurrent qui redessine en permanence, bouffe la cpu et finalement le connecteur n'apparaît pas à cause de la fréquence d'effacement du fond.

NB: Je tourne sous Linux-x64 avec Lazarus 1.2.4 & FPC 2.6.4, peut-être es-tu sous windows avec des versions différentes...

Comment effacer un TForm ? [Lazarus]

Lazarus Pascal

Vue hybride

Discussions similaires

Partager

Partager