KodeZwerg's Real Theme Beispiel

[KodeZwerg]

Halli hallo liebe Entwicker-Freunde!

Nun ist es soweit, drei Fragen hatte ich gestellt, drei Fragen wurden im besten Delphi Forum aller Zeit beantwortet! Dafür möchte ich mich hier noch mal bedanken!

Für die ganz eifrigen, im Anhang ist das gesamte Quelltext Verzeichnis plus Kompilat zum sofort runterladen/testen archiviert.
Der Quelltext ist noch sehr unaufgeräumt (alles in einer einzigen unit meinerseits), dafür entschuldige ich mich hier schon mal vorweg. Aber zum ausprobieren und schnell hin und her hüpfen im code ist es einfacher für mich so
Umgeschrieben und angefangen aufzuräumen, nun ist es eine Klasse die man sehr simpel ansprechen kann.

Wenn es sich nicht kompilieren/öffnen lässt, bitte die .dproj datei löschen und erneut versuchen, runtime themes müssen deaktiviert sein damit es seinen momentanen Zweck erfüllt!

Geschrieben wurde es unter Delphi 10.3 (Rio), mir ist unbekannt mit welchen anderen Versionen es funktioniert, versuch macht klug.

Worum geht es?
Ich fand die Einführung der Vcl-Styles wirklich bemerkenswert, es sieht alles schön aus, soviel vorweg. Was macht nun dieses Projekt anders?
- Ich nutze von Mahdi Safsafi seine ImmersiveColors unit um Dark bzw Light theming zu praktizieren, im extrem simplen Umfang erstmal. (MIT Lizenz)
- Ich nutze von Windows den personalisierten Farbwert (c) by you.
- Ich nutze vom Desktop das Wallpaper um einen Farbwert zu berechnen, TiGü mein Held!
- Ich biete vom DWM 2 Modi an, Transparent und Blur
Das sind die drei ??? die hoffentlich nun gelöst sind.

Für weitere Verbesserungen, Vorschläge und wie man es hinbekommt das auch runtime themes aktiviert sein können, das sind Dinge die mir am Herzen liegen.
Der Quelltext ist noch nicht refactored, lediglich auf seine Funktionalität getestet.

Nun gehts los, haltet Euch fest

Demo-Anwendung:

Delphi-Quellcode:

// codename: real windows theme usage - Demo
// 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!

unit uMain;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, Winapi.ShellAPI,
  System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.ExtCtrls, Vcl.StdCtrls, Vcl.Buttons,
  kzTheming;

type
  TfrmMain = class(TForm)
    Label1: TLabel;
    Edit1: TEdit;
    Button1: TButton;
    cbNoEdit: TCheckBox;
    Panel1: TPanel;
    RadioGroup1: TRadioGroup;
    rbOS: TRadioButton;
    rbSystem: TRadioButton;
    BitBtn1: TBitBtn;
    SpeedButton1: TSpeedButton;
    rbNone: TRadioButton;
    cbNoButton: TCheckBox;
    rbWallpaper: TRadioButton;
    cbSimpleFont: TCheckBox;
    ListBox1: TListBox;
    Panel2: TPanel;
    Panel3: TPanel;
    cbDwm: TCheckBox;
    rbTransparent: TRadioButton;
    rbBlur: TRadioButton;
    Image1: TImage;
    Label2: TLabel;
    procedure FormCreate(Sender: TObject);
    procedure rbOSClick(Sender: TObject);
    procedure rbSystemClick(Sender: TObject);
    procedure rbNoneClick(Sender: TObject);
    procedure cbNoEditClick(Sender: TObject);
    procedure cbNoButtonClick(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure rbWallpaperClick(Sender: TObject);
    procedure cbSimpleFontClick(Sender: TObject);
    procedure cbDwmClick(Sender: TObject);
    procedure rbTransparentClick(Sender: TObject);
    procedure rbBlurClick(Sender: TObject);
    procedure Image1Click(Sender: TObject);
    procedure Image1MouseEnter(Sender: TObject);
    procedure Image1MouseLeave(Sender: TObject);
  private
    MyTheme: kzTheme;
    procedure ColorSetChanged(Sender: TObject);
  public
  end;

var
  frmMain: TfrmMain;

implementation

{$R *.dfm}

procedure TfrmMain.rbOSClick(Sender: TObject);
begin
  cbDwm.Enabled := MyTheme.HasDwm;
  MyTheme.StyleTheme := ThemeDarkLight;
end;

procedure TfrmMain.rbSystemClick(Sender: TObject);
begin
  cbDwm.Enabled := MyTheme.HasDwm;
  MyTheme.StyleTheme := ThemeSystem;
end;

procedure TfrmMain.rbWallpaperClick(Sender: TObject);
begin
  cbDwm.Enabled := MyTheme.HasDwm;
  MyTheme.StyleTheme := ThemeWallpaper;
end;

procedure TfrmMain.rbNoneClick(Sender: TObject);
begin
  if (cbDWM.Enabled and cbDWM.Checked) then
  begin
    cbDWM.Checked := false;
    cbDWM.Enabled := false;
    MyTheme.StyleDwm := DwmNone;
  end;
  MyTheme.StyleTheme := ThemeNone;
end;

procedure TfrmMain.rbTransparentClick(Sender: TObject);
begin
  if cbDWM.Checked then
  begin
    MyTheme.StyleDwm := DwmNone;
    MyTheme.StyleDwm := DwmTransparent;
  end;
end;

procedure TfrmMain.rbBlurClick(Sender: TObject);
begin
  if cbDWM.Checked then
    MyTheme.StyleDwm := DwmBlur;
end;

procedure TfrmMain.cbNoEditClick(Sender: TObject);
begin
  Edit1.Enabled := not cbNoEdit.Checked;
end;

procedure TfrmMain.cbSimpleFontClick(Sender: TObject);
begin
  if rbOS.Checked then
    rbOSClick(Sender);
  if rbSystem.Checked then
    rbSystemClick(Sender);
  if rbWallpaper.Checked then
    rbWallpaperClick(Sender);
  if rbNone.Checked then
    rbNoneClick(Sender);
  MyTheme.UseSimpleFont := cbSimpleFont.Checked;
end;

procedure TfrmMain.cbNoButtonClick(Sender: TObject);
begin
  Button1.Enabled := not cbNoButton.Checked;
  BitBtn1.Enabled := not cbNoButton.Checked;
  SpeedButton1.Enabled := not cbNoButton.Checked;
end;

procedure TfrmMain.cbDwmClick(Sender: TObject);
begin
  cbDWM.Enabled := MyTheme.HasDwm;
  if ((cbDWM.Enabled) and (cbDWM.Checked)) then
  begin
    if rbTransparent.Checked then
    begin
      MyTheme.StyleDwm := DwmNone;
      MyTheme.StyleDwm := DwmTransparent;
    end;
    if rbBlur.Checked then
      MyTheme.StyleDwm := DwmBlur;
  end;

  if ((not cbDWM.Enabled) and cbDWM.Checked) then
    cbDWM.Checked := false;

  if (not cbDWM.Checked) then
    MyTheme.StyleDwm := DwmNone;
end;

procedure TfrmMain.FormCreate(Sender: TObject);
begin
  MyTheme := kzTheme.Create(Self);
  MyTheme.OnColorSetChanged := ColorSetChanged;
  rbWallpaper.Enabled := MyTheme.HasWallpaper;
  MyTheme.FormUpdate := True;
  MyTheme.StyleTheme := ThemeDarkLight;
  cbDWM.Enabled := MyTheme.HasDwm;
end;

procedure TfrmMain.FormDestroy(Sender: TObject);
begin
  MyTheme.Free;
end;

procedure TfrmMain.Image1Click(Sender: TObject);
const
 cURL = 'https://www.delphipraxis.net/207862-kodezwergs-real-theme-beispiel.html';
begin
  ShellExecute(Handle, 'OPEN', PChar(cURL), nil, nil, SW_SHOWNORMAL);
end;

procedure TfrmMain.Image1MouseEnter(Sender: TObject);
begin
  Cursor := crHandPoint;
end;

procedure TfrmMain.Image1MouseLeave(Sender: TObject);
begin
  Cursor := crDefault;
end;

procedure TfrmMain.ColorSetChanged(Sender: TObject);
begin
  rbWallpaper.Enabled := MyTheme.HasWallpaper;
  cbDWM.Enabled := MyTheme.HasDwm;
  if cbDWM.Checked then
  begin
    if rbTransparent.Checked then
    begin
      MyTheme.StyleDwm := DwmNone;
      MyTheme.StyleDwm := DwmTransparent;
    end;
    if rbBlur.Checked then
      MyTheme.StyleDwm := DwmBlur;
  end;
  if ((not cbDWM.Enabled) and (cbDWM.Checked)) then
  begin
    cbDWM.Checked := false;
    MyTheme.StyleDwm := DwmNone;
  end;
  if ((not rbWallpaper.Enabled) and (rbWallpaper.Checked)) then
  begin
    rbWallpaper.Checked := false;
    rbOS.Checked := True;
  end;
  if rbSystem.Checked then
    MyTheme.StyleTheme := ThemeSystem;
  if rbOS.Checked then
    MyTheme.StyleTheme := ThemeDarkLight;
  if rbWallpaper.Checked then
    MyTheme.StyleTheme := ThemeWallpaper;
end;

end.

kzTheme Class:

Delphi-Quellcode:

// 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.

Viel Spass damit und LG vom KodeZwerg!

Die Bilder im Anhang sind nicht mehr ganz aktuell, aber dennoch verdeutlichen sie mein Vorhaben.

[Der schöne Günther]

Zitat:

// disable runtime themes at manifest,

Ich glaube das wäre für mich ein ziemlicher Showstopper. Da sieht doch alles aus wie Windows 2000 (wie in deinen Screenshots) und eine Menge Optik-Spielereien funktionieren gar nicht.

[TiGü]

Du musst noch den Fall abfangen, das jemand einfarbige Hintergründe gesetzt hat.

Zum Weiterlesen:
https://stackoverflow.com/questions/...dows-wallpaper

[dummzeuch]

Ohne jetzt das Programm schlechtreden zu wollen:
Ich frage mich, was einem diese Immersive Colors bringen. Es ist eine nette Spielerei, aber hat es einen praktischen Nutzen?

[Der schöne Günther]

Ich finde es angenehm wenn sich eine Oberfläche eher dem Bereich der Farbpalette bedient der mir gefällt.

Einen knallharten praktischen Nutzen der mich 20 Minuten früher Feierabend machen lässt ist da sicher nicht drin, aber ist doch schön.

[KodeZwerg]

Zitat von Der schöne Günther:

Zitat:

// disable runtime themes at manifest,

Ich glaube das wäre für mich ein ziemlicher Showstopper. Da sieht doch alles aus wie Windows 2000 (wie in deinen Screenshots) und eine Menge Optik-Spielereien funktionieren gar nicht.

Ich benötige bald eh eine Neue Brille, wenn ich nur die Dark/Light nutze, fallen mir gegenüber der manifest themed variante nicht so viele Dinge auf, mich hat es nur ein wenig verwundert das obwohl ich Ctl3D deaktiviert habe der immer noch so ein "Emboss/Stamp" malt.

Zitat von dummzeuch:

Ohne jetzt das Programm schlechtreden zu wollen:
Ich frage mich, was einem diese Immersive Colors bringen. Es ist eine nette Spielerei, aber hat es einen praktischen Nutzen?

Für mich halt, das ich mich an Windows halte, mehr nicht. Viele Applikationen arbeiten so, das wenn Windows dunkel ist, ist deren UI es auch.
Man kann ja auch die Delphi styles nutzen und zwei passende hinterlegen, IsDarkTheme nutzen um die unterscheiden zu können.

Zitat von TiGü:

Du musst noch den Fall abfangen, das jemand einfarbige Hintergründe gesetzt hat.
Zum Weiterlesen:
https://stackoverflow.com/questions/...dows-wallpaper

Das ist bereits enthalten (Desktop-Themed). Oder ich verstehe dich gerade fasch?

[venice2]

Zitat:

Ich frage mich, was einem diese Immersive Colors bringen.

Fast nichts!

Weil diverse Controls von Windows behandelt werden sobald die Themes eingeschaltet sind.
Siehe Radio Buttons, Tooltips und Diverser anderer Kram.

Man muß also wieder OwnerDrawn damit die Farbe dem Dark Mode oder was auch immer angepaßt werden kann.

Zitat:

Das ist bereits enthalten (Desktop-Themed). Oder ich verstehe dich gerade fasch?

Du prüfst auf GetWallpaperFilename (Wallpaper ist eigentlich immer da) aber man kann den Hintergrund auch einfarbig schalten.
Wenn dieser einfarbig ist benötigst du die Prüfung auf GetAverageColor nicht mehr.

[KodeZwerg]

Zitat von venice2:

Zitat:

Das ist bereits enthalten (Desktop-Themed). Oder ich verstehe dich gerade fasch?

Du prüfst auf GetWallpaperFilename (Wallpaper ist eigentlich immer da) aber man kann den Hintergrund auch einfarbig schalten.
Wenn dieser einfarbig ist benötigst du die Prüfung auf GetAverageColor nicht mehr.

Schau mal bitte das Bild im Anhang an, vielleicht reden wir ja auch an einander vorbei, wenn man bei diesem Setting von Bild -> Volltonfarbe geht, da passiert etwas in meinem Programm.
Der RadioButton ist deaktiviert weil ab diesem moment "GetWallpaperFilename" leer ist, muss noch mehr geprüft werden?
Ich habe vielleicht echt gerade Tomaten auf den Augen und finde besagte Zeile nicht die da noch aktiv sein soll.

Ps: Da mir das spielen mit Delphi und Windows Theme so viel Spass bereitet, arbeite ich an einer "Glas-Methode"

[venice2]

Zitat:

Der RadioButton ist deaktiviert weil ab diesem moment "GetWallpaperFilename" leer ist, muss noch mehr geprüft werden?

Habe dein Prog nicht geladen oder getestet und bin davon ausgegangen das immer ein Wallpaper (Pfad dazu) existiert egal ob du diesen ausgewählt hast oder nicht.
Wenn es so ist wie du sagst erübrigt sich die zusätzliche Abfrage aus der Registry natürlich. (Vorausgesetzt du benötigst die Farbe für die VollTonFarbe nicht)

Zitat:

Du musst noch den Fall abfangen, das jemand einfarbige Hintergründe gesetzt hat.

Ist dann nicht nötig.

EDIT:
Habe es so verstanden wenn Wallpaper verwendet wird setzt du den Mittelwert der Farbe davon.
Welchen wert setzt du nun bei der Volltonfarbe? (Denke das ist was @Tigü meint). Den Bekommst du nur aus der registry
Der Pfad fehlt definitiv in deinem Code (HKEY_CURRENT_USER\Control Panel\Colors\Background)

[KodeZwerg]

Zitat von venice2:

Zitat:

Der RadioButton ist deaktiviert weil ab diesem moment "GetWallpaperFilename" leer ist, muss noch mehr geprüft werden?

Habe dein Prog nicht geladen oder getestet und bin davon ausgegangen das immer ein Wallpaper (Pfad dazu) existiert egal ob du diesen ausgewählt hast oder nicht.
Wenn es so ist wie du sagst erübrigt sich die zusätzliche Abfrage aus der Registry natürlich. (Vorausgesetzt du benötigst die Farbe für die VollTonFarbe nicht)

Zitat:

Du musst noch den Fall abfangen, das jemand einfarbige Hintergründe gesetzt hat.

Ist dann nicht nötig.

Die Volltonfarbe wird für "Desktop-Theme" verwendet
Aber gut das das geklärt ist. Definitiv Danke das Du es angesprochen hast!