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.