Typically we use a combobox or listbox to allow to the final user select and appy a VCL Style, Today I will show you a new way using the system menu of the form.
First you need to use the GetSystemMenu WinApi function to get a handle to the system menu of the form. Then using the AppendMenu or the InsertMenuItem methods you can customize the system menu, from here you must store the identifier of the new menu item added and finally process the WM_SYSCOMMAND message to launch an action.
Check the next commented code
uses
System.Rtti,
System.Classes,
System.Generics.Collections,
WinApi.Windows,
WinApi.Messages,
Vcl.Themes,
Vcl.Styles,
Vcl.Forms;
type
TMethodInfo=class;
TProcCallback = reference to procedure(Info : TMethodInfo);
TMethodInfo=class
Value1 : TValue;
Value2 : TValue;
Method : TProcCallback;
end;
TVclStylesSystemMenu=class(TComponent)
strict private
FVCLStylesMenu : HMenu;
FOrgWndProc: TWndMethod;
FForm : TForm;
FMethodsDict : TObjectDictionary<NativeUInt, TMethodInfo>;
procedure CreateMenus;
procedure DeleteMenus;
procedure CreateMenuStyles;
procedure WndProc(var Message: TMessage);
public
constructor Create(AOwner: TForm); reintroduce;
destructor Destroy; override;
end;
implementation
uses
Vcl.Controls,
System.SysUtils;
const
VCLStylesMenu=WM_USER + 666;
//Add a new Menu Item
function InsertMenuHelper(hMenu: HMENU; uPosition: UINT; uIDNewItem: UINT_PTR; lpNewItem, IconName: LPCWSTR) : BOOL;
var
LMenuItem : TMenuItemInfo;
begin
ZeroMemory(@LMenuItem, SizeOf(TMenuItemInfo));
LMenuItem.cbSize := SizeOf(TMenuItemInfo);
LMenuItem.fMask := MIIM_FTYPE or MIIM_ID or MIIM_BITMAP or MIIM_STRING;
LMenuItem.fType := MFT_STRING;
LMenuItem.wID := uIDNewItem;
LMenuItem.dwTypeData := lpNewItem;
Result:=InsertMenuItem(hMenu, uPosition, True, LMenuItem);
end;
//Add a new separator
procedure AddMenuSeparatorHelper(hMenu : HMENU; var MenuIndex : Integer);
var
LMenuInfo : TMenuItemInfo;
Buffer : array [0..79] of char;
begin
ZeroMemory(@LMenuInfo, SizeOf(TMenuItemInfo));
LMenuInfo.cbSize := sizeof(LMenuInfo);
LMenuInfo.fMask := MIIM_TYPE;
LMenuInfo.dwTypeData := Buffer;
LMenuInfo.cch := SizeOf(Buffer);
if GetMenuItemInfo(hMenu, MenuIndex-1, True, LMenuInfo) then
begin
if (LMenuInfo.fType and MFT_SEPARATOR) = MFT_SEPARATOR then
else
begin
InsertMenu(hMenu, MenuIndex, MF_BYPOSITION or MF_SEPARATOR, 0, nil);
inc(MenuIndex);
end;
end;
end;
{ TVclStylesSystemMenu }
constructor TVclStylesSystemMenu.Create(AOwner: TForm);
begin
inherited Create(AOwner);
//Get an instance to the form
FForm:=AOwner;
//Init the collection to store the menu ids and callbacks
FMethodsDict:=TObjectDictionary<NativeUInt, TMethodInfo>.Create([doOwnsValues]);
//store the original WndProc
FOrgWndProc := FForm.WindowProc;
//replace the WndProc of the form
FForm.WindowProc := WndProc;
//Modify the system menu
CreateMenus;
end;
destructor TVclStylesSystemMenu.Destroy;
begin
DeleteMenus;
FForm.WindowProc := FOrgWndProc;
FMethodsDict.Free;
inherited;
end;
procedure TVclStylesSystemMenu.CreateMenus;
begin
CreateMenuStyles;
end;
procedure TVclStylesSystemMenu.DeleteMenus;
begin
if IsMenu(FVCLStylesMenu) then
while GetMenuItemCount(FVCLStylesMenu)>0 do
DeleteMenu(FVCLStylesMenu, 0, MF_BYPOSITION);
FMethodsDict.Clear;
end;
procedure TVclStylesSystemMenu.CreateMenuStyles;
var
LSysMenu : HMenu;
LMenuItem: TMenuItemInfo;
s : string;
uIDNewItem, LSubMenuIndex : Integer;
LMethodInfo : TMethodInfo;
begin
LSysMenu := GetSystemMenu(FForm.Handle, False);
LSubMenuIndex:=GetMenuItemCount(LSysMenu);
AddMenuSeparatorHelper(LSysMenu, LSubMenuIndex);
FVCLStylesMenu := CreatePopupMenu();
s:='VCL Styles';
uIDNewItem := VCLStylesMenu;
ZeroMemory(@LMenuItem, SizeOf(TMenuItemInfo));
LMenuItem.cbSize := SizeOf(TMenuItemInfo);
LMenuItem.fMask := MIIM_SUBMENU or MIIM_FTYPE or MIIM_ID or MIIM_BITMAP or MIIM_STRING;
LMenuItem.fType := MFT_STRING;
LMenuItem.wID := VCLStylesMenu;
LMenuItem.hSubMenu := FVCLStylesMenu;
LMenuItem.dwTypeData := PWideChar(s);
LMenuItem.cch := Length(s);
//Add the new menu item to the system menu
InsertMenuItem(LSysMenu, GetMenuItemCount(LSysMenu), True, LMenuItem);
inc(uIDNewItem);
LSubMenuIndex:=0;
//Iterate over the registered styles and create a new menu entry for each style
for s in TStyleManager.StyleNames do
begin
InsertMenuHelper(FVCLStylesMenu, LSubMenuIndex, uIDNewItem, PChar(s), nil);
if SameText(TStyleManager.ActiveStyle.Name, s) then
CheckMenuItem(FVCLStylesMenu, LSubMenuIndex, MF_BYPOSITION or MF_CHECKED);
inc(LSubMenuIndex);
inc(uIDNewItem);
LMethodInfo:=TMethodInfo.Create;
LMethodInfo.Value1:=s;
//set the method to execute when the item is clicked
LMethodInfo.Method:=procedure(Info : TMethodInfo)
begin
TStyleManager.SetStyle(Info.Value1.AsString);
end;
//register the menu id and the callback function.
FMethodsDict.Add(uIDNewItem-1, LMethodInfo);
end;
end;
procedure TVclStylesSystemMenu.WndProc(var Message: TMessage);
var
LVerb : NativeUInt;
begin
case Message.Msg of
//Detect when the window handle is recreated
CM_RECREATEWND: begin
DeleteMenus;
FOrgWndProc(Message);
CreateMenus;
end;
//Track the system menu calls
WM_SYSCOMMAND : begin
if FMethodsDict.ContainsKey(TWMSysCommand(Message).CmdType) then
begin
LVerb:=TWMSysCommand(Message).CmdType;
FMethodsDict.Items[LVerb].Method(FMethodsDict.Items[LVerb]);
end
else
FOrgWndProc(Message);
end
else
FOrgWndProc(Message);
end;
end;
end.
And this the result
To use this class, only you need create an new instance passing a reference to the form.
procedure TForm1.FormCreate(Sender: TObject); begin TVclStylesSystemMenu.Create(Self); end;
You can check the full source code here.



February 12, 2014 at 8:03 pm
Do you reckon you could use a similar technique to get rid of
‘Right to left encoding’, ‘Open IME’ and the other silly standard things on the default right click nowadays?
February 12, 2014 at 9:14 pm
Of course, but will require another technique (like use a hook) to get the popup menu and remove the menu items.
February 15, 2014 at 9:50 am
How can i insert the styles under a normal menu item?
eg:
MainMenu->Settings->VisualStyles->Style1, Style2 …
Thanks for sharing.
February 16, 2014 at 10:33 am
You must use the TMenuItem.Add method, for an example try the Embarcadero documentation http://docs.embarcadero.com/products/rad_studio/delphiAndcpp2009/HelpUpdate2/EN/html/delphivclwin32/Menus_TMenuItem_Add@TMenuItem.html
Pingback: A new way to select and apply a VCL Style in Ru...
March 10, 2014 at 8:58 am
Hi,
i was wondering if its possible to different styles for the same component. For exemple i have two Tspeedbutton (yes its importent to be tspeedbutton) and i want them to look differently. Is that even possible and if so then how?
Thanks for your answer in advance,
Soma Zöld
March 12, 2014 at 11:51 am
No, that is not possible. The VCL Styles are Application wide, So you cannot use different VCL Style at the same time. At least which draw the control completely.