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
| //------------------------------------------------------------------------------
(* SoLuTions is an Versatile Library for Delphi -
* -
* Version alternative publiée sur "www.developpez.net" -
* Post : "Des applications qui ont de la gueule avec XE2 " -
* Post Number : 6596974 -
* Post URL = "http://www.developpez.net/forums/d1204594/c-cpp/outils-c-cpp/cppbuilder/applications-ont-gueule-xe2/#post6596974"
* -
* Copyright ou © ou Copr. "SLT Solutions", (2006) -
* contributeur : ShaiLeTroll (2012) - Gestion des Styles sous C++BuilderXE2 -
* contributeur : ShaiLeTroll (2012) - Documentation Insight -
* contributeur : ShaiLeTroll (2014) - Traduction du code C++Builder vers DelphiXE2
* -
* -
* Ce logiciel est un programme informatique servant à aider les développeurs -
* Delphi avec une bibliothèque polyvalente, adaptable et fragmentable. -
* -
* Ce logiciel est régi par la licence CeCILL-C soumise au droit français et -
* respectant les principes de diffusion des logiciels libres. Vous pouvez -
* utiliser, modifier et/ou redistribuer ce programme sous les conditions -
* de la licence CeCILL-C telle que diffusée par le CEA, le CNRS et l'INRIA -
* sur le site "http://www.cecill.info". -
* -
* En contrepartie de l'accessibilité au code source et des droits de copie, -
* de modification et de redistribution accordés par cette licence, il n'est -
* offert aux utilisateurs qu'une garantie limitée. Pour les mêmes raisons, -
* seule une responsabilité restreinte pèse sur l'auteur du programme, le -
* titulaire des droits patrimoniaux et les concédants successifs. -
* -
* A cet égard l'attention de l'utilisateur est attirée sur les risques -
* associés au chargement, à l'utilisation, à la modification et/ou au -
* développement et à la reproduction du logiciel par l'utilisateur étant -
* donné sa spécificité de logiciel libre, qui peut le rendre complexe à -
* manipuler et qui le réserve donc à des développeurs et des professionnels -
* avertis possédant des connaissances informatiques approfondies. Les -
* utilisateurs sont donc invités à charger et tester l'adéquation du -
* logiciel à leurs besoins dans des conditions permettant d'assurer la -
* sécurité de leurs systèmes et ou de leurs données et, plus généralement, -
* à l'utiliser et l'exploiter dans les mêmes conditions de sécurité. -
* -
* Le fait que vous puissiez accéder à cet en-tête signifie que vous avez -
* pris connaissance de la licence CeCILL-C, et que vous en avez accepté les -
* termes. -
* -
*----------------------------------------------------------------------------*)
unit SLT.Controls.VCL.ThemesEx;
interface
uses System.Classes, System.SysUtils,
Vcl.Themes, Vcl.Menus, Vcl.Forms, Vcl.Graphics;
type
/// <summary>Assistance de la classe TStyleManager</summary>
/// <remarks>Le TStyleManagerSLTAssistant n'est pas un class helper car lors de sa création la version utilisée était C++Builder XE2,
/// Traduction C++Builder vers Delphi en concervant ce concept des Assistances de classes (Class Helper) du Delphi.NET</remarks>
TStyleManagerSLTAssistant = class(TObject)
public
/// <summary>BuildChangeStyleMenu ajoute comme menus enfants dans un TMenuItem, tous les noms de style connus par le gestionnaire de style</summary>
/// <param name="AMenu">Menu dans lequel seront insérés comme sous-menu chaque style géré par l'application</param>
/// <param name="AOnClick">Gestionnaire d'évèmenent commun à chaque sous-menu, le Tag permet de trouver le style concerné, il recommandé d'utiliser StyleClickDefaultEventHandler</param>
/// <param name="ADefaultStyle">Style fixé à l'origine</param>
class procedure BuildChangeStyleMenu(AMenu: TMenuItem; AOnClick: TNotifyEvent; const ADefaultStyle: string = '');
class procedure StyleClickDefaultEventHandler(Sender: TObject);
class function GetThemedBackgroundColor(): TColor;
end;
implementation
//------------------------------------------------------------------------------
class procedure TStyleManagerSLTAssistant.BuildChangeStyleMenu(AMenu: TMenuItem; AOnClick: TNotifyEvent; const ADefaultStyle: string = '');
var
Styles: TArray<string>;
I: Integer;
menu: TMenuItem;
DefaultStyleName: string;
begin
AMenu.AutoHotkeys := maManual;
AMenu.Clear();
if ADefaultStyle <> '' then
DefaultStyleName := ADefaultStyle
else
DefaultStyleName := Vcl.Themes.TStyleManager.SystemStyle.Name;
Styles := Vcl.Themes.TStyleManager.StyleNames;
for I := Low(Styles) to High(Styles) do
begin
menu := TMenuItem.Create(AMenu);
AMenu.Add(menu);
menu.Tag := i;
menu.AutoHotkeys := maManual;
menu.RadioItem := true;
menu.GroupIndex := 1;
menu.Caption := Styles[i];
if menu.Caption = DefaultStyleName then
begin
menu.Checked := True;
TStyleManager.SetStyle(menu.Caption);
end;
menu.OnClick := AOnClick;
end;
end;
//------------------------------------------------------------------------------
class function TStyleManagerSLTAssistant.GetThemedBackgroundColor(): TColor;
begin
if not StyleServices.Enabled or StyleServices.IsSystemStyle then
Result := clBtnFace
else
Result := ColorToRGB(StyleServices.GetStyleColor(scWindow)); // semble la même couleur que scGenericBackground
end;
//------------------------------------------------------------------------------
class procedure TStyleManagerSLTAssistant.StyleClickDefaultEventHandler(Sender: TObject);
var
menu: TMenuItem;
begin
if Sender is TMenuItem then
begin
menu := TMenuItem(Sender);
if not SameText(TStyleManager.ActiveStyle.Name, menu.Caption) then
begin
menu.Checked := True;
TStyleManager.SetStyle(menu.Caption);
end;
Application.BringToFront();
end;
end;
end. |
