A new way to select and apply a VCL Style in Runtime

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

[sourcecode language=”delphi”]
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.
[/sourcecode]

And this the result

To use this class, only you need create an new instance passing a reference to the form.

[sourcecode language=”delphi”]
procedure TForm1.FormCreate(Sender: TObject);
begin
TVclStylesSystemMenu.Create(Self);
end;
[/sourcecode]

You can check the full source code here.