Delphi中使用CreatePopupMenu实现跟随系统深色模式菜单失败求助

问题概述 #

使用Delphi的CreatePopupMenu创建菜单时，无法跟随Windows「个性化→颜色」的深色模式设置，尝试过SetWindowTheme调用和自定义setDarkMode过程均未生效，需要实现与桌面右键菜单一致的深色效果。

已尝试的无效方法 #

方法1：错误的SetWindowTheme调用 #

HAll := CreatePopupMenu; 
SetWindowTheme(HAll, 'Dark Mode Explorer', nil);

方法2：自定义setDarkMode过程 #

procedure setDarkMode(hnd:HWND);
var
  hNTDLL, hUxtheme: HMODULE;
  RtlGetNtVersionNumbers: function(var major, minor, buildNumber: DWORD): BOOL; stdcall;
  AllowDarkModeForApp: function(allow: Boolean): Boolean; stdcall;
  SetPreferredAppMode: function(appMode: WORD): Word stdcall;
  AllowDarkModeForWindow : function (Had: hWnd; allow:Boolean):Boolean stdcall;
  FlushMenuThemes: procedure(); stdcall;
  major, minor, buildNumber: DWORD;
  Ret:Integer;
begin
  hNTDLL := GetModuleHandle('ntdll.dll');
  if hNTDLL <> 0 then
  begin
    @RtlGetNtVersionNumbers := GetProcAddress(hNTDLL, 'RtlGetNtVersionNumbers');
    if Assigned(RtlGetNtVersionNumbers) then
    begin
      RtlGetNtVersionNumbers(major, minor, buildNumber);
      buildNumber := buildNumber and not $F0000000;
      if (major >= 10) and ((buildNumber = 17763) or (buildNumber = 18362) or (buildNumber = 18363) or
        (buildNumber = 19041) or (buildNumber >= 19042)) then
      begin
        hUxtheme := LoadLibraryEx('uxtheme.dll', 0, $00000800);
        @FlushMenuThemes := GetProcAddress(hUxtheme, MAKEINTRESOURCEA(136));
        if hUxtheme <> 0 then
        begin
          if buildNumber < 18362 then
          begin
            @AllowDarkModeForApp := GetProcAddress(hUxtheme, MAKEINTRESOURCEA(135));
            if Assigned(AllowDarkModeForApp) then
              AllowDarkModeForApp(True);
          end
          else
          begin
            @AllowDarkModeForWindow := GetProcAddress(hUxtheme, MAKEINTRESOURCEA(133));
            @SetPreferredAppMode := GetProcAddress(hUxtheme, MAKEINTRESOURCEA(135));
            if Assigned(AllowDarkModeForWindow) then
              AllowDarkModeForWindow(hnd,True);
            if Assigned(SetPreferredAppMode) then
              SetPreferredAppMode(2);
            Ret:=GetLastError;
          end;
          FlushMenuThemes;
          FreeLibrary(hUxtheme);
        end;
      end;
    end;
  end;
end;

有效解决方案 #

要复刻桌面右键菜单的深色效果，需从主题设置、系统配置、消息处理三个方面调整：

1. 正确设置菜单窗口主题 #

桌面右键菜单使用的系统主题标识是'Explorer'，修正SetWindowTheme调用：

HAll := CreatePopupMenu;
SetWindowTheme(HAll, 'Explorer', nil);

2. 配置应用清单支持深色模式 #

在Windows 10 1809及以上版本，需在应用的manifest文件中添加配置，声明应用支持深色模式：

<application xmlns="urn:schemas-microsoft-com:asm.v3">
  <windowsSettings>
    <AppCompatFlags xmlns="urn:schemas-microsoft-com:compatibility.v1">
      <AppCompatFlag Name="DisableDarkModeOptOut" />
    </AppCompatFlags>
    <PreferredAppMode xmlns="http://schemas.microsoft.com/SMI/2017/WindowsSettings">AllowDark</PreferredAppMode>
  </windowsSettings>
</application>

3. 处理系统主题切换的消息通知 #

当用户切换系统颜色模式时，窗口会收到WM_SETTINGCHANGE消息，需在菜单所属窗口的消息处理中刷新菜单主题：

procedure TForm1.WMSettingChange(var Msg: TWMSettingChange);
var
  hUxtheme: HMODULE;
  FlushMenuThemes: procedure(); stdcall;
begin
  inherited;
  // 检测主题相关设置变更
  if (Msg.Setting = SPI_SETDESKWALLPAPER) or (Msg.Setting = SPI_GETICONTHEME) then
  begin
    if Assigned(HAll) then
    begin
      SetWindowTheme(HAll, 'Explorer', nil);
      // 刷新菜单主题
      hUxtheme := LoadLibrary('uxtheme.dll');
      if hUxtheme <> 0 then
      begin
        @FlushMenuThemes := GetProcAddress(hUxtheme, MAKEINTRESOURCEA(136));
        if Assigned(FlushMenuThemes) then
          FlushMenuThemes;
        FreeLibrary(hUxtheme);
      end;
    end;
  end;
end;

4. 修正setDarkMode过程的核心逻辑 #

原过程中SetPreferredAppMode(2)是强制深色，若要跟随系统设置，应改为SetPreferredAppMode(1)，同时确保函数调用顺序正确：

procedure setDarkMode(hnd: HWND);
var
  hNTDLL, hUxtheme: HMODULE;
  RtlGetNtVersionNumbers: function(var major, minor, buildNumber: DWORD): BOOL; stdcall;
  AllowDarkModeForApp: function(allow: Boolean): Boolean; stdcall;
  SetPreferredAppMode: function(appMode: WORD): Word stdcall;
  AllowDarkModeForWindow: function(Had: HWND; allow: Boolean): Boolean; stdcall;
  FlushMenuThemes: procedure(); stdcall;
  major, minor, buildNumber: DWORD;
begin
  hNTDLL := GetModuleHandle('ntdll.dll');
  if hNTDLL = 0 then Exit;

  @RtlGetNtVersionNumbers := GetProcAddress(hNTDLL, 'RtlGetNtVersionNumbers');
  if not Assigned(RtlGetNtVersionNumbers) then Exit;

  RtlGetNtVersionNumbers(major, minor, buildNumber);
  buildNumber := buildNumber and not $F0000000;

  // 仅支持Windows 10 17763及以上版本
  if (major >= 10) and (buildNumber >= 17763) then
  begin
    hUxtheme := LoadLibraryEx('uxtheme.dll', 0, $00000800);
    if hUxtheme = 0 then Exit;

    @FlushMenuThemes := GetProcAddress(hUxtheme, MAKEINTRESOURCEA(136));

    if buildNumber < 18362 then
    begin
      @AllowDarkModeForApp := GetProcAddress(hUxtheme, MAKEINTRESOURCEA(135));
      if Assigned(AllowDarkModeForApp) then
        AllowDarkModeForApp(True);
    end
    else
    begin
      @AllowDarkModeForWindow := GetProcAddress(hUxtheme, MAKEINTRESOURCEA(133));
      @SetPreferredAppMode := GetProcAddress(hUxtheme, MAKEINTRESOURCEA(135));
      
      // 设置为跟随系统主题
      if Assigned(SetPreferredAppMode) then
        SetPreferredAppMode(1); // 1 = 跟随系统，2=强制深色，0=强制浅色
      
      if Assigned(AllowDarkModeForWindow) then
        AllowDarkModeForWindow(hnd, True);
    end;

    if Assigned(FlushMenuThemes) then
      FlushMenuThemes;

    FreeLibrary(hUxtheme);
  end;
end;

内容的提问来源于stack exchange，提问作者坦克兵