|
![]() |
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 ![]() - 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:
kzTheme Class:
// 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.
Delphi-Quellcode:
Viel Spass damit und LG vom KodeZwerg!
// 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. Die Bilder im Anhang sind nicht mehr ganz aktuell, aber dennoch verdeutlichen sie mein Vorhaben.
Gruß vom
![]() Geändert von KodeZwerg (13. Mai 2021 um 11:46 Uhr) Grund: update V3 |
Delphi 11 Alexandria |
#12
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\Desktop\Wallpaper)
Delphi-Quellcode:
//edit
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; und kaum poste ich es, fällt mir ein fehler auf, danke fürs fragen! Geändert von KodeZwerg (10. Mai 2021 um 17:50 Uhr) |
![]() |
venice2
|
#13
FBackgroundColor := GetSysColor(COLOR_DESKTOP); <<<--- diesen hier = Volltonfarbe
Ok erklärt alles. Sollte das gleiche wie der Wert aus der Registry sein (hoffe ich mal) ![]() ![]() Der Pfad fehlt definitiv in deinem Code (HKEY_CURRENT_USER\Control Panel\Desktop\Wallpaper)
![]() und kaum poste ich es, fällt mir ein fehler auf, danke fürs fragen!
FTextColor := InvertColor(GetSysColor(COLOR_DESKTOP)); // FTextColor := InvertColor(FBackgroundColor); Na dann weiter viel Spaß. Geändert von venice2 (10. Mai 2021 um 18:25 Uhr) |
![]() |
Delphi 11 Alexandria |
#14
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. ![]() Na dann weiter viel Spaß.
Geändert von KodeZwerg (10. Mai 2021 um 18:08 Uhr) |
![]() |
venice2
|
#15
![]() ![]() ![]() oder für Glass. ![]() DwmGetColorizationColor oder schau mal unter HKCU\SOFTWARE\Microsoft\Windows\DWM, ColorizationColor ![]() "FTextColor" ist die Font-Farbe bei mir, falls das noch unklar sein sollte.
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. Geändert von venice2 (10. Mai 2021 um 18:45 Uhr) |
![]() |
Delphi 11 Alexandria |
#16
Super
![]() ![]() Dankeschön, werde ich alle mal durchtesten, meine Anwendung übernimmt ja sofort bei einer Änderung die Werte. ![]() //edit ![]() Ich sehe nur eins.
Geändert von KodeZwerg (10. Mai 2021 um 18:32 Uhr) |
![]() |
Delphi 11 Alexandria |
#17
![]() "FTextColor" ist die Font-Farbe bei mir, falls das noch unklar sein sollte.
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.
Delphi-Quellcode:
SimpleInvertColor = endet in schwarz oder weiß und hat probleme mit grau werten
FTextColor := SimpleInvertColor(FBackgroundColor);
FTextColor := InvertColor(FBackgroundColor); InvertColor = führt eine extrem schwierige kalkulation durch lol (und hat auch so seine probleme) Danke für Deine "Link" nachträge!!! Geändert von KodeZwerg (10. Mai 2021 um 19:02 Uhr) |
![]() |
venice2
|
#18
![]() Der Unterschied liegt in den Methoden die da aufgerufen werden. :-]
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 ![]() |
![]() |
Delphi 11 Alexandria |
#19
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); Genau das wars! hehehe
OK! Bin raus
![]() |
![]() |
Ansicht |
![]() |
![]() |
![]() |
ForumregelnEs ist dir nicht erlaubt, neue Themen zu verfassen.
Es ist dir nicht erlaubt, auf Beiträge zu antworten.
Es ist dir nicht erlaubt, Anhänge hochzuladen.
Es ist dir nicht erlaubt, deine Beiträge zu bearbeiten.
BB-Code ist an.
Smileys sind an.
[IMG] Code ist an.
HTML-Code ist aus. Trackbacks are an
Pingbacks are an
Refbacks are aus
|
|
Nützliche Links |
Heutige Beiträge |
Sitemap |
Suchen |
Code-Library |
Wer ist online |
Alle Foren als gelesen markieren |
Gehe zu... |
LinkBack |
![]() |
![]() |