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.

[venice2]

Siehe Edit!

[KodeZwerg]

Zitat von venice2:

EDIT:
Habe es so verstanden wenn Wallpaper verwendet wird setzt du den Mittelwert der Farbe davon.

Korrekt!

Zitat von venice2:

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\Desktop\Wallpaper)

Delphi-Quellcode:

procedure TfrmMain.ApplyDesktopColors;
begin
  FBackgroundColor := GetSysColor(COLOR_DESKTOP); <<<--- diesen hier = Volltonfarbe
  case cbSimpleFont.Checked of
    True:
      FTextColor := SimpleInvertColor(FBackgroundColor);
    false:
      FTextColor := InvertColor(GetSysColor(COLOR_DESKTOP));
  end;
  UpdateColors;
end;

//edit
und kaum poste ich es, fällt mir ein fehler auf, danke fürs fragen!

[venice2]

FBackgroundColor := GetSysColor(COLOR_DESKTOP); <<<--- diesen hier = Volltonfarbe
Ok erklärt alles. Sollte das gleiche wie der Wert aus der Registry sein (hoffe ich mal)

Zitat:

Der Pfad fehlt definitiv in deinem Code (HKEY_CURRENT_USER\Control Panel\Desktop\Wallpaper)

Den Pfad hatte ich nochmals korrigiert. Sorry (HKEY_CURRENT_USER\Control Panel\Colors\Background)

Zitat:

und kaum poste ich es, fällt mir ein fehler auf, danke fürs fragen!

Ich sehe nur eins.
FTextColor := InvertColor(GetSysColor(COLOR_DESKTOP)); // FTextColor := InvertColor(FBackgroundColor);

Na dann weiter viel Spaß.

[KodeZwerg]

Was mir echt weiterhelfen würde, vielleicht kennst Du ja was, Farbwert für Fonts.... siehst ja mein kläglichen Versuch was brauchbares rauszuholen.
Windows muss doch dafür auch irgendwo was haben, ich fand bis jetzt nichts brauchbares.
GetSysColor() wäre mir da am liebsten, bei Mircosoft gabs auch keine Treffer auf meine Anfragen.

//edit
"FTextColor" ist die Font-Farbe bei mir, falls das noch unklar sein sollte.

Zitat:

Na dann weiter viel Spaß.

Danke, den habe ich, dir auch alles Gute!

[venice2]

GetThemeSysColor (aber keine gewähr das du nicht schwarz bekommst das hängt mit dem hohen Kontrast zusammen)
GetThemeColor.
GetThemeSysColorBrush

oder für Glass.
DwmGetColorizationParameters
DwmGetColorizationColor
oder schau mal unter
HKCU\SOFTWARE\Microsoft\Windows\DWM, ColorizationColor

Zitat:

"FTextColor" ist die Font-Farbe bei mir, falls das noch unklar sein sollte.

Ist klar
Nur wo ist nun der Unterschied zwischen
FTextColor := InvertColor(GetSysColor(COLOR_DESKTOP));
und
FTextColor := InvertColor(FBackgroundColor);
Richtig! Keiner, nur das du die Funktion GetSysColor mit FBackgroundColor schon ermittelt hast.
Also warum dann nochmals.

[KodeZwerg]

Super das es mehr als eins gibt!
Dankeschön, werde ich alle mal durchtesten, meine Anwendung übernimmt ja sofort bei einer Änderung die Werte.


//edit

Zitat:

Ich sehe nur eins.

Genau das wars! hehehe

[KodeZwerg]

Zitat von venice2:

Zitat:

"FTextColor" ist die Font-Farbe bei mir, falls das noch unklar sein sollte.

Ist klar
Nur wo ist nun der Unterschied zwischen
FTextColor := InvertColor(GetSysColor(COLOR_DESKTOP));
und
FTextColor := InvertColor(FBackgroundColor);
Richtig! Keiner, nur das du die Funktion GetSysColor mit FBackgroundColor schon ermittelt hast.
Also warum dann nochmals.

Der Unterschied liegt in den Methoden die da aufgerufen werden. :-]

Delphi-Quellcode:

FTextColor := SimpleInvertColor(FBackgroundColor);
FTextColor := InvertColor(FBackgroundColor);

SimpleInvertColor = endet in schwarz oder weiß und hat probleme mit grau werten
InvertColor = führt eine extrem schwierige kalkulation durch lol (und hat auch so seine probleme)

Danke für Deine "Link" nachträge!!!

[venice2]

Zitat:

Der Unterschied liegt in den Methoden die da aufgerufen werden. :-]

Meinst du das ernst?

Es ging nicht um die Methode (War mir bekannt) sondern darum das du hier eine Funktion doppelt bedienst von der du den Wert zu FBackgroundColor schon ermittelt hattest.
Warum einen Wert nochmals ermitteln den ich schon habe.

OK! Bin raus

[KodeZwerg]

Zitat von KodeZwerg:

und kaum poste ich es, fällt mir ein fehler auf, danke fürs fragen!

Zitat von venice2:

Ich sehe nur eins.
FTextColor := InvertColor(GetSysColor(COLOR_DESKTOP)); // FTextColor := InvertColor(FBackgroundColor);

Zitat von KodeZwerg:

Genau das wars! hehehe

Ich dachte das war bereits durch damit und empfand "Nur wo ist nun der Unterschied zwischen" als ein Vergucker von Dir.

Zitat von venice2:

OK! Bin raus

Ich wollt Dich nicht kränken. Schade!

[KodeZwerg]

Ich glaube die Idee mit "Glas" verwerfe ich mal schnell wieder, hat zwar was lustiges aber so richtig reizt es mich doch nicht. Da müsste ich zu viel anpassen damit es irgendwie ordentlich wirkt, siehe Anhang.