如何在运行时在主题和非主题之间切换应用程序？

Question

与“项目|选项|应用程序|启用运行时主题”复选框非常相似，但是在运行时动态处理。

[Delphi XE 以 Win XP 或 Win 7 为目标]

我尝试使用 uxTheme.SetWindowTheme 进行一些调整，但迄今为止没有成功...

- Francesca

Answer 1

仅作为补充Rob Kennedy的回答，您必须以以下方式使用SetThemeAppProperties。

uses
 UxTheme;

procedure DisableThemesApp;
begin
  SetThemeAppProperties(0);
  SendMessage(Application.Handle,WM_THEMECHANGED,0,0);
  SendMessage(Application.MainForm.Handle,CM_RECREATEWND,0,0);
end;

procedure EnableThemesApp;
begin
  SetThemeAppProperties(STAP_ALLOW_NONCLIENT or STAP_ALLOW_CONTROLS or STAP_ALLOW_WEBCONTENT);
  SendMessage(Application.Handle,WM_THEMECHANGED,0,0);
  SendMessage(Application.MainForm.Handle,CM_RECREATEWND,0,0);
end;

为了确定你的控件是否应用了主题，你可以使用GetThemeAppProperties函数。

var
  Flag : DWORD;
begin
  Flag:=GetThemeAppProperties;
  if (Flag and STAP_ALLOW_CONTROLS)<>0 then //if the controls are themed
  begin

  end;
end;

更新

由于您描述的问题，我检查了 UxTheme 单元的代码，并发现问题与 UseThemes 函数有关。因此，我编写了这个小修补程序（使用 Andreas Hausladen 开发的 HookProc、UnHookProc 和 GetActualAddr 函数进行修补），在我的测试中可以正常工作。如果它对您也起作用，请让我知道。

您必须在使用列表中包含 PatchUxTheme，并调用函数 DisableThemesApp 和 EnableThemesApp。

unit PatchUxTheme;

interface


procedure EnableThemesApp;
procedure DisableThemesApp;


implementation

uses
Controls,
Forms,
Messages,
UxTheme,
Sysutils,
Windows;

type
  TJumpOfs = Integer;
  PPointer = ^Pointer;

  PXRedirCode = ^TXRedirCode;
  TXRedirCode = packed record
    Jump: Byte;
    Offset: TJumpOfs;
  end;

  PAbsoluteIndirectJmp = ^TAbsoluteIndirectJmp;
  TAbsoluteIndirectJmp = packed record
    OpCode: Word;
    Addr: PPointer;
  end;

var
 UseThemesBackup: TXRedirCode;

function GetActualAddr(Proc: Pointer): Pointer;
begin
  if Proc <> nil then
  begin
    if (Win32Platform = VER_PLATFORM_WIN32_NT) and (PAbsoluteIndirectJmp(Proc).OpCode = $25FF) then
      Result := PAbsoluteIndirectJmp(Proc).Addr^
    else
      Result := Proc;
  end
  else
    Result := nil;
end;


procedure HookProc(Proc, Dest: Pointer; var BackupCode: TXRedirCode);
var
  n: DWORD;
  Code: TXRedirCode;
begin
  Proc := GetActualAddr(Proc);
  Assert(Proc <> nil);
  if ReadProcessMemory(GetCurrentProcess, Proc, @BackupCode, SizeOf(BackupCode), n) then
  begin
    Code.Jump := $E9;
    Code.Offset := PAnsiChar(Dest) - PAnsiChar(Proc) - SizeOf(Code);
    WriteProcessMemory(GetCurrentProcess, Proc, @Code, SizeOf(Code), n);
  end;
end;

procedure UnhookProc(Proc: Pointer; var BackupCode: TXRedirCode);
var
  n: Cardinal;
begin
  if (BackupCode.Jump <> 0) and (Proc <> nil) then
  begin
    Proc := GetActualAddr(Proc);
    Assert(Proc <> nil);
    WriteProcessMemory(GetCurrentProcess, Proc, @BackupCode, SizeOf(BackupCode), n);
    BackupCode.Jump := 0;
  end;
end;

function UseThemesH:Boolean;
Var
 Flag : DWORD;
begin
  Flag:=GetThemeAppProperties;
  if ( (@IsAppThemed<>nil) and (@IsThemeActive<>nil) ) then
    Result := IsAppThemed and IsThemeActive and ((Flag and STAP_ALLOW_CONTROLS)<>0)
  else
    Result := False;
end;

procedure HookUseThemes;
begin
  HookProc(@UxTheme.UseThemes, @UseThemesH, UseThemesBackup);
end;

procedure UnHookUseThemes;
begin
  UnhookProc(@UxTheme.UseThemes, UseThemesBackup);
end;


Procedure DisableThemesApp;
begin
  SetThemeAppProperties(0);
  SendMessage(Application.Handle,WM_THEMECHANGED,0,0);
  SendMessage(Application.MainForm.Handle,CM_RECREATEWND,0,0);
end;

Procedure EnableThemesApp;
begin
  SetThemeAppProperties(STAP_ALLOW_NONCLIENT or STAP_ALLOW_CONTROLS or STAP_ALLOW_WEBCONTENT);
  SendMessage(Application.Handle,WM_THEMECHANGED,0,0);
  SendMessage(Application.MainForm.Handle,CM_RECREATEWND,0,0);
end;

initialization
 HookUseThemes;
finalization
 UnHookUseThemes;
end.

- RRUZ

---

@RRUZ。已经接近成功了，但还不够完美...使用CM_RECREATEWND肯定是必要的，才能看到任何东西（尽管我会避免使用它，因为它可能会带来对组合框、列表视图等的不良副作用）。 当移除主题时仍然存在问题，如SpeedButtons消失，PageControls在更改选项卡时未重新绘制，以及Grids显示混乱。其中一个原因可能是因为**IsAppThemed和IsThemeActive**仍然返回True，这会使VCL在尝试绘制时感到困惑... - Francesca

@François，如果您从控制面板全局更改主题设置，是否会出现类似的问题？ - Rob Kennedy

@Rob。非常好的问题。在控制面板中删除主题（切换到Windows Classic）后，情况不会那么糟糕。那种情况下唯一的问题似乎是网格单元的绘制。SpeedButtons和PageControls的行为是正确的。现在有趣的部分是，在控制面板中进行更改并在上述代码的应用程序中进行更改都可以正常工作（似乎所有人的行为都是正确的）。 - Francesca

@Rob。当我从控制面板和应用程序中关闭主题时，如果我在应用程序中重新启用首选项，那么在控制面板中主题就会回来，而如果我先在控制面板中操作，然后再在应用程序中使用代码，主题就不会回来，这更加有趣。 - Francesca

@RRUZ。看起来是一个可行的解决方案。在删除主题时，TToolBars仍然会有一些小问题，但是通过一些调整可能可以解决。它可能不是唯一的解决方案，因为它对于从控制面板中删除主题时并没有任何作用...顺便说一下，Delphi本身也处理得不太好。;-)谢谢Rodrigo（和Rob）！ - Francesca

@RRUZ 我之前一直在使用清单文件来进行主题设置，在用户启用它并重新启动程序后即可生效。但是这种方法不起作用了。我的问题是，这个方法是否替代了清单文件的做法？ - Rohit Gupta

Answer 2

调用SetThemeAppProperties函数。

- Rob Kennedy

---

嗯，似乎在我家里的D2010上无法工作。 SetThemeAppProperties（0）似乎没有任何可见效果。 IsAppThemed和IsThemeActive仍然返回True，无论是否使用WM_THEMECHANGED或调用ThemeServices.ApplyThemeChange。我明天会在Delphi XE上尝试更多... - Francesca

Answer 3

在我的一个项目中，我使用了类似这样的东西：

Procedure RemoveTheme(Const Controls : Array Of HWnd; Const Redraw : Boolean = True);
Var
  I : Integer;
Begin
  If IsAppThemed And IsThemeActive Then Try
    I := 0;
    While (I < Length(Controls)) Do Begin
      If (Controls[I] > 0) And IsWindow(Controls[I]) Then SetWindowTheme(Controls[I], '', '');
      If Redraw Then Begin
        InvalidateRect(Controls[I], Nil, True);
        UpdateWindow(Controls[I]);
      End;
      Inc(I);
    End;
  Except
  End;
End;

使用方法： RemoveTheme([Edit1.Handle, Edit2.Handle]);

- BoB

---

谢谢，但这在我的情况下不起作用。(a) 您需要递归下容器 (面板、框、选项卡/页面控件...)，(b) 非 WinControls 的控件 (如 SpeedButtons 等图形控件) 不受处理，(c) 未由应用程序定义的对话框 (windows.MessageBox...) 仍会被主题化，(d) 由 VCL 绘制的控件（如网格）会部分更改（滚动条由 Windows 更改，单元格不由 VCL 更改）。我宁愿设置一个全局标志，并告诉 Windows/主题管理器/VCL 此应用程序不使用主题。如果可能的话... - Francesca