Modifier l'évènement d'un composant

Invité · 29/09/2010, 11h45

Bonjour,

Dans un TmySpeedButton hérité d'un TSpeedButton, je voudrais modifier le comportement de l'évènement OnMouseEnter.

Je crée un TmySpeedButton dont j'aimerais que l'évènement MouseOver soit éludé : Par exemple, qu'il affiche "d'abord" showmessage('interne');.

Donc un survol de mySpeedButton1 avec dans la Form

Code :

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

1
2
3
4
5
 
procedure TForm1.mySpeedButton1MouseEnter(Sender: TObject);
begin
  showmessage('externe');
end;

afficherait d'abord 'interne' (modification de OnMouseEnter) puis ensuite 'externe' (code dans l'inpecteur d'objet).

Actuellement je crée une procedure DoMouseEnter(const Value: TNotifyEvent); virtual; (protected)
Mais comment je la relie à l'évènement d'origine ? J'ai essayé quelque chose dans ce genre là

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
 
type
  TmySpeedButton = class(TSpeedButton)
  private                       
  { Private declarations }
   FOnMouseEnter: TNotifyEvent;
   protected
    { Protected declarations }
    procedure SetOnMouseEnter(const Value: TNotifyEvent);
    procedure DoMouseEnter(const Value: TNotifyEvent); virtual;
  published
    { Published declarations }
    property OnMouseEnter: TNotifyEvent read FOnMouseEnter write SetOnMouseEnter;
   //Au départ "naïvement" property OnMouseEnter: TNotifyEvent read FOnMouseEnter write DoMouseEnter;
  end;

Si cette base déclarative est bonne (faut-il redéclarer le FOnMouseEnter: TNotifyEvent; et dans le cas contraire ?), comment relie-t-on alors les évènements ?

Cordialement. Gilles

Invité · 29/09/2010, 13h58

Alors, par recoupement de sources Web et par tâtonnements, j'ai obtenu un code qui fonctionne... mais est-il 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
36
37
38
39
40
41
42
43
44
45
46
47
type
  TMySpeedButton = class(TSpeedButton)
  private
  { Private declarations }
    FOnMouseEnter: TNotifyEvent;                         
    procedure SelfOnMouseEnter (Sender : TObject);   // [procédure de substitution ou complémentaire]
    protected
    { Protected declarations }
   public
    { Public declarations }
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
   published
    { Published declarations }
    property OnMouseEnter : TNotifyEvent read FOnMouseEnter write FOnMouseEnter;
end;
 
procedure Register;
 
implementation
 
procedure Register;
begin
  RegisterComponents('Additional',[TmySpeedButton]);
end;
 
constructor Tmyspeedbutton.Create(AOwner: TComponent);
begin
    Inherited Create(AOwner);
    FOnMouseEnter := nil;
    Inherited OnMouseEnter := @SelfOnMouseEnter;
end;
 
destructor Tmyspeedbutton.Destroy;
begin
    Inherited Destroy;
end;
 
//----------------------------------------------------------
procedure Tmyspeedbutton.SelfOnMouseEnter(Sender : TObject);
begin
 Showmessage('Interne');
 //Si code de l'utilisateur dans événement OnMouseOver, alors le déclencher...
 if Assigned(FOnMouseEnter) then FOnMouseEnter(Sender);
 //Cette dernière ligne est à éliminer s'il s'agit d'un code de remplacement et 
 //non d'un code complémentaire précédant ou suivant le code de l'utilisateur
end;

Cordialement. Gilles

**chris37** · 29/09/2010, 14h01

Hello,

Dans la déclaration des procédures de ta classe

procedure DoMouseEnter(const value: TNotifyEvent);Override;

Ensuite tu déclares ta procédure dans ta classe

procedure maclasse.DoMouseEnter(const value: TNotifyEvent);
begin
//Ici tu appels le code que tu veux (ton perso)
Ma procedure();

//Là tu appels l'événement de la classe ancêtre apres l'exécution de TON code )
inherited DoMouseEnter(value);
end;

Voila le principe

Cordialement,
Chris

Invité · 29/09/2010, 16h25

Question complémentaire : Je veux stocker le glyph d'origine dans une variable du composant pour la rappeler ultérieurement.

Donc cela se présenterait ainsi au niveau déclaratif comme :

Code :

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

1
2
3
4
5
6
type
  TMySpeedButton = class(TSpeedButton)
  private
  { Private declarations }
    FBitmapOld : TBitMap;
    [...]

Je pensais la "fixer" dans le create :

Code :

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

1
2
3
4
5
6
7
constructor TMYSpeedbutton.Create(AOwner: TComponent);
begin
    Inherited Create(AOwner);
    FBitmapOld := TBitmap.Create; 
   //et...
   fBitmapOld.Assign(glyph); //*
  [...]

* Le glyph est celui par défaut du composant (ie le champ Glyph dans son inspecteur d'objet) . Même s'il est défini dans ce dernier par l'utilisateur, est-il disponible à ce moment du code lors de la compilation ?

Pour l'appeler, je procède ainsi

Code :

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

1
2
3
4
procedure TMySpeedbutton.SelfOnMouseLeave(Sender : TObject);
begin
  Self.Glyph := fBitmapOld;  
  [...]

Et cela ne fonctionne pas... J'alterne 2 glyphs : un dans l'évènement OnMouseEnter et l'autre dans OnMouseLeave. J'ai défini un glyp additionnel dans le code pour le OnMouseEnter... Le résultat est que lors du survol le Glyph d'origine est bien remplacé par le glyph de survol... mais après au mieux, j'obtiens lors du "Leave" un glyph vide alors que je voudrais que cela soit celui d'origine... Donc la question est : Est-ce le chargement du glyph d'origine qui est mauvais... ou son appel (ou les 2

) ?

Et toujours ce même problème très désagréable. Comment désactiver une propriété (pas un évènement).
Par exemple, l'aspect des TspeedButtons ne me plait pas lorsque SpeedButton.Enabled := false;
On peut assez facilement bloquer le Enabled à true, créer une propriété Enabled2 et gérer l'aspect du TSpeedButton à partir de Enabled :=True et de la valeur de Enabled2... Mais c'est très désagréable...

Merci. Gilles

**yann.m** · 29/09/2010, 18h47

Pourrais-tu nous montrer le code complet du constructeur
"constructor TMYSpeedbutton.Create(AOwner: TComponent);" ?

Invité · 29/09/2010, 18h57

Bonsoir Yann.m,

voici l'unit complète... Elle fonctionne correctement, du moins de manière analogue à ce que je produis normalement en code "Form". Il y manque simplement la gestion de l'équivalent d'Enabled := False... qui modifiera sensiblement les procédures SelfOnMousexxxx... mais simplement. Au lieu d'implanter un code complémentaire dans la procédure modifiée, je placerai un code de remplacement (ie se substituant totalement à la procédure d'origine) :
cf dans le code //Cette dernière ligne est à éliminer s'il s'agit d'un code de remplacement et non d'un code complémentaire précédant ou suivant le code de l'utilisateur.

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
unit mySpeedButton;
//Vers. 10.09.29.18.54
{$mode objfpc}{$H+}
 
interface
 
uses
  Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs, Buttons;
 
type
  TmySpeedButton = class(TSpeedButton)
  private
  { Private declarations }
    FBitmapOver: TBitmap;
    FBitmapOut: TBitmap;
    FBitmapSelected: TBitmap;
 
    FNumGlyphs : Integer;
 
    // Modification des événements........................................... [partie 1]
    FOnMouseEnter: TNotifyEvent;
    FOnMouseLeave: TNotifyEvent;
    FOnMouseDown : TNotifyEvent;
    FOnMouseUp   : TNotifyEvent;
    FOnResize    : TNotifyEvent;
 
    // Modification des évènements............................... [partie 1-bis]
    procedure SelfOnMouseEnter (Sender : TObject); //procedure complémentaire
    procedure SelfOnMouseLeave (Sender : TObject); //       idem
    procedure SelfOnResize (Sender : TObject);     //       idem
    procedure SelfOnMouseDown (Sender: TObject;Button: TMouseButton;
              Shift: TShiftState; X, Y: Integer);
    procedure SelfOnMouseUp (Sender: TObject; Button: TMouseButton;
              Shift: TShiftState; X, Y: Integer);
 
    // Autres procedures : affectation des valeurs (dont blocage de NumGlyphs)
    procedure SetNumGlyphs(Value : Integer);
    procedure SetBitmapOver(Value: TBitmap);
    procedure SetBitmapOut(Value: TBitmap);
    procedure SetBitmapSelected(Value: TBitmap);
 
  protected
    { Protected declarations }
  public
    { Public declarations }
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    { Published declarations }
    property GlyphOver: TBitmap Read FBitmapOver Write SetBitmapOver;
    property GlyphOut: TBitmap Read FBitmapOut Write SetBitmapOut;
    property GlyphSelected:TBitmap Read FBitmapSelected Write SetBitmapSelected;
    property NumGlyphs : integer read FNumGlyphs write SetNumGlyphs;
 
    // Modification des évènements .................................. [partie 2]
    property OnMouseEnter : TNotifyEvent read FOnMouseEnter write FOnMouseEnter;
    property OnMouseLeave : TNotifyEvent read FOnMouseLeave write FOnMouseLeave;
    property OnResize : TNotifyEvent read FOnResize write FOnResize;
    property OnMouseDown : TNotifyEvent read FOnMouseDown write FOnMouseDown;
    property OnMouseUp : TNotifyEvent read FOnMouseUp write FOnMouseUp;
 
end;
 
procedure Register;
 
implementation
 
procedure Register;
begin
  RegisterComponents('Additional',[TmySpeedButton]);
end;
 
constructor Tmyspeedbutton.Create(AOwner: TComponent);
begin
    Inherited Create(AOwner);
    FBitmapOut  := TBitmap.Create;
    FBitmapOver := TBitmap.Create;
    FBitmapSelected := TBitmap.Create;
    FNumGlyphs  := 1;
    // Modification des évènements .................................. [partie 3]
    FOnMouseEnter := nil;
    Inherited OnMouseEnter := @SelfOnMouseEnter;
    FOnMouseLeave := nil;
    Inherited OnMouseLeave := @SelfOnMouseLeave;
    FOnResize := nil;
    Inherited OnResize := @SelfOnResize;
    FOnMouseDown := nil;
    Inherited OnMouseDown := @SelfOnMouseDown;
    FOnMouseUp := nil;
    Inherited OnMouseUp := @SelfOnMouseUp;
end;
 
destructor Tmyspeedbutton.Destroy;
begin
  FBitmapSelected.Free;
  FBitmapOver.Free;
  FBitmapOut.Free;
  inherited Destroy;
end;
 
// Modification des évènements .................................. [partie 4]
procedure Tmyspeedbutton.SelfOnMouseEnter(Sender : TObject);
begin
  Self.Glyph := FBitmapOver;
  //Si code OnMouseEnter alors l'exécuter
  if Assigned(FOnMouseEnter) then FOnMouseEnter(Sender);
  //Cette dernière ligne est à éliminer s'il s'agit d'un code de remplacement et
  //non d'un code complémentaire précédant ou suivant le code de l'utilisateur.
end;
 
procedure Tmyspeedbutton.SelfOnMouseLeave(Sender : TObject);
begin
  Self.Glyph := FBitmapOut;
  if Assigned(FOnMouseLeave) then FOnMouseLeave(Sender);
end;
 
procedure Tmyspeedbutton.SelfOnResize(Sender : TObject);
begin
  Self.Glyph := FBitmapOut;
  if Assigned(FOnResize) then FOnResize(Sender);
end;
 
procedure Tmyspeedbutton.SelfOnMouseDown(Sender: TObject;Button: TMouseButton;
          Shift: TShiftState; X, Y: Integer);
begin
  if Button <> mbLeft then
   inherited
  else begin
   Self.Glyph := FBitmapSelected;
   if Assigned(FOnMouseDown) then FOnMouseDown(Sender);
  end;
end;
 
procedure Tmyspeedbutton.SelfOnMouseUp(Sender: TObject;Button: TMouseButton;
          Shift: TShiftState; X, Y: Integer);
begin
  if Button <> mbLeft then
   inherited
  else begin
   if (X > 0) and (X < Self.Width) and (Y > 0) and (Y < Self.Height) then
    Self.Glyph := FBitmapOver
   else
    Self.Glyph := FBitmapOut;
    if Assigned(FOnMouseUp) then FOnMouseUp(Sender);
  end;
end; 
 
// Autres procedures : affectation des valeurs (dont blocage de NumGlyphs)
procedure Tmyspeedbutton.SetNumGlyphs(Value : Integer);
begin
 value := 1;
end; 
 
procedure Tmyspeedbutton.SetBitmapOver(Value: TBitmap);
begin
 FBitmapOver.Assign(value);
 invalidate;
end;
 
procedure Tmyspeedbutton.SetBitmapOut(Value: TBitmap);
begin
 FBitmapOut.Assign(value);
 invalidate;
end;
 
procedure Tmyspeedbutton.SetBitmapSelected(Value: TBitmap);
begin
 FBitmapSelected.Assign(value);
 invalidate;
end;
 
end.

C'est un TspeedButton 4 états [4 glyphs] : 1 out, 1 over, 1 selected, 1 disabled. J'aurais bien aimé utiliser le glyph d'origine qui aurait remplacé avantageusement (peut-être ?) le FBitmapOut... qui fait double emploi. Je n'arrive pas à "charger" le "glyph d'origine" sachant que pour initialiser mon SpeedButton dans mon code usuel hors composant, j'utilise également l'évènement onResize.

D'un autre côté, je n'utilise pas la propriété Enabled... et ses effets secondaires. Si je comprends bien qu'il n'est pas envisageable de supprimer la propriété de l'objet compte-tenu de sa présence dans le code des ancêtres, je déplore qu'il n'existe pas la possibilité de la rétrograder en protected... ou voire même en published mais sans write...

Evidemment, il y a des codes inutiles (genre uses Dialogs...) et des manques notamment vérifier la largeur des images sélectionnées.

Je dois avouer que si ce code fonctionne, je n'ai aucune certitude quant à son orthodoxie ou même à son niveau de qualité...

Cordialement. Gilles

**yann.m** · 29/09/2010, 19h49

C'est fonctionnel (au niveau visuel) pour moi sous mac

Par contre il y a un problème de logique avec les glyph:

GlyphOut devrait être suprimé !
Glyph = bouton enabled avec bmp par défaut
GlypOver = survol souris -> bmp survol souris
GlyphOut = hum, en fait là on devrait avoir Glyph (bmp par défaut puisque retour à l'état par défaut)

J'ai codé l'appel de ton composant et les propriétés comme suis (à la va-vite et avec des bitmaps carrés de couleurs différentes - ce qui explique le transparent=false) :

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
 
 
unit Unit1; 
 
{$mode objfpc}{$H+}
 
interface
 
uses
  ...
 mySpeedButton;
 
type
 
  { TForm1 }
 
  TForm1 = class(TForm)
      msb: TMySpeedButton;
      procedure FormCreate(Sender: TObject);
  private
    { private declarations }
  public
    { public declarations }
  end; 
 
var
  Form1: TForm1; 
 
implementation
 
{ TForm1 }
 
procedure TForm1.FormCreate(Sender: TObject);
begin
    msb := TMySpeedButton.Create(Self);
    msb.Transparent := False;
    msb.Glyph.LoadFromFile('/Users/yann/Desktop/test/1.bmp');
    msb.GlyphOver.LoadFromFile('/Users/yann/Desktop/test/2.bmp');
    msb.GlyphOut.LoadFromFile('/Users/yann/Desktop/test/3.bmp');
    msb.GlyphSelected.LoadFromFile('/Users/yann/Desktop/test/4.bmp');
    msb.Parent := Self;
end;

Je pense que tu es au courant que le premier pixel (haut, gauche) d'un Glyphe est déclaré "couleur transparente" lorsque la propriété Transparent := True;

Essaie ce code avec tes chemins de bitmap pour vérifier.

**yann.m** · 29/09/2010, 20h22

Tu pourrais juste copier Glyph dans fBitmapOut lors du survol de la souris (et supprimer la propriété GlyphOut)

Code :

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

1
2
3
4
5
6
7
8
9
10
11
 
 
procedure Tmyspeedbutton.SelfOnMouseEnter(Sender : TObject);
begin
  FBitmapOut.Assign(Self.Glyph);// <- on stocke image par défaut
  Self.Glyph := FBitmapOver;
  //Si code OnMouseEnter alors l'exécuter
  if Assigned(FOnMouseEnter) then FOnMouseEnter(Sender);
  //Cette dernière ligne est à éliminer s'il s'agit d'un code de remplacement et
  //non d'un code complémentaire précédant ou suivant le code de l'utilisateur.
end;

Invité · 29/09/2010, 20h23

Rebonsoir Yann,

Je ne suis pas non plus un spécialiste des glyphs... Cela fonctionne avec des bmp sous Win et Nux... Avec des png, cela passe si on utilise l'inspecteur d'Objet mais en LoadFromFile non... et j'utilise des png (et l'inspecteur d'objet )... Encore une lacune...
D'accord pour la logique du TBitmapOut. Je l'utilise pour contourner le problème indiqué. Le mySpeedButton1.Glyph change en fonction de l'image qui est adaptée à l'évènement considéré. Donc, j'ai voulu charger le glyph initial (défini dans mySpeedButton1.Glyph) dans un TBipMapIni... et je n'y suis pas arrivé...

Bon, j'arrête ici pour ce soir. Je vous remercie pour votre aide.

Bonne soirée. Gilles

**yann.m** · 29/09/2010, 20h30

tout simplement parce que Glyph = TBitmap
or tu essaye de lui mettre une image PNG -> éh non ! seul les images bitmap sont autorisées

Sinon avec avec la petite astuce pour récupérer le glyphe par défaut (msg précédent) ton composant marche sans problème pour moi (je n'ai pas vérifié les TNotifyEvent)

Invité · 29/09/2010, 20h35

Donc entre 2 modifications de ma part... Oui, je me demandais par quel mécanisme, l'inspecteur d'objet permet-il d'intégrer des png dans son champ "Glyph"...

Cordialement. Gilles

**yann.m** · 30/09/2010, 18h18

Je reviens sur ce que j'ai écrit au msg précédent, car après avoir jeté un coup d'oeil aux codes sources, je vois que le Glyph accepte en effet les bitmaps ayant un masque de transparence ou non. Le glyph utilise le masque de transparence du bitmap que tu lui assigne - si il y en a un - sinon, et seulement si la propriété Transparent := True, il lit le premier pixel (haut gauche) du bitmap et déclare que tous les pixels de la même couleur sont transparents et donc ne les affiche pas.

J'ai modifié le code pour le chargement des images. J'utilise un TPicture car il permet l'ouverture de différents formats d'image et gère en interne les conversions de formats.
J'ai laissé Transparent:=False, car au milieu des images PNG, je charge un bitmap sans masque de transparence, et comme tous les pixels de celui-ci sont de la même couleur, le glyph déclare tout comme transparent si je laisse Transparent:=True.

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
 
...
procedure TForm1.FormCreate(Sender: TObject);
var pic: TPicture;
begin
    msb := TMySpeedButton.Create(Self);
    pic := TPicture.Create;
 
    msb.Transparent := false;
 
    pic.LoadFromFile('/Users/yann/Desktop/test/1.png');
    msb.Glyph := pic.Bitmap;
    pic.LoadFromFile('/Users/yann/Desktop/test/2.bmp');
    msb.GlyphOver := pic.Bitmap;
    pic.LoadFromFile('/Users/yann/Desktop/test/3.png');
    msb.GlyphSelected := pic.Bitmap;
 
    msb.Parent := Self;
    pic.Free;
 
end;
...

Ci-dessous ton composant avec quelques portions de codes superflus désactivés

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
 
unit mySpeedButton;
//Vers. 10.09.29.18.54
{$mode objfpc}{$H+}
 
interface
 
uses
  Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs, Buttons;
 
type
  TmySpeedButton = class(TSpeedButton)
  private
  { Private declarations }
    FBitmapOver: TBitmap;
    FBitmapOut: TBitmap;
    FBitmapSelected: TBitmap;
 
    FNumGlyphs : Integer;
 
    // Modification des événements........................................... [partie 1]
    FOnMouseEnter: TNotifyEvent;
    FOnMouseLeave: TNotifyEvent;
    FOnMouseDown : TNotifyEvent;
    FOnMouseUp   : TNotifyEvent;
    FOnResize    : TNotifyEvent;
 
    procedure SetBitmapOver(Value: TBitmap);
    //procedure SetBitmapOut(Value: TBitmap);
    procedure SetBitmapSelected(Value: TBitmap);
 
    // Modification des évènements............................... [partie 1-bis]
    procedure SelfOnMouseEnter (Sender : TObject); //procedure complémentaire
    procedure SelfOnMouseLeave (Sender : TObject); //       idem
    procedure SelfOnResize (Sender : TObject);     //       idem
    procedure SelfOnMouseDown (Sender: TObject;Button: TMouseButton;
              Shift: TShiftState; X, Y: Integer);
    procedure SelfOnMouseUp (Sender: TObject; Button: TMouseButton;
              Shift: TShiftState; X, Y: Integer);
 
    // Autres procedures : blocage du NumGlyphs
    procedure SetNumGlyphs(Value : Integer);
 
 
  protected
    { Protected declarations }
  public
    { Public declarations }
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    { Published declarations }
    property GlyphOver: TBitmap Read FBitmapOver Write SetBitmapOver;
    //property GlyphOut: TBitmap Read FBitmapOut Write SetBitmapOut;
    property GlyphSelected:TBitmap Read FBitmapSelected Write SetBitmapSelected;
    // Modification des évènements .................................. [partie 2]
    property OnMouseEnter : TNotifyEvent read FOnMouseEnter write FOnMouseEnter;
    property OnMouseLeave : TNotifyEvent read FOnMouseLeave write FOnMouseLeave;
    property OnResize : TNotifyEvent read FOnResize write FOnResize;
    property OnMouseDown : TNotifyEvent read FOnMouseDown write FOnMouseDown;
    property OnMouseUp : TNotifyEvent read FOnMouseUp write FOnMouseUp;
 
    property NumGlyphs : integer read FNumGlyphs write SetNumGlyphs;
  end;
 
procedure Register;
 
implementation
 
procedure Register;
begin
  RegisterComponents('Additional',[TmySpeedButton]);
end;
 
constructor Tmyspeedbutton.Create(AOwner: TComponent);
begin
    Inherited Create(AOwner);
    FBitmapOut  := TBitmap.Create;
    FBitmapOver := TBitmap.Create;
    FBitmapSelected := TBitmap.Create;
    FNumGlyphs  := 1;
    // Modification de l'évènement OnMouseEnter...................... [partie 3]
    //FOnMouseEnter := nil;
    Inherited OnMouseEnter := @SelfOnMouseEnter;
    //FOnMouseLeave := nil;
    Inherited OnMouseLeave := @SelfOnMouseLeave;
    //FOnResize := nil;
    Inherited OnResize := @SelfOnResize;
    //FOnMouseDown := nil;
    Inherited OnMouseDown := @SelfOnMouseDown;
    //FOnMouseUp := nil;
    Inherited OnMouseUp := @SelfOnMouseUp;
end;
 
destructor Tmyspeedbutton.Destroy;
begin
  FBitmapSelected.Free;
  FBitmapOver.Free;
  FBitmapOut.Free;
  inherited Destroy;
end;
 
procedure Tmyspeedbutton.SetNumGlyphs(Value : Integer);
begin
 value := 1;
end;
 
{procedure Tmyspeedbutton.SetBitMap(Value : TBitmap);
begin
 value := nil;
end;}
//------------------------------------------------------------------------------
procedure Tmyspeedbutton.SetBitmapOver(Value: TBitmap);
begin
 fBitmapOver.Assign(value);
 //invalidate;
end;
 
{procedure Tmyspeedbutton.SetBitmapOut(Value: TBitmap);
begin
 fBitmapOut.Assign(value);
 //invalidate;
end;}
 
procedure Tmyspeedbutton.SetBitmapSelected(Value: TBitmap);
begin
 fBitmapSelected.Assign(value);
 //invalidate;
end;
// Modification de l'évènement OnMouseEnter.......................... [partie 4]
procedure Tmyspeedbutton.SelfOnMouseEnter(Sender : TObject);
begin
  FBitmapOut.Assign(Self.Glyph); // <- stocke l'image par défaut
  Self.Glyph := FBitmapOver;
  //Si code OnMouseEnter alors l'exécuter
  if Assigned(FOnMouseEnter) then FOnMouseEnter(Sender);
  //Cette dernière ligne est à éliminer s'il s'agit d'un code de remplacement et
  //non d'un code complémentaire précédant ou suivant le code de l'utilisateur.
end;
procedure Tmyspeedbutton.SelfOnMouseLeave(Sender : TObject);
begin
  Self.Glyph := FBitmapOut;
  if Assigned(FOnMouseLeave) then FOnMouseLeave(Sender);
end;
procedure Tmyspeedbutton.SelfOnResize(Sender : TObject);
begin
  Self.Glyph := FBitmapOut;
  if Assigned(FOnResize) then FOnResize(Sender);
end;
procedure Tmyspeedbutton.SelfOnMouseDown(Sender: TObject;Button: TMouseButton;
          Shift: TShiftState; X, Y: Integer);
begin
  if Button <> mbLeft then
   inherited
  else begin
   Self.Glyph := FBitmapSelected;
   if Assigned(FOnMouseDown) then FOnMouseDown(Sender);
  end;
end;
 
procedure Tmyspeedbutton.SelfOnMouseUp(Sender: TObject;Button: TMouseButton;
          Shift: TShiftState; X, Y: Integer);
begin
  if Button <> mbLeft then
   inherited
  else begin
   if (X > 0) and (X < Self.Width) and (Y > 0) and (Y < Self.Height) then
    Self.Glyph := FBitmapOver
   else
    Self.Glyph := FBitmapOut;
    if Assigned(FOnMouseUp) then FOnMouseUp(Sender);
  end;
end;
end.

Sur le plan visuel, pour moi c'est ok, avec des png ou bmp et sans la propriété GlyphOut

Invité · 01/10/2010, 02h54

Bonsoir Yann,

J'ai recopié votre dernière proposition de code... En test sous Windows XP (j'essayerai demain sous Linux), je n'obtiens pas l'affichage du glyph au départ, ni une fois "survolé" : il n'y a pas d'image. Dans mon test, les 3 images sont définies dans l'inspecteur d'objet du composant "posé" sur la Form.

J'ai modifié votre code ainsi :

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
 
procedure Tmyspeedbutton.SelfOnMouseEnter(Sender : TObject);
begin
  Self.Glyph := FBitmapOver;
  //Si code OnMouseEnter alors l'exécuter
  if Assigned(FOnMouseEnter) then FOnMouseEnter(Sender);
  //Cette dernière ligne est à éliminer s'il s'agit d'un code de remplacement et
  //non d'un code complémentaire précédant ou suivant le code de l'utilisateur.
end; 
 
procedure Tmyspeedbutton.SelfOnResize(Sender : TObject);
begin
 if FBitmapOut.Empty then  FBitmapOut.Assign(Self.Glyph); // <- stocke l'image par défaut
 // Self.Glyph := FBitmapOut; //A mon avis à supprimer
  if Assigned(FOnResize) then FOnResize(Sender);
end;

SelfOnMouseEnter : retour au code d'origine

SelfOnResize : Chargement du Glyph dans FBitmapOut

Lors de l'affichage initial du composant, après sa création par le constructeur (où à ce niveau semble-t-il le glyph n'est pas "récupérable"), la séquence des évènements pendant cette phase de création/affichage passe une fois (au moins) par l'étape (onResize). "Au moins" : à priori qu'une seule fois en utilisation "normale"... mais cela ne coûte rien de prévoir d'autres cas éventuels (?). A ce moment-là (onResize), le glyph "existe" (ie : il est "chargé"). Donc si le BitMapOut n'a pas été rempli, on le fait... Sinon, c'est inutile d'autant que le contenu du glyph varie dans le temps avec les assignations correspondant aux divers états.

Est-ce que dans cette même procédure (onResize) le // Self.Glyph := FBitmapOut; est nécessaire ? Je pense que non.

Vous testez sous Mac ?
----------------------------------

Parallèlement, je cherche toujours à améliorer mes connaissances sur la structure des composants de Lazarus.

Pour occulter le Enabled et le remplacer par mon Disabled qui me permet une meilleure ergonomie (affichage de messages, pas de grisage auto mais un maison ou autre chose), j'ai essayé la technique suivante :

Au lieu de prendre comme ancêtre TspeedButton pour mon TMySpeedButton, j'ai pris un TCustomSpeedButton. Dans un TCustom, toutes les properties sont en protected...[cf http://chgi.developpez.com/compo1/]. Un petit tour dans le /lcl/buttons.pp pour récupérer leur liste. Je laisse le Enabled dans les protected et je déplace celles utiles dans le published. En plus, je bloque le Enabled à True. Je créer ma propriété Disabled...

Cette technique présente cependant très probablement un inconvénient quoi que je ne l'ai pas mis en évidence de manière significative avec les SpeedButtons, d'autant que je manque de recul :

Mais supposer que la différence entre un Tcustomxxxx "natif (ie inclus dans le package Lazarus)" et son Txxxx "natif (ie la version incluse dans Lazarus du composant final)" se réduirait systématiquement à une simple et unique modification des déclarations des properties dans protected et published est une démarche

fausse. Cela supposerait que le code du Txxxxx, composant final de Lazarus ne disposerait pas de ses "propres" méthodes (ie soit de méthodes surchargées par rapport à son ancêtre TCustomxxxx, soit de nouvelles méthodes). Cela serait en quelque sorte une redondance... donc apparamment inutile...
mais réellement productive car on pourrait imaginer que, conscients de ce problème (des properties non rétrogradables), les développeurs de Lazarus conçoivent des Customs -il faudrait trouver une autre formulation- justement pour le contourner (ie mêmes codes que les composants finaux mais avec des properties protected uniquement et codes intégrés directement dans la LCL ici lcl\buttons.pp), proposant ainsi une plateforme d'"héritage orientée vers l'utilisateur final"... et permettant de développer très rapidement une foison de composants sans concession et très proprement (ie maintenable -sans visiter sytématiquement la lcl pour intégrer ses modifications dans le code du composant en développement) ... Car penser qu'un jour proche, une property published sera rétrogradable en protected en Lazarus, c'est rêver parce que son "modèle", Delphi ne le fait pas mieux...

Ces propos peuvent paraître iconoclastes mais, en attendant, pour occulter à ma guise une propriété published d'un composant final de Lazarus qui me servirait d'ancêtre, je ne vois que des "approximations" pour un résultat qui ne correspond pas à la demande. Je ne dispose pas de technique pour vraiment l'occulter dans l'Inspecteur d'Objet... hormis le recours au "Custom Ancêtre".

Aujourd'hui, choisir cette dernière solution me semble s'apparenter à un gros challenge (risque)... En faisant le choix de partir d'un Custom, à chaque release de Lazarus, il faudra vérifier la cohérence (ie la similitude) entre d'une part, le code dans Lazarus (lcl) ajouté ou modifié dans l'héritier final du Custom... et d'autre part, le code ajouté (recopié) dans son propre composant... en plus de ses propres modifications dans son composant final. Autrement dit, plus simplement, avec l'exemple du TspeedButton et de Tmyspeedbutton : En partant du TCustomSpeedButton, il fau(drai)t recopier dans le TmySpeedButon une bonne part des méthodes surchargées et des nouvelles méthodes implantées dans le TSpeedButton -qui font sa propre caractéristique-, méthodes que l'on trouve dans la lcl de Lazarus (Là, c'est pas un très bon exemple vu le code de ce composant particulier). De ce fait, compte tenu des nombreuses variations de Lazarus -normales car il est en phase de construction-, la maintenance du nouveau composant en deviendra(it) extrêmement pénible. Il suffit pour s'en convaincre de se rappeler de l'évolution du code des StringGrids qui m'ont longtemps "chagrinées". A partir de ses "hypothèses" (en attendant la contradiction), j'en conclus donc pour l'instant que développer un composant "à sa main" à partir d'un composant final comme TSpeedButton oblige à des concessions non "négligeables" notamment en terme d'ergonomie de l'Inspecteur d'objet et que développer le composant à partir du custom ancêtre du composant final est plutôt facilement réalisable mais que sa maintenance sera très pénible et fréquente.

Evidemment, cela ne prétend pas être une conclusion "ferme et définitive". Je suis "tout jeune" en composant... Je découvre, j'avance doucement et cela fait plusieurs fois que je fais appel au forum- et consulte les moteurs de recherche... Je "ressens" une limite, la mienne certainement - et le forum m'aide et continue à m'aider à la repousser, mais peut-être aussi une limite (ie une insuffisance) de Lazarus, un petit peu comme pour les indirections...

Il m'a semblé que dans le C# par exemple, il est beaucoup plus simple d'occulter une property car on pourrait ici partir du TSpeedButton (donc sans passer par son ancêtre) et rétrograder le Enabled de Published à Protected... ce qui permet finalement de dériver un composant à partir du composant final (et non Custum) donc de manière plus simple.

Quelqu'un(e) a-t-il un avis "éclairé", une (autre) expérience sur la question, une (autre) solution ?

Encore merci pour votre aide.
Cordialement. Gilles

Pour info

le lcl/buttons.pp

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
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
{ $Id: buttons.pp 25204 2010-05-05 07:59:04Z paul $}
 
{
 /***************************************************************************
                                 buttons.pp
                                 ----------
                             Component Library Code
 
 
                   Initial Revision : Sun Mar 28 23:15:32 CST 1999
                   Revised: Sat Jul 3 1999
 
 ***************************************************************************/
                                               *
 *****************************************************************************
}
 
unit Buttons;
 
{$mode objfpc}{$H+}
 
 
interface
 
{$ifdef Trace}
{$ASSERTIONS ON}
{$endif}
 
uses
  Types, Classes, SysUtils, Math, LCLType, LCLProc, LCLIntf, LCLStrConsts,
  GraphType, Graphics, ImgList, ActnList, Controls, StdCtrls, LMessages, Forms,
  Themes, Menus{for ShortCut procedures}, LResources, ImageListCache;
 
type
  TButtonLayout =
  (
    blGlyphLeft,
    blGlyphRight,
    blGlyphTop,
    blGlyphBottom
  );
 
  TButtonState =
  (
    bsUp,       // button is up
    bsDisabled, // button disabled (grayed)
    bsDown,     // button is down
    bsExclusive,// button is the only down in his group
    bsHot       // button is under mouse
  );
 
  {
   TNumGlyphs holds the number of glyphs in an image.
   If we change this the code in SetNumGlyphs for @link(TCustomSpeedButton)
   needs to be changed
  }
  TNumGlyphs = 1..5;
 
  { TButtonGlyph }
  TGlyphTransparencyMode = (
    gtmGlyph,       // transparency is defined by the glyph itself (bitbtn)
    gtmOpaque,      // transparent = false is defined by the owner (speedbutton)
    gtmTransparent  // transparent = true
  );
 
  TButtonGlyph = class(TObject, IUnknown, IImageCacheListener)
  private
    FIsDesigning: Boolean;
    FShowMode: TGlyphShowMode;
    FImageIndexes: array[TButtonState] of Integer;
    FImages: TCustomImageList;
    FOriginal: TBitmap;
    FNumGlyphs: TNumGlyphs;
    FOnChange: TNotifyEvent;
    FImagesCache: TImageListCache;
    FTransparentMode: TGlyphTransparencyMode;         // set by our owner to indicate that the glyphbitmap should be transparent
    function GetHeight: Integer;
    function GetWidth: Integer;
    procedure SetGlyph(Value: TBitmap);
    procedure SetNumGlyphs(Value: TNumGlyphs);
    procedure SetShowMode(const AValue: TGlyphShowMode);
    procedure ClearImages;
  protected
    // IUnknown
    function QueryInterface(const iid: tguid; out obj): longint; stdcall;
    function _AddRef: longint; stdcall;
    function _Release: longint; stdcall;
 
    // IImageCacheListener
    procedure CacheSetImageList(AImageList: TCustomImageList);
    procedure CacheSetImageIndex(AIndex, AImageIndex: Integer);
 
    procedure GlyphChanged(Sender: TObject);
    procedure SetTransparentMode(AValue: TGlyphTransparencyMode);
 
    property TransparentMode: TGlyphTransparencyMode read FTransparentMode;
  public
    constructor Create;
    destructor Destroy; override;
    procedure GetImageIndexAndEffect(State: TButtonState; var AIndex: Integer; var AEffect: TGraphicsDrawEffect);
    function Draw(Canvas: TCanvas; const Client: TRect; const Offset: TPoint;
                  State: TButtonState; Transparent: Boolean;
                  BiDiFlags: Longint): TRect;
    procedure Refresh;
    property Glyph: TBitmap read FOriginal write SetGlyph;
    property IsDesigning: Boolean read FIsDesigning write FIsDesigning;
    property NumGlyphs: TNumGlyphs read FNumGlyphs write SetNumGlyphs;
    property Images: TCustomImageList read FImages;
    property Width: Integer read GetWidth;
    property Height: Integer read GetHeight;
    property ShowMode: TGlyphShowMode read FShowMode write SetShowMode;
  public
    property OnChange: TNotifyEvent read FOnChange write FOnChange;
  end;
 
 
  { TCustomBitBtn }
 
  // when adding items here, also update TBitBtn.GetCaptionOfKind
  TBitBtnKind = (bkCustom, bkOK, bkCancel, bkHelp, bkYes, bkNo,
                 bkClose, bkAbort, bkRetry, bkIgnore, bkAll,
                 bkNoToAll, bkYesToAll);
  TBitBtnKinds = set of TBitBtnKind;
 
  TCustomBitBtn = class(TCustomButton)
  private
    FKind: TBitBtnKind;
    FLayout: TButtonLayout;
    FMargin: integer;
    FSpacing: Integer;
    function GetGlyph: TBitmap;
    function GetGlyphShowMode: TGlyphShowMode;
    function GetNumGlyphs: Integer;
    function IsGlyphStored: Boolean;
    procedure SetGlyph(AValue: TBitmap);
    procedure SetGlyphShowMode(const AValue: TGlyphShowMode);
    procedure SetKind(AValue: TBitBtnKind);
    procedure SetLayout(AValue: TButtonLayout);
    procedure SetMargin(const AValue: integer);
    procedure SetNumGlyphs(AValue: Integer);
    procedure SetSpacing(AValue: Integer);
    procedure RealizeKind;
    //Return the caption associated with the aKind value.
    function GetCaptionOfKind(AKind: TBitBtnKind): String;
  protected
    FButtonGlyph: TButtonGlyph;
    class procedure WSRegisterClass; override;
    procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override;
    procedure GlyphChanged(Sender: TObject);
    procedure InitializeWnd; override;
    procedure TextChanged; override;
    class function GetControlClassDefaultSize: TSize; override;
    procedure CMAppShowBtnGlyphChanged(var Message: TLMessage); message CM_APPSHOWBTNGLYPHCHANGED;
  public
    constructor Create(TheOwner: TComponent); override;
    destructor Destroy; override;
    procedure Click; override;
    procedure LoadGlyphFromLazarusResource(const AName: String);
    procedure LoadGlyphFromStock(idButton: Integer);
    function CanShowGlyph: Boolean;
  public
    property Glyph: TBitmap read GetGlyph write SetGlyph stored IsGlyphStored;
    property NumGlyphs: Integer read GetNumGlyphs write SetNumGlyphs default 1;
    property Kind: TBitBtnKind read FKind write SetKind default bkCustom;
    property Layout: TButtonLayout read FLayout write SetLayout default blGlyphLeft;
    property Margin: integer read FMargin write SetMargin default -1;
    property Spacing: Integer read FSpacing write SetSpacing default 3;
    property GlyphShowMode: TGlyphShowMode read GetGlyphShowMode write SetGlyphShowMode default gsmApplication;
  end;
 
  { TBitBtn }
  { To set custom bitbtn glyphs for the whole application, see below for
    GetDefaultBitBtnGlyph }
 
  TBitBtn = class(TCustomBitBtn)
  published
    property Action;
    property Align;
    property Anchors;
    property AutoSize;
    property BidiMode;
    property BorderSpacing;
    property Cancel;
    property Caption;
    property Color;
    property Constraints;
    property Default;
    property Enabled;
    property Font;
    property Glyph;
    property GlyphShowMode;
    property Kind;
    property Layout;
    property Margin;
    property ModalResult;
    property NumGlyphs;
    property OnChangeBounds;
    property OnClick;
    property OnContextPopup;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDrag;
    property OnEnter;
    property OnExit;
    property OnKeyDown;
    property OnKeyPress;
    property OnKeyUp;
    property OnMouseDown;
    property OnMouseEnter;
    property OnMouseLeave;
    property OnMouseMove;
    property OnMouseUp;
    property OnResize;
    property OnStartDrag;
    property OnUTF8KeyPress;
    property ParentBidiMode;
    property ParentFont;
    property ParentShowHint;
    property PopupMenu;
    property ShowHint;
    property Spacing;
    property TabOrder;
    property TabStop;
    property Visible;
  end;
 
 
  { TSpeedButtonActionLink }
 
  TSpeedButtonActionLink = class(TControlActionLink)
  protected
    procedure AssignClient(AClient: TObject); override;
    procedure SetGroupIndex(Value: Integer); override;
    procedure SetChecked(Value: Boolean); override;
  public
    function IsCheckedLinked: Boolean; override;
    function IsGroupIndexLinked: Boolean; override;
  end;
 
  { TCustomSpeedButton }
 
  TCustomSpeedButton = class(TGraphicControl)
  private
    FGlyph: TButtonGlyph;
    FGroupIndex: Integer;
    FLastDrawDetails: TThemedElementDetails;
    FLayout: TButtonLayout;
    FMargin: integer;
    FSpacing: integer;
    FShortcut: TShortCut;
    FShowAccelChar: boolean;
    FShowCaption: boolean;
    FAllowAllUp: Boolean;
    FDown: Boolean;
    FDownLoaded : Boolean;// value of Down set during loading
    FDragging: Boolean;
    FFlat: Boolean;
    FMouseInControl: Boolean;
    function GetGlyph: TBitmap;
    procedure SetShowCaption(const AValue: boolean);
    procedure UpdateExclusive;
    function  GetTransparent: Boolean;
    procedure SetAllowAllUp(Value: Boolean);
    procedure SetGlyph(Value: TBitmap);
    procedure SetLayout(const Value: TButtonLayout);
    procedure SetShowAccelChar(Value: boolean);
    procedure SetTransparent(const AValue: boolean);
    procedure CMButtonPressed(var Message: TLMessage); message CM_BUTTONPRESSED;
    procedure CMEnabledChanged(var Message: TLMessage); message CM_ENABLEDCHANGED;
  private
    procedure DoBeforeMouseMessage;
    procedure DoMouseUp(var Message: TLMMouse; Button: TMouseButton);
    procedure WMLButtonDown(Var Message: TLMLButtonDown); message LM_LBUTTONDOWN;
    procedure WMLButtonUp(var Message: TLMLButtonUp); message LM_LBUTTONUP;
    procedure WMLButtonDBLCLK(Var Message: TLMLButtonDblClk); message LM_LBUTTONDBLCLK;
  protected
    FState: TButtonState;
    class procedure WSRegisterClass; override;
    function GetNumGlyphs: Integer;
    procedure GlyphChanged(Sender: TObject);
    function  DialogChar(var Message: TLMKey): boolean; override;
    procedure MouseEnter; override;
    procedure MouseLeave; override;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
      X, Y: Integer); override;
    procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState;
      X, Y: Integer); override;
    procedure Paint; override;
    procedure PaintBackground(var PaintRect: TRect); virtual;
    procedure SetDown(Value: Boolean);
    procedure SetGroupIndex(const Value: Integer);
    procedure SetFlat(const Value: Boolean);
    procedure SetMargin(const Value: integer);
    procedure SetNumGlyphs(Value: integer);
    procedure SetSpacing(const Value: integer);
    procedure RealSetText(const Value: TCaption); override;
    procedure UpdateState(InvalidateOnChange: boolean); virtual;
    function GetDrawDetails: TThemedElementDetails; virtual;
    property MouseInControl: Boolean read FMouseInControl;
    procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override;
    function GetActionLinkClass: TControlActionLinkClass; override;
    class function GetControlClassDefaultSize: TSize; override;
    procedure Loaded; override;
  protected
    function GetGlyphSize(PaintRect: TRect): TSize; virtual;
    function GetTextSize(PaintRect: TRect): TSize; virtual;
    function DrawGlyph(ACanvas: TCanvas; const AClient: TRect; const AOffset: TPoint;
      AState: TButtonState; ATransparent: Boolean; BiDiFlags: Longint): TRect; virtual;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    function FindDownButton: TCustomSpeedButton;
    procedure Click; override; // make Click public
    procedure LoadGlyphFromLazarusResource(const AName: String);
  public
    property AllowAllUp: Boolean read FAllowAllUp write SetAllowAllUp default false;
    property Down: Boolean read FDown write SetDown default false;
    property Flat: Boolean read FFlat write SetFlat default false;
    property Glyph: TBitmap read GetGlyph write SetGlyph;
    property GroupIndex: Integer read FGroupIndex write SetGroupIndex default 0;
    property Layout: TButtonLayout read FLayout write SetLayout default blGlyphLeft;
    property Margin: integer read FMargin write SetMargin default -1;
    property NumGlyphs: Integer read GetNumGlyphs write SetNumGlyphs default 1;
    property ShowAccelChar: boolean read FShowAccelChar write SetShowAccelChar default true;
    property ShowCaption: boolean read FShowCaption write SetShowCaption default true;
    property Spacing: integer read FSpacing write SetSpacing default 4;
    property Transparent: Boolean read GetTransparent write SetTransparent default true;
  end;
 
 
  { TSpeedButton }
 
  TSpeedButton = class(TCustomSpeedButton)
  published
    property Action;
    property Align;
    property AllowAllUp;
    property Anchors;
    property AutoSize;
    property BidiMode;
    property BorderSpacing;
    property Constraints;
    property Caption;
    property Color;
    property Down;
    property Enabled;
    property Flat;
    property Font;
    property Glyph;
    property GroupIndex;
    property Layout;
    property Margin;
    property NumGlyphs;
    property Spacing;
    property Transparent;
    property Visible;
    property OnClick;
    property OnDblClick;
    property OnMouseDown;
    property OnMouseEnter;
    property OnMouseLeave;
    property OnMouseMove;
    property OnMouseUp;
    property OnPaint;
    property OnResize;
    property OnChangeBounds;
    property ShowCaption;
    property ShowHint;
    property ParentBidiMode;
    property ParentFont;
    property ParentShowHint;
    property PopupMenu;
  end;
 
  { To override the default TBitBtn glyphs set GetDefaultBitBtnGlyph below.
    Example:
 
    function GetBitBtnGlyph(Kind: TBitBtnKind): TBitmap;
    begin
      if Kind in [bkOK, bkCancel] then begin
        Result:=TBitmap.Create;
        case Kind of
          bkOk:      Result.Assign(MyOkGlyph);
          bkCancel:  Result.Assign(MyCancelGlyph);
        end;
      end else
        Result:=nil;
    end;
    }
type
  TGetDefaultBitBtnGlyph = function(Kind: TBitBtnKind; var Handled: Boolean): TBitmap;
var
  GetDefaultBitBtnGlyph: TGetDefaultBitBtnGlyph = nil;
 
function GetLCLDefaultBtnGlyph(Kind: TBitBtnKind): TGraphic;
procedure LoadGlyphFromLazarusResource(AGlyph: TButtonGlyph; const AName: String);
procedure LoadGlyphFromStock(AGlyph: TButtonGlyph; idButton: Integer);
 
// helper functions (search LCLType for idButton)
function GetButtonCaption(idButton: Integer): String;
function GetDefaultButtonIcon(idButton: Integer): TCustomBitmap;
function GetButtonIcon(idButton: Integer): TCustomBitmap;
function BidiAdjustButtonLayout(IsRightToLeft: Boolean; Layout: TButtonLayout): TButtonLayout;
 
procedure Register;
 
implementation
 
uses
  WSButtons;
 
const
  BitBtnModalResults: array[TBitBtnKind] of TModalResult = (
    0, mrOK, mrCancel, 0, mrYes, mrNo,
    0, mrAbort, mrRetry, mrIgnore, mrAll,
    mrNoToAll, mrYesToAll);
 
  BitBtnImages: array[TBitBtnKind] of Longint = (
    idButtonBase, idButtonOk, idButtonCancel, idButtonHelp, idButtonYes,
    idButtonNo, idButtonClose, idButtonAbort, idButtonRetry, idButtonIgnore,
    idButtonAll, idButtonNoToAll, idButtonYesToAll);
 
  BitBtnResNames: array[idButtonOk..idButtonNoToAll] of String =
  (
{idButtonOk      } 'btn_ok',
{idButtonCancel  } 'btn_cancel',
{idButtonHelp    } 'btn_help',
{idButtonYes     } 'btn_yes',
{idButtonNo      } 'btn_no',
{idButtonClose   } 'btn_close',
{idButtonAbort   } 'btn_abort',
{idButtonRetry   } 'btn_retry',
{idButtonIgnore  } 'btn_ignore',
{idButtonAll     } 'btn_all',
{idButtonYesToAll} 'btn_all',
{idButtonNoToAll } 'btn_no'
  );
 
function GetLCLDefaultBtnGlyph(Kind: TBitBtnKind): TGraphic;
begin
  Result := GetDefaultButtonIcon(BitBtnImages[Kind]);
end;
 
function GetDefaultButtonIcon(idButton: Integer): TCustomBitmap;
begin
  Result := nil;
  if (idButton < Low(BitBtnResNames)) or (idButton > High(BitBtnResNames)) then
    Exit;
  if BitBtnResNames[idButton] = '' then
    Exit;
  Result := CreateBitmapFromLazarusResource(BitBtnResNames[idButton]);
end;
 
procedure LoadGlyphFromLazarusResource(AGlyph: TButtonGlyph; const AName: String);
var
  C: TCustomBitmap;
begin
  if AName = '' then
    C := nil
  else
    C := CreateBitmapFromLazarusResource(AName);
 
  if C = nil
  then begin
    AGlyph.Glyph := nil;
    Exit;
  end
  else
  begin
    try
      AGlyph.Glyph.Assign(C);
    finally
      C.Free;
    end;
  end;
end;
 
procedure LoadGlyphFromStock(AGlyph: TButtonGlyph; idButton: Integer);
var
  C: TCustomBitmap;
begin
  C := GetButtonIcon(idButton);
  if C = nil then
    AGlyph.Glyph := nil
  else
  begin
    try
      AGlyph.Glyph.Assign(C);
    finally
      C.Free;
    end;
  end;
end;
 
function GetButtonCaption(idButton: Integer): String;
begin
  case idButton of
    idButtonOk       : Result := rsmbOK;
    idButtonCancel   : Result := rsmbCancel;
    idButtonHelp     : Result := rsmbHelp;
    idButtonYes      : Result := rsmbYes;
    idButtonNo       : Result := rsmbNo;
    idButtonClose    : Result := rsmbClose;
    idButtonAbort    : Result := rsmbAbort;
    idButtonRetry    : Result := rsmbRetry;
    idButtonIgnore   : Result := rsmbIgnore;
    idButtonAll      : Result := rsmbAll;
    idButtonYesToAll : Result := rsmbYesToAll;
    idButtonNoToAll  : Result := rsmbNoToAll;
    idButtonOpen     : Result := rsmbOpen;
    idButtonSave     : Result := rsmbSave;
    idButtonShield   : Result := rsmbUnlock;
  else
    Result := '?';
  end;
end;
 
function GetButtonIcon(idButton: Integer): TCustomBitmap;
var
  BitmapHandle, MaskHandle: HBitmap;
begin
  if ThemeServices.GetStockImage(idButton, BitmapHandle, MaskHandle) then
  begin
    Result := TBitmap.Create;
    Result.Handle := BitmapHandle;
    if MaskHandle <> 0 then
      Result.MaskHandle := MaskHandle;
  end
  else
    Result := GetDefaultButtonIcon(idButton);
end;
 
const
  BtnBidiLayout: array[Boolean, TButtonLayout] of TButtonLayout =
  (
    (
      blGlyphLeft,
      blGlyphRight,
      blGlyphTop,
      blGlyphBottom
    ),
    (
      blGlyphRight,
      blGlyphLeft,
      blGlyphTop,
      blGlyphBottom
    )
  );
 
function BidiAdjustButtonLayout(IsRightToLeft: Boolean; Layout: TButtonLayout): TButtonLayout;
begin
  Result := BtnBidiLayout[IsRightToLeft, Layout];
end;
 
procedure Register;
begin
  RegisterComponents('Additional',[TBitBtn,TSpeedButton]);
end;
 
{$I bitbtn.inc}
{$I buttonglyph.inc}
{$I speedbutton.inc}
 
initialization
  {$I btn_icons.lrs}
end.

le lcl/include/speedbutton.inc

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
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
{%MainUnit ../buttons.pp}
 
{******************************************************************************
                                   TCustomSpeedButton
 ******************************************************************************
 
 *****************************************************************************
 *                                                                           *
 *  This file is part of the Lazarus Component Library (LCL)                 *
 *                                                                           *
 *  See the file COPYING.modifiedLGPL.txt, included in this distribution,    *
 *  for details about the copyright.                                         *
 *                                                                           *
 *  This program is distributed in the hope that it will be useful,          *
 *  but WITHOUT ANY WARRANTY; without even the implied warranty of           *
 *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.                     *
 *                                                                           *
 *****************************************************************************
}
 
{$IFOPT C-}
// Uncomment for local trace
//  {$C+}
//  {$DEFINE ASSERT_IS_ON}
{$ENDIF}
 
const
  UpState: array[Boolean] of TButtonState =
  (
{False} bsUp, // mouse in control = false
{True } bsHot // mouse in contorl = true
  );
 
{------------------------------------------------------------------------------
  Method:  TCustomSpeedButton.Create
  Params:  none
  Returns: Nothing
 
  Constructor for the class.
 ------------------------------------------------------------------------------}
constructor TCustomSpeedButton.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FGlyph := TButtonGlyph.Create;
  FGlyph.IsDesigning := csDesigning in ComponentState;
  FGlyph.ShowMode := gsmAlways;
  FGlyph.SetTransparentMode(gtmTransparent);
  FGlyph.OnChange := @GlyphChanged;
 
  with GetControlClassDefaultSize do
    SetInitialBounds(0, 0, CX, CY);
  ControlStyle := ControlStyle + [csCaptureMouse]-[csSetCaption, csClickEvents, csOpaque];
 
  FLayout := blGlyphLeft;
  FAllowAllUp := False;
  FMouseInControl := False;
  FDragging := False;
  FShowAccelChar := True;
  FSpacing := 4;
  FMargin := -1;
  Color := clBtnFace;
  FShowCaption := true;
end;
 
{------------------------------------------------------------------------------
  Method: TCustomSpeedButton.Destroy
  Params:  None
  Returns: Nothing
 
  Destructor for the class.
 ------------------------------------------------------------------------------}
destructor TCustomSpeedButton.Destroy;
begin
  FreeAndNil(FGlyph);
  inherited Destroy;
end;
 
{------------------------------------------------------------------------------
  Method: TCustomSpeedButton.FindDownButton: TCustomSpeedButton;
 
  Searches the speed button with Down=true and the same GroupIndex.
 ------------------------------------------------------------------------------}
function TCustomSpeedButton.FindDownButton: TCustomSpeedButton;
 
  function FindDown(AWinControl: TWinControl): TCustomSpeedButton;
  var
    i: Integer;
    Child: TControl;
    Button: TCustomSpeedButton;
  begin
    if AWinControl=nil then exit(nil);
    for i:=0 to AWinControl.ControlCount-1 do begin
      Child:=AWinControl.Controls[i];
      if Child is TCustomSpeedButton then begin
        Button:=TCustomSpeedButton(Child);
        if (Button.GroupIndex=GroupIndex)
        and (Button.Down) then
          exit(Button);
      end;
      if Child is TWinControl then begin
        Result:=FindDown(TWinControl(Child));
        if Result<>nil then exit;
      end;
    end;
    Result:=nil;
  end;
 
begin
  if Down or (GroupIndex=0) then exit(Self);
  Result:=FindDown(GetFirstParentForm(Self));
end;
 
procedure TCustomSpeedButton.Click;
begin
  inherited Click;
end;
 
{------------------------------------------------------------------------------
  Method: TCustomSpeedButton.SetAllowAllUp
  Params: Value:
  Returns:  nothing
 
 ------------------------------------------------------------------------------}
procedure TCustomSpeedButton.SetAllowAllUp(Value : Boolean);
begin
  if FAllowAllUp <> Value
  then begin
    FAllowAllUp := Value;
    UpdateExclusive;
  end;
end;
 
{------------------------------------------------------------------------------
  Method: TCustomSpeedButton.SetDown
  Params: Value:
  Returns:  nothing
 
 ------------------------------------------------------------------------------}
procedure TCustomSpeedButton.SetDown(Value : Boolean);
var
  OldState: TButtonState;
  OldDown: Boolean;
begin
  //since Down needs GroupIndex, then we need to wait that all properties
  //loaded before we continue
  if (csLoading in ComponentState) then
  begin
    FDownLoaded := Value;
    exit;
  end else
  begin
    if FGroupIndex = 0 then
      Value:= false;
    if FDown <> Value then
    begin
      if FDown and not FAllowAllUp then
        Exit;
      OldDown := FDown;
      FDown := Value;
      OldState := FState;
      if FDown then
        FState := bsExclusive
      else
        FState := UpState[FMouseInControl];
      if (OldDown <> FDown) or (OldState <> FState) then
        Invalidate;
      if Value then
        UpdateExclusive;
    end;
  end;
end;
 
{------------------------------------------------------------------------------
  Method: TCustomSpeedButton.SetFlat
  Params: Value:
  Returns:  nothing
 
 ------------------------------------------------------------------------------}
procedure TCustomSpeedButton.SetFlat(const Value : boolean);
begin
  if FFlat <> Value then 
  begin
    FFlat := Value;
    Invalidate;
  end;
end;
 
{------------------------------------------------------------------------------
  Method: TCustomSpeedButton.SetGlyph
  Params: Value:
  Returns:  nothing
 
 ------------------------------------------------------------------------------}
procedure TCustomSpeedButton.SetGlyph(Value : TBitmap);
begin
  FGlyph.Glyph := Value;
  Invalidate;
end;
 
{------------------------------------------------------------------------------
  Method: TCustomSpeedButton.SetGroupIndex
  Params: Value:
  Returns:  nothing
 
 ------------------------------------------------------------------------------}
procedure TCustomSpeedButton.SetGroupIndex(const Value : Integer);
begin
  if FGroupIndex <> Value then begin
    FGroupIndex := Value;
    UpdateExclusive;
  end;
end;
 
{------------------------------------------------------------------------------
  Method: TCustomSpeedButton.SetMargin
  Params: Value:
  Returns:  nothing
 
 ------------------------------------------------------------------------------}
procedure TCustomSpeedButton.SetMargin(const Value : Integer);
begin
  if FMargin <> Value then begin
    FMargin := Value;
    Invalidate;
  end;
end;
 
{------------------------------------------------------------------------------
  Method: TCustomSpeedButton.SetNumGlyphs
  Params: Value : Integer = Number of glyphs in the file/resource
  Returns:  nothing
 
 ------------------------------------------------------------------------------}
procedure TCustomSpeedButton.SetNumGlyphs(Value : integer);
Begin
  if Value < 0 then Value := 1;
  if Value > High(TNumGlyphs) then Value := High(TNumGlyphs);
 
  if Value <> TButtonGlyph(fGlyph).NumGlyphs then
  Begin
    TButtonGlyph(fGlyph).NumGlyphs := TNumGlyphs(Value);
    Invalidate;
  end;
end;
 
{------------------------------------------------------------------------------
  Method: TCustomSpeedButton.SetSpacing
  Params: Value:
  Returns:  nothing
 
 ------------------------------------------------------------------------------}
procedure TCustomSpeedButton.SetSpacing(const Value : Integer);
begin
  if FSpacing <> Value then begin
    FSpacing := Value;
    Invalidate;
  end;
end;
 
procedure TCustomSpeedButton.SetShowAccelChar(Value : Boolean);
begin
  If FShowAccelChar <> Value then begin
    FShowAccelChar := Value;
    Invalidate;
  end;
end;
 
 
{------------------------------------------------------------------------------
  procedure TCustomSpeedButton.RealSetText(const Value: TCaption);
 ------------------------------------------------------------------------------}
procedure TCustomSpeedButton.RealSetText(const Value: TCaption);
begin
  if Caption = Value then Exit;
  inherited RealSetText(Value);
 
  Invalidate;
end;
 
{------------------------------------------------------------------------------
  procedure TCustomSpeedButton.UpdateState(InvalidateOnChange: boolean);
 ------------------------------------------------------------------------------}
procedure TCustomSpeedButton.UpdateState(InvalidateOnChange: boolean);
var
  OldState: TButtonState;
begin
  OldState := FState;
  if not Enabled then
  begin
    FState := bsDisabled;
    FDragging := False;
  end else
  begin
    if FState = bsDisabled then
    begin
      if FDown and (GroupIndex <> 0) then
        FState := bsExclusive
      else
        FState := UpState[FMouseInControl];
    end
    else
    if (FState in [bsHot, bsDown]) and (not FMouseInControl) and (not FDragging) and (not FDown) then
    begin
      // return to normal
      FState := bsUp;
    end
    else
    if (FState = bsUp) and FMouseInControl then
      FState := bsHot;
  end;
  if FState <> OldState then
    if (Action is TCustomAction) then
      TCustomAction(Action).Checked := FState = bsDown;
  //if InvalidateOnChange then DebugLn(['TCustomSpeedButton.UpdateState ',DbgSName(Self),' InvalidateOnChange=',InvalidateOnChange,' StateChange=',FState<>OldState]);
  if InvalidateOnChange and
     (
       (FState <> OldState) or
       not ThemedElementDetailsEqual(FLastDrawDetails, GetDrawDetails)
     )
  then
    Invalidate;
end;
 
{------------------------------------------------------------------------------
  function TCustomSpeedButton.GetDrawDetails: TThemedElementDetails;
 ------------------------------------------------------------------------------}
function TCustomSpeedButton.GetDrawDetails: TThemedElementDetails;
 
  function ButtonPart: TThemedButton;
  begin
    // tbPushButtonNormal, tbPushButtonHot, tbPushButtonPressed,
    // tbPushButtonDisabled, tbPushButtonDefaulted
 
    // no check states available
    Result := tbPushButtonNormal;
    if not Enabled then
      Result := tbPushButtonDisabled
    else
    if FState in [bsDown, bsExclusive] then
      Result := tbPushButtonPressed
    else
    if FState = bsHot then
      Result := tbPushButtonHot
    else
      Result := tbPushButtonNormal
  end;
 
  function ToolButtonPart: TThemedToolBar;
  begin
    // ttbButtonNormal, ttbButtonHot, ttbButtonPressed, ttbButtonDisabled
    // ttbButtonChecked, ttbButtonCheckedHot
    if not Enabled then
      Result := ttbButtonDisabled
    else
    begin
      if Down then
      begin // checked states
        if FMouseInControl then
          Result := ttbButtonCheckedHot
        else
          Result := ttbButtonChecked
      end
      else
      begin
        if FState in [bsDown, bsExclusive] then
          Result := ttbButtonPressed else
        if FState = bsHot then
          Result := ttbButtonHot
        else
          Result := ttbButtonNormal
      end;
    end;
  end;
 
begin
  if Flat then
    Result := ThemeServices.GetElementDetails(ToolButtonPart)
  else
    Result := ThemeServices.GetElementDetails(ButtonPart)
end;
 
procedure TCustomSpeedButton.ActionChange(Sender: TObject;
  CheckDefaults: Boolean);
begin
  inherited ActionChange(Sender,CheckDefaults);
  if Sender is TCustomAction then begin
    with TCustomAction(Sender) do begin
      if CheckDefaults or (Self.GroupIndex = 0) then
        Self.GroupIndex := GroupIndex;
      if (Glyph.Empty) and (ActionList <> nil) and (ActionList.Images <> nil)
      and (ImageIndex >= 0) and (ImageIndex < ActionList.Images.Count) then
        ActionList.Images.GetBitmap(ImageIndex, Glyph);
    end;
  end;
end;
 
function TCustomSpeedButton.GetActionLinkClass: TControlActionLinkClass;
begin
  Result := TSpeedButtonActionLink;
end;
 
class function TCustomSpeedButton.GetControlClassDefaultSize: TSize;
begin
  Result.CX := 23;
  Result.CY := 22;
end;
 
{------------------------------------------------------------------------------
  Method: TCustomSpeedButton.UpdateExclusive
  Params: none
  Returns:  nothing
 
 ------------------------------------------------------------------------------}
procedure TCustomSpeedButton.UpdateExclusive;
var
  msg : TLMessage;
begin
  if (FGroupIndex <> 0) and (Parent <> nil)
  and (not (csLoading in ComponentState))
  then begin
    Msg.Msg := CM_ButtonPressed;
    Msg.WParam := FGroupIndex;
    Msg.LParam := PtrInt(Self);
    Msg.Result := 0;
    Parent.Broadcast(Msg);
  end;
end;
 
{------------------------------------------------------------------------------
  Function: TCustomSpeedButton.GetGlyph
  Params: none
  Returns:  The bitmap
 
 ------------------------------------------------------------------------------}
function TCustomSpeedButton.GetGlyph : TBitmap;
begin
  Result := FGlyph.Glyph;
end;
 
procedure TCustomSpeedButton.SetShowCaption(const AValue: boolean);
begin
  if FShowCaption=AValue then exit;
  FShowCaption:=AValue;
  invalidate;
end;
 
{------------------------------------------------------------------------------
  Method: TCustomSpeedButton.GetNumGlyphs
  Params: none
  Returns:  The number stored in TButtonGlyph(FGlyph).NumGlyphs
 
 ------------------------------------------------------------------------------}
function TCustomSpeedButton.GetNumGlyphs : Integer;
Begin
  Result :=  TButtonGlyph(fGlyph).NumGlyphs;
end;
 
{------------------------------------------------------------------------------
  Method: TCustomSpeedButton.GlyphChanged
  Params: Sender - The glyph that changed
  Returns:  zippo
 
 ------------------------------------------------------------------------------}
procedure TCustomSpeedButton.GlyphChanged(Sender : TObject);
Begin
  //redraw the button;
  Invalidate;
end;
 
function TCustomSpeedButton.DialogChar(var Message: TLMKey): boolean;
begin
  Result := False;
 
  Assert(Message.Msg = LM_SYSCHAR, '*** Warning: non LM_SYSCHAR passed to TCustomSpeedButton.DialogChar ! ***');
 
  if not FShowAccelChar then Exit;
 
  if IsAccel(Message.CharCode, Caption) then
  begin
    Result := True;
    if GroupIndex <> 0 then
      SetDown(not FDown);
    Click;
  end else
    Result := inherited DialogChar(Message);
end;
 
{------------------------------------------------------------------------------
  Method: TCustomSpeedButton.Paint
  Params: none
  Returns:  nothing
 
 ------------------------------------------------------------------------------}
procedure TCustomSpeedButton.Paint;
var
  PaintRect: TRect;
  GlyphWidth, GlyphHeight: Integer;
  Offset, OffsetCap: TPoint;
  ClientSize, TotalSize, TextSize, GlyphSize: TSize;
  M, S : integer;
  SIndex : Longint;
  TMP : String;
  TextFlags: Integer;
begin
  UpdateState(false);
  if FGlyph = nil then exit;
 
  PaintRect:=ClientRect;
  FLastDrawDetails := GetDrawDetails;
 
  PaintBackground(PaintRect);
 
  GlyphSize := GetGlyphSize(PaintRect);
  GlyphWidth := GlyphSize.CX;
  if TButtonGlyph(FGlyph).NumGlyphs > 1 then
    GlyphWidth:=GlyphWidth div NumGlyphs;
  GlyphHeight := GlyphSize.CY;
 
  ClientSize.cx:= PaintRect.Right - PaintRect.Left;
  ClientSize.cy:= PaintRect.Bottom - PaintRect.Top;
 
  TextSize := GetTextSize(PaintRect);
 
  if Caption <> '' then
  begin
    TMP := Caption;
    SIndex := DeleteAmpersands(TMP);
    If SIndex > 0 then
      If SIndex <= Length(TMP) then begin
        FShortcut := Ord(TMP[SIndex]);
      end;
  end;
 
  if (GlyphWidth = 0) or (GlyphHeight = 0)
  or (TextSize.cx = 0) or (TextSize.cy = 0)
  then
    S:= 0
  else
    S:= Spacing;
 
  // Calculate caption and glyph layout
 
  if Margin = -1 then begin
    if S = -1 then begin
      TotalSize.cx:= TextSize.cx + GlyphWidth;
      TotalSize.cy:= TextSize.cy + GlyphHeight;
      if Layout in [blGlyphLeft, blGlyphRight] then
        M:= (ClientSize.cx - TotalSize.cx) div 3
      else
        M:= (ClientSize.cy - TotalSize.cy) div 3;
      S:= M;
    end else begin
      TotalSize.cx:= GlyphWidth + S + TextSize.cx;
      TotalSize.cy:= GlyphHeight + S + TextSize.cy;
      if Layout in [blGlyphLeft, blGlyphRight] then
        M:= (ClientSize.cx - TotalSize.cx) div 2
      else
        M:= (ClientSize.cy - TotalSize.cy) div 2;
    end;
  end else begin
    if S = -1 then begin
      TotalSize.cx:= ClientSize.cx - (Margin + GlyphWidth);
      TotalSize.cy:= ClientSize.cy - (Margin + GlyphHeight);
      if Layout in [blGlyphLeft, blGlyphRight] then
        S:= (TotalSize.cx - TextSize.cx) div 2
      else
        S:= (TotalSize.cy - TextSize.cy) div 2;
    end;
    M:= Margin;
  end;
 
  case BidiAdjustButtonLayout(UseRightToLeftReading, Layout) of
    blGlyphLeft : begin
      Offset.X:= M;
      Offset.Y:= (ClientSize.cy - GlyphHeight) div 2;
      OffsetCap.X:= Offset.X + GlyphWidth + S;
      OffsetCap.Y:= (ClientSize.cy - TextSize.cy) div 2;
    end;
    blGlyphRight : begin
      Offset.X:= ClientSize.cx - M - GlyphWidth;
      Offset.Y:= (ClientSize.cy - GlyphHeight) div 2;
      OffsetCap.X:= Offset.X - S - TextSize.cx;
      OffsetCap.Y:= (ClientSize.cy - TextSize.cy) div 2;
    end;
    blGlyphTop : begin
      Offset.X:= (ClientSize.cx - GlyphWidth) div 2;
      Offset.Y:= M;
      OffsetCap.X:= (ClientSize.cx - TextSize.cx) div 2;
      OffsetCap.Y:= Offset.Y + GlyphHeight + S;
    end;
    blGlyphBottom : begin
      Offset.X:= (ClientSize.cx - GlyphWidth) div 2;
      Offset.Y:= ClientSize.cy - M - GlyphHeight;
      OffsetCap.X:= (ClientSize.cx - TextSize.cx) div 2;
      OffsetCap.Y:= Offset.Y - S - TextSize.cy;
    end;
  end;
 
  DrawGlyph(Canvas, PaintRect, Offset, FState, Transparent, 0);
  if FShowCaption and (Caption <> '') then
  begin
    with PaintRect, OffsetCap do
    begin
      Left := Left + X;
      Top := Top + Y;
    end;
 
    TextFlags := DT_LEFT or DT_TOP;
    if UseRightToLeftReading then
      TextFlags := TextFlags or DT_RTLREADING;
 
    ThemeServices.DrawText(Canvas, FLastDrawDetails, Caption, PaintRect,
      TextFlags, 0);
  end;
 
  inherited Paint;
end;
 
procedure TCustomSpeedButton.PaintBackground(var PaintRect: TRect);
begin
  if not Transparent and ThemeServices.HasTransparentParts(FLastDrawDetails) then
  begin
    Canvas.Brush.Color := Color;
    Canvas.FillRect(PaintRect);
  end;
  ThemeServices.DrawElement(Canvas.Handle, FLastDrawDetails, PaintRect);
  PaintRect := ThemeServices.ContentRect(Canvas.Handle, FLastDrawDetails, PaintRect);
end;
 
{------------------------------------------------------------------------------
  Method: TCustomSpeedButton.MouseDown
  Params: Button:
          Shift:
          X, Y:
  Returns:  nothing
 ------------------------------------------------------------------------------}
procedure TCustomSpeedButton.MouseDown(Button: TMouseButton; Shift: TShiftState;
  X, Y: Integer);
begin
  inherited MouseDown(Button, Shift, X, Y);
  if csDesigning in ComponentState then exit;
 
  if (Button = mbLeft) and Enabled then
  begin
    if not FDown then
    begin
      FState := bsDown;
      if (Action is TCustomAction) then
        TCustomAction(Action).Checked := False;
      Invalidate;
    end;
    FDragging := True;
  end;
end;
 
{------------------------------------------------------------------------------
  Method: TCustomSpeedButton.MouseMove
  Params: Shift:
          X, Y:
  Returns:  nothing
 
 ------------------------------------------------------------------------------}
procedure TCustomSpeedButton.MouseMove(Shift: TShiftState; X, Y: Integer);
var
  NewState: TButtonState;
begin
  inherited MouseMove(Shift, X, Y);
  if csDesigning in ComponentState then exit;
 
  if FDragging then
  begin
    Assert(False,'Trace:FDragging is true');
    if FDown then
      NewState := bsExclusive
    else
    begin
      if  (X >= 0) and (X < Width)
      and (Y >= 0) and (Y < Height) 
      then
        NewState := bsDown
      else
        NewState := UpState[FMouseInControl];
    end;
 
    if NewState <> FState then
    begin
      //debugln(['TCustomSpeedButton.MouseMove ',DbgSName(Self),' fState=',ord(fstate),' NewState=',ord(NewState)]);
      FState := NewState;
      Invalidate;
    end;
  end;
end;
 
{------------------------------------------------------------------------------
  Method: TCustomSpeedButton.MouseUp
  Params: Button:
          Shift:
          X, Y:
  Returns:  nothing
 ------------------------------------------------------------------------------}
procedure TCustomSpeedButton.MouseUp(Button: TMouseButton; Shift: TShiftState;
  X, Y: Integer);
begin
  inherited MouseUp(Button, Shift, X, Y);
end;
 
{------------------------------------------------------------------------------
  procedure TCustomSpeedButton.DoBeforeMouseMessage;
------------------------------------------------------------------------------}
procedure TCustomSpeedButton.DoBeforeMouseMessage;
begin
  if Application<>nil then
    Application.DoBeforeMouseMessage(Self);
end;
 
{------------------------------------------------------------------------------
       TCustomSpeedButton DoMouseUp  "Event Handler"
------------------------------------------------------------------------------}
procedure TCustomSpeedButton.DoMouseUp(var Message: TLMMouse; Button: TMouseButton);
begin
  if not (csNoStdEvents in ControlStyle)
  then with Message do
    MouseUp(Button, KeysToShiftState(Keys), XPos, YPos);
end;
 
procedure TCustomSpeedButton.WMLButtonDown(var Message: TLMLButtonDown);
begin
  inherited;
 
  // because csClickEvents is not set no csClicked is set in the inherited method
  Include(FControlState, csClicked);
end;
 
procedure TCustomSpeedButton.WMLButtonDBLCLK(var Message: TLMLButtonDblClk);
begin
  inherited;
 
  // if in a group, raise dblclick event, otherwise translate to click event
  if Down
    then DblClick
    else Click;
end;
 
class procedure TCustomSpeedButton.WSRegisterClass;
begin
  inherited WSRegisterClass;
  RegisterCustomSpeedButton;
end;
 
{------------------------------------------------------------------------------
  Method: TCustomSpeedButton.WMLButtonUp
  Params: Message
  Returns: Nothing
 
  Mouse event handler
 ------------------------------------------------------------------------------}
procedure TCustomSpeedButton.WMLButtonUp(var Message: TLMLButtonUp);
var
  OldState: TButtonState;
begin
  DoBeforeMouseMessage;
  //DebugLn('TCustomSpeedButton.WMLButtonUp A ',DbgSName(Self),' csCaptureMouse=',DbgS(csCaptureMouse in ControlStyle),' csClicked=',DbgS(csClicked in ControlState));
  if (csCaptureMouse in ControlStyle) and (mbLeft in CaptureMouseButtons) then
  begin
    {$IFDEF VerboseMouseCapture}
    DebugLn('TCustomSpeedButton.WMLButtonUp ',Name,':',ClassName);
    {$ENDIF}
    MouseCapture := False;
  end;
 
  if not (csDesigning in ComponentState) and FDragging then
  begin
    OldState := FState;
    FDragging := False;
 
    if FGroupIndex = 0 then
    begin
      FState := UpState[FMouseInControl];
      if OldState <> FState then
        Invalidate;
    end
    else if (Message.XPos >= 0) and (Message.XPos < Width)
        and (Message.YPos >= 0) and (Message.YPos < Height) then
      SetDown(not FDown);
  end;
 
  DoMouseUp(Message, mbLeft);
 
  if csClicked in ControlState then
  begin
    Exclude(FControlState, csClicked);
    //DebugLn('TCustomSpeedButton.WMLButtonUp B ',dbgs(ClientRect.Left),',',dbgs(ClientRect.Top),',',dbgs(ClientRect.Right),',',dbgs(ClientRect.Bottom),' ',dbgs(Message.Pos.X),',',dbgs(Message.Pos.Y));
    if PtInRect(ClientRect, SmallPointToPoint(Message.Pos))
    then begin
      //DebugLn('TCustomSpeedButton.WMLButtonUp C');
      // Important: Calling Click can invoke modal dialogs, so call this as last
      Click;
    end;
  end;
 
 
  //DebugLn('TCustomSpeedButton.WMLButtonUp END');
end;
 
{------------------------------------------------------------------------------
  Method: TCustomSpeedButton.SetLayout
  Params: Value: new layout value
  Returns:  nothing
 
 ------------------------------------------------------------------------------}
procedure TCustomSpeedButton.SetLayout(const Value : TButtonLayout);
begin
  if Value <> FLayout then begin
    FLayout:= Value;
    Invalidate;
  end;
end;
 
{------------------------------------------------------------------------------
  Method: TCustomSpeedButton.SetTransparent
  Params: Value: new transparency value
  Returns:  nothing
 
 ------------------------------------------------------------------------------}
procedure TCustomSpeedButton.SetTransparent(const AValue: boolean);
const
  MODE: array[Boolean] of TGlyphTransparencyMode = (gtmOpaque, gtmTransparent);
begin
  if AValue = Transparent then Exit;
 
  if AValue then
    ControlStyle := ControlStyle - [csOpaque]
  else
    ControlStyle := ControlStyle + [csOpaque];
 
  FGlyph.SetTransparentMode(MODE[AValue]);
  Invalidate;
end;
 
{------------------------------------------------------------------------------
  Method: TCustomSpeedButton.CMButtonPressed
  Params: Message:
  Returns:  nothing
 
 ------------------------------------------------------------------------------}
procedure TCustomSpeedButton.CMButtonPressed(var Message : TLMessage);
var
  Sender : TCustomSpeedButton;
begin
  if csDestroying in ComponentState then exit;
  if Message.WParam = WParam(FGroupIndex)
  then begin
    Sender := TCustomSpeedButton(Message.LParam);
    if Sender <> Self
    then begin
      if Sender.Down and FDown
      then begin
        FDown := False;
        FState := UpState[FMouseInControl];
        Invalidate;
      end;
      FAllowAllUp := Sender.AllowAllUp;
    end;
  end;
end;
 
procedure TCustomSpeedButton.Loaded;
begin
  inherited Loaded;
  UpdateExclusive;
  if FDownLoaded then
    SetDown(FDownLoaded);
end;
 
procedure TCustomSpeedButton.LoadGlyphFromLazarusResource(const AName: String);
begin
  Buttons.LoadGlyphFromLazarusResource(FGlyph, AName);
end;
 
function TCustomSpeedButton.GetGlyphSize(PaintRect: TRect): TSize;
begin
  Result.CX := FGlyph.Glyph.Width;
  Result.CY := FGlyph.Glyph.Height;
end;
 
function TCustomSpeedButton.GetTextSize(PaintRect: TRect): TSize;
var
  TMP: String;
  TXTStyle: TTextStyle;
  Flags: Cardinal;
begin
  if FShowCaption and (Caption <> '') then
  begin
    TMP := Caption;
    TXTStyle := Canvas.TextStyle;
    TXTStyle.Opaque := False;
    TXTStyle.Clipping := True;
    TXTStyle.ShowPrefix := ShowAccelChar;
    TXTStyle.Alignment := taLeftJustify;
    TXTStyle.Layout := tlTop;
    TXTStyle.RightToLeft := UseRightToLeftReading;
    TXTStyle.SystemFont := Canvas.Font.IsDefault;//Match System Default Style
    DeleteAmpersands(TMP);
 
    Flags := DT_CalcRect;
    if not TXTStyle.SingleLine then Inc(Flags, DT_WordBreak);
 
    DrawText(Canvas.Handle, PChar(TMP), Length(TMP), PaintRect, Flags);
    Result.CY := PaintRect.Bottom - PaintRect.Top;
    Result.CX := PaintRect.Right - PaintRect.Left;
  end
  else
  begin
    Result.CY:= 0;
    Result.CX:= 0;
  end;
end;
 
function TCustomSpeedButton.GetTransparent: Boolean;
begin
  if FGlyph.TransparentMode = gtmGlyph
  then Result := FGlyph.FOriginal.Transparent
  else Result := FGlyph.TransparentMode = gtmTransparent;
end;
 
function TCustomSpeedButton.DrawGlyph(ACanvas: TCanvas; const AClient: TRect;
  const AOffset: TPoint; AState: TButtonState; ATransparent: Boolean;
  BiDiFlags: Longint): TRect;
begin
  if Assigned(FGlyph) then
  begin
    if (AState = bsDown) or (Down = true) then
      Result := FGlyph.Draw(ACanvas, AClient, point(AOffset.x + 1, AOffset.y + 1), AState, ATransparent, BiDiFlags)
    else
      Result := FGlyph.Draw(ACanvas, AClient, AOffset, AState, ATransparent, BiDiFlags);
  end;
end;
 
{------------------------------------------------------------------------------
  Method: TCustomSpeedButton.CMEnabledChanged
  Params: Message:
  Returns:  nothing
 
 ------------------------------------------------------------------------------}
procedure TCustomSpeedButton.CMEnabledChanged(var Message: TLMEssage);
Begin
  //Should create a new glyph based on the new state
  UpdateState(true);
end;
 
{------------------------------------------------------------------------------
  Method: TCustomSpeedButton.MouseEnter
  Params:
  Returns:  nothing
 
 ------------------------------------------------------------------------------}
procedure TCustomSpeedButton.MouseEnter;
begin
  if csDesigning in ComponentState then exit;
  if not FMouseInControl and Enabled and (GetCapture = 0) then
  begin
    FMouseInControl := True;
    UpdateState(true);
    inherited MouseEnter;
  end;
end;
 
{------------------------------------------------------------------------------
  Method: TCustomSpeedButton.MouseLeave
  Params:
  Returns:  nothing
 
 ------------------------------------------------------------------------------}
procedure TCustomSpeedButton.MouseLeave;
begin
  if csDesigning in ComponentState then exit;
  ///DebugLn(['TCustomSpeedButton.MouseLeave ',DbgSName(Self),' FMouseInControl=',FMouseInControl,' FDragging=',FDragging]);
  if FMouseInControl then
  begin
    FMouseInControl := False;
    if Enabled then
    begin
      if FDragging and (not MouseCapture) then
      begin
        // something fetched our mouse capture
        FDragging:=false;
      end;
      UpdateState(true);
      inherited MouseLeave;
    end;
  end;
end;
 
{ TSpeedButtonActionLink }
 
procedure TSpeedButtonActionLink.AssignClient(AClient: TObject);
begin
  inherited AssignClient(AClient);
  FClient := AClient as TCustomSpeedButton;
end;
 
function TSpeedButtonActionLink.IsCheckedLinked: Boolean;
var
  SpeedButton: TCustomSpeedButton;
begin
  SpeedButton:=TCustomSpeedButton(FClient);
  Result := inherited IsCheckedLinked
            and (SpeedButton.GroupIndex <> 0)
            and SpeedButton.AllowAllUp
            and (SpeedButton.Down = (Action as TCustomAction).Checked);
end;
 
function TSpeedButtonActionLink.IsGroupIndexLinked: Boolean;
var
  SpeedButton: TCustomSpeedButton;
begin
  SpeedButton:=TCustomSpeedButton(FClient);
  Result := (SpeedButton is TCustomSpeedButton) and
    (SpeedButton.GroupIndex = (Action as TCustomAction).GroupIndex);
end;
 
procedure TSpeedButtonActionLink.SetGroupIndex(Value: Integer);
begin
  if IsGroupIndexLinked then TCustomSpeedButton(FClient).GroupIndex := Value;
end;
 
procedure TSpeedButtonActionLink.SetChecked(Value: Boolean);
begin
  if IsCheckedLinked then TCustomSpeedButton(FClient).Down := Value;
end;
 
 
{$IFDEF ASSERT_IS_ON}
  {$UNDEF ASSERT_IS_ON}
  {$C-}
{$ENDIF}

Invité · 02/10/2010, 11h53

Bonjour,

Suite de la réflexion (j+1) :

La "customisation" (en protected) semble être une (la) bonne solution. Reste la maintenance. J'ai préféré régler le problème comme cela : Dans la lcl/buttons.pp, j'ai recopié le code

Code :

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

1
2
3
4
5
6
 { TSpeedButton}
 
  TSpeedButton = class(TCustomSpeedButton)
  published
    property Action;
   [...]

en transformant simplement les properties published en protected (et en recopiant s'il le faut les nouvelles méthodes et les méthodes surchargées qu'il contient).

Code :

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

1
2
3
4
5
6
7
 
{ TSpeedButtonSLZ }
 
  TSpeedButtonSLZ = class(TCustomSpeedButton)
  protected
    property Action;
  [...]

On reconstruit Lazarus... et le nouveau composant (TmySpeedbutton) hérite de TSpeedButtonSLZ (exactement le même que TSpeedButton sauf qu'il est "custommisé" en protected...). Ce n'est pas vraiment LA solution, mais cela aboutit au résultat recherché...

Ce n'est pas LA solution parce qu'elle n'est pas portable. En interne, pas de problème sauf une correction (au moins une vérification) à chaque fois que l'on change de version de Lazarus. Mais le composant n'est pas diffusable en "externe" à partir du moment où on corrige le code de Lazarus lui-même. C'est un peu mieux, si on utilise le TCustomSpeedButton de Lazarus comme ancêtre et qu'on inclut (copie à partir de celui de la classe TSpeedButton), le code nécessaire dans le TmySpeedbutton. Mais la durée de vie sera très limitée par la nécessité que les méthodes surchargées ont de rester compatibles avec celles du Custom (autrement dit qu'elles soient -de fait- compatibles avec celles du composant final distribué avec Lazarus).

Petite disgression avant de déclarer "Résolu"
Pour le développement de Lazarus, c'est une mauvaise "réalité". Dans une société de production, en interne le problème est facilement jouable. Mais Lazarus est un IDE communautaire. S'il n'y a pas de plateforme commune à son développement notamment de ses composants, c'est nuisible. Or, chacun ne peut pas répercuter les "modifications" de la LCL pour générer les composants. Chacun ne peut pas s'amuser, non plus, à modifier un code "lourd" de composant parce que la nouvelle version de Lazarus n'est plus compatible (Le code est facile à modifier par l'auteur parce qu'il l'a créé... mais pas l'utilisateur). A contrario, pour infirmer cette position, on pourrait prendre l'exemple de Delphi qui dispose de nombreux composants. Mais Delphi est plus stable et dispose surtout d'une compatibilité ascendante remarquable. On arrive encore à compiler des très vieux codes avec des versions récentes. Donc les composants sont facilement réutilisables et longtemps. Essayez de recompiler en 0.9.29 des codes produits en 0.9.26. Le nombre de fois où cela plante chez moi est largement supérieur au nobre de fois où cela passe. Et d'autre part, Delphi pendant longtemps a disposé d'une communauté très nombreuse largement supérieure à celle de Lazarus actuellement.

Je considère le problème comme résolu à mon niveau. Mais la solution (le composant) compte tenu des choix -j'allais dire "contraints" pour respecter intégralement mon cahier des charges initial- n'est malheureusement pas "portable"... Evidemment, rien impose d'être aussi exigeant avec la présence "visuelle' de property bloquée par le code (mais qui reste cependant inutile). Il est vrai que l'usager final ne voit pas l'inspecteur d'objet du composant... Mais si Lazarus peut faire mieux, il n'y a pas non plus de raisons de rester à la traîne d'autant que je suppose que beaucoup d'utilisateurs de Lazarus ont l'habitude (et le plaisir) de mettre les mains (ou au moins les yeux) dans le "moteur".

Bonne journée.
Cordialement. Gilles

Modifier l'évènement d'un composant [Lazarus]

Lazarus Pascal

Discussions similaires

Partager

Partager