Discussion :

[Gouyon]

Salut à tous

Je me lance dans la création d'un composant et j'ai de gros soucis. Le composant que je cherche à faire est une barre de progression colorée. Le principe est que la couleur de la barre, au lieu de rester la même, évolue en fonction du remplissage et le taux de remplissage est inscrit au milieu.

Voici le code :

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
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
 
unit ColoredProgressBar1;
 
{$mode objfpc}{$H+}
 
interface
 
uses
  Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs,ExtCtrls;
 
type
  TColoredProgressBar = class(TImage)
  private
    { Private declarations }
    Couleur1: TColor;
    Couleur2: TColor;
    Couleur3: TColor;
    Couleur4: TColor;
    Progressif: boolean;
    Max: integer;
    Min: integer;
    Position: integer;
    Texte:string;
 
    procedure SetCouleur1(New: TColor);
    procedure SetCouleur2(New: TColor);
    procedure SetCouleur3(New: TColor);
    procedure SetCouleur4(New: TColor);
    procedure SetProgressif(New: boolean);
    procedure SetMax(New: integer);
    procedure SetMin(New: integer);
    procedure SetPosition(New: integer);
    procedure SetCaption(New: String);
 
  protected
    { Protected declarations }
    procedure Paint; override;
  public
    { Public declarations }
    constructor Create(AOwner : TComponent); override;
    destructor Destroy; override;
 
  published
    { Published declarations }
    property Color1: TColor read Couleur1 write SetCouleur1 default clRed;
    property Color2: TColor read Couleur2 write SetCouleur2 default clYellow;
    property Color3: TColor read Couleur3 write SetCouleur3 default clLime;
    property Color4: TColor read Couleur4 write SetCouleur4 default clBlue;
    property Progressive: boolean read Progressif write SetProgressif default True;
    property Maximum: integer read Max write SetMax default 100;
    property Minimum: integer read Min write SetMin default 0;
    property Pos: integer read Position write SetPosition;
    property Caption: String read Texte write SetCaption;
  end;
 
procedure Register;
 
implementation
 
procedure Register;
begin
  {$I coloredprogressbar1_icon.lrs}
  RegisterComponents('MonPac', [TColoredProgressBar]);
end;
 
constructor TColoredProgressBar.Create(AOwner : TComponent);
begin
  inherited;
  Width:=100;
  Height:=20;
  Couleur1:=clRed;
  Couleur2:=clYellow;
  Couleur3:= clLime;
  Couleur4:=clBlue;
end;
 
destructor TColoredProgressBar.Destroy;
begin
  inherited;
end;
 
procedure TColoredProgressBar.SetCouleur1(New: TColor);
begin
  Couleur1 := New;
end;
 
procedure TColoredProgressBar.SetCouleur2(New: TColor);
begin
  Couleur2 := New;
end;
 
procedure TColoredProgressBar.SetCouleur3(New: TColor);
begin
  Couleur3 := New;
end;
 
procedure TColoredProgressBar.SetCouleur4(New: TColor);
begin
  Couleur4 := New;
end;
 
procedure TColoredProgressBar.SetProgressif(New: boolean);
begin
  Progressif := New;
end;
 
procedure TColoredProgressBar.SetMax(New: integer);
begin
  Max := New;
end;
 
procedure TColoredProgressBar.SetMin(New: integer);
begin
  Min := New;
end;
 
procedure TColoredProgressBar.SetPosition(New: integer);
begin
  Position := New;
end;
procedure TColoredProgressBar.SetCaption(New: String);
begin
 Texte:=New;
end;
 
procedure TColoredProgressBar.Paint;
 var
  Seuil,Plage,xt, yt: integer;
  MaBmp: TBitmap;
  Rect: TRect;
  Lcol,Hcol:TColor;
  R,G,B,rh,gh,bh,rl,gl,bl:byte;
  X:integer;
  S:String;
begin
  X:=round((100*(Position-Min))/(Max-Min));
  S:=Texte+Format(' %3d%%', [X]);
  xt := (Width - Canvas.GetTextWidth(S)) div 2;
  yt:=(Height - Canvas.GetTextHeight(S)) div 2;
  MaBmp := TBitmap.Create;
  MaBmp.Width := Width;
  MaBmp.Height := Height;
  MaBmp.Canvas.Brush.Color := clWhite;
  MaBmp.Canvas.Brush.Style := bsSolid;
  MaBmp.Canvas.FillRect(0, 0, Width, Height);
  MaBmp.Canvas.Font.Color := clBlack;
  MaBmp.Canvas.TextOut(xt, yt, S);
 
  if (X >= 66) then
    begin
      rl:=Blue(Couleur3);
      rh:=Blue(Couleur4);
      gl:=Blue(Couleur3);
      gh:=Blue(Couleur4);
      bl:=Blue(Couleur3);
      bh:=Blue(Couleur4);
      Seuil:=66;
      Plage:=100-66;
    end;
  if (X >= 33) and (X < 66) then
    begin
      rl:=Blue(Couleur2);
      rh:=Blue(Couleur3);
      gl:=Blue(Couleur2);
      gh:=Blue(Couleur3);
      bl:=Blue(Couleur2);
      bh:=Blue(Couleur3);
      Seuil:=33;
      Plage:=66-33;
    end;
  if (X < 33) then
   begin
      rl:=Blue(Couleur1);
      rh:=Blue(Couleur2);
      gl:=Blue(Couleur1);
      gh:=Blue(Couleur2);
      bl:=Blue(Couleur1);
      bh:=Blue(Couleur2);
      Seuil:=0;
      Plage:=33-0;
    end;
  if Progressif then
   begin
      R:=round((rh-rl)*(X-Seuil)/Plage+rl) ;
      G:=round((gh-gl)*(X-Seuil)/Plage+gl) ;
      B:=round((bh-bl)*(X-Seuil)/Plage+bl) ;
      Canvas.Brush.Color := RGBToColor(R, G, B);
   end
  else
  begin
    if X>=100 then
     begin
        X:=100;
        Canvas.Brush.Color := Couleur4;
        end
    else
    begin
     Canvas.Brush.Color := RGBToColor(rl, gl, bl);
      end;
  end;
  xt:=(X * Width) div 100;
  Canvas.FillRect(0, 0, xt, Height);
  Canvas.Brush.Color := clWhite;
  Canvas.FillRect(xt, 0,Width, Height);
  Rect.Left := 0;
  Rect.Top := 0;
  Rect.Right := Width;
  Rect.Bottom := Height;
  Canvas.CopyMode := cmSrcAnd;
  Canvas.CopyRect(Rect, MaBmp.Canvas, Rect);
  MaBmp.Free;
 
end;
 
end.

La compilation se fait bien de même que l'installation du paquet. Par contre, dès que je dépose ce composant sur une Form, Lazarus plante.

Si quelqu'un peut me dire où se situe l'erreur.

[tourlourou]

Bonjour,

Ton composant a un Owner, mais pas de Parent qui se charge de l'afficher ?

[Gouyon]

Ton composant a un Owner, mais pas de Parent qui se charge de l'afficher ?

Peux tu être un peu plus explicite. Car il me semblait justement que le Owner est le Parent

[tourlourou]

En Delphi, le Owner est le propriétaire : cad se charge de la libération de l'objet (on peut passer nil quand on gère soi-même le cycle de vie ; et le Parent est l'objet qui se charge de transmettre les messages Windows (au moins d'affichage).

Donc en création dynamique, si on n'affecte pas le Parent, il n'y a pas d'affichage du tout.

Cela dit, le composant peut être conçu de manière à affecter le Owner comme Parent lors du Create... Pour le TImage, je ne pense pas que ce soit le cas, et il doit falloir le renseigner manuellement.

En FPC/Lazarus, ça reste à voir s'il y a la même distinction.

Cela dit, à bien relire ton code, il me semble qu'il y a un hic : tu écris au OnPaint sur le TImage.Canvas ; celui-ci est-il bien défini si on n'affecte pas de Picture ? Et un TPaintBox ne serait-il pas plus indiqué ?

Je regrette de ne pas avoir Lazarus pour tester ici !

Ton composant fonctionne-t-il en création dynamique ?

[Gouyon]

Cela dit, à bien relire ton code, il me semble qu'il y a un hic : tu écris au OnPaint sur le TImage.Canvas ; celui-ci est-il bien défini si on n'affecte pas de Picture ? Et un TPaintBox ne serait-il pas plus indiqué ?

La méthode Paint est surchargée et elle définit comment se comporte mon composant à l'affichage. En fait je me suis inspiré du tutoriel delphi de création d'un composant.

Ton composant fonctionne-t-il en création dynamique ?

Je n'ai pas testé mais ça m'étonnerais que ça fonctionne.

[tourlourou]

Peut-être faut-il essayer plutôt que de copier dans TImage.Canvas le Bitmap que tu as préparé dans le OnPaint, de l'assigner à la propriété Picture (?) du TImage.

Par ailleurs, tu dessines à chaque OnPaint le Bitmap, qu'il ait changé ou pas...

Peut-être peux-tu envisager de le dessiner dans un champ de ton objet, le OnPaint se chargeant seulement de le recopier pour l'afficher. A charge pour le SetProgression de dessiner le nouveau BitMap si changement de position (donc stocker l'ancienne) et de demander le redessin du compo.

[pedestre]

Bonjour,

J'ai recopié et installé ton composant. je l'ai utilisé sur un programme et n'ai obtenu aucune erreur. Cependant il ne fait apparemment rien (pb. d'affichage...) , mais ne crée aucun plantage. Je pense que le Pb. est dans l'installation qui est sans doute à refaire. Pierre

[Gouyon]

Bonjour,

J'ai recopié et installé ton composant. je l'ai utilisé sur un programme et n'ai obtenu aucune erreur. Cependant il ne fait apparemment rien (pb. d'affichage...) , mais ne crée aucun plantage. Je pense que le Pb. est dans l'installation qui est sans doute à refaire. Pierre

Comment as tu fait l'installation ?

Pour ma part l'installation "c'est bien passée" mais dès que je met ce composant sur une fiche Lazarus plante.

[tourlourou]

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
procedure TForm1.Button1Click(Sender: TObject);
var
  MyColoredProgressBar: TColoredProgressBar;
  i: integer;
begin
  MyColoredProgressBar:=TColoredProgressBar.Create(self);
//  MyColoredProgressBar.Parent:=self;
  MyColoredProgressBar.Top:=27;
  MyColoredProgressBar.Left:=27;
  MyColoredProgressBar.Height:=54;
  MyColoredProgressBar.Width:=162;
  MyColoredProgressBar.Show;
  ShowMessage(IntToStr(MyColoredProgressBar.Canvas.Width));
  MyColoredProgressBar.Progressif:=True;
  MyColoredProgressBar.Pos:=0;
  for i:=0 to 10
  do begin
    MyColoredProgressBar.Pos:=10*i;
    MyColoredProgressBar.Invalidate;
    Application.ProcessMessages;     
    Sleep(300);
  end;
  MyColoredProgressBar.Free;
end;

avec ce code, pas d'erreur, mais rien ne se passe...
si je décommente pour attribuer le Parent, exception liée dans le Paint par une division par 0 dans la première ligne :

Code :

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

X:=round((100*(Position-Min))/(Max-Min));

car Max-Min=0-0=la tête à Toto !
bizarre qu'il ne prenne pas les valeurs par défaut...

et si je les sette avant, boucle infinie dans le Paint à O% qui s'affiche correctement, mais le programme ne répond plus !

[EDIT] pour qu'il affiche qqch, il faut attribuer le Parent et mettre inherited dans le Paint

[tourlourou]

Je pense qu'en Design Time, le Create du TImage doit affecter le Parent au Owner, mais que c'est à faire manuellement au Run Time.

Sinon, j'arrive à une barre qui affiche les pourcentages mais reste désespérément blanche (je n'ai pas compris la logique de l'effet : neurones en week-end !) avec ce code, qui dérive de la PaintBox au lieu du TImage :

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
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
unit Unit1; 
 
{$mode objfpc}{$H+}
 
interface
 
uses
  Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, StdCtrls,
  LResources, ExtCtrls;
 
type
  TColoredProgressBar = class(TPaintBox)
  private
    { Private declarations }
    FCouleur1: TColor;
    FCouleur2: TColor;
    FCouleur3: TColor;
    FCouleur4: TColor;
    FProgressif: boolean;
    FMax: integer;
    FMin: integer;
    FPosition: integer;
    FTexte:string;
    FBitmap: TBitmap;
    procedure SetCouleur1(New: TColor);
    procedure SetCouleur2(New: TColor);
    procedure SetCouleur3(New: TColor);
    procedure SetCouleur4(New: TColor);
    procedure SetProgressif(New: boolean);
    procedure SetMax(New: integer);
    procedure SetMin(New: integer);
    procedure SetPosition(New: integer);
    procedure SetCaption(New: String);
 
  protected
    { Protected declarations }
    procedure Paint; override;
 
  public
    { Public declarations }
    constructor Create(AOwner : TComponent); override;
    destructor Destroy; override;
 
  published
    { Published declarations }
    property Color1: TColor read FCouleur1 write SetCouleur1 default clRed;
    property Color2: TColor read FCouleur2 write SetCouleur2 default clYellow;
    property Color3: TColor read FCouleur3 write SetCouleur3 default clLime;
    property Color4: TColor read FCouleur4 write SetCouleur4 default clBlue;
    property Progressive: boolean read FProgressif write SetProgressif default True;
    property Maximum: integer read FMax write SetMax default 100;
    property Minimum: integer read FMin write SetMin default 0;
    property Pos: integer read FPosition write SetPosition;
    property Caption: String read FTexte write SetCaption;
  end;
 
 
type
 
  { TForm1 }
 
  TForm1 = class(TForm)
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
  private
    { private declarations }
  public
    { public declarations }        // C:\lazarus\lcl\interfacebase.pp
  end; 
 
var
  Form1: TForm1; 
 
implementation
 
{ TForm1 }
 
procedure TForm1.Button1Click(Sender: TObject);
var
  MyColoredProgressBar: TColoredProgressBar;
  i: integer;
begin
  MyColoredProgressBar:=TColoredProgressBar.Create(self);
  MyColoredProgressBar.Top:=27;
  MyColoredProgressBar.Left:=27;
  MyColoredProgressBar.Height:=54;
  MyColoredProgressBar.Width:=162;
  MyColoredProgressBar.Maximum:=100;
  MyColoredProgressBar.Minimum:=0;
  MyColoredProgressBar.Show;
//  ShowMessage(IntToStr(MyColoredProgressBar.Canvas.Width));
 
  MyColoredProgressBar.Progressive:=True;
  MyColoredProgressBar.Parent:=self;
  MyColoredProgressBar.Pos:=0;
  for i:=0 to 10
  do begin
    MyColoredProgressBar.Pos:=10*i;
    MyColoredProgressBar.Invalidate;
    Application.ProcessMessages;
    Sleep(300);
//    ShowMessage(IntToStr(i));
  end;
  MyColoredProgressBar.Free;
end;
 
{$R *.lfm}
constructor TColoredProgressBar.Create(AOwner : TComponent);
begin
  inherited;
  Width:=100;
  Height:=20;
  FCouleur1:=clRed;
  FCouleur2:=clYellow;
  FCouleur3:=clLime;
  FCouleur4:=clBlue;
  FMax:=100;
  FMin:=0;
  FPosition:=0;
end;
 
destructor TColoredProgressBar.Destroy;
begin
  inherited;
end;
 
procedure TColoredProgressBar.SetCouleur1(New: TColor);
begin
  FCouleur1 := New;
end;
 
procedure TColoredProgressBar.SetCouleur2(New: TColor);
begin
  FCouleur2 := New;
end;
 
procedure TColoredProgressBar.SetCouleur3(New: TColor);
begin
  FCouleur3 := New;
end;
 
procedure TColoredProgressBar.SetCouleur4(New: TColor);
begin
  FCouleur4 := New;
end;
 
procedure TColoredProgressBar.SetProgressif(New: boolean);
begin
  FProgressif := New;
end;
 
procedure TColoredProgressBar.SetMax(New: integer);
begin
  FMax := New;
end;
 
procedure TColoredProgressBar.SetMin(New: integer);
begin
  FMin := New;
end;
 
procedure TColoredProgressBar.SetPosition(New: integer);
begin
  FPosition := New;
end;
procedure TColoredProgressBar.SetCaption(New: String);
begin
  FTexte:=New;
end;
 
procedure TColoredProgressBar.Paint;
 var
  Seuil,Plage,xt, yt: integer;
  Rect: TRect;
  Lcol,Hcol:TColor;
  R,G,B,rh,gh,bh,rl,gl,bl:byte;
  X:integer;
  S:String;
begin
 
  if (FMax-FMin)>0
  then X:=round((100*(FPosition-FMin))/(FMax-FMin))
  else X:=0;
  S:=FTexte+Format(' %3d%%', [X]);
  xt := (Width - Canvas.GetTextWidth(S)) div 2;
  yt:=(Height - Canvas.GetTextHeight(S)) div 2;
  Canvas.Brush.Color := clWhite;
  Canvas.Brush.Style := bsSolid;
  Canvas.FillRect(0, 0, Canvas.Width, Canvas.Height);
  Canvas.Font.Color := clBlack;
//    [EDIT]
//  Canvas.TextOut(xt, yt, S);     exit;
// [/EDIT]
  if (X >= 66) then
    begin
      rl:=Red(FCouleur3);
      rh:=Red(FCouleur4);
      gl:=Green(FCouleur3);
      gh:=Green(FCouleur4);
      bl:=Blue(FCouleur3);
      bh:=Blue(FCouleur4);
      Seuil:=66;
      Plage:=100-66;
    end;
  if (X >= 33) and (X < 66) then
    begin
      rl:=Red(FCouleur2);
      rh:=Red(FCouleur3);
      gl:=Green(FCouleur2);
      gh:=Green(FCouleur3);
      bl:=Blue(FCouleur2);
      bh:=Blue(FCouleur3);
      Seuil:=33;
      Plage:=66-33;
    end;
  if (X < 33) then
   begin
      rl:=Red(FCouleur1);
      rh:=Red(FCouleur2);
      gl:=Green(FCouleur1);
      gh:=Green(FCouleur2);
      bl:=Blue(FCouleur1);
      bh:=Blue(FCouleur2);
      Seuil:=0;
      Plage:=33-0;
    end;
  if fProgressif then
   begin
      R:=round((rh-rl)*(X-Seuil)/Plage+rl) ;
      G:=round((gh-gl)*(X-Seuil)/Plage+gl) ;
      B:=round((bh-bl)*(X-Seuil)/Plage+bl) ;
      Canvas.Brush.Color := RGBToColor(R, G, B);
   end
  else
  begin
    if X>=100
    then begin
        X:=100;
        Canvas.Brush.Color := FCouleur4;
    end
    else Canvas.Brush.Color := RGBToColor(rl, gl, bl);
  end;
  xt:=(X * Width) div 100;
  Canvas.FillRect(0, 0, xt, Canvas.Height);
  Canvas.Brush.Color := clWhite;
  Canvas.FillRect(xt, 0,Canvas.Width, Canvas.Height);
//    [EDIT]
  Canvas.TextOut(xt, yt, S);     exit;
// [/EDIT]
  Rect.Left := 0;
  Rect.Top := 0;
  Rect.Right := Width;
  Rect.Bottom := Height;
//  Canvas.CopyMode := cmSrcAnd;
//  Canvas.CopyRect(Rect, MaBmp.Canvas, Rect);
//  MaBmp.Free;
//  inherited;
end;
 
end.

[EDIT] j'aurais pu éviter de me ridiculiser si j'avais vu plus tôt le "exit;" que j'avais laissé après le TextOut... Celui-ci enlevé, mettre le TextOut à la fin du Paint, sinon il est effacé par la barre qui progresse bien, et en couleur...
Reste à tester en composant de la palette et voir si OK quand déposé sur une fiche.

[Gouyon]

Salut
J'ai repris ton code et effectivement la barre reste désespérément blanche ce qui évidement ne devrait pas être le cas. Et je ne comprend pas pourquoi. D'autant plus que pour le mettre au point j'avais fait des essais avec un TImage.

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
 
//PourCent est un TImage sur la fiche
procedure TForm1.FormPaint(Sender: TObject);
var
  S: string;
  xt, yt: integer;
  pBmp: TBitmap;
  Rect: TRect;
  Lcol,Hcol:TColor;
  R,G,B:byte;
begin
  S := Format('Essai %3d%%', [X]);
  xt := (PourCent.Width - Pourcent.Canvas.GetTextWidth(S)) div 2;
  yt:=(PourCent.Height - Pourcent.Canvas.GetTextHeight(S)) div 2;
  pBmp := TBitmap.Create;
  pBmp.Width := PourCent.Width;
  pBmp.Height := PourCent.Height;
  pBmp.Canvas.Brush.Color := clWhite;
  pBmp.Canvas.FillRect(0, 0, pBmp.Width, pBmp.Height);
  pBmp.Canvas.Font.Color := clBlack;
  pBmp.Canvas.TextOut(xt, yt, S);
  //Canvas.Draw(10,20,pBmp);
  if (X >= 66) then
    begin
      B:=0;
      R:=round((0-255)*(X-66)/(100-66)+255);
      //G:=round((128-255)*(X-66)/(100-66)+255);
      G:=255;
    end;
  if (X >= 33) and (X < 66) then
    begin
      B:=0;
      R:=255;
      G:=round((255-128)*(X-33)/(66-33)+128);
    end;
  if (X < 33) then
   begin
      B:=0;
      R:=255;
      G:=round((128-0)*(X-0)/(33-0)+0);
    end;
 
  Pourcent.Canvas.Brush.Color := RGBToColor(R, G, B);
  yt:=Pourcent.Width;
  xt:=(X * Pourcent.Width) div 100;
  Pourcent.Canvas.FillRect(0, 0, xt, PourCent.Height);
  Pourcent.Canvas.Brush.Color := clWhite;
  Pourcent.Canvas.FillRect(xt, 0,Pourcent.Width, PourCent.Height);
 
  Rect.Left := 0;
  Rect.Top := 0;
  Rect.Right := PourCent.Width;
  Rect.Bottom := PourCent.Height;
  PourCent.Canvas.CopyMode := cmSrcAnd;
  PourCent.Canvas.CopyRect(Rect, pBmp.Canvas, Rect);
  pBmp.Free;
end;

Par ailleurs en suivant le tutoriel composants delphi j'ai utilisé au départ comme ancêtre la classe TGraphicControl puis voyant que ça ne fonctionnait pas j'ai utilisé la classe TImage.

[tourlourou]

tu n'as pas dû lire l'EDIT en ligne 192 avec un Exit de debuggage qui traînait...

le TImage est un outil "bizarre" si tu l'utilises comme base du composant et décommente la ligne 91, son Canvas a une taille de 0...

le TImage est fait pour afficher une image qu'on affecte à sa propriété Picture, et le TPaintBox pour en dessiner une : autant prendre le bon outil !

ici : http://sheepdogguides.com/dt3b.htm un bout de code qui montre comment utiliser le TImage pour dessiner :

Code :

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

1
2
3
4
5
6
7
8
9
10
11
var Bitmap:TBitmap;(*Provide a suitable variable*)
begin(*main of OnCreate*)
Bitmap:=TBitmap.create;(*Create a bitmap object*)
Bitmap.width:=400;(*Assign dimensions*)
Bitmap.height:=100;
Image1.Picture.Graphic:=Bitmap;(*Assign the bitmap to the image component*)
Image1.Picture.Bitmap.canvas.pen.color:=clRed;
   (*Have a look at the canvas Help to see all the properties*)
Image1.Picture.Bitmap.canvas.moveto(10,10);
Image1.Picture.Bitmap.canvas.lineto(300,50);
end;

[Gouyon]

tu n'as pas dû lire l'EDIT en ligne 192 avec un Exit de debuggage qui traînait...

Effectivement j'avais mal lu. Mais ta solution ne fonctionne pas comme elle devrait car le texte s'affiche après la barre coloré alors qu'il doit s'afficher dessus.

Pour ce qui est du TImage je j'utilise très souvent pour dessiner. En général je procède comme dans l'exemple de code de ton dernier post.

[tourlourou]

effectivement, le xt utilisé pour centrer le texte est recalculé pour la barre.

en déplaçant l'affichage du texte après dessin des surfaces colorées, il est bien centré, mais sur fond blanc lors du passage de la barre

[Gouyon]

J'ai repris entièrement le composant en partant d'un ancêtre TGraphicControl et ça marche un peu mieux. Surtout depuis que j'ai modifié l'accès aux propriétés. L'IDE plantait car j'affectais sa valeur à une propriété en appelant la fonction d'affectation à l'intérieur de cette même fonction.

Par contre j'ai des problèmes de recopie de mon texte sur ma barre colorée.
J'ai essayé de modifier le style du texte mais le compilateur m'a jeté sur cette instruction:

Code :

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

1
2
 
Canvas.TextStyle.Opaque:=false;

il me met Error:Argument can't be assigned to

Je ne vois pas bien pourquoi car TextStyle n'est pas privée

[tourlourou]

http://www.lazarus.freepascal.org/in...p?topic=8526.0 traite du problème dans la discussion

[Gouyon]

Voilà ça marche maintenant.

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
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
 
unit CompoTest;
 
{$mode objfpc}{$H+}
 
interface
 
uses
  Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs;
 
type
  TCompoTest = class(TGraphicControl)
  private
    { Private declarations }
    FMyText: string;
    FMax: integer;
    FMin: integer;
    FPosition: integer;
    FProgressif: boolean;
 
    FCouleur1: TColor;
    FCouleur2: TColor;
    FCouleur3: TColor;
    FCouleur4: TColor;
 
  protected
    { Protected declarations }
    function GetMyText: string;
    procedure SetMyText(MyText: string);
    function GetMax: integer;
    function GetMin: integer;
    function GetPosition: integer;
    procedure SetMax(Nouv: integer);
    procedure SetMin(Nouv: integer);
    procedure SetPosition(Nouv: integer);
 
    function GetCouleur1: TColor;
    procedure SetCouleur1(Nouv: TColor);
    function GetCouleur2: TColor;
    procedure SetCouleur2(Nouv: TColor);
    function GetCouleur3: TColor;
    procedure SetCouleur3(Nouv: TColor);
    function GetCouleur4: TColor;
    procedure SetCouleur4(Nouv: TColor);
 
 
    function GetProgressif: boolean;
    procedure SetProgressif(Nouv: boolean);
 
    procedure Paint; override;
  public
    { Public declarations }
    constructor Create(MyOwner: TComponent); override;
  published
    { Published declarations }
    property Texte: string read GetMyText write SetMyText;
 
    property Max: integer read GetMax write SetMax;
    property Min: integer read GetMin write SetMin;
    property Position: integer read GetPosition write SetPosition;
 
    property Couleur1: TColor read GetCouleur1 write SetCouleur1;
    property Couleur2: TColor read GetCouleur2 write SetCouleur2;
    property Couleur3: TColor read GetCouleur3 write SetCouleur3;
    property Couleur4: TColor read GetCouleur4 write SetCouleur4;
 
    property Progressif: boolean read GetProgressif write SetProgressif;
 
    property Align;
    property Anchors;
    property Constraints;
    property DragCursor;
    property DragMode;
    property Enabled;
    property Font;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property OnStartDrag;
    property ParentFont;
    property ParentShowHint;
    property PopupMenu;
    property ShowHint;
    property Visible;
  end;
 
procedure Register;
 
implementation
 
procedure Register;
begin
  {$I compotest_icon.lrs}
  RegisterComponents('MesCompo', [TCompoTest]);
end;
 
function TCompoTest.GetMyText: string;
begin
  Result := FMyText;
end;
 
procedure TCompoTest.SetMyText(MyText: string);
begin
  FMyText := MyText;
end;
 
procedure TCompoTest.Paint;
var
  Seuil, Plage, xt, yt: integer;
  R, G, B, rh, gh, bh, rl, gl, bl: byte;
  X: integer;
  S: string;
  MaBmp: TBitmap;
 
begin
  if (FMax - FMin) > 0 then
    X := round((100 * (FPosition - FMin)) / (FMax - FMin))
  else
    X := 0;
  if (X >= 66) then
  begin
    rl := Red(FCouleur3);
    rh := Red(FCouleur4);
    gl := Green(FCouleur3);
    gh := Green(FCouleur4);
    bl := Blue(FCouleur3);
    bh := Blue(FCouleur4);
    Seuil := 66;
    Plage := 100 - 66;
  end;
  if (X >= 33) and (X < 66) then
  begin
    rl := Red(FCouleur2);
    rh := Red(FCouleur3);
    gl := Green(FCouleur2);
    gh := Green(FCouleur3);
    bl := Blue(FCouleur2);
    bh := Blue(FCouleur3);
    Seuil := 33;
    Plage := 66 - 33;
  end;
  if (X < 33) then
  begin
    rl := Red(FCouleur1);
    rh := Red(FCouleur2);
    gl := Green(FCouleur1);
    gh := Green(FCouleur2);
    bl := Blue(FCouleur1);
    bh := Blue(FCouleur2);
    Seuil := 0;
    Plage := 33 - 0;
  end;
 
  if FProgressif then
  begin
    R := round((rh - rl) * (X - Seuil) / Plage + rl);
    G := round((gh - gl) * (X - Seuil) / Plage + gl);
    B := round((bh - bl) * (X - Seuil) / Plage + bl);
    Canvas.Brush.Color := RGBToColor(R, G, B);
  end
  else
  begin
    if X >= 100 then
    begin
      X := 100;
      Canvas.Brush.Color := FCouleur4;
    end
    else
    begin
      Canvas.Brush.Color := RGBToColor(rl, gl, bl);
    end;
  end;
  xt := (X * Width) div 100;
  Canvas.FillRect(0, 0, xt, Height);
  Canvas.Brush.Color := clWhite;
  Canvas.FillRect(xt, 0, Width, Height);
  S := FMyText + Format(' %3d%%', [X]);
  xt := (Width - Canvas.GetTextWidth(S)) div 2;
  yt := (Height - Canvas.GetTextHeight(S)) div 2;
 
  MaBmp := TBitmap.Create;
  MaBmp.Width := Width;
  MaBmp.Height := Height;
  MaBmp.Transparent := True;
  MaBmp.TransparentColor := Canvas.Brush.Color;
  MaBmp.Canvas.Brush.Color := Canvas.Brush.Color;
  MaBmp.Canvas.Brush.Style := bsSolid;
  MaBmp.Canvas.FillRect(0, 0, Width, Height);
  MaBmp.Canvas.Font.Color := clBlack;
  MaBmp.Canvas.TextOut(xt, yt, S);
  Canvas.Draw(0, 0, MaBmp);
  MaBmp.Free;
end;
 
 
constructor TCompoTest.Create(MyOwner: TComponent);
begin
  inherited Create(MyOwner);
  Width := 100;
  Height := 20;
  FMax := 100;
  FMin := 0;
  FPosition := 50;
 
  FCouleur1 := clRed;
  FCouleur2 := clYellow;
  FCouleur3 := clLime;
  FCouleur4 := clBlue;
 
  FProgressif := True;
end;
 
function TCompoTest.GetMax: integer;
begin
  Result := FMax;
end;
 
function TCompoTest.GetMin: integer;
begin
  Result := FMin;
end;
 
function TCompoTest.GetPosition: integer;
begin
  Result := FPosition;
end;
 
procedure TCompoTest.SetMax(Nouv: integer);
begin
  FMax := Nouv;
end;
 
procedure TCompoTest.SetMin(Nouv: integer);
begin
  FMin := Nouv;
end;
 
procedure TCompoTest.SetPosition(Nouv: integer);
begin
  FPosition := Nouv;
end;
 
function TCompoTest.GetCouleur1: TColor;
begin
  Result := FCouleur1;
end;
 
procedure TCompoTest.SetCouleur1(Nouv: TColor);
begin
  FCouleur1 := Nouv;
end;
 
function TCompoTest.GetCouleur2: TColor;
begin
  Result := FCouleur2;
end;
 
procedure TCompoTest.SetCouleur2(Nouv: TColor);
begin
  FCouleur2 := Nouv;
end;
 
function TCompoTest.GetCouleur3: TColor;
begin
  Result := FCouleur3;
end;
 
procedure TCompoTest.SetCouleur3(Nouv: TColor);
begin
  FCouleur3 := Nouv;
end;
 
function TCompoTest.GetCouleur4: TColor;
begin
  Result := FCouleur4;
end;
 
procedure TCompoTest.SetCouleur4(Nouv: TColor);
begin
  FCouleur4 := Nouv;
end;
 
 
function TCompoTest.GetProgressif: boolean;
begin
  Result := FProgressif;
end;
 
procedure TCompoTest.SetProgressif(Nouv: boolean);
begin
  FProgressif := Nouv;
end;
 
end.

L'écriture du texte donne des résultats mitigé en fonction de l'OS. Pour l'instant je n'ai testé que sous windows Seven

[tourlourou]

Content que ça fonctionne.

Voici des précisions assez intéressantes sur Owner et Parent : http://www.developpez.net/forums/d11...e/#post6326346

En D5, je faisais donc bien de continuer à les différencier, mais un peu comme M. Jourdain ! Depuis, ou en Lazarus, à vérifier...

[ChPr]

Je me permets d'intervenir car j'ai des problèmes avec TGraphicControl.

Dans l'environnement Linux (Ubuntu 11.04 pour moi), si je place ce composant, ou un de ses descendants dans un TGroupBox, l'affichage de ce composant est décalé vers le haut/gauche par rapport à son placement initial. Tu peux télécharger le fichier de mon composant (une jauge).

En est-il de même avec le tien ?

Cordialement.

Pierre

[Gouyon]

Non ça marche je viens de l'installer. Par contre ma version d'Ubuntu est 10.10 (la 11.04 ne fonctionne pas sur ma machine). J'ai installer le tient et il marche parfaitement sous linux. Il est assez similaire à ce que j'ai fait.