Discussion :

[KlausGunther]

Je suis sous W10, je n'utilise pas de thème particulier, et j'utilise Delphi 6 Personal Edition.

Je veux changer les couleurs d'un composant TProgressBar via SendMessage. Je peux le faire pour la barre indiquant la position, de la manière suivante:

Code :

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

1
2
3
4
procedure ChangeProgressBarColor1(ProgressBarHandle: HWND; clBar: TColor);
begin
    SendMessage (ProgressBarHandle, PBM_SETBARCOLOR, 0, clrBar);
end;

Mais je ne peux pas changer la couleur de fond:

Code :

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

1
2
3
4
procedure ChangeProgressBarColor2(ProgressBarHandle: HWND; clBack: TColor);
begin
    SendMessage (ProgressBarHandle, PBM_SETBKCOLOR, 0, clrBack);
end;

J'ai vérifié la valeur de la constante PBM_SETBKCOLORqui équivaut à $2001 chez moi, ce qui est exact selon MSDN.
Lors de la première utilisation de PBM_SETBKCOLOR, l'API retourne $FF000000.
Ensuite, pour chaque appel successif, l'API retourne la valeur clrBack que je veux imposer, seulement elle n'est pas visible dans l'affichage qui reste à sa couleur par défaut.

Qu'est-ce que j'ai manqué pour pouvoir changer la couleur de fond d'un TProgressBar ?

[KlausGunther]

J'ai trouvé une solution "brute force" qui ne me satisfait pas mais qui colore le fond.

Je capture le canvas à partir du handle, je fais un floodfill dans la partie non couverte par la barre de progression, avec la couleur de fond souhaitée, puis je libère le canvas. Comme ceci:

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
 
...
 
type
  pObjectCanvas=^TObjectCanvas;
  TObjectCanvas=record
    hDC: THandle;
    WindowHandle: THandle;
    MustFreeDC: boolean;
    Width: integer;
    Height: integer;
    PenPos: TPoint;
  end;
 
  TObjectCanvasList=class(TList)
  private
    function Get(Index: Integer): pObjectCanvas;
  public
    destructor Destroy; override;
    function Add(Value: pObjectCanvas): Integer;
    property Items[Index: Integer]: pObjectCanvas read Get; default;
  end;
 
...
 
Implementation
 
function SetProgressBarColor(hnd: HWND; clrBack, clrBar: TColor): integer; stdcall; export;
var
  res: integer;
  WndRec: TRect;
  OC: pObjectCanvas;
  OCL: TObjectCanvasList;
  bmp: TBitmap;
  cBMP: HBITMAP;
  px: TColor;
begin
  result := -1;
  try
    SendMessage (hnd, PBM_SETBARCOLOR, 0, clrBar);
    delay(100);
 
    GetWindowRect(hnd,WndRec);                     // Windows fournit les dimensions de l'objet
    GetMem(OC, SizeOf(TObjectCanvas));             // réserver l'espace pour l'objet OC
    OC.hDC := GetDC(hnd);                          // Windows fournit le DC pour cet objet
    OC.MustFreeDC := true;                         // le DC doit être libéré par la DLL !
    OC.WindowHandle := hnd;                        // et donc mémoriser le handle de l'objet
    OC.Width := WndRec.Right-WndRec.Left;          // installer les dimensions de l'objet
    OC.Height := WndRec.Bottom-WndRec.Top;
    OCL := TObjectCanvasList.Create;               // créer une liste d'objets
    OCL.Add(OC);                                   // y ajouter l'objet OC
 
    bmp := Graphics.tBitmap.create;
    cBMP := CreateCompatibleBitmap(OC.hDC, OC.Width, OC.Height);
    bmp.Width := OC.Width;                                     // ajuster les dimensions
    bmp.Height := OC.Height;
    bmp.Handle:=cBMP;
    if not BitBlt(bmp.Canvas.Handle,0,0,OC.Width,OC.Height,OC.hDC,0,0,SRCCOPY) then begin
//      ShowMessage('Oups 1: '+IntToStr(getlasterror)+' '+SysErrorMessage(GetLastError))   // récupérer le contenu du canvas
    end;
 
    px := bmp.Canvas.Pixels[OC.Width-5,OC.Height-5];
    if px<>clrBar then begin
      bmp.Canvas.Brush.Color := clrBack;
      bmp.Canvas.FloodFill(OC.Width-5,OC.Height-5,px,fsSurface);
      delay(100);
    end;
    if not BitBlt(OC.hDC,0,0,OC.Width,OC.Height,bmp.Canvas.Handle,0,0,SRCCOPY) then begin
//      ShowMessage('Oups 2: '+IntToStr(getlasterror)+' '+SysErrorMessage(GetLastError))   // réécrire l'image résultante dans le canvas
    end;
    DeleteObject(cBMP);
    bmp.free;
 
 
    if OCL.Items[0].MustFreeDC then ReleaseDC(OCL.Items[0].WindowHandle,OCL.Items[0].hDC);
    OCL.Free;
 
    result := 0;
  except
  end;
end;
exports SetProgressBarColor;
 
...

Si j'appelle ma fonction avec clrBack=clYellow et clrBar=clRed, j'obtiens ceci:

C'est exactement ce que je veux obtenir. Mais quelle usine à gaz ! N'y aurait-il pas une solution plus sérieuse ?

[SergioMaster]

Bonjour,

à votre place, j'irai faire un tour dans les sources du TGauge

[KlausGunther]

J'ai regardé ce source qui est simple et limpide. Mais ça ne m'avance pas, malheureusement.

Dans mon cas, je suis en train de créer une fonction dans une vaste DLL de soutien à un langage tiers. Ma fonction est appelée à partir de ce langage, et je ne connais que le handle de la ProgressBar. Je n'ai pas accès à l'instance de l'objet, et donc pas non plus à ses méthodes, propriétés et variables privées. Mon seul moyen est d'agir par des API via le handle.

Ceci fonctionne parfaitement pour la couleur de la partie variable de la barre. Un seul SendMessage et le changement de couleur est durable pour l'objet, quelque soit la longueur de la barre.

Il en va différemment pour la couleur de fond. Alors que la valeur retournée par SendMessage indique bien que mon changement de couleur a été pris en compte, à l'écran, je ne vois que la couleur de fond par défaut. Car, en réalité, à chaque évènement Draw de l'objet, le fond est redessiné avec la couleur de fond par défaut et non la nouvelle couleur imposée par SendMessage code PBM_SETBKCOLOR. C'est pour cette raison que j'ai trouvé le hack pour peindre directement dans le canvas de l'objet. Conséquence négative: il faut le refaire systématiquement après chaque changement de position, et même après chaque recouvrement de l'objet par une autre fenêtre, etc.

Je cherche donc un moyen qui, à l'instar de SendMessage code PBM_SETBKCOLOR, permet de changer la couleur de fond de façon pérenne.

[KlausGunther]

Suite à la proposition de SergioMaster, j'ai utilisé Gauges.pas pour créer mes propres ProgessBars.

Ca marche parfaitement, bien sûr, même si je dois les "injecter" dans la fenêtre de destination. Et comme les composants TGauge sont des descendants de TGraphicControl et n'ont donc pas de propriété ParentWindow, j'au dû créer un TPanel dans lequel le place le TGauge, et j'injecte le TPanel dans la fenêtre de destination via le handle de cette fenêtre qui m'est passé en paramètre lors de la création de la barre.

Autre écueil: un objet TGauge n''a pas de cadrre 3D, seulement un rectangle noir comme bordure, ou rien du tout. Je l'ai donc configuré sans bordure du tout et j'ai ajusté le bevel du TPanel de sorte à obtenir le même effet 3D quie celui d'une ProgressBar normale.

Voici le code de cette unité, permettant de créer les 5 types de ProgressBar offerts par TGauge:

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
unit KGF_unit_ProgressBar;
 
interface
  uses Windows, Forms, SysUtils, Controls, ExtCtrls, ComCtrls, Gauges, Graphics, Dialogs;
 
implementation
 
function CreateProgressBar(dest: HWND; typ: TGaugeKind):integer; stdcall; export;
var
  PA: TPanel;
  PB0: TProgressBar;
  PB: TGauge;
begin
  result := 0;
  try
    PA := TPanel.Create(nil);
    PA.ParentWindow := dest;
 
    PA.BevelOuter := bvLowered;
    PA.BevelInner := bvNone; 
    PA.BevelWidth := 1;
 
    PB0 := TProgressBar.Create(PA);
    PB := TGauge.Create(PA);
    PA.InsertControl(PB);
    PB.Kind := typ;
    PB.BorderStyle := bsNone;
    PA.Width := PB.Width;
    PA.Height := PB.Height;
    PB0.Width := PB.Width;
    PB0.Height := PB.Height;
    PB.Top:= 2;
    PB.Left := 2;
    PB.Width := PB.Width - 4;
    PB.Height := PB.Height - 4;
    result := integer(PB);
  except
  end;
end;
exports CreateProgressBar;
 
function DeleteProgressBar(PB: TGauge):integer; stdcall; export;
var
  PA: TPanel;
begin
  result := integer(PB);
  try
    if not assigned(PB) then exit;
    if PB.ClassName<>'TGauge' then exit;
    PA := TPanel(PB.Owner);
    PB.Free;
    PA.Free;
    result := 0;
  except
  end;
end;
exports DeleteProgressBar;
 
function LocateProgressBar(PB: TGauge; x,y,w,h: integer):integer; stdcall; export;
var
  PA: TPanel;
begin
  result := 0;
  try
    PA := TPanel(PB.Owner);
    PA.Left := x;
    PA.Top := y;
    PA.Width := w;
    PA.Height := h;
    PB.Width := w-4;
    PB.Height := h-4;
    result := 0;
  except
  end;
end;
exports LocateProgressBar;
 
function SetProgressBarLimits(PB: TGauge; bas, haut: integer): integer; stdcall; export;
begin
  result := 0;
  try
    PB.MinValue := bas;
    PB.MaxValue := haut;
    result := 0;
  except
  end;
end;
exports SetProgressBarLimits;
 
function SetProgressBarPosition(PB: TGauge; pos: integer): integer; stdcall; export;
begin
  result := 0;
  try
    PB.Progress := pos;
    result := 0;
  except
  end;
end;
exports SetProgressBarPosition;
 
function SetProgressBarColors(PB: TGauge; clrBack, clrBar: TColor): integer; stdcall; export;
begin
  result := 0;
  try
    PB.BackColor := clrBack;
    PB.ForeColor := clrBar;
    result := 0;
  except
  end;
end;
exports SetProgressBarColors;
 
end.

Bon, c'est très joli tout ça. Pour de nouveaux programmes du langage externe en question, on peut faire appel à ce composant composite au lieu de la ProgressBar classique. Mais j'aimerais tout de même offir une solution viable pour des programmes existants, afin de pouvoir colorer les ProgressBars sans avoir à réécrire des portions de code existant.

[KlausGunther]

J'ai même ajouté un 6ème type de ProgressBar en utilisaent une copie modifiée de Gauges.pas: j'ai ajouté une ProgressBar en forme d'annéau (cercle ou ellipse) avec un trou de diamètre réglable. C'est fait en utilisant les régions Windows ce qui permet d'avoir un vrai trou et de voir et cliquer à travers.

Voici la version modifiée de Gauges.pas:

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
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
Unit KGF_unit_Gauges;
 
{
  Ce module est une version modifiée de Gauges.pas fourni avec Delphi 6 Personal Edition.
 
  Historique des modifications:
  Date         Auteur  Explication
  ====================================================================================
  18/04/2018   Klaus   ajout du type gkRing dans TGaugeKind
                       ajout du type TGaugeHole
                       ajout de la propriété Hole
                       gestion de cet anneau par des régions Windows
}
 
interface
 
uses SysUtils, Windows, Messages, Classes, Graphics, Controls, Forms, StdCtrls;
 
type
 
  TGaugeKind = (gkText, gkHorizontalBar, gkVerticalBar, gkPie, gkNeedle, gkRing);
 
  TGaugeHole = record
    xleft,xtop,xwidth,xheight: integer
  end;
 
  TGauge = class(TGraphicControl)
  private
    FMinValue: Longint;
    FMaxValue: Longint;
    FCurValue: Longint;
    FKind: TGaugeKind;
    FShowText: Boolean;
    FBorderStyle: TBorderStyle;
    FForeColor: TColor;
    FBackColor: TColor;
    fInnerRingDiameter: integer;
    fHole: TGaugeHole;
 
    procedure PaintBackground(AnImage: TBitmap);
    procedure PaintAsText(AnImage: TBitmap; PaintRect: TRect);
    procedure PaintAsNothing(AnImage: TBitmap; PaintRect: TRect);
    procedure PaintAsBar(AnImage: TBitmap; PaintRect: TRect);
    procedure PaintAsPie(AnImage: TBitmap; PaintRect: TRect);
    procedure PaintAsNeedle(AnImage: TBitmap; PaintRect: TRect);
    procedure SetGaugeKind(Value: TGaugeKind);
    procedure SetShowText(Value: Boolean);
    procedure SetBorderStyle(Value: TBorderStyle);
    procedure SetForeColor(Value: TColor);
    procedure SetBackColor(Value: TColor);
    procedure SetMinValue(Value: Longint);
    procedure SetMaxValue(Value: Longint);
    procedure SetProgress(Value: Longint);
    function GetPercentDone: Longint;
  protected
    procedure Paint; override;
  public
    constructor Create(AOwner: TComponent); override;
    procedure AddProgress(Value: Longint);
    property PercentDone: Longint read GetPercentDone;
  published
    property Align;
    property Anchors;
    property BackColor: TColor read FBackColor write SetBackColor default clWhite;
    property BorderStyle: TBorderStyle read FBorderStyle write SetBorderStyle default bsSingle;
    property Color;
    property Constraints;
    property Enabled;
    property ForeColor: TColor read FForeColor write SetForeColor default clBlack;
    property Font;
    property Kind: TGaugeKind read FKind write SetGaugeKind default gkHorizontalBar;
    property MinValue: Longint read FMinValue write SetMinValue default 0;
    property MaxValue: Longint read FMaxValue write SetMaxValue default 100;
    property ParentColor;
    property ParentFont;
    property ParentShowHint;
    property PopupMenu;
    property Progress: Longint read FCurValue write SetProgress;
    property ShowHint;
    property ShowText: Boolean read FShowText write SetShowText default True;
    property Visible;
    property InnerRingDiameter: integer read fInnerRingDiameter write fInnerRingDiameter;
    property Hole: TGaugeHole read fHole write fHole;
  end;
 
implementation
 
uses Consts;
 
type
  TBltBitmap = class(TBitmap)
    procedure MakeLike(ATemplate: TBitmap);
  end;
 
{ TBltBitmap }
 
procedure TBltBitmap.MakeLike(ATemplate: TBitmap);
begin
  Width := ATemplate.Width;
  Height := ATemplate.Height;
  Canvas.Brush.Color := clWindowFrame;
  Canvas.Brush.Style := bsSolid;
  Canvas.FillRect(Rect(0, 0, Width, Height));
end;
 
{ This function solves for x in the equation "x is y% of z". }
function SolveForX(Y, Z: Longint): Longint;
begin
  Result := Longint(Trunc( Z * (Y * 0.01) ));
end;
 
{ This function solves for y in the equation "x is y% of z". }
function SolveForY(X, Z: Longint): Longint;
begin
  if Z = 0 then Result := 0
  else Result := Longint(Trunc( (X * 100.0) / Z ));
end;
 
{ TGauge }
 
constructor TGauge.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  ControlStyle := ControlStyle + [csFramed, csOpaque];
  { default values }
  FMinValue := 0;
  FMaxValue := 100;
  FCurValue := 0;
  FKind := gkHorizontalBar;
  FShowText := True;
  FBorderStyle := bsSingle;
  FForeColor := clBlack;
  FBackColor := clWhite;
  fInnerRingDiameter := 80;
  fHole.xleft := 10;
  fHole.xtop := 10;
  fHole.xwidth := 80;
  fHole.xheight := 80;
  Width := 100;
  Height := 100;
end;
 
function TGauge.GetPercentDone: Longint;
begin
  Result := SolveForY(FCurValue - FMinValue, FMaxValue - FMinValue);
end;
 
procedure TGauge.Paint;
var
  TheImage: TBitmap;
  OverlayImage: TBltBitmap;
  PaintRect: TRect;
begin
  with Canvas do
  begin
    TheImage := TBitmap.Create;
    try
      TheImage.Height := Height;
      TheImage.Width := Width;
      PaintBackground(TheImage);
      PaintRect := ClientRect;
      if FBorderStyle = bsSingle then InflateRect(PaintRect, -1, -1);
      OverlayImage := TBltBitmap.Create;
      try
        OverlayImage.MakeLike(TheImage);
        PaintBackground(OverlayImage);
        case FKind of
          gkText: PaintAsNothing(OverlayImage, PaintRect);
          gkHorizontalBar, gkVerticalBar: PaintAsBar(OverlayImage, PaintRect);
          gkPie: PaintAsPie(OverlayImage, PaintRect);
          gkNeedle: PaintAsNeedle(OverlayImage, PaintRect);
          gkRing: PaintAsPie(OverlayImage, PaintRect);
        end;
        TheImage.Canvas.CopyMode := cmSrcInvert;
        TheImage.Canvas.Draw(0, 0, OverlayImage);
        TheImage.Canvas.CopyMode := cmSrcCopy;
        if ShowText then PaintAsText(TheImage, PaintRect);
      finally
        OverlayImage.Free;
      end;
      Canvas.CopyMode := cmSrcCopy;
      Canvas.Draw(0, 0, TheImage);
    finally
      TheImage.Destroy;
    end;
  end;
end;
 
procedure TGauge.PaintBackground(AnImage: TBitmap);
var
  ARect: TRect;
begin
  with AnImage.Canvas do
  begin
    CopyMode := cmBlackness;
    ARect := Rect(0, 0, Width, Height);
    CopyRect(ARect, Animage.Canvas, ARect);
    CopyMode := cmSrcCopy;
  end;
end;
 
procedure TGauge.PaintAsText(AnImage: TBitmap; PaintRect: TRect);
var
  S: string;
  X, Y: Integer;
  OverRect: TBltBitmap;
begin
  OverRect := TBltBitmap.Create;
  try
    OverRect.MakeLike(AnImage);
    PaintBackground(OverRect);
    S := Format('%d%%', [PercentDone]);
    with OverRect.Canvas do
    begin
      Brush.Style := bsClear;
      Font := Self.Font;
      Font.Color := clWhite;
      with PaintRect do
      begin
        X := (Right - Left + 1 - TextWidth(S)) div 2;
        Y := (Bottom - Top + 1 - TextHeight(S)) div 2;
      end;
      TextRect(PaintRect, X, Y, S);
    end;
    AnImage.Canvas.CopyMode := cmSrcInvert;
    AnImage.Canvas.Draw(0, 0, OverRect);
  finally
    OverRect.Free;
  end;
end;
 
procedure TGauge.PaintAsNothing(AnImage: TBitmap; PaintRect: TRect);
begin
  with AnImage do
  begin
    Canvas.Brush.Color := BackColor;
    Canvas.FillRect(PaintRect);
  end;
end;
 
procedure TGauge.PaintAsBar(AnImage: TBitmap; PaintRect: TRect);
var
  FillSize: Longint;
  W, H: Integer;
begin
  W := PaintRect.Right - PaintRect.Left + 1;
  H := PaintRect.Bottom - PaintRect.Top + 1;
  with AnImage.Canvas do
  begin
    Brush.Color := BackColor;
    FillRect(PaintRect);
    Pen.Color := ForeColor;
    Pen.Width := 1;
    Brush.Color := ForeColor;
    case FKind of
      gkHorizontalBar:
        begin
          FillSize := SolveForX(PercentDone, W);
          if FillSize > W then FillSize := W;
          if FillSize > 0 then FillRect(Rect(PaintRect.Left, PaintRect.Top,
            FillSize, H));
        end;
      gkVerticalBar:
        begin
          FillSize := SolveForX(PercentDone, H);
          if FillSize >= H then FillSize := H - 1;
          FillRect(Rect(PaintRect.Left, H - FillSize, W, H));
        end;
    end;
  end;
end;
 
procedure TGauge.PaintAsPie(AnImage: TBitmap; PaintRect: TRect);
var
  MiddleX, MiddleY: Integer;
  Angle: Double;
  W, H: Integer;
begin
  W := PaintRect.Right - PaintRect.Left;
  H := PaintRect.Bottom - PaintRect.Top;
  if FBorderStyle = bsSingle then
  begin
    Inc(W);
    Inc(H);
  end;
  with AnImage.Canvas do
  begin
    Brush.Color := Color;
    FillRect(PaintRect);
    Brush.Color := BackColor;
    Pen.Color := ForeColor;
    Pen.Width := 1;
    Ellipse(PaintRect.Left, PaintRect.Top, W, H);
    if PercentDone > 0 then
    begin
      Brush.Color := ForeColor;
      MiddleX := W div 2;
      MiddleY := H div 2;
      Angle := (Pi * ((PercentDone / 50) + 0.5));
      Pie(PaintRect.Left, PaintRect.Top, W, H,
        Integer(Round(MiddleX * (1 - Cos(Angle)))),
        Integer(Round(MiddleY * (1 - Sin(Angle)))), MiddleX, 0);
    end;
  end;
end;
 
procedure TGauge.PaintAsNeedle(AnImage: TBitmap; PaintRect: TRect);
var
  MiddleX: Integer;
  Angle: Double;
  X, Y, W, H: Integer;
begin
  with PaintRect do
  begin
    X := Left;
    Y := Top;
    W := Right - Left;
    H := Bottom - Top;
    if FBorderStyle = bsSingle then
    begin
      Inc(W);
      Inc(H);
    end;
  end;
  with AnImage.Canvas do
  begin
    Brush.Color := Color;
    FillRect(PaintRect);
    Brush.Color := BackColor;
    Pen.Color := ForeColor;
    Pen.Width := 1;
    Pie(X, Y, W, H * 2 - 1, X + W, PaintRect.Bottom - 1, X, PaintRect.Bottom - 1);
    MoveTo(X, PaintRect.Bottom);
    LineTo(X + W, PaintRect.Bottom);
    if PercentDone > 0 then
    begin
      Pen.Color := ForeColor;
      MiddleX := Width div 2;
      MoveTo(MiddleX, PaintRect.Bottom - 1);
      Angle := (Pi * ((PercentDone / 100)));
      LineTo(Integer(Round(MiddleX * (1 - Cos(Angle)))),
        Integer(Round((PaintRect.Bottom - 1) * (1 - Sin(Angle)))));
    end;
  end;
end;
 
procedure TGauge.SetGaugeKind(Value: TGaugeKind);
begin
  if Value <> FKind then
  begin
    FKind := Value;
    Refresh;
  end;
end;
 
procedure TGauge.SetShowText(Value: Boolean);
begin
  if Value <> FShowText then
  begin
    FShowText := Value;
    Refresh;
  end;
end;
 
procedure TGauge.SetBorderStyle(Value: TBorderStyle);
begin
  if Value <> FBorderStyle then
  begin
    FBorderStyle := Value;
    Refresh;
  end;
end;
 
procedure TGauge.SetForeColor(Value: TColor);
begin
  if Value <> FForeColor then
  begin
    FForeColor := Value;
    Refresh;
  end;
end;
 
procedure TGauge.SetBackColor(Value: TColor);
begin
  if Value <> FBackColor then
  begin
    FBackColor := Value;
    Refresh;
  end;
end;
 
procedure TGauge.SetMinValue(Value: Longint);
begin
  if Value <> FMinValue then
  begin
    if Value > FMaxValue then
      if not (csLoading in ComponentState) then
        raise EInvalidOperation.CreateFmt(SOutOfRange, [-MaxInt, FMaxValue - 1]);
    FMinValue := Value;
    if FCurValue < Value then FCurValue := Value;
    Refresh;
  end;
end;
 
procedure TGauge.SetMaxValue(Value: Longint);
begin
  if Value <> FMaxValue then
  begin
    if Value < FMinValue then
      if not (csLoading in ComponentState) then
        raise EInvalidOperation.CreateFmt(SOutOfRange, [FMinValue + 1, MaxInt]);
    FMaxValue := Value;
    if FCurValue > Value then FCurValue := Value;
    Refresh;
  end;
end;
 
procedure TGauge.SetProgress(Value: Longint);
var
  TempPercent: Longint;
begin
  TempPercent := GetPercentDone;  { remember where we were }
  if Value < FMinValue then
    Value := FMinValue
  else if Value > FMaxValue then
    Value := FMaxValue;
  if FCurValue <> Value then
  begin
    FCurValue := Value;
    if TempPercent <> GetPercentDone then { only refresh if percentage changed }
      Refresh;
  end;
end;
 
procedure TGauge.AddProgress(Value: Longint);
begin
  Progress := FCurValue + Value;
  Refresh;
end;
 
end.

et l'unité qui sert de "wrapper" pour une langage externe pour lequel je réalise ces fonctions:

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
unit KGF_unit_ProgressBar;
 
interface
  uses Windows, Forms, SysUtils, Controls, ExtCtrls, ComCtrls, KGF_unit_Gauges, Graphics, Dialogs;
 
implementation
 
procedure WindowEllipticRegion(xhand,xleft,xtop,xwidth,xheight: integer);
  var
    Rgn : HRGN;
begin
  try
    Rgn := CreateEllipticRgn(xleft,xtop,xleft+xwidth,xtop+xheight);
    SetWindowRgn(xhand,Rgn,true);
  finally
  end;
end;
 
procedure WindowEllipticHole(xhand,xmode,xleft,xtop,xwidth,xheight: integer);
  var
    Rgn1 : HRGN;
    Rgn2 : HRGN;
    NewRgn : HRGN;
    WinInfo: TWindowInfo;
    WinRect: TRect;
    xrgn: HRGN;
 
begin
  try
    FillChar(WinInfo, Sizeof(WinInfo), 0);
    WinInfo.cbSize := Sizeof(WinInfo);
    GetWindowInfo(xhand, WinInfo);
    WinRect := WinInfo.rcWindow;
    Rgn1 := CreateEllipticRgn(xleft,xtop,xleft+xwidth,xtop+xheight);
 
    xrgn := CreateRectRgn(0,0,0,0);
    GetWindowRgn(xhand,xrgn);
    Rgn2 := xrgn;
 
    NewRgn := CreateRectRgn(0,0,0,0);
    if xmode=1 then
        CombineRgn(NewRgn,Rgn1,Rgn2,RGN_XOR)
    else
        CombineRgn(NewRgn,Rgn1,Rgn2,RGN_OR);
    DeleteObject(Rgn1);
    DeleteObject(Rgn2);
    SetWindowRgn(xhand,NewRgn,true);
  finally
  end;
end;
 
function CreateKGFProgressBar(dest: HWND; typ: TGaugeKind):integer; stdcall; export;
var
  PA: TPanel;
  PB: TGauge;
  xleft,xtop,xwidth,xheight, d: integer;
begin
  result := 0;
  try
    PA := TPanel.Create(nil);
    PA.ParentWindow := dest;
 
    PA.BevelOuter := bvLowered;
    PA.BevelInner := bvNone;
    PA.BevelWidth := 1;
 
    PB := TGauge.Create(PA);
    PA.InsertControl(PB);
    PB.Kind := typ;
    PB.BorderStyle := bsNone;
    PA.Width := PB.Width;
    PA.Height := PB.Height;
    PB.Top:= 2;
    PB.Left := 2;
    PB.Width := PB.Width - 4;
    PB.Height := PB.Height - 4;
    if typ=gkRing then begin
                         PB.InnerRingDiameter := round(PB.Width*0.8);
                         d := round((PB.Width - PB.InnerRingDiameter)/2);
                         xleft   := PB.Left + d;
                         xtop    := PB.Top + d;
                         xwidth  := PB.Width - 2*d;
                         xheight := PB.Height - 2*d;
                         WindowEllipticRegion(PA.Handle,PB.Left,PB.Top,PB.Width,PB.Height);
                         WindowEllipticHole(PA.Handle,1,xleft,xtop,xwidth,xheight);
                       end else begin
                         PB.InnerRingDiameter := 0;
                       end;
    result := integer(PB);
  except
  end;
end;
exports CreateKGFProgressBar;
 
function DeleteKGFProgressBar(PB: TGauge):integer; stdcall; export;
var
  PA: TPanel;
begin
  result := integer(PB);
  try
    if not assigned(PB) then exit;
    if PB.ClassName<>'TGauge' then exit;
    PA := TPanel(PB.Owner);
    PB.Free;
    PA.Free;
    result := 0;
  except
  end;
end;
exports DeleteKGFProgressBar;
 
function LocateKGFProgressBar(PB: TGauge; x,y,w,h,inner: integer):integer; stdcall; export;
var
  PA: TPanel;
  xleft,xtop,xwidth,xheight, d: integer;
  xHole: TGaugeHole;
  Rgn2 : HRGN;
begin
  result := 0;
  try
    PA := TPanel(PB.Owner);
    PA.Left := x;
    PA.Top := y;
    PA.Width := w;
    PA.Height := h;
    PB.Width := w-4;
    PB.Height := h-4;
    if PB.Kind=gkRing then begin
                             xHole := PB.Hole;
                             Rgn2 := CreateRectRgn(0, 0, PB.Width, PB.Height);
                             SetWindowRgn(PA.Handle,Rgn2,true);
//                             WindowEllipticHole(PA.Handle,0,xHole.xleft,xHole.xtop,xHole.xwidth,xHole.xheight);
                             if inner<PB.Width then PB.InnerRingDiameter := inner
                                               else PB.InnerRingDiameter := round(PB.Width*0.8);
                             d := round((PB.Width - PB.InnerRingDiameter)/2);
                             xHole.xleft   := PB.Left + d;
                             xHole.xtop    := PB.Top + d;
                             xHole.xwidth  := PB.Width - 2*d;
                             xHole.xheight := PB.Height - 2*d;
                             PB.Hole := xHole;
                             WindowEllipticRegion(PA.Handle,PB.Left,PB.Top,PB.Width,PB.Height);
                             WindowEllipticHole(PA.Handle,1,xHole.xleft,xHole.xtop,xHole.xwidth,xHole.xheight);
                           end else begin
                             PB.InnerRingDiameter := 0;
                           end;
    result := 0;
  except
  end;
end;
exports LocateKGFProgressBar;
 
function SetKGFProgressBarLimits(PB: TGauge; bas, haut: integer): integer; stdcall; export;
begin
  result := 0;
  try
    PB.MinValue := bas;
    PB.MaxValue := haut;
    result := 0;
  except
  end;
end;
exports SetKGFProgressBarLimits;
 
function SetKGFProgressBarPosition(PB: TGauge; pos: integer): integer; stdcall; export;
begin
  result := 0;
  try
    PB.Progress := pos;
    result := 0;
  except
  end;
end;
exports SetKGFProgressBarPosition;
 
function SetKGFProgressBarColors(PB: TGauge; clrBack, clrBar: TColor): integer; stdcall; export;
begin
  result := 0;
  try
    PB.BackColor := clrBack;
    PB.ForeColor := clrBar;
    result := 0;
  except
  end;
end;
exports SetKGFProgressBarColors;
 
end.

Ceci dit, je reste toujours sur la question initiale: comment changer la couleur de fond d'un TScrollBar standard, en uttilisant des APIs ? Ma technique de "craquer" le canvas de l'objet et de dessiner dessus est certes opérationnelle, mais je la trouve très inélégante. Et elle a surtout un grand inconvéniant: dès que la ScrollBar est recouverte par autre chose, il faut la redessiner lorsqu'elle réapparaît. Or, je n'ai pas accès à son évènement ON_DRAW... j'ai seulement son handle. Est-e que je devrai remplacer la WndProc de l'objet pour intercepter les messages Windows concernés ? C'est lourd également...

[SergioMaster]

Bonjour,

ma réponse en indiquant le TGauge était faite sans avoir les informations sous-jacente à savoir la dll, j'étais juste trop surpris de l'utilisation des messages Windows que cela me semblait un peu "disproportionné" surtout qu'il existait ces fameuse jauges.
La réponse à votre question se trouve certainement dans le livre 'the tomes of Delphi 3 : Win32 Graphical API' que j'ai en main, toutefois c'est un tel pavé (presque 900 pages), accompagné qui plus est d'un CD qu'il est difficile de trouver la réponse surtout qu'il n'y a pas d'entrées directe comme TProgress
il y a par contre un chapitre complet sur les fonctions painting et drawing (paintrgn, extfloodfill) m'ont interpellé, puisque vous parlez de régions un chapitre enier est consacré aux fonctions region and path et enfin il y a un appendice complet sur les messages.
Je vais essayer de remettre la main sur le CD accompagnateur qui contient "a complete Help file for use within Delphi"

Malheureusement, je pense que ce livre est largement épuisé et ne sera pas ré-édité (et bien sûr n'existe pas en version électronique )
je peux, à l'occasion vous faire parvenir quelques scan pages (faut en profiter, je suis en vacance encore aujourd'hui , pas encore joyeux retraité mais peut être proche du pays de cocagne selon mes derniers entretiens avec l'organisme qui correspond si bien à la description de l'administration vaincue par Astérix !

[anapurna]

salut

alors pourquoi faire simple quand on peut faire compliqué

Code :

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

Progress.Brush.Color := ClRed; // change la couleur du background

[KlausGunther]

alors pourquoi faire simple quand on peut faire compliqué

Ah oui, j'aimerais bien... mais le contexte ne le permet pas. Je rappelle la situation complète ici:
- je suis sous W10
- j'utilise Delphi 6 Personal Edition
- je réalise une vaste DLL d'extension et de soutien à un langage de programmation tiers (un clone de Basic)
- dans ce contexte, je n'ai pas accès aux instances des composants créés par ce langage, étant donné que ce ne sont pas les mêmes versions, ni de Delphi ni de la VCL
- le seul accès à ces composants dont je dispose, c'est leur handle, et je suis donc contraint d'utiliser les APIs directement afin d'intervenir sur ces composants

C'est la raison pour laquelle j'ai fini par trouver l'astuce de "hacker" le canvas de l'objet ciblé (une TProgressBar) afin de repeindre la partie "arrière-plan" de la barre. Ca marche, mais c'est lourd, et ce n'est pas sans problèmes, en particulier lorsque l'objet a été recouvert par une autre fenêtre, puis découvert...

J'ai essayé SEND_MESSAGE avec le code PBM_SETBKCOLOR pour changer la couleur de l'arrière-plan, ce qui devrait marcher d'après la doc. Mais ça ne marche pas. Je suppose qu'il s'agir d'un bug du code de TProgressBar dans la VCL de ma version de Delphi. Car, voici ce qui se produit:
- SEND_MESSAGE se passe bien, sans erreur. Le code retourné par SEND_MESSAGE est supposé être la couleur de l'arrière-plan avant modification.
- lors d'un premier SEND_MESSAGE, le code retourné est bien celui de la couleur RGB du fond - j'ai vérifié. Ma nouvelle couleur est supposée être installée, mais elle n'apparapit pas.
- lors d'un deuxième appel (et lors de tous les suivants), le code retourné donne bien la couleur que j'avais installée lors du premier SEND_MESSAGE, mais elle n'est toujours pas utilisée.

Alors, lors de mes essais pour "hacker" le canvas, j'ai constaté que ma couleur installlée via mon "hack" apparaît bien, mais est très rapidement remplacée par la couleur par défaut de l'arrière-plan.

Donc, ma conclusion est la suivante:
- le composant TProgressBar de ma version Delphi accepte bien le code message PBM_SETBKCOLOR et mémorise la couleur imposée
- l'évènementON_DRAW de ce cpomosant utilise systématiquement la couleur par défaut pour le fond, et NON la couleur imposée par l'API
- le code message PBM_SETBARCOLOR pour changer ma couleur de la partie variable de la barre fonctionne bien et n'est pas sujet à ces problèmes !

D'où ma question: en-dehors de mon "hack" du canvas, est-ce qu'il y a une solution viable de changer cette couleur ?

[SergioMaster]

Re,
Toujours la main sur ma "bible" API je n'ai vu nulle entrée pour PBM_SETBKCOLOR.
en tout cas cette plongée dans ce livre m'a permis de re/trouver le polybezier et un code qui m'a fait comprendre la structure d'un fichier CRISPIN (en relation avec ma question sur les calculs de surface)

[KlausGunther]

PBM_SETBKCOLOR ?

"Google est ton ami"...
https://msdn.microsoft.com/en-us/lib...(v=vs.85).aspx

[SergioMaster]

Re,

ma remarque était fonction du livre pas, bien évidemment, d'une recherche google.
je remarque que c'était applicable à partir de vista et donc lors de la sortie de D3 (puisque D3 est le sujet du livre) ces PBM_xxxx n'existaient pas, (d'où peut être, ton problème avec ces derniers ?)

[KlausGunther]

Loin de moi de voiloir critiquer ou donner des leçons - ce n'est pas mon genre. Je voulais simplement donner mes sources, avec une petite pointe d'humour.

je remarque que c'était applicable à partir de vista et donc lors de la sortie de D3 (puisque D3 est le sujet du livre) ces PBM_xxxx n'existaient pas, (d'où peut être, ton problème avec ces derniers ?)

Je suis en D6, donc ça devrait marcher ? Et le retour de SEND_MESSAGE indique bien la bonne "couleur précédente" dès le deuxième appel. Donc, le composant réagit au méssage et mémorise l'information. Seulement, il ne l'utilise pas. Il est là, mon problème !

EDIT

Si je tente de sub-classer l'objet TProgressBar visé, je pourrais peut-être intercepter le message WM_PAINT, mais cela ne résoud pas mon problème, car dans ce cas, je me situe AVANT la phase de dessin de l'objet et non après.

Question: est-ce qu'il y a un moyen (un message à capter, ...) qui m'alerte de la FIN de l'exécution du message WM_PAINT? Car là, je pourrais intervenir sur le canvas et ce serait pérenne...