source: trunk/Packages/Common/Theme.pas

unit Theme;

interface

uses
  Classes, SysUtils, Graphics, ComCtrls, Controls, ExtCtrls, Menus, StdCtrls,
  Spin, Forms, Generics.Collections, Grids, Registry, LCLType;

type
  TTheme = class
    Name: string;
    ColorWindow: TColor;
    ColorWindowText: TColor;
    ColorControl: TColor;
    ColorControlText: TColor;
    ColorControlSelected: TColor;
  end;

  { TThemes }

  TThemes = class(TObjectList<TTheme>)
    function AddNew(Name: string): TTheme;
    function FindByName(Name: string): TTheme;
    procedure LoadToStrings(Strings: TStrings);
  end;

  TDwmSetWindowAttribute = function(hwnd: HWND; dwAttribute: DWORD; pvAttribute: Pointer; cbAttribute: DWORD): HRESULT; stdcall;

  { TThemeManager }

  TThemeManager = class(TComponent)
  private
    FTheme: TTheme;
    FActualTheme: TTheme;
    DwmapiLib: TLibHandle;
    DwmSetWindowAttribute: TDwmSetWindowAttribute;
    function Gray(C: TColor): Byte;
    procedure SetTheme(AValue: TTheme);
    procedure SetThemeName(Name: string);
    procedure SetThemedTitleBar(AForm: TForm; Active: Bool);
    function IsWindows10OrGreater(BuildNumber: Integer): Boolean;
  public
    Used: Boolean;
    Themes: TThemes;
    function IsDarkTheme: Boolean;
    procedure ApplyTheme(Component: TComponent);
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure UseTheme(Form: TForm);
    property Theme: TTheme read FTheme write SetTheme;
    property ActualTheme: TTheme read FActualTheme;
  end;

const
  ThemeNameSystem = 'System';
  ThemeNameLight = 'Light';
  ThemeNameDark = 'Dark';
  DwmapiLibName = 'dwmapi.dll';
  DWMWA_USE_IMMERSIVE_DARK_MODE_BEFORE_20H1 = 19;
  DWMWA_USE_IMMERSIVE_DARK_MODE = 20;

procedure Register;


implementation

{ TThemes }

procedure Register;
begin
  RegisterComponents('Common', [TThemeManager]);
end;

function TThemes.AddNew(Name: string): TTheme;
begin
  Result := TTheme.Create;
  Result.Name := Name;
  Add(Result);
end;

function TThemes.FindByName(Name: string): TTheme;
var
  Theme: TTheme;
begin
  Result := nil;
  for Theme in Self do
    if Theme.Name = Name then begin
      Result := Theme;
      Exit;
    end;
end;

procedure TThemes.LoadToStrings(Strings: TStrings);
var
  I: Integer;
begin
  Strings.BeginUpdate;
  try
    while Strings.Count < Count do Strings.Add('');
    while Strings.Count > Count do Strings.Delete(Strings.Count - 1);
    for I := 0 to Count - 1 do begin
      Strings[I] := Items[I].Name;
      Strings.Objects[I] := Items[I];
    end;
  finally
    Strings.EndUpdate;
  end;
end;

{ TThemeManager }

function TThemeManager.Gray(C: TColor): Byte;
begin
  Result := Trunc(Red(C) * 0.3 + Green(C) * 0.59 + Blue(C) * 0.11);
end;

function TThemeManager.IsDarkTheme: Boolean;
{$IFDEF WINDOWS}
var
  LightKey: Boolean;
  Registry: TRegistry;
const
  KeyPath = '\Software\Microsoft\Windows\CurrentVersion\Themes\Personalize';
  KeyName = 'AppsUseLightTheme';
{$ELSE}
var
  ColorWindow: TColor;
  ColorWindowText: TColor;
{$ENDIF}
begin
  Result := False;
  {$IFDEF WINDOWS}
  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;
  {$ELSE}
  ColorWindow := ColorToRGB(clWindow);
  ColorWindowText := ColorToRGB(clWindowText);
  Result := Gray(ColorWindow) < Gray(ColorWindowText);
  {$ENDIF}
end;

procedure TThemeManager.SetThemeName(Name: string);
begin
  Theme := Themes.FindByName(Name);
end;

function TThemeManager.IsWindows10OrGreater(BuildNumber: Integer): Boolean;
begin
  {$IFDEF WINDOWS}
  Result := (Win32MajorVersion >= 10) and (Win32BuildNumber >= BuildNumber);
  {$ELSE}
  Result := False;
  {$ENDIF}
end;

procedure TThemeManager.SetThemedTitleBar(AForm: TForm; Active: Bool);
var
  Attr: DWord;
begin
  if Assigned(DwmSetWindowAttribute) and IsWindows10OrGreater(17763) then begin
    Attr := DWMWA_USE_IMMERSIVE_DARK_MODE_BEFORE_20H1;
    if IsWindows10OrGreater(18985) then Attr := DWMWA_USE_IMMERSIVE_DARK_MODE;

    DwmSetWindowAttribute(AForm.Handle, Attr, @Active, SizeOf(Active));
  end;
end;

procedure TThemeManager.SetTheme(AValue: TTheme);
begin
  if FTheme = AValue then Exit;
  FTheme := AValue;
  FActualTheme := FTheme;
  {$IFDEF WINDOWS}
  if Assigned(FTheme) and (FTheme = Themes.FindByName(ThemeNameSystem)) and IsDarkTheme then
    FActualTheme := Themes.FindByName(ThemeNameDark);
  {$ENDIF}
end;

constructor TThemeManager.Create(AOwner: TComponent);
begin
  inherited;
  {$IFDEF WINDOWS}
  DwmapiLib := LoadLibrary(DwmapiLibName);
  if DwmapiLib <> 0 then DwmSetWindowAttribute := GetProcAddress(DwmapiLib, 'DwmSetWindowAttribute')
    else DwmSetWindowAttribute := nil;
  {$ENDIF}

  Themes := TThemes.Create;
  with Themes.AddNew(ThemeNameSystem) do begin
    ColorWindow := clWindow;
    ColorWindowText := clWindowText;
    ColorControl := clMenu;
    ColorControlText := clWindowText;
    ColorControlSelected := clWindow;
  end;
  with Themes.AddNew(ThemeNameDark) do begin
    ColorWindow := RGBToColor($20, $20, $20);
    ColorWindowText := clWhite;
    ColorControl := RGBToColor($40, $40, $40);
    ColorControlText := clWhite;
    ColorControlSelected := RGBToColor(96, 125, 155);
  end;
  with Themes.AddNew(ThemeNameLight) do begin
    ColorWindow := clWhite;
    ColorWindowText := clBlack;
    ColorControl := RGBToColor($e0, $e0, $e0);
    ColorControlText := clBlack;
    ColorControlSelected := RGBToColor(196, 225, 255);
  end;
  Theme := TTheme(Themes.First);
end;

destructor TThemeManager.Destroy;
begin
  FreeAndNil(Themes);
  {$IFDEF WINDOWS}
  if DwmapiLib <> 0 then FreeLibrary(DwmapiLib);
  {$ENDIF}
  inherited;
end;

procedure TThemeManager.ApplyTheme(Component: TComponent);
var
  Control: TControl;
  I: Integer;
begin
  if Component is TWinControl then begin
    for I := 0 to TWinControl(Component).ControlCount - 1 do
      ApplyTheme(TWinControl(Component).Controls[I]);
  end;

  if Component is TControl then begin
    Control := (Component as TControl);
    if (Control is TEdit) or (Control is TSpinEdit) or (Control is TComboBox) and
    (Control is TMemo) or (Control is TListView) or (Control is TCustomDrawGrid) or
    (Control is TCheckBox) or (Control is TPageControl) or (Control is TRadioButton) then begin
      Control.Color := FActualTheme.ColorWindow;
      Control.Font.Color := FActualTheme.ColorWindowText;
    end else begin
      Control.Color := FActualTheme.ColorControl;
      Control.Font.Color := FActualTheme.ColorControlText;
    end;

    if Control is TCustomDrawGrid then begin
      (Control as TCustomDrawGrid).Editor.Color := FActualTheme.ColorWindow;
      (Control as TCustomDrawGrid).Editor.Font.Color := FActualTheme.ColorWindowText;
    end;

    if Control is TPageControl then begin
      for I := 0 to TPageControl(Component).PageCount - 1 do
        ApplyTheme(TPageControl(Component).Pages[I]);
    end;

    if Control is TCoolBar then begin
      (Control as TCoolBar).Themed := False;
    end;
  end;
end;

procedure TThemeManager.UseTheme(Form: TForm);
begin
  if not Used and (FActualTheme.Name = ThemeNameSystem) then Exit;
  ApplyTheme(Form);
  SetThemedTitleBar(Form, FActualTheme.Name = ThemeNameDark);
  Used := True;
end;

end.