Difference between revisions of "Aero Glass"
Jwdietrich (talk | contribs) (Platform template added.) |
|||
(6 intermediate revisions by 4 users not shown) | |||
Line 1: | Line 1: | ||
− | {{Platform only|Windows|Windows| | + | {{Platform only|Windows|Windows|Windows}} |
{{Aero Glass}} | {{Aero Glass}} | ||
Line 8: | Line 8: | ||
First save the above code to a text file "glass.pas": | First save the above code to a text file "glass.pas": | ||
− | <syntaxhighlight>unit glass; | + | <syntaxhighlight lang=pascal>unit glass; |
{$mode delphi} | {$mode delphi} | ||
Line 115: | Line 115: | ||
In the "uses" section of your project you need to add "glass": | In the "uses" section of your project you need to add "glass": | ||
− | <syntaxhighlight>unit form1; | + | <syntaxhighlight lang=pascal>unit form1; |
{$mode objfpc}{$H+} | {$mode objfpc}{$H+} | ||
Line 127: | Line 127: | ||
OnActivate event of each form call the procedure in this way: | OnActivate event of each form call the procedure in this way: | ||
− | <syntaxhighlight>procedure TForm1.FormActivate(Sender: TObject); | + | <syntaxhighlight lang=pascal>procedure TForm1.FormActivate(Sender: TObject); |
var | var | ||
tmpMargins: TMargins; | tmpMargins: TMargins; | ||
Line 137: | Line 137: | ||
tmpMargins.cyTopHeight := -1; | tmpMargins.cyTopHeight := -1; | ||
{ FormName ; Margins ; TransparentColor } | { FormName ; Margins ; TransparentColor } | ||
− | GlassForm( | + | GlassForm(Self, tmpMargins, clFuchsia); |
end;</syntaxhighlight> | end;</syntaxhighlight> | ||
Also you need to enable Themes to use this procedure, go to Options > Project Options > then select "Use Manifest to Enable Themes (Windows)". | Also you need to enable Themes to use this procedure, go to Options > Project Options > then select "Use Manifest to Enable Themes (Windows)". | ||
+ | |||
+ | == Windows 10 == | ||
+ | |||
+ | [[Image:aeroglasswin10.png]] | ||
+ | |||
+ | <syntaxhighlight lang=pascal> | ||
+ | { | ||
+ | author: vhanla | ||
+ | http://vhanla.codigobit.info | ||
+ | } | ||
+ | unit Unit1; | ||
+ | |||
+ | interface | ||
+ | |||
+ | uses | ||
+ | Windows, Messages, SysUtils, Variants, Classes, Graphics, | ||
+ | Controls, Forms, Dialogs, DWMApi, png, IntfGraphics, FPImage, GraphType, | ||
+ | StdCtrls, ExtCtrls, BCButtonFocus, BCLabel, Registry, LMessages, LCLType, LCLIntf; | ||
+ | |||
+ | type | ||
+ | |||
+ | { TForm1 } | ||
+ | |||
+ | TForm1 = class(TForm) | ||
+ | BCButtonFocus1: TBCButtonFocus; | ||
+ | BCLabel1: TBCLabel; | ||
+ | Image1: TImage; | ||
+ | Image2: TImage; | ||
+ | Panel1: TPanel; | ||
+ | |||
+ | procedure BCButtonFocus1Click(Sender: TObject); | ||
+ | procedure FormCreate(Sender: TObject); | ||
+ | procedure Button1Click(Sender: TObject); | ||
+ | procedure Panel1MouseDown(Sender: TObject; Button: TMouseButton; | ||
+ | Shift: TShiftState; X, Y: Integer); | ||
+ | private | ||
+ | { Private declarations } | ||
+ | function TaskbarAccented:boolean; | ||
+ | function TaskbarTranslucent:boolean; | ||
+ | procedure EnableBlur; | ||
+ | procedure AeroGlass; | ||
+ | procedure UpdateColorization; | ||
+ | function GetAccentColor:TColor; | ||
+ | public | ||
+ | { Public declarations } | ||
+ | end; | ||
+ | |||
+ | AccentPolicy = packed record | ||
+ | AccentState: Integer; | ||
+ | AccentFlags: Integer; | ||
+ | GradientColor: Integer; | ||
+ | AnimationId: Integer; | ||
+ | end; | ||
+ | |||
+ | TWinCompAttrData = packed record | ||
+ | attribute: THandle; | ||
+ | pData: Pointer; | ||
+ | dataSize: ULONG; | ||
+ | end; | ||
+ | |||
+ | |||
+ | var | ||
+ | Form1: TForm1; | ||
+ | |||
+ | var | ||
+ | SetWindowCompositionAttribute: function (Wnd: HWND; const AttrData: TWinCompAttrData): BOOL; stdcall = Nil; | ||
+ | implementation | ||
+ | |||
+ | {$R *.lfm} | ||
+ | |||
+ | procedure SetAlphaColorPicture( | ||
+ | const Col: TColor; | ||
+ | const Alpha: Integer; | ||
+ | Picture: TPicture; | ||
+ | const _width: Integer; | ||
+ | const _height: Integer | ||
+ | ); | ||
+ | var | ||
+ | IM: TLazIntfImage; | ||
+ | x,y: integer; | ||
+ | sl: pByteArray; | ||
+ | I, J, W, H: Integer; | ||
+ | FC: TFPColor; | ||
+ | begin | ||
+ | IM := TLazIntfImage.Create(0, 0, [riqfRGB, riqfAlpha]); | ||
+ | try | ||
+ | IM.SetSize(_width, _height); | ||
+ | for I := 0 to _width - 1 do | ||
+ | begin | ||
+ | for J := 0 to _height - 1 do | ||
+ | begin | ||
+ | FC.red := (128 + I) shl 8; | ||
+ | FC.green := (128 + J) shl 8; | ||
+ | FC.blue := 128 shl 8; | ||
+ | FC.alpha := 128 shl 8; // now works fine | ||
+ | IM.Colors[I, J] := FC; | ||
+ | end; | ||
+ | end; | ||
+ | Picture.Assign(IM); | ||
+ | |||
+ | |||
+ | finally | ||
+ | IM.Free; | ||
+ | |||
+ | end; | ||
+ | end; | ||
+ | |||
+ | procedure TForm1.Button1Click(Sender: TObject); | ||
+ | begin | ||
+ | Close; | ||
+ | end; | ||
+ | |||
+ | procedure TForm1.Panel1MouseDown(Sender: TObject; Button: TMouseButton; | ||
+ | Shift: TShiftState; X, Y: Integer); | ||
+ | begin | ||
+ | ReleaseCapture; | ||
+ | SendMessage(Form1.Handle, LM_SYSCOMMAND, 61458, 0) ; | ||
+ | end; | ||
+ | |||
+ | procedure TForm1.AeroGlass; | ||
+ | var | ||
+ | Aero: BOOL; | ||
+ | Area: TRect; | ||
+ | hDWM: THandle; | ||
+ | begin | ||
+ | hDWM:=LoadLibrary('dwmapi.dll'); | ||
+ | try | ||
+ | @DwmIsCompositionEnabled:=GetProcAddress(hDWM,'DwmIsCompositionEnabled'); | ||
+ | if @DwmIsCompositionEnabled<>nil then | ||
+ | DwmIsCompositionEnabled(Aero); | ||
+ | if Aero then | ||
+ | begin | ||
+ | Area:=Rect(-1,-1,-1,-1); | ||
+ | Color:=clBlack; | ||
+ | @DwmExtendFrameIntoClientArea:=GetProcAddress(hDWM,'DwmExtendFrameIntoClientArea'); | ||
+ | if @DwmExtendFrameIntoClientArea<>nil then | ||
+ | DwmExtendFrameIntoClientArea(Handle,@Area); | ||
+ | |||
+ | end | ||
+ | else ShowMessage('Aero is Disabled'); | ||
+ | finally | ||
+ | FreeLibrary(hDWM); | ||
+ | end; | ||
+ | end; | ||
+ | |||
+ | procedure TForm1.EnableBlur; | ||
+ | const | ||
+ | WCA_ACCENT_POLICY = 19; | ||
+ | ACCENT_ENABLE_BLURBEHIND = 3; | ||
+ | ACCENT_ENABLE_ACRYLICBLURBEHIND = 4; | ||
+ | DrawLeftBorder = $20; | ||
+ | DrawTopBorder = $40; | ||
+ | DrawRightBorder = $80; | ||
+ | DrawBottomBorder = $100; | ||
+ | var | ||
+ | dwm10: THandle; | ||
+ | data : TWinCompAttrData; | ||
+ | accent: AccentPolicy; | ||
+ | begin | ||
+ | |||
+ | dwm10 := LoadLibrary('user32.dll'); | ||
+ | try | ||
+ | @SetWindowCompositionAttribute := GetProcAddress(dwm10, 'SetWindowCompositionAttribute'); | ||
+ | if @SetWindowCompositionAttribute <> nil then | ||
+ | begin | ||
+ | accent.AccentState := ACCENT_ENABLE_BLURBEHIND ; | ||
+ | //accent.AccentState := ACCENT_ENABLE_ACRYLICBLURBEHIND; | ||
+ | accent.GradientColor := (100 SHL 24) or ($00E3E0DE); | ||
+ | accent.AccentFlags := DrawLeftBorder or DrawTopBorder or DrawRightBorder or DrawBottomBorder; | ||
+ | |||
+ | data.Attribute := WCA_ACCENT_POLICY; | ||
+ | data.dataSize := SizeOf(accent); | ||
+ | data.pData := @accent; | ||
+ | SetWindowCompositionAttribute(self.Handle, data); | ||
+ | end | ||
+ | else | ||
+ | begin | ||
+ | ShowMessage('Not found Windows 10 blur API'); | ||
+ | end; | ||
+ | finally | ||
+ | FreeLibrary(dwm10); | ||
+ | end; | ||
+ | |||
+ | end; | ||
+ | |||
+ | procedure TForm1.FormCreate(Sender: TObject); | ||
+ | begin | ||
+ | DoubleBuffered := True; | ||
+ | Color := clBlack; | ||
+ | BorderStyle := bsnoNe; | ||
+ | BorderIcons := [biSystemMenu, biMinimize, biMaximize]; | ||
+ | //AeroGlass; | ||
+ | if TaskbarTranslucent then | ||
+ | EnableBlur; | ||
+ | |||
+ | UpdateColorization; | ||
+ | end; | ||
+ | |||
+ | procedure TForm1.BCButtonFocus1Click(Sender: TObject); | ||
+ | begin | ||
+ | close; | ||
+ | end; | ||
+ | |||
+ | function TForm1.TaskbarAccented: 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('ColorPrevalence') = 1 then | ||
+ | Result := True; | ||
+ | except | ||
+ | Result := False; | ||
+ | end; | ||
+ | reg.CloseKey; | ||
+ | |||
+ | finally | ||
+ | reg.Free; | ||
+ | end; | ||
+ | end; | ||
+ | |||
+ | function TForm1.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 TForm1.UpdateColorization; | ||
+ | begin | ||
+ | if TaskbarTranslucent then | ||
+ | begin | ||
+ | SetAlphaColorPicture(clblack, 200, Image1.Picture, 10,10 ); | ||
+ | Image1.Align := alClient; | ||
+ | Image1.Stretch := True; | ||
+ | Image1.Visible := True; | ||
+ | end | ||
+ | else | ||
+ | Image1.Visible := False; | ||
+ | |||
+ | if TaskbarAccented then | ||
+ | begin | ||
+ | SetAlphaColorPicture(9338482, 110, Image2.Picture, 10, 10); | ||
+ | Image2.Visible := True; | ||
+ | Image2.Align := alClient; | ||
+ | Image2.Stretch := True; | ||
+ | end | ||
+ | else | ||
+ | Image2.Visible := False; | ||
+ | end; | ||
+ | |||
+ | function TForm1.GetAccentColor:TColor; | ||
+ | var | ||
+ | col: cardinal; | ||
+ | opaque: longbool; | ||
+ | newcolor: TColor; | ||
+ | a,r,g,b: byte; | ||
+ | begin | ||
+ | DwmGetColorizationColor(col, opaque); | ||
+ | a := Byte(col shr 24); | ||
+ | r := Byte(col shr 16); | ||
+ | g := Byte(col shr 8); | ||
+ | b := Byte(col); | ||
+ | |||
+ | |||
+ | newcolor := RGB( | ||
+ | round(r*(a/255)+255-a), | ||
+ | round(g*(a/255)+255-a), | ||
+ | round(b*(a/255)+255-a) | ||
+ | ); | ||
+ | |||
+ | Result := newcolor; | ||
+ | |||
+ | |||
+ | end; | ||
+ | |||
+ | |||
+ | initialization | ||
+ | SetWindowCompositionAttribute := GetProcAddress(GetModuleHandle(user32), 'SetWindowCompositionAttribute'); | ||
+ | end. | ||
+ | </syntaxhighlight> | ||
== Bugs == | == Bugs == |
Latest revision as of 01:53, 25 June 2020
This article applies to Windows only.
See also: Multiplatform Programming Guide
│
Deutsch (de) │
English (en) │
español (es) │
polski (pl) │
Aero Glass effect on Lazarus Form
First save the above code to a text file "glass.pas":
unit glass;
{$mode delphi}
//{$mode objfpc}{$H+}
interface
uses
Windows, Forms, Graphics;
type
_MARGINS = packed record
cxLeftWidth : Integer;
cxRightWidth : Integer;
cyTopHeight : Integer;
cyBottomHeight : Integer;
end;
PMargins = ^_MARGINS;
TMargins = _MARGINS;
DwmIsCompositionEnabledFunc = function(pfEnabled: PBoolean): HRESULT; stdcall;
DwmExtendFrameIntoClientAreaFunc = function(destWnd: HWND; const pMarInset: PMargins): HRESULT; stdcall;
SetLayeredWindowAttributesFunc = function(destWnd: HWND; cKey: TColor; bAlpha: Byte; dwFlags: DWord): BOOL; stdcall;
const
WS_EX_LAYERED = $80000;
LWA_COLORKEY = 1;
procedure GlassForm(frm: TForm; tmpMargins: TMargins; cBlurColorKey: TColor = clFuchsia);
function WindowsAeroGlassCompatible: Boolean;
implementation
function WindowsAeroGlassCompatible: Boolean;
var
osVinfo: TOSVERSIONINFO;
begin
ZeroMemory(@osVinfo, SizeOf(osVinfo));
OsVinfo.dwOSVersionInfoSize := SizeOf(TOSVERSIONINFO);
if (
(GetVersionEx(osVInfo) = True) and
(osVinfo.dwPlatformId = VER_PLATFORM_WIN32_NT) and
(osVinfo.dwMajorVersion >= 6)
)
then Result:=True
else Result:=False;
end;
procedure GlassForm(frm: TForm; tmpMargins: TMargins; cBlurColorKey: TColor = clFuchsia);
var
hDwmDLL: Cardinal;
fDwmIsCompositionEnabled: DwmIsCompositionEnabledFunc;
fDwmExtendFrameIntoClientArea: DwmExtendFrameIntoClientAreaFunc;
fSetLayeredWindowAttributesFunc: SetLayeredWindowAttributesFunc;
bCmpEnable: Boolean;
mgn: TMargins;
begin
{ Continue if Windows version is compatible }
if WindowsAeroGlassCompatible then begin
{ Continue if 'dwmapi' library is loaded }
hDwmDLL := LoadLibrary('dwmapi.dll');
if hDwmDLL <> 0 then begin
{ Get values }
@fDwmIsCompositionEnabled := GetProcAddress(hDwmDLL, 'DwmIsCompositionEnabled');
@fDwmExtendFrameIntoClientArea := GetProcAddress(hDwmDLL, 'DwmExtendFrameIntoClientArea');
@fSetLayeredWindowAttributesFunc := GetProcAddress(GetModulehandle(user32), 'SetLayeredWindowAttributes');
{ Continue if values are <> nil }
if (
(@fDwmIsCompositionEnabled <> nil) and
(@fDwmExtendFrameIntoClientArea <> nil) and
(@fSetLayeredWindowAttributesFunc <> nil)
)
then begin
{ Continue if composition is enabled }
fDwmIsCompositionEnabled(@bCmpEnable);
if bCmpEnable = True then begin
{ Set Form Color same as cBlurColorKey }
frm.Color := cBlurColorKey;
{ ... }
SetWindowLong(frm.Handle, GWL_EXSTYLE, GetWindowLong(frm.Handle, GWL_EXSTYLE) or WS_EX_LAYERED);
{ ... }
fSetLayeredWindowAttributesFunc(frm.Handle, cBlurColorKey, 0, LWA_COLORKEY);
{ Set margins }
ZeroMemory(@mgn, SizeOf(mgn));
mgn.cxLeftWidth := tmpMargins.cxLeftWidth;
mgn.cxRightWidth := tmpMargins.cxRightWidth;
mgn.cyTopHeight := tmpMargins.cyTopHeight;
mgn.cyBottomHeight := tmpMargins.cyBottomHeight;
{ Extend Form }
fDwmExtendFrameIntoClientArea(frm.Handle,@mgn);
end;
end;
{ Free loaded 'dwmapi' library }
FreeLibrary(hDWMDLL);
end;
end;
end;
end.
Copy the "glass.pas" file to the main folder of your project:
MyProject\glass.pas
In the "uses" section of your project you need to add "glass":
unit form1;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs
glass; // This includes GlassForm procedure
OnActivate event of each form call the procedure in this way:
procedure TForm1.FormActivate(Sender: TObject);
var
tmpMargins: TMargins;
begin
{ If all margins are -1 the whole form will be aero glass}
tmpMargins.cxLeftWidth := -1;
tmpMargins.cxRightWidth := -1;
tmpMargins.cyBottomHeight := -1;
tmpMargins.cyTopHeight := -1;
{ FormName ; Margins ; TransparentColor }
GlassForm(Self, tmpMargins, clFuchsia);
end;
Also you need to enable Themes to use this procedure, go to Options > Project Options > then select "Use Manifest to Enable Themes (Windows)".
Windows 10
{
author: vhanla
http://vhanla.codigobit.info
}
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics,
Controls, Forms, Dialogs, DWMApi, png, IntfGraphics, FPImage, GraphType,
StdCtrls, ExtCtrls, BCButtonFocus, BCLabel, Registry, LMessages, LCLType, LCLIntf;
type
{ TForm1 }
TForm1 = class(TForm)
BCButtonFocus1: TBCButtonFocus;
BCLabel1: TBCLabel;
Image1: TImage;
Image2: TImage;
Panel1: TPanel;
procedure BCButtonFocus1Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure Panel1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
private
{ Private declarations }
function TaskbarAccented:boolean;
function TaskbarTranslucent:boolean;
procedure EnableBlur;
procedure AeroGlass;
procedure UpdateColorization;
function GetAccentColor:TColor;
public
{ Public declarations }
end;
AccentPolicy = packed record
AccentState: Integer;
AccentFlags: Integer;
GradientColor: Integer;
AnimationId: Integer;
end;
TWinCompAttrData = packed record
attribute: THandle;
pData: Pointer;
dataSize: ULONG;
end;
var
Form1: TForm1;
var
SetWindowCompositionAttribute: function (Wnd: HWND; const AttrData: TWinCompAttrData): BOOL; stdcall = Nil;
implementation
{$R *.lfm}
procedure SetAlphaColorPicture(
const Col: TColor;
const Alpha: Integer;
Picture: TPicture;
const _width: Integer;
const _height: Integer
);
var
IM: TLazIntfImage;
x,y: integer;
sl: pByteArray;
I, J, W, H: Integer;
FC: TFPColor;
begin
IM := TLazIntfImage.Create(0, 0, [riqfRGB, riqfAlpha]);
try
IM.SetSize(_width, _height);
for I := 0 to _width - 1 do
begin
for J := 0 to _height - 1 do
begin
FC.red := (128 + I) shl 8;
FC.green := (128 + J) shl 8;
FC.blue := 128 shl 8;
FC.alpha := 128 shl 8; // now works fine
IM.Colors[I, J] := FC;
end;
end;
Picture.Assign(IM);
finally
IM.Free;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
Close;
end;
procedure TForm1.Panel1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
ReleaseCapture;
SendMessage(Form1.Handle, LM_SYSCOMMAND, 61458, 0) ;
end;
procedure TForm1.AeroGlass;
var
Aero: BOOL;
Area: TRect;
hDWM: THandle;
begin
hDWM:=LoadLibrary('dwmapi.dll');
try
@DwmIsCompositionEnabled:=GetProcAddress(hDWM,'DwmIsCompositionEnabled');
if @DwmIsCompositionEnabled<>nil then
DwmIsCompositionEnabled(Aero);
if Aero then
begin
Area:=Rect(-1,-1,-1,-1);
Color:=clBlack;
@DwmExtendFrameIntoClientArea:=GetProcAddress(hDWM,'DwmExtendFrameIntoClientArea');
if @DwmExtendFrameIntoClientArea<>nil then
DwmExtendFrameIntoClientArea(Handle,@Area);
end
else ShowMessage('Aero is Disabled');
finally
FreeLibrary(hDWM);
end;
end;
procedure TForm1.EnableBlur;
const
WCA_ACCENT_POLICY = 19;
ACCENT_ENABLE_BLURBEHIND = 3;
ACCENT_ENABLE_ACRYLICBLURBEHIND = 4;
DrawLeftBorder = $20;
DrawTopBorder = $40;
DrawRightBorder = $80;
DrawBottomBorder = $100;
var
dwm10: THandle;
data : TWinCompAttrData;
accent: AccentPolicy;
begin
dwm10 := LoadLibrary('user32.dll');
try
@SetWindowCompositionAttribute := GetProcAddress(dwm10, 'SetWindowCompositionAttribute');
if @SetWindowCompositionAttribute <> nil then
begin
accent.AccentState := ACCENT_ENABLE_BLURBEHIND ;
//accent.AccentState := ACCENT_ENABLE_ACRYLICBLURBEHIND;
accent.GradientColor := (100 SHL 24) or ($00E3E0DE);
accent.AccentFlags := DrawLeftBorder or DrawTopBorder or DrawRightBorder or DrawBottomBorder;
data.Attribute := WCA_ACCENT_POLICY;
data.dataSize := SizeOf(accent);
data.pData := @accent;
SetWindowCompositionAttribute(self.Handle, data);
end
else
begin
ShowMessage('Not found Windows 10 blur API');
end;
finally
FreeLibrary(dwm10);
end;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
DoubleBuffered := True;
Color := clBlack;
BorderStyle := bsnoNe;
BorderIcons := [biSystemMenu, biMinimize, biMaximize];
//AeroGlass;
if TaskbarTranslucent then
EnableBlur;
UpdateColorization;
end;
procedure TForm1.BCButtonFocus1Click(Sender: TObject);
begin
close;
end;
function TForm1.TaskbarAccented: 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('ColorPrevalence') = 1 then
Result := True;
except
Result := False;
end;
reg.CloseKey;
finally
reg.Free;
end;
end;
function TForm1.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 TForm1.UpdateColorization;
begin
if TaskbarTranslucent then
begin
SetAlphaColorPicture(clblack, 200, Image1.Picture, 10,10 );
Image1.Align := alClient;
Image1.Stretch := True;
Image1.Visible := True;
end
else
Image1.Visible := False;
if TaskbarAccented then
begin
SetAlphaColorPicture(9338482, 110, Image2.Picture, 10, 10);
Image2.Visible := True;
Image2.Align := alClient;
Image2.Stretch := True;
end
else
Image2.Visible := False;
end;
function TForm1.GetAccentColor:TColor;
var
col: cardinal;
opaque: longbool;
newcolor: TColor;
a,r,g,b: byte;
begin
DwmGetColorizationColor(col, opaque);
a := Byte(col shr 24);
r := Byte(col shr 16);
g := Byte(col shr 8);
b := Byte(col);
newcolor := RGB(
round(r*(a/255)+255-a),
round(g*(a/255)+255-a),
round(b*(a/255)+255-a)
);
Result := newcolor;
end;
initialization
SetWindowCompositionAttribute := GetProcAddress(GetModuleHandle(user32), 'SetWindowCompositionAttribute');
end.
Bugs
As you can see in the first image Labels aren't displayed fine in Aero Glass, there are links with components and code that show how to make "Glow Labels":
Also if you clic the transparent part of the window the back window / desktop is selected (focus is lost in the form with aero glass).
About
This was converted to Lazarus using "{$mode delphi}" from "Aero Glass Effekt für Delphi-Forms, Delphi-Unit von Daniel Mitte (2006)":
There is a Delphi component here (to be ported in Lazarus):