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

非常类似于“项目|选项|应用程序|启用运行时主题”复选框，但在运行时动态启用。
[Delphi XE针对Win XP或Win 7]

---

我尝试过使用uxTheme.SetWindowTheme，但迄今为止没有成功。

调用。

在我的一个项目中，我使用了如下内容：

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;

Procedure RemoveTheme（常量控件：HWnd数组；常量重画：布尔值=True）；
变量
I：整数；
开始
如果是应用主题且是反应性的，则尝试
I:=0；
当（I<长度（控制））开始时
如果（控件[I]>0）和IsWindow（控件[I]），则设置WindowTheme（控件[I]，“”）；
如果重新绘制，则开始
无效（对照[I]，无，真）；
更新窗口（控件[I]）；
结束；
公司（一）；
结束；
除了
结束；
结束；

使用类似于：

---

去除血红素（[Edit1.Handle，Edit2.Handle]）

为了补充Rob Kennedy的答案，您必须以这种方式使用

设置EAPProperties

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;

要确定控件是否主题化，可以使用该函数

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

  end;
end;

---

嗯，我的D2010在家里似乎不起作用

SetThemeAppProperties（0）

似乎没有任何可见的效果

已应用主题，并且IsThemeActive

仍然返回带或不带

WM\u更改的
True
或调用
电子服务。ApplyThemeChange
。明天我会和德尔福一起在工作中尝试更多…@RRUZ。正在到达那里，但还没有完全到达。。。CM_RecreatWnd绝对需要看到任何东西（尽管我会避免它，因为它会给组合、列表视图带来令人讨厌的副作用…）。当删除主题时仍然存在问题，速度按钮消失，页面控件在更改选项卡时没有重新绘制，网格显示混乱。原因之一可能是，
IsAppThemed和IsThemeActive
仍然返回
True
，这会在尝试绘制时混淆VCL…@François，如果从控制面板全局更改主题设置，您是否会看到类似问题？@Rob。很好的问题。在删除控制面板中的主题（到Windows Classic）时，情况并没有那么糟。在这种情况下唯一的问题似乎是网格单元的绘制。SpeedButtons和PageControl功能正常。现在有趣的是，用上面的代码在控制面板和应用程序中进行更改可以正常工作（每个人似乎都表现良好）。@Rob。更有趣的是，当我从“控制面板”和“带有代码的应用程序”中关闭主题时，如果我先在“应用程序”中重新启用，然后在“控制面板”中重新启用，则主题会返回，而如果我先在“控制面板”中启用，然后在“应用程序”中使用代码，则主题不会返回。@RRUZ。这似乎是一个可行的解决办法。删除主题后，TToolbar仍有一点行为不端，但一些修改可能会修复它。不过，这可能不是解决方案，因为当您从控制面板中删除主题时，它不起任何作用。。。顺便说一句，德尔福本身也处理得不好谢谢罗德里戈（和罗布）！谢谢，但对我来说不行。（a） 您需要递归下容器（面板、框、选项卡/页面控件…），（b）不处理非WinControl的控件（图形控件，如SpeedButtons…），（c）应用程序未定义的对话框（windows.MessageBox…）无论如何都会主题化，（d）由类似VCL的网格绘制的控件会部分更改（滚动条由Windows更改，单元格不由VCL更改）。我宁愿设置一个全局标志，并告诉Windows/主题管理器/VCL此应用程序没有主题。如果可能的话。。。。
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.