delphi - ¿Cómo cambiar una aplicación entre temas y no temas en tiempo de ejecución?

windows-7 themes

Question

Muy parecido al CheckBox de "Proyecto | Opciones | Aplicación | Habilitar temas de tiempo de ejecución", pero de forma dinámica en el tiempo de ejecución.
[Delphi XE apuntando a Win XP o Win 7]

Intenté jugar un poco con uxTheme.SetWindowTheme sin éxito hasta ahora ...

Answer 1

Llame a SetThemeAppProperties .

Answer 2

Para uno de mis proyectos usé algo como esto:

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;

Utilice como: RemoveTheme ([Edit1.Handle, Edit2.Handle]);

Answer 3

Solo para complementar la respuesta de Rob Kennedy, debe usar SetThemeAppProperties de esta manera.

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;

y para determinar si sus controles son temáticos o no, puede usar la función GetThemeAppProperties .

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

ACTUALIZAR

Debido a los problemas descritos para usted, UseThemes el código de la unidad UxTheme y veo que el problema está relacionado con la función UseThemes . así que escribí este pequeño parche (usando las funciones para parchear HookProc , UnHookProc y GetActualAddr desarrollado por Andreas Hausladen), que funciona bien en mis pruebas. hazme saber si funciona para ti también.

debe incluir el PatchUxTheme en su lista de usos. y llamar a las funciones EnableThemesApp y 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.