The road to Delphi: The VCL Styles Utils Project now supports dialogs and popup menus

Two missing parts of the standard VCL Styles is the lack of the capacity to theme the popup menus and the standard Windows dialogs. I started to work a year ago in the dialogs area, but due to my limited time I was not able to finish that. But a few months ago I receive a very interesting mail from Mahdi Safsafi (SMP3) that show me his own work on this topic. So we decided merge the code of his project and the VCL Styles Utils. So finally the VCL Styles Utils project was updated to support standard dialogs, popup and system menus.

How it works?

The key is using a WH_CBT Hook, detecting the HCBT_CREATEWND and HCBT_DESTROYWND codes and then checking if the class of the window is #32770 (the class for a dialog box.) or the #32768 (the class for a popupmenu) from here you can replace the window procedure (WndProc) using the SetWindowLongPtr function with the GWL_WNDPROC index. Now we have the control of the messages sent by the windows dialogs and menus and we can iterate over the child controls and replace the window procedure again using the GWL_WNDPROC index. Finally depending of the class of the control (button, syslistview32, Combobox and so on) a Wrapper class (like the VCL does) is created to handle the messages related to the paint of the control.

Check the next source code which install the hook and process the Win32 controls

unit Vcl.Styles.SysControls;

interface

implementation

uses
  Winapi.Windows,
  System.Generics.Collections,
  System.SysUtils,
  Vcl.Controls,
  Vcl.Dialogs,
  Vcl.Styles,
  Vcl.Themes,
  Vcl.Styles.PopupWnd,
  Vcl.Styles.EditWnd,
  Vcl.Styles.StaticWnd,
  Vcl.Styles.ThemedDialog,
  Vcl.Styles.ToolbarWindow32Wnd,
  Vcl.Styles.SysListView32Wnd,
  Vcl.Styles.ButtonWnd,
  Vcl.Styles.UnknownControlWnd,
  Vcl.Styles.ControlWnd,
  Vcl.Styles.ComboBoxWnd,
  Vcl.Styles.ToolTipsWnd;

type
  TThemedSysControls = class
  private
  class var
    FBalloonHint: TBalloonHint;
    FPreviousSysBtn: Integer;
    FPreviousHandle: THandle;
    FHook: HHook;
  protected
    class function HookActionCallBack(Code: Integer; wParam: wParam;
      lParam: lParam): LRESULT; stdcall; static;
    procedure InstallHook;
    procedure RemoveHook;
  public
    constructor Create; overload;
    destructor Destroy; override;
  end;

var
  MenuItemInfoArray: array of TMenuItemInfo;
  TooltipsWndList: TObjectDictionary<HWND, TooltipsWnd>;
  PopupWndList: TObjectDictionary<HWND, TPopupWnd>;
  StaticWndList: TObjectDictionary<HWND, TStaticWnd>;
  DialogWndList: TObjectDictionary<HWND, TDialogWnd>;
  EditWndList: TObjectDictionary<HWND, TEditWnd>;
  ComboBoxWndList: TObjectDictionary<HWND, TComboBoxWnd>;
  UnknownControlList: TObjectDictionary<HWND, TUnknownControlWnd>;
  ToolbarWindow32WndList : TObjectDictionary<HWND, TToolbarWindow32Wnd>;
  SysListView32WndList : TObjectDictionary<HWND, TSysListView32Wnd>;
  BtnWndArrayList : TObjectDictionary<HWND, TButtonWnd>;
  ThemedSysControls: TThemedSysControls;

{ TThemedSysControls }

constructor TThemedSysControls.Create;
begin
  inherited;
  FBalloonHint := TBalloonHint.Create(nil);
  FBalloonHint.Style := bhsStandard;
  FBalloonHint.Delay := 1500;
  FBalloonHint.HideAfter := 3000;
  FPreviousHandle := 0;
  FHook := 0;
  InstallHook;
  PopupWndList:= TObjectDictionary<HWND, TPopupWnd>.Create([doOwnsValues]);
  TooltipsWndList:= TObjectDictionary<HWND, TooltipsWnd>.Create([doOwnsValues]);
  StaticWndList:= TObjectDictionary<HWND, TStaticWnd>.Create([doOwnsValues]);
  DialogWndList:= TObjectDictionary<HWND,TDialogWnd>.Create([doOwnsValues]);
  EditWndList:= TObjectDictionary<HWND, TEditWnd>.Create([doOwnsValues]);
  ComboBoxWndList:= TObjectDictionary<HWND, TComboBoxWnd>.Create([doOwnsValues]);
  UnknownControlList:= TObjectDictionary<HWND, TUnknownControlWnd>.Create([doOwnsValues]);
  ToolbarWindow32WndList:= TObjectDictionary<HWND, TToolbarWindow32Wnd>.Create([doOwnsValues]);
  SysListView32WndList := TObjectDictionary<HWND, TSysListView32Wnd>.Create([doOwnsValues]);
  BtnWndArrayList := TObjectDictionary<HWND, TButtonWnd>.Create([doOwnsValues]);
end;

destructor TThemedSysControls.Destroy;
begin
  RemoveHook;

  PopupWndList.Free;
  TooltipsWndList.Free;
  StaticWndList.Free;
  DialogWndList.Free;
  EditWndList.Free;
  ComboBoxWndList.Free;
  UnknownControlList.Free;
  ToolbarWindow32WndList.Free;
  SysListView32WndList.Free;
  BtnWndArrayList.Free;

  FBalloonHint.Free;
  inherited;
end;

class function TThemedSysControls.HookActionCallBack(Code: Integer;
  wParam: wParam; lParam: lParam): LRESULT;
var
  Msg: TMOUSEHOOKSTRUCT;
  C: array [0 .. 256] of Char;

  procedure HideSysToolTip;
  var
    hSysToolTip: THandle;
  begin
    For hSysToolTip := 65550 To 65600 do
      begin
        If IsWindowVisible(hSysToolTip) then
          begin
            GetClassName(hSysToolTip, C, 256);
            ShowWindow(hSysToolTip, SW_HIDE);
          end;
      end;
  end;

  procedure ShowToolTip(HintTitle: String);
  begin
    HideSysToolTip;
    if FPreviousSysBtn <> Integer(Msg.wHitTestCode) then
      begin
        FBalloonHint.HideHint;
        FBalloonHint.Title := HintTitle;
        FPreviousSysBtn := Msg.wHitTestCode;
        FBalloonHint.ShowHint(Msg.pt);
      end;
  end;

var
  CBTSturct: TCBTCreateWnd;
  sClassName : string;
begin
    if (StyleServices.Enabled) and not (StyleServices.IsSystemStyle) then
    begin
      if Code = HCBT_SYSCOMMAND then
        begin
          FBalloonHint.HideHint;
          FPreviousSysBtn := 0;
        end
      else
      if Code = HCBT_DESTROYWND then
      begin
        sClassName := GetWindowClassName(wParam);
          if sClassName = '#32768' then
          {PopupMenu}
          begin
            if PopupWndList.ContainsKey(wParam) then
              PopupWndList.Remove(wParam);
            //OutputDebugString(PChar('remove PopupWndList count '+IntToStr(PopupWndList.Count)));
          end
          else
          if sClassName = '#32770' then
          {Dialog}
          begin
            if DialogWndList.ContainsKey(wParam) then
              DialogWndList.Remove(wParam);
            //OutputDebugString(PChar('remove DialogWndList count '+IntToStr(DialogWndList.Count)));
          end
          else
          if sClassName = 'Button' then
          {Button}
          begin
            if BtnWndArrayList.ContainsKey(wParam) then
              BtnWndArrayList.Remove(wParam);
            //OutputDebugString(PChar('remove BtnWndArrayList count '+IntToStr(BtnWndArrayList.Count)));
          end
          else
          if (sClassName = 'ScrollBar') or (sClassName = 'ReBarWindow32') {or (sClassName = 'ToolbarWindow32')} then
          begin
            if UnknownControlList.ContainsKey(wParam) then
              UnknownControlList.Remove(wParam);
          end
          else
          if sClassName = 'SysListView32' then
          begin
            if SysListView32WndList.ContainsKey(wParam) then
              SysListView32WndList.Remove(wParam);
          end
          else
          if sClassName = 'ToolbarWindow32' then
          begin
            if ToolbarWindow32WndList.ContainsKey(wParam) then
              ToolbarWindow32WndList.Remove(wParam);
          end
          else
          if sClassName = 'Edit' then
          begin
            if EditWndList.ContainsKey(wParam) then
              EditWndList.Remove(wParam);
          end
          else
          if sClassName = 'Static' then
          begin
            if StaticWndList.ContainsKey(wParam) then
              StaticWndList.Remove(wParam);
          end
          else
          if sClassName = 'ComboBox' then
          begin
            if ComboBoxWndList.ContainsKey(wParam) then
              ComboBoxWndList.Remove(wParam);
          end
          else
          if sClassName = 'tooltips_class32' then
          begin
            if TooltipsWndList.ContainsKey(wParam) then
              TooltipsWndList.Remove(wParam);
          end
      end
      else
      if Code = HCBT_CREATEWND then
        begin
          CBTSturct := PCBTCreateWnd(lParam)^;
          sClassName := GetWindowClassName(wParam);
          //PopupMenu
          if Integer(CBTSturct.lpcs.lpszClass) = 32768 then
              PopupWndList.Add(wParam, TPopupWnd.Create(wParam))
          else
          //Dialog
          if Integer(CBTSturct.lpcs.lpszClass) = 32770 then
            begin
              if (CBTSturct.lpcs.cx <> 0) and (CBTSturct.lpcs.cy <> 0) then
                DialogWndList.Add(wParam, TDialogWnd.Create(wParam))
            end
          else
          if sClassName = 'Button' then
              BtnWndArrayList.Add(wParam, TButtonWnd.Create(wParam))
          else
          if (sClassName = 'ScrollBar') or (sClassName = 'ReBarWindow32') {or (sClassName = 'ToolbarWindow32')} then
              UnknownControlList.Add(wParam, TUnknownControlWnd.Create(wParam))
          else
          if sClassName = 'SysListView32' then
              SysListView32WndList.Add(wParam, TSysListView32Wnd.Create(wParam))
          else
          if sClassName = 'ToolbarWindow32' then
            begin
              if not UseLatestCommonDialogs then
                ToolbarWindow32WndList.Add(wParam, TToolbarWindow32Wnd.Create(wParam));
            end
          else
          if sClassName = 'Edit' then
              EditWndList.Add(wParam, TEditWnd.Create(wParam))
          else
          if sClassName = 'Static' then
            begin
              { This condition can solve the Edit animated cursor : see ColorDialog !! }
              if (CBTSturct.lpcs.Style and SS_ICON <> SS_ICON) and
                (CBTSturct.lpcs.Style and SS_BITMAP <> SS_BITMAP) and
                (CBTSturct.lpcs.Style and SS_GRAYRECT <> SS_GRAYRECT) and
                (CBTSturct.lpcs.Style and SS_GRAYFRAME <> SS_GRAYFRAME) then
                  StaticWndList.Add(wParam, TStaticWnd.Create(wParam));
            end
          else
          if sClassName = 'ComboBox' then
            ComboBoxWndList.Add(wParam, TComboBoxWnd.Create(wParam))
          else
          if sClassName = 'tooltips_class32' then
            TooltipsWndList.Add(wParam, TooltipsWnd.Create(wParam))
        end
    end;
  Result := CallNextHookEx(FHook, Code, wParam, lParam);
end;

procedure TThemedSysControls.InstallHook;
begin
  FHook := SetWindowsHookEx(WH_CBT, @TThemedSysControls.HookActionCallBack, 0, GetCurrentThreadId);
end;

procedure TThemedSysControls.RemoveHook;
begin
  if FHook <> 0 then
    UnhookWindowsHookEx(FHook);
end;

initialization

  ThemedSysControls:=nil;
  if StyleServices.Available then
    ThemedSysControls := TThemedSysControls.Create;

finalization

if Assigned(ThemedSysControls) then
    ThemedSysControls.Free;


end.

Menus

Standard TMainMenu with VCL Styles Enabled.

using the Vcl.Styles.SysControls unit

SysMenu with VCL Styles Enabled.

using the Vcl.Styles.SysControls unit

System menu with VCL Styles Enabled.

System menu using the Vcl.Styles.SysControls unit

Dialogs

Open Dialog With VCL Styles enabled

Open Dialog using the Vcl.Styles.SysControls unit

Even the shell menu inside of the dialog is themed

Others Dialogs

You can activate this functionality in your apps just adding the Vcl.Styles.SysControls unit to your project. Also a new sample project was added to test all the new features.

As always all your comments and suggestions are welcome.