// codename: real windows theme usage - Class
// author: KodeZwerg with alot of help from Delphi-Praxis, best Delphi forum ever!
// uses Mahdi Safsafi GetImmersiveColorFromColorSetEx port to delphi (MIT licence)
//
// this work in here is free of any license. use at own risk.
// disable runtime themes at manifest, else = you will see.... :-)
//
// enjoy!
{$IF !defined(MSWINDOWS)}
{$MESSAGE ERROR 'This unit is made for Windows only!'}
{$ENDIF MSWindows}
unit kzTheming;
{$ALIGN ON}
{$ALIGN 4}
interface
uses
Winapi.Windows,
Winapi.Wincodec,
System.SysUtils, System.Classes, System.Win.Registry, System.Rtti,
Vcl.Graphics,
Vcl.Forms,
uImmersiveColors;
type
TkzTheme = (ThemeNone, ThemeDarkLight, ThemeSystem, ThemeWallpaper);
TkzDwm = (DwmNone, DwmTransparent, DwmBlur);
{ $REGION 'Documentation' }
/// <summary><para>The Theming support class.</para></summary>
/// <remarks><para>Use this class with Create(Self) constructor.</para></remarks>
/// <remarks><para>Example:</para></remarks>
/// <remarks><para>var kzT: TkzTheme;</para></remarks>
/// <remarks><para>begin</para></remarks>
/// <remarks><para>**kzT := TkzTheme.Create(Self);</para></remarks>
/// <remarks><para>end;</para></remarks>
{ $ENDREGION }
kzTheme =
class(TObject)
strict private
FImmersiveColors: TImmersiveColors;
FColorSet: TColorSet;
FColorBackground, FColorText: TColor;
FOldBackground, FOldFont: TColor;
FSimpleFont: Boolean;
FHasDwm: Boolean;
FUseDwm: Boolean;
FForm: TForm;
FStyleTheme: TkzTheme;
FStyleDwm: TkzDwm;
strict private
procedure SetupForm;
function IsDarkTheme: Boolean;
procedure InitColors;
// FilenameToBmp = unused ATM
function FilenameToBmp(
const AFilename:
string;
const ABmp: TBitmap): Boolean;
function GetWallpaperFilename:
String;
function IsWin10: Boolean;
function InvertColor(
const AColor: TColor): TColor;
function SimpleInvertColor(
const AColor: TColor): TColor;
function GetAvgBmpColor: TColor;
procedure SetObjectColors(AObject: TObject);
procedure ApplyColors;
function TaskbarTranslucent: Boolean;
procedure SetDwmMode(
const Mode: ShortInt);
procedure ApplyThemedColors;
procedure ApplyDesktopColors;
procedure ApplyWallpaperColors;
procedure ApplyDefaultColors;
private
FUseFormUpdate: Boolean;
procedure SetFormUpdate(
const AValue: Boolean);
procedure SetThemeStyle(
const AValue: TkzTheme);
procedure SetDwmStyle(
const AValue: TkzDwm);
procedure SetSimpleFont(
const AValue: Boolean);
function GetDwmCheck: Boolean;
function GetWallpaperCheck: Boolean;
procedure SetOnColorChanged(
const AValue: TNotifyEvent);
public
{ $REGION 'Documentation' }
/// <summary><para>Create new object.</para></summary>
/// <param name="FormName (TForm)">Enter current FormName (Self).</param>
{ $ENDREGION }
constructor Create(
const AForm: TForm);
virtual;
{ $REGION 'Documentation' }
/// <summary><para>Destroy object.</para></summary>
{ $ENDREGION }
destructor Destroy;
override;
{ $REGION 'Documentation' }
/// <summary><para>Update current content on Form.</para></summary>
{ $ENDREGION }
procedure Update;
{ $REGION 'Documentation' }
/// <summary><para>Apply System Font and Rescale Form.</para></summary>
{ $ENDREGION }
property FormUpdate: Boolean
read FUseFormUpdate
write SetFormUpdate;
{ $REGION 'Documentation' }
/// <summary><para>Choose a Theming Style!</para></summary>
/// <remarks><para>ThemeNone, ThemeDarkLight, ThemeSystem, ThemeWallpaper</para></remarks>
{ $ENDREGION }
property StyleTheme: TkzTheme
read FStyleTheme
write SetThemeStyle;
{ $REGION 'Documentation' }
/// <summary><para>Choose a DWM Style!</para></summary>
/// <remarks><para>DwmNone, DwmTransparent, DwmBlur</para></remarks>
/// <remarks><para>This feature needs Windows 10+ plus Transparent Taskbar!</para></remarks>
{ $ENDREGION }
property StyleDwm: TkzDwm
read FStyleDwm
write SetDwmStyle;
{ $REGION 'Documentation' }
/// <summary><para>Boolean to Check if system is capable of using DWM.</para></summary>
{ $ENDREGION }
property HasDwm: Boolean
read GetDwmCheck;
{ $REGION 'Documentation' }
/// <summary><para>Boolean to Check if system has a wallpaper set.</para></summary>
{ $ENDREGION }
property HasWallpaper: Boolean
read GetWallpaperCheck;
{ $REGION 'Documentation' }
/// <summary><para>Setup your own Handler when OS changes something.</para></summary>
{ $ENDREGION }
property OnColorSetChanged: TNotifyEvent
write SetOnColorChanged;
{ $REGION 'Documentation' }
/// <summary><para>If you enabled this feature, Fonts are only Black or White.</para></summary>
{ $ENDREGION }
property UseSimpleFont: Boolean
read FSimpleFont
write SetSimpleFont;
end;
AccentPolicy =
packed record
AccentState: Integer;
AccentFlags: Integer;
GradientColor: Integer;
AnimationId: Integer;
end;
TWinCompAttrData =
packed record
attribute: THandle;
pData: Pointer;
dataSize: ULONG;
end;
TWICImageHelper =
class helper
for TWICImage
function GetAverageColor: TColor;
end;
var
SetWindowCompositionAttribute:
function(Wnd: HWND;
const AttrData: TWinCompAttrData): BOOL;
stdcall =
nil;
implementation
{ kzTheme Class - Public Methods and Properties }
constructor kzTheme.Create(
const AForm: TForm);
begin
inherited Create;
FColorBackground := 0;
FColorText := 0;
FSimpleFont := False;
FHasDwm := False;
FUseDwm := False;
FForm := AForm;
FUseFormUpdate := False;
FOldBackground := FForm.Color;
FOldFont := FForm.Font.Color;
FStyleTheme := ThemeNone;
FStyleDwm := DwmNone;
InitColors;
end;
Destructor kzTheme.Destroy;
begin
FImmersiveColors.Free;
inherited Destroy;
end;
procedure kzTheme.SetFormUpdate(
const AValue: Boolean);
begin
FUseFormUpdate := AValue;
if FUseFormUpdate
then
SetupForm;
end;
procedure kzTheme.SetThemeStyle(
const AValue: TkzTheme);
begin
FStyleTheme := AValue;
case FStyleTheme
of
ThemeNone: ApplyDefaultColors;
ThemeDarkLight: ApplyThemedColors;
ThemeSystem: ApplyDesktopColors;
ThemeWallpaper: ApplyWallpaperColors;
end;
ApplyColors;
end;
procedure kzTheme.SetDwmStyle(
const AValue: TkzDwm);
begin
FStyleDwm := AValue;
if FStyleDwm <> DwmNone
then
FUseDwm := True
else
FUseDwm := False;
ApplyColors;
end;
function kzTheme.GetDwmCheck: Boolean;
begin
Result := (IsWin10
and TaskbarTranslucent);
end;
function kzTheme.GetWallpaperCheck: Boolean;
begin
Result := ('
' <> GetWallpaperFilename);
end;
procedure kzTheme.Update;
begin
case FStyleTheme
of
ThemeNone: ApplyDefaultColors;
ThemeDarkLight: ApplyThemedColors;
ThemeSystem: ApplyDesktopColors;
ThemeWallpaper: ApplyWallpaperColors;
end;
end;
procedure kzTheme.SetSimpleFont(
const AValue: Boolean);
begin
FSimpleFont := AValue;
case FStyleTheme
of
ThemeNone: ApplyDefaultColors;
ThemeDarkLight: ApplyThemedColors;
ThemeSystem: ApplyDesktopColors;
ThemeWallpaper: ApplyWallpaperColors;
end;
ApplyColors;
end;
procedure kzTheme.SetOnColorChanged(
const AValue: TNotifyEvent);
begin
FImmersiveColors.OnColorSetChanged := AValue;
end;
{ kzTheme Class - Internal Methods and Properties }
function kzTheme.InvertColor(
const AColor: TColor): TColor;
var
r, g, b: Byte;
calc: Double;
begin
r := GetRValue(AColor);
g := GetGValue(AColor);
b := GetBValue(AColor);
calc := (r / 255) * 100;
if calc < 50
then
r := r + 126
else
r := r - 126;
calc := (g / 255) * 100;
if calc < 50
then
g := g + 126
else
g := g - 126;
calc := (b / 255) * 100;
if calc < 50
then
b := b + 126
else
b := b - 126;
Result :=
RGB(r, g, b);
end;
function kzTheme.SimpleInvertColor(
const AColor: TColor): TColor;
begin
if ((GetRValue(AColor) + GetGValue(AColor) + GetBValue(AColor)) > 384)
then
Result := clBlack
else
Result := clWhite;
end;
procedure kzTheme.SetupForm;
var
OldSize: Integer;
Font: TFont;
begin
OldSize := FForm.Font.Size;
if (Screen.MessageFont.Size <> OldSize)
then
begin
Font := TFont.Create;
try
Font.Assign(Screen.MessageFont);
Font.Size := OldSize;
FForm.Font := Font;
finally
Font.Free;
end;
FForm.ScaleBy(Abs(Screen.MessageFont.Size), Abs(OldSize));
end
else
FForm.Font := Screen.MessageFont;
if FForm.BorderStyle <> bsSizeable
then
begin
if FForm.Height > Screen.WorkAreaHeight
then
FForm.ScaleBy(Screen.WorkAreaHeight, FForm.Height);
if FForm.Width > Screen.WorkAreaWidth
then
FForm.ScaleBy(Screen.WorkAreaWidth, FForm.Width);
end;
end;
function kzTheme.IsDarkTheme: Boolean;
const
KEYPATH = '
\Software\Microsoft\Windows\CurrentVersion\Themes\Personalize';
KEYNAME = '
AppsUseLightTheme';
var
LightKey: Boolean;
Registry: TRegistry;
begin
Registry := TRegistry.Create;
try
Registry.RootKey := HKEY_CURRENT_USER;
if Registry.OpenKeyReadOnly(KEYPATH)
then
begin
if Registry.ValueExists(KEYNAME)
then
LightKey := Registry.ReadBool(KEYNAME)
else
LightKey := True;
end
else
LightKey := True;
Result :=
not LightKey;
finally
Registry.Free;
end;
end;
procedure kzTheme.SetObjectColors(AObject: TObject);
const
sPropColor = '
Color';
sPropFont = '
Font';
var
Context: TRttiContext;
RType: TRttiType;
Prop: TRttiProperty;
begin
Context := TRttiContext.Create;
RType := Context.GetType(AObject.ClassType);
for Prop
in RType.GetProperties
do
begin
if Prop.
Name = sPropColor
then
Prop.SetValue(AObject, FColorBackground);
if (Prop.
Name = sPropFont)
and Prop.PropertyType.IsInstance
and Prop.PropertyType.AsInstance.MetaclassType.InheritsFrom(TFont)
then
TFont(prop.GetValue(AObject).AsObject).Color := FColorText;
end;
Context.Free;
end;
function kzTheme.FilenameToBmp(
const AFilename:
string;
const ABmp: TBitmap): Boolean;
var
wic: TWICImage;
begin
if ((
not FileExists(AFilename))
or (
nil = ABmp))
then
Exit(false);
wic := TWICImage.Create;
try
ABmp.Dormant;
ABmp.FreeImage;
ABmp.ReleaseHandle;
wic.LoadFromFile(AFilename);
ABmp.Assign(wic);
ABmp.PixelFormat := pf24bit;
Result := Assigned(ABmp);
finally
wic.Free;
end;
end;
function kzTheme.IsWin10: Boolean;
begin
Result := CheckWin32Version(10, 0);
end;
function kzTheme.GetWallpaperFilename:
String;
function GetTranscodedImageCache: WideString;
const
CDataValue:
string = '
TranscodedImageCache';
CKeyName:
string = '
Control Panel\Desktop\';
var
regist: TRegistry;
KeyExists: Boolean;
vSize, i: Integer;
tmpStr: WideString;
begin
Result := '
';
regist := TRegistry.Create(KEY_READ);
try
regist.Access := KEY_READ;
regist.RootKey := HKEY_CURRENT_USER;
try
KeyExists := regist.OpenKey(CKeyName, false);
if (KeyExists)
then
begin
vSize := regist.GetDataSize(CDataValue);
if (vSize > 0)
then
begin
tmpStr := '
';
SetLength(tmpStr, vSize
div 2);
regist.ReadBinaryData(CDataValue, tmpStr[1], vSize);
Delete(tmpStr, 1, 12);
for i := 1
to (length(tmpStr) - 1)
do
if ((tmpStr[i] = WideChar(#0))
and (tmpStr[i + 1] = WideChar(#0)))
then
begin
Delete(tmpStr, i, length(tmpStr));
Break;
end;
Result := tmpStr;
end;
regist.CloseKey;
end;
except
regist.CloseKey;
end
finally
regist.Free;
end;
end;
function GetWallpaperBitmap:
String;
var
wpFName:
array [0 .. MAX_PATH]
of Char;
begin
if SystemParametersInfo(SPI_GETDESKWALLPAPER, MAX_PATH, @wpFName, 0)
then
Result :=
String(wpFName)
else
Result := '
';
end;
var
tmpStr:
String;
begin
tmpStr := GetWallpaperBitmap;
if (Pos('
transcodedwallpaper', LowerCase(tmpStr)) > 0)
then
Result := GetTranscodedImageCache
else
Result := tmpStr;
end;
function kzTheme.GetAvgBmpColor: TColor;
var
Filename:
string;
wic: TWICImage;
begin
Result := 0;
Filename := GetWallpaperFilename;
if not FileExists(Filename)
then
Exit;
wic := TWICImage.Create;
try
wic.LoadFromFile(Filename);
Result := wic.GetAverageColor;
finally
wic.Free;
end;
end;
function TWICImageHelper.GetAverageColor: TColor;
type
// copy from Vcl.Graphics
PRGBTripleArray = ^TRGBTripleArray;
TRGBTripleArray =
array [Byte]
of Winapi.Windows.TRGBTriple;
PRGBQuadArray = ^TRGBQuadArray;
TRGBQuadArray =
array [Byte]
of Winapi.Windows.TRGBQuad;
var
LWicBitmap: IWICBitmapSource;
Stride: Cardinal;
Buffer:
array of Byte;
BGRAPixel: TRGBQuad;
x, y, r, g, b, Resolution, LBytesPerScanline: UInt64;
ScanLinePtr: Pointer;
begin
Result := 0;
with Self
do
begin
if FWicBitmap =
nil then
Exit;
FWicBitmap.GetSize(FWidth, FHeight);
Stride := FWidth * 4;
SetLength(Buffer, Stride * FHeight);
WICConvertBitmapSource(GUID_WICPixelFormat32bppBGRA, FWicBitmap,
LWicBitmap);
LWicBitmap.CopyPixels(
nil, Stride, length(Buffer), @Buffer[0]);
r := 0;
g := 0;
b := 0;
LBytesPerScanline := BytesPerScanline(FWidth, 32, 32);
for y := 0
to FHeight - 1
do
begin
ScanLinePtr := PByte(@Buffer[0]) + y * LBytesPerScanline;
for x := 0
to FWidth - 1
do
begin
BGRAPixel := PRGBQuadArray(ScanLinePtr)^[x];
r := r + BGRAPixel.rgbRed;
g := g + BGRAPixel.rgbGreen;
b := b + BGRAPixel.rgbBlue;
end;
end;
Resolution := FWidth * FHeight;
end;
r := r
div Resolution;
g := g
div Resolution;
b := b
div Resolution;
Result :=
RGB(r, g, b);
end;
procedure kzTheme.ApplyThemedColors;
begin
if IsDarkTheme
then
begin
FColorBackground := FColorSet.Colors
[ImmersiveApplicationBackgroundDarkTheme];
if FSimpleFont
then
FColorText := SimpleInvertColor(FColorBackground)
else
FColorText := FColorSet.Colors[ImmersiveApplicationTextDarkTheme];
end
else
begin
FColorBackground := FColorSet.Colors
[ImmersiveApplicationBackgroundLightTheme];
if FSimpleFont
then
FColorText := SimpleInvertColor(FColorBackground)
else
FColorText := FColorSet.Colors[ImmersiveApplicationTextLightTheme];
end;
ApplyColors;
end;
procedure kzTheme.ApplyDesktopColors;
begin
FColorBackground := GetSysColor(COLOR_DESKTOP);
if FSimpleFont
then
FColorText := SimpleInvertColor(FColorBackground)
else
FColorText := InvertColor(FColorBackground);
ApplyColors;
end;
procedure kzTheme.ApplyWallpaperColors;
begin
FColorBackground := GetAvgBmpColor;
if FSimpleFont
then
FColorText := SimpleInvertColor(FColorBackground)
else
FColorText := InvertColor(FColorBackground);
ApplyColors;
end;
procedure kzTheme.ApplyDefaultColors;
begin
FColorBackground := FOldBackground;
FColorText := FOldFont;
ApplyColors;
end;
procedure kzTheme.ApplyColors;
var
i: Integer;
begin
FHasDwm := (IsWin10
and TaskbarTranslucent);
FForm.Color := FColorBackground;
FForm.Font.Color := FColorText;
for i := 0
to Pred(FForm.ComponentCount)
do
SetObjectColors(FForm.Components[i]);
if (FHasDwm
and FUseDwm)
then
begin
SetDwmMode(0);
if StyleDwm = DwmTransparent
then
SetDwmMode(2);
if StyleDwm = DwmBlur
then
SetDwmMode(3);
end
else
SetDwmMode(0);
end;
function kzTheme.TaskbarTranslucent: Boolean;
var
reg: TRegistry;
begin
Result := false;
reg := TRegistry.Create;
try
reg.RootKey := HKEY_CURRENT_USER;
reg.OpenKeyReadOnly
('
SOFTWARE\Microsoft\Windows\CurrentVersion\Themes\Personalize');
try
if reg.ReadInteger('
EnableTransparency') = 1
then
Result := True;
except
Result := false;
end;
reg.CloseKey;
finally
reg.Free;
end;
end;
procedure kzTheme.SetDwmMode(
const Mode: ShortInt);
const
WCA_ACCENT_POLICY = 19;
ACCENT_DISABLE = 0;
ACCENT_ENABLE_GRADIENT = 1;
ACCENT_ENABLE_TRANSPARENT = 2;
ACCENT_ENABLE_BLURBEHIND = 3;
GRADIENT_COLOR = $01000000;
DrawLeftBorder = $20;
DrawTopBorder = $40;
DrawRightBorder = $80;
DrawBottomBorder = $100;
var
dwm10: THandle;
data: TWinCompAttrData;
accent: AccentPolicy;
begin
if Mode = 1
then
Exit;
dwm10 := LoadLibrary(user32);
try
@SetWindowCompositionAttribute :=
GetProcAddress(dwm10, '
SetWindowCompositionAttribute');
if @SetWindowCompositionAttribute <>
nil then
begin
accent.AccentState := Mode;
accent.AccentFlags := DrawLeftBorder
or DrawTopBorder
or
DrawRightBorder
or DrawBottomBorder;
if ((FStyleTheme = ThemeSystem)
or (FStyleTheme = ThemeWallpaper))
then
accent.GradientColor := FColorBackground;
data.attribute := WCA_ACCENT_POLICY;
data.dataSize := SizeOf(accent);
data.pData := @accent;
SetWindowCompositionAttribute(FForm.Handle, data);
end;
finally
FreeLibrary(dwm10);
end;
end;
procedure kzTheme.InitColors;
begin
FImmersiveColors := TImmersiveColors.Create;
FColorSet := FImmersiveColors.ActiveColorSet;
end;
initialization
SetWindowCompositionAttribute := GetProcAddress(GetModuleHandle(user32),
'
SetWindowCompositionAttribute');
end.