Comment effacer un TForm ?

Version imprimable

1 pièce(s) jointe(s)

Bonjour @ toutes & tous,

Mon problème n'est malheureusement pas aussi simple que le titre pourrait le laisser penser... :aie:
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.: Pièce jointe 155349
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 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:

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 ?

Trouvé !

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:

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. :D

@+ !

Bonjour

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

Code:

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:

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:

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

03/09/2014, 22h46
TheFreeBerga

Oui mais...

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 :P
( et jettes un œil sur la charge cpu :calim2: )
Sinon, j'imagine que le fait de créer le TForm2 dynamiquement est purement "cosmétique" ?! Si non, cela change quoi exactement ?

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:

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

04/09/2014, 00h10
TheFreeBerga

Citation:

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.

Citation:

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...